(* Parameter Eps_i "174b78e53fc239e8c2aab4ab5a996a27e3e5741e88070dad186e05fb13f275e5" *)
Parameter Eps_i : (set->prop)->set.
Axiom Eps_i_ax : forall P:set->prop, forall x:set, P x -> P (Eps_i P).
Definition True : prop := forall p:prop, p -> p.
Definition False : prop := forall p:prop, p.
Definition not : prop -> prop := fun A:prop => A -> False.
(* Unicode ~ "00ac" *)
Prefix ~ 700 := not.
Definition and : prop -> prop -> prop := fun A B:prop => forall p:prop, (A -> B -> p) -> p.
(* Unicode /\ "2227" *)
Infix /\ 780 left := and.
Definition or : prop -> prop -> prop := fun A B:prop => forall p:prop, (A -> p) -> (B -> p) -> p.
(* Unicode \/ "2228" *)
Infix \/ 785 left := or.
Definition iff : prop -> prop -> prop := fun A B:prop => and (A -> B) (B -> A).
(* Unicode <-> "2194" *)
Infix <-> 805 := iff.
Section Eq.
Variable A:SType.
Definition eq : A->A->prop := fun x y:A => forall Q:A->A->prop, Q x y -> Q y x.
Definition neq : A->A->prop := fun x y:A => ~ eq x y.
End Eq.
Infix = 502 := eq.
(* Unicode <> "2260" *)
Infix <> 502 := neq.
Section FE.
Variable A B : SType.
Axiom func_ext : forall f g : A -> B , (forall x : A , f x = g x) -> f = g.
End FE.
Section Ex.
Variable A:SType.
Definition ex : (A->prop)->prop := fun Q:A->prop => forall P:prop, (forall x:A, Q x -> P) -> P.
End Ex.
(* Unicode exists "2203" *)
Binder+ exists , := ex.
Axiom prop_ext : forall p q:prop, iff p q -> p = q.
Parameter In:set->set->prop.
Definition Subq : set -> set -> prop := fun A B => forall x :e A, x :e B.
Axiom set_ext : forall X Y:set, X c= Y -> Y c= X -> X = Y.
Axiom In_ind : forall P:set->prop, (forall X:set, (forall x :e X, P x) -> P X) -> forall X:set, P X.
Binder+ exists , := ex; and.
Parameter Empty : set.
Axiom EmptyAx : ~exists x:set, x :e Empty.
(* Unicode Union "22C3" *)
Parameter Union : set->set.
Axiom UnionEq : forall X x, x :e Union X <-> exists Y, x :e Y /\ Y :e X.
(* Unicode Power "1D4AB" *)
Parameter Power : set->set.
Axiom PowerEq : forall X Y:set, Y :e Power X <-> Y c= X.
Parameter Repl : set -> (set -> set) -> set.
Notation Repl Repl.
Axiom ReplEq : forall A:set, forall F:set->set, forall y:set, y :e {F x|x :e A} <-> exists x :e A, y = F x.
Definition TransSet : set->prop := fun U:set => forall x :e U, x c= U.
Definition Union_closed : set->prop := fun U:set => forall X:set, X :e U -> Union X :e U.
Definition Power_closed : set->prop := fun U:set => forall X:set, X :e U -> Power X :e U.
Definition Repl_closed : set->prop := fun U:set => forall X:set, X :e U -> forall F:set->set,
   (forall x:set, x :e X -> F x :e U) -> {F x|x :e X} :e U.
Definition ZF_closed : set->prop := fun U:set =>
   Union_closed U
/\ Power_closed U
/\ Repl_closed U.
Parameter UnivOf : set->set.
Axiom UnivOf_In : forall N:set, N :e UnivOf N.
Axiom UnivOf_TransSet : forall N:set, TransSet (UnivOf N).
Axiom UnivOf_ZF_closed : forall N:set, ZF_closed (UnivOf N).
Axiom UnivOf_Min : forall N U:set, N :e U
  -> TransSet U
  -> ZF_closed U
  -> UnivOf N c= U.

Theorem andI : forall (A B : prop), A -> B -> A /\ B.
exact (fun A B a b P H => H a b).
Qed.

Theorem orIL : forall (A B : prop), A -> A \/ B.
exact (fun A B a P H1 H2 => H1 a).
Qed.

Theorem orIR : forall (A B : prop), B -> A \/ B.
exact (fun A B b P H1 H2 => H2 b).
Qed.

Theorem iffI : forall A B:prop, (A -> B) -> (B -> A) -> (A <-> B).
exact (fun A B => andI (A -> B) (B -> A)).
Qed.

Theorem pred_ext : forall P Q:set -> prop, (forall x, P x <-> Q x) -> P = Q.
let P Q. assume H1. apply func_ext set prop.
let x. apply prop_ext.
prove P x <-> Q x. exact H1 x.
Qed.

Definition nIn : set->set->prop :=
fun x X => ~In x X.
(* Unicode /:e "2209" *)
Infix /:e 502 := nIn.

Theorem EmptyE : forall x:set, x /:e Empty.
let x. assume H.
apply EmptyAx.
witness x. exact H.
Qed.

Theorem PowerI : forall X Y:set, Y c= X -> Y :e Power X.
let X Y. apply PowerEq X Y. exact (fun _ H => H).
Qed.

Theorem Subq_Empty : forall X:set, Empty c= X.
exact (fun (X x : set) (H : x :e Empty) => EmptyE x H (x :e X)).
Qed.

Theorem Empty_In_Power : forall X:set, Empty :e Power X.
exact (fun X : set => PowerI X Empty (Subq_Empty X)).
Qed.


Theorem xm : forall P:prop, P \/ ~P.
let P:prop.
set p1 := fun x : set => x = Empty \/ P.
set p2 := fun x : set => x <> Empty \/ P.
claim L1:p1 Empty.
{ prove (Empty = Empty \/ P). apply orIL. exact (fun q H => H). }
claim L2: (Eps_i p1) = Empty \/ P.
{ exact (Eps_i_ax p1 Empty L1). }
claim L3:p2 (Power Empty).
{ prove ~(Power Empty = Empty) \/ P. apply orIL.
  assume H1: Power Empty = Empty.
  apply EmptyE Empty.
  prove Empty :e Empty.
  rewrite <- H1 at 2. apply Empty_In_Power.
}
claim L4: Eps_i p2 <> Empty \/ P.
{ exact (Eps_i_ax p2 (Power Empty) L3). }
apply L2.
- assume H1: Eps_i p1 = Empty.
  apply L4.
  + assume H2: Eps_i p2 <> Empty.
    prove P \/ ~ P.
    apply orIR.
    prove ~ P.
    assume H3 : P.
    claim L5:p1 = p2.
    { apply pred_ext. let x. apply iffI.
      - assume H4.
        prove (~(x = Empty) \/ P).
        apply orIR.
        prove P.
        exact H3.
      - assume H4.
        prove (x = Empty \/ P).
        apply orIR.
        prove P.
        exact H3.
    }
    apply H2. rewrite <- L5. exact H1.
  + assume H2:P.
    prove P \/ ~ P.
    apply orIL.
    prove P.
    exact H2.
- assume H1:P.
    prove P \/ ~ P.
    apply orIL.
    prove P.
    exact H1.
Qed.

Theorem FalseE : False -> forall p:prop, p.
exact (fun H => H).
Qed.

Theorem andEL : forall (A B : prop), A /\ B -> A.
exact (fun A B H => H A (fun a b => a)).
Qed.

Theorem andER : forall (A B : prop), A /\ B -> B.
exact (fun A B H => H B (fun a b => b)).
Qed.

Section PropN.
Variable P1 P2 P3:prop.

Theorem and3I : P1 -> P2 -> P3 -> P1 /\ P2 /\ P3.
exact (fun H1 H2 H3 => andI (P1 /\ P2) P3 (andI P1 P2 H1 H2) H3).
Qed.

Theorem and3E : P1 /\ P2 /\ P3 -> (forall p:prop, (P1 -> P2 -> P3 -> p) -> p).
exact (fun u p H => u p (fun u u3 => u p (fun u1 u2 => H u1 u2 u3))).
Qed.

Theorem or3I1 : P1 -> P1 \/ P2 \/ P3.
exact (fun u => orIL (P1 \/ P2) P3 (orIL P1 P2 u)).
Qed.

Theorem or3I2 : P2 -> P1 \/ P2 \/ P3.
exact (fun u => orIL (P1 \/ P2) P3 (orIR P1 P2 u)).
Qed.

Theorem or3I3 : P3 -> P1 \/ P2 \/ P3.
exact (orIR (P1 \/ P2) P3).
Qed.

Theorem or3E : P1 \/ P2 \/ P3 -> (forall p:prop, (P1 -> p) -> (P2 -> p) -> (P3 -> p) -> p).
exact (fun u p H1 H2 H3 => u p (fun u => u p H1 H2) H3).
Qed.

Variable P4:prop.

Theorem and4I : P1 -> P2 -> P3 -> P4 -> P1 /\ P2 /\ P3 /\ P4.
exact (fun H1 H2 H3 H4 => andI (P1 /\ P2 /\ P3) P4 (and3I H1 H2 H3) H4).
Qed.

Variable P5:prop.

Theorem and5I : P1 -> P2 -> P3 -> P4 -> P5 -> P1 /\ P2 /\ P3 /\ P4 /\ P5.
exact (fun H1 H2 H3 H4 H5 => andI (P1 /\ P2 /\ P3 /\ P4) P5 (and4I H1 H2 H3 H4) H5).
Qed.

Variable P6:prop.

Theorem and6I: P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6.
exact (fun H1 H2 H3 H4 H5 H6 => andI (P1 /\ P2 /\ P3 /\ P4 /\ P5) P6 (and5I H1 H2 H3 H4 H5) H6).
Qed.

Variable P7:prop.

Theorem and7I: P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7.
exact (fun H1 H2 H3 H4 H5 H6 H7 => andI (P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6) P7 (and6I H1 H2 H3 H4 H5 H6) H7).
Qed.

End PropN.

Theorem not_or_and_demorgan : forall A B:prop, ~(A \/ B) -> ~A /\ ~B.
let A B.
assume u : ~(A \/ B).
apply andI.
- prove ~A. assume a:A. exact (u (orIL A B a)).
- prove ~B. assume b:B. exact (u (orIR A B b)).
Qed.

Theorem not_ex_all_demorgan_i : forall P:set->prop, (~exists x, P x) -> forall x, ~P x.
let P. assume H1. let x. assume H2. apply H1.
witness x.
exact H2.
Qed.

Theorem iffEL : forall A B:prop, (A <-> B) -> A -> B.
exact (fun A B => andEL (A -> B) (B -> A)).
Qed.

Theorem iffER : forall A B:prop, (A <-> B) -> B -> A.
exact (fun A B => andER (A -> B) (B -> A)).
Qed.

Theorem iff_refl : forall A:prop, A <-> A.
exact (fun A:prop => andI (A -> A) (A -> A) (fun H : A => H) (fun H : A => H)).
Qed.

Theorem iff_sym : forall A B:prop, (A <-> B) -> (B <-> A).
let A B.
assume H1: (A -> B) /\ (B -> A).
apply H1.
assume H2: A -> B.
assume H3: B -> A.
exact iffI B A H3 H2.
Qed.

Theorem iff_trans : forall A B C: prop, (A <-> B) -> (B <-> C) -> (A <-> C).
let A B C.
assume H1: A <-> B.
assume H2: B <-> C.
apply H1.
assume H3: A -> B.
assume H4: B -> A.
apply H2.
assume H5: B -> C.
assume H6: C -> B.
exact (iffI A C (fun H => H5 (H3 H)) (fun H => H4 (H6 H))).
Qed.

Theorem eq_i_tra : forall x y z, x = y -> y = z -> x = z.
let x y z. assume H1 H2. rewrite <- H2. exact H1.
Qed.

Theorem neq_i_sym: forall x y, x <> y -> y <> x.
let x y. assume H1 H2. apply H1. symmetry. exact H2.
Qed.

Theorem Eps_i_ex : forall P:set -> prop, (exists x, P x) -> P (Eps_i P).
let P. assume H1. apply H1.
let x. assume H2.
exact Eps_i_ax P x H2.
Qed.

Theorem prop_ext_2 : forall p q:prop, (p -> q) -> (q -> p) -> p = q.
let p q. assume H1 H2. apply prop_ext. apply iffI.
- exact H1.
- exact H2.
Qed.

Theorem Subq_ref : forall X:set, X c= X.
exact (fun (X x : set) (H : x :e X) => H).
Qed.

Theorem Subq_tra : forall X Y Z:set, X c= Y -> Y c= Z -> X c= Z.
exact (fun (X Y Z : set) (H1 : X c= Y) (H2 : Y c= Z) (x : set) (H : x :e X) => (H2 x (H1 x H))).
Qed.

Theorem Empty_Subq_eq : forall X:set, X c= Empty -> X = Empty.
let X.
assume H1: X c= Empty.
apply set_ext.
- exact H1.
- exact (Subq_Empty X).
Qed.

Theorem Empty_eq : forall X:set, (forall x, x /:e X) -> X = Empty.
let X.
assume H1: forall x, x /:e X.
apply Empty_Subq_eq.
let x.
assume H2: x :e X.
prove False.
exact (H1 x H2).
Qed.

Theorem UnionI : forall X x Y:set, x :e Y -> Y :e X -> x :e Union X.
let X x Y.
assume H1: x :e Y.
assume H2: Y :e X.
apply UnionEq X x.
assume _ H3. apply H3.
prove exists Y:set, x :e Y /\ Y :e X.
witness Y.
apply andI.
- exact H1.
- exact H2.
Qed.

Theorem UnionE : forall X x:set, x :e Union X -> exists Y:set, x :e Y /\ Y :e X.
exact (fun X x : set => iffEL (x :e Union X) (exists Y:set, x :e Y /\ Y :e X) (UnionEq X x)).
Qed.

Theorem UnionE_impred : forall X x:set, x :e Union X -> forall p:prop, (forall Y:set, x :e Y -> Y :e X -> p) -> p.
let X x. assume H1.
let p. assume Hp.
apply UnionE X x H1.
let x. assume H2. apply H2.
exact Hp x.
Qed.

Theorem PowerE : forall X Y:set, Y :e Power X -> Y c= X.
let X Y. apply PowerEq X Y. exact (fun H _ => H).
Qed.

Theorem Self_In_Power : forall X:set, X :e Power X.
exact (fun X : set => PowerI X X (Subq_ref X)).
Qed.

Theorem dneg : forall P:prop, ~~P -> P.
let P. assume H1.
apply xm P.
- exact (fun H => H).
- assume H2: ~P.
  prove False.
  exact H1 H2.
Qed.

Theorem not_all_ex_demorgan_i : forall P:set->prop, ~(forall x, P x) -> exists x, ~P x.
let P.
assume u:~forall x, P x.
apply dneg.
assume v:~exists x, ~P x.
apply u. let x. apply dneg.
assume w:~P x. 
exact (not_ex_all_demorgan_i (fun x => ~P x) v x w).
Qed.

Theorem eq_or_nand : or = (fun (x y:prop) => ~(~x /\ ~y)).
apply func_ext prop (prop -> prop).
let x. apply func_ext prop prop.
let y. apply prop_ext_2.
- assume H1: x \/ y.
  assume H2: ~x /\ ~y.
  apply H2. assume H3 H4. exact (H1 False H3 H4).
- assume H1:~(~x /\ ~y).
  apply (xm x).
  + assume H2: x. apply orIL. exact H2.
  + assume H2: ~x. apply (xm y).
    * assume H3: y. apply orIR. exact H3.
    * assume H3: ~y. apply H1. exact (andI (~x) (~y) H2 H3).
Qed.

(* Parameter exactly1of2 "3578b0d6a7b318714bc5ea889c6a38cf27f08eaccfab7edbde3cb7a350cf2d9b" "163602f90de012a7426ee39176523ca58bc964ccde619b652cb448bd678f7e21" *)
Definition exactly1of2 : prop->prop->prop := fun A B:prop =>
A /\ ~B \/ ~A /\ B.

Theorem exactly1of2_I1 : forall A B:prop, A -> ~B -> exactly1of2 A B.
let A B.
assume HA: A.
assume HB: ~B.
prove A /\ ~B \/ ~A /\ B.
apply orIL.
prove A /\ ~B.
exact (andI A (~B) HA HB).
Qed.

Theorem exactly1of2_I2 : forall A B:prop, ~A -> B -> exactly1of2 A B.
let A B.
assume HA: ~A.
assume HB: B.
prove A /\ ~B \/ ~A /\ B.
apply orIR.
prove ~A /\ B.
exact (andI (~A) B HA HB).
Qed.

Theorem exactly1of2_E : forall A B:prop, exactly1of2 A B ->
forall p:prop,
(A -> ~B -> p) ->
(~A -> B -> p) ->
p.
let A B.
assume H1: exactly1of2 A B.
let p.
assume H2 : A -> ~B -> p.
assume H3 : ~A -> B -> p.
apply (H1 p).
- exact (fun H4 : A /\ ~B => H4 p H2).
- exact (fun H4 : ~A /\ B => H4 p H3).
Qed.

Theorem exactly1of2_or : forall A B:prop, exactly1of2 A B -> A \/ B.
let A B.
assume H1: exactly1of2 A B.
apply (exactly1of2_E A B H1 (A \/ B)).
- exact (fun (HA : A) (_ : ~B) => orIL A B HA).
- exact (fun (_ : ~A) (HB : B) => orIR A B HB).
Qed.

Theorem ReplI : forall A:set, forall F:set->set, forall x:set, x :e A -> F x :e {F x|x :e A}.
let A F x. assume H1.
apply ReplEq A F (F x).
assume _ H2. apply H2.
prove exists x' :e A, F x = F x'.
witness x. apply andI.
- exact H1.
- exact (fun q H => H).
Qed.

Theorem ReplE : forall A:set, forall F:set->set, forall y:set, y :e {F x|x :e A} -> exists x :e A, y = F x.
let A F y. apply ReplEq A F y. exact (fun H _ => H).
Qed.

Theorem ReplE_impred : forall A:set, forall F:set->set, forall y:set, y :e {F x|x :e A} -> forall p:prop, (forall x:set, x :e A -> y = F x -> p) -> p.
let A F y. assume H1.
apply ReplE A F y H1.
let x. assume H2. apply H2.
assume H3 H4.
let p. assume Hp.
exact Hp x H3 H4.
Qed.

Theorem ReplE' : forall X, forall f:set -> set, forall p:set -> prop, (forall x :e X, p (f x)) -> forall y :e {f x|x :e X}, p y.
let X f p. assume H1. let y. assume Hy.
apply ReplE_impred X f y Hy.
let x. assume Hx: x :e X. assume Hx2: y = f x.
prove p y. rewrite Hx2. exact H1 x Hx.
Qed.

Theorem Repl_Empty : forall F:set -> set, {F x|x :e Empty} = Empty.
let F. apply (Empty_eq {F x|x :e Empty}).
let y.
assume H1: y :e {F x|x :e Empty}.
apply (ReplE_impred Empty F y H1).
let x.
assume H2: x :e Empty.
assume _.
exact (EmptyE x H2).
Qed.

Theorem ReplEq_ext_sub : forall X, forall F G:set -> set, (forall x :e X, F x = G x) -> {F x|x :e X} c= {G x|x :e X}.
let X F G.
assume H1: forall x :e X, F x = G x.
let y. assume Hy: y :e {F x|x :e X}.
apply ReplE_impred X F y Hy.
let x. assume Hx: x :e X.
assume H2: y = F x.
prove y :e {G x|x :e X}.
rewrite H2.
prove F x :e {G x|x :e X}.
rewrite H1 x Hx.
prove G x :e {G x|x :e X}.
apply ReplI. exact Hx.
Qed.

Theorem ReplEq_ext : forall X, forall F G:set -> set, (forall x :e X, F x = G x) -> {F x|x :e X} = {G x|x :e X}.
let X F G.
assume H1: forall x :e X, F x = G x.
apply set_ext.
- exact ReplEq_ext_sub X F G H1.
- apply ReplEq_ext_sub X G F.
  let x. assume Hx. symmetry. exact H1 x Hx.
Qed.

Theorem Repl_inv_eq : forall P:set -> prop, forall f g:set -> set,
    (forall x, P x -> g (f x) = x)
 -> forall X, (forall x :e X, P x) -> {g y|y :e {f x|x :e X}} = X.
let P f g. assume H1. let X. assume HX.
apply set_ext.
- let w. assume Hw: w :e {g y|y :e {f x|x :e X}}.
  apply ReplE_impred {f x|x :e X} g w Hw.
  let y. assume Hy: y :e {f x|x :e X}.
  assume Hwy: w = g y.
  apply ReplE_impred X f y Hy.
  let x. assume Hx: x :e X.
  assume Hyx: y = f x.
  prove w :e X. rewrite Hwy. rewrite Hyx.
  prove g (f x) :e X.
  rewrite H1 x (HX x Hx).
  exact Hx.
- let x. assume Hx: x :e X.
  rewrite <- H1 x (HX x Hx).
  prove g (f x) :e {g y|y :e {f x|x :e X}}.
  apply ReplI.
  prove f x :e {f x|x :e X}.
  apply ReplI. exact Hx.
Qed.

Theorem Repl_invol_eq : forall P:set -> prop, forall f:set -> set,
    (forall x, P x -> f (f x) = x)
 -> forall X, (forall x :e X, P x) -> {f y|y :e {f x|x :e X}} = X.
let P f. assume H1.
exact Repl_inv_eq P f f H1.
Qed.

(* Parameter If_i "8c8f550868df4fdc93407b979afa60092db4b1bb96087bc3c2f17fadf3f35cbf" "b8ff52f838d0ff97beb955ee0b26fad79602e1529f8a2854bda0ecd4193a8a3c" *)
Definition If_i : prop->set->set->set := (fun p x y => Eps_i (fun z:set => p /\ z = x \/ ~p /\ z = y)).
Notation IfThenElse If_i.

Theorem If_i_correct : forall p:prop, forall x y:set,
p /\ (if p then x else y) = x \/ ~p /\ (if p then x else y) = y.
let p x y.
apply (xm p).
- assume H1: p.
  claim L1: p /\ x = x \/ ~p /\ x = y.
  {
    apply orIL. apply andI.
    - exact H1.
    - reflexivity.
  }
  exact (Eps_i_ax (fun z : set => p /\ z = x \/ ~ p /\ z = y) x L1).
- assume H1: ~p.
  claim L1: p /\ y = x \/ ~p /\ y = y.
  {
    apply orIR. apply andI.
    - exact H1.
    - reflexivity.
  }
  exact (Eps_i_ax (fun z : set => p /\ z = x \/ ~ p /\ z = y) y L1).
Qed.

Theorem If_i_0 : forall p:prop, forall x y:set,
~ p -> (if p then x else y) = y.
let p x y.
assume H1: ~p.
apply (If_i_correct p x y).
- assume H2: p /\ (if p then x else y) = x.
  exact (H1 (andEL p ((if p then x else y) = x) H2) ((if p then x else y) = y)).
- assume H2: ~p /\ (if p then x else y) = y.
  exact (andER (~p) ((if p then x else y) = y) H2).
Qed.

Theorem If_i_1 : forall p:prop, forall x y:set,
p -> (if p then x else y) = x.
let p x y.
assume H1: p.
apply (If_i_correct p x y).
- assume H2: p /\ (if p then x else y) = x.
  exact (andER p ((if p then x else y) = x) H2).
- assume H2: ~p /\ (if p then x else y) = y.
  exact (andEL (~p) ((if p then x else y) = y) H2 H1 ((if p then x else y) = x)).
Qed.

Theorem If_i_or : forall p:prop, forall x y:set, (if p then x else y) = x \/ (if p then x else y) = y.
let p x y.
apply (xm p).
- assume H1: p. apply orIL. exact (If_i_1 p x y H1).
- assume H1: ~p. apply orIR. exact (If_i_0 p x y H1).
Qed.

(* Parameter UPair "80aea0a41bb8a47c7340fe8af33487887119c29240a470e920d3f6642b91990d" "74243828e4e6c9c0b467551f19c2ddaebf843f72e2437cc2dea41d079a31107f" *)
Definition UPair : set->set->set :=
fun y z => {if Empty :e X then y else z | X :e Power (Power Empty)}.
Notation SetEnum2 UPair.

Theorem UPairE :
forall x y z:set, x :e {y,z} -> x = y \/ x = z.
let x y z.
assume H1: x :e {y,z}.
apply (ReplE (Power (Power Empty)) (fun X => if Empty :e X then y else z) x H1).
let X.
assume H2: X :e Power (Power Empty) /\ x = if Empty :e X then y else z.
claim L1: x = if Empty :e X then y else z.
{ exact (andER (X :e Power (Power Empty)) (x = if Empty :e X then y else z) H2). }
apply (If_i_or (Empty :e X) y z).
- assume H3: (if Empty :e X then y else z) = y.
  apply orIL.
  prove x = y.
  rewrite <- H3. exact L1.
- assume H3: (if Empty :e X then y else z) = z.
  apply orIR.
  prove x = z.
  rewrite <- H3. exact L1.
Qed.

Theorem UPairI1 : forall y z:set, y :e {y,z}.
let y z.
prove y :e {y,z}.
rewrite <- (If_i_1 (Empty :e Power Empty) y z (Empty_In_Power Empty)) at 1.
prove (if Empty :e Power Empty then y else z) :e {y,z}.
prove (if Empty :e Power Empty then y else z) :e {if Empty :e X then y else z | X :e Power (Power Empty)}.
apply (ReplI (Power (Power Empty)) (fun X : set => if (Empty :e X) then y else z) (Power Empty)).
prove Power Empty :e Power (Power Empty).
exact (Self_In_Power (Power Empty)).
Qed.

Theorem UPairI2 : forall y z:set, z :e {y,z}.
let y z.
prove z :e {y,z}.
rewrite <- (If_i_0 (Empty :e Empty) y z (EmptyE Empty)) at 1.
prove (if Empty :e Empty then y else z) :e {y,z}.
prove (if Empty :e Empty then y else z) :e {if Empty :e X then y else z | X :e Power (Power Empty)}.
apply (ReplI (Power (Power Empty)) (fun X : set => if (Empty :e X) then y else z) Empty).
prove Empty :e Power (Power Empty).
exact (Empty_In_Power (Power Empty)).
Qed.

(* Parameter Sing "158bae29452f8cbf276df6f8db2be0a5d20290e15eca88ffe1e7b41d211d41d7" "bd01a809e97149be7e091bf7cbb44e0c2084c018911c24e159f585455d8e6bd0" *)
Definition Sing : set -> set := fun x => {x,x}.
Notation SetEnum1 Sing.

Theorem SingI : forall x:set, x :e {x}. 
exact (fun x : set => UPairI1 x x).
Qed.

Theorem SingE : forall x y:set, y :e {x} -> y = x. 
exact (fun x y H => UPairE y x x H (y = x) (fun H => H) (fun H => H)).
Qed.

(* Parameter binunion "0a445311c45f0eb3ba2217c35ecb47f122b2301b2b80124922fbf03a5c4d223e" "5e1ac4ac93257583d0e9e17d6d048ff7c0d6ccc1a69875b2a505a2d4da305784" *)
Definition binunion : set -> set -> set := fun X Y => Union {X,Y}.
(* Unicode :\/: "222a" *)
Infix :\/: 345 left := binunion.

Theorem binunionI1 : forall X Y z:set, z :e X -> z :e X :\/: Y.
let X Y z.
assume H1: z :e X.
prove z :e X :\/: Y.
prove z :e Union {X,Y}.
apply (UnionI {X,Y} z X).
- prove z :e X. exact H1.
- prove X :e {X,Y}. exact (UPairI1 X Y).
Qed.

Theorem binunionI2 : forall X Y z:set, z :e Y -> z :e X :\/: Y.
let X Y z.
assume H1: z :e Y.
prove z :e X :\/: Y.
prove z :e Union {X,Y}.
apply (UnionI {X,Y} z Y).
- prove z :e Y. exact H1.
- prove Y :e {X,Y}. exact (UPairI2 X Y).
Qed.

Theorem binunionE : forall X Y z:set, z :e X :\/: Y -> z :e X \/ z :e Y.
let X Y z.
assume H1: z :e X :\/: Y.
prove z :e X \/ z :e Y.
apply (UnionE_impred {X,Y} z H1).
let Z.
assume H2: z :e Z.
assume H3: Z :e {X,Y}.
apply (UPairE Z X Y H3).
- assume H4: Z = X.
  apply orIL.
  prove z :e X.
  rewrite <- H4.
  prove z :e Z.
  exact H2.
- assume H4: Z = Y.
  apply orIR.
  prove z :e Y.
  rewrite <- H4.
  prove z :e Z.
  exact H2.
Qed.

Theorem binunionE' : forall X Y z, forall p:prop, (z :e X -> p) -> (z :e Y -> p) -> (z :e X :\/: Y -> p).
let X Y z p. assume H1 H2 Hz.
apply binunionE X Y z Hz.
- assume H3: z :e X. exact H1 H3.
- assume H3: z :e Y. exact H2 H3.
Qed.

Theorem binunion_asso:forall X Y Z:set, X :\/: (Y :\/: Z) = (X :\/: Y) :\/: Z.
let X Y Z. apply set_ext.
- let w. assume H1: w :e X :\/: (Y :\/: Z).
  prove w :e (X :\/: Y) :\/: Z.
  apply (binunionE X (Y :\/: Z) w H1).
  + assume H2: w :e X.
    apply binunionI1. apply binunionI1. exact H2.
  + assume H2: w :e Y :\/: Z.
    apply (binunionE Y Z w H2).
    * assume H3: w :e Y.
      apply binunionI1. apply binunionI2. exact H3.
    * assume H3: w :e Z.
      apply binunionI2. exact H3.
- let w. assume H1: w :e (X :\/: Y) :\/: Z.
  prove w :e X :\/: (Y :\/: Z).
  apply (binunionE (X :\/: Y) Z w H1).
  + assume H2: w :e X :\/: Y.
    apply (binunionE X Y w H2).
    * assume H3: w :e X.
      apply binunionI1. exact H3.
    * assume H3: w :e Y.
      apply binunionI2. apply binunionI1. exact H3.
  + assume H2: w :e Z.
    apply binunionI2. apply binunionI2. exact H2.
Qed.

Theorem binunion_com_Subq:forall X Y:set, X :\/: Y c= Y :\/: X.
let X Y w. assume H1: w :e X :\/: Y.
prove w :e Y :\/: X.
apply (binunionE X Y w H1).
- assume H2: w :e X. apply binunionI2. exact H2.
- assume H2: w :e Y. apply binunionI1. exact H2.
Qed.

Theorem binunion_com:forall X Y:set, X :\/: Y = Y :\/: X.
let X Y. apply set_ext.
- exact (binunion_com_Subq X Y).
- exact (binunion_com_Subq Y X).
Qed.

Theorem binunion_idl:forall X:set, Empty :\/: X = X.
let X. apply set_ext.
- let x. assume H1: x :e Empty :\/: X.
  apply (binunionE Empty X x H1).
  + assume H2: x :e Empty. prove False. exact (EmptyE x H2).
  + assume H2: x :e X. exact H2.
- let x. assume H2: x :e X. prove x :e Empty :\/: X. apply binunionI2. exact H2.
Qed.

Theorem binunion_idr:forall X:set, X :\/: Empty = X.
let X.
rewrite (binunion_com X Empty).
exact (binunion_idl X).
Qed.

Theorem binunion_Subq_1: forall X Y:set, X c= X :\/: Y.
exact binunionI1.
Qed.

Theorem binunion_Subq_2: forall X Y:set, Y c= X :\/: Y.
exact binunionI2.
Qed.

Theorem binunion_Subq_min: forall X Y Z:set, X c= Z -> Y c= Z -> X :\/: Y c= Z.
let X Y Z.
assume H1: X c= Z.
assume H2: Y c= Z.
let w.
assume H3: w :e X :\/: Y.
apply (binunionE X Y w H3).
- assume H4: w :e X. exact (H1 w H4).
- assume H4: w :e Y. exact (H2 w H4).
Qed.

Theorem Subq_binunion_eq:forall X Y, (X c= Y) = (X :\/: Y = Y).
let X Y. apply prop_ext_2.
- assume H1: X c= Y.
  prove X :\/: Y = Y.
  apply set_ext.
  + prove X :\/: Y c= Y. apply (binunion_Subq_min X Y Y).
    * prove X c= Y. exact H1.
    * prove Y c= Y. exact (Subq_ref Y).
  + prove Y c= X :\/: Y. exact (binunion_Subq_2 X Y).
- assume H1: X :\/: Y = Y.
  prove X c= Y.
  rewrite <- H1.
  prove X c= X :\/: Y.
  exact (binunion_Subq_1 X Y).
Qed.

Definition SetAdjoin : set->set->set := fun X y => X :\/: {y}.
Notation SetEnum Empty Sing UPair SetAdjoin.
(* Parameter famunion "d772b0f5d472e1ef525c5f8bd11cf6a4faed2e76d4eacfa455f4d65cc24ec792" "b3e3bf86a58af5d468d398d3acad61ccc50261f43c856a68f8594967a06ec07a" *)
Definition famunion:set->(set->set)->set
:= fun X F => Union {F x|x :e X}.
(* Unicode \/_ "22C3" *)
(* Subscript \/_ *)
Binder \/_ , := famunion.

Theorem famunionI:forall X:set, forall F:(set->set), forall x y:set, x :e X -> y :e F x -> y :e \/_ x :e X, F x.
exact (fun X F x y H1 H2 => UnionI (Repl X F) y (F x) H2 (ReplI X F x H1)).
Qed.

Theorem famunionE:forall X:set, forall F:(set->set), forall y:set, y :e (\/_ x :e X, F x) -> exists x :e X, y :e F x.
let X F y.
assume H1: y :e (\/_ x :e X, F x).
prove exists x :e X, y :e F x.
apply (UnionE_impred {F x|x :e X} y H1).
let Y.
assume H2: y :e Y.
assume H3: Y :e {F x|x :e X}.
apply (ReplE_impred X F Y H3).
let x.
assume H4: x :e X.
assume H5: Y = F x.
witness x.
prove x :e X /\ y :e F x.
apply andI.
- exact H4.
- prove y :e F x.
  rewrite <- H5.
  exact H2.
Qed.

Theorem famunionE_impred : forall X : set , forall F : (set -> set) , forall y : set , y :e (\/_ x :e X , F x) -> forall p:prop, (forall x, x :e X -> y :e F x -> p) -> p.
let X F y. assume Hy.
let p. assume Hp.
apply famunionE X F y Hy.
let x. assume H1. apply H1.
exact Hp x.
Qed.

Theorem famunion_Empty: forall F:set -> set, (\/_ x :e Empty, F x) = Empty.
let F. apply Empty_Subq_eq.
let y. assume Hy: y :e \/_ x :e Empty, F x.
apply famunionE_impred Empty F y Hy.
let x. assume Hx: x :e Empty. prove False. exact EmptyE x Hx.
Qed.

Theorem famunion_Subq: forall X, forall f g:set -> set, (forall x :e X, f x c= g x) -> famunion X f c= famunion X g.
let X f g. assume Hfg.
let y. assume Hy. apply famunionE_impred X f y Hy.
let x. assume Hx.
assume H1: y :e f x.
apply famunionI X g x y Hx.
prove y :e g x.
exact Hfg x Hx y H1.
Qed.

Theorem famunion_ext: forall X, forall f g:set -> set, (forall x :e X, f x = g x) -> famunion X f = famunion X g.
let X f g. assume Hfg.
apply set_ext.
- apply famunion_Subq.
  let x. assume Hx. rewrite Hfg x Hx. apply Subq_ref.
- apply famunion_Subq.
  let x. assume Hx. rewrite Hfg x Hx. apply Subq_ref.
Qed.

Section SepSec.
Variable X:set.
Variable P:set->prop.
Let z : set := Eps_i (fun z => z :e X /\ P z).
Let F:set->set := fun x => if P x then x else z.
(* Parameter Sep "f7e63d81e8f98ac9bc7864e0b01f93952ef3b0cbf9777abab27bcbd743b6b079" "f336a4ec8d55185095e45a638507748bac5384e04e0c48d008e4f6a9653e9c44" *)
Definition Sep:set
:= if (exists z :e X, P z) then {F x|x :e X} else Empty.
End SepSec.
Notation Sep Sep.

Theorem SepI:forall X:set, forall P:(set->prop), forall x:set, x :e X -> P x -> x :e {x :e X|P x}.
let X P x.
set z : set := Eps_i (fun z => z :e X /\ P z).
set F : set->set := fun x => if P x then x else z.
assume H1: x :e X.
assume H2: P x.
claim L1: exists z :e X, P z.
{
  witness x. apply andI.
  - exact H1.
  - exact H2.
}
prove x :e {x :e X|P x}.
prove x :e if (exists z :e X, P z) then {F x|x :e X} else Empty.
(*** Note:
 Making L2 a claim and then rewriting with it succeeds, but rewrite (If_i_1 (exists z :e X, P z) {F x|x :e X} Empty L1) fails.
 The reason is that when the proposition proved by (If_i_1 (exists z :e X, P z) {F x|x :e X} Empty L1) is
 extracted by the code, the F x will be beta reduced to be if P x then x else z. After this beta reduction, the left hand side of the
 equation does not match the right hand side of the claim x :e if (exists z :e X, P z) then {F x|x :e X} else Empty.
 This is an example of how one must be careful using the apply and rewrite tactics and must sometimes give these
 kinds of explicit annotations, i.e., proving a beta-eta-delta equivalent claim.
 ***)
claim L2: (if (exists z :e X, P z) then {F x|x :e X} else Empty) = {F x|x :e X}.
{
  exact (If_i_1 (exists z :e X, P z) {F x|x :e X} Empty L1).
}
rewrite L2.
prove x :e {F x|x :e X}.
claim L3: F x = x.
{
  prove (if P x then x else z) = x.
  exact (If_i_1 (P x) x z H2).
}
rewrite <- L3.
prove F x :e {F x|x :e X}.
exact (ReplI X F x H1).
Qed.

Theorem SepE:forall X:set, forall P:(set->prop), forall x:set, x :e {x :e X|P x} -> x :e X /\ P x.
let X P x.
set z : set := Eps_i (fun z => z :e X /\ P z).
set F : set->set := fun x => if P x then x else z.
apply (xm (exists z :e X, P z)).
- assume H1: exists z :e X, P z.
  prove (x :e (if (exists z :e X, P z) then {F x|x :e X} else Empty) -> x :e X /\ P x).
  claim L1: (if (exists z :e X, P z) then {F x|x :e X} else Empty) = {F x|x :e X}.
  {
    exact (If_i_1 (exists z :e X, P z) {F x|x :e X} Empty H1).
  }
  rewrite L1.
  prove x :e {F x|x :e X} -> x :e X /\ P x.
  assume H2: x :e {F x|x :e X}.
  apply (ReplE_impred X F x H2).
  let y.
  assume H3: y :e X.
  assume H4: x = F y.
  prove x :e X /\ P x.
  apply (xm (P y)).
  + assume H5: P y.
    claim L2: x = y.
    {
      rewrite <- (If_i_1 (P y) y z H5).
      exact H4.
    }
    rewrite L2.
    prove y :e X /\ P y.
    apply andI.
    * exact H3.
    * exact H5.
  + assume H5: ~P y.
    claim L2: x = z.
    {
      rewrite <- (If_i_0 (P y) y z H5).
      exact H4.
    }
    rewrite L2.
    prove z :e X /\ P z.
    exact (Eps_i_ex (fun z => z :e X /\ P z) H1).
- assume H1: ~exists z :e X, P z.
  prove (x :e (if (exists z :e X, P z) then {F x|x :e X} else Empty) -> x :e X /\ P x).
  claim L1: (if (exists z :e X, P z) then {F x|x :e X} else Empty) = Empty.
  { exact (If_i_0 (exists z :e X, P z) {F x|x :e X} Empty H1). }
  rewrite L1.
  prove x :e Empty -> x :e X /\ P x.
  assume H2: x :e Empty.
  prove False.
  exact (EmptyE x H2).
Qed.

Theorem SepE1:forall X:set, forall P:(set->prop), forall x:set, x :e {x :e X|P x} -> x :e X.
exact (fun X P x H => SepE X P x H (x :e X) (fun H _ => H)).
Qed.

Theorem SepE2:forall X:set, forall P:(set->prop), forall x:set, x :e {x :e X|P x} -> P x.
exact (fun X P x H => SepE X P x H (P x) (fun _ H => H)).
Qed.

Theorem Sep_Empty: forall P:set -> prop, {x :e Empty|P x} = Empty.
let P. apply Empty_eq.
let x. assume Hx.
exact EmptyE x (SepE1 Empty P x Hx).
Qed.

Theorem Sep_Subq : forall X:set, forall P:set->prop, {x :e X|P x} c= X.
exact SepE1.
Qed.

Theorem Sep_In_Power : forall X:set, forall P:set->prop, {x :e X|P x} :e Power X.
exact (fun X P => PowerI X (Sep X P) (Sep_Subq X P)).
Qed.

(* Parameter ReplSep "f627d20f1b21063483a5b96e4e2704bac09415a75fed6806a2587ce257f1f2fd" "ec807b205da3293041239ff9552e2912636525180ddecb3a2b285b91b53f70d8" *)
Definition ReplSep : set->(set->prop)->(set->set)->set := fun X P F => {F x|x :e {z :e X|P z}}.
Notation ReplSep ReplSep.

Theorem ReplSepI: forall X:set, forall P:set->prop, forall F:set->set, forall x:set, x :e X -> P x -> F x :e {F x|x :e X, P x}.
exact (fun X P F x u v => ReplI (Sep X P) F x (SepI X P x u v)).
Qed.

Theorem ReplSepE:forall X:set, forall P:set->prop, forall F:set->set, forall y:set, y :e {F x|x :e X, P x} -> exists x:set, x :e X /\ P x /\ y = F x.
let X P F y.
assume H1: y :e {F x|x :e {z :e X|P z}}.
apply (ReplE {z :e X|P z} F y H1).
let x.
assume H2: x :e {z :e X|P z} /\ y = F x.
apply H2.
assume H3: x :e {z :e X|P z}.
assume H4: y = F x.
apply (SepE X P x H3).
assume H5: x :e X.
assume H6: P x.
witness x.
apply and3I.
- exact H5.
- exact H6.
- exact H4.
Qed.

Theorem ReplSepE_impred: forall X:set, forall P:set->prop, forall F:set->set, forall y:set, y :e {F x|x :e X, P x} -> forall p:prop, (forall x :e X, P x -> y = F x -> p) -> p.
let X P F y.
assume H1: y :e {F x|x :e X, P x}.
let p.
assume H2: forall x :e X, P x -> y = F x -> p.
prove p.
apply ReplSepE X P F y H1.
let x. assume H3. apply H3. assume H3. apply H3.
exact H2 x.
Qed.

(* Parameter binintersect "8cf6b1f490ef8eb37db39c526ab9d7c756e98b0eb12143156198f1956deb5036" "b2abd2e5215c0170efe42d2fa0fb8a62cdafe2c8fbd0d37ca14e3497e54ba729" *)
Definition binintersect:set->set->set
:= fun X Y => {x :e X |x :e Y}.
(* Unicode :/\: "2229" *)
Infix :/\: 340 left := binintersect.

Theorem binintersectI:forall X Y z, z :e X -> z :e Y -> z :e X :/\: Y.
exact (fun X Y z H1 H2 => SepI X (fun x:set => x :e Y) z H1 H2).
Qed.

Theorem binintersectE:forall X Y z, z :e X :/\: Y -> z :e X /\ z :e Y.
exact (fun X Y z H1 => SepE X (fun x:set => x :e Y) z H1).
Qed.

Theorem binintersectE1:forall X Y z, z :e X :/\: Y -> z :e X.
exact (fun X Y z H1 => SepE1 X (fun x:set => x :e Y) z H1).
Qed.

Theorem binintersectE2:forall X Y z, z :e X :/\: Y -> z :e Y.
exact (fun X Y z H1 => SepE2 X (fun x:set => x :e Y) z H1).
Qed.

Theorem binintersect_Subq_1:forall X Y:set, X :/\: Y c= X.
exact binintersectE1.
Qed.

Theorem binintersect_Subq_2:forall X Y:set, X :/\: Y c= Y.
exact binintersectE2.
Qed.

Theorem binintersect_Subq_eq_1 : forall X Y, X c= Y -> X :/\: Y = X.
let X Y.
assume H1: X c= Y.
apply set_ext.
- apply binintersect_Subq_1.
- let x. assume H2: x :e X.
  apply binintersectI.
  + exact H2.
  + apply H1. exact H2.
Qed.

Theorem binintersect_Subq_max:forall X Y Z:set, Z c= X -> Z c= Y -> Z c= X :/\: Y.
let X Y Z.
assume H1: Z c= X.
assume H2: Z c= Y.
let w.
assume H3: w :e Z.
apply (binintersectI X Y w).
- prove w :e X. exact (H1 w H3).
- prove w :e Y. exact (H2 w H3).
Qed.

Theorem binintersect_com_Subq: forall X Y:set, X :/\: Y c= Y :/\: X.
let X Y. apply (binintersect_Subq_max Y X (X :/\: Y)).
- prove X :/\: Y c= Y. apply binintersect_Subq_2.
- prove X :/\: Y c= X. apply binintersect_Subq_1.
Qed.

Theorem binintersect_com: forall X Y:set, X :/\: Y = Y :/\: X.
let X Y. apply set_ext.
- exact (binintersect_com_Subq X Y).
- exact (binintersect_com_Subq Y X).
Qed.

(* Parameter setminus "cc569397a7e47880ecd75c888fb7c5512aee4bcb1e7f6bd2c5f80cccd368c060" "c68e5a1f5f57bc5b6e12b423f8c24b51b48bcc32149a86fc2c30a969a15d8881" *)
Definition setminus:set->set->set
:= fun X Y => Sep X (fun x => x /:e Y).
(* Unicode :\: "2216" *)
Infix :\: 350 := setminus.

Theorem setminusI:forall X Y z, (z :e X) -> (z /:e Y) -> z :e X :\: Y.
exact (fun X Y z H1 H2 => SepI X (fun x:set => x /:e Y) z H1 H2).
Qed.

Theorem setminusE:forall X Y z, (z :e X :\: Y) -> z :e X /\ z /:e Y.
exact (fun X Y z H => SepE X (fun x:set => x /:e Y) z H).
Qed.

Theorem setminusE1:forall X Y z, (z :e X :\: Y) -> z :e X.
exact (fun X Y z H => SepE1 X (fun x:set => x /:e Y) z H).
Qed.

Theorem setminusE2:forall X Y z, (z :e X :\: Y) -> z /:e Y.
exact (fun X Y z H => SepE2 X (fun x:set => x /:e Y) z H).
Qed.

Theorem setminus_Subq:forall X Y:set, X :\: Y c= X.
exact setminusE1.
Qed.

Theorem setminus_In_Power : forall A U, A :\: U :e Power A.
let A U. apply PowerI. apply setminus_Subq.
Qed.

Theorem binunion_remove1_eq: forall X, forall x :e X, X = (X :\: {x}) :\/: {x}.
let X x.
assume Hx: x :e X.
apply set_ext.
- let y. assume Hy: y :e X.
  prove y :e (X :\: {x}) :\/: {x}.
  apply xm (y :e {x}).
  + assume H1: y :e {x}.
    apply binunionI2. exact H1.
  + assume H1: y /:e {x}.
    apply binunionI1. apply setminusI.
    * exact Hy.
    * exact H1.
- let y. assume Hy: y :e (X :\: {x}) :\/: {x}.
  apply binunionE (X :\: {x}) {x} y Hy.
  + assume H1: y :e X :\: {x}.
    prove y :e X.
    exact setminusE1 X {x} y H1.
  + assume H1: y :e {x}.
    prove y :e X.
    rewrite SingE x y H1.
    prove x :e X.
    exact Hx.
Qed.

Theorem In_irref : forall x, x /:e x.
apply In_ind.
prove (forall X:set, (forall x:set, x :e X -> x /:e x) -> X /:e X).
let X.
assume IH: forall x : set, x :e X -> x /:e x.
assume H: X :e X.
exact IH X H H.
Qed.

Theorem In_no2cycle : forall x y, x :e y -> y :e x -> False.
apply In_ind.
let x.
assume IH: forall z, z :e x -> forall y, z :e y -> y :e z -> False.
let y.
assume H1: x :e y.
assume H2: y :e x.
exact IH y H2 x H2 H1.
Qed.

(* Parameter ordsucc "9db634daee7fc36315ddda5f5f694934869921e9c5f55e8b25c91c0a07c5cbec" "65d8837d7b0172ae830bed36c8407fcd41b7d875033d2284eb2df245b42295a6" *)
Definition ordsucc : set->set := fun x:set => x :\/: {x}.

Theorem ordsuccI1 : forall x:set, x c= ordsucc x.
let x.
exact (fun (y : set) (H1 : y :e x) => binunionI1 x {x} y H1).
Qed.

Theorem ordsuccI2 : forall x:set, x :e ordsucc x.
exact (fun x : set => binunionI2 x {x} x (SingI x)).
Qed.

Theorem ordsuccE : forall x y:set, y :e ordsucc x -> y :e x \/ y = x.
let x y.
assume H1: y :e x :\/: {x}.
apply (binunionE x {x} y H1).
- assume H2: y :e x. apply orIL. exact H2.
- assume H2: y :e {x}. apply orIR. exact (SingE x y H2).
Qed.

Notation Nat Empty ordsucc.

Theorem neq_0_ordsucc : forall a:set, 0 <> ordsucc a.
let a. prove ~(0 = ordsucc a).
assume H1: 0 = ordsucc a.
claim L1: a :e ordsucc a -> False.
{ rewrite <- H1. exact (EmptyE a). }
exact (L1 (ordsuccI2 a)).
Qed.

Theorem neq_ordsucc_0 : forall a:set, ordsucc a <> 0.
let a. exact neq_i_sym 0 (ordsucc a) (neq_0_ordsucc a).
Qed.

Theorem ordsucc_inj : forall a b:set, ordsucc a = ordsucc b -> a = b.
let a b.
assume H1: ordsucc a = ordsucc b.
claim L1: a :e ordsucc b.
{
  rewrite <- H1.
  exact (ordsuccI2 a).
}
apply (ordsuccE b a L1).
- assume H2: a :e b.
  claim L2: b :e ordsucc a.
  {
    rewrite H1.
    exact (ordsuccI2 b).
  }
  apply (ordsuccE a b L2).
  + assume H3: b :e a. prove False. exact (In_no2cycle a b H2 H3).
  + assume H3: b = a. symmetry. exact H3.
- assume H2: a = b. exact H2.
Qed.

Theorem In_0_1 : 0 :e 1.
exact (ordsuccI2 0).
Qed.

Theorem In_0_2 : 0 :e 2.
exact (ordsuccI1 1 0 In_0_1).
Qed.

Theorem In_1_2 : 1 :e 2.
exact (ordsuccI2 1).
Qed.

Definition nat_p : set->prop := fun n:set => forall p:set->prop, p 0 -> (forall x:set, p x -> p (ordsucc x)) -> p n.

Theorem nat_0 : nat_p 0.
exact (fun p H _ => H).
Qed.

Theorem nat_ordsucc : forall n:set, nat_p n -> nat_p (ordsucc n).
exact (fun n H1 p H2 H3 => H3 n (H1 p H2 H3)).
Qed.

Theorem nat_1 : nat_p 1.
exact (nat_ordsucc 0 nat_0).
Qed.

Theorem nat_2 : nat_p 2.
exact (nat_ordsucc 1 nat_1).
Qed.

Theorem nat_0_in_ordsucc : forall n, nat_p n -> 0 :e ordsucc n.
let n.
assume H1.
apply H1 (fun n => 0 :e ordsucc n).
- prove 0 :e ordsucc 0.
  exact In_0_1.
- let n.
  assume IH: 0 :e ordsucc n.
  prove 0 :e ordsucc (ordsucc n).
  exact (ordsuccI1 (ordsucc n) 0 IH).
Qed.

Theorem nat_ordsucc_in_ordsucc : forall n, nat_p n -> forall m :e n, ordsucc m :e ordsucc n.
let n.
assume H1.
apply (H1 (fun n => forall m :e n, ordsucc m :e ordsucc n)).
- prove forall m :e 0, ordsucc m :e ordsucc 0.
  let m.
  assume Hm: m :e 0.
  prove False.
  exact (EmptyE m Hm).
- let n.
  assume IH: forall m :e n, ordsucc m :e ordsucc n.
  prove forall m :e ordsucc n, ordsucc m :e ordsucc (ordsucc n).
  let m.
  assume H2: m :e ordsucc n.
  prove ordsucc m :e ordsucc (ordsucc n).
  apply (ordsuccE n m H2).
  + assume H3: m :e n.
    claim L1: ordsucc m :e ordsucc n.
    { exact (IH m H3). }
    exact (ordsuccI1 (ordsucc n) (ordsucc m) L1).
  + assume H3: m = n.
    rewrite H3.
    prove ordsucc n :e ordsucc (ordsucc n).
    exact (ordsuccI2 (ordsucc n)).
Qed.

Theorem nat_ind : forall p:set->prop, p 0 -> (forall n, nat_p n -> p n -> p (ordsucc n)) -> forall n, nat_p n -> p n.
let p.
assume H1: p 0.
assume H2: forall n, nat_p n -> p n -> p (ordsucc n).
claim L1: nat_p 0 /\ p 0.
{ exact (andI (nat_p 0) (p 0) nat_0 H1). }
claim L2: forall n, nat_p n /\ p n -> nat_p (ordsucc n) /\ p (ordsucc n).
{ let n.
  assume H3: nat_p n /\ p n.
  apply H3.
  assume H4: nat_p n.
  assume H5: p n.
  apply andI.
  - prove nat_p (ordsucc n).
    exact (nat_ordsucc n H4).
  - prove p (ordsucc n).
    exact (H2 n H4 H5).
}
let n.
assume H3.
claim L3: nat_p n /\ p n.
{ exact (H3 (fun n => nat_p n /\ p n) L1 L2). }
exact (andER (nat_p n) (p n) L3).
Qed.

Theorem nat_complete_ind : forall p:set->prop, (forall n, nat_p n -> (forall m :e n, p m) -> p n) -> forall n, nat_p n -> p n.
let p.
assume H1: forall n, nat_p n -> (forall m :e n, p m) -> p n.
claim L1: forall n:set, nat_p n -> forall m :e n, p m.
{ apply nat_ind.
  - prove forall m :e 0, p m.
    let m.
    assume Hm: m :e 0.
    prove False.
    exact (EmptyE m Hm).
  - let n.
    assume Hn: nat_p n.
    assume IHn: forall m :e n, p m.
    prove forall m :e ordsucc n, p m.
    let m.
    assume Hm: m :e ordsucc n.
    prove p m.
    apply (ordsuccE n m Hm).
    + assume H2: m :e n.
      exact (IHn m H2).
    + assume H2: m = n.
      prove p m.
      rewrite H2.
      prove p n.
      exact (H1 n Hn IHn).
}
prove forall n, nat_p n -> p n.
exact (fun n Hn => H1 n Hn (L1 n Hn)).
Qed.

Theorem nat_inv_impred : forall p:set->prop, p 0 -> (forall n, nat_p n -> p (ordsucc n)) -> forall n, nat_p n -> p n.
let p. assume H1 H2. exact nat_ind p H1 (fun n H _ => H2 n H).
Qed.

Theorem nat_inv : forall n, nat_p n -> n = 0 \/ exists x, nat_p x /\ n = ordsucc x.
apply nat_inv_impred.
- apply orIL. reflexivity.
- let n. assume Hn. apply orIR. witness n. apply andI.
  + exact Hn.
  + reflexivity.
Qed.

Theorem nat_p_trans : forall n, nat_p n -> forall m :e n, nat_p m.
apply nat_ind.
- prove forall m :e 0, nat_p m.
  let m.
  assume Hm: m :e 0.
  prove False.
  exact (EmptyE m Hm).
- let n.
  assume Hn: nat_p n.
  assume IHn: forall m :e n, nat_p m.
  prove forall m :e ordsucc n, nat_p m.
  let m.
  assume Hm: m :e ordsucc n.
  apply (ordsuccE n m Hm).
  + assume H1: m :e n.
    exact (IHn m H1).
  + assume H1: m = n.
    rewrite H1.
    exact Hn.
Qed.

Theorem nat_trans : forall n, nat_p n -> forall m :e n, m c= n.
apply nat_ind.
- prove forall m :e 0, m c= 0.
  let m.
  assume Hm: m :e 0.
  prove False.
  exact (EmptyE m Hm).
- let n.
  assume Hn: nat_p n.
  assume IHn: forall m :e n, m c= n.
  prove forall m :e ordsucc n, m c= ordsucc n.
  let m.
  assume Hm: m :e ordsucc n.
  apply (ordsuccE n m Hm).
  + assume H1: m :e n.
    prove m c= ordsucc n.
    apply (Subq_tra m n (ordsucc n)).
    * exact (IHn m H1).
    * exact (ordsuccI1 n).
  + assume H1: m = n.
    prove m c= ordsucc n.
    rewrite H1.
    prove n c= ordsucc n.
    exact (ordsuccI1 n).
Qed.

Theorem nat_ordsucc_trans : forall n, nat_p n -> forall m :e ordsucc n, m c= n.
let n.
assume Hn: nat_p n.
let m.
assume Hm: m :e ordsucc n.
let k.
assume Hk: k :e m.
prove k :e n.
apply (ordsuccE n m Hm).
- assume H1: m :e n.
  exact nat_trans n Hn m H1 k Hk.
- assume H1: m = n.
  rewrite <- H1.
  exact Hk.
Qed.

Definition surj : set->set->(set->set)->prop :=
  fun X Y f =>
  (forall u :e X, f u :e Y)
  /\
  (forall w :e Y, exists u :e X, f u = w).

Theorem form100_63_surjCantor: forall A:set, forall f:set -> set, ~surj A (Power A) f.
let A f. assume H. apply H.
assume H1: forall u :e A, f u :e Power A.
assume H2: forall w :e Power A, exists u :e A, f u = w.
set D := {x :e A|x /:e f x}.
claim L1: D :e Power A.
{ exact Sep_In_Power A (fun x => x /:e f x). }
apply H2 D L1.
let d. assume H. apply H.
assume Hd: d :e A.
assume HfdD: f d = D.
claim L2: d /:e D.
{ assume H3: d :e D.
  apply SepE2 A (fun x => x /:e f x) d H3.
  prove d :e f d.
  rewrite HfdD.
  prove d :e D.
  exact H3.
}
apply L2.
prove d :e D.
apply SepI.
- prove d :e A. exact Hd.
- prove d /:e f d. rewrite HfdD. exact L2.
Qed.

Definition inj : set->set->(set->set)->prop :=
  fun X Y f =>
  (forall u :e X, f u :e Y)
  /\
  (forall u v :e X, f u = f v -> u = v).

Theorem form100_63_injCantor: forall A:set, forall f:set -> set, ~inj (Power A) A f.
let A f. assume H. apply H.
assume H1: forall X :e Power A, f X :e A.
assume H2: forall X Y :e Power A, f X = f Y -> X = Y.
set D := {f X | X :e Power A, f X /:e X}.
claim L1: D :e Power A.
{ apply PowerI.
  let n. assume H3: n :e D.
  apply ReplSepE_impred (Power A) (fun X => f X /:e X) f n H3.
  let X. assume HX: X :e Power A.
  assume H4: f X /:e X.
  assume H5: n = f X.
  prove n :e A. rewrite H5. apply H1. exact HX.
}
claim L2: f D /:e D.
{ assume H3: f D :e D.
  apply ReplSepE_impred (Power A) (fun X => f X /:e X) f (f D) H3.
  let X. assume HX: X :e Power A.
  assume H4: f X /:e X.
  assume H5: f D = f X.
  claim L2a: D = X.
  { exact H2 D L1 X HX H5. }
  apply H4. rewrite <- L2a. exact H3.
}
apply L2.
prove f D :e D.
apply ReplSepI.
- prove D :e Power A. exact L1.
- prove f D /:e D. exact L2.
Qed.

Theorem injI : forall X Y, forall f:set -> set, (forall x :e X, f x :e Y) -> (forall x z :e X, f x = f z -> x = z) -> inj X Y f.
let X Y f. assume H1 H2.
prove (forall x :e X, f x :e Y) /\ (forall x z :e X, f x = f z -> x = z).
apply andI.
- exact H1.
- exact H2.
Qed.

Theorem inj_comp : forall X Y Z:set, forall f g:set->set, inj X Y f -> inj Y Z g -> inj X Z (fun x => g (f x)).
let X Y Z f g.
assume Hf.
assume Hg.
apply Hf.
assume Hf1 Hf2.
apply Hg.
assume Hg1 Hg2.
apply injI.
- let u. assume Hu: u :e X. exact (Hg1 (f u) (Hf1 u Hu)).
- let u. assume Hu: u :e X. let v. assume Hv: v :e X.
  assume H1: g (f u) = g (f v).
  prove u = v.
  apply Hf2 u Hu v Hv.
  prove f u = f v.
  apply Hg2 (f u) (Hf1 u Hu) (f v) (Hf1 v Hv).
  prove g (f u) = g (f v).
  exact H1.
Qed.

Definition bij : set->set->(set->set)->prop :=
  fun X Y f =>
  (forall u :e X, f u :e Y)
  /\
  (forall u v :e X, f u = f v -> u = v)
  /\
  (forall w :e Y, exists u :e X, f u = w).

Theorem bijI : forall X Y, forall f:set -> set,
    (forall u :e X, f u :e Y)
 -> (forall u v :e X, f u = f v -> u = v)
 -> (forall w :e Y, exists u :e X, f u = w)
 -> bij X Y f.
let X Y f. assume Hf1 Hf2 Hf3.
prove (forall u :e X, f u :e Y)
   /\ (forall u v :e X, f u = f v -> u = v)
   /\ (forall w :e Y, exists u :e X, f u = w).
apply and3I.
- exact Hf1.
- exact Hf2.
- exact Hf3.
Qed.

Theorem bijE : forall X Y, forall f:set -> set,
    bij X Y f
 -> forall p:prop,
      ((forall u :e X, f u :e Y)
    -> (forall u v :e X, f u = f v -> u = v)
    -> (forall w :e Y, exists u :e X, f u = w)
    -> p)
   -> p.
let X Y f. assume Hf. let p. assume Hp.
apply Hf. assume Hf. apply Hf.
assume Hf1 Hf2 Hf3.
exact Hp Hf1 Hf2 Hf3.
Qed.

Theorem bij_inj : forall X Y, forall f:set -> set, bij X Y f -> inj X Y f.
let X Y f. assume H1. apply H1. assume H1 _. exact H1.
Qed.

Theorem bij_id : forall X, bij X X (fun x => x).
let X.
prove (forall u :e X, u :e X) /\ (forall u v :e X, u = v -> u = v) /\ (forall w :e X, exists u :e X, u = w).
apply and3I.
- exact (fun u Hu => Hu).
- exact (fun u Hu v Hv H1 => H1).
- let w. assume Hw. witness w. apply andI.
  + exact Hw.
  + reflexivity.
Qed.

Theorem bij_comp : forall X Y Z:set, forall f g:set->set, bij X Y f -> bij Y Z g -> bij X Z (fun x => g (f x)).
let X Y Z f g.
assume Hf. apply Hf. assume Hf12 Hf3. apply Hf12. assume Hf1 Hf2.
assume Hg. apply Hg. assume Hg12 Hg3. apply Hg12. assume Hg1 Hg2.
prove (forall u :e X, g (f u) :e Z)
  /\
  (forall u v :e X, g (f u) = g (f v) -> u = v)
  /\
  (forall w :e Z, exists u :e X, g (f u) = w).
apply and3I.
- let u. assume Hu: u :e X. exact (Hg1 (f u) (Hf1 u Hu)).
- let u. assume Hu: u :e X. let v. assume Hv: v :e X.
  assume H1: g (f u) = g (f v).
  prove u = v.
  apply Hf2 u Hu v Hv.
  prove f u = f v.
  apply Hg2 (f u) (Hf1 u Hu) (f v) (Hf1 v Hv).
  prove g (f u) = g (f v).
  exact H1.
- let w. assume Hw: w :e Z. apply Hg3 w Hw.
  let y. assume Hy12. apply Hy12.
  assume Hy1: y :e Y. assume Hy2: g y = w.
  apply Hf3 y Hy1.
  let u. assume Hu12. apply Hu12.
  assume Hu1: u :e X. assume Hu2: f u = y.
  prove exists u :e X, g (f u) = w.
  witness u.
  apply andI.
  + exact Hu1.
  + rewrite Hu2. exact Hy2.
Qed.

Theorem bij_surj : forall X Y, forall f:set -> set, bij X Y f -> surj X Y f.
let X Y f. assume H1. apply H1. assume H1. apply H1.
assume H1 _ H2.
prove (forall u :e X, f u :e Y)
   /\ (forall w :e Y, exists u :e X, f u = w).
apply andI.
- exact H1.
- exact H2.
Qed.

Definition inv : set -> (set -> set) -> set -> set := fun X f => fun y:set => Eps_i (fun x => x :e X /\ f x = y).

Theorem surj_rinv : forall X Y, forall f:set->set, (forall w :e Y, exists u :e X, f u = w) -> forall y :e Y, inv X f y :e X /\ f (inv X f y) = y.
let X Y f. assume H1.
let y. assume Hy: y :e Y.
apply H1 y Hy.
let x.
assume H2.
exact Eps_i_ax (fun x => x :e X /\ f x = y) x H2.
Qed.

Theorem inj_linv : forall X, forall f:set->set, (forall u v :e X, f u = f v -> u = v) -> forall x :e X, inv X f (f x) = x.
let X f.
assume H1.
let x. assume Hx.
claim L1: inv X f (f x) :e X /\ f (inv X f (f x)) = f x.
{ apply Eps_i_ax (fun x' => x' :e X /\ f x' = f x) x.
  apply andI.
  - exact Hx.
  - reflexivity.
}
apply L1.
assume H2 H3.
exact H1 (inv X f (f x)) H2 x Hx H3.
Qed.

Theorem bij_inv : forall X Y, forall f:set->set, bij X Y f -> bij Y X (inv X f).
let X Y f.
assume H1. apply H1.
assume H2. apply H2.
assume H3: forall u :e X, f u :e Y.
assume H4: forall u v :e X, f u = f v -> u = v.
assume H5: forall w :e Y, exists u :e X, f u = w.
set g : set->set := fun y => Eps_i (fun x => x :e X /\ f x = y).
claim L1: forall y :e Y, g y :e X /\ f (g y) = y.
{ exact surj_rinv X Y f H5. }
prove (forall u :e Y, g u :e X)
      /\
      (forall u v :e Y, g u = g v -> u = v)
      /\
      (forall w :e X, exists u :e Y, g u = w).
apply and3I.
- prove forall u :e Y, g u :e X.
  let u. assume Hu. apply L1 u Hu. assume H _. exact H.
- prove forall u v :e Y, g u = g v -> u = v.
  let u. assume Hu. let v. assume Hv H6.
  prove u = v.
  apply L1 u Hu.
  assume H7: g u :e X.
  assume H8: f (g u) = u.
  apply L1 v Hv.
  assume H9: g v :e X.
  assume H10: f (g v) = v.
  rewrite <- H8.
  rewrite <- H10.
  rewrite <- H6.
  reflexivity.
- prove forall w :e X, exists u :e Y, g u = w.
  let w. assume Hw.
  claim Lfw: f w :e Y.
  { exact H3 w Hw. }
  witness f w.
  apply andI.
  + exact Lfw.
  + exact inj_linv X f H4 w Hw.
Qed.

Definition atleastp : set -> set -> prop
 := fun X Y : set => exists f : set -> set, inj X Y f.

Theorem atleastp_tra: forall X Y Z, atleastp X Y -> atleastp Y Z -> atleastp X Z.
 admit. (** FAIL **)
Qed.

Theorem Subq_atleastp : forall X Y, X c= Y -> atleastp X Y.
 admit. (** FAIL **)
Qed.

Definition equip : set -> set -> prop
 := fun X Y : set => exists f : set -> set, bij X Y f.

Theorem equip_atleastp: forall X Y, equip X Y -> atleastp X Y.
admit. (** FAIL **)
Qed.

Theorem equip_ref : forall X, equip X X.
admit. (** FAIL **)
Qed.

Theorem equip_sym : forall X Y, equip X Y -> equip Y X.
admit.
Qed.

Theorem equip_tra : forall X Y Z, equip X Y -> equip Y Z -> equip X Z.
admit.
Qed.

Theorem equip_0_Empty : forall X, equip X 0 -> X = 0.
admit.
Qed.

Theorem equip_adjoin_ordsucc : forall N X y, y /:e X -> equip N X -> equip (ordsucc N) (X :\/: {y}).
admit.
Qed.

Theorem equip_ordsucc_remove1: forall X N, forall x :e X, equip X (ordsucc N) -> equip (X :\: {x}) N.
admit.
Qed.

Section SchroederBernstein.

Theorem KnasterTarski_set: forall A, forall F:set->set,
    (forall U :e Power A, F U :e Power A)
 -> (forall U V :e Power A, U c= V -> F U c= F V)
 -> exists Y :e Power A, F Y = Y.
admit.
Qed.

Theorem image_In_Power : forall A B, forall f:set -> set, (forall x :e A, f x :e B) -> forall U :e Power A, {f x|x :e U} :e Power B.
admit.
Qed.

Theorem image_monotone : forall f:set -> set, forall U V, U c= V -> {f x|x :e U} c= {f x|x :e V}.
admit.
Qed.

Theorem setminus_antimonotone : forall A U V, U c= V -> A :\: V c= A :\: U.
admit.
Qed.

Theorem SchroederBernstein: forall A B, forall f g:set -> set, inj A B f -> inj B A g -> equip A B.
admit.
Qed.

Theorem atleastp_antisym_equip: forall A B, atleastp A B -> atleastp B A -> equip A B.
admit.
Qed.

End SchroederBernstein.

Section PigeonHole.

Theorem PigeonHole_nat : forall n, nat_p n -> forall f:set -> set, (forall i :e ordsucc n, f i :e n) -> ~(forall i j :e ordsucc n, f i = f j -> i = j).
admit.
Qed.

Theorem Pigeonhole_not_atleastp_ordsucc : forall n, nat_p n -> ~atleastp (ordsucc n) n.
admit.
Qed.

End PigeonHole.

Theorem Union_ordsucc_eq : forall n, nat_p n -> Union (ordsucc n) = n.
admit.
Qed.

Theorem cases_1: forall i :e 1, forall p:set->prop, p 0 -> p i.
admit.
Qed.

Theorem cases_2: forall i :e 2, forall p:set->prop, p 0 -> p 1 -> p i.
admit.
Qed.

Theorem neq_0_1 : 0 <> 1.
admit.
Qed.

Theorem neq_1_0 : 1 <> 0.
admit.
Qed.

Theorem neq_0_2 : 0 <> 2.
admit.
Qed.

Theorem neq_2_0 : 2 <> 0.
admit.
Qed.

Definition ordinal : set->prop := fun (alpha:set) => TransSet alpha /\ forall beta :e alpha, TransSet beta.

Theorem ordinal_TransSet : forall alpha:set, ordinal alpha -> TransSet alpha.
admit.
Qed.

Theorem ordinal_Empty : ordinal Empty.
admit.
Qed.

Theorem ordinal_Hered : forall alpha:set, ordinal alpha -> forall beta :e alpha, ordinal beta.
admit.
Qed.

Theorem TransSet_ordsucc : forall X:set, TransSet X -> TransSet (ordsucc X).
admit.
Qed.

Theorem ordinal_ordsucc : forall alpha:set, ordinal alpha -> ordinal (ordsucc alpha).
admit.
Qed.

Theorem nat_p_ordinal : forall n:set, nat_p n -> ordinal n.
admit.
Qed.

Theorem ordinal_1 : ordinal 1.
admit.
Qed.

Theorem ordinal_2 : ordinal 2.
admit.
Qed.

Theorem TransSet_ordsucc_In_Subq : forall X:set, TransSet X -> forall x :e X, ordsucc x c= X.
admit.
Qed.

Theorem ordinal_ordsucc_In_Subq : forall alpha, ordinal alpha -> forall beta :e alpha, ordsucc beta c= alpha.
admit.
Qed.

Theorem ordinal_trichotomy_or : forall alpha beta:set, ordinal alpha -> ordinal beta -> alpha :e beta \/ alpha = beta \/ beta :e alpha.
admit.
Qed.    

Theorem ordinal_trichotomy_or_impred : forall alpha beta:set, ordinal alpha -> ordinal beta -> forall p:prop, (alpha :e beta -> p) -> (alpha = beta -> p) -> (beta :e alpha -> p) -> p.
admit.
Qed.

Theorem ordinal_In_Or_Subq : forall alpha beta, ordinal alpha -> ordinal beta -> alpha :e beta \/ beta c= alpha.
admit.
Qed.

Theorem ordinal_linear : forall alpha beta, ordinal alpha -> ordinal beta -> alpha c= beta \/ beta c= alpha.
admit.
Qed.

Theorem ordinal_ordsucc_In_eq : forall alpha beta, ordinal alpha -> beta :e alpha -> ordsucc beta :e alpha \/ alpha = ordsucc beta.
admit.
Qed.

Theorem ordinal_lim_or_succ : forall alpha, ordinal alpha -> (forall beta :e alpha, ordsucc beta :e alpha) \/ (exists beta :e alpha, alpha = ordsucc beta).
admit.
Qed.

Theorem ordinal_ordsucc_In : forall alpha, ordinal alpha -> forall beta :e alpha, ordsucc beta :e ordsucc alpha.
admit.
Qed.

Theorem ordinal_famunion : forall X, forall F:set -> set, (forall x :e X, ordinal (F x)) -> ordinal (\/_ x :e X, F x).
admit.
Qed.

Theorem ordinal_binintersect : forall alpha beta, ordinal alpha -> ordinal beta -> ordinal (alpha :/\: beta).
admit.
Qed.

Theorem ordinal_binunion : forall alpha beta, ordinal alpha -> ordinal beta -> ordinal (alpha :\/: beta).
admit.
Qed.

Theorem ordinal_ind : forall p:set->prop, 
(forall alpha, ordinal alpha -> (forall beta :e alpha, p beta) -> p alpha)
->
forall alpha, ordinal alpha -> p alpha.
admit.
Qed.

Theorem least_ordinal_ex : forall p:set -> prop, (exists alpha, ordinal alpha /\ p alpha) -> exists alpha, ordinal alpha /\ p alpha /\ forall beta :e alpha, ~p beta.
admit.
Qed.

Theorem equip_Sing_1 : forall x, equip {x} 1.
admit.
Qed.

Theorem TransSet_In_ordsucc_Subq : forall x y, TransSet y -> x :e ordsucc y -> x c= y.
admit.
Qed.

Theorem exandE_i : forall P Q:set -> prop, (exists x, P x /\ Q x) -> forall r:prop, (forall x, P x -> Q x -> r) -> r.
admit.
Qed.

Theorem exandE_ii : forall P Q:(set -> set) -> prop, (exists x:set -> set, P x /\ Q x) -> forall p:prop, (forall x:set -> set, P x -> Q x -> p) -> p.
admit.
Qed.

Theorem exandE_iii : forall P Q:(set -> set -> set) -> prop, (exists x:set -> set -> set, P x /\ Q x) -> forall p:prop, (forall x:set -> set -> set, P x -> Q x -> p) -> p.
admit.
Qed.

Theorem exandE_iiii : forall P Q:(set -> set -> set -> set) -> prop, (exists x:set -> set -> set -> set, P x /\ Q x) -> forall p:prop, (forall x:set -> set -> set -> set, P x -> Q x -> p) -> p.
admit.
Qed.

Section Descr_ii.
Variable P : (set -> set) -> prop.
(* Parameter Descr_ii "a6e81668bfd1db6e6eb6a13bf66094509af176d9d0daccda274aa6582f6dcd7c" "3bae39e9880bbf5d70538d82bbb05caf44c2c11484d80d06dee0589d6f75178c" *)
Definition Descr_ii : set -> set := fun x:set => Eps_i (fun y => forall h:set -> set, P h -> h x = y).
Hypothesis Pex: exists f:set -> set, P f.
Hypothesis Puniq: forall f g:set -> set, P f -> P g -> f = g.

Theorem Descr_ii_prop : P Descr_ii.
admit.
Qed.

End Descr_ii.
Section Descr_iii.
Variable P : (set -> set -> set) -> prop.
(* Parameter Descr_iii "dc42f3fe5d0c55512ef81fe5d2ad0ff27c1052a6814b1b27f5a5dcb6d86240bf" "ca5fc17a582fdd4350456951ccbb37275637ba6c06694213083ed9434fe3d545" *)
Definition Descr_iii : set -> set -> set := fun x y:set => Eps_i (fun z => forall h:set -> set -> set, P h -> h x y = z).
Hypothesis Pex: exists f:set -> set -> set, P f.
Hypothesis Puniq: forall f g:set -> set -> set, P f -> P g -> f = g.

Theorem Descr_iii_prop : P Descr_iii.
admit.
Qed.

End Descr_iii.
Section Descr_Vo1.
Variable P : Vo 1 -> prop.
(* Parameter Descr_Vo1 "322bf09a1711d51a4512e112e1767cb2616a7708dc89d7312c8064cfee6e3315" "615c0ac7fca2b62596ed34285f29a77b39225d1deed75d43b7ae87c33ba37083" *)
Definition Descr_Vo1 : Vo 1 := fun x:set => forall h:set -> prop, P h -> h x.
Hypothesis Pex: exists f:Vo 1, P f.
Hypothesis Puniq: forall f g:Vo 1, P f -> P g -> f = g.

Theorem Descr_Vo1_prop : P Descr_Vo1.
admit.
Qed.

End Descr_Vo1.
Section If_ii.
Variable p:prop.
Variable f g:set -> set.
(* Parameter If_ii "e76df3235104afd8b513a92c00d3cc56d71dd961510bf955a508d9c2713c3f29" "17057f3db7be61b4e6bd237e7b37125096af29c45cb784bb9cc29b1d52333779" *)
Definition If_ii : set -> set := fun x => if p then f x else g x.

Theorem If_ii_1 : p -> If_ii = f.
admit.
Qed.

Theorem If_ii_0 : ~p -> If_ii = g.
admit.
Qed.

End If_ii.
Section If_iii.
Variable p:prop.
Variable f g:set -> set -> set.
(* Parameter If_iii "53034f33cbed012c3c6db42812d3964f65a258627a765f5bede719198af1d1ca" "3314762dce5a2e94b7e9e468173b047dd4a9fac6ee2c5f553c6ea15e9c8b7542" *)
Definition If_iii : set -> set -> set := fun x y => if p then f x y else g x y.

Theorem If_iii_1 : p -> If_iii = f.
admit.
Qed.

Theorem If_iii_0 : ~p -> If_iii = g.
admit.
Qed.

End If_iii.
Section EpsilonRec_i.
Variable F:set -> (set -> set) -> set.
Definition In_rec_i_G : set -> set -> prop :=
fun X Y =>
forall R:set->set->prop,
(forall X:set, forall f:set->set, (forall x :e X, R x (f x)) -> R X (F X f)) ->
R X Y.
(* Parameter In_rec_i "f97da687c51f5a332ff57562bd465232bc70c9165b0afe0a54e6440fc4962a9f" "fac413e747a57408ad38b3855d3cde8673f86206e95ccdadff2b5babaf0c219e" *)
Definition In_rec_i : set -> set := fun X => Eps_i (In_rec_i_G X).

Theorem In_rec_i_G_c : forall X:set, forall f:set->set, (forall x :e X, In_rec_i_G x (f x)) -> In_rec_i_G X (F X f).
admit.
Qed.

Theorem In_rec_i_G_inv : forall X:set, forall Y:set, In_rec_i_G X Y -> exists f:set->set, (forall x :e X, In_rec_i_G x (f x)) /\ Y = F X f.
admit.
Qed.

Hypothesis Fr:forall X:set, forall g h:set -> set, (forall x :e X, g x = h x) -> F X g = F X h.

Theorem In_rec_i_G_f : forall X:set, forall Y Z:set, In_rec_i_G X Y -> In_rec_i_G X Z -> Y = Z.
admit.
Qed.

Theorem In_rec_i_G_In_rec_i : forall X:set, In_rec_i_G X (In_rec_i X).
admit.
Qed.

Theorem In_rec_i_G_In_rec_i_d : forall X:set, In_rec_i_G X (F X In_rec_i).
admit.
Qed.

Theorem In_rec_i_eq : forall X:set, In_rec_i X = F X In_rec_i.
admit.
Qed.

End EpsilonRec_i.
Section EpsilonRec_ii.
Variable F:set -> (set -> (set -> set)) -> (set -> set).
Definition In_rec_G_ii : set -> (set -> set) -> prop :=
fun X Y =>
forall R:set->(set -> set)->prop,
(forall X:set, forall f:set->(set -> set), (forall x :e X, R x (f x)) -> R X (F X f)) ->
R X Y.
(* Parameter In_rec_ii "4d137cad40b107eb0fc2c707372525f1279575e6cadb4ebc129108161af3cedb" "f3c9abbc5074c0d68e744893a170de526469426a5e95400ae7fc81f74f412f7e" *)
Definition In_rec_ii : set -> (set -> set) := fun X => Descr_ii (In_rec_G_ii X).

Theorem In_rec_G_ii_c : forall X:set, forall f:set->(set -> set), (forall x :e X, In_rec_G_ii x (f x)) -> In_rec_G_ii X (F X f).
admit.
Qed.

Theorem In_rec_G_ii_inv : forall X:set, forall Y:(set -> set), In_rec_G_ii X Y -> exists f:set->(set -> set), (forall x :e X, In_rec_G_ii x (f x)) /\ Y = F X f.
admit.
Qed.

Hypothesis Fr:forall X:set, forall g h:set -> (set -> set), (forall x :e X, g x = h x) -> F X g = F X h.

Theorem In_rec_G_ii_f : forall X:set, forall Y Z:(set -> set), In_rec_G_ii X Y -> In_rec_G_ii X Z -> Y = Z.
admit.
Qed.

Theorem In_rec_G_ii_In_rec_ii : forall X:set, In_rec_G_ii X (In_rec_ii X).
admit.
Qed.

Theorem In_rec_G_ii_In_rec_ii_d : forall X:set, In_rec_G_ii X (F X In_rec_ii).
admit.
Qed.

Theorem In_rec_ii_eq : forall X:set, In_rec_ii X = F X In_rec_ii.
admit.
Qed.

End EpsilonRec_ii.
Section EpsilonRec_iii.
Variable F:set -> (set -> (set -> set -> set)) -> (set -> set -> set).
Definition In_rec_G_iii : set -> (set -> set -> set) -> prop :=
fun X Y =>
forall R:set->(set -> set -> set)->prop,
(forall X:set, forall f:set->(set -> set -> set), (forall x :e X, R x (f x)) -> R X (F X f)) ->
R X Y.
(* Parameter In_rec_iii "222f1b8dcfb0d2e33cc4b232e87cbcdfe5c4a2bdc5326011eb70c6c9aeefa556" "9b3a85b85e8269209d0ca8bf18ef658e56f967161bf5b7da5e193d24d345dd06" *)
Definition In_rec_iii : set -> (set -> set -> set) := fun X => Descr_iii (In_rec_G_iii X).

Theorem In_rec_G_iii_c : forall X:set, forall f:set->(set -> set -> set), (forall x :e X, In_rec_G_iii x (f x)) -> In_rec_G_iii X (F X f).
admit.
Qed.

Theorem In_rec_G_iii_inv : forall X:set, forall Y:(set -> set -> set), In_rec_G_iii X Y -> exists f:set->(set -> set -> set), (forall x :e X, In_rec_G_iii x (f x)) /\ Y = F X f.
admit.
Qed.

Hypothesis Fr:forall X:set, forall g h:set -> (set -> set -> set), (forall x :e X, g x = h x) -> F X g = F X h.

Theorem In_rec_G_iii_f : forall X:set, forall Y Z:(set -> set -> set), In_rec_G_iii X Y -> In_rec_G_iii X Z -> Y = Z.
admit.
Qed.

Theorem In_rec_G_iii_In_rec_iii : forall X:set, In_rec_G_iii X (In_rec_iii X).
admit.
Qed.

Theorem In_rec_G_iii_In_rec_iii_d : forall X:set, In_rec_G_iii X (F X In_rec_iii).
admit.
Qed.

Theorem In_rec_iii_eq : forall X:set, In_rec_iii X = F X In_rec_iii.
admit.
Qed.

End EpsilonRec_iii.
Section NatRec.
Variable z:set.
Variable f:set->set->set.
Let F : set->(set->set)->set := fun n g => if Union n :e n then f (Union n) (g (Union n)) else z.
Definition nat_primrec : set->set := In_rec_i F.

Theorem nat_primrec_r : forall X:set, forall g h:set -> set, (forall x :e X, g x = h x) -> F X g = F X h.
admit.
Qed.

Theorem nat_primrec_0 : nat_primrec 0 = z.
admit.
Qed.

Theorem nat_primrec_S : forall n:set, nat_p n -> nat_primrec (ordsucc n) = f n (nat_primrec n).
admit.
Qed.

End NatRec.

Section NatAdd.

Definition add_nat : set->set->set := fun n m:set => nat_primrec n (fun _ r => ordsucc r) m.
Infix + 360 right := add_nat.

Theorem add_nat_0R : forall n:set, n + 0 = n.
admit.
Qed.

Theorem add_nat_SR : forall n m:set, nat_p m -> n + ordsucc m = ordsucc (n + m).
admit.
Qed.

Theorem add_nat_p : forall n:set, nat_p n -> forall m:set, nat_p m -> nat_p (n + m).
admit.
Qed.

Theorem add_nat_1_1_2 : 1 + 1 = 2.
admit.
Qed.

Theorem add_nat_asso : forall n:set, nat_p n -> forall m:set, nat_p m -> forall k:set, nat_p k -> (n+m)+k = n+(m+k).
admit.
Qed.

Theorem add_nat_0L : forall m:set, nat_p m -> 0+m = m.
admit.
Qed.

Theorem add_nat_SL : forall n:set, nat_p n -> forall m:set, nat_p m -> ordsucc n + m = ordsucc (n+m).
admit.
Qed.

Theorem add_nat_com : forall n:set, nat_p n -> forall m:set, nat_p m -> n + m = m + n.
admit.
Qed.

Theorem add_nat_In_R: forall m, nat_p m -> forall k :e m, forall n, nat_p n -> k + n :e m + n.
admit.
Qed.

Theorem add_nat_In_L: forall n, nat_p n -> forall m, nat_p m -> forall k :e m, n + k :e n + m.
admit.
Qed.

Theorem add_nat_Subq_R: forall k, nat_p k -> forall m, nat_p m -> k c= m -> forall n, nat_p n -> k + n c= m + n.
admit.
Qed.

Theorem add_nat_Subq_L: forall n, nat_p n -> forall k, nat_p k -> forall m, nat_p m -> k c= m -> n + k c= n + m.
admit.
Qed.

Theorem add_nat_Subq_R' : forall m, nat_p m -> forall n, nat_p n -> m c= m + n.
admit.
Qed.

Theorem nat_Subq_add_ex: forall n, nat_p n -> forall m, nat_p m -> n c= m -> exists k, nat_p k /\ m = k + n.
admit.
Qed.

Theorem add_nat_cancel_R : forall k, nat_p k -> forall m, nat_p m -> forall n, nat_p n -> k + n = m + n -> k = m.
admit.
Qed.

End NatAdd.

Section NatMul.

Infix + 360 right := add_nat.

Definition mul_nat : set->set->set := fun n m:set => nat_primrec 0 (fun _ r => n + r) m.
Infix * 355 right := mul_nat.

Theorem mul_nat_0R : forall n:set, n * 0 = 0.
admit.
Qed.

Theorem mul_nat_SR : forall n m, nat_p m -> n * ordsucc m = n + n * m.
admit.
Qed.

Theorem mul_nat_1R: forall n, n * 1 = n.
admit.
Qed.

Theorem mul_nat_p : forall n:set, nat_p n -> forall m:set, nat_p m -> nat_p (n * m).
admit.
Qed.

Theorem mul_nat_0L : forall m:set, nat_p m -> 0 * m = 0.
admit.
Qed.

Theorem mul_nat_SL : forall n:set, nat_p n -> forall m:set, nat_p m -> ordsucc n * m = n * m + m.
admit.
Qed.

Theorem mul_nat_com : forall n:set, nat_p n -> forall m:set, nat_p m -> n * m = m * n.
admit.
Qed.

Theorem mul_add_nat_distrL : forall n:set, nat_p n -> forall m:set, nat_p m -> forall k:set, nat_p k -> n * (m + k) = n * m + n * k.
admit.
Qed.

Theorem mul_nat_asso : forall n:set, nat_p n -> forall m:set, nat_p m -> forall k:set, nat_p k -> (n*m)*k = n*(m*k).
admit.
Qed.

Theorem mul_nat_Subq_R : forall m n, nat_p m -> nat_p n -> m c= n -> forall k, nat_p k -> m * k c= n * k.
admit.
Qed.

Theorem mul_nat_Subq_L : forall m n, nat_p m -> nat_p n -> m c= n -> forall k, nat_p k -> k * m c= k * n.
admit.
Qed.

Theorem mul_nat_0_or_Subq: forall m, nat_p m -> forall n, nat_p n -> n = 0 \/ m c= m * n.
admit.
Qed.

(** If m times n = 0 for naturals m and n, then one must be 0. **)
Theorem mul_nat_0_inv : forall m, nat_p m -> forall n, nat_p n -> m * n = 0 -> m = 0 \/ n = 0.
admit.
Qed.

Theorem mul_nat_0m_1n_In: forall m, nat_p m -> forall n, nat_p n -> 0 :e m -> 1 :e n -> m :e m * n.
admit.
Qed.

Theorem nat_le1_cases: forall m, nat_p m -> m c= 1 -> m = 0 \/ m = 1.
admit.
Qed.

Definition Pi_nat : (set -> set) -> set -> set := fun f n =>
  nat_primrec 1 (fun i r => r * f i) n.

Theorem Pi_nat_0: forall f:set -> set, Pi_nat f 0 = 1.
admit.
Qed.

Theorem Pi_nat_S: forall f:set -> set, forall n, nat_p n -> Pi_nat f (ordsucc n) = Pi_nat f n * f n.
admit.
Qed.

Theorem Pi_nat_p: forall f:set -> set,
 forall n, nat_p n ->
     (forall i :e n, nat_p (f i))
  -> nat_p (Pi_nat f n).
admit.
Qed.

Theorem Pi_nat_0_inv: forall f:set->set,
  forall n, nat_p n ->
      (forall i :e n, nat_p (f i))
   -> Pi_nat f n = 0
   -> (exists i :e n, f i = 0).
admit.
Qed.

Definition exp_nat : set->set->set := fun n m:set => nat_primrec 1 (fun _ r => n * r) m.

Infix ^ 342 right := exp_nat.

Theorem exp_nat_0 : forall n, n ^ 0 = 1.
admit.
Qed.

Theorem exp_nat_S : forall n m, nat_p m -> n ^ (ordsucc m) = n * n ^ m.
admit.
Qed.

Theorem exp_nat_p : forall n, nat_p n -> forall m, nat_p m -> nat_p (n ^ m).
admit.
Qed.

Theorem exp_nat_1 : forall n, n ^ 1 = n.
admit.
Qed.

End NatMul.

Section form100_52.

Infix + 360 right := add_nat.
Infix * 355 right := mul_nat.
Infix ^ 342 right := exp_nat.

Theorem Subq_Sing0_1 : {0} c= 1.
admit.
Qed.

Theorem Subq_1_Sing0 : 1 c= {0}.
admit.
Qed.

Theorem eq_1_Sing0 : 1 = {0}.
admit.
Qed.

Theorem Power_0_Sing_0 : Power 0 = {0}.
admit.
Qed.

Theorem equip_finite_Power: forall n, nat_p n -> forall X,
  equip X n -> equip (Power X) (2 ^ n).
admit.
Qed.

End form100_52.

Theorem ZF_closed_E : forall U, ZF_closed U ->
 forall p:prop,
 (Union_closed U ->
  Power_closed U ->
  Repl_closed U -> p)
 -> p.
admit.
Qed.

Theorem ZF_Union_closed : forall U, ZF_closed U ->
  forall X :e U, Union X :e U.
admit.
Qed.

Theorem ZF_Power_closed : forall U, ZF_closed U ->
  forall X :e U, Power X :e U.
admit.
Qed.

Theorem ZF_Repl_closed : forall U, ZF_closed U ->
  forall X :e U, forall F:set->set, (forall x :e X, F x :e U) -> {F x|x:eX} :e U.
admit.
Qed.

Theorem ZF_UPair_closed : forall U, ZF_closed U ->
  forall x y :e U, {x,y} :e U.
admit.
Qed.

Theorem ZF_Sing_closed : forall U, ZF_closed U ->
  forall x :e U, {x} :e U.
admit.
Qed.

Theorem ZF_binunion_closed : forall U, ZF_closed U ->
  forall X Y :e U, (X :\/: Y) :e U.
admit.
Qed.

Theorem ZF_ordsucc_closed : forall U, ZF_closed U ->
  forall x :e U, ordsucc x :e U.
admit.
Qed.

Theorem nat_p_UnivOf_Empty : forall n:set, nat_p n -> n :e UnivOf Empty.
admit.
Qed.

(* Unicode omega "3c9" *)
(* Parameter omega "39cdf86d83c7136517f803d29d0c748ea45a274ccbf9b8488f9cda3e21f4b47c" "6fc30ac8f2153537e397b9ff2d9c981f80c151a73f96cf9d56ae2ee27dfd1eb2" *)
Definition omega : set := {n :e UnivOf Empty|nat_p n}.

Theorem omega_nat_p : forall n :e omega, nat_p n.
admit.
Qed.

Theorem nat_p_omega : forall n:set, nat_p n -> n :e omega.
admit.
Qed.

Theorem omega_ordsucc : forall n :e omega, ordsucc n :e omega.
admit.
Qed.

Theorem form100_22_v2: forall f:set -> set, ~inj (Power omega) omega f.
admit.
Qed.

Theorem form100_22_v3: forall g:set -> set, ~surj omega (Power omega) g.
admit.
Qed.

Theorem form100_22_v1: ~equip omega (Power omega).
admit.
Qed.

Theorem omega_TransSet : TransSet omega.
admit.
Qed.

Theorem omega_ordinal : ordinal omega.
admit.
Qed.

Theorem ordsucc_omega_ordinal: ordinal (ordsucc omega).
admit.
Qed.

Definition finite : set -> prop := fun X => exists n :e omega, equip X n.

Theorem nat_finite: forall n, nat_p n -> finite n.
admit.
Qed.

Theorem finite_ind : forall p:set -> prop,
    p Empty
 -> (forall X y, finite X -> y /:e X -> p X -> p (X :\/: {y}))
 -> forall X, finite X -> p X.
admit.
Qed.

Theorem finite_Empty: finite 0.
admit.
Qed.

Theorem Sing_finite: forall x, finite {x}.
admit.
Qed.

Theorem adjoin_finite: forall X y, finite X -> finite (X :\/: {y}).
admit.
Qed.

Theorem binunion_finite: forall X, finite X -> forall Y, finite Y -> finite (X :\/: Y).
admit.
Qed.

Theorem famunion_nat_finite : forall X:set -> set, forall n, nat_p n -> (forall i :e n, finite (X i)) -> finite (\/_ i :e n, X i).
admit.
Qed.

Theorem Subq_finite : forall X, finite X -> forall Y, Y c= X -> finite Y.
admit.
Qed.

Definition infinite : set -> prop := fun A => ~finite A.

Section InfinitePrimes.

Infix + 360 right := add_nat.
Infix * 355 right := mul_nat.

Definition divides_nat : set -> set -> prop :=
  fun m n => m :e omega /\ n :e omega /\ exists k :e omega, m * k = n.

Theorem divides_nat_ref: forall n, nat_p n -> divides_nat n n.
admit.
Qed.

Theorem divides_nat_tra: forall k m n, divides_nat k m -> divides_nat m n -> divides_nat k n.
admit.
Qed.

Definition prime_nat : set -> prop :=
  fun n => n :e omega /\ 1 :e n /\ forall k :e omega, divides_nat k n -> k = 1 \/ k = n.

Theorem divides_nat_mulR: forall m n :e omega, divides_nat m (m * n).
admit.
Qed.

Theorem divides_nat_mulL: forall m n :e omega, divides_nat n (m * n).
admit.
Qed.

Theorem Pi_nat_divides: forall f:set->set,
  forall n, nat_p n ->
      (forall i :e n, nat_p (f i))
   -> (forall i :e n, divides_nat (f i) (Pi_nat f n)).
admit.
Qed.

Definition composite_nat : set -> prop :=
  fun n => n :e omega /\ exists k m :e omega, 1 :e k /\ 1 :e m /\ k * m = n.

Theorem prime_nat_or_composite_nat: forall n :e omega, 1 :e n -> prime_nat n \/ composite_nat n.
admit.
Qed.

Theorem prime_nat_divisor_ex: forall n, nat_p n -> 1 :e n -> exists p, prime_nat p /\ divides_nat p n.
admit.
Qed.

Theorem nat_1In_not_divides_ordsucc: forall m n, 1 :e m -> divides_nat m n -> ~divides_nat m (ordsucc n).
admit.
Qed.

Definition primes : set := {n :e omega|prime_nat n}.

Theorem form100_11_infinite_primes: infinite primes.
admit.
Qed.

End InfinitePrimes.

Section InfiniteRamsey.

Infix + 360 right := add_nat.

Theorem atleastp_omega_infinite: forall X, atleastp omega X -> infinite X.
admit.
Qed.

Theorem infinite_remove1: forall X, infinite X -> forall y, infinite (X :\: {y}).
admit.
Qed.

Theorem infinite_Finite_Subq_ex: forall X, infinite X ->
  forall n, nat_p n -> exists Y c= X, equip Y n.
admit.
Qed.

Theorem infiniteRamsey_lem: forall X, forall f g f':set -> set,
    infinite X
 -> (forall Z c= X, infinite Z -> f Z c= Z /\ infinite (f Z))
 -> (forall Z c= X, infinite Z -> g Z :e Z /\ g Z /:e f Z)
 -> f' 0 = f X
 -> (forall m, nat_p m -> f' (ordsucc m) = f (f' m))
 -> (forall m, nat_p m -> f' m c= X /\ infinite (f' m))
 /\ (forall m m' :e omega, m c= m' -> f' m' c= f' m)
 /\ (forall m m' :e omega, g (f' m) = g (f' m') -> m = m').
admit.
Qed.

Theorem infiniteRamsey: forall c, nat_p c -> forall n, nat_p n ->
  forall X, infinite X -> forall C:set -> set,
    (forall Y c= X, equip Y n -> C Y :e c)
 -> exists H c= X, exists i :e c, infinite H /\ forall Y c= H, equip Y n -> C Y = i.
admit.
Qed.

End InfiniteRamsey.

(*** Injection of set into itself that will correspond to x |-> (1,x) after pairing is defined. ***)
Definition Inj1 : set -> set := In_rec_i (fun X f => {0} :\/: {f x|x :e X}).

Theorem Inj1_eq : forall X:set, Inj1 X = {0} :\/: {Inj1 x|x :e X}.
admit.
Qed.

Theorem Inj1I1 : forall X:set, 0 :e Inj1 X.
admit.
Qed.

Theorem Inj1I2 : forall X x:set, x :e X -> Inj1 x :e Inj1 X.
admit.
Qed.

Theorem Inj1E : forall X y:set, y :e Inj1 X -> y = 0 \/ exists x :e X, y = Inj1 x.
admit.
Qed.

Theorem Inj1NE1 : forall x:set, Inj1 x <> 0.
admit.
Qed.

Theorem Inj1NE2 : forall x:set, Inj1 x /:e {0}.
admit.
Qed.

(*** Injection of set into itself that will correspond to x |-> (0,x) after pairing is defined. ***)
Definition Inj0 : set -> set := fun X => {Inj1 x|x :e X}.

Theorem Inj0I : forall X x:set, x :e X -> Inj1 x :e Inj0 X.
admit.
Qed.

Theorem Inj0E : forall X y:set, y :e Inj0 X -> exists x:set, x :e X /\ y = Inj1 x.
admit.
Qed.

(*** Unj : Left inverse of Inj1 and Inj0 ***)
Definition Unj : set -> set := In_rec_i (fun X f => {f x|x :e X :\: {0}}).

Theorem Unj_eq : forall X:set, Unj X = {Unj x|x :e X :\: {0}}.
admit.
Qed.

Theorem Unj_Inj1_eq : forall X:set, Unj (Inj1 X) = X.
admit.
Qed.

Theorem Inj1_inj : forall X Y:set, Inj1 X = Inj1 Y -> X = Y.
admit.
Qed.

Theorem Unj_Inj0_eq : forall X:set, Unj (Inj0 X) = X.
admit.
Qed.

Theorem Inj0_inj : forall X Y:set, Inj0 X = Inj0 Y -> X = Y.
admit.
Qed.

Theorem Inj0_0 : Inj0 0 = 0.
admit.
Qed.

Theorem Inj0_Inj1_neq : forall X Y:set, Inj0 X <> Inj1 Y.
admit.
Qed.

(*** setsum ***)
Definition setsum : set -> set -> set := fun X Y => {Inj0 x|x :e X} :\/: {Inj1 y|y :e Y}.
(* Unicode :+: "002b" *)
Infix :+: 450 left := setsum.

Theorem Inj0_setsum : forall X Y x:set, x :e X -> Inj0 x :e X :+: Y.
admit.
Qed.

Theorem Inj1_setsum : forall X Y y:set, y :e Y -> Inj1 y :e X :+: Y.
admit.
Qed.

Theorem setsum_Inj_inv : forall X Y z:set, z :e X :+: Y -> (exists x :e X, z = Inj0 x) \/ (exists y :e Y, z = Inj1 y).
admit.
Qed.

Theorem Inj0_setsum_0L : forall X:set, 0 :+: X = Inj0 X.
admit.
Qed.

Theorem Inj1_setsum_1L : forall X:set, 1 :+: X = Inj1 X.
admit.
Qed.

Section pair_setsum.
Let pair := setsum.
Definition proj0 : set -> set := fun Z => {Unj z|z :e Z, exists x:set, Inj0 x = z}.
Definition proj1 : set -> set := fun Z => {Unj z|z :e Z, exists y:set, Inj1 y = z}.

Theorem Inj0_pair_0_eq : Inj0 = pair 0.
admit.
Qed.

Theorem Inj1_pair_1_eq : Inj1 = pair 1.
admit.
Qed.

Theorem pairI0 : forall X Y x, x :e X -> pair 0 x :e pair X Y.
admit.
Qed.

Theorem pairI1 : forall X Y y, y :e Y -> pair 1 y :e pair X Y.
admit.
Qed.

Theorem pairE : forall X Y z, z :e pair X Y -> (exists x :e X, z = pair 0 x) \/ (exists y :e Y, z = pair 1 y).
admit.
Qed.

Theorem pairE0 : forall X Y x, pair 0 x :e pair X Y -> x :e X.
admit.
Qed.

Theorem pairE1 : forall X Y y, pair 1 y :e pair X Y -> y :e Y.
admit.
Qed.

Theorem proj0I : forall w u:set, pair 0 u :e w -> u :e proj0 w.
admit.
Qed.

Theorem proj0E : forall w u:set, u :e proj0 w -> pair 0 u :e w.
admit.
Qed.

Theorem proj1I : forall w u:set, pair 1 u :e w -> u :e proj1 w.
admit.
Qed.

Theorem proj1E : forall w u:set, u :e proj1 w -> pair 1 u :e w.
admit.
Qed.

Theorem proj0_pair_eq : forall X Y:set, proj0 (pair X Y) = X.
admit.
Qed.

Theorem proj1_pair_eq : forall X Y:set, proj1 (pair X Y) = Y.
admit.
Qed.

Opaque add_nat mul_nat omega ordsucc setminus binintersect ReplSep Sep famunion binunion Sing UPair exactly1of2 If_i If_ii If_iii Descr_Vo1 Descr_iii Descr_ii inv In_rec_i In_rec_ii In_rec_iii.

(*** Sigma X Y = {(x,y) | x in X, y in Y x} ***)
Definition Sigma : set -> (set -> set) -> set :=
fun X Y => \/_ x :e X, {pair x y|y :e Y x}.
(* Unicode Sigma_ "2211" *)
Binder+ Sigma_ , := Sigma.

Theorem Sigma_eta_proj0_proj1 : forall X:set, forall Y:set -> set, forall z :e (Sigma_ x :e X, Y x), pair (proj0 z) (proj1 z) = z /\ proj0 z :e X /\ proj1 z :e Y (proj0 z).
admit.
Qed.

Theorem proj0_Sigma : forall X:set, forall Y:set -> set, forall z:set, z :e (Sigma_ x :e X, Y x) -> proj0 z :e X.
admit.
Qed.

Theorem proj1_Sigma : forall X:set, forall Y:set -> set, forall z:set, z :e (Sigma_ x :e X, Y x) -> proj1 z :e Y (proj0 z).
admit.
Qed.

Theorem pair_Sigma : forall X:set, forall Y:set -> set, forall x :e X, forall y :e Y x, pair x y :e Sigma_ x :e X, Y x.
admit.
Qed.

Theorem pair_Sigma_E1 : forall X:set, forall Y:set->set, forall x y:set, pair x y :e (Sigma_ x :e X, Y x) -> y :e Y x.
admit.
Qed.

Theorem Sigma_E : forall X:set, forall Y:set->set, forall z:set, z :e (Sigma_ x :e X, Y x) -> exists x :e X, exists y :e Y x, z = pair x y.
admit.
Qed.

Definition setprod : set->set->set := fun X Y:set => Sigma_ x :e X, Y.
(* Unicode :*: "2a2f" *)
Infix :*: 440 left := setprod.
(*** lam X F = {(x,y) | x :e X, y :e F x} = \/_{x :e X} {(x,y) | y :e (F x)} = Sigma X F ***)
Let lam : set -> (set -> set) -> set := Sigma.
(***  ap f x = {proj1 z | z :e f,  exists y, z = pair x y}} ***)
Definition ap : set -> set -> set := fun f x => {proj1 z|z :e f, exists y:set, z = pair x y}.
Notation SetImplicitOp ap.
Notation SetLam Sigma.

Theorem lamI : forall X:set, forall F:set->set, forall x :e X, forall y :e F x, pair x y :e fun x :e X => F x.
admit.
Qed.

Theorem lamE : forall X:set, forall F:set->set, forall z:set, z :e (fun x :e X => F x) -> exists x :e X, exists y :e F x, z = pair x y.
admit.
Qed.

Theorem apI : forall f x y, pair x y :e f -> y :e f x.
admit.
Qed.

Theorem apE : forall f x y, y :e f x -> pair x y :e f.
admit.
Qed.

Theorem beta : forall X:set, forall F:set -> set, forall x:set, x :e X -> (fun x :e X => F x) x = F x.
admit.
Qed.

Theorem proj0_ap_0 : forall u, proj0 u = u 0.
admit.
Qed.

Theorem proj1_ap_1 : forall u, proj1 u = u 1.
admit.
Qed.

Theorem pair_ap_0 : forall x y:set, (pair x y) 0 = x.
admit.
Qed.

Theorem pair_ap_1 : forall x y:set, (pair x y) 1 = y.
admit.
Qed.

Theorem ap0_Sigma : forall X:set, forall Y:set -> set, forall z:set, z :e (Sigma_ x :e X, Y x) -> (z 0) :e X.
admit.
Qed.

Theorem ap1_Sigma : forall X:set, forall Y:set -> set, forall z:set, z :e (Sigma_ x :e X, Y x) -> (z 1) :e (Y (z 0)).
admit.
Qed.

Definition pair_p:set->prop
:= fun u:set => pair (u 0) (u 1) = u.

Theorem pair_p_I : forall x y, pair_p (pair x y).
admit.
Qed.

Theorem Subq_2_UPair01 : 2 c= {0,1}.
admit.
Qed.

Theorem tuple_pair : forall x y:set, pair x y = (x,y).
admit.
Qed.

Definition Pi : set -> (set -> set) -> set := fun X Y => {f :e Power (Sigma_ x :e X, Union (Y x)) | forall x :e X, f x :e Y x}.
(* Unicode Pi_ "220f" *)
Binder+ Pi_ , := Pi.

Theorem PiI : forall X:set, forall Y:set->set, forall f:set,
    (forall u :e f, pair_p u /\ u 0 :e X) -> (forall x :e X, f x :e Y x) -> f :e Pi_ x :e X, Y x.
admit.
Qed.

Theorem lam_Pi : forall X:set, forall Y:set -> set, forall F:set -> set,
 (forall x :e X, F x :e Y x) -> (fun x :e X => F x) :e (Pi_ x :e X, Y x).
admit.
Qed.

Theorem ap_Pi : forall X:set, forall Y:set -> set, forall f:set, forall x:set, f :e (Pi_ x :e X, Y x) -> x :e X -> f x :e Y x.
admit.
Qed.

Definition setexp : set->set->set := fun X Y:set => Pi_ y :e Y, X.
(* Superscript :^: *)
Infix :^: 430 left := setexp.

Theorem pair_tuple_fun : pair = (fun x y => (x,y)).
admit.
Qed.

Section Tuples.
Variable x0 x1: set.

Theorem tuple_2_0_eq: (x0,x1) 0 = x0.
admit.
Qed.

Theorem tuple_2_1_eq: (x0,x1) 1 = x1.
admit.
Qed.

End Tuples.

Theorem ReplEq_setprod_ext : forall X Y, forall F G:set -> set -> set, (forall x :e X, forall y :e Y, F x y = G x y) -> {F (w 0) (w 1)|w :e X :*: Y} = {G (w 0) (w 1)|w :e X :*: Y}.
admit.
Qed.

Theorem lamI2 : forall X, forall F:set->set, forall x :e X, forall y :e F x, (x,y) :e fun x :e X => F x.
admit.
Qed.

Theorem tuple_2_Sigma : forall X:set, forall Y:set -> set, forall x :e X, forall y :e Y x, (x,y) :e Sigma_ x :e X, Y x.
admit.
Qed.

Theorem tuple_2_setprod : forall X:set, forall Y:set, forall x :e X, forall y :e Y, (x,y) :e X :*: Y.
admit.
Qed.

End pair_setsum.
(* Unicode Sigma_ "2211" *)
Binder+ Sigma_ , := Sigma.
(* Unicode :*: "2a2f" *)
Infix :*: 440 left := setprod.
(* Unicode Pi_ "220f" *)
Binder+ Pi_ , := Pi.
(* Superscript :^: *)
Infix :^: 430 left := setexp.
(* Parameter DescrR_i_io_1 "1f005fdad5c6f98763a15a5e5539088f5d43b7d1be866b0b204fda1ce9ed9248" "1d3fd4a14ef05bd43f5c147d7966cf05fd2fed808eea94f56380454b9a6044b2" *)
Definition DescrR_i_io_1 : (set->(set->prop)->prop) -> set := fun R => Eps_i (fun x => (exists y:set -> prop, R x y) /\ (forall y z:set -> prop, R x y -> R x z -> y = z)).
(* Parameter DescrR_i_io_2 "28d8599686476258c12dcc5fc5f5974335febd7d5259e1a8e5918b7f9b91ca03" "768eb2ad186988375e6055394e36e90c81323954b8a44eb08816fb7a84db2272" *)
Definition DescrR_i_io_2 : (set->(set->prop)->prop) -> set->prop := fun R => Descr_Vo1 (fun y => R (DescrR_i_io_1 R) y).

Theorem DescrR_i_io_12 : forall R:set->(set->prop)->prop, (exists x, (exists y:set->prop, R x y) /\ (forall y z:set -> prop, R x y -> R x z -> y = z)) -> R (DescrR_i_io_1 R) (DescrR_i_io_2 R).
admit.
Qed.

(** Conway describes this way of formalizing in ZF in an appendix to Part Zero of his book,
    but rejects formalization in favor of "Mathematician's Liberation."
 **)
Definition PNoEq_ : set -> (set -> prop) -> (set -> prop) -> prop
 := fun alpha p q => forall beta :e alpha, p beta <-> q beta.

Theorem PNoEq_ref_ : forall alpha, forall p:set -> prop, PNoEq_ alpha p p.
admit.
Qed.

Theorem PNoEq_sym_ : forall alpha, forall p q:set -> prop, PNoEq_ alpha p q -> PNoEq_ alpha q p.
admit.
Qed.

Theorem PNoEq_tra_ : forall alpha, forall p q r:set -> prop, PNoEq_ alpha p q -> PNoEq_ alpha q r -> PNoEq_ alpha p r.
admit.
Qed.

Theorem PNoEq_antimon_ : forall p q:set -> prop, forall alpha, ordinal alpha -> forall beta :e alpha, PNoEq_ alpha p q -> PNoEq_ beta p q.
admit.
Qed.

Definition PNoLt_ : set -> (set -> prop) -> (set -> prop) -> prop
 := fun alpha p q => exists beta :e alpha, PNoEq_ beta p q /\ ~p beta /\ q beta.

Theorem PNoLt_E_ : forall alpha, forall p q:set -> prop, PNoLt_ alpha p q ->
  forall R:prop, (forall beta, beta :e alpha -> PNoEq_ beta p q -> ~p beta -> q beta -> R) -> R.
admit.
Qed.

Theorem PNoLt_irref_ : forall alpha, forall p:set -> prop, ~PNoLt_ alpha p p.
admit.
Qed.

Theorem PNoLt_mon_ : forall p q:set -> prop, forall alpha, ordinal alpha -> forall beta :e alpha, PNoLt_ beta p q -> PNoLt_ alpha p q.
admit.
Qed.

Theorem PNoLt_trichotomy_or_ : forall p q:set -> prop, forall alpha, ordinal alpha
  -> PNoLt_ alpha p q \/ PNoEq_ alpha p q \/ PNoLt_ alpha q p.
admit.
Qed.

(* Parameter PNoLt "2336eb45d48549dd8a6a128edc17a8761fd9043c180691483bcf16e1acc9f00a" "8f57a05ce4764eff8bc94b278352b6755f1a46566cd7220a5488a4a595a47189" *)
Definition PNoLt : set -> (set -> prop) -> set -> (set -> prop) -> prop
 := fun alpha p beta q =>
        PNoLt_ (alpha :/\: beta) p q
     \/ alpha :e beta /\ PNoEq_ alpha p q /\ q alpha
     \/ beta :e alpha /\ PNoEq_ beta p q /\ ~p beta.

Theorem PNoLtI1 : forall alpha beta, forall p q:set -> prop,
  PNoLt_ (alpha :/\: beta) p q -> PNoLt alpha p beta q.
admit.
Qed.

Theorem PNoLtI2 : forall alpha beta, forall p q:set -> prop,
  alpha :e beta -> PNoEq_ alpha p q -> q alpha -> PNoLt alpha p beta q.
admit.
Qed.

Theorem PNoLtI3 : forall alpha beta, forall p q:set -> prop,
  beta :e alpha -> PNoEq_ beta p q -> ~p beta -> PNoLt alpha p beta q.
admit.
Qed.

Theorem PNoLtE : forall alpha beta, forall p q:set -> prop,
  PNoLt alpha p beta q ->
  forall R:prop,
      (PNoLt_ (alpha :/\: beta) p q -> R)
   -> (alpha :e beta -> PNoEq_ alpha p q -> q alpha -> R)
   -> (beta :e alpha -> PNoEq_ beta p q -> ~p beta -> R)
   -> R.
admit.
Qed.

Theorem PNoLt_irref : forall alpha, forall p:set -> prop, ~PNoLt alpha p alpha p.
admit.
Qed.

Theorem PNoLt_trichotomy_or : forall alpha beta, forall p q:set -> prop,
 ordinal alpha -> ordinal beta ->
 PNoLt alpha p beta q \/ alpha = beta /\ PNoEq_ alpha p q \/ PNoLt beta q alpha p.
admit.
Qed.

Theorem PNoLtEq_tra : forall alpha beta, ordinal alpha -> ordinal beta -> forall p q r:set -> prop, PNoLt alpha p beta q -> PNoEq_ beta q r -> PNoLt alpha p beta r.
admit.
Qed.

Theorem PNoEqLt_tra : forall alpha beta, ordinal alpha -> ordinal beta -> forall p q r:set -> prop, PNoEq_ alpha p q -> PNoLt alpha q beta r -> PNoLt alpha p beta r.
admit.
Qed.

Theorem PNoLt_tra : forall alpha beta gamma, ordinal alpha -> ordinal beta -> ordinal gamma -> forall p q r:set -> prop, PNoLt alpha p beta q -> PNoLt beta q gamma r -> PNoLt alpha p gamma r.
admit.
Qed.

Definition PNoLe : set -> (set -> prop) -> set -> (set -> prop) -> prop
   := fun alpha p beta q => PNoLt alpha p beta q \/ alpha = beta /\ PNoEq_ alpha p q.

Theorem PNoLeI1 : forall alpha beta, forall p q:set -> prop,
   PNoLt alpha p beta q -> PNoLe alpha p beta q.
admit.
Qed.

Theorem PNoLeI2 : forall alpha, forall p q:set -> prop,
   PNoEq_ alpha p q -> PNoLe alpha p alpha q.
admit.
Qed.

Theorem PNoLe_ref : forall alpha, forall p:set -> prop, PNoLe alpha p alpha p.
admit.
Qed.

Theorem PNoLe_antisym : forall alpha beta, ordinal alpha -> ordinal beta ->
 forall p q:set -> prop,
 PNoLe alpha p beta q -> PNoLe beta q alpha p -> alpha = beta /\ PNoEq_ alpha p q.
admit.
Qed.

Theorem PNoLtLe_tra : forall alpha beta gamma, ordinal alpha -> ordinal beta -> ordinal gamma -> forall p q r:set -> prop, PNoLt alpha p beta q -> PNoLe beta q gamma r -> PNoLt alpha p gamma r.
admit.
Qed.

Theorem PNoLeLt_tra : forall alpha beta gamma, ordinal alpha -> ordinal beta -> ordinal gamma -> forall p q r:set -> prop, PNoLe alpha p beta q -> PNoLt beta q gamma r -> PNoLt alpha p gamma r.
admit.
Qed.

Theorem PNoEqLe_tra : forall alpha beta, ordinal alpha -> ordinal beta -> forall p q r:set -> prop, PNoEq_ alpha p q -> PNoLe alpha q beta r -> PNoLe alpha p beta r.
admit.
Qed.

Theorem PNoLe_tra : forall alpha beta gamma, ordinal alpha -> ordinal beta -> ordinal gamma -> forall p q r:set -> prop, PNoLe alpha p beta q -> PNoLe beta q gamma r -> PNoLe alpha p gamma r.
admit.
Qed.

Definition PNo_downc : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
 := fun L alpha p => exists beta, ordinal beta /\ exists q:set -> prop, L beta q /\ PNoLe alpha p beta q.
Definition PNo_upc : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
 := fun R alpha p => exists beta, ordinal beta /\ exists q:set -> prop, R beta q /\ PNoLe beta q alpha p.

Theorem PNoLe_downc : forall L:set -> (set -> prop) -> prop, forall alpha beta, forall p q:set -> prop,
  ordinal alpha -> ordinal beta ->
  PNo_downc L alpha p -> PNoLe beta q alpha p -> PNo_downc L beta q.
admit.
Qed.

Theorem PNo_downc_ref : forall L:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p:set -> prop, L alpha p -> PNo_downc L alpha p.
admit.
Qed.

Theorem PNo_upc_ref : forall R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p:set -> prop, R alpha p -> PNo_upc R alpha p.
admit.
Qed.

Theorem PNoLe_upc : forall R:set -> (set -> prop) -> prop, forall alpha beta, forall p q:set -> prop,
  ordinal alpha -> ordinal beta ->
  PNo_upc R alpha p -> PNoLe alpha p beta q -> PNo_upc R beta q.
admit.
Qed.

Definition PNoLt_pwise : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> prop
  := fun L R => forall gamma, ordinal gamma -> forall p:set -> prop, L gamma p -> forall delta, ordinal delta -> forall q:set -> prop, R delta q -> PNoLt gamma p delta q.

Theorem PNoLt_pwise_downc_upc : forall L R:set -> (set -> prop) -> prop,
    PNoLt_pwise L R -> PNoLt_pwise (PNo_downc L) (PNo_upc R).
admit.
Qed.

Definition PNo_rel_strict_upperbd : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L alpha p =>
       forall beta :e alpha, forall q:set -> prop, PNo_downc L beta q -> PNoLt beta q alpha p.
Definition PNo_rel_strict_lowerbd : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun R alpha p =>
       forall beta :e alpha, forall q:set -> prop, PNo_upc R beta q -> PNoLt alpha p beta q.
Definition PNo_rel_strict_imv : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R alpha p => PNo_rel_strict_upperbd L alpha p /\ PNo_rel_strict_lowerbd R alpha p.

Theorem PNoEq_rel_strict_upperbd : forall L:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_rel_strict_upperbd L alpha p -> PNo_rel_strict_upperbd L alpha q.
admit.
Qed.

Theorem PNo_rel_strict_upperbd_antimon : forall L:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p:set -> prop, forall beta :e alpha,
  PNo_rel_strict_upperbd L alpha p -> PNo_rel_strict_upperbd L beta p.
admit.
Qed.

Theorem PNoEq_rel_strict_lowerbd : forall R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_rel_strict_lowerbd R alpha p -> PNo_rel_strict_lowerbd R alpha q.
admit.
Qed.

Theorem PNo_rel_strict_lowerbd_antimon : forall R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p:set -> prop, forall beta :e alpha,
  PNo_rel_strict_lowerbd R alpha p -> PNo_rel_strict_lowerbd R beta p.
admit.
Qed.

Theorem PNoEq_rel_strict_imv : forall L R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_rel_strict_imv L R alpha p -> PNo_rel_strict_imv L R alpha q.
admit.
Qed.

Theorem PNo_rel_strict_imv_antimon : forall L R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p:set -> prop, forall beta :e alpha,
  PNo_rel_strict_imv L R alpha p -> PNo_rel_strict_imv L R beta p.
admit.
Qed.

Definition PNo_rel_strict_uniq_imv : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R alpha p => PNo_rel_strict_imv L R alpha p /\ forall q:set -> prop, PNo_rel_strict_imv L R alpha q -> PNoEq_ alpha p q.
Definition PNo_rel_strict_split_imv : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R alpha p =>
         PNo_rel_strict_imv L R (ordsucc alpha) (fun delta => p delta /\ delta <> alpha)
      /\ PNo_rel_strict_imv L R (ordsucc alpha) (fun delta => p delta \/ delta = alpha).

Theorem PNo_extend0_eq : forall alpha, forall p:set -> prop, PNoEq_ alpha p (fun delta => p delta /\ delta <> alpha).
admit.
Qed.

Theorem PNo_extend1_eq : forall alpha, forall p:set -> prop, PNoEq_ alpha p (fun delta => p delta \/ delta = alpha).
admit.
Qed.

Theorem PNo_rel_imv_ex : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha ->
      (exists p:set -> prop, PNo_rel_strict_uniq_imv L R alpha p)
   \/ (exists tau :e alpha, exists p:set -> prop, PNo_rel_strict_split_imv L R tau p).
admit.
Qed.

Definition PNo_lenbdd : set -> (set -> (set -> prop) -> prop) -> prop
  := fun alpha L => forall beta, forall p:set -> prop, L beta p -> beta :e alpha.

Theorem PNo_lenbdd_strict_imv_extend0 : forall L R:set -> (set -> prop) -> prop,
  forall alpha, ordinal alpha -> PNo_lenbdd alpha L -> PNo_lenbdd alpha R ->
  forall p:set -> prop,
  PNo_rel_strict_imv L R alpha p -> PNo_rel_strict_imv L R (ordsucc alpha) (fun delta => p delta /\ delta <> alpha).
admit.
Qed.

Theorem PNo_lenbdd_strict_imv_extend1 : forall L R:set -> (set -> prop) -> prop,
  forall alpha, ordinal alpha -> PNo_lenbdd alpha L -> PNo_lenbdd alpha R ->
  forall p:set -> prop,
  PNo_rel_strict_imv L R alpha p -> PNo_rel_strict_imv L R (ordsucc alpha) (fun delta => p delta \/ delta = alpha).
admit.
Qed.

Theorem PNo_lenbdd_strict_imv_split : forall L R:set -> (set -> prop) -> prop,
  forall alpha, ordinal alpha -> PNo_lenbdd alpha L -> PNo_lenbdd alpha R ->
  forall p:set -> prop,
  PNo_rel_strict_imv L R alpha p -> PNo_rel_strict_split_imv L R alpha p.
admit.
Qed.

Theorem PNo_rel_imv_bdd_ex : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> exists beta :e ordsucc alpha,
      exists p:set -> prop, PNo_rel_strict_split_imv L R beta p.
admit.
Qed.

Definition PNo_strict_upperbd : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L alpha p =>
       forall beta, ordinal beta -> forall q:set -> prop, L beta q -> PNoLt beta q alpha p.
Definition PNo_strict_lowerbd : (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun R alpha p =>
       forall beta, ordinal beta -> forall q:set -> prop, R beta q -> PNoLt alpha p beta q.
Definition PNo_strict_imv : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R alpha p => PNo_strict_upperbd L alpha p /\ PNo_strict_lowerbd R alpha p.

Theorem PNoEq_strict_upperbd : forall L:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_strict_upperbd L alpha p -> PNo_strict_upperbd L alpha q.
admit.
Qed.

Theorem PNoEq_strict_lowerbd : forall R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_strict_lowerbd R alpha p -> PNo_strict_lowerbd R alpha q.
admit.
Qed.

Theorem PNoEq_strict_imv : forall L R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha -> forall p q:set -> prop,
  PNoEq_ alpha p q -> PNo_strict_imv L R alpha p -> PNo_strict_imv L R alpha q.
admit.
Qed.

Theorem PNo_strict_upperbd_imp_rel_strict_upperbd : forall L:set -> (set -> prop) -> prop, forall alpha, ordinal alpha ->
  forall beta :e ordsucc alpha, forall p:set -> prop,
   PNo_strict_upperbd L alpha p -> PNo_rel_strict_upperbd L beta p.
admit.
Qed.

Theorem PNo_strict_lowerbd_imp_rel_strict_lowerbd : forall R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha ->
  forall beta :e ordsucc alpha, forall p:set -> prop,
   PNo_strict_lowerbd R alpha p -> PNo_rel_strict_lowerbd R beta p.
admit.
Qed.

Theorem PNo_strict_imv_imp_rel_strict_imv : forall L R:set -> (set -> prop) -> prop, forall alpha, ordinal alpha ->
  forall beta :e ordsucc alpha, forall p:set -> prop,
   PNo_strict_imv L R alpha p -> PNo_rel_strict_imv L R beta p.
admit.
Qed.

Theorem PNo_rel_split_imv_imp_strict_imv : forall L R:set -> (set -> prop) -> prop,
  forall alpha, ordinal alpha -> forall p:set -> prop,
       PNo_rel_strict_split_imv L R alpha p
    -> PNo_strict_imv L R alpha p.
admit.
Qed.

Theorem PNo_lenbdd_strict_imv_ex : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> exists beta :e ordsucc alpha,
      exists p:set -> prop, PNo_strict_imv L R beta p.
admit.
Qed.

Definition PNo_least_rep : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R beta p => ordinal beta
       /\ PNo_strict_imv L R beta p
       /\ forall gamma :e beta,
           forall q:set -> prop, ~PNo_strict_imv L R gamma q.
Definition PNo_least_rep2 : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> (set -> prop) -> prop
  := fun L R beta p => PNo_least_rep L R beta p /\ forall x, x /:e beta -> ~p x.

Theorem PNo_strict_imv_pred_eq : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha -> forall p q:set -> prop,
     PNo_least_rep L R alpha p
  -> PNo_strict_imv L R alpha q
  -> forall beta :e alpha, p beta <-> q beta.
admit.
Qed.

Theorem PNo_lenbdd_least_rep2_exuniq2 : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> exists beta,
        (exists p:set -> prop, PNo_least_rep2 L R beta p)
     /\ (forall p q:set -> prop, PNo_least_rep2 L R beta p -> PNo_least_rep2 L R beta q -> p = q).
admit.
Qed.

(* Parameter PNo_bd "1b39e85278dd9e820e7b6258957386ac55934d784aa3702c57a28ec807453b01" "ed76e76de9b58e621daa601cca73b4159a437ba0e73114924cb92ec8044f2aa2" *)
Definition PNo_bd : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set
 := fun L R => DescrR_i_io_1 (PNo_least_rep2 L R).
(* Parameter PNo_pred "be07c39b18a3aa93f066f4c064fee3941ec27cfd07a4728b6209135c77ce5704" "b2d51dcfccb9527e9551b0d0c47d891c9031a1d4ee87bba5a9ae5215025d107a" *)
Definition PNo_pred : (set -> (set -> prop) -> prop) -> (set -> (set -> prop) -> prop) -> set -> prop
 := fun L R => DescrR_i_io_2 (PNo_least_rep2 L R).

Theorem PNo_bd_pred_lem : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> PNo_least_rep2 L R (PNo_bd L R) (PNo_pred L R).
admit.
Qed.

Theorem PNo_bd_pred : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> PNo_least_rep L R (PNo_bd L R) (PNo_pred L R).
admit.
Qed.

Theorem PNo_bd_In : forall L R:set -> (set -> prop) -> prop,
  PNoLt_pwise L R ->
  forall alpha, ordinal alpha
   -> PNo_lenbdd alpha L
   -> PNo_lenbdd alpha R
   -> PNo_bd L R :e ordsucc alpha.
admit.
Qed.

Opaque Sigma Pi ap PNo_pred PNo_bd PNoLt DescrR_i_io_1 DescrR_i_io_2.

Section TaggedSets.
Let tag : set -> set := fun alpha => SetAdjoin alpha {1}.
Postfix ' 100 := tag.

Theorem not_TransSet_Sing1 : ~TransSet {1}.
admit.
Qed.

Theorem not_ordinal_Sing1 : ~ordinal {1}.
admit.
Qed.

Theorem tagged_not_ordinal : forall y, ~ordinal (y ').
admit.
Qed.

Theorem tagged_notin_ordinal : forall alpha y, ordinal alpha -> (y ') /:e alpha.
admit.
Qed.

Theorem tagged_eqE_Subq : forall alpha beta, ordinal alpha -> alpha ' = beta ' -> alpha c= beta.
admit.
Qed.

Theorem tagged_eqE_eq : forall alpha beta, ordinal alpha -> ordinal beta -> alpha ' = beta ' -> alpha = beta.
admit.
Qed.

Theorem tagged_ReplE : forall alpha beta, ordinal alpha -> ordinal beta -> beta ' :e {gamma '|gamma :e alpha} -> beta :e alpha.
admit.
Qed.

Theorem ordinal_notin_tagged_Repl : forall alpha Y, ordinal alpha -> alpha /:e {y '|y :e Y}.
admit.
Qed.

Definition SNoElts_ : set -> set := fun alpha => alpha :\/: {beta '|beta :e alpha}.

Theorem SNoElts_mon : forall alpha beta, alpha c= beta -> SNoElts_ alpha c= SNoElts_ beta.
admit.
Qed.

Definition SNo_ : set -> set -> prop := fun alpha x =>
    x c= SNoElts_ alpha
 /\ forall beta :e alpha, exactly1of2 (beta ' :e x) (beta :e x).
Definition PSNo : set -> (set -> prop) -> set :=
  fun alpha p => {beta :e alpha|p beta} :\/: {beta '|beta :e alpha, ~p beta}.

Theorem PNoEq_PSNo : forall alpha, ordinal alpha -> forall p:set -> prop, PNoEq_ alpha (fun beta => beta :e PSNo alpha p) p.
admit.
Qed.

Theorem SNo_PSNo : forall alpha, ordinal alpha -> forall p:set -> prop, SNo_ alpha (PSNo alpha p).
admit.
Qed.

Theorem SNo_PSNo_eta_ : forall alpha x, ordinal alpha -> SNo_ alpha x -> x = PSNo alpha (fun beta => beta :e x).
admit.
Qed.

(* Parameter SNo "87d7604c7ea9a2ae0537066afb358a94e6ac0cd80ba277e6b064422035a620cf" "11faa7a742daf8e4f9aaf08e90b175467e22d0e6ad3ed089af1be90cfc17314b" *)
Definition SNo : set -> prop := fun x => exists alpha, ordinal alpha /\ SNo_ alpha x.

Theorem SNo_SNo : forall alpha, ordinal alpha -> forall z, SNo_ alpha z -> SNo z.
admit.
Qed.

(* Parameter SNoLev "bf1decfd8f4025a2271f2a64d1290eae65933d0f2f0f04b89520449195f1aeb8" "293b77d05dab711767d698fb4484aab2a884304256765be0733e6bd5348119e8" *)
Definition SNoLev : set -> set := fun x => Eps_i (fun alpha => ordinal alpha /\ SNo_ alpha x).

Theorem SNoLev_uniq_Subq : forall x alpha beta, ordinal alpha -> ordinal beta -> SNo_ alpha x -> SNo_ beta x -> alpha c= beta.
admit.
Qed.

Theorem SNoLev_uniq : forall x alpha beta, ordinal alpha -> ordinal beta -> SNo_ alpha x -> SNo_ beta x -> alpha = beta.
admit.
Qed.

Theorem SNoLev_prop : forall x, SNo x -> ordinal (SNoLev x) /\ SNo_ (SNoLev x) x.
admit.
Qed.

Theorem SNoLev_ordinal : forall x, SNo x -> ordinal (SNoLev x).
admit.
Qed.

Theorem SNoLev_ : forall x, SNo x -> SNo_ (SNoLev x) x.
admit.
Qed.

Theorem SNo_PSNo_eta : forall x, SNo x -> x = PSNo (SNoLev x) (fun beta => beta :e x).
admit.
Qed.

Theorem SNoLev_PSNo : forall alpha, ordinal alpha -> forall p:set -> prop, SNoLev (PSNo alpha p) = alpha.
admit.
Qed.

Theorem SNo_Subq : forall x y, SNo x -> SNo y -> SNoLev x c= SNoLev y -> (forall alpha :e SNoLev x, alpha :e x <-> alpha :e y) -> x c= y.
admit.
Qed.

Definition SNoEq_ : set -> set -> set -> prop
 := fun alpha x y => PNoEq_ alpha (fun beta => beta :e x) (fun beta => beta :e y).

Theorem SNoEq_I : forall alpha x y, (forall beta :e alpha, beta :e x <-> beta :e y) -> SNoEq_ alpha x y.
admit.
Qed.

Theorem SNo_eq : forall x y, SNo x -> SNo y -> SNoLev x = SNoLev y -> SNoEq_ (SNoLev x) x y -> x = y.
admit.
Qed.

End TaggedSets.
Definition SNoLt : set -> set -> prop :=
  fun x y => PNoLt (SNoLev x) (fun beta => beta :e x) (SNoLev y) (fun beta => beta :e y).
Infix < 490 := SNoLt.
Definition SNoLe : set -> set -> prop :=
  fun x y => PNoLe (SNoLev x) (fun beta => beta :e x) (SNoLev y) (fun beta => beta :e y).
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.

Theorem SNoLtLe : forall x y, x < y -> x <= y.
admit.
Qed.

Theorem SNoLeE : forall x y, SNo x -> SNo y -> x <= y -> x < y \/ x = y.
admit.
Qed.

Theorem SNoEq_sym_ : forall alpha x y, SNoEq_ alpha x y -> SNoEq_ alpha y x.
admit.
Qed.

Theorem SNoEq_tra_ : forall alpha x y z, SNoEq_ alpha x y -> SNoEq_ alpha y z -> SNoEq_ alpha x z.
admit.
Qed.

Theorem SNoLtE : forall x y, SNo x -> SNo y -> x < y ->
 forall p:prop,
    (forall z, SNo z -> SNoLev z :e SNoLev x :/\: SNoLev y -> SNoEq_ (SNoLev z) z x -> SNoEq_ (SNoLev z) z y -> x < z -> z < y -> SNoLev z /:e x -> SNoLev z :e y -> p)
 -> (SNoLev x :e SNoLev y -> SNoEq_ (SNoLev x) x y -> SNoLev x :e y -> p)
 -> (SNoLev y :e SNoLev x -> SNoEq_ (SNoLev y) x y -> SNoLev y /:e x -> p)
 -> p.
admit.
Qed.

(** The analogous thm to PNoLtI1 can be recovered by SNoLt_tra (transitivity) and SNoLtI2 and SNoLtI3. **)
Theorem SNoLtI2 : forall x y,
     SNoLev x :e SNoLev y
  -> SNoEq_ (SNoLev x) x y
  -> SNoLev x :e y
  -> x < y.
admit.
Qed.

Theorem SNoLtI3 : forall x y,
     SNoLev y :e SNoLev x
  -> SNoEq_ (SNoLev y) x y
  -> SNoLev y /:e x
  -> x < y.
admit.
Qed.

Theorem SNoLt_irref : forall x, ~SNoLt x x.
admit.
Qed.

Theorem SNoLt_trichotomy_or : forall x y, SNo x -> SNo y -> x < y \/ x = y \/ y < x.
admit.
Qed.

Theorem SNoLt_trichotomy_or_impred : forall x y, SNo x -> SNo y ->
  forall p:prop,
      (x < y -> p)
   -> (x = y -> p)
   -> (y < x -> p)
   -> p.
admit.
Qed.

Theorem SNoLt_tra : forall x y z, SNo x -> SNo y -> SNo z -> x < y -> y < z -> x < z.
admit.
Qed.

Theorem SNoLe_ref : forall x, SNoLe x x.
admit.
Qed.

Theorem SNoLe_antisym : forall x y, SNo x -> SNo y -> x <= y -> y <= x -> x = y.
admit.
Qed.

Theorem SNoLtLe_tra : forall x y z, SNo x -> SNo y -> SNo z -> x < y -> y <= z -> x < z.
admit.
Qed.

Theorem SNoLeLt_tra : forall x y z, SNo x -> SNo y -> SNo z -> x <= y -> y < z -> x < z.
admit.
Qed.

Theorem SNoLe_tra : forall x y z, SNo x -> SNo y -> SNo z -> x <= y -> y <= z -> x <= z.
admit.
Qed.

Theorem SNoLtLe_or : forall x y, SNo x -> SNo y -> x < y \/ y <= x.
admit.
Qed.

Theorem SNoLt_PSNo_PNoLt : forall alpha beta, forall p q:set -> prop,
 ordinal alpha -> ordinal beta ->
 PSNo alpha p < PSNo beta q -> PNoLt alpha p beta q.
admit.
Qed.

Theorem PNoLt_SNoLt_PSNo : forall alpha beta, forall p q:set -> prop,
 ordinal alpha -> ordinal beta ->
 PNoLt alpha p beta q -> PSNo alpha p < PSNo beta q.
admit.
Qed.

Definition SNoCut : set -> set -> set :=
  fun L R => PSNo (PNo_bd (fun alpha p => ordinal alpha /\ PSNo alpha p :e L) (fun alpha p => ordinal alpha /\ PSNo alpha p :e R)) (PNo_pred (fun alpha p => ordinal alpha /\ PSNo alpha p :e L) (fun alpha p => ordinal alpha /\ PSNo alpha p :e R)).
Definition SNoCutP : set -> set -> prop :=
 fun L R =>
      (forall x :e L, SNo x)
   /\ (forall y :e R, SNo y)
   /\ (forall x :e L, forall y :e R, x < y).

Theorem SNoCutP_SNoCut : forall L R, SNoCutP L R
 -> SNo (SNoCut L R)
 /\ SNoLev (SNoCut L R) :e ordsucc ((\/_ x :e L, ordsucc (SNoLev x)) :\/: (\/_ y :e R, ordsucc (SNoLev y)))
 /\ (forall x :e L, x < SNoCut L R)
 /\ (forall y :e R, SNoCut L R < y)
 /\ (forall z, SNo z -> (forall x :e L, x < z) -> (forall y :e R, z < y) -> SNoLev (SNoCut L R) c= SNoLev z /\ SNoEq_ (SNoLev (SNoCut L R)) (SNoCut L R) z).
admit.
Qed.

Theorem SNoCutP_SNoCut_impred : forall L R, SNoCutP L R
 -> forall p:prop,
      (SNo (SNoCut L R)
    -> SNoLev (SNoCut L R) :e ordsucc ((\/_ x :e L, ordsucc (SNoLev x)) :\/: (\/_ y :e R, ordsucc (SNoLev y)))
    -> (forall x :e L, x < SNoCut L R)
    -> (forall y :e R, SNoCut L R < y)
    -> (forall z, SNo z -> (forall x :e L, x < z) -> (forall y :e R, z < y) -> SNoLev (SNoCut L R) c= SNoLev z /\ SNoEq_ (SNoLev (SNoCut L R)) (SNoCut L R) z)
    -> p)
   -> p.
admit.
Qed.

Theorem SNoCutP_L_0: forall L, (forall x :e L, SNo x) -> SNoCutP L 0.
admit.
Qed.

Theorem SNoCutP_0_0: SNoCutP 0 0.
admit.
Qed.

Definition SNoS_ : set -> set := fun alpha => {x :e Power (SNoElts_ alpha)|exists beta :e alpha, SNo_ beta x}.

Theorem SNoS_E : forall alpha, ordinal alpha -> forall x :e SNoS_ alpha, exists beta :e alpha, SNo_ beta x.
admit.
Qed.

Section TaggedSets2.
Let tag : set -> set := fun alpha => SetAdjoin alpha {1}.
Postfix ' 100 := tag.

Theorem SNoS_I : forall alpha, ordinal alpha -> forall x, forall beta :e alpha, SNo_ beta x -> x :e SNoS_ alpha.
admit.
Qed.

Theorem SNoS_I2 : forall x y, SNo x -> SNo y -> SNoLev x :e SNoLev y -> x :e SNoS_ (SNoLev y).
admit.
Qed.  

Theorem SNoS_Subq : forall alpha beta, ordinal alpha -> ordinal beta -> alpha c= beta -> SNoS_ alpha c= SNoS_ beta.
admit.
Qed.

Theorem SNoLev_uniq2 : forall alpha, ordinal alpha -> forall x, SNo_ alpha x -> SNoLev x = alpha.
admit.
Qed.

Theorem SNoS_E2 : forall alpha, ordinal alpha -> forall x :e SNoS_ alpha,
 forall p:prop,
     (SNoLev x :e alpha -> ordinal (SNoLev x) -> SNo x -> SNo_ (SNoLev x) x -> p)
  -> p.
admit.
Qed.

Theorem SNoS_In_neq : forall w, SNo w -> forall x :e SNoS_ (SNoLev w), x <> w.
admit.
Qed.

Theorem SNoS_SNoLev : forall z, SNo z -> z :e SNoS_ (ordsucc (SNoLev z)).
admit.
Qed.

Definition SNoL : set -> set := fun z => {x :e SNoS_ (SNoLev z) | x < z}.
Definition SNoR : set -> set := fun z => {y :e SNoS_ (SNoLev z) | z < y}.

Theorem SNoCutP_SNoL_SNoR: forall z, SNo z -> SNoCutP (SNoL z) (SNoR z).
admit.
Qed.

Theorem SNoL_E : forall x, SNo x -> forall w :e SNoL x,
  forall p:prop,
       (SNo w -> SNoLev w :e SNoLev x -> w < x -> p)
    -> p.
admit.
Qed.

Theorem SNoR_E : forall x, SNo x -> forall z :e SNoR x,
  forall p:prop,
       (SNo z -> SNoLev z :e SNoLev x -> x < z -> p)
    -> p.
admit.
Qed.

Theorem SNoL_SNoS_ : forall z, SNoL z c= SNoS_ (SNoLev z).
admit.
Qed.

Theorem SNoR_SNoS_ : forall z, SNoR z c= SNoS_ (SNoLev z).
admit.
Qed.

Theorem SNoL_SNoS : forall x, SNo x -> forall w :e SNoL x, w :e SNoS_ (SNoLev x).
admit.
Qed.

Theorem SNoR_SNoS : forall x, SNo x -> forall z :e SNoR x, z :e SNoS_ (SNoLev x).
admit.
Qed.

Theorem SNoL_I : forall z, SNo z -> forall x, SNo x -> SNoLev x :e SNoLev z -> x < z -> x :e SNoL z.
admit.
Qed.

Theorem SNoR_I : forall z, SNo z -> forall y, SNo y -> SNoLev y :e SNoLev z -> z < y -> y :e SNoR z.
admit.
Qed.

Theorem SNo_eta : forall z, SNo z -> z = SNoCut (SNoL z) (SNoR z).
admit.
Qed.

Theorem SNoCutP_SNo_SNoCut : forall L R, SNoCutP L R -> SNo (SNoCut L R).
admit.
Qed.

Theorem SNoCutP_SNoCut_L : forall L R, SNoCutP L R -> forall x :e L, x < SNoCut L R.
admit.
Qed.

Theorem SNoCutP_SNoCut_R : forall L R, SNoCutP L R -> forall y :e R, SNoCut L R < y.
admit.
Qed.

Theorem SNoCutP_SNoCut_fst : forall L R, SNoCutP L R ->
 forall z, SNo z
   -> (forall x :e L, x < z)
   -> (forall y :e R, z < y)
   -> SNoLev (SNoCut L R) c= SNoLev z
   /\ SNoEq_ (SNoLev (SNoCut L R)) (SNoCut L R) z.
admit.
Qed.

Theorem SNoCut_Le : forall L1 R1 L2 R2, SNoCutP L1 R1 -> SNoCutP L2 R2
  -> (forall w :e L1, w < SNoCut L2 R2)
  -> (forall z :e R2, SNoCut L1 R1 < z)
  -> SNoCut L1 R1 <= SNoCut L2 R2.
admit.
Qed.

Theorem SNoCut_ext : forall L1 R1 L2 R2, SNoCutP L1 R1 -> SNoCutP L2 R2
  -> (forall w :e L1, w < SNoCut L2 R2)
  -> (forall z :e R1, SNoCut L2 R2 < z)
  -> (forall w :e L2, w < SNoCut L1 R1)
  -> (forall z :e R2, SNoCut L1 R1 < z)
  -> SNoCut L1 R1 = SNoCut L2 R2.
admit.
Qed.

Theorem SNoLt_SNoL_or_SNoR_impred: forall x y, SNo x -> SNo y -> x < y ->
 forall p:prop,
    (forall z :e SNoL y, z :e SNoR x -> p)
 -> (x :e SNoL y -> p)
 -> (y :e SNoR x -> p)
 -> p.
admit.
Qed.

Theorem SNoL_or_SNoR_impred: forall x y, SNo x -> SNo y ->
 forall p:prop,
    (x = y -> p)
 -> (forall z :e SNoL y, z :e SNoR x -> p)
 -> (x :e SNoL y -> p)
 -> (y :e SNoR x -> p)
 -> (forall z :e SNoR y, z :e SNoL x -> p)
 -> (x :e SNoR y -> p)
 -> (y :e SNoL x -> p)
 -> p.
admit.
Qed.

Theorem SNoL_SNoCutP_ex: forall L R, SNoCutP L R -> forall w :e SNoL (SNoCut L R), exists w' :e L, w <= w'.
admit.
Qed.

Theorem SNoR_SNoCutP_ex: forall L R, SNoCutP L R -> forall z :e SNoR (SNoCut L R), exists z' :e R, z' <= z.
admit.
Qed.

Theorem ordinal_SNo_ : forall alpha, ordinal alpha -> SNo_ alpha alpha.
admit.
Qed.

Theorem ordinal_SNo : forall alpha, ordinal alpha -> SNo alpha.
admit.
Qed.

Theorem ordinal_SNoLev : forall alpha, ordinal alpha -> SNoLev alpha = alpha.
admit.
Qed.

Theorem ordinal_SNoLev_max : forall alpha, ordinal alpha -> forall z, SNo z -> SNoLev z :e alpha -> z < alpha.
admit.
Qed.

Theorem ordinal_SNoL : forall alpha, ordinal alpha -> SNoL alpha = SNoS_ alpha.
admit.
Qed.

Theorem ordinal_SNoR : forall alpha, ordinal alpha -> SNoR alpha = Empty.
admit.
Qed.

Theorem nat_p_SNo: forall n, nat_p n -> SNo n.
admit.
Qed.

Theorem omega_SNo: forall n :e omega, SNo n.
admit.
Qed.

Theorem omega_SNoS_omega : omega c= SNoS_ omega.
admit.
Qed.

Theorem ordinal_In_SNoLt : forall alpha, ordinal alpha -> forall beta :e alpha, beta < alpha.
admit.
Qed.

Theorem ordinal_SNoLev_max_2 : forall alpha, ordinal alpha -> forall z, SNo z -> SNoLev z :e ordsucc alpha -> z <= alpha.
admit.
Qed.

Theorem ordinal_Subq_SNoLe : forall alpha beta, ordinal alpha -> ordinal beta -> alpha c= beta -> alpha <= beta.
admit.
Qed.

Theorem ordinal_SNoLt_In : forall alpha beta, ordinal alpha -> ordinal beta -> alpha < beta -> alpha :e beta.
admit.
Qed.

Theorem omega_nonneg : forall m :e omega, 0 <= m.
admit.
Qed.

Theorem SNo_0 : SNo 0.
admit.
Qed.

Theorem SNo_1 : SNo 1.
admit.
Qed.

Theorem SNo_2 : SNo 2.
admit.
Qed.

Theorem SNoLev_0 : SNoLev 0 = 0.
admit.
Qed.

Theorem SNoCut_0_0: SNoCut 0 0 = 0.
admit.
Qed.

Theorem SNoL_0 : SNoL 0 = 0.
admit.
Qed.

Theorem SNoR_0 : SNoR 0 = 0.
admit.
Qed.

Theorem SNoL_1 : SNoL 1 = 1.
admit.
Qed.

Theorem SNoR_1 : SNoR 1 = 0.
admit.
Qed.

Theorem SNo_max_SNoLev : forall x, SNo x -> (forall y :e SNoS_ (SNoLev x), y < x) -> SNoLev x = x.
admit.
Qed.

Theorem SNo_max_ordinal : forall x, SNo x -> (forall y :e SNoS_ (SNoLev x), y < x) -> ordinal x.
admit.
Qed.

Theorem pos_low_eq_one : forall x, SNo x -> 0 < x -> SNoLev x c= 1 -> x = 1.
admit.
Qed.

Definition SNo_extend0 : set -> set := fun x => PSNo (ordsucc (SNoLev x)) (fun delta => delta :e x /\ delta <> SNoLev x).
Definition SNo_extend1 : set -> set := fun x => PSNo (ordsucc (SNoLev x)) (fun delta => delta :e x \/ delta = SNoLev x).

Theorem SNo_extend0_SNo_ : forall x, SNo x -> SNo_ (ordsucc (SNoLev x)) (SNo_extend0 x).
admit.
Qed.

Theorem SNo_extend1_SNo_ : forall x, SNo x -> SNo_ (ordsucc (SNoLev x)) (SNo_extend1 x).
admit.
Qed.

Theorem SNo_extend0_SNo : forall x, SNo x -> SNo (SNo_extend0 x).
admit.
Qed.

Theorem SNo_extend1_SNo : forall x, SNo x -> SNo (SNo_extend1 x).
admit.
Qed.

Theorem SNo_extend0_SNoLev : forall x, SNo x -> SNoLev (SNo_extend0 x) = ordsucc (SNoLev x).
admit.
Qed.

Theorem SNo_extend1_SNoLev : forall x, SNo x -> SNoLev (SNo_extend1 x) = ordsucc (SNoLev x).
admit.
Qed.

Theorem SNo_extend0_nIn : forall x, SNo x -> SNoLev x /:e SNo_extend0 x.
admit.
Qed.

Theorem SNo_extend1_In : forall x, SNo x -> SNoLev x :e SNo_extend1 x.
admit.
Qed.

Theorem SNo_extend0_SNoEq : forall x, SNo x -> SNoEq_ (SNoLev x) (SNo_extend0 x) x.
admit.
Qed.

Theorem SNo_extend1_SNoEq : forall x, SNo x -> SNoEq_ (SNoLev x) (SNo_extend1 x) x.
admit.
Qed.

Theorem SNoLev_0_eq_0 : forall x, SNo x -> SNoLev x = 0 -> x = 0.
admit.
Qed.

(** eps_ n is the Surreal Number 1/2^n, without needing to define division or exponents first **)
Definition eps_ : set -> set := fun n => {0} :\/: {(ordsucc m) ' | m :e n}.

Theorem eps_ordinal_In_eq_0 : forall n alpha, ordinal alpha -> alpha :e eps_ n -> alpha = 0.
admit.
Qed.

Theorem eps_0_1 : eps_ 0 = 1.
admit.
Qed.

Theorem SNo__eps_ : forall n :e omega, SNo_ (ordsucc n) (eps_ n).
admit.
Qed.

Theorem SNo_eps_ : forall n :e omega, SNo (eps_ n).
admit.
Qed.

Theorem SNo_eps_1 : SNo (eps_ 1).
admit.
Qed.

Theorem SNoLev_eps_ : forall n :e omega, SNoLev (eps_ n) = ordsucc n.
admit.
Qed.

Theorem SNo_eps_SNoS_omega : forall n :e omega, eps_ n :e SNoS_ omega.
admit.
Qed.

Theorem SNo_eps_decr : forall n :e omega, forall m :e n, eps_ n < eps_ m.
admit.
Qed.

Theorem SNo_eps_pos : forall n :e omega, 0 < eps_ n.
admit.
Qed.

Theorem SNo_pos_eps_Lt : forall n, nat_p n -> forall x :e SNoS_ (ordsucc n), 0 < x -> eps_ n < x.
admit.
Qed.

Theorem SNo_pos_eps_Le : forall n, nat_p n -> forall x :e SNoS_ (ordsucc (ordsucc n)), 0 < x -> eps_ n <= x.
admit.
Qed.

Theorem eps_SNo_eq : forall n, nat_p n -> forall x :e SNoS_ (ordsucc n), 0 < x -> SNoEq_ (SNoLev x) (eps_ n) x -> exists m :e n, x = eps_ m.
admit.
Qed.

Theorem eps_SNoCutP : forall n :e omega, SNoCutP {0} {eps_ m|m :e n}.
admit.
Qed.

Theorem eps_SNoCut : forall n :e omega, eps_ n = SNoCut {0} {eps_ m|m :e n}.
admit.
Qed.

End TaggedSets2.

Theorem SNo_etaE : forall z, SNo z ->
  forall p:prop,
     (forall L R, SNoCutP L R
       -> (forall x :e L, SNoLev x :e SNoLev z)
       -> (forall y :e R, SNoLev y :e SNoLev z)
       -> z = SNoCut L R
       -> p)
   -> p.
admit.
Qed.

(*** surreal induction ***)
Theorem SNo_ind : forall P:set -> prop,
  (forall L R, SNoCutP L R
   -> (forall x :e L, P x)
   -> (forall y :e R, P y)
   -> P (SNoCut L R))
 -> forall z, SNo z -> P z.
admit.
Qed.

(*** surreal recursion ***)
Section SurrealRecI.
Variable F:set -> (set -> set) -> set.
Let default : set := Eps_i (fun _ => True).
Let G : set -> (set -> set -> set) -> set -> set
  := fun alpha g =>
       If_ii
          (ordinal alpha)
          (fun z:set => if z :e SNoS_ (ordsucc alpha) then
                           F z (fun w => g (SNoLev w) w)
                        else
                           default)
          (fun z:set => default).
(* Parameter SNo_rec_i "352082c509ab97c1757375f37a2ac62ed806c7b39944c98161720a584364bfaf" "be45dfaed6c479503a967f3834400c4fd18a8a567c8887787251ed89579f7be3" *)
Definition SNo_rec_i : set -> set
 := fun z => In_rec_ii G (SNoLev z) z.
Hypothesis Fr: forall z, SNo z ->
   forall g h:set -> set, (forall w :e SNoS_ (SNoLev z), g w = h w)
     -> F z g = F z h.

Theorem SNo_rec_i_eq : forall z, SNo z -> SNo_rec_i z = F z SNo_rec_i.
admit.
Qed.

End SurrealRecI.
Section SurrealRecII.
Variable F:set -> (set -> (set -> set)) -> (set -> set).
Let default : (set -> set) := Descr_ii (fun _ => True).
Let G : set -> (set -> set -> (set -> set)) -> set -> (set -> set)
  := fun alpha g =>
       If_iii
          (ordinal alpha)
          (fun z:set => If_ii (z :e SNoS_ (ordsucc alpha))
                              (F z (fun w => g (SNoLev w) w))
                              default)
          (fun z:set => default).
(* Parameter SNo_rec_ii "030b1b3db48f720b8db18b1192717cad8f204fff5fff81201b9a2414f5036417" "e148e62186e718374accb69cda703e3440725cca8832aed55c0b32731f7401ab" *)
Definition SNo_rec_ii : set -> (set -> set)
 := fun z => In_rec_iii G (SNoLev z) z.
Hypothesis Fr: forall z, SNo z ->
   forall g h:set -> (set -> set), (forall w :e SNoS_ (SNoLev z), g w = h w)
     -> F z g = F z h.

Theorem SNo_rec_ii_eq : forall z, SNo z -> SNo_rec_ii z = F z SNo_rec_ii.
admit.
Qed.

End SurrealRecII.
Section SurrealRec2.
Variable F:set -> set -> (set -> set -> set) -> set.
Let G:set -> (set -> set -> set) -> set -> (set -> set) -> set
  := fun w f z g => F w z (fun x y => if x = w then g y else f x y).
Let H:set -> (set -> set -> set) -> set -> set
  := fun w f z => if SNo z then SNo_rec_i (G w f) z else Empty.
(* Parameter SNo_rec2 "9c6267051fa817eed39b404ea37e7913b3571fe071763da2ebc1baa56b4b77f5" "7d10ab58310ebefb7f8bf63883310aa10fc2535f53bb48db513a868bc02ec028" *)
Definition SNo_rec2 : set -> set -> set
  := SNo_rec_ii H.
Hypothesis Fr: forall w, SNo w -> forall z, SNo z ->
   forall g h:set -> set -> set,
        (forall x :e SNoS_ (SNoLev w), forall y, SNo y -> g x y = h x y)
     -> (forall y :e SNoS_ (SNoLev z), g w y = h w y)
     -> F w z g = F w z h.

Theorem SNo_rec2_G_prop : forall w, SNo w -> forall f k:set -> set -> set,
    (forall x :e SNoS_ (SNoLev w), f x = k x)
 -> forall z, SNo z ->
    forall g h:set -> set, (forall u :e SNoS_ (SNoLev z), g u = h u)
 -> G w f z g = G w k z h.
admit.
Qed.

Theorem SNo_rec2_eq_1 : forall w, SNo w -> forall f:set -> set -> set,
  forall z, SNo z ->
   SNo_rec_i (G w f) z = G w f z (SNo_rec_i (G w f)).
admit.
Qed.

Theorem SNo_rec2_eq : forall w, SNo w -> forall z, SNo z ->
   SNo_rec2 w z = F w z SNo_rec2.
admit.
Qed.

End SurrealRec2.

Theorem SNo_ordinal_ind : forall P:set -> prop,
  (forall alpha, ordinal alpha -> forall x :e SNoS_ alpha, P x)
  ->
  (forall x, SNo x -> P x).
admit.
Qed.

Theorem SNo_ordinal_ind2 : forall P:set -> set -> prop,
  (forall alpha, ordinal alpha ->
   forall beta, ordinal beta ->
   forall x :e SNoS_ alpha, forall y :e SNoS_ beta, P x y)
  ->
  (forall x y, SNo x -> SNo y -> P x y).
admit.
Qed.

Theorem SNo_ordinal_ind3 : forall P:set -> set -> set -> prop,
  (forall alpha, ordinal alpha ->
   forall beta, ordinal beta ->
   forall gamma, ordinal gamma ->
   forall x :e SNoS_ alpha, forall y :e SNoS_ beta, forall z :e SNoS_ gamma, P x y z)
  ->
  (forall x y z, SNo x -> SNo y -> SNo z -> P x y z).
admit.
Qed.

Theorem SNoLev_ind : forall P:set -> prop,
  (forall x, SNo x -> (forall w :e SNoS_ (SNoLev x), P w) -> P x)
  ->
  (forall x, SNo x -> P x).
admit.
Qed.

Theorem SNoLev_ind2 : forall P:set -> set -> prop,
  (forall x y, SNo x -> SNo y
    -> (forall w :e SNoS_ (SNoLev x), P w y)
    -> (forall z :e SNoS_ (SNoLev y), P x z)
    -> (forall w :e SNoS_ (SNoLev x), forall z :e SNoS_ (SNoLev y), P w z)
    -> P x y)
-> forall x y, SNo x -> SNo y -> P x y.
admit.
Qed.

Theorem SNoLev_ind3 : forall P:set -> set -> set -> prop,
  (forall x y z, SNo x -> SNo y -> SNo z
    -> (forall u :e SNoS_ (SNoLev x), P u y z)
    -> (forall v :e SNoS_ (SNoLev y), P x v z)
    -> (forall w :e SNoS_ (SNoLev z), P x y w)
    -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), P u v z)
    -> (forall u :e SNoS_ (SNoLev x), forall w :e SNoS_ (SNoLev z), P u y w)
    -> (forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), P x v w)
    -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), P u v w)
    -> P x y z)
 -> forall x y z, SNo x -> SNo y -> SNo z -> P x y z.
admit.
Qed.

Theorem SNo_omega : SNo omega.
admit.
Qed.

Theorem SNoLt_0_1 : 0 < 1.
admit.
Qed.

Theorem SNoLt_0_2 : 0 < 2.
admit.
Qed.

Theorem SNoLt_1_2 : 1 < 2.
admit.
Qed.

Theorem restr_SNo_ : forall x, SNo x -> forall alpha :e SNoLev x, SNo_ alpha (x :/\: SNoElts_ alpha).
admit.
Qed.

Theorem restr_SNo : forall x, SNo x -> forall alpha :e SNoLev x, SNo (x :/\: SNoElts_ alpha).
admit.
Qed.

Theorem restr_SNoLev : forall x, SNo x -> forall alpha :e SNoLev x, SNoLev (x :/\: SNoElts_ alpha) = alpha.
admit.
Qed.

Theorem restr_SNoEq : forall x, SNo x -> forall alpha :e SNoLev x, SNoEq_ alpha (x :/\: SNoElts_ alpha) x.
admit.
Qed.

Theorem SNo_extend0_restr_eq : forall x, SNo x -> x = SNo_extend0 x :/\: SNoElts_ (SNoLev x).
admit.
Qed.

Theorem SNo_extend1_restr_eq : forall x, SNo x -> x = SNo_extend1 x :/\: SNoElts_ (SNoLev x).
admit.
Qed.

Opaque eps_ SNo_rec2 SNo_rec_ii SNo_rec_i SNoLev SNo.

Section SurrealMinus.
(* Parameter minus_SNo "6d39c64862ac40c95c6f5e4ed5f02bb019279bfb0cda8c9bbe0e1b813b1e876c" "268a6c1da15b8fe97d37be85147bc7767b27098cdae193faac127195e8824808" *)
Definition minus_SNo : set -> set
  := SNo_rec_i (fun x m => SNoCut {m z|z :e SNoR x} {m w|w :e SNoL x}).
Prefix - 358 := minus_SNo.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.

Theorem minus_SNo_eq : forall x, SNo x -> - x = SNoCut {- z|z :e SNoR x} {- w|w :e SNoL x}.
admit.
Qed.

Theorem minus_SNo_prop1 : forall x, SNo x -> SNo (- x) /\ (forall u :e SNoL x, - x < - u) /\ (forall u :e SNoR x, - u < - x) /\ SNoCutP {- z|z :e SNoR x} {- w|w :e SNoL x}.
admit.
Qed.

Theorem SNo_minus_SNo : forall x, SNo x -> SNo (- x).
admit.
Qed.

Theorem minus_SNo_Lt_contra : forall x y, SNo x -> SNo y -> x < y -> - y < - x.
admit.
Qed.

Theorem minus_SNo_Le_contra : forall x y, SNo x -> SNo y -> x <= y -> - y <= - x.
admit.
Qed.

Theorem minus_SNo_SNoCutP : forall x, SNo x -> SNoCutP {- z|z :e SNoR x} {- w|w :e SNoL x}.
admit.
Qed.

Theorem minus_SNo_SNoCutP_gen : forall L R, SNoCutP L R -> SNoCutP {- z|z :e R} {- w|w :e L}.
admit.
Qed.

Theorem minus_SNo_Lev_lem1 : forall alpha, ordinal alpha -> forall x :e SNoS_ alpha, SNoLev (- x) c= SNoLev x.
admit.
Qed.

Theorem minus_SNo_Lev_lem2 : forall x, SNo x -> SNoLev (- x) c= SNoLev x.
admit.
Qed.

Theorem minus_SNo_invol : forall x, SNo x -> - - x = x.
admit.
Qed.

Theorem minus_SNo_Lev : forall x, SNo x -> SNoLev (- x) = SNoLev x.
admit.
Qed.

Theorem minus_SNo_SNo_ : forall alpha, ordinal alpha -> forall x, SNo_ alpha x -> SNo_ alpha (- x).
admit.
Qed.

Theorem minus_SNo_SNoS_ : forall alpha, ordinal alpha -> forall x, x :e SNoS_ alpha -> - x :e SNoS_ alpha.
admit.
Qed.

Theorem minus_SNoCut_eq_lem : forall v, SNo v -> forall L R, SNoCutP L R -> v = SNoCut L R -> - v = SNoCut {- z|z :e R} {- w|w :e L}.
admit.
Qed.

Theorem minus_SNoCut_eq : forall L R, SNoCutP L R -> - SNoCut L R = SNoCut {- z|z :e R} {- w|w :e L}.
admit.
Qed.

Theorem minus_SNo_Lt_contra1 : forall x y, SNo x -> SNo y -> -x < y -> - y < x.
admit.
Qed.

Theorem minus_SNo_Lt_contra2 : forall x y, SNo x -> SNo y -> x < -y -> y < - x.
admit.
Qed.

Theorem mordinal_SNoLev_min_2 : forall alpha, ordinal alpha -> forall z, SNo z -> SNoLev z :e ordsucc alpha -> - alpha <= z.
admit.
Qed.

Theorem minus_SNo_SNoS_omega : forall x :e SNoS_ omega, - x :e SNoS_ omega.
admit.
Qed.

Theorem SNoL_minus_SNoR: forall x, SNo x -> SNoL (- x) = {- w|w :e SNoR x}.
admit.
Qed.

End SurrealMinus.
Opaque minus_SNo.
Section SurrealAdd.
Prefix - 358 := minus_SNo.
(* Parameter add_SNo "29b9b279a7a5b776b777d842e678a4acaf3b85b17a0223605e4cc68025e9b2a7" "127d043261bd13d57aaeb99e7d2c02cae2bd0698c0d689b03e69f1ac89b3c2c6" *)
Definition add_SNo : set -> set -> set
  := SNo_rec2 (fun x y a => SNoCut ({a w y|w :e SNoL x} :\/: {a x w|w :e SNoL y}) ({a z y|z :e SNoR x} :\/: {a x z|z :e SNoR y})).
Infix + 360 right := add_SNo.

Theorem add_SNo_eq : forall x, SNo x -> forall y, SNo y ->
    x + y = SNoCut ({w + y|w :e SNoL x} :\/: {x + w|w :e SNoL y}) ({z + y|z :e SNoR x} :\/: {x + z|z :e SNoR y}).
admit.
Qed.

Theorem add_SNo_prop1 : forall x y, SNo x -> SNo y ->
    SNo (x + y)
 /\ (forall u :e SNoL x, u + y < x + y)
 /\ (forall u :e SNoR x, x + y < u + y)
 /\ (forall u :e SNoL y, x + u < x + y)
 /\ (forall u :e SNoR y, x + y < x + u)
 /\ SNoCutP ({w + y|w :e SNoL x} :\/: {x + w|w :e SNoL y}) ({z + y|z :e SNoR x} :\/: {x + z|z :e SNoR y}).
admit.
Qed.

Theorem SNo_add_SNo : forall x y, SNo x -> SNo y -> SNo (x + y).
admit.
Qed.

Theorem SNo_add_SNo_3 : forall x y z, SNo x -> SNo y -> SNo z -> SNo (x + y + z).
admit.
Qed.

Theorem SNo_add_SNo_3c : forall x y z, SNo x -> SNo y -> SNo z -> SNo (x + y + - z).
admit.
Qed.

Theorem SNo_add_SNo_4 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> SNo (x + y + z + w).
admit.
Qed.

Theorem add_SNo_Lt1 : forall x y z, SNo x -> SNo y -> SNo z -> x < z -> x + y < z + y.
admit.
Qed.

Theorem add_SNo_Le1 : forall x y z, SNo x -> SNo y -> SNo z -> x <= z -> x + y <= z + y.
admit.
Qed.

Theorem add_SNo_Lt2 : forall x y z, SNo x -> SNo y -> SNo z -> y < z -> x + y < x + z.
admit.
Qed.

Theorem add_SNo_Le2 : forall x y z, SNo x -> SNo y -> SNo z -> y <= z -> x + y <= x + z.
admit.
Qed.

Theorem add_SNo_Lt3a : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x < z -> y <= w -> x + y < z + w.
admit.
Qed.

Theorem add_SNo_Lt3b : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x <= z -> y < w -> x + y < z + w.
admit.
Qed.

Theorem add_SNo_Lt3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x < z -> y < w -> x + y < z + w.
admit.
Qed.

Theorem add_SNo_Le3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x <= z -> y <= w -> x + y <= z + w.
admit.
Qed.

Theorem add_SNo_SNoCutP : forall x y, SNo x -> SNo y -> SNoCutP ({w + y|w :e SNoL x} :\/: {x + w|w :e SNoL y}) ({z + y|z :e SNoR x} :\/: {x + z|z :e SNoR y}).
admit.
Qed.

Theorem add_SNo_com : forall x y, SNo x -> SNo y -> x + y = y + x.
admit.
Qed.

Theorem add_SNo_0L : forall x, SNo x -> 0 + x = x.
admit.
Qed.

Theorem add_SNo_0R : forall x, SNo x -> x + 0 = x.
admit.
Qed.

Theorem add_SNo_minus_SNo_linv : forall x, SNo x -> -x+x = 0.
admit.
Qed.

Theorem add_SNo_minus_SNo_rinv : forall x, SNo x -> x + -x = 0.
admit.
Qed.

Theorem add_SNo_ordinal_SNoCutP : forall alpha, ordinal alpha -> forall beta, ordinal beta -> SNoCutP ({x + beta | x :e SNoS_ alpha} :\/: {alpha + x | x :e SNoS_ beta}) Empty.
admit.
Qed.

Theorem add_SNo_ordinal_eq : forall alpha, ordinal alpha -> forall beta, ordinal beta -> alpha + beta = SNoCut ({x + beta | x :e SNoS_ alpha} :\/: {alpha + x | x :e SNoS_ beta}) Empty.
admit.
Qed.

Theorem add_SNo_ordinal_ordinal : forall alpha, ordinal alpha -> forall beta, ordinal beta -> ordinal (alpha + beta).
admit.
Qed.

Theorem add_SNo_ordinal_SL : forall alpha, ordinal alpha -> forall beta, ordinal beta -> ordsucc alpha + beta = ordsucc (alpha + beta).
admit.
Qed.

Theorem add_SNo_ordinal_SR : forall alpha, ordinal alpha -> forall beta, ordinal beta -> alpha + ordsucc beta = ordsucc (alpha + beta).
admit.
Qed.

Theorem add_SNo_ordinal_InL : forall alpha, ordinal alpha -> forall beta, ordinal beta -> forall gamma :e alpha, gamma + beta :e alpha + beta.
admit.
Qed.

Theorem add_SNo_ordinal_InR : forall alpha, ordinal alpha -> forall beta, ordinal beta -> forall gamma :e beta, alpha + gamma :e alpha + beta.
admit.
Qed.

Theorem add_nat_add_SNo : forall n m :e omega, add_nat n m = n + m.
admit.
Qed.

Theorem add_SNo_In_omega : forall n m :e omega, n + m :e omega.
admit.
Qed.

Theorem add_SNo_1_1_2 : 1 + 1 = 2.
admit.
Qed.

Theorem add_SNo_SNoL_interpolate : forall x y, SNo x -> SNo y -> forall u :e SNoL (x + y), (exists v :e SNoL x, u <= v + y) \/ (exists v :e SNoL y, u <= x + v).
admit.
Qed.

Theorem add_SNo_SNoR_interpolate : forall x y, SNo x -> SNo y -> forall u :e SNoR (x + y), (exists v :e SNoR x, v + y <= u) \/ (exists v :e SNoR y, x + v <= u).
admit.
Qed.

Theorem add_SNo_assoc : forall x y z, SNo x -> SNo y -> SNo z -> x + (y + z) = (x + y) + z.
admit.
Qed.

Theorem add_SNo_minus_R2 : forall x y, SNo x -> SNo y -> (x + y) + - y = x.
admit.
Qed.

Theorem add_SNo_minus_R2' : forall x y, SNo x -> SNo y -> (x + - y) + y = x.
admit.
Qed.

Theorem add_SNo_minus_L2 : forall x y, SNo x -> SNo y -> - x + (x + y) = y.
admit.
Qed.

Theorem add_SNo_minus_L2' : forall x y, SNo x -> SNo y -> x + (- x + y) = y.
admit.
Qed.

Theorem add_SNo_cancel_L : forall x y z, SNo x -> SNo y -> SNo z -> x + y = x + z -> y = z.
admit.
Qed.

Theorem add_SNo_cancel_R : forall x y z, SNo x -> SNo y -> SNo z -> x + y = z + y -> x = z.
admit.
Qed.

Theorem minus_SNo_0 : - 0 = 0.
admit.
Qed.

Theorem minus_add_SNo_distr : forall x y, SNo x -> SNo y -> -(x+y) = (-x) + (-y).
admit.
Qed.

Theorem minus_add_SNo_distr_3 : forall x y z, SNo x -> SNo y -> SNo z -> -(x + y + z) = -x + - y + -z.
admit.
Qed.

Theorem add_SNo_Lev_bd : forall x y, SNo x -> SNo y -> SNoLev (x + y) c= SNoLev x + SNoLev y.
admit.
Qed.

Theorem add_SNo_SNoS_omega : forall x y :e SNoS_ omega, x + y :e SNoS_ omega.
admit.
Qed.

Theorem add_SNo_Lt1_cancel : forall x y z, SNo x -> SNo y -> SNo z -> x + y < z + y -> x < z.
admit.
Qed.

Theorem add_SNo_Lt2_cancel : forall x y z, SNo x -> SNo y -> SNo z -> x + y < x + z -> y < z.
admit.
Qed.

Theorem add_SNo_Le1_cancel : forall x y z, SNo x -> SNo y -> SNo z -> x + y <= z + y -> x <= z.
admit.
Qed.

Theorem add_SNo_assoc_4 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w
  -> x + y + z + w = (x + y + z) + w.
admit.
Qed.

Theorem add_SNo_com_3_0_1 : forall x y z, SNo x -> SNo y -> SNo z
  -> x + y + z = y + x + z.
admit.
Qed.

Theorem add_SNo_com_3b_1_2 : forall x y z, SNo x -> SNo y -> SNo z
  -> (x + y) + z = (x + z) + y.
admit.
Qed.

Theorem add_SNo_com_4_inner_mid : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w
  -> (x + y) + (z + w) = (x + z) + (y + w).
admit.
Qed.

Theorem add_SNo_rotate_3_1 : forall x y z, SNo x -> SNo y -> SNo z ->
  x + y + z = z + x + y.
admit.
Qed.

Theorem add_SNo_rotate_4_1 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w ->
  x + y + z + w = w + x + y + z.
admit.
Qed.

Theorem add_SNo_rotate_5_1 : forall x y z w v, SNo x -> SNo y -> SNo z -> SNo w -> SNo v ->
  x + y + z + w + v = v + x + y + z + w.
admit.
Qed.

Theorem add_SNo_rotate_5_2 : forall x y z w v, SNo x -> SNo y -> SNo z -> SNo w -> SNo v ->
  x + y + z + w + v = w + v + x + y + z.
admit.
Qed.

Theorem add_SNo_minus_SNo_prop2 : forall x y, SNo x -> SNo y -> x + - x + y = y.
admit.
Qed.

Theorem add_SNo_minus_SNo_prop3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> (x + y + z) + (- z + w) = x + y + w.
admit.
Qed.

Theorem add_SNo_minus_SNo_prop5 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> (x + y + - z) + (z + w) = x + y + w.
admit.
Qed.

Theorem add_SNo_minus_Lt1 : forall x y z, SNo x -> SNo y -> SNo z -> x + - y < z -> x < z + y.
admit.
Qed.

Theorem add_SNo_minus_Lt2 : forall x y z, SNo x -> SNo y -> SNo z -> z < x + - y -> z + y < x.
admit.
Qed.

Theorem add_SNo_minus_Lt1b : forall x y z, SNo x -> SNo y -> SNo z -> x < z + y -> x + - y < z.
admit.
Qed.

Theorem add_SNo_minus_Lt2b : forall x y z, SNo x -> SNo y -> SNo z -> z + y < x -> z < x + - y.
admit.
Qed.

Theorem add_SNo_minus_Lt1b3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x + y < w + z -> x + y + - z < w.
admit.
Qed.

Theorem add_SNo_minus_Lt2b3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> w + z < x + y -> w < x + y + - z.
admit.
Qed.

Theorem add_SNo_minus_Lt_lem : forall x y z u v w, SNo x -> SNo y -> SNo z -> SNo u -> SNo v -> SNo w ->
  x + y + w < u + v + z ->
  x + y + - z < u + v + - w.
admit.
Qed.

Theorem add_SNo_minus_Le2 : forall x y z, SNo x -> SNo y -> SNo z -> z <= x + - y -> z + y <= x.
admit.
Qed.

Theorem add_SNo_minus_Le2b : forall x y z, SNo x -> SNo y -> SNo z -> z + y <= x -> z <= x + - y.
admit.
Qed.

Theorem add_SNo_Lt_subprop2 : forall x y z w u v, SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo v
  -> x + u < z + v
  -> y + v < w + u
  -> x + y < z + w.
admit.
Qed.

Theorem add_SNo_Lt_subprop3a : forall x y z w u a, SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo a
  -> x + z < w + a
  -> y + a < u
  -> x + y + z < w + u.
admit.
Qed.

Theorem add_SNo_Lt_subprop3b : forall x y w u v a, SNo x -> SNo y -> SNo w -> SNo u -> SNo v -> SNo a
  -> x + a < w + v
  -> y < a + u
  -> x + y < w + u + v.
admit.
Qed.

Theorem add_SNo_Lt_subprop3c : forall x y z w u a b c, SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo a -> SNo b -> SNo c
 -> x + a < b + c
 -> y + c < u
 -> b + z < w + a
 -> x + y + z < w + u.
admit.
Qed.

Theorem add_SNo_Lt_subprop3d : forall x y w u v a b c, SNo x -> SNo y -> SNo w -> SNo u -> SNo v -> SNo a -> SNo b -> SNo c
 -> x + a < b + v
 -> y < c + u
 -> b + c < w + a
 -> x + y < w + u + v.
admit.
Qed.

Theorem ordinal_ordsucc_SNo_eq : forall alpha, ordinal alpha -> ordsucc alpha = 1 + alpha.
admit.
Qed.

Theorem add_SNo_3a_2b: forall x y z w u, SNo x -> SNo y -> SNo z -> SNo w -> SNo u
 -> (x + y + z) + (w + u) = (u + y + z) + (w + x).
admit.
Qed.

Theorem add_SNo_1_ordsucc : forall n :e omega, n + 1 = ordsucc n.
admit.
Qed.

Theorem add_SNo_eps_Lt : forall x, SNo x -> forall n :e omega, x < x + eps_ n.
admit.
Qed.

Theorem add_SNo_eps_Lt' : forall x y, SNo x -> SNo y -> forall n :e omega, x < y -> x < y + eps_ n.
admit.
Qed.

Theorem SNoLt_minus_pos : forall x y, SNo x -> SNo y -> x < y -> 0 < y + - x.
admit.
Qed.

Theorem add_SNo_omega_In_cases: forall m, forall n :e omega, forall k, nat_p k -> m :e n + k -> m :e n \/ m + - n :e k.
admit.
Qed.

Theorem add_SNo_Lt4 : forall x y z w u v, SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo v -> x < w -> y < u -> z < v -> x + y + z < w + u + v.
admit.
Qed.

Theorem add_SNo_3_3_3_Lt1 : forall x y z w u, SNo x -> SNo y -> SNo z -> SNo w -> SNo u ->
  x + y < z + w -> x + y + u < z + w + u.
admit.
Qed.

Theorem add_SNo_3_2_3_Lt1 : forall x y z w u, SNo x -> SNo y -> SNo z -> SNo w -> SNo u ->
  y + x < z + w -> x + u + y < z + w + u.
admit.
Qed.

Theorem add_SNo_minus_Lt12b3: forall x y z w u v,
    SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo v
 -> x + y + v < w + u + z
 -> x + y + - z < w + u + - v.
admit.
Qed.

Theorem add_SNo_minus_Le1b : forall x y z, SNo x -> SNo y -> SNo z -> x <= z + y -> x + - y <= z.
admit.
Qed.

Theorem add_SNo_minus_Le1b3 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> x + y <= w + z -> x + y + - z <= w.
admit.
Qed.

Theorem add_SNo_minus_Le12b3: forall x y z w u v,
    SNo x -> SNo y -> SNo z -> SNo w -> SNo u -> SNo v
 -> x + y + v <= w + u + z
 -> x + y + - z <= w + u + - v.
admit.
Qed.

End SurrealAdd.

Opaque add_SNo.

Section SurrealAbs.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
(* Parameter abs_SNo "9f9389c36823b2e0124a7fe367eb786d080772b5171a5d059b10c47361cef0ef" "34f6dccfd6f62ca020248cdfbd473fcb15d8d9c5c55d1ec7c5ab6284006ff40f" *)
Definition abs_SNo : set -> set := fun x => if 0 <= x then x else - x.

Theorem nonneg_abs_SNo : forall x, 0 <= x -> abs_SNo x = x.
admit.
Qed.

Theorem not_nonneg_abs_SNo : forall x, ~(0 <= x) -> abs_SNo x = - x.
admit.
Qed.

Theorem pos_abs_SNo : forall x, 0 < x -> abs_SNo x = x.
admit.
Qed.

Theorem neg_abs_SNo : forall x, SNo x -> x < 0 -> abs_SNo x = - x.
admit.
Qed.

Theorem SNo_abs_SNo : forall x, SNo x -> SNo (abs_SNo x).
admit.
Qed.

Theorem abs_SNo_minus: forall x, SNo x -> abs_SNo (- x) = abs_SNo x.
admit.
Qed.

Theorem abs_SNo_dist_swap: forall x y, SNo x -> SNo y -> abs_SNo (x + - y) = abs_SNo (y + - x).
admit.
Qed.

End SurrealAbs.

Opaque abs_SNo.

Section SurrealMul.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
(* Parameter mul_SNo "f56bf39b8eea93d7f63da529dedb477ae1ab1255c645c47d8915623f364f2d6b" "48d05483e628cb37379dd5d279684d471d85c642fe63533c3ad520b84b18df9d" *)
Definition mul_SNo : set -> set -> set
  := SNo_rec2
      (fun x y m =>
        SNoCut ({m (w 0) y + m x (w 1) + - m (w 0) (w 1)|w :e SNoL x :*: SNoL y}
                  :\/:
                {m (z 0) y + m x (z 1) + - m (z 0) (z 1)|z :e SNoR x :*: SNoR y})
               ({m (w 0) y + m x (w 1) + - m (w 0) (w 1)|w :e SNoL x :*: SNoR y}
                  :\/:
                {m (z 0) y + m x (z 1) + - m (z 0) (z 1)|z :e SNoR x :*: SNoL y})).

Infix * 355 right := mul_SNo.

Theorem mul_SNo_eq : forall x, SNo x -> forall y, SNo y ->
   x * y
      = SNoCut ({(w 0) * y + x * (w 1) + - (w 0) * (w 1)|w :e SNoL x :*: SNoL y}
                  :\/:
                {(z 0) * y + x * (z 1) + - (z 0) * (z 1)|z :e SNoR x :*: SNoR y})
               ({(w 0) * y + x * (w 1) + - (w 0) * (w 1)|w :e SNoL x :*: SNoR y}
                  :\/:
                {(z 0) * y + x * (z 1) + - (z 0) * (z 1)|z :e SNoR x :*: SNoL y}).
admit.
Qed.

Theorem mul_SNo_eq_2 : forall x y, SNo x -> SNo y ->
  forall p:prop,
    (forall L R,
         (forall u, u :e L ->
           (forall q:prop,
                (forall w0 :e SNoL x, forall w1 :e SNoL y, u = w0 * y + x * w1 + - w0 * w1 -> q)
             -> (forall z0 :e SNoR x, forall z1 :e SNoR y, u = z0 * y + x * z1 + - z0 * z1 -> q)
             -> q))
      -> (forall w0 :e SNoL x, forall w1 :e SNoL y, w0 * y + x * w1 + - w0 * w1 :e L)
      -> (forall z0 :e SNoR x, forall z1 :e SNoR y, z0 * y + x * z1 + - z0 * z1 :e L)
      -> (forall u, u :e R ->
           (forall q:prop,
                (forall w0 :e SNoL x, forall z1 :e SNoR y, u = w0 * y + x * z1 + - w0 * z1 -> q)
             -> (forall z0 :e SNoR x, forall w1 :e SNoL y, u = z0 * y + x * w1 + - z0 * w1 -> q)
             -> q))
      -> (forall w0 :e SNoL x, forall z1 :e SNoR y, w0 * y + x * z1 + - w0 * z1 :e R)
      -> (forall z0 :e SNoR x, forall w1 :e SNoL y, z0 * y + x * w1 + - z0 * w1 :e R)
      -> x * y = SNoCut L R
      -> p)
   -> p.
admit.
Qed.

Theorem mul_SNo_prop_1 : forall x, SNo x -> forall y, SNo y ->
 forall p:prop,
    (SNo (x * y)
  -> (forall u :e SNoL x, forall v :e SNoL y, u * y + x * v < x * y + u * v)
  -> (forall u :e SNoR x, forall v :e SNoR y, u * y + x * v < x * y + u * v)
  -> (forall u :e SNoL x, forall v :e SNoR y, x * y + u * v < u * y + x * v)
  -> (forall u :e SNoR x, forall v :e SNoL y, x * y + u * v < u * y + x * v)
  -> p)
 -> p.
admit.
Qed.

Theorem SNo_mul_SNo : forall x y, SNo x -> SNo y -> SNo (x * y).
admit.
Qed.

Theorem SNo_mul_SNo_lem : forall x y u v, SNo x -> SNo y -> SNo u -> SNo v -> SNo (u * y + x * v + - (u * v)).
admit.
Qed.

Theorem SNo_mul_SNo_3 : forall x y z, SNo x -> SNo y -> SNo z -> SNo (x * y * z).
admit.
Qed.

Theorem mul_SNo_eq_3 : forall x y, SNo x -> SNo y ->
  forall p:prop,
    (forall L R, SNoCutP L R
       -> (forall u, u :e L ->
           (forall q:prop,
                (forall w0 :e SNoL x, forall w1 :e SNoL y, u = w0 * y + x * w1 + - w0 * w1 -> q)
             -> (forall z0 :e SNoR x, forall z1 :e SNoR y, u = z0 * y + x * z1 + - z0 * z1 -> q)
             -> q))
      -> (forall w0 :e SNoL x, forall w1 :e SNoL y, w0 * y + x * w1 + - w0 * w1 :e L)
      -> (forall z0 :e SNoR x, forall z1 :e SNoR y, z0 * y + x * z1 + - z0 * z1 :e L)
      -> (forall u, u :e R ->
           (forall q:prop,
                (forall w0 :e SNoL x, forall z1 :e SNoR y, u = w0 * y + x * z1 + - w0 * z1 -> q)
             -> (forall z0 :e SNoR x, forall w1 :e SNoL y, u = z0 * y + x * w1 + - z0 * w1 -> q)
             -> q))
      -> (forall w0 :e SNoL x, forall z1 :e SNoR y, w0 * y + x * z1 + - w0 * z1 :e R)
      -> (forall z0 :e SNoR x, forall w1 :e SNoL y, z0 * y + x * w1 + - z0 * w1 :e R)
      -> x * y = SNoCut L R
      -> p)
   -> p.
admit.
Qed.

Theorem mul_SNo_Lt : forall x y u v, SNo x -> SNo y -> SNo u -> SNo v
 -> u < x -> v < y -> u * y + x * v < x * y + u * v.
admit.
Qed.

Theorem mul_SNo_Le : forall x y u v, SNo x -> SNo y -> SNo u -> SNo v
 -> u <= x -> v <= y -> u * y + x * v <= x * y + u * v.
admit.
Qed.

Theorem mul_SNo_SNoL_interpolate : forall x y, SNo x -> SNo y -> forall u :e SNoL (x * y),
 (exists v :e SNoL x, exists w :e SNoL y, u + v * w <= v * y + x * w)
 \/
 (exists v :e SNoR x, exists w :e SNoR y, u + v * w <= v * y + x * w).
admit.
Qed.

Theorem mul_SNo_SNoL_interpolate_impred : forall x y, SNo x -> SNo y -> forall u :e SNoL (x * y),
 forall p:prop,
      (forall v :e SNoL x, forall w :e SNoL y, u + v * w <= v * y + x * w -> p)
   -> (forall v :e SNoR x, forall w :e SNoR y, u + v * w <= v * y + x * w -> p)
   -> p.
admit.
Qed.  

Theorem mul_SNo_SNoR_interpolate : forall x y, SNo x -> SNo y -> forall u :e SNoR (x * y),
 (exists v :e SNoL x, exists w :e SNoR y, v * y + x * w <= u + v * w)
 \/
 (exists v :e SNoR x, exists w :e SNoL y, v * y + x * w <= u + v * w).
admit.
Qed.

Theorem mul_SNo_SNoR_interpolate_impred : forall x y, SNo x -> SNo y -> forall u :e SNoR (x * y),
 forall p:prop,
     (forall v :e SNoL x, forall w :e SNoR y, v * y + x * w <= u + v * w -> p)
  -> (forall v :e SNoR x, forall w :e SNoL y, v * y + x * w <= u + v * w -> p)
  -> p.
admit.
Qed.

(** This could be useful for proving L c= L', L = L', R c= R' or R = R'
    when corresponding conditions hold. **)
Theorem mul_SNo_Subq_lem : forall x y X Y Z W,
  forall U U',
      (forall u, u :e U ->
         (forall q:prop,
                (forall w0 :e X, forall w1 :e Y, u = w0 * y + x * w1 + - w0 * w1 -> q)
             -> (forall z0 :e Z, forall z1 :e W, u = z0 * y + x * z1 + - z0 * z1 -> q)
             -> q))
   -> (forall w0 :e X, forall w1 :e Y, w0 * y + x * w1 + - w0 * w1 :e U')
   -> (forall w0 :e Z, forall w1 :e W, w0 * y + x * w1 + - w0 * w1 :e U')
   -> U c= U'.
admit.
Qed.

(** Part of Conway Chapter 2 Theorem 7 **)
Theorem mul_SNo_zeroR : forall x, SNo x -> x * 0 = 0.
admit.
Qed.

Theorem mul_SNo_oneR : forall x, SNo x -> x * 1 = x.
admit.
Qed.

Theorem mul_SNo_com : forall x y, SNo x -> SNo y -> x * y = y * x.
admit.
Qed.

Theorem mul_SNo_minus_distrL : forall x y, SNo x -> SNo y -> (- x) * y = - x * y.
admit.
Qed.

Theorem mul_SNo_minus_distrR: forall x y, SNo x -> SNo y -> x * (- y) = - (x * y).
admit.
Qed.

Theorem mul_SNo_distrR : forall x y z, SNo x -> SNo y -> SNo z
  -> (x + y) * z = x * z + y * z.
admit.
Qed.

Theorem mul_SNo_distrL : forall x y z, SNo x -> SNo y -> SNo z
  -> x * (y + z) = x * y + x * z.
admit.
Qed.

Section mul_SNo_assoc_lems.
Variable M:set -> set -> set.
Infix * 355 right := M.
Hypothesis SNo_M : forall x y, SNo x -> SNo y -> SNo (x * y).
Hypothesis DL: forall x y z, SNo x -> SNo y -> SNo z -> x * (y + z) = x * y + x * z.
Hypothesis DR: forall x y z, SNo x -> SNo y -> SNo z -> (x + y) * z = x * z + y * z.
Hypothesis IL: forall x y, SNo x -> SNo y -> forall u :e SNoL (x * y),
 forall p:prop,
      (forall v :e SNoL x, forall w :e SNoL y, u + v * w <= v * y + x * w -> p)
   -> (forall v :e SNoR x, forall w :e SNoR y, u + v * w <= v * y + x * w -> p)
   -> p.
Hypothesis IR: forall x y, SNo x -> SNo y -> forall u :e SNoR (x * y),
 forall p:prop,
     (forall v :e SNoL x, forall w :e SNoR y, v * y + x * w <= u + v * w -> p)
  -> (forall v :e SNoR x, forall w :e SNoL y, v * y + x * w <= u + v * w -> p)
  -> p.
Hypothesis M_Lt: forall x y u v, SNo x -> SNo y -> SNo u -> SNo v
 -> u < x -> v < y -> u * y + x * v < x * y + u * v.
Hypothesis M_Le: forall x y u v, SNo x -> SNo y -> SNo u -> SNo v
 -> u <= x -> v <= y -> u * y + x * v <= x * y + u * v.

Theorem mul_SNo_assoc_lem1 : forall x y z, SNo x -> SNo y -> SNo z
 -> (forall u :e SNoS_ (SNoLev x), u * (y * z) = (u * y) * z)
 -> (forall v :e SNoS_ (SNoLev y), x * (v * z) = (x * v) * z)
 -> (forall w :e SNoS_ (SNoLev z), x * (y * w) = (x * y) * w)
 -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), u * (v * z) = (u * v) * z)
 -> (forall u :e SNoS_ (SNoLev x), forall w :e SNoS_ (SNoLev z), u * (y * w) = (u * y) * w)
 -> (forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), x * (v * w) = (x * v) * w)
 -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), u * (v * w) = (u * v) * w)
 -> forall L,
    (forall u :e L,
     forall q:prop,
         (forall v :e SNoL x, forall w :e SNoL (y * z), u = v * (y * z) + x * w + - v * w -> q)
      -> (forall v :e SNoR x, forall w :e SNoR (y * z), u = v * (y * z) + x * w + - v * w -> q)
      -> q)
 -> forall u :e L, u < (x * y) * z.
admit.
Qed.

Theorem mul_SNo_assoc_lem2 : forall x y z, SNo x -> SNo y -> SNo z
 -> (forall u :e SNoS_ (SNoLev x), u * (y * z) = (u * y) * z)
 -> (forall v :e SNoS_ (SNoLev y), x * (v * z) = (x * v) * z)
 -> (forall w :e SNoS_ (SNoLev z), x * (y * w) = (x * y) * w)
 -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), u * (v * z) = (u * v) * z)
 -> (forall u :e SNoS_ (SNoLev x), forall w :e SNoS_ (SNoLev z), u * (y * w) = (u * y) * w)
 -> (forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), x * (v * w) = (x * v) * w)
 -> (forall u :e SNoS_ (SNoLev x), forall v :e SNoS_ (SNoLev y), forall w :e SNoS_ (SNoLev z), u * (v * w) = (u * v) * w)
 -> forall R,
    (forall u :e R,
     forall q:prop,
         (forall v :e SNoL x, forall w :e SNoR (y * z), u = v * (y * z) + x * w + - v * w -> q)
      -> (forall v :e SNoR x, forall w :e SNoL (y * z), u = v * (y * z) + x * w + - v * w -> q)
      -> q)
 -> forall u :e R, (x * y) * z < u.
admit.
Qed.

End mul_SNo_assoc_lems.

Theorem mul_SNo_assoc : forall x y z, SNo x -> SNo y -> SNo z
  -> x * (y * z) = (x * y) * z.
admit.
Qed.

Theorem mul_nat_mul_SNo : forall n m :e omega, mul_nat n m = n * m.
admit.
Qed.

Theorem mul_SNo_In_omega : forall n m :e omega, n * m :e omega.
admit.
Qed.

Theorem mul_SNo_zeroL : forall x, SNo x -> 0 * x = 0.
admit.
Qed.

Theorem mul_SNo_oneL : forall x, SNo x -> 1 * x = x.
admit.
Qed.

Theorem mul_SNo_rotate_3_1 : forall x y z, SNo x -> SNo y -> SNo z ->
  x * y * z = z * x * y.
admit.
Qed.

Theorem pos_mul_SNo_Lt : forall x y z, SNo x -> 0 < x -> SNo y -> SNo z -> y < z -> x * y < x * z.
admit.
Qed.

Theorem nonneg_mul_SNo_Le : forall x y z, SNo x -> 0 <= x -> SNo y -> SNo z -> y <= z -> x * y <= x * z.
admit.
Qed.

Theorem neg_mul_SNo_Lt : forall x y z, SNo x -> x < 0 -> SNo y -> SNo z -> z < y -> x * y < x * z.
admit.
Qed.

Theorem pos_mul_SNo_Lt' : forall x y z, SNo x -> SNo y -> SNo z -> 0 < z -> x < y -> x * z < y * z.
admit.
Qed.

Theorem mul_SNo_Lt1_pos_Lt : forall x y, SNo x -> SNo y -> x < 1 -> 0 < y -> x * y < y.
admit.
Qed.

Theorem nonneg_mul_SNo_Le' : forall x y z, SNo x -> SNo y -> SNo z -> 0 <= z -> x <= y -> x * z <= y * z.
admit.
Qed.

Theorem mul_SNo_Le1_nonneg_Le : forall x y, SNo x -> SNo y -> x <= 1 -> 0 <= y -> x * y <= y.
admit.
Qed.

Theorem pos_mul_SNo_Lt2 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> 0 < x -> 0 < y -> x < z -> y < w -> x * y < z * w.
admit.
Qed.

Theorem nonneg_mul_SNo_Le2 : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> 0 <= x -> 0 <= y -> x <= z -> y <= w -> x * y <= z * w.
admit.
Qed.

Theorem mul_SNo_pos_pos: forall x y, SNo x -> SNo y -> 0 < x -> 0 < y -> 0 < x * y.
admit.
Qed.

Theorem mul_SNo_pos_neg: forall x y, SNo x -> SNo y -> 0 < x -> y < 0 -> x * y < 0.
admit.
Qed.

Theorem mul_SNo_neg_pos: forall x y, SNo x -> SNo y -> x < 0 -> 0 < y -> x * y < 0.
admit.
Qed.

Theorem mul_SNo_neg_neg: forall x y, SNo x -> SNo y -> x < 0 -> y < 0 -> 0 < x * y.
admit.
Qed.

Theorem mul_SNo_nonneg_nonneg: forall x y, SNo x -> SNo y -> 0 <= x -> 0 <= y -> 0 <= x * y.
admit.
Qed.

Theorem mul_SNo_nonpos_pos: forall x y, SNo x -> SNo y -> x <= 0 -> 0 < y -> x * y <= 0.
admit.
Qed.

Theorem mul_SNo_nonpos_neg: forall x y, SNo x -> SNo y -> x <= 0 -> y < 0 -> 0 <= x * y.
admit.
Qed.

Theorem nonpos_mul_SNo_Le : forall x y z, SNo x -> x <= 0 -> SNo y -> SNo z -> z <= y -> x * y <= x * z.
admit.
Qed.

Theorem SNo_zero_or_sqr_pos : forall x, SNo x -> x = 0 \/ 0 < x * x.
admit.
Qed.

Theorem SNo_pos_sqr_uniq: forall x y, SNo x -> SNo y -> 0 < x -> 0 < y -> x * x = y * y -> x = y.
admit.
Qed.

Theorem SNo_nonneg_sqr_uniq: forall x y, SNo x -> SNo y -> 0 <= x -> 0 <= y -> x * x = y * y -> x = y.
admit.
Qed.

Theorem SNo_foil: forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> (x + y) * (z + w) = x * z + x * w + y * z + y * w.
admit.
Qed.

Theorem mul_SNo_minus_minus: forall x y, SNo x -> SNo y -> (- x) * (- y) = x * y.
admit.
Qed.

Theorem mul_SNo_com_3_0_1 : forall x y z, SNo x -> SNo y -> SNo z
  -> x * y * z = y * x * z.
admit.
Qed.

Theorem mul_SNo_com_3b_1_2 : forall x y z, SNo x -> SNo y -> SNo z
  -> (x * y) * z = (x * z) * y.
admit.
Qed.

Theorem mul_SNo_com_4_inner_mid : forall x y z w, SNo x -> SNo y -> SNo z -> SNo w
  -> (x * y) * (z * w) = (x * z) * (y * w).
admit.
Qed.

Theorem SNo_foil_mm: forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> (x + - y) * (z + - w) = x * z + - x * w + - y * z + y * w.
admit.
Qed.

Theorem mul_SNo_nonzero_cancel: forall x y z, SNo x -> x <> 0 -> SNo y -> SNo z -> x * y = x * z -> y = z.
admit.
Qed.

Theorem mul_SNoCutP_lem : forall Lx Rx Ly Ry x y,
    SNoCutP Lx Rx
 -> SNoCutP Ly Ry
 -> x = SNoCut Lx Rx
 -> y = SNoCut Ly Ry
 -> SNoCutP ({w 0 * y + x * w 1 + - w 0 * w 1|w :e Lx :*: Ly}
              :\/:
             {z 0 * y + x * z 1 + - z 0 * z 1|z :e Rx :*: Ry})
            ({w 0 * y + x * w 1 + - w 0 * w 1|w :e Lx :*: Ry}
              :\/:
             {z 0 * y + x * z 1 + - z 0 * z 1|z :e Rx :*: Ly})
 /\ x * y
  = SNoCut ({w 0 * y + x * w 1 + - w 0 * w 1|w :e Lx :*: Ly}
             :\/:
            {z 0 * y + x * z 1 + - z 0 * z 1|z :e Rx :*: Ry})
           ({w 0 * y + x * w 1 + - w 0 * w 1|w :e Lx :*: Ry}
             :\/:
            {z 0 * y + x * z 1 + - z 0 * z 1|z :e Rx :*: Ly})
 /\ forall q:prop,
     (forall LxLy' RxRy' LxRy' RxLy',
         (forall u :e LxLy', forall p:prop, (forall w :e Lx, forall w' :e Ly, SNo w -> SNo w' -> w < x -> w' < y -> u = w * y + x * w' + - w * w' -> p) -> p)
      -> (forall w :e Lx, forall w' :e Ly, w * y + x * w' + - w * w' :e LxLy')
      -> (forall u :e RxRy', forall p:prop, (forall z :e Rx, forall z' :e Ry, SNo z -> SNo z' -> x < z -> y < z' -> u = z * y + x * z' + - z * z' -> p) -> p)
      -> (forall z :e Rx, forall z' :e Ry, z * y + x * z' + - z * z' :e RxRy')
      -> (forall u :e LxRy', forall p:prop, (forall w :e Lx, forall z :e Ry, SNo w -> SNo z -> w < x -> y < z -> u = w * y + x * z + - w * z -> p) -> p)
      -> (forall w :e Lx, forall z :e Ry, w * y + x * z + - w * z :e LxRy')
      -> (forall u :e RxLy', forall p:prop, (forall z :e Rx, forall w :e Ly, SNo z -> SNo w -> x < z -> w < y -> u = z * y + x * w + - z * w -> p) -> p)
      -> (forall z :e Rx, forall w :e Ly, z * y + x * w + - z * w :e RxLy')
      -> SNoCutP (LxLy' :\/: RxRy') (LxRy' :\/: RxLy')
      -> x * y = SNoCut (LxLy' :\/: RxRy') (LxRy' :\/: RxLy')
      -> q)
    -> q.
admit.
Qed.

Theorem mul_SNoCut_abs : forall Lx Rx Ly Ry x y,
    SNoCutP Lx Rx
 -> SNoCutP Ly Ry
 -> x = SNoCut Lx Rx
 -> y = SNoCut Ly Ry
 -> forall q:prop,
     (forall LxLy' RxRy' LxRy' RxLy',
         (forall u :e LxLy', forall p:prop, (forall w :e Lx, forall w' :e Ly, SNo w -> SNo w' -> w < x -> w' < y -> u = w * y + x * w' + - w * w' -> p) -> p)
      -> (forall w :e Lx, forall w' :e Ly, w * y + x * w' + - w * w' :e LxLy')
      -> (forall u :e RxRy', forall p:prop, (forall z :e Rx, forall z' :e Ry, SNo z -> SNo z' -> x < z -> y < z' -> u = z * y + x * z' + - z * z' -> p) -> p)
      -> (forall z :e Rx, forall z' :e Ry, z * y + x * z' + - z * z' :e RxRy')
      -> (forall u :e LxRy', forall p:prop, (forall w :e Lx, forall z :e Ry, SNo w -> SNo z -> w < x -> y < z -> u = w * y + x * z + - w * z -> p) -> p)
      -> (forall w :e Lx, forall z :e Ry, w * y + x * z + - w * z :e LxRy')
      -> (forall u :e RxLy', forall p:prop, (forall z :e Rx, forall w :e Ly, SNo z -> SNo w -> x < z -> w < y -> u = z * y + x * w + - z * w -> p) -> p)
      -> (forall z :e Rx, forall w :e Ly, z * y + x * w + - z * w :e RxLy')
      -> SNoCutP (LxLy' :\/: RxRy') (LxRy' :\/: RxLy')
      -> x * y = SNoCut (LxLy' :\/: RxRy') (LxRy' :\/: RxLy')
      -> q)
    -> q.
admit.
Qed.

Theorem mul_SNo_SNoCut_SNoL_interpolate : forall Lx Rx Ly Ry,
    SNoCutP Lx Rx -> SNoCutP Ly Ry
 -> forall x y, x = SNoCut Lx Rx -> y = SNoCut Ly Ry
 -> forall u :e SNoL (x * y),
 (exists v :e Lx, exists w :e Ly, u + v * w <= v * y + x * w)
 \/
 (exists v :e Rx, exists w :e Ry, u + v * w <= v * y + x * w).
admit.
Qed.

Theorem mul_SNo_SNoCut_SNoL_interpolate_impred : forall Lx Rx Ly Ry,
    SNoCutP Lx Rx -> SNoCutP Ly Ry
 -> forall x y, x = SNoCut Lx Rx -> y = SNoCut Ly Ry
 -> forall u :e SNoL (x * y),
    forall p:prop,
        (forall v :e Lx, forall w :e Ly, u + v * w <= v * y + x * w -> p)
     -> (forall v :e Rx, forall w :e Ry, u + v * w <= v * y + x * w -> p)
     -> p.
admit.
Qed.

Theorem mul_SNo_SNoCut_SNoR_interpolate : forall Lx Rx Ly Ry,
    SNoCutP Lx Rx -> SNoCutP Ly Ry
 -> forall x y, x = SNoCut Lx Rx -> y = SNoCut Ly Ry
 -> forall u :e SNoR (x * y),
 (exists v :e Lx, exists w :e Ry, v * y + x * w <= u + v * w)
 \/
 (exists v :e Rx, exists w :e Ly, v * y + x * w <= u + v * w).
admit.
Qed.

Theorem mul_SNo_SNoCut_SNoR_interpolate_impred : forall Lx Rx Ly Ry,
    SNoCutP Lx Rx -> SNoCutP Ly Ry
 -> forall x y, x = SNoCut Lx Rx -> y = SNoCut Ly Ry
 -> forall u :e SNoR (x * y),
    forall p:prop,
        (forall v :e Lx, forall w :e Ry, v * y + x * w <= u + v * w -> p)
     -> (forall v :e Rx, forall w :e Ly, v * y + x * w <= u + v * w -> p)
     -> p.
admit.
Qed.

Theorem nonpos_nonneg_0 : forall m n :e omega, m = - n -> m = 0 /\ n = 0.
admit.
Qed.

Theorem mul_minus_SNo_distrR: forall x y, SNo x -> SNo y -> x * (- y) = - (x * y).
admit.
Qed.

End SurrealMul.

Opaque mul_SNo.

Section Int.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.

Definition int : set := omega :\/: {- n|n :e omega}.

Theorem int_SNo_cases : forall p:set -> prop,
    (forall n :e omega, p n)
 -> (forall n :e omega, p (- n))
 -> forall x :e int, p x.
admit.
Qed.

Theorem int_3_cases: forall n :e int, forall p:prop,
    (forall m :e omega, n = - ordsucc m -> p)
 -> (n = 0 -> p)
 -> (forall m :e omega, n = ordsucc m -> p)
 -> p.
admit.
Qed.

Theorem int_SNo : forall x :e int, SNo x.
admit.
Qed.

Theorem Subq_omega_int : omega c= int.
admit.
Qed.

Theorem int_minus_SNo_omega : forall n :e omega, - n :e int.
admit.
Qed.

Theorem int_add_SNo_lem: forall n :e omega, forall m, nat_p m -> - n + m :e int.
admit.
Qed.

Theorem int_add_SNo: forall x y :e int, x + y :e int.
admit.
Qed.

Theorem int_minus_SNo: forall x :e int, - x :e int.
admit.
Qed.

Theorem int_mul_SNo: forall x y :e int, x * y :e int.
admit.
Qed.

Theorem nonneg_int_nat_p: forall n :e int, 0 <= n -> nat_p n.
admit.
Qed.

End Int.

Section BezoutAndGCD.

Infix + 360 right := add_nat.
Infix * 355 right := mul_nat.

Theorem quotient_remainder_nat: forall n :e omega :\: {0}, forall m, nat_p m -> exists q :e omega, exists r :e n, m = q * n + r.
admit.
Qed.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix ^ 342 right := exp_SNo_nat.
Infix < 490 := SNoLt.
Infix <= 490 := SNoLe.

Theorem mul_SNo_nonpos_nonneg: forall x y, SNo x -> SNo y -> x <= 0 -> 0 <= y -> x * y <= 0.
admit.
Qed.

Theorem ordinal_0_In_ordsucc: forall alpha, ordinal alpha -> 0 :e ordsucc alpha.
admit.
Qed.

Theorem ordinal_ordsucc_pos: forall alpha, ordinal alpha -> 0 < ordsucc alpha.
admit.
Qed.

Theorem quotient_remainder_int: forall n :e omega :\: {0}, forall m :e int, exists q :e int, exists r :e n, m = q * n + r.
admit.
Qed.

Definition divides_int : set -> set -> prop := fun m n => m :e int /\ n :e int /\ exists k :e int, m * k = n.

Theorem divides_int_ref: forall n :e int, divides_int n n.
admit.
Qed.

Theorem divides_int_0: forall n :e int, divides_int n 0.
admit.
Qed.

Theorem divides_int_add_SNo: forall m n k, divides_int m n -> divides_int m k -> divides_int m (n + k).
admit.
Qed.

Theorem divides_int_mul_SNo: forall m n m' n', divides_int m m' -> divides_int n n' -> divides_int (m * n) (m' * n').
admit.
Qed.

Theorem divides_nat_divides_int: forall m n, divides_nat m n -> divides_int m n.
admit.
Qed.

Theorem divides_int_divides_nat: forall m n :e omega, divides_int m n -> divides_nat m n.
admit.
Qed.

Theorem divides_int_minus_SNo: forall m n, divides_int m n -> divides_int m (- n).
admit.
Qed.

Theorem divides_int_mul_SNo_L: forall m n, forall k :e int, divides_int m n -> divides_int m (n * k).
admit.
Qed.

Theorem divides_int_mul_SNo_R: forall m n, forall k :e int, divides_int m n -> divides_int m (k * n).
admit.
Qed.

Theorem divides_int_1: forall n :e int, divides_int 1 n.
admit.
Qed.

Theorem divides_int_pos_Le: forall m n, divides_int m n -> 0 < n -> m <= n.
admit.
Qed.

Definition gcd_reln : set -> set -> set -> prop := fun m n d => divides_int d m /\ divides_int d n /\ forall d', divides_int d' m -> divides_int d' n -> d' <= d.

Theorem gcd_reln_uniq: forall a b c d, gcd_reln a b c -> gcd_reln a b d -> c = d.
admit.
Qed.

Definition int_lin_comb : set -> set -> set -> prop := fun a b c => a :e int /\ b :e int /\ c :e int /\ exists m n :e int, m * a + n * b = c.

Theorem int_lin_comb_I: forall a b c :e int, (exists m n :e int, m * a + n * b = c) -> int_lin_comb a b c.
admit.
Qed.

Theorem int_lin_comb_E: forall a b c, int_lin_comb a b c ->
  forall p:prop,
       (a :e int -> b :e int -> c :e int -> forall m n :e int, m * a + n * b = c -> p)
    -> p.
admit.
Qed.

Theorem int_lin_comb_E1: forall a b c, int_lin_comb a b c -> a :e int.
admit.
Qed.

Theorem int_lin_comb_E2: forall a b c, int_lin_comb a b c -> b :e int.
admit.
Qed.

Theorem int_lin_comb_E3: forall a b c, int_lin_comb a b c -> c :e int.
admit.
Qed.

Theorem int_lin_comb_E4: forall a b c, int_lin_comb a b c ->
  forall p:prop,
       (forall m n :e int, m * a + n * b = c -> p)
    -> p.
admit.
Qed.

Theorem least_pos_int_lin_comb_ex: forall a b :e int, ~(a = 0 /\ b = 0) -> exists c, int_lin_comb a b c /\ 0 < c /\ forall c', int_lin_comb a b c' -> 0 < c' -> c <= c'.
admit.
Qed.

Theorem int_lin_comb_sym: forall a b d,
     int_lin_comb a b d
  -> int_lin_comb b a d.
admit.
Qed.
  
Theorem least_pos_int_lin_comb_divides_int: forall a b d,
     int_lin_comb a b d
  -> 0 < d
  -> (forall c, int_lin_comb a b c -> 0 < c -> d <= c)
  -> divides_int d a.
admit.
Qed.

Theorem least_pos_int_lin_comb_gcd: forall a b d,
     int_lin_comb a b d
  -> 0 < d
  -> (forall c, int_lin_comb a b c -> 0 < c -> d <= c)
  -> gcd_reln a b d.
admit.
Qed.

Theorem BezoutThm: forall a b :e int, ~(a = 0 /\ b = 0) ->
  forall d, gcd_reln a b d <-> int_lin_comb a b d /\ 0 < d /\ forall d', int_lin_comb a b d' -> 0 < d' -> d <= d'.
admit.
Qed.

Theorem gcd_id: forall m :e omega :\: {0}, gcd_reln m m m.
admit.
Qed.

Theorem gcd_0: forall m :e omega :\: {0}, gcd_reln 0 m m.
admit.
Qed.

Theorem gcd_sym: forall m n d, gcd_reln m n d -> gcd_reln n m d.
admit.
Qed.

Theorem gcd_minus: forall m n d, gcd_reln m n d -> gcd_reln m (- n) d.
admit.
Qed.

Theorem euclidean_algorithm_prop_1: forall m n d, n :e int -> gcd_reln m (n + - m) d -> gcd_reln m n d.
admit.
Qed.

Theorem euclidean_algorithm:
     (forall m :e omega :\: {0}, gcd_reln m m m)
  /\ (forall m :e omega :\: {0}, gcd_reln 0 m m)
  /\ (forall m :e omega :\: {0}, gcd_reln m 0 m)
  /\ (forall m n :e omega, m < n
          -> forall d, gcd_reln m (n + - m) d
                    -> gcd_reln m n d)
  /\ (forall m n :e omega, n < m
          -> forall d, gcd_reln n m d
                    -> gcd_reln m n d)
  /\ (forall m :e omega, forall n :e int, n < 0
          -> forall d, gcd_reln m (- n) d
                    -> gcd_reln m n d)
  /\ (forall m n :e int, m < 0
          -> forall d, gcd_reln (- m) n d
                    -> gcd_reln m n d).
admit.
Qed.

Theorem Euclid_lemma: forall p, prime_nat p -> forall a b :e int, divides_int p (a * b) -> divides_int p a \/ divides_int p b.
admit.
Qed.

End BezoutAndGCD.

Section PrimeFactorization.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix ^ 342 right := exp_SNo_nat.
Infix < 490 := SNoLt.
Infix <= 490 := SNoLe.

Theorem prime_not_divides_int_1: forall p, prime_nat p -> ~divides_int p 1.
admit.
Qed.

Definition Pi_SNo : (set -> set) -> set -> set := fun f n =>
  nat_primrec 1 (fun i r => r * f i) n.

Theorem Pi_SNo_0: forall f:set -> set, Pi_SNo f 0 = 1.
admit.
Qed.

Theorem Pi_SNo_S: forall f:set -> set, forall n, nat_p n -> Pi_SNo f (ordsucc n) = Pi_SNo f n * f n.
admit.
Qed.

Theorem Pi_SNo_In_omega: forall f:set -> set,
 forall n, nat_p n ->
     (forall i :e n, f i :e omega)
  -> Pi_SNo f n :e omega.
admit.
Qed.

Theorem Pi_SNo_In_int: forall f:set -> set,
 forall n, nat_p n ->
     (forall i :e n, f i :e int)
  -> Pi_SNo f n :e int.
admit.
Qed.

Theorem divides_int_prime_nat_eq: forall p q, prime_nat p -> prime_nat q -> divides_int p q -> p = q.
admit.
Qed.

Theorem Euclid_lemma_Pi_SNo: forall f:set->set,
  forall p, prime_nat p ->
  forall n, nat_p n ->
      (forall i :e n, f i :e int)
   -> divides_int p (Pi_SNo f n)
   -> exists i :e n, divides_int p (f i).
admit.
Qed.

Theorem divides_nat_mul_SNo_R: forall m n :e omega, divides_nat m (m * n).
admit.
Qed.

Theorem divides_nat_mul_SNo_L: forall m n :e omega, divides_nat n (m * n).
admit.
Qed.

Theorem Pi_SNo_divides: forall f:set->set,
  forall n, nat_p n ->
      (forall i :e n, f i :e omega)
   -> (forall i :e n, divides_nat (f i) (Pi_SNo f n)).
admit.
Qed.

Definition nonincrfinseq : (set -> prop) -> set -> (set -> set) -> prop := fun A n f => forall i :e n, A (f i) /\ forall j :e i, f i <= f j.

Theorem Pi_SNo_eq: forall f g:set->set,
  forall m, nat_p m
   -> (forall i :e m, f i = g i)
   -> Pi_SNo f m = Pi_SNo g m.
admit.
Qed.

Theorem prime_factorization_ex_uniq: forall n, nat_p n -> 0 :e n ->
  exists k :e omega, exists f:set -> set, nonincrfinseq prime_nat k f /\ Pi_SNo f k = n
    /\ forall k' :e omega, forall f':set -> set, nonincrfinseq prime_nat k' f' -> Pi_SNo f' k' = n
         -> k' = k /\ forall i :e k, f' i = f i.
admit.
Qed.

End PrimeFactorization.

Section SurrealExp.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Definition exp_SNo_nat : set->set->set := fun n m:set => nat_primrec 1 (fun _ r => n * r) m.
Infix ^ 342 right := exp_SNo_nat.

Theorem exp_SNo_nat_0 : forall x, SNo x -> x ^ 0 = 1.
admit.
Qed.

Theorem exp_SNo_nat_S : forall x, SNo x -> forall n, nat_p n -> x ^ (ordsucc n) = x * x ^ n.
admit.
Qed.

Theorem exp_SNo_nat_1: forall x, SNo x -> x ^ 1 = x.
admit.
Qed.

Theorem SNo_exp_SNo_nat : forall x, SNo x -> forall n, nat_p n -> SNo (x ^ n).
admit.
Qed.

Theorem nat_exp_SNo_nat : forall x, nat_p x -> forall n, nat_p n -> nat_p (x ^ n).
admit.
Qed.

Theorem eps_ordsucc_half_add : forall n, nat_p n -> eps_ (ordsucc n) + eps_ (ordsucc n) = eps_ n.
admit.
Qed.

Theorem eps_1_half_eq1 : eps_ 1 + eps_ 1 = 1.
admit.
Qed.

Theorem eps_1_half_eq2 : 2 * eps_ 1 = 1.
admit.
Qed.

Theorem double_eps_1 : forall x y z, SNo x -> SNo y -> SNo z -> x + x = y + z -> x = eps_ 1 * (y + z).
admit.
Qed.

Theorem exp_SNo_1_bd: forall x, SNo x -> 1 <= x -> forall n, nat_p n -> 1 <= x ^ n.
admit.
Qed.

Theorem exp_SNo_2_bd: forall n, nat_p n -> n < 2 ^ n.
admit.
Qed.

Theorem mul_SNo_eps_power_2: forall n, nat_p n -> eps_ n * 2 ^ n = 1.
admit.
Qed.

Theorem eps_bd_1 : forall n :e omega, eps_ n <= 1.
admit.
Qed.

Theorem mul_SNo_eps_power_2': forall n, nat_p n -> 2 ^ n * eps_ n = 1.
admit.
Qed.

Theorem exp_SNo_nat_mul_add : forall x, SNo x -> forall m, nat_p m -> forall n, nat_p n -> x ^ m * x ^ n = x ^ (m + n).
admit.
Qed.

Theorem exp_SNo_nat_mul_add' : forall x, SNo x -> forall m n :e omega, x ^ m * x ^ n = x ^ (m + n).
admit.
Qed.

Theorem exp_SNo_nat_pos : forall x, SNo x -> 0 < x -> forall n, nat_p n -> 0 < x ^ n.
admit.
Qed.

Theorem mul_SNo_eps_eps_add_SNo: forall m n :e omega, eps_ m * eps_ n = eps_ (m + n).
admit.
Qed.

Theorem SNoS_omega_Lev_equip : forall n, nat_p n -> equip {x :e SNoS_ omega|SNoLev x = n} (2 ^ n).
admit.
Qed.

Theorem SNoS_finite : forall n :e omega, finite (SNoS_ n).
admit.
Qed.

Theorem SNoS_omega_SNoL_finite : forall x :e SNoS_ omega, finite (SNoL x).
admit.
Qed.

Theorem SNoS_omega_SNoR_finite : forall x :e SNoS_ omega, finite (SNoR x).
admit.
Qed.

End SurrealExp.

Opaque exp_SNo_nat.

Section SNoMaxMin.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix ^ 342 right := exp_SNo_nat.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.
Definition SNo_max_of : set -> set -> prop := fun X x => x :e X /\ SNo x /\ forall y :e X, SNo y -> y <= x.
Definition SNo_min_of : set -> set -> prop := fun X x => x :e X /\ SNo x /\ forall y :e X, SNo y -> x <= y.

Theorem minus_SNo_max_min : forall X y, (forall x :e X, SNo x) -> SNo_max_of X y -> SNo_min_of {- x|x :e X} (- y).
admit.
Qed.

Theorem minus_SNo_max_min' : forall X y, (forall x :e X, SNo x) -> SNo_max_of {- x|x :e X} y -> SNo_min_of X (- y).
admit.
Qed.

Theorem minus_SNo_min_max : forall X y, (forall x :e X, SNo x) -> SNo_min_of X y -> SNo_max_of {- x|x :e X} (- y).
admit.
Qed.

Theorem double_SNo_max_1 : forall x y, SNo x -> SNo_max_of (SNoL x) y -> forall z, SNo z -> x < z -> y + z < x + x -> exists w :e SNoR z, y + w = x + x.
admit.
Qed.

Theorem double_SNo_min_1 : forall x y, SNo x -> SNo_min_of (SNoR x) y -> forall z, SNo z -> z < x -> x + x < y + z -> exists w :e SNoL z, y + w = x + x.
admit.
Qed.

Theorem finite_max_exists : forall X, (forall x :e X, SNo x) -> finite X -> X <> 0 -> exists x, SNo_max_of X x.
admit.
Qed.

Theorem finite_min_exists : forall X, (forall x :e X, SNo x) -> finite X -> X <> 0 -> exists x, SNo_min_of X x.
admit.
Qed.

Theorem SNoS_omega_SNoL_max_exists : forall x :e SNoS_ omega, SNoL x = 0 \/ exists y, SNo_max_of (SNoL x) y.
admit.
Qed.

Theorem SNoS_omega_SNoR_min_exists : forall x :e SNoS_ omega, SNoR x = 0 \/ exists y, SNo_min_of (SNoR x) y.
admit.
Qed.

End SNoMaxMin.

Section DiadicRationals.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.
Infix ^ 342 right := exp_SNo_nat.

Theorem nonneg_diadic_rational_p_SNoS_omega: forall k :e omega, forall n, nat_p n -> eps_ k * n :e SNoS_ omega.
admit.
Qed.

Definition diadic_rational_p : set -> prop := fun x => exists k :e omega, exists m :e int, x = eps_ k * m.

Theorem diadic_rational_p_SNoS_omega: forall x, diadic_rational_p x -> x :e SNoS_ omega.
admit.
Qed.

Theorem int_diadic_rational_p : forall m :e int, diadic_rational_p m.
admit.
Qed.

Theorem omega_diadic_rational_p : forall m :e omega, diadic_rational_p m.
admit.
Qed.

Theorem eps_diadic_rational_p : forall k :e omega, diadic_rational_p (eps_ k).
admit.
Qed.

Theorem minus_SNo_diadic_rational_p : forall x, diadic_rational_p x -> diadic_rational_p (- x).
admit.
Qed.

Theorem mul_SNo_diadic_rational_p : forall x y, diadic_rational_p x -> diadic_rational_p y -> diadic_rational_p (x * y).
admit.
Qed.

Theorem add_SNo_diadic_rational_p : forall x y, diadic_rational_p x -> diadic_rational_p y -> diadic_rational_p (x + y).
admit.
Qed.

Theorem SNoS_omega_diadic_rational_p_lem: forall n, nat_p n -> forall x, SNo x -> SNoLev x = n -> diadic_rational_p x.
admit.
Qed.

Theorem SNoS_omega_diadic_rational_p: forall x :e SNoS_ omega, diadic_rational_p x.
admit.
Qed.

Theorem mul_SNo_SNoS_omega : forall x y :e SNoS_ omega, x * y :e SNoS_ omega.
admit.
Qed.

End DiadicRationals.

Opaque int.

Section SurrealDiv.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.
Infix ^ 342 right := exp_SNo_nat.
Definition SNoL_pos : set -> set := fun x => {w :e SNoL x|0 < w}.

Theorem SNo_recip_pos_pos: forall x xi, SNo x -> SNo xi -> 0 < x -> x * xi = 1 -> 0 < xi.
admit.
Qed.

Theorem SNo_recip_lem1: forall x x' x'i y y', SNo x -> 0 < x -> x' :e SNoL_pos x -> SNo x'i -> x' * x'i = 1 -> SNo y -> x * y < 1 -> SNo y' -> 1 + - x * y' = (1 + - x * y) * (x' + - x) * x'i -> 1 < x * y'.
admit.
Qed.

Theorem SNo_recip_lem2: forall x x' x'i y y', SNo x -> 0 < x -> x' :e SNoL_pos x -> SNo x'i -> x' * x'i = 1 -> SNo y -> 1 < x * y -> SNo y' -> 1 + - x * y' = (1 + - x * y) * (x' + - x) * x'i -> x * y' < 1.
admit.
Qed.

Theorem SNo_recip_lem3: forall x x' x'i y y', SNo x -> 0 < x -> x' :e SNoR x -> SNo x'i -> x' * x'i = 1 -> SNo y -> x * y < 1 -> SNo y' -> 1 + - x * y' = (1 + - x * y) * (x' + - x) * x'i -> x * y' < 1.
admit.
Qed.

Theorem SNo_recip_lem4: forall x x' x'i y y', SNo x -> 0 < x -> x' :e SNoR x -> SNo x'i -> x' * x'i = 1 -> SNo y -> 1 < x * y -> SNo y' -> 1 + - x * y' = (1 + - x * y) * (x' + - x) * x'i -> 1 < x * y'.
admit.
Qed.

Definition SNo_recipauxset : set -> set -> set -> (set -> set) -> set := fun Y x X g => \/_ y :e Y, {(1 + (x' + - x) * y) * g x'|x' :e X}.

Theorem SNo_recipauxset_I: forall Y x X, forall g:set -> set,
 forall y :e Y, forall x' :e X, (1 + (x' + - x) * y) * g x' :e SNo_recipauxset Y x X g.
admit.
Qed.

Theorem SNo_recipauxset_E : forall Y x X, forall g:set -> set, forall z :e SNo_recipauxset Y x X g, forall p:prop, (forall y :e Y, forall x' :e X, z = (1 + (x' + - x) * y) * g x' -> p) -> p.
admit.
Qed.

Theorem SNo_recipauxset_ext: forall Y x X, forall g h:set -> set, (forall x' :e X, g x' = h x') -> SNo_recipauxset Y x X g = SNo_recipauxset Y x X h.
admit.
Qed.

Definition SNo_recipaux : set -> (set -> set) -> set -> set :=
 fun x g =>
  nat_primrec ({0},0)
   (fun k p => (p 0 :\/: SNo_recipauxset (p 0) x (SNoR x) g
                    :\/: SNo_recipauxset (p 1) x (SNoL_pos x) g,
                p 1 :\/: SNo_recipauxset (p 0) x (SNoL_pos x) g
                    :\/: SNo_recipauxset (p 1) x (SNoR x) g)).

Theorem SNo_recipaux_0: forall x, forall g:set -> set, SNo_recipaux x g 0 = ({0},0).
admit.
Qed.

Theorem SNo_recipaux_S: forall x, forall g:set -> set, forall n, nat_p n ->
   SNo_recipaux x g (ordsucc n)
 = (SNo_recipaux x g n 0 :\/: SNo_recipauxset (SNo_recipaux x g n 0) x (SNoR x) g
        :\/: SNo_recipauxset (SNo_recipaux x g n 1) x (SNoL_pos x) g,
    SNo_recipaux x g n 1 :\/: SNo_recipauxset (SNo_recipaux x g n 0) x (SNoL_pos x) g
        :\/: SNo_recipauxset (SNo_recipaux x g n 1) x (SNoR x) g).
admit.
Qed.

Theorem SNo_recipaux_lem1: forall x, SNo x -> 0 < x ->
 forall g:set -> set,
    (forall x' :e SNoS_ (SNoLev x), 0 < x' -> SNo (g x') /\ x' * g x' = 1)
 -> forall k, nat_p k ->
         (forall y :e SNo_recipaux x g k 0, SNo y /\ x * y < 1)
      /\ (forall y :e SNo_recipaux x g k 1, SNo y /\ 1 < x * y).
admit.
Qed.

Theorem SNo_recipaux_lem2: forall x, SNo x -> 0 < x ->
 forall g:set -> set,
    (forall x' :e SNoS_ (SNoLev x), 0 < x' -> SNo (g x') /\ x' * g x' = 1)
 -> SNoCutP (\/_ k :e omega, SNo_recipaux x g k 0) (\/_ k :e omega, SNo_recipaux x g k 1).
admit.
Qed.

Theorem SNo_recipaux_ext: forall x, SNo x -> forall g h:set -> set, (forall x' :e SNoS_ (SNoLev x), g x' = h x') -> forall k, nat_p k -> SNo_recipaux x g k = SNo_recipaux x h k.
admit.
Qed.

Section recip_SNo_pos.
Let G : set -> (set -> set) -> set := fun x g => SNoCut (\/_ k :e omega, SNo_recipaux x g k 0) (\/_ k :e omega, SNo_recipaux x g k 1).
Definition recip_SNo_pos : set -> set := SNo_rec_i G.

Theorem recip_SNo_pos_eq: forall x, SNo x -> recip_SNo_pos x = G x recip_SNo_pos.
admit.
Qed.

Theorem recip_SNo_pos_prop1: forall x, SNo x -> 0 < x -> SNo (recip_SNo_pos x) /\ x * recip_SNo_pos x = 1.
admit.
Qed.

Theorem SNo_recip_SNo_pos: forall x, SNo x -> 0 < x -> SNo (recip_SNo_pos x).
admit.
Qed.

Theorem recip_SNo_pos_invR: forall x, SNo x -> 0 < x -> x * recip_SNo_pos x = 1.
admit.
Qed.

Theorem recip_SNo_pos_is_pos: forall x, SNo x -> 0 < x -> 0 < recip_SNo_pos x.
admit.
Qed.

Theorem recip_SNo_pos_invol: forall x, SNo x -> 0 < x -> recip_SNo_pos (recip_SNo_pos x) = x.
admit.
Qed.

Theorem recip_SNo_pos_eps_: forall n, nat_p n -> recip_SNo_pos (eps_ n) = 2 ^ n.
admit.
Qed.

Theorem recip_SNo_pos_pow_2: forall n, nat_p n -> recip_SNo_pos (2 ^ n) = eps_ n.
admit.
Qed.

Theorem recip_SNo_pos_2: recip_SNo_pos 2 = eps_ 1.
admit.
Qed.

End recip_SNo_pos.
Definition recip_SNo : set -> set := fun x => if 0 < x then recip_SNo_pos x else if x < 0 then - recip_SNo_pos (- x) else 0.

Theorem recip_SNo_poscase: forall x, 0 < x -> recip_SNo x = recip_SNo_pos x.
admit.
Qed.

Theorem recip_SNo_negcase: forall x, SNo x -> x < 0 -> recip_SNo x = - recip_SNo_pos (- x).
admit.
Qed.

Theorem recip_SNo_0: recip_SNo 0 = 0.
admit.
Qed.

Theorem SNo_recip_SNo: forall x, SNo x -> SNo (recip_SNo x).
admit.
Qed.

Theorem recip_SNo_invR: forall x, SNo x -> x <> 0 -> x * recip_SNo x = 1.
admit.
Qed.

Theorem recip_SNo_invL: forall x, SNo x -> x <> 0 -> recip_SNo x * x = 1.
admit.
Qed.

Theorem mul_SNo_nonzero_cancel_L: forall x y z, SNo x -> x <> 0 -> SNo y -> SNo z -> x * y = x * z -> y = z.
admit.
Qed.

Theorem recip_SNo_pow_2 : forall n, nat_p n -> recip_SNo (2 ^ n) = eps_ n.
admit.
Qed.

Theorem recip_SNo_of_pos_is_pos: forall x, SNo x -> 0 < x -> 0 < recip_SNo x.
admit.
Qed.

Definition div_SNo : set -> set -> set := fun x y => x * recip_SNo y.

Infix :/: 353 := div_SNo.

Theorem SNo_div_SNo: forall x y, SNo x -> SNo y -> SNo (x :/: y).
admit.
Qed.

Theorem div_SNo_0_num: forall x, SNo x -> 0 :/: x = 0.
admit.
Qed.

Theorem div_SNo_0_denum: forall x, SNo x -> x :/: 0 = 0.
admit.
Qed.

Theorem mul_div_SNo_invL: forall x y, SNo x -> SNo y -> y <> 0 -> (x :/: y) * y = x.
admit.
Qed.

Theorem mul_div_SNo_invR: forall x y, SNo x -> SNo y -> y <> 0 -> y * (x :/: y) = x.
admit.
Qed.

Theorem mul_div_SNo_R: forall x y z, SNo x -> SNo y -> SNo z -> (x :/: y) * z = (x * z) :/: y.
admit.
Qed.

Theorem mul_div_SNo_L: forall x y z, SNo x -> SNo y -> SNo z -> z * (x :/: y) = (z * x) :/: y.
admit.
Qed.

Theorem div_mul_SNo_invL: forall x y, SNo x -> SNo y -> y <> 0 -> (x * y) :/: y = x.
admit.
Qed.

Theorem div_div_SNo: forall x y z, SNo x -> SNo y -> SNo z -> (x :/: y) :/: z = x :/: (y * z).
admit.
Qed.

Theorem mul_div_SNo_both: forall x y z w, SNo x -> SNo y -> SNo z -> SNo w -> (x :/: y) * (z :/: w) = (x * z) :/: (y * w).
admit.
Qed.

Theorem recip_SNo_pos_pos: forall x, SNo x -> 0 < x -> 0 < recip_SNo_pos x.
admit.
Qed.

Theorem div_SNo_pos_pos: forall x y, SNo x -> SNo y -> 0 < x -> 0 < y -> 0 < x :/: y.
admit.
Qed.

Theorem div_SNo_neg_pos: forall x y, SNo x -> SNo y -> x < 0 -> 0 < y -> x :/: y < 0.
admit.
Qed.

Theorem div_SNo_pos_LtL : forall x y z, SNo x -> SNo y -> SNo z -> 0 < y -> x < z * y -> x :/: y < z.
admit.
Qed.

Theorem div_SNo_pos_LtR : forall x y z, SNo x -> SNo y -> SNo z -> 0 < y -> z * y < x -> z < x :/: y.
admit.
Qed.

Theorem div_SNo_pos_LtL' : forall x y z, SNo x -> SNo y -> SNo z -> 0 < y -> x :/: y < z -> x < z * y.
admit.
Qed.

Theorem div_SNo_pos_LtR' : forall x y z, SNo x -> SNo y -> SNo z -> 0 < y -> z < x :/: y -> z * y < x.
admit.
Qed.

Theorem mul_div_SNo_nonzero_eq: forall x y z, SNo x -> SNo y -> SNo z -> y <> 0 -> x = y * z -> x :/: y = z.
admit.
Qed.

End SurrealDiv.

Opaque recip_SNo_pos recip_SNo.

Section Reals.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix :/: 353 := div_SNo.
Infix ^ 342 right := exp_SNo_nat.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.

Theorem SNoS_omega_drat_intvl : forall x :e SNoS_ omega,
  forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k.
admit.
Qed.

Theorem SNoS_ordsucc_omega_bdd_above : forall x :e SNoS_ (ordsucc omega), x < omega -> exists N :e omega, x < N.
admit.
Qed.

Theorem SNoS_ordsucc_omega_bdd_below : forall x :e SNoS_ (ordsucc omega), - omega < x -> exists N :e omega, - N < x.
admit.
Qed.

Theorem SNoS_ordsucc_omega_bdd_drat_intvl : forall x :e SNoS_ (ordsucc omega),
    - omega < x -> x < omega
 -> forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k.
admit.
Qed.

Definition real : set := {x :e SNoS_ (ordsucc omega)| x <> omega /\ x <> - omega /\ (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)}.

Theorem real_I : forall x :e SNoS_ (ordsucc omega),
    x <> omega
 -> x <> - omega
 -> (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
 -> x :e real.
admit.
Qed.

Theorem real_E : forall x :e real,
 forall p:prop,
      (SNo x
    -> SNoLev x :e ordsucc omega
    -> x :e SNoS_ (ordsucc omega)
    -> - omega < x
    -> x < omega
    -> (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
    -> (forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k)
    -> p)
   -> p.
admit.
Qed.

Theorem real_SNo : forall x :e real, SNo x.
admit.
Qed.

Theorem real_SNoS_omega_prop : forall x :e real, forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x.
admit.
Qed.

Theorem SNoS_omega_real : SNoS_ omega c= real.
admit.
Qed.

Theorem real_0 : 0 :e real.
admit.
Qed.

Theorem real_1 : 1 :e real.
admit.
Qed.

Theorem SNoLev_In_real_SNoS_omega : forall x :e real, forall w, SNo w -> SNoLev w :e SNoLev x -> w :e SNoS_ omega.
admit.
Qed.

Theorem real_SNoCut_SNoS_omega: forall L R c= SNoS_ omega, SNoCutP L R
 -> L <> 0
 -> R <> 0
 -> (forall w :e L, exists w' :e L, w < w')
 -> (forall z :e R, exists z' :e R, z' < z)
 -> SNoCut L R :e real.
admit.
Qed.

Theorem real_SNoCut: forall L R c= real, SNoCutP L R
 -> L <> 0
 -> R <> 0
 -> (forall w :e L, exists w' :e L, w < w')
 -> (forall z :e R, exists z' :e R, z' < z)
 -> SNoCut L R :e real.
admit.
Qed.

Theorem minus_SNo_prereal_1 : forall x, SNo x ->
    (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
 -> (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - - x) < eps_ k) -> q = - x).
admit.
Qed.

Theorem minus_SNo_prereal_2 : forall x, SNo x ->
    (forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k)
 -> (forall k :e omega, exists q :e SNoS_ omega, q < - x /\ - x < q + eps_ k).
admit.
Qed.

Theorem SNo_prereal_incr_lower_pos: forall x, SNo x -> 0 < x
 -> (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
 -> (forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k)
 -> forall k :e omega,
     forall p:prop,
         (forall q :e SNoS_ omega, 0 < q -> q < x -> x < q + eps_ k -> p)
      -> p.
admit.
Qed.

Theorem real_minus_SNo : forall x :e real, - x :e real.
admit.
Qed.

Theorem SNo_prereal_incr_lower_approx: forall x, SNo x ->
    (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
 -> (forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k)
 -> exists f :e SNoS_ omega :^: omega,
       forall n :e omega, f n < x /\ x < f n + eps_ n
                       /\ forall i :e n, f i < f n.
admit.
Qed.

Theorem SNo_prereal_decr_upper_approx: forall x, SNo x ->
    (forall q :e SNoS_ omega, (forall k :e omega, abs_SNo (q + - x) < eps_ k) -> q = x)
 -> (forall k :e omega, exists q :e SNoS_ omega, q < x /\ x < q + eps_ k)
 -> exists g :e SNoS_ omega :^: omega,
       forall n :e omega, g n + - eps_ n < x /\ x < g n
                       /\ forall i :e n, g n < g i.
admit.
Qed.

Theorem SNoCutP_SNoCut_lim : forall lambda, ordinal lambda
 -> (forall alpha :e lambda, ordsucc alpha :e lambda)
 -> forall L R c= SNoS_ lambda, SNoCutP L R
 -> SNoLev (SNoCut L R) :e ordsucc lambda.
admit.
Qed.

Theorem SNoCutP_SNoCut_omega : forall L R c= SNoS_ omega, SNoCutP L R
 -> SNoLev (SNoCut L R) :e ordsucc omega.
admit.
Qed.

Theorem SNo_approx_real_lem:
  forall f g :e SNoS_ omega :^: omega,
     (forall n m :e omega, f n < g m)
  -> forall p:prop,
         (SNoCutP {f n|n :e omega} {g n|n :e omega}
       -> SNo (SNoCut {f n|n :e omega} {g n|n :e omega})
       -> SNoLev (SNoCut {f n|n :e omega} {g n|n :e omega}) :e ordsucc omega
       -> SNoCut {f n|n :e omega} {g n|n :e omega} :e SNoS_ (ordsucc omega)
       -> (forall n :e omega, f n < SNoCut {f n|n :e omega} {g n|n :e omega})
       -> (forall n :e omega, SNoCut {f n|n :e omega} {g n|n :e omega} < g n)
       -> p)
      -> p.
admit.
Qed.

Theorem SNo_approx_real: forall x, SNo x ->
 forall f g :e SNoS_ omega :^: omega,
     (forall n :e omega, f n < x)
  -> (forall n :e omega, x < f n + eps_ n)
  -> (forall n :e omega, forall i :e n, f i < f n)
  -> (forall n :e omega, x < g n)
  -> (forall n :e omega, forall i :e n, g n < g i)
  -> x = SNoCut {f n|n :e omega} {g n|n :e omega}
  -> x :e real.
admit.
Qed.

Theorem SNo_approx_real_rep : forall x :e real,
 forall p:prop,
     (forall f g :e SNoS_ omega :^: omega,
           (forall n :e omega, f n < x)
        -> (forall n :e omega, x < f n + eps_ n)
        -> (forall n :e omega, forall i :e n, f i < f n)
        -> (forall n :e omega, g n + - eps_ n < x)
        -> (forall n :e omega, x < g n)
        -> (forall n :e omega, forall i :e n, g n < g i)
        -> SNoCutP {f n|n :e omega} {g n|n :e omega}
        -> x = SNoCut {f n|n :e omega} {g n|n :e omega}
        -> p)
  -> p.
admit.
Qed.

Theorem real_add_SNo : forall x y :e real, x + y :e real.
admit.
Qed.

Theorem SNoS_ordsucc_omega_bdd_eps_pos : forall x :e SNoS_ (ordsucc omega), 0 < x -> x < omega -> exists N :e omega, eps_ N * x < 1.
admit.
Qed.

Theorem real_mul_SNo_pos : forall x y :e real, 0 < x -> 0 < y -> x * y :e real.
admit.
Qed.

Theorem real_mul_SNo : forall x y :e real, x * y :e real.
admit.
Qed.

Theorem nonneg_real_nat_interval: forall x :e real, 0 <= x -> exists n :e omega, n <= x /\ x < ordsucc n.
admit.
Qed.

Theorem pos_real_left_approx_double: forall x :e real, 0 < x
 -> x <> 2 -> (forall m :e omega, x <> eps_ m)
 -> exists w :e SNoL_pos x, x < 2 * w.
admit.
Qed.

Theorem real_recip_SNo_lem1: forall x, SNo x -> x :e real -> 0 < x ->
    recip_SNo_pos x :e real
 /\ forall k, nat_p k ->
         (SNo_recipaux x recip_SNo_pos k 0 c= real)
      /\ (SNo_recipaux x recip_SNo_pos k 1 c= real).
admit.
Qed.

Theorem real_recip_SNo_pos: forall x :e real, 0 < x -> recip_SNo_pos x :e real.
admit.
Qed.

Theorem real_recip_SNo: forall x :e real, recip_SNo x :e real.
admit.
Qed.

Theorem real_div_SNo: forall x y :e real, x :/: y :e real.
admit.
Qed.

End Reals.

Opaque real.

Section even_odd.

Infix + 360 right := add_nat.
Infix * 355 right := mul_nat.

Theorem nat_le2_cases: forall m, nat_p m -> m c= 2 -> m = 0 \/ m = 1 \/ m = 2.
admit.
Qed.

Theorem prime_nat_2_lem: forall m, nat_p m -> forall n, nat_p n -> m * n = 2 -> m = 1 \/ m = 2.
admit.
Qed.

Theorem prime_nat_2: prime_nat 2.
admit.
Qed.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.

Theorem not_eq_2m_2n1: forall m n :e int, 2 * m <> 2 * n + 1.
admit.
Qed.

End even_odd.

Section form100_22b.

Let tag : set -> set := fun alpha => SetAdjoin alpha {1}.
Postfix ' 100 := tag.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.

Theorem atleastp_SNoS_ordsucc_omega_Power_omega: atleastp (SNoS_ (ordsucc omega)) (Power omega).
admit.
Qed.

Theorem Repl_finite: forall f:set -> set, forall X, finite X -> finite {f x|x :e X}.
admit.
Qed.

Theorem infinite_bigger: forall X c= omega, infinite X -> forall m :e omega, exists n :e X, m :e n.
admit.
Qed.

Theorem equip_real_Power_omega: equip real (Power omega).
admit.
Qed.

Theorem form100_22_real_uncountable_atleastp: ~atleastp real omega.
admit.
Qed.

Theorem form100_22_real_uncountable_equip: ~equip real omega.
admit.
Qed.

Theorem form100_22_real_uncountable: atleastp omega real /\ ~equip real omega.
admit.
Qed.

End form100_22b.

Section rational.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix ^ 342 right := exp_SNo_nat.
Infix :/: 353 := div_SNo.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.

Definition rational : set := {x :e real | exists m :e int, exists n :e omega :\: {0}, x = m :/: n}.

End rational.

Section form100_3.

(** The Denumerability of the Rational Numbers **)

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix :/: 353 := div_SNo.
Infix ^ 342 right := exp_SNo_nat.

Theorem Subq_int_SNoS_omega: int c= SNoS_ omega.
admit.
Qed.

Theorem Subq_SNoS_omega_rational: SNoS_ omega c= rational.
admit.
Qed.

Theorem Subq_rational_real: rational c= real.
admit.
Qed.

Theorem rational_minus_SNo: forall q :e rational, - q :e rational.
admit.
Qed.

Definition nat_pair : set -> set -> set := fun m n => 2 ^ m * (2 * n + 1).

Theorem nat_pair_In_omega: forall m n :e omega, nat_pair m n :e omega.
admit.
Qed.

Theorem nat_pair_0: forall m n m' n' :e omega, nat_pair m n = nat_pair m' n' -> m = m'.
admit.
Qed.

Theorem nat_pair_1: forall m n m' n' :e omega, nat_pair m n = nat_pair m' n' -> n = n'.
admit.
Qed.

Theorem form100_3: equip omega rational.
admit.
Qed.

End form100_3.

Section SurrealSqrt.
Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix :/: 353 := div_SNo.
Infix < 490 := SNoLt.
(* Unicode <= "2264" *)
Infix <= 490 := SNoLe.
Infix ^ 342 right := exp_SNo_nat.
Definition SNoL_nonneg : set -> set := fun x => {w :e SNoL x|0 <= w}.

Theorem SNoL_nonneg_0: SNoL_nonneg 0 = 0.
admit.
Qed.

Theorem SNoL_nonneg_1: SNoL_nonneg 1 = 1.
admit.
Qed.

Definition SNo_sqrtauxset : set -> set -> set -> set := fun Y Z x => \/_ y :e Y, {(x + y * z) :/: (y + z)|z :e Z, 0 < y + z}.

Theorem SNo_sqrtauxset_I : forall Y Z x,
 forall y :e Y, forall z :e Z, 0 < y + z -> (x + y * z) :/: (y + z) :e SNo_sqrtauxset Y Z x.
admit.
Qed.

Theorem SNo_sqrtauxset_E : forall Y Z x,
 forall u :e SNo_sqrtauxset Y Z x, forall p:prop,
     (forall y :e Y, forall z :e Z, 0 < y + z -> u = (x + y * z) :/: (y + z) -> p)
  -> p.
admit.
Qed.

Theorem SNo_sqrtauxset_0: forall Z x, SNo_sqrtauxset 0 Z x = 0.
admit.
Qed.

Theorem SNo_sqrtauxset_0': forall Y x, SNo_sqrtauxset Y 0 x = 0.
admit.
Qed.

Definition SNo_sqrtaux : set -> (set -> set) -> set -> set :=
 fun x g =>
  nat_primrec ({g w|w :e SNoL_nonneg x},{g z|z :e SNoR x})
   (fun k p => (p 0 :\/: SNo_sqrtauxset (p 0) (p 1) x,
                p 1 :\/: SNo_sqrtauxset (p 0) (p 0) x
                    :\/: SNo_sqrtauxset (p 1) (p 1) x)).

Theorem SNo_sqrtaux_0: forall x, forall g:set -> set, SNo_sqrtaux x g 0 = ({g w|w :e SNoL_nonneg x},{g z|z :e SNoR x}).
admit.
Qed.

Theorem SNo_sqrtaux_S: forall x, forall g:set -> set, forall n, nat_p n
 -> SNo_sqrtaux x g (ordsucc n)
  = (SNo_sqrtaux x g n 0
       :\/: SNo_sqrtauxset (SNo_sqrtaux x g n 0) (SNo_sqrtaux x g n 1) x,
     SNo_sqrtaux x g n 1
       :\/: SNo_sqrtauxset (SNo_sqrtaux x g n 0) (SNo_sqrtaux x g n 0) x
       :\/: SNo_sqrtauxset (SNo_sqrtaux x g n 1) (SNo_sqrtaux x g n 1) x).
admit.
Qed.

Theorem SNo_sqrtaux_mon_lem: forall x, forall g:set -> set,
  forall m, nat_p m -> forall n, nat_p n
   -> SNo_sqrtaux x g m 0 c= SNo_sqrtaux x g (add_nat m n) 0
   /\ SNo_sqrtaux x g m 1 c= SNo_sqrtaux x g (add_nat m n) 1.
admit.
Qed.

Theorem SNo_sqrtaux_mon: forall x, forall g:set -> set,
  forall m, nat_p m -> forall n, nat_p n -> m c= n
   -> SNo_sqrtaux x g m 0 c= SNo_sqrtaux x g n 0
   /\ SNo_sqrtaux x g m 1 c= SNo_sqrtaux x g n 1.
admit.
Qed.

Theorem SNo_sqrtaux_ext: forall x, SNo x -> forall g h:set -> set, (forall x' :e SNoS_ (SNoLev x), g x' = h x') -> forall k, nat_p k -> SNo_sqrtaux x g k = SNo_sqrtaux x h k.
admit.
Qed.

Section sqrt_SNo_nonneg.
Let G : set -> (set -> set) -> set := fun x g => SNoCut (\/_ k :e omega, SNo_sqrtaux x g k 0) (\/_ k :e omega, SNo_sqrtaux x g k 1).
Definition sqrt_SNo_nonneg : set -> set := SNo_rec_i G.

Theorem sqrt_SNo_nonneg_eq: forall x, SNo x -> sqrt_SNo_nonneg x = G x sqrt_SNo_nonneg.
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1a: forall x, SNo x -> 0 <= x ->
    (forall w :e SNoS_ (SNoLev x), 0 <= w -> SNo (sqrt_SNo_nonneg w) /\ 0 <= sqrt_SNo_nonneg w /\ sqrt_SNo_nonneg w * sqrt_SNo_nonneg w = w)
 -> forall k, nat_p k ->
              (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 0, SNo y /\ 0 <= y /\ y * y < x)
           /\ (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 1, SNo y /\ 0 <= y /\ x < y * y).
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1b: forall x, SNo x -> 0 <= x
 -> (forall k, nat_p k ->
              (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 0, SNo y /\ 0 <= y /\ y * y < x)
           /\ (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 1, SNo y /\ 0 <= y /\ x < y * y))
 -> SNoCutP (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0) (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1).
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1c: forall x, SNo x -> 0 <= x ->
    SNoCutP (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0) (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1)
 -> (forall z :e (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1), forall p:prop, (SNo z -> 0 <= z -> x < z * z -> p) -> p)
 -> 0 <= G x sqrt_SNo_nonneg.
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1d: forall x, SNo x -> 0 <= x
  -> (forall w :e SNoS_ (SNoLev x), 0 <= w -> SNo (sqrt_SNo_nonneg w) /\ 0 <= sqrt_SNo_nonneg w /\ sqrt_SNo_nonneg w * sqrt_SNo_nonneg w = w)
  -> SNoCutP (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0) (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1)
  -> 0 <= G x sqrt_SNo_nonneg
  -> G x sqrt_SNo_nonneg * G x sqrt_SNo_nonneg < x
  -> False.
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1e: forall x, SNo x -> 0 <= x
  -> (forall w :e SNoS_ (SNoLev x), 0 <= w -> SNo (sqrt_SNo_nonneg w) /\ 0 <= sqrt_SNo_nonneg w /\ sqrt_SNo_nonneg w * sqrt_SNo_nonneg w = w)
  -> SNoCutP (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0) (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1)
  -> 0 <= G x sqrt_SNo_nonneg
  -> x < G x sqrt_SNo_nonneg * G x sqrt_SNo_nonneg
  -> False.
admit.
Qed.

Theorem sqrt_SNo_nonneg_prop1: forall x, SNo x -> 0 <= x -> SNo (sqrt_SNo_nonneg x) /\ 0 <= sqrt_SNo_nonneg x /\ sqrt_SNo_nonneg x * sqrt_SNo_nonneg x = x.
admit.
Qed.

End sqrt_SNo_nonneg.

Theorem SNo_sqrtaux_0_1_prop: forall x, SNo x -> 0 <= x ->
  forall k, nat_p k ->
      (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 0, SNo y /\ 0 <= y /\ y * y < x)
   /\ (forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 1, SNo y /\ 0 <= y /\ x < y * y).
admit.
Qed.

Theorem SNo_sqrtaux_0_prop: forall x, SNo x -> 0 <= x ->
  forall k, nat_p k ->
  forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 0, SNo y /\ 0 <= y /\ y * y < x.
admit.
Qed.

Theorem SNo_sqrtaux_1_prop: forall x, SNo x -> 0 <= x ->
  forall k, nat_p k ->
  forall y :e SNo_sqrtaux x sqrt_SNo_nonneg k 1, SNo y /\ 0 <= y /\ x < y * y.
admit.
Qed.

Theorem SNo_sqrt_SNo_SNoCutP: forall x, SNo x -> 0 <= x ->
  SNoCutP (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0)
          (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1).
admit.
Qed.

Theorem SNo_sqrt_SNo_nonneg: forall x, SNo x -> 0 <= x -> SNo (sqrt_SNo_nonneg x).
admit.
Qed.

Theorem sqrt_SNo_nonneg_nonneg: forall x, SNo x -> 0 <= x -> 0 <= sqrt_SNo_nonneg x.
admit.
Qed.

Theorem sqrt_SNo_nonneg_sqr: forall x, SNo x -> 0 <= x -> sqrt_SNo_nonneg x * sqrt_SNo_nonneg x = x.
admit.
Qed.

Theorem sqrt_SNo_nonneg_0 : sqrt_SNo_nonneg 0 = 0.
admit.
Qed.

Theorem sqrt_SNo_nonneg_1 : sqrt_SNo_nonneg 1 = 1.
admit.
Qed.

Theorem sqrt_SNo_nonneg_0inL0: forall x, SNo x -> 0 <= x -> 0 :e SNoLev x -> 0 :e SNo_sqrtaux x sqrt_SNo_nonneg 0 0.
admit.
Qed.

Theorem sqrt_SNo_nonneg_Lnonempty: forall x, SNo x -> 0 <= x -> 0 :e SNoLev x -> (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 0) <> 0.
admit.
Qed.

Theorem sqrt_SNo_nonneg_Rnonempty: forall x, SNo x -> 0 <= x -> 1 :e SNoLev x -> (\/_ k :e omega, SNo_sqrtaux x sqrt_SNo_nonneg k 1) <> 0.
admit.
Qed.

Theorem SNo_sqrtauxset_real: forall Y Z x, Y c= real -> Z c= real -> x :e real -> SNo_sqrtauxset Y Z x c= real.
admit.
Qed.

Theorem SNo_sqrtauxset_real_nonneg: forall Y Z x, Y c= {w :e real|0 <= w} -> Z c= {z :e real|0 <= z} -> x :e real -> 0 <= x -> SNo_sqrtauxset Y Z x c= {w :e real|0 <= w}.
admit.
Qed.

Theorem sqrt_SNo_nonneg_SNoS_omega: forall x :e SNoS_ omega, 0 <= x -> sqrt_SNo_nonneg x :e real.
admit.
Qed.

Theorem sqrt_SNo_nonneg_real: forall x :e real, 0 <= x -> sqrt_SNo_nonneg x :e real.
admit.
Qed.

End SurrealSqrt.
Opaque sqrt_SNo_nonneg.

Section form100_1.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix :/: 353 := div_SNo.

Theorem divides_int_div_SNo_int: forall m n, divides_int m n -> n :/: m :e int.
admit.
Qed.

(** If m times m = 2 times n times n for naturals m and n, then n = 0. **)
Theorem form100_1_lem1 : forall m, nat_p m -> forall n, nat_p n -> m * m = 2 * n * n -> n = 0.
admit.
Qed.

(** There are no nonzero naturals m and n such that m times m = 2 times n times n. **)
Theorem form100_1_lem2 : forall m :e omega, forall n :e omega :\: 1, m * m <> 2 * n * n.
admit.
Qed.

Prefix - 358 := minus_SNo.
Infix + 360 right := add_SNo.
Infix * 355 right := mul_SNo.
Infix :/: 353 := div_SNo.

Theorem sqrt_2_irrational: sqrt_SNo_nonneg 2 :e real :\: rational.
admit.
Qed.

End form100_1.

Section Topology.

(** from §12 Topological Spaces: definition of topology on X **)
(** LATEX VERSION: A topology on a set X is a collection T of subsets of X such that ∅ and X are in T, arbitrary unions of subcollections of T lie in T, and finite intersections of elements of T lie in T. **)
(** SUSPICIOUS DEFINITION: This is a left-associated conjunction; later proofs must destruct it as ((((A /\ B) /\ C) /\ D) /\ E). **)
Definition topology_on : set -> set -> prop := fun X T =>
  T c= Power X
/\ Empty :e T
/\ X :e T
/\ (forall UFam :e Power T, Union UFam :e T)
/\ (forall U :e T, forall V :e T, U :/\: V :e T).

(** Helper: extract T c= Power X from topology_on **)
Theorem topology_sub_Power : forall X T:set,
  topology_on X T -> T c= Power X.
let X T.
assume HTx: topology_on X T.
prove T c= Power X.
(** topology_on X T = ((((T c= Power X /\ Empty :e T) /\ X :e T) /\ Union axiom) /\ Intersection axiom) **)
claim H1: (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) /\ (forall U :e T, forall V :e T, U :/\: V :e T).
{ exact HTx. }
claim H2: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))
               (forall U :e T, forall V :e T, U :/\: V :e T)
               H1). }
claim H3: (T c= Power X /\ Empty :e T) /\ X :e T.
{ exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T)
               (forall UFam :e Power T, Union UFam :e T)
               H2). }
claim H4: T c= Power X /\ Empty :e T.
{ exact (andEL (T c= Power X /\ Empty :e T) (X :e T) H3). }
exact (andEL (T c= Power X) (Empty :e T) H4).
Qed.

(** from §12: definition of open sets in a topology **)
(** LATEX VERSION: If X has topology T, a subset U of X is open exactly when U is an element of T. **)
(** SUSPICIOUS DEFINITION: `open_in X T U` bundles the hypothesis `topology_on X T`; this is convenient but means “open” cannot be stated independently of already knowing T is a topology. **)
Definition open_in : set -> set -> set -> prop := fun X T U =>
  topology_on X T /\ U :e T.

(** Helper: extract topology_on from open_in **)
Theorem open_in_topology : forall X T U:set,
  open_in X T U -> topology_on X T.
let X T U.
assume H: open_in X T U.
exact (andEL (topology_on X T) (U :e T) H).
Qed.

(** Helper: extract membership from open_in **)
Theorem open_in_elem : forall X T U:set,
  open_in X T U -> U :e T.
let X T U.
assume H: open_in X T U.
exact (andER (topology_on X T) (U :e T) H).
Qed.

(** Helper: introduction rule for open_in **)
Theorem open_inI : forall X T U:set,
  topology_on X T -> U :e T -> open_in X T U.
let X T U.
assume HT: topology_on X T.
assume HU: U :e T.
exact (andI (topology_on X T) (U :e T) HT HU).
Qed.

(** Helper: Open set is a subset of X **)
Theorem open_in_subset : forall X T U:set,
  open_in X T U -> U c= X.
let X T U.
assume HU: open_in X T U.
prove U c= X.
claim HTx: topology_on X T.
{ exact (open_in_topology X T U HU). }
claim HUT: U :e T.
{ exact (open_in_elem X T U HU). }
claim HUPower: U :e Power X.
{ exact ((topology_sub_Power X T HTx) U HUT). }
exact (PowerE X U HUPower).
Qed.

(** Helper: Elements of topology are subsets of X **)
Theorem topology_elem_subset : forall X T U:set,
  topology_on X T -> U :e T -> U c= X.
let X T U.
assume HTx: topology_on X T.
assume HU: U :e T.
prove U c= X.
claim HUPower: U :e Power X.
{ exact ((topology_sub_Power X T HTx) U HU). }
exact (PowerE X U HUPower).
Qed.

(** Helper: Empty is in every topology **)
Theorem topology_has_empty : forall X T:set,
  topology_on X T -> Empty :e T.
let X T.
assume HTx: topology_on X T.
prove Empty :e T.
(** topology_on X T = ((((T c= Power X /\ Empty :e T) /\ X :e T) /\ Union axiom) /\ Intersection axiom) **)
claim H1: (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) /\ (forall U :e T, forall V :e T, U :/\: V :e T).
{ exact HTx. }
claim H2: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) H1). }
claim H3: (T c= Power X /\ Empty :e T) /\ X :e T.
{ exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) H2). }
claim H4: T c= Power X /\ Empty :e T.
{ exact (andEL (T c= Power X /\ Empty :e T) (X :e T) H3). }
exact (andER (T c= Power X) (Empty :e T) H4).
Qed.

(** Helper: X is in every topology on X **)
Theorem topology_has_X : forall X T:set,
  topology_on X T -> X :e T.
let X T.
assume HTx: topology_on X T.
prove X :e T.
(** topology_on X T = ((((T c= Power X /\ Empty :e T) /\ X :e T) /\ Union axiom) /\ Intersection axiom) **)
claim H1: (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) /\ (forall U :e T, forall V :e T, U :/\: V :e T).
{ exact HTx. }
claim H2: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) H1). }
claim H3: (T c= Power X /\ Empty :e T) /\ X :e T.
{ exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) H2). }
exact (andER (T c= Power X /\ Empty :e T) (X :e T) H3).
Qed.

(** Helper: topology is a family of subsets **)
Theorem topology_subset_axiom : forall X T:set,
  topology_on X T -> T c= Power X.
let X T.
assume HTx: topology_on X T.
prove T c= Power X.
claim H0: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) HTx). }
claim H1: (T c= Power X /\ Empty :e T) /\ X :e T.
{ exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) H0). }
claim H2: T c= Power X /\ Empty :e T.
{ exact (andEL (T c= Power X /\ Empty :e T) (X :e T) H1). }
exact (andEL (T c= Power X) (Empty :e T) H2).
Qed.

(** Helper: Union of family in topology stays in topology **)
Theorem topology_union_closed : forall X T UFam:set,
  topology_on X T -> UFam c= T -> Union UFam :e T.
let X T UFam.
assume HTx: topology_on X T.
assume HUFam: UFam c= T.
prove Union UFam :e T.
(** Extract union axiom from topology_on **)
claim H1: (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam0 :e Power T, Union UFam0 :e T)) /\ (forall U :e T, forall V :e T, U :/\: V :e T).
{ exact HTx. }
claim H2: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam0 :e Power T, Union UFam0 :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam0 :e Power T, Union UFam0 :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) H1). }
claim HUnionAxiom: forall UFam0 :e Power T, Union UFam0 :e T.
{ exact (andER (((T c= Power X /\ Empty :e T) /\ X :e T)) (forall UFam0 :e Power T, Union UFam0 :e T) H2). }
claim HUFamPower: UFam :e Power T.
{ exact (PowerI T UFam HUFam). }
exact (HUnionAxiom UFam HUFamPower).
Qed.

(** Helper: Union axiom using Power membership **)
Theorem topology_union_closed_pow : forall X T UFam:set,
  topology_on X T -> UFam :e Power T -> Union UFam :e T.
let X T UFam.
assume HTx: topology_on X T.
assume HUFamPow: UFam :e Power T.
prove Union UFam :e T.
claim HUFamSub: UFam c= T.
{ exact (PowerE T UFam HUFamPow). }
exact (topology_union_closed X T UFam HTx HUFamSub).
Qed.

(** Helper: union axiom extracted **)
Theorem topology_union_axiom : forall X T:set,
  topology_on X T ->
  forall UFam :e Power T, Union UFam :e T.
let X T.
assume HTx: topology_on X T.
prove forall UFam :e Power T, Union UFam :e T.
let UFam. assume HUFamPow: UFam :e Power T.
exact (topology_union_closed_pow X T UFam HTx HUFamPow).
Qed.

(** Helper: Binary intersection in topology stays in topology **)
Theorem topology_binintersect_closed : forall X T U V:set,
  topology_on X T -> U :e T -> V :e T -> U :/\: V :e T.
let X T U V.
assume HTx: topology_on X T.
assume HU: U :e T.
assume HV: V :e T.
prove U :/\: V :e T.
(** Extract intersection axiom from topology_on **)
claim HIntersectAxiom: forall U0 :e T, forall V0 :e T, U0 :/\: V0 :e T.
{ exact (andER ((((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))) (forall U0 :e T, forall V0 :e T, U0 :/\: V0 :e T) HTx). }
exact (HIntersectAxiom U HU V HV).
Qed.

(** Helper: intersection axiom extracted **)
Theorem topology_binintersect_axiom : forall X T:set,
  topology_on X T ->
  forall U :e T, forall V :e T, U :/\: V :e T.
let X T.
assume HTx: topology_on X T.
prove forall U :e T, forall V :e T, U :/\: V :e T.
let U. assume HU: U :e T.
let V. assume HV: V :e T.
exact (topology_binintersect_closed X T U V HTx HU HV).
Qed.

(** Helper: Empty set is open in any topology **)
Theorem Empty_is_open : forall X T:set,
  topology_on X T -> open_in X T Empty.
let X T.
assume HTx: topology_on X T.
prove open_in X T Empty.
prove topology_on X T /\ Empty :e T.
apply andI.
- exact HTx.
- exact (topology_has_empty X T HTx).
Qed.

(** Helper: X is open in its own topology **)
Theorem X_is_open : forall X T:set,
  topology_on X T -> open_in X T X.
let X T.
assume HTx: topology_on X T.
prove open_in X T X.
prove topology_on X T /\ X :e T.
apply andI.
- exact HTx.
- exact (topology_has_X X T HTx).
Qed.

(** Helper: Union of open sets is open **)
Theorem union_open : forall X T UFam:set,
  topology_on X T ->
  (forall U :e UFam, open_in X T U) ->
  open_in X T (Union UFam).
let X T UFam.
assume HTx: topology_on X T.
assume HUFam: forall U :e UFam, open_in X T U.
prove open_in X T (Union UFam).
prove topology_on X T /\ Union UFam :e T.
apply andI.
- exact HTx.
- prove Union UFam :e T.
  claim HUFamsub: UFam c= T.
  { let U. assume HUin: U :e UFam.
    claim HUopen: open_in X T U.
    { exact (HUFam U HUin). }
    exact (andER (topology_on X T) (U :e T) HUopen).
  }
  exact (topology_union_closed X T UFam HTx HUFamsub).
Qed.

(** Helper: Binary intersection of open sets is open **)
Theorem binintersect_open : forall X T U V:set,
  open_in X T U ->
  open_in X T V ->
  open_in X T (U :/\: V).
let X T U V.
assume HU: open_in X T U.
assume HV: open_in X T V.
prove open_in X T (U :/\: V).
claim HTx: topology_on X T.
{ exact (andEL (topology_on X T) (U :e T) HU). }
claim HUinT: U :e T.
{ exact (andER (topology_on X T) (U :e T) HU). }
claim HVinT: V :e T.
{ exact (andER (topology_on X T) (V :e T) HV). }
prove topology_on X T /\ U :/\: V :e T.
apply andI.
- exact HTx.
- exact (topology_binintersect_closed X T U V HTx HUinT HVinT).
  Qed.

(** from §12: closed set as complement of open set **)
(** LATEX VERSION: A set C is closed in X (with topology T) if there exists an open set U∈T whose complement in X equals C. **)
(** SUSPICIOUS DEFINITION: This is packaged with an explicit subset condition `C c= X` and an existential complement witness; later closure lemmas must unpack that witness carefully. **)
Definition closed_in : set -> set -> set -> prop := fun X T C =>
  topology_on X T /\ (C c= X /\ exists U :e T, C = X :\: U).

(** Helper: extract topology_on from closed_in **)
Theorem closed_in_topology : forall X T C:set,
  closed_in X T C -> topology_on X T.
let X T C.
assume H: closed_in X T C.
exact (andEL (topology_on X T) (C c= X /\ exists U :e T, C = X :\: U) H).
Qed.

(** Helper: extract the complement-witness package from closed_in **)
Theorem closed_in_package : forall X T C:set,
  closed_in X T C -> C c= X /\ exists U :e T, C = X :\: U.
let X T C.
assume H: closed_in X T C.
exact (andER (topology_on X T) (C c= X /\ exists U :e T, C = X :\: U) H).
Qed.

(** Helper: introduction rule for closed_in **)
Theorem closed_inI : forall X T C:set,
  topology_on X T ->
  C c= X ->
  (exists U :e T, C = X :\: U) ->
  closed_in X T C.
let X T C.
assume HT: topology_on X T.
assume HCsub: C c= X.
assume Hex: exists U :e T, C = X :\: U.
exact (andI (topology_on X T) (C c= X /\ exists U :e T, C = X :\: U)
            HT
            (andI (C c= X) (exists U :e T, C = X :\: U) HCsub Hex)).
Qed.

(** Helper: pairing belongs to setprod via Sigma encoding **)
Theorem tuple_2_setprod_by_pair_Sigma : forall X Y:set, forall x y:set,
  x :e X -> y :e Y -> (x,y) :e setprod X Y.
let X Y x y.
assume Hx: x :e X.
assume Hy: y :e Y.
prove (x,y) :e setprod X Y.
rewrite <- (tuple_pair x y) at 1.
exact (pair_Sigma X (fun _ : set => Y) x Hx y Hy).
Qed.

(** Helper: extract existence of open complement witness from closed_in **)
Theorem closed_in_exists_open_complement : forall X T C:set,
  closed_in X T C -> exists U :e T, C = X :\: U.
let X T C.
assume H: closed_in X T C.
claim Hpack: C c= X /\ exists U :e T, C = X :\: U.
{ exact (closed_in_package X T C H). }
exact (andER (C c= X) (exists U :e T, C = X :\: U) Hpack).
Qed.

(** Helper: Closed set is a subset of X **)
Theorem closed_in_subset : forall X T C:set,
  closed_in X T C -> C c= X.
let X T C.
assume HC: closed_in X T C.
prove C c= X.
exact (andEL (C c= X) (exists U :e T, C = X :\: U) (closed_in_package X T C HC)).
Qed.

(** from §12: complement of open set is closed **)
(** LATEX VERSION: If U is open in topology T on X, then X\\U is closed in that topology. **)
Theorem closed_of_open_complement : forall X T U:set, topology_on X T -> U :e T -> closed_in X T (X :\: U).
let X. let T. let U.
assume Htop HU.
prove closed_in X T (X :\: U).
apply (closed_inI X T (X :\: U)).
- exact Htop.
- exact (setminus_Subq X U).
- witness U.
  apply andI.
  * exact HU.
  * reflexivity.
Qed.

(** Helper: X is closed in any topology **)
Theorem X_is_closed : forall X T:set,
  topology_on X T -> closed_in X T X.
let X T.
assume HTx: topology_on X T.
prove closed_in X T X.
apply (closed_inI X T X).
- exact HTx.
- exact (Subq_ref X).
- witness Empty.
  apply andI.
  * exact (topology_has_empty X T HTx).
  * prove X = X :\: Empty.
    apply set_ext.
    { let x. assume Hx: x :e X.
      prove x :e X :\: Empty.
      apply setminusI.
      - exact Hx.
      - assume H: x :e Empty.
        exact (EmptyE x H).
    }
    { let x. assume Hx: x :e X :\: Empty.
      exact (setminusE1 X Empty x Hx).
    }
Qed.

(** Helper: Empty is closed in any topology **)
Theorem Empty_is_closed : forall X T:set,
  topology_on X T -> closed_in X T Empty.
let X T.
assume HTx: topology_on X T.
prove closed_in X T Empty.
apply (closed_inI X T Empty).
- exact HTx.
- exact (Subq_Empty X).
- witness X.
  apply andI.
  * exact (topology_has_X X T HTx).
  * prove Empty = X :\: X.
    apply set_ext.
    { exact (Subq_Empty (X :\: X)). }
    { let x. assume Hx: x :e X :\: X.
      claim HxX: x :e X.
      { exact (setminusE1 X X x Hx). }
      claim HxnotX: x /:e X.
      { exact (setminusE2 X X x Hx). }
      apply FalseE.
      exact (HxnotX HxX).
    }
Qed.

(** Helper: intersection of two closed sets is closed **)
(** LATEX VERSION: Complements turn finite intersections of closed sets into finite unions of open sets. **)
Theorem closed_binintersect : forall X T C D:set,
  closed_in X T C ->
  closed_in X T D ->
  closed_in X T (C :/\: D).
let X T C D.
assume HC: closed_in X T C.
assume HD: closed_in X T D.
prove closed_in X T (C :/\: D).
claim HTx: topology_on X T.
{ exact (closed_in_topology X T C HC). }
claim HexU: exists U :e T, C = X :\: U.
{ exact (closed_in_exists_open_complement X T C HC). }
claim HexV: exists V :e T, D = X :\: V.
{ exact (closed_in_exists_open_complement X T D HD). }
apply HexU.
let U. assume HUcore.
apply HUcore.
assume HU: U :e T.
assume HCe: C = X :\: U.
apply HexV.
let V. assume HVcore.
apply HVcore.
assume HV: V :e T.
assume HDe: D = X :\: V.
set UV := Union {U,V}.
claim Hpairsub: {U,V} c= T.
{ let W. assume HW: W :e {U,V}.
  claim Hor: W = U \/ W = V.
  { exact (UPairE W U V HW). }
  apply Hor.
  - assume HWU: W = U. rewrite HWU. exact HU.
  - assume HWV: W = V. rewrite HWV. exact HV.
}
claim HUVinT: UV :e T.
{ exact (topology_union_closed X T {U,V} HTx Hpairsub). }
claim HUVeq: UV = U :\/: V.
{ apply set_ext.
  - let x. assume Hx: x :e UV.
    apply (UnionE_impred {U,V} x Hx).
    let Z. assume HxZ: x :e Z.
    assume HZ: Z :e {U,V}.
    claim Hor: Z = U \/ Z = V.
    { exact (UPairE Z U V HZ). }
    apply Hor.
    + assume HZU: Z = U.
      claim HxU: x :e U.
      { rewrite <- HZU. exact HxZ. }
      exact (binunionI1 U V x HxU).
    + assume HZV: Z = V.
      claim HxV: x :e V.
      { rewrite <- HZV. exact HxZ. }
      exact (binunionI2 U V x HxV).
  - let x. assume Hx: x :e U :\/: V.
    apply (binunionE U V x Hx).
    + assume HxU: x :e U.
      exact (UnionI {U,V} x U HxU (UPairI1 U V)).
    + assume HxV: x :e V.
      exact (UnionI {U,V} x V HxV (UPairI2 U V)).
}
claim Hsubset: (C :/\: D) c= X.
{ let x. assume Hx: x :e C :/\: D.
  claim HxC: x :e C.
  { exact (binintersectE1 C D x Hx). }
  exact (closed_in_subset X T C HC x HxC). }
claim Heq: (C :/\: D) = X :\: UV.
{ rewrite HCe.
  rewrite HDe.
  apply set_ext.
  - let x. assume Hx: x :e (X :\: U) :/\: (X :\: V).
    prove x :e X :\: UV.
    claim HxU: x :e X :\: U.
    { exact (binintersectE1 (X :\: U) (X :\: V) x Hx). }
    claim HxV: x :e X :\: V.
    { exact (binintersectE2 (X :\: U) (X :\: V) x Hx). }
    claim HxX: x :e X.
    { exact (setminusE1 X U x HxU). }
    claim HxNotU: x /:e U.
    { exact (setminusE2 X U x HxU). }
    claim HxNotV: x /:e V.
    { exact (setminusE2 X V x HxV). }
    claim HxNotUV: x /:e UV.
    { assume HxUV: x :e UV.
      apply (UnionE_impred {U,V} x HxUV).
      let Z. assume HxZ: x :e Z.
      assume HZ: Z :e {U,V}.
      claim Hor: Z = U \/ Z = V.
      { exact (UPairE Z U V HZ). }
      apply Hor.
      + assume HZU: Z = U.
        claim HxU2: x :e U.
        { rewrite <- HZU. exact HxZ. }
        exact (HxNotU HxU2).
      + assume HZV: Z = V.
        claim HxV2: x :e V.
        { rewrite <- HZV. exact HxZ. }
        exact (HxNotV HxV2). }
    exact (setminusI X UV x HxX HxNotUV).
  - let x. assume Hx: x :e X :\: UV.
    prove x :e (X :\: U) :/\: (X :\: V).
    claim HxX: x :e X.
    { exact (setminusE1 X UV x Hx). }
    claim HxNotUV: x /:e UV.
    { exact (setminusE2 X UV x Hx). }
    claim HxNotU: x /:e U.
    { assume HxU: x :e U.
      claim HxUV: x :e UV.
      { exact (UnionI {U,V} x U HxU (UPairI1 U V)). }
      exact (HxNotUV HxUV). }
    claim HxNotV: x /:e V.
    { assume HxV: x :e V.
      claim HxUV: x :e UV.
      { exact (UnionI {U,V} x V HxV (UPairI2 U V)). }
      exact (HxNotUV HxUV). }
    apply binintersectI.
    + exact (setminusI X U x HxX HxNotU).
    + exact (setminusI X V x HxX HxNotV). }
apply (closed_inI X T (C :/\: D)).
- exact HTx.
- exact Hsubset.
- witness UV.
  apply andI.
  * exact HUVinT.
  * exact Heq.
Qed.

(** Helper: union of two closed sets is closed **)
(** LATEX VERSION: Complements turn finite unions of closed sets into finite intersections of open sets. **)
Theorem closed_binunion : forall X T C D:set,
  closed_in X T C ->
  closed_in X T D ->
  closed_in X T (C :\/: D).
let X T C D.
assume HC: closed_in X T C.
assume HD: closed_in X T D.
prove closed_in X T (C :\/: D).
claim HTx: topology_on X T.
{ exact (closed_in_topology X T C HC). }
claim HexU: exists U :e T, C = X :\: U.
{ exact (closed_in_exists_open_complement X T C HC). }
claim HexV: exists V :e T, D = X :\: V.
{ exact (closed_in_exists_open_complement X T D HD). }
apply HexU.
let U. assume HUcore.
apply HUcore.
assume HU: U :e T.
assume HCe: C = X :\: U.
apply HexV.
let V. assume HVcore.
apply HVcore.
assume HV: V :e T.
assume HDe: D = X :\: V.
set W := U :/\: V.
claim HW: W :e T.
{ exact (topology_binintersect_closed X T U V HTx HU HV). }
claim Hsubset: (C :\/: D) c= X.
{ let x. assume Hx: x :e C :\/: D.
  apply (binunionE C D x Hx).
  - assume HxC: x :e C.
    exact (closed_in_subset X T C HC x HxC).
  - assume HxD: x :e D.
    exact (closed_in_subset X T D HD x HxD). }
claim Heq: (C :\/: D) = X :\: W.
{ rewrite HCe.
  rewrite HDe.
  apply set_ext.
  - let x. assume Hx: x :e (X :\: U) :\/: (X :\: V).
    prove x :e X :\: W.
    apply (binunionE (X :\: U) (X :\: V) x Hx).
    + assume HxU: x :e X :\: U.
      claim HxX: x :e X.
      { exact (setminusE1 X U x HxU). }
      claim HxNotU: x /:e U.
      { exact (setminusE2 X U x HxU). }
      claim HxNotW: x /:e W.
      { assume HxW: x :e W.
        claim HxUin: x :e U.
        { exact (binintersectE1 U V x HxW). }
        exact (HxNotU HxUin). }
      exact (setminusI X W x HxX HxNotW).
    + assume HxV: x :e X :\: V.
      claim HxX: x :e X.
      { exact (setminusE1 X V x HxV). }
      claim HxNotV: x /:e V.
      { exact (setminusE2 X V x HxV). }
      claim HxNotW: x /:e W.
      { assume HxW: x :e W.
        claim HxVin: x :e V.
        { exact (binintersectE2 U V x HxW). }
        exact (HxNotV HxVin). }
      exact (setminusI X W x HxX HxNotW).
  - let x. assume Hx: x :e X :\: W.
    prove x :e (X :\: U) :\/: (X :\: V).
    claim HxX: x :e X.
    { exact (setminusE1 X W x Hx). }
    claim HxNotW: x /:e W.
    { exact (setminusE2 X W x Hx). }
    apply (xm (x :e U)).
    + assume HxUin: x :e U.
      claim HxNotV: x /:e V.
      { assume HxVin: x :e V.
        claim HxW: x :e W.
        { exact (binintersectI U V x HxUin HxVin). }
        exact (HxNotW HxW). }
      exact (binunionI2 (X :\: U) (X :\: V) x (setminusI X V x HxX HxNotV)).
    + assume HxNotU: ~(x :e U).
      exact (binunionI1 (X :\: U) (X :\: V) x (setminusI X U x HxX HxNotU)). }
apply (closed_inI X T (C :\/: D)).
- exact HTx.
- exact Hsubset.
- witness W.
  apply andI.
  * exact HW.
  * exact Heq.
Qed.

(** Helper: Complement of closed set is open **)
Theorem open_of_closed_complement : forall X T C:set,
  closed_in X T C -> open_in X T (X :\: C).
let X T C.
assume HC: closed_in X T C.
prove open_in X T (X :\: C).
claim HTx: topology_on X T.
{ exact (closed_in_topology X T C HC). }
claim HCex: exists U :e T, C = X :\: U.
{ exact (closed_in_exists_open_complement X T C HC). }
apply HCex.
let U. assume HU: U :e T /\ C = X :\: U.
claim HUinT: U :e T.
{ exact (andEL (U :e T) (C = X :\: U) HU). }
claim HCeq: C = X :\: U.
{ exact (andER (U :e T) (C = X :\: U) HU). }
claim HUsubX: U c= X.
{ exact (topology_elem_subset X T U HTx HUinT). }
claim HXCe: X :\: C = U.
{ rewrite HCeq.
  prove X :\: (X :\: U) = U.
  apply set_ext.
  - let x. assume Hx: x :e X :\: (X :\: U).
    prove x :e U.
    claim HxX: x :e X.
    { exact (setminusE1 X (X :\: U) x Hx). }
    claim HxnotXU: x /:e X :\: U.
    { exact (setminusE2 X (X :\: U) x Hx). }
    apply (xm (x :e U)).
    + assume HxU: x :e U.
      exact HxU.
    + assume HxnotU: x /:e U.
      claim HxXU: x :e X :\: U.
      { apply setminusI.
        - exact HxX.
        - exact HxnotU.
      }
      apply FalseE.
      exact (HxnotXU HxXU).
  - let x. assume Hx: x :e U.
    prove x :e X :\: (X :\: U).
    claim HxX: x :e X.
    { exact (HUsubX x Hx). }
    apply setminusI.
    + exact HxX.
    + assume HxXU: x :e X :\: U.
      claim HxnotU: x /:e U.
      { exact (setminusE2 X U x HxXU). }
      exact (HxnotU Hx).
}
apply (open_inI X T (X :\: C) HTx).
rewrite HXCe.
exact HUinT.
Qed.

(** Helper: binary union is union of a pair **)
Theorem binunion_eq_Union_pair : forall X Y:set, X :\/: Y = Union {X,Y}.
let X Y.
apply set_ext.
- let z. assume Hz: z :e X :\/: Y.
  prove z :e Union {X,Y}.
  apply (binunionE X Y z Hz).
  - assume HzX: z :e X.
    apply (UnionI {X,Y} z X).
    + exact HzX.
    + exact (UPairI1 X Y).
  - assume HzY: z :e Y.
    apply (UnionI {X,Y} z Y).
    + exact HzY.
    + exact (UPairI2 X Y).
- let z. assume Hz: z :e Union {X,Y}.
  prove z :e X :\/: Y.
  apply (UnionE_impred {X,Y} z Hz).
  let Z.
  assume HzZ: z :e Z.
  assume HZ: Z :e {X,Y}.
  claim Hor: Z = X \/ Z = Y.
  { exact (UPairE Z X Y HZ). }
  apply Hor.
  - assume HZX: Z = X.
    claim HzX: z :e X.
    { rewrite <- HZX. exact HzZ. }
    exact (binunionI1 X Y z HzX).
  - assume HZY: Z = Y.
    claim HzY: z :e Y.
    { rewrite <- HZY. exact HzZ. }
    exact (binunionI2 X Y z HzY).
Qed.

(** Helper: binary union of members of a topology is in the topology **)
(** LATEX VERSION: Since U ∪ V is the union of the pair {U,V}, any topology is closed under binary unions. **)
Theorem topology_binunion_closed : forall X T U V:set,
  topology_on X T -> U :e T -> V :e T -> U :\/: V :e T.
let X T U V.
assume HTx: topology_on X T.
assume HU: U :e T.
assume HV: V :e T.
prove U :\/: V :e T.
claim Hpairsub: {U,V} c= T.
{ let W. assume HW: W :e {U,V}.
  claim Hor: W = U \/ W = V.
  { exact (UPairE W U V HW). }
  apply Hor.
  - assume HWU: W = U.
    rewrite HWU. exact HU.
  - assume HWV: W = V.
    rewrite HWV. exact HV.
}
claim HUnionPair: Union {U,V} :e T.
{ exact (topology_union_closed X T {U,V} HTx Hpairsub). }
rewrite (binunion_eq_Union_pair U V).
exact HUnionPair.
Qed.

(** Helper: binary union of open sets is open **)
(** LATEX VERSION: The union of two open sets is open. **)
Theorem binunion_open : forall X T U V:set,
  open_in X T U ->
  open_in X T V ->
  open_in X T (U :\/: V).
let X T U V.
assume HU: open_in X T U.
assume HV: open_in X T V.
prove open_in X T (U :\/: V).
claim HTx: topology_on X T.
{ exact (andEL (topology_on X T) (U :e T) HU). }
claim HUinT: U :e T.
{ exact (andER (topology_on X T) (U :e T) HU). }
claim HVinT: V :e T.
{ exact (andER (topology_on X T) (V :e T) HV). }
prove topology_on X T /\ (U :\/: V) :e T.
apply andI.
- exact HTx.
- exact (topology_binunion_closed X T U V HTx HUinT HVinT).
Qed.

(** from §12: "finer than" / "coarser than" topologies **)
(** LATEX VERSION: Given topologies T and T' on X, T' is finer than T if T' ⊃ T; T is coarser than T'; the topologies are comparable if one contains the other. **)
Definition finer_than : set -> set -> prop := fun T' T => T c= T'.

(** LATEX VERSION: Coarser is the reverse inclusion: T' is coarser than T when T' ⊂ T. **)
Definition coarser_than : set -> set -> prop := fun T' T => T' c= T.


(** from §12 Example 2: discrete topology **)
(** LATEX VERSION: Example 2 defines the discrete topology on X as the collection of all subsets of X. **)
Definition discrete_topology : set -> set := fun X => Power X.

(** from §12: indiscrete/trivial topology **)
(** LATEX VERSION: The indiscrete (trivial) topology on X consists only of X and ∅. **)
Definition indiscrete_topology : set -> set := fun X => {Empty, X}.

(** from §12 Example 3: finite complement topology **)
(** LATEX VERSION: Example 3 defines T_f = { U ⊂ X | X\\U is finite or U = ∅ }, the finite complement topology. **)
Definition finite_complement_topology : set -> set :=
  fun X => {U :e Power X | finite (X :\: U) \/ U = Empty}.

(** helper: countable set: admits an injection into omega (at most countable) **)
(** LATEX VERSION: A set is countable if it admits an injection into ω (at most countable). **)
(** NOTE: `atleastp X omega` is used here in the sense “there exists an injection from X into omega” (cardinality at most omega). **)
(** SUSPICIOUS DEFINITION: This is “at most countable” (injects into omega), not “countably infinite” (equip omega). Later statements must use the intended meaning consistently. **)
Definition countable : set -> prop := fun X => atleastp X omega.

(** LATEX VERSION: Every finite set is countable. **)
Theorem finite_countable : forall X:set, finite X -> countable X.
let X. assume Hfin.
apply Hfin.
let n. assume Hpair: n :e omega /\ equip X n.
claim Hn : n :e omega.
{ exact (andEL (n :e omega) (equip X n) Hpair). }
claim Heq : equip X n.
{ exact (andER (n :e omega) (equip X n) Hpair). }
claim Hn_sub : n c= omega.
{ exact (omega_TransSet n Hn). }
claim Hcount_n : atleastp n omega.
{ exact (Subq_atleastp n omega Hn_sub). }
claim Hcount_X : atleastp X n.
{ exact (equip_atleastp X n Heq). }
exact (atleastp_tra X n omega Hcount_X Hcount_n).
Qed.

(** Helper: Empty is countable **)
Theorem countable_Empty : countable Empty.
exact (Subq_atleastp Empty omega (Subq_Empty omega)).
Qed.

(** Helper: Subset of countable set is countable **)
Theorem Subq_countable : forall X Y:set, countable Y -> X c= Y -> countable X.
let X Y. assume HcountY HsubXY.
prove atleastp X omega.
apply atleastp_tra X Y omega.
- exact (Subq_atleastp X Y HsubXY).
- exact HcountY.
Qed.

(** Helper: intersection of a countable set with any set is countable **)
(** LATEX VERSION: Any subset of a countable set is countable; in particular X∩Y is countable if X is countable. **)
Theorem binintersect_countable_left : forall X Y:set,
  countable X -> countable (X :/\: Y).
let X Y.
assume HcountX: countable X.
prove countable (X :/\: Y).
apply (Subq_countable (X :/\: Y) X HcountX).
exact (binintersect_Subq_1 X Y).
Qed.

(** Helper: set difference of a countable set is countable **)
(** LATEX VERSION: X\\A is countable if X is countable. **)
Theorem setminus_countable : forall X A:set,
  countable X -> countable (X :\: A).
let X A.
assume HcountX: countable X.
prove countable (X :\: A).
apply (Subq_countable (X :\: A) X HcountX).
exact (setminus_Subq X A).
Qed.

(** Helper: Union of two countable sets is countable **)
(** NOTE: This requires some form of choice or construction **)
Theorem binunion_countable : forall X Y:set, countable X -> countable Y -> countable (X :\/: Y).
let X Y.
assume HcountX: countable X.
assume HcountY: countable Y.
prove countable (X :\/: Y).
prove exists h : set -> set, inj (X :\/: Y) omega h.
apply HcountX.
let f : set -> set.
assume Hf: inj X omega f.
apply HcountY.
let g : set -> set.
assume Hg: inj Y omega g.
set h : set -> set := (fun u:set => if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u)).
witness h.
prove inj (X :\/: Y) omega h.
apply (injI (X :\/: Y) omega h).
- (** h maps union into omega **)
  let u. assume Hu: u :e X :\/: Y.
  prove h u :e omega.
  claim HuXY: u :e X \/ u :e Y.
  { exact (binunionE X Y u Hu). }
  apply (xm (u :e X)).
  * assume HuX: u :e X.
    claim Hfmap: forall a :e X, f a :e omega.
    { exact (andEL (forall a :e X, f a :e omega)
                   (forall a b :e X, f a = f b -> a = b)
                   Hf). }
    claim Hu0: 0 :e omega.
    { exact (nat_p_omega 0 nat_0). }
    claim Hfu: f u :e omega.
    { exact (Hfmap u HuX). }
    claim Hp: nat_pair 0 (f u) :e omega.
    { exact (nat_pair_In_omega 0 Hu0 (f u) Hfu). }
	    claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
	    { reflexivity. }
	    rewrite Hhu_def.
	    rewrite (If_i_1 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HuX).
	    exact Hp.
  * assume HnotuX: ~(u :e X).
    claim Hug: u :e Y.
    { apply (HuXY (u :e Y)).
      - assume HuX: u :e X.
        apply FalseE.
        exact (HnotuX HuX).
      - assume HuY: u :e Y.
        exact HuY. }
    claim Hgmap: forall a :e Y, g a :e omega.
    { exact (andEL (forall a :e Y, g a :e omega)
                   (forall a b :e Y, g a = g b -> a = b)
                   Hg). }
    claim Hu1: 1 :e omega.
    { exact (nat_p_omega 1 nat_1). }
    claim Hgu: g u :e omega.
    { exact (Hgmap u Hug). }
    claim Hp: nat_pair 1 (g u) :e omega.
    { exact (nat_pair_In_omega 1 Hu1 (g u) Hgu). }
	    claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
	    { reflexivity. }
	    rewrite Hhu_def.
	    rewrite (If_i_0 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HnotuX).
	    exact Hp.
- (** h is injective on union **)
  let u. assume Hu: u :e X :\/: Y.
  let v. assume Hv: v :e X :\/: Y.
  assume Heq: h u = h v.
  prove u = v.
  claim HuXY: u :e X \/ u :e Y.
  { exact (binunionE X Y u Hu). }
  claim HvXY: v :e X \/ v :e Y.
  { exact (binunionE X Y v Hv). }
  claim Hfmap: forall a :e X, f a :e omega.
  { exact (andEL (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hfinj: forall a b :e X, f a = f b -> a = b.
  { exact (andER (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hgmap: forall a :e Y, g a :e omega.
  { exact (andEL (forall a :e Y, g a :e omega)
                 (forall a b :e Y, g a = g b -> a = b)
                 Hg). }
  claim Hginj: forall a b :e Y, g a = g b -> a = b.
  { exact (andER (forall a :e Y, g a :e omega)
                 (forall a b :e Y, g a = g b -> a = b)
                 Hg). }
  apply (xm (u :e X)).
  * assume HuX: u :e X.
    apply (xm (v :e X)).
    + assume HvX: v :e X.
      claim Hu0: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      claim Hfu: f u :e omega.
      { exact (Hfmap u HuX). }
      claim Hfv: f v :e omega.
      { exact (Hfmap v HvX). }
      claim Hhueq: h u = nat_pair 0 (f u).
      { claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
        { reflexivity. }
        rewrite Hhu_def.
        rewrite (If_i_1 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HuX).
        reflexivity. }
      claim Hhveq: h v = nat_pair 0 (f v).
      { claim Hhv_def: h v = if v :e X then nat_pair 0 (f v) else nat_pair 1 (g v).
        { reflexivity. }
        rewrite Hhv_def.
        rewrite (If_i_1 (v :e X) (nat_pair 0 (f v)) (nat_pair 1 (g v)) HvX).
        reflexivity. }
      claim Hpair: nat_pair 0 (f u) = nat_pair 0 (f v).
      { rewrite <- Hhueq.
        rewrite <- Hhveq.
        exact Heq. }
      claim HfuEq: f u = f v.
      { exact (nat_pair_1 0 Hu0 (f u) Hfu 0 Hu0 (f v) Hfv Hpair). }
      exact (Hfinj u HuX v HvX HfuEq).
    + assume HnotvX: ~(v :e X).
      claim HvY: v :e Y.
      { apply (HvXY (v :e Y)).
        - assume HvX: v :e X.
          apply FalseE.
          exact (HnotvX HvX).
        - assume HvY: v :e Y.
          exact HvY. }
      claim Hu0: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      claim Hu1: 1 :e omega.
      { exact (nat_p_omega 1 nat_1). }
      claim Hfu: f u :e omega.
      { exact (Hfmap u HuX). }
      claim Hgv: g v :e omega.
      { exact (Hgmap v HvY). }
      claim Hhueq: h u = nat_pair 0 (f u).
      { claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
        { reflexivity. }
        rewrite Hhu_def.
        rewrite (If_i_1 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HuX).
        reflexivity. }
      claim Hhveq: h v = nat_pair 1 (g v).
      { claim Hhv_def: h v = if v :e X then nat_pair 0 (f v) else nat_pair 1 (g v).
        { reflexivity. }
        rewrite Hhv_def.
        rewrite (If_i_0 (v :e X) (nat_pair 0 (f v)) (nat_pair 1 (g v)) HnotvX).
        reflexivity. }
      claim Hpair: nat_pair 0 (f u) = nat_pair 1 (g v).
      { rewrite <- Hhueq.
        rewrite <- Hhveq.
        exact Heq. }
      claim H01: 0 = 1.
      { exact (nat_pair_0 0 Hu0 (f u) Hfu 1 Hu1 (g v) Hgv Hpair). }
      apply FalseE.
      exact (neq_0_1 H01).
  * assume HnotuX: ~(u :e X).
    claim HuY: u :e Y.
    { apply (HuXY (u :e Y)).
      - assume HuX: u :e X.
        apply FalseE.
        exact (HnotuX HuX).
      - assume HuY: u :e Y.
        exact HuY. }
    apply (xm (v :e X)).
    + assume HvX: v :e X.
      claim Hu0: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      claim Hu1: 1 :e omega.
      { exact (nat_p_omega 1 nat_1). }
      claim Hfv: f v :e omega.
      { exact (Hfmap v HvX). }
      claim Hgu: g u :e omega.
      { exact (Hgmap u HuY). }
      claim Hhueq: h u = nat_pair 1 (g u).
      { claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
        { reflexivity. }
        rewrite Hhu_def.
        rewrite (If_i_0 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HnotuX).
        reflexivity. }
      claim Hhveq: h v = nat_pair 0 (f v).
      { claim Hhv_def: h v = if v :e X then nat_pair 0 (f v) else nat_pair 1 (g v).
        { reflexivity. }
        rewrite Hhv_def.
        rewrite (If_i_1 (v :e X) (nat_pair 0 (f v)) (nat_pair 1 (g v)) HvX).
        reflexivity. }
      claim Hpair: nat_pair 1 (g u) = nat_pair 0 (f v).
      { rewrite <- Hhueq.
        rewrite <- Hhveq.
        exact Heq. }
      claim H10: 1 = 0.
      { exact (nat_pair_0 1 Hu1 (g u) Hgu 0 Hu0 (f v) Hfv Hpair). }
      claim H01: 0 = 1.
      { symmetry. exact H10. }
      apply FalseE.
      exact (neq_0_1 H01).
    + assume HnotvX: ~(v :e X).
      claim HvY: v :e Y.
      { apply (HvXY (v :e Y)).
        - assume HvX: v :e X.
          apply FalseE.
          exact (HnotvX HvX).
        - assume HvY: v :e Y.
          exact HvY. }
      claim Hu1: 1 :e omega.
      { exact (nat_p_omega 1 nat_1). }
      claim Hgu: g u :e omega.
      { exact (Hgmap u HuY). }
      claim Hgv: g v :e omega.
      { exact (Hgmap v HvY). }
      claim Hhueq: h u = nat_pair 1 (g u).
      { claim Hhu_def: h u = if u :e X then nat_pair 0 (f u) else nat_pair 1 (g u).
        { reflexivity. }
        rewrite Hhu_def.
        rewrite (If_i_0 (u :e X) (nat_pair 0 (f u)) (nat_pair 1 (g u)) HnotuX).
        reflexivity. }
      claim Hhveq: h v = nat_pair 1 (g v).
      { claim Hhv_def: h v = if v :e X then nat_pair 0 (f v) else nat_pair 1 (g v).
        { reflexivity. }
        rewrite Hhv_def.
        rewrite (If_i_0 (v :e X) (nat_pair 0 (f v)) (nat_pair 1 (g v)) HnotvX).
        reflexivity. }
      claim Hpair: nat_pair 1 (g u) = nat_pair 1 (g v).
      { rewrite <- Hhueq.
        rewrite <- Hhveq.
        exact Heq. }
      claim HguEq: g u = g v.
      { exact (nat_pair_1 1 Hu1 (g u) Hgu 1 Hu1 (g v) Hgv Hpair). }
      exact (Hginj u HuY v HvY HguEq).
Qed.

(** Helper: dependent sum of countables is countable **)
(** LATEX VERSION: A countable union of countable sets is countable, encoded as a dependent sum with nat-pairing. **)
Theorem Sigma_countable : forall X:set, countable X ->
  forall Y:set->set, (forall x:set, x :e X -> countable (Y x)) ->
  countable (Sigma_ x :e X, Y x).
let X.
assume HX: countable X.
let Y.
assume HY: forall x:set, x :e X -> countable (Y x).
prove countable (Sigma_ x :e X, Y x).
prove exists h : set -> set, inj (Sigma_ x :e X, Y x) omega h.
apply HX.
let f : set -> set.
assume Hf: inj X omega f.
set graph : set -> (set -> set) -> set := fun A g => {(a, g a) | a :e A}.
set app : set -> set -> set := fun g a => Eps_i (fun n => (a,n) :e g).
set G : set -> set := fun x =>
  Eps_i (fun g => exists hx : set->set, inj (Y x) omega hx /\ g = graph (Y x) hx).
set h : set -> set := fun z =>
  nat_pair (f (proj0 z)) (app (G (proj0 z)) (proj1 z)).
witness h.

(** Helper: evaluating a graph built by Repl gives the original value **)
claim graph_app : forall A:set, forall g:set->set, forall a:set,
  a :e A -> app (graph A g) a = g a.
{ let A g a.
  assume Ha: a :e A.
  prove app (graph A g) a = g a.
  prove Eps_i (fun n => (a,n) :e graph A g) = g a.
  claim H1: (a, g a) :e graph A g.
  { exact (ReplI A (fun a0:set => (a0, g a0)) a Ha). }
  claim H2: (a, Eps_i (fun n => (a,n) :e graph A g)) :e graph A g.
  { exact (Eps_i_ax (fun n => (a,n) :e graph A g) (g a) H1). }
  apply (ReplE_impred A (fun a0:set => (a0, g a0)) (a, Eps_i (fun n => (a,n) :e graph A g)) H2).
  let a0.
  assume Ha0: a0 :e A.
  assume Heq: (a, Eps_i (fun n => (a,n) :e graph A g)) = (a0, g a0).
  claim Ha_eq: a = a0.
  { rewrite <- (tuple_2_0_eq a (Eps_i (fun n => (a,n) :e graph A g))).
    rewrite <- (tuple_2_0_eq a0 (g a0)).
    rewrite Heq.
    reflexivity. }
  claim Hn_eq: Eps_i (fun n => (a,n) :e graph A g) = g a0.
  { rewrite <- (tuple_2_1_eq a (Eps_i (fun n => (a,n) :e graph A g))) at 1.
    rewrite <- (tuple_2_1_eq a0 (g a0)) at 1.
    rewrite Heq.
    reflexivity. }
  rewrite Hn_eq.
  rewrite <- Ha_eq.
  reflexivity. }

(** Helper: graph evaluation under set equality **)
claim graph_app_eq : forall A:set, forall g:set->set, forall G0 a:set,
  a :e A -> G0 = graph A g -> app G0 a = g a.
{ let A g G0 a.
  assume Ha: a :e A.
  assume Heq: G0 = graph A g.
  prove app G0 a = g a.
  prove Eps_i (fun n => (a,n) :e G0) = g a.
  claim H1: (a, g a) :e G0.
  { rewrite Heq.
    exact (ReplI A (fun a0:set => (a0, g a0)) a Ha). }
  claim H2: (a, Eps_i (fun n => (a,n) :e G0)) :e G0.
  { exact (Eps_i_ax (fun n => (a,n) :e G0) (g a) H1). }
  claim H2g: (a, Eps_i (fun n => (a,n) :e G0)) :e graph A g.
  { rewrite <- Heq.
    exact H2. }
  apply (ReplE_impred A (fun a0:set => (a0, g a0)) (a, Eps_i (fun n => (a,n) :e G0)) H2g).
  let a0.
  assume Ha0: a0 :e A.
  assume Heq2: (a, Eps_i (fun n => (a,n) :e G0)) = (a0, g a0).
  claim Ha_eq: a = a0.
  { rewrite <- (tuple_2_0_eq a (Eps_i (fun n => (a,n) :e G0))).
    rewrite <- (tuple_2_0_eq a0 (g a0)).
    rewrite Heq2.
    reflexivity. }
  claim Hn_eq: Eps_i (fun n => (a,n) :e G0) = g a0.
  { rewrite <- (tuple_2_1_eq a (Eps_i (fun n => (a,n) :e G0))) at 1.
    rewrite <- (tuple_2_1_eq a0 (g a0)) at 1.
    rewrite Heq2.
    reflexivity. }
  rewrite Hn_eq.
  rewrite <- Ha_eq.
  reflexivity. }

apply (injI (Sigma_ x :e X, Y x) omega h).
- let z.
  assume Hz: z :e Sigma_ x :e X, Y x.
  prove h z :e omega.
  claim Hz0: proj0 z :e X.
  { exact (proj0_Sigma X Y z Hz). }
  claim Hz1: proj1 z :e Y (proj0 z).
  { exact (proj1_Sigma X Y z Hz). }
  claim Hfmap: forall a :e X, f a :e omega.
  { exact (andEL (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hfz: f (proj0 z) :e omega.
  { exact (Hfmap (proj0 z) Hz0). }
  set x0 := proj0 z.
  claim HcountY: countable (Y x0).
  { exact (HY x0 Hz0). }
  apply HcountY.
  let hx : set->set.
  assume Hhx: inj (Y x0) omega hx.
  claim HPw: exists hx0 : set->set, inj (Y x0) omega hx0 /\ graph (Y x0) hx = graph (Y x0) hx0.
  { witness hx.
    apply andI.
    - exact Hhx.
    - reflexivity. }
  claim HGdef: G x0 = Eps_i (fun g => exists hx0 : set->set, inj (Y x0) omega hx0 /\ g = graph (Y x0) hx0).
  { reflexivity. }
  claim HQG: exists hx0 : set->set, inj (Y x0) omega hx0 /\ G x0 = graph (Y x0) hx0.
  { rewrite HGdef.
    exact (Eps_i_ax (fun g => exists hx0 : set->set, inj (Y x0) omega hx0 /\ g = graph (Y x0) hx0)
                    (graph (Y x0) hx)
                    HPw). }
  apply HQG.
  let hx0 : set->set.
  assume Hhx0pair.
  apply Hhx0pair.
  assume Hhx0 HGeq.
  claim Hhx0map: forall u :e Y x0, hx0 u :e omega.
  { exact (andEL (forall u :e Y x0, hx0 u :e omega)
                 (forall u v :e Y x0, hx0 u = hx0 v -> u = v)
                 Hhx0). }
  claim Hhy: hx0 (proj1 z) :e omega.
  { exact (Hhx0map (proj1 z) Hz1). }
  claim Happ: app (G x0) (proj1 z) = hx0 (proj1 z).
  { exact (graph_app_eq (Y x0) hx0 (G x0) (proj1 z) Hz1 HGeq). }
  claim Hhdef: h z = nat_pair (f (proj0 z)) (app (G (proj0 z)) (proj1 z)).
  { reflexivity. }
  rewrite Hhdef.
  rewrite Happ.
  exact (nat_pair_In_omega (f (proj0 z)) Hfz (hx0 (proj1 z)) Hhy).
- let z1.
  assume Hz1: z1 :e Sigma_ x :e X, Y x.
  let z2.
  assume Hz2: z2 :e Sigma_ x :e X, Y x.
  assume Heq: h z1 = h z2.
  prove z1 = z2.
  claim Hz10: proj0 z1 :e X.
  { exact (proj0_Sigma X Y z1 Hz1). }
  claim Hz20: proj0 z2 :e X.
  { exact (proj0_Sigma X Y z2 Hz2). }
  claim Hz11: proj1 z1 :e Y (proj0 z1).
  { exact (proj1_Sigma X Y z1 Hz1). }
  claim Hz21: proj1 z2 :e Y (proj0 z2).
  { exact (proj1_Sigma X Y z2 Hz2). }
  claim Hfmap: forall a :e X, f a :e omega.
  { exact (andEL (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hfinj: forall a b :e X, f a = f b -> a = b.
  { exact (andER (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hfz1: f (proj0 z1) :e omega.
  { exact (Hfmap (proj0 z1) Hz10). }
  claim Hfz2: f (proj0 z2) :e omega.
  { exact (Hfmap (proj0 z2) Hz20). }
  claim Hhy1: app (G (proj0 z1)) (proj1 z1) :e omega.
  { set x1 := proj0 z1.
    claim HcountY: countable (Y x1).
    { exact (HY x1 Hz10). }
    apply HcountY.
    let hx : set->set.
    assume Hhx: inj (Y x1) omega hx.
    claim HPw: exists hx0 : set->set, inj (Y x1) omega hx0 /\ graph (Y x1) hx = graph (Y x1) hx0.
    { witness hx.
      apply andI.
      - exact Hhx.
      - reflexivity. }
    claim HGdef: G x1 = Eps_i (fun g => exists hx0 : set->set, inj (Y x1) omega hx0 /\ g = graph (Y x1) hx0).
    { reflexivity. }
    claim HQG: exists hx0 : set->set, inj (Y x1) omega hx0 /\ G x1 = graph (Y x1) hx0.
	    { rewrite HGdef.
	      exact (Eps_i_ax (fun g => exists hx0 : set->set, inj (Y x1) omega hx0 /\ g = graph (Y x1) hx0)
	                      (graph (Y x1) hx)
	                      HPw). }
	    apply HQG.
	    let hx0 : set->set.
	    assume Hhx0pair.
	    apply Hhx0pair.
	    assume Hhx0 HGeq.
	    claim Hhx0map: forall u :e Y x1, hx0 u :e omega.
	    { exact (andEL (forall u :e Y x1, hx0 u :e omega)
	                   (forall u v :e Y x1, hx0 u = hx0 v -> u = v)
	                   Hhx0). }
	    claim Hhy: hx0 (proj1 z1) :e omega.
	    { exact (Hhx0map (proj1 z1) Hz11). }
	    claim Happ: app (G x1) (proj1 z1) = hx0 (proj1 z1).
	    { exact (graph_app_eq (Y x1) hx0 (G x1) (proj1 z1) Hz11 HGeq). }
	    rewrite Happ.
	    exact Hhy. }
  claim Hhy2: app (G (proj0 z2)) (proj1 z2) :e omega.
  { set x2 := proj0 z2.
    claim HcountY: countable (Y x2).
    { exact (HY x2 Hz20). }
	    apply HcountY.
	    let hx : set->set.
	    assume Hhx: inj (Y x2) omega hx.
	    claim HPw: exists hx0 : set->set, inj (Y x2) omega hx0 /\ graph (Y x2) hx = graph (Y x2) hx0.
	    { witness hx.
	      apply andI.
	      - exact Hhx.
	      - reflexivity. }
	    claim HGdef: G x2 = Eps_i (fun g => exists hx0 : set->set, inj (Y x2) omega hx0 /\ g = graph (Y x2) hx0).
	    { reflexivity. }
	    claim HQG: exists hx0 : set->set, inj (Y x2) omega hx0 /\ G x2 = graph (Y x2) hx0.
		    { rewrite HGdef.
		      exact (Eps_i_ax (fun g => exists hx0 : set->set, inj (Y x2) omega hx0 /\ g = graph (Y x2) hx0)
		                      (graph (Y x2) hx)
		                      HPw). }
		    apply HQG.
		    let hx0 : set->set.
		    assume Hhx0pair.
		    apply Hhx0pair.
		    assume Hhx0 HGeq.
	    claim Hhx0map: forall u :e Y x2, hx0 u :e omega.
	    { exact (andEL (forall u :e Y x2, hx0 u :e omega)
	                   (forall u v :e Y x2, hx0 u = hx0 v -> u = v)
	                   Hhx0). }
	    claim Hhy: hx0 (proj1 z2) :e omega.
	    { exact (Hhx0map (proj1 z2) Hz21). }
	    claim Happ: app (G x2) (proj1 z2) = hx0 (proj1 z2).
	    { exact (graph_app_eq (Y x2) hx0 (G x2) (proj1 z2) Hz21 HGeq). }
	    rewrite Happ.
	    exact Hhy. }
  claim Hhdef1: h z1 = nat_pair (f (proj0 z1)) (app (G (proj0 z1)) (proj1 z1)).
  { reflexivity. }
  claim Hhdef2: h z2 = nat_pair (f (proj0 z2)) (app (G (proj0 z2)) (proj1 z2)).
  { reflexivity. }
  claim Hpair: nat_pair (f (proj0 z1)) (app (G (proj0 z1)) (proj1 z1))
              = nat_pair (f (proj0 z2)) (app (G (proj0 z2)) (proj1 z2)).
  { rewrite <- Hhdef1.
    rewrite <- Hhdef2.
    exact Heq. }
  claim Hxeq: proj0 z1 = proj0 z2.
  { claim Hf0: f (proj0 z1) = f (proj0 z2).
    { exact (nat_pair_0 (f (proj0 z1)) Hfz1 (app (G (proj0 z1)) (proj1 z1)) Hhy1
                        (f (proj0 z2)) Hfz2 (app (G (proj0 z2)) (proj1 z2)) Hhy2
                        Hpair). }
    exact (Hfinj (proj0 z1) Hz10 (proj0 z2) Hz20 Hf0). }
  set x := proj0 z1.
  claim HxX: x :e X.
  { exact Hz10. }
  claim Hz2x: proj0 z2 = x.
  { symmetry. exact Hxeq. }
  claim Hy21': proj1 z2 :e Y x.
  { rewrite <- Hz2x.
    exact Hz21. }
  claim Hy11': proj1 z1 :e Y x.
  { claim Hxdef: x = proj0 z1.
    { reflexivity. }
    rewrite Hxdef.
    exact Hz11. }
  claim HcountY: countable (Y x).
  { exact (HY x HxX). }
  apply HcountY.
  let hx : set->set.
  assume Hhx: inj (Y x) omega hx.
  claim HPw: exists hx0 : set->set, inj (Y x) omega hx0 /\ graph (Y x) hx = graph (Y x) hx0.
  { witness hx.
    apply andI.
    - exact Hhx.
    - reflexivity. }
  claim HGdef: G x = Eps_i (fun g => exists hx0 : set->set, inj (Y x) omega hx0 /\ g = graph (Y x) hx0).
  { reflexivity. }
  claim HQG: exists hx0 : set->set, inj (Y x) omega hx0 /\ G x = graph (Y x) hx0.
  { rewrite HGdef.
    exact (Eps_i_ax (fun g => exists hx0 : set->set, inj (Y x) omega hx0 /\ g = graph (Y x) hx0)
                    (graph (Y x) hx)
                    HPw). }
  apply HQG.
  let hx0 : set->set.
  assume Hhx0pair.
  apply Hhx0pair.
  assume Hhx0 HGeq.
  claim Hhx0inj: forall u v :e Y x, hx0 u = hx0 v -> u = v.
  { exact (andER (forall u :e Y x, hx0 u :e omega)
                 (forall u v :e Y x, hx0 u = hx0 v -> u = v)
                 Hhx0). }
  claim Happ1: app (G x) (proj1 z1) = hx0 (proj1 z1).
  { exact (graph_app_eq (Y x) hx0 (G x) (proj1 z1) Hy11' HGeq). }
  claim Happ2: app (G x) (proj1 z2) = hx0 (proj1 z2).
  { exact (graph_app_eq (Y x) hx0 (G x) (proj1 z2) Hy21' HGeq). }
  claim Hn_eq: app (G x) (proj1 z1) = app (G x) (proj1 z2).
  { claim Hn0: app (G (proj0 z1)) (proj1 z1) = app (G (proj0 z2)) (proj1 z2).
    { exact (nat_pair_1 (f (proj0 z1)) Hfz1 (app (G (proj0 z1)) (proj1 z1)) Hhy1
                        (f (proj0 z2)) Hfz2 (app (G (proj0 z2)) (proj1 z2)) Hhy2
                        Hpair). }
    claim Hxdef: x = proj0 z1.
    { reflexivity. }
    rewrite Hxdef.
    rewrite Hxeq at 2.
    exact Hn0. }
  claim Hhx0eq: hx0 (proj1 z1) = hx0 (proj1 z2).
  { rewrite <- Happ1.
    rewrite <- Happ2.
    exact Hn_eq. }
  claim Hyeq: proj1 z1 = proj1 z2.
  { exact (Hhx0inj (proj1 z1) Hy11' (proj1 z2) Hy21' Hhx0eq). }
  apply (Sigma_eta_proj0_proj1 X Y z1 Hz1).
  assume Heta1core Heta1Y.
  apply Heta1core.
  assume Heta1 Heta1X.
  apply (Sigma_eta_proj0_proj1 X Y z2 Hz2).
  assume Heta2core Heta2Y.
  apply Heta2core.
  assume Heta2 Heta2X.
  rewrite <- Heta1.
  rewrite <- Heta2.
  rewrite Hxeq.
  rewrite Hyeq.
  reflexivity.
Qed.

(** Helper: product of two countable sets is countable **)
(** LATEX VERSION: If X and Y are countable then X×Y is countable via nat-pairing of injections. **)
Theorem setprod_countable : forall X Y:set, countable X -> countable Y -> countable (X :*: Y).
let X Y.
assume HX: countable X.
assume HY: countable Y.
prove countable (X :*: Y).
prove exists h : set -> set, inj (X :*: Y) omega h.
apply HX.
let f : set -> set.
assume Hf: inj X omega f.
apply HY.
let g : set -> set.
assume Hg: inj Y omega g.
set Yc : set -> set := fun _ => Y.
set h : set -> set := fun z => nat_pair (f (proj0 z)) (g (proj1 z)).
witness h.
apply (injI (X :*: Y) omega h).
- let z. assume Hz: z :e X :*: Y.
  prove h z :e omega.
  claim Hz0: proj0 z :e X.
  { exact (proj0_Sigma X Yc z Hz). }
  claim Hz1: proj1 z :e Y.
  { exact (proj1_Sigma X Yc z Hz). }
  claim Hfmap: forall a :e X, f a :e omega.
  { exact (andEL (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hgmap: forall b :e Y, g b :e omega.
  { exact (andEL (forall b :e Y, g b :e omega)
                 (forall b1 b2 :e Y, g b1 = g b2 -> b1 = b2)
                 Hg). }
  claim Hfz: f (proj0 z) :e omega.
  { exact (Hfmap (proj0 z) Hz0). }
  claim Hgz: g (proj1 z) :e omega.
  { exact (Hgmap (proj1 z) Hz1). }
  claim Hhdef: h z = nat_pair (f (proj0 z)) (g (proj1 z)).
  { reflexivity. }
  rewrite Hhdef.
  exact (nat_pair_In_omega (f (proj0 z)) Hfz (g (proj1 z)) Hgz).
- let z1. assume Hz1: z1 :e X :*: Y.
  let z2. assume Hz2: z2 :e X :*: Y.
  assume Hhz: h z1 = h z2.
  prove z1 = z2.
  apply (Sigma_E X Yc z1 Hz1).
  let x1. assume Hx1pair.
  apply Hx1pair.
  assume Hx1X Hexy1.
  apply Hexy1.
  let y1. assume Hy1pair.
  apply Hy1pair.
  assume Hy1Y Hz1eq.
  apply (Sigma_E X Yc z2 Hz2).
  let x2. assume Hx2pair.
  apply Hx2pair.
  assume Hx2X Hexy2.
  apply Hexy2.
  let y2. assume Hy2pair.
  apply Hy2pair.
  assume Hy2Y Hz2eq.
  claim Hfmap: forall a :e X, f a :e omega.
  { exact (andEL (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hgmap: forall b :e Y, g b :e omega.
  { exact (andEL (forall b :e Y, g b :e omega)
                 (forall b1 b2 :e Y, g b1 = g b2 -> b1 = b2)
                 Hg). }
  claim Hfinj: forall a b :e X, f a = f b -> a = b.
  { exact (andER (forall a :e X, f a :e omega)
                 (forall a b :e X, f a = f b -> a = b)
                 Hf). }
  claim Hginj: forall b1 b2 :e Y, g b1 = g b2 -> b1 = b2.
  { exact (andER (forall b :e Y, g b :e omega)
                 (forall b1 b2 :e Y, g b1 = g b2 -> b1 = b2)
                 Hg). }
	  claim Hproj01: proj0 z1 = x1.
	  { rewrite (proj0_ap_0 z1).
	    rewrite Hz1eq.
	    exact (pair_ap_0 x1 y1). }
	  claim Hproj11: proj1 z1 = y1.
	  { rewrite (proj1_ap_1 z1).
	    rewrite Hz1eq.
	    exact (pair_ap_1 x1 y1). }
	  claim Hproj02: proj0 z2 = x2.
	  { rewrite (proj0_ap_0 z2).
	    rewrite Hz2eq.
	    exact (pair_ap_0 x2 y2). }
	  claim Hproj12: proj1 z2 = y2.
	  { rewrite (proj1_ap_1 z2).
	    rewrite Hz2eq.
	    exact (pair_ap_1 x2 y2). }
  claim Hh1: h z1 = nat_pair (f x1) (g y1).
  { claim Hhdef: h z1 = nat_pair (f (proj0 z1)) (g (proj1 z1)).
    { reflexivity. }
    rewrite Hhdef.
    rewrite Hproj01.
    rewrite Hproj11.
    reflexivity. }
  claim Hh2: h z2 = nat_pair (f x2) (g y2).
  { claim Hhdef: h z2 = nat_pair (f (proj0 z2)) (g (proj1 z2)).
    { reflexivity. }
    rewrite Hhdef.
    rewrite Hproj02.
    rewrite Hproj12.
    reflexivity. }
  claim Hpair: nat_pair (f x1) (g y1) = nat_pair (f x2) (g y2).
  { rewrite <- Hh1. rewrite <- Hh2. exact Hhz. }
  claim Hf1: f x1 :e omega.
  { exact (Hfmap x1 Hx1X). }
  claim Hf2: f x2 :e omega.
  { exact (Hfmap x2 Hx2X). }
  claim Hg1: g y1 :e omega.
  { exact (Hgmap y1 Hy1Y). }
  claim Hg2: g y2 :e omega.
  { exact (Hgmap y2 Hy2Y). }
  claim Heqf: f x1 = f x2.
  { exact (nat_pair_0 (f x1) Hf1 (g y1) Hg1
                      (f x2) Hf2 (g y2) Hg2
                      Hpair). }
  claim Heqx: x1 = x2.
  { exact (Hfinj x1 Hx1X x2 Hx2X Heqf). }
  claim Heqg: g y1 = g y2.
  { exact (nat_pair_1 (f x1) Hf1 (g y1) Hg1
                      (f x2) Hf2 (g y2) Hg2
                      Hpair). }
	  claim Heqy: y1 = y2.
	  { exact (Hginj y1 Hy1Y y2 Hy2Y Heqg). }
  rewrite Hz1eq.
  rewrite Hz2eq.
  rewrite Heqx.
  rewrite Heqy.
  reflexivity.
Qed.

(** Helper: Union of a family preserves Power set membership **)
Theorem Union_Power : forall X Fam:set,
  Fam c= Power X -> Union Fam c= X.
let X Fam.
assume HFam: Fam c= Power X.
prove Union Fam c= X.
let x. assume Hx: x :e Union Fam.
prove x :e X.
apply (UnionE_impred Fam x Hx).
let U. assume HxU: x :e U. assume HU: U :e Fam.
claim HUPower: U :e Power X.
{ exact (HFam U HU). }
claim HUsub: U c= X.
{ exact (PowerE X U HUPower). }
exact (HUsub x HxU).
Qed.

(** Helper: Binary intersection of Power set members is in Power set **)
Theorem binintersect_Power : forall X U V:set,
  U :e Power X -> V :e Power X -> U :/\: V :e Power X.
let X U V.
assume HU: U :e Power X.
assume HV: V :e Power X.
prove U :/\: V :e Power X.
apply PowerI.
let x. assume Hx: x :e U :/\: V.
prove x :e X.
claim HxU: x :e U.
{ exact (binintersectE1 U V x Hx). }
claim HUsub: U c= X.
{ exact (PowerE X U HU). }
exact (HUsub x HxU).
Qed.

(** Helper: intersection with Empty on the left **)
Theorem binintersect_Empty_left : forall A:set,
  Empty :/\: A = Empty.
let A.
apply Empty_Subq_eq.
exact (binintersect_Subq_1 Empty A).
Qed.

(** Helper: intersection with Empty on the right **)
Theorem binintersect_Empty_right : forall A:set,
  A :/\: Empty = Empty.
let A.
apply Empty_Subq_eq.
exact (binintersect_Subq_2 A Empty).
Qed.

(** Helper: Setminus with subset is in Power set **)
Theorem setminus_Power : forall X U:set,
  U :e Power X -> X :\: U :e Power X.
let X U.
assume HU: U :e Power X.
prove X :\: U :e Power X.
apply PowerI.
let x. assume Hx: x :e X :\: U.
prove x :e X.
exact (setminusE1 X U x Hx).
Qed.

(** from §12 Example 4: countable complement topology **)
(** LATEX VERSION: Example 4 defines T_c = { U ⊂ X | X\\U is countable or U = ∅ }, the countable complement topology. **)
Definition countable_complement_topology : set -> set :=
  fun X => {U :e Power X | countable (X :\: U) \/ U = Empty}.

(** from §12 Example 4: countable complement topology is a topology **)
(** LATEX VERSION: The countable complement collection T_c on X is a topology: ∅, X are open; arbitrary unions and finite intersections remain in T_c. **)
Theorem countable_complement_topology_on : forall X, topology_on X (countable_complement_topology X).
let X.
claim HEmptyOpen : Empty :e countable_complement_topology X.
{ exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty)
              Empty (Empty_In_Power X)
              (orIR (countable (X :\: Empty)) (Empty = Empty) (fun P H => H))). }
prove countable_complement_topology X c= Power X
/\ Empty :e countable_complement_topology X
/\ X :e countable_complement_topology X
/\ (forall UFam :e Power (countable_complement_topology X), Union UFam :e countable_complement_topology X)
/\ (forall U :e countable_complement_topology X, forall V :e countable_complement_topology X, U :/\: V :e countable_complement_topology X).
apply and5I.
- let U. assume HU: U :e countable_complement_topology X.
  exact (SepE1 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U HU).
- exact HEmptyOpen.
- claim Hdiff_empty : X :\: X = Empty.
  { apply Empty_Subq_eq.
    let x. assume Hx.
    claim HxX : x :e X.
    { exact (setminusE1 X X x Hx). }
    claim Hxnot : x /:e X.
    { exact (setminusE2 X X x Hx). }
    apply FalseE.
    exact (Hxnot HxX).
  }
  claim HcountDiff : countable (X :\: X).
  { rewrite Hdiff_empty. exact countable_Empty. }
  exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty)
              X (Self_In_Power X)
              (orIL (countable (X :\: X)) (X = Empty) HcountDiff)).
- prove forall UFam :e Power (countable_complement_topology X), Union UFam :e countable_complement_topology X.
  let UFam. assume Hfam: UFam :e Power (countable_complement_topology X).
  claim Hsub : UFam c= countable_complement_topology X.
  { exact (PowerE (countable_complement_topology X) UFam Hfam). }
  apply xm (exists U:set, U :e UFam /\ countable (X :\: U)).
  - assume Hex: exists U:set, U :e UFam /\ countable (X :\: U).
    claim HUnionInPower : Union UFam :e Power X.
    { apply PowerI X (Union UFam).
      let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUinPow : U :e Power X.
      { exact (SepE1 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U (Hsub U HUin)). }
      claim HUsubX : U c= X.
      { exact (PowerE X U HUinPow). }
      exact (HUsubX x HxU).
    }
    claim HUnionPred : countable (X :\: Union UFam) \/ Union UFam = Empty.
    { apply orIL.
      apply Hex.
      let U. assume HUdata. apply HUdata.
      assume HUin.
      assume HUcount.
      prove countable (X :\: Union UFam).
      claim Hsubset : X :\: Union UFam c= X :\: U.
      { let x. assume Hx.
        claim HxX : x :e X.
        { exact (setminusE1 X (Union UFam) x Hx). }
        claim HnotUnion : x /:e Union UFam.
        { exact (setminusE2 X (Union UFam) x Hx). }
        claim HnotU : x /:e U.
        { assume HxU.
          apply HnotUnion.
          exact (UnionI UFam x U HxU HUin).
        }
        apply setminusI.
        - exact HxX.
        - exact HnotU.
      }
      exact (Subq_countable (X :\: Union UFam) (X :\: U) HUcount Hsubset).
    }
    exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty)
                (Union UFam) HUnionInPower HUnionPred).
  - assume Hnone: ~exists U:set, U :e UFam /\ countable (X :\: U).
    claim HUnionEmpty : Union UFam = Empty.
    { apply Empty_Subq_eq.
      let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUdata : countable (X :\: U) \/ U = Empty.
      { exact (SepE2 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U (Hsub U HUin)). }
      apply HUdata (x :e Empty).
      - assume HUcount.
        apply FalseE.
        apply Hnone.
        witness U.
        apply andI.
        + exact HUin.
        + exact HUcount.
      - assume HUempty : U = Empty.
        rewrite <- HUempty.
        exact HxU.
    }
    rewrite HUnionEmpty.
    exact HEmptyOpen.
- prove forall U :e countable_complement_topology X, forall V :e countable_complement_topology X, U :/\: V :e countable_complement_topology X.
  let U. assume HU: U :e countable_complement_topology X.
  let V. assume HV: V :e countable_complement_topology X.
  claim HUdata : countable (X :\: U) \/ U = Empty.
  { exact (SepE2 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U HU). }
  claim HVdata : countable (X :\: V) \/ V = Empty.
  { exact (SepE2 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) V HV). }
  apply HUdata (U :/\: V :e countable_complement_topology X).
  * assume HUcount.
    apply HVdata (U :/\: V :e countable_complement_topology X).
    { assume HVcount.
      claim HcapInPower : U :/\: V :e Power X.
      { claim HUsub : U c= X.
        { exact (PowerE X U (SepE1 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U HU)). }
        apply PowerI X (U :/\: V).
        let x. assume HxCap.
        apply binintersectE U V x HxCap.
        assume HxU HxV.
        exact (HUsub x HxU).
      }
      claim HcapPred : countable (X :\: (U :/\: V)) \/ U :/\: V = Empty.
      { apply orIL.
        claim HcountUnion : countable ((X :\: U) :\/: (X :\: V)).
        { exact (binunion_countable (X :\: U) (X :\: V) HUcount HVcount). }
        claim Hsubset : X :\: (U :/\: V) c= (X :\: U) :\/: (X :\: V).
        { let x. assume Hx.
          claim HxX : x :e X.
          { exact (setminusE1 X (U :/\: V) x Hx). }
          claim HnotCap : x /:e U :/\: V.
          { exact (setminusE2 X (U :/\: V) x Hx). }
          apply xm (x :e U).
          - assume HxU.
            claim HnotV : x /:e V.
            { assume HxV.
              apply HnotCap.
              exact (binintersectI U V x HxU HxV).
            }
            apply binunionI2 (X :\: U) (X :\: V).
            apply setminusI X V x HxX HnotV.
          - assume HnotU.
            apply binunionI1 (X :\: U) (X :\: V).
            apply setminusI X U x HxX HnotU.
        }
        exact (Subq_countable (X :\: (U :/\: V)) ((X :\: U) :\/: (X :\: V)) HcountUnion Hsubset).
      }
      exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty)
                  (U :/\: V) HcapInPower HcapPred).
    }
    { assume HVempty : V = Empty.
      claim Hcap_empty : U :/\: V = Empty.
      { rewrite HVempty.
        apply Empty_Subq_eq.
        exact (binintersect_Subq_2 U Empty).
      }
      rewrite Hcap_empty.
      exact HEmptyOpen.
    }
  * assume HUempty : U = Empty.
    claim Hcap_empty : U :/\: V = Empty.
    { rewrite HUempty.
      apply Empty_Subq_eq.
      exact (binintersect_Subq_1 Empty V).
    }
    rewrite Hcap_empty.
    exact HEmptyOpen.
Qed.

(** from §12: discrete topology is a topology **)
(** LATEX VERSION: The discrete topology on any set X satisfies the axioms of a topology. **)
Theorem discrete_topology_on : forall X, topology_on X (discrete_topology X).
let X.
prove Power X c= Power X
/\ Empty :e Power X
/\ X :e Power X
/\ (forall UFam :e Power (Power X), Union UFam :e Power X)
/\ (forall U :e Power X, forall V :e Power X, U :/\: V :e Power X).
apply and5I.
- exact (Subq_ref (Power X)).
- apply Empty_In_Power.
- apply PowerI. exact (Subq_ref X).
- prove forall UFam :e Power (Power X), Union UFam :e Power X.
  let UFam. assume Hfam: UFam :e Power (Power X).
  apply PowerI X (Union UFam).
  let x. assume HxUnion: x :e Union UFam.
  apply UnionE_impred UFam x HxUnion.
  let U. assume HUinx: x :e U. assume HUinFam: U :e UFam.
  claim HFamSub: UFam c= Power X.
  { exact (iffEL (UFam :e Power (Power X)) (UFam c= Power X) (PowerEq (Power X) UFam) Hfam). }
  claim HUinPower: U :e Power X.
  { exact HFamSub U HUinFam. }
  claim HUsub : U c= X.
  { exact (iffEL (U :e Power X) (U c= X) (PowerEq X U) HUinPower). }
  exact (HUsub x HUinx).
- prove forall U :e Power X, forall V :e Power X, U :/\: V :e Power X.
  let U. assume HU: U :e Power X.
  let V. assume HV: V :e Power X.
  apply PowerI X (U :/\: V).
  let x. assume Hxcap: x :e U :/\: V.
  apply binintersectE U V x Hxcap.
  assume HxU HxV.
  claim HUsub: U c= X.
  { exact (iffEL (U :e Power X) (U c= X) (PowerEq X U) HU). }
  exact (HUsub x HxU).
Qed.

(** from §12: indiscrete topology is a topology **)
(** LATEX VERSION: The trivial/indiscrete topology {∅, X} on any set X satisfies the topology axioms. **)
Theorem indiscrete_topology_on : forall X, topology_on X (indiscrete_topology X).
let X.
prove indiscrete_topology X c= Power X
/\ Empty :e indiscrete_topology X
/\ X :e indiscrete_topology X
/\ (forall UFam :e Power (indiscrete_topology X), Union UFam :e indiscrete_topology X)
/\ (forall U :e indiscrete_topology X, forall V :e indiscrete_topology X, U :/\: V :e indiscrete_topology X).
apply and5I.
- let U. assume HU: U :e indiscrete_topology X.
  apply UPairE U Empty X HU.
  + assume HUe: U = Empty. rewrite HUe. exact (Empty_In_Power X).
  + assume HUX: U = X. rewrite HUX. exact (Self_In_Power X).
- exact (UPairI1 Empty X).
- exact (UPairI2 Empty X).
- prove forall UFam :e Power (indiscrete_topology X), Union UFam :e indiscrete_topology X.
  let UFam. assume Hfam: UFam :e Power (indiscrete_topology X).
  claim Hsub : UFam c= indiscrete_topology X.
  { exact (PowerE (indiscrete_topology X) UFam Hfam). }
  apply xm (exists U:set, U :e UFam /\ U = X).
  - assume Hex: exists U:set, U :e UFam /\ U = X.
    claim HUnion_sub : Union UFam c= X.
    { let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUtop : U :e indiscrete_topology X.
      { exact (Hsub U HUin). }
      apply UPairE U Empty X HUtop.
      - assume HUe: U = Empty.
        claim HxEmpty : x :e Empty.
        { rewrite <- HUe. exact HxU. }
        exact (EmptyE x HxEmpty (x :e X)).
      - assume HUX: U = X.
        rewrite <- HUX.
        exact HxU.
    }
    claim HX_sub : X c= Union UFam.
    { let x. assume HxX.
      apply Hex.
      let U. assume HUinpair : U :e UFam /\ U = X.
      claim HUin : U :e UFam.
      { exact (andEL (U :e UFam) (U = X) HUinpair). }
      claim HUeq : U = X.
      { exact (andER (U :e UFam) (U = X) HUinpair). }
      claim HxU : x :e U.
      { rewrite HUeq. exact HxX. }
      apply UnionI UFam x U HxU HUin.
    }
    claim HUnion_eq : Union UFam = X.
    { apply set_ext.
      - exact HUnion_sub.
      - exact HX_sub.
    }
    rewrite HUnion_eq.
    exact (UPairI2 Empty X).
  - assume Hnone: ~exists U:set, U :e UFam /\ U = X.
    claim HUnion_empty : Union UFam = Empty.
    { apply Empty_Subq_eq.
      let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUtop : U :e indiscrete_topology X.
      { exact (Hsub U HUin). }
      apply UPairE U Empty X HUtop.
      - assume HUe: U = Empty.
        claim HxEmpty : x :e Empty.
        { rewrite <- HUe. exact HxU. }
        exact HxEmpty.
      - assume HUX: U = X.
        apply FalseE.
        apply Hnone.
        witness U.
        apply andI.
        + exact HUin.
        + exact HUX.
    }
    rewrite HUnion_empty. exact (UPairI1 Empty X).
- prove forall U :e indiscrete_topology X, forall V :e indiscrete_topology X, U :/\: V :e indiscrete_topology X.
  let U. assume HU: U :e indiscrete_topology X.
  let V. assume HV: V :e indiscrete_topology X.
  apply UPairE U Empty X HU.
  * assume HUe: U = Empty.
    claim Hcap : U :/\: V = Empty.
    { rewrite HUe.
      apply Empty_Subq_eq.
      exact (binintersect_Subq_1 Empty V).
    }
    rewrite Hcap. exact (UPairI1 Empty X).
  * assume HUX: U = X.
    apply UPairE V Empty X HV.
    { assume HVe: V = Empty.
      claim Hcap : U :/\: V = Empty.
      { rewrite HVe.
        apply Empty_Subq_eq.
        exact (binintersect_Subq_2 U Empty).
      }
      rewrite Hcap. exact (UPairI1 Empty X).
    }
    { assume HVX: V = X.
      claim Hcap : U :/\: V = X.
      { apply set_ext.
        - rewrite HUX. rewrite HVX. exact (binintersect_Subq_1 X X).
        - let x. assume HxX.
          rewrite HUX. rewrite HVX.
          exact (binintersectI X X x HxX HxX).
      }
      rewrite Hcap. exact (UPairI2 Empty X).
    }
Qed.

(** from §12 Example 3: finite complement topology is a topology **)
(** LATEX VERSION: The finite complement collection T_f on X is a topology: ∅, X are open; arbitrary unions and finite intersections remain in T_f. **)
Theorem finite_complement_topology_on : forall X, topology_on X (finite_complement_topology X).
let X.
claim HEmptyOpen : Empty :e finite_complement_topology X.
{ exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) Empty (Empty_In_Power X) (orIR (finite (X :\: Empty)) (Empty = Empty) (fun P H => H))). }
prove finite_complement_topology X c= Power X
/\ Empty :e finite_complement_topology X
/\ X :e finite_complement_topology X
/\ (forall UFam :e Power (finite_complement_topology X), Union UFam :e finite_complement_topology X)
/\ (forall U :e finite_complement_topology X, forall V :e finite_complement_topology X, U :/\: V :e finite_complement_topology X).
apply and5I.
- let U. assume HU: U :e finite_complement_topology X.
  exact (SepE1 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU).
- exact HEmptyOpen.
- claim Hdiff_empty : X :\: X = Empty.
  { apply Empty_Subq_eq.
    let x. assume Hx.
    claim HxX : x :e X.
    { exact (setminusE1 X X x Hx). }
    claim Hxnot : x /:e X.
    { exact (setminusE2 X X x Hx). }
    apply FalseE.
    exact (Hxnot HxX).
  }
  claim HfinDiff : finite (X :\: X).
  { rewrite Hdiff_empty. exact finite_Empty. }
  exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) X (Self_In_Power X) (orIL (finite (X :\: X)) (X = Empty) HfinDiff)).
- prove forall UFam :e Power (finite_complement_topology X), Union UFam :e finite_complement_topology X.
  let UFam. assume Hfam: UFam :e Power (finite_complement_topology X).
  claim Hsub : UFam c= finite_complement_topology X.
  { exact (PowerE (finite_complement_topology X) UFam Hfam). }
  apply xm (exists U:set, U :e UFam /\ finite (X :\: U)).
  - assume Hex: exists U:set, U :e UFam /\ finite (X :\: U).
    claim HUnionInPower : Union UFam :e Power X.
    { apply PowerI X (Union UFam).
      let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUinPow : U :e Power X.
      { exact (SepE1 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U (Hsub U HUin)). }
      claim HUsub : U c= X.
      { exact (PowerE X U HUinPow). }
      exact (HUsub x HxU).
    }
    claim HUnionPred : finite (X :\: Union UFam) \/ Union UFam = Empty.
    { apply orIL.
      apply Hex.
      let U. assume Hpair : U :e UFam /\ finite (X :\: U).
      claim HUin : U :e UFam.
      { exact (andEL (U :e UFam) (finite (X :\: U)) Hpair). }
      claim HUfin : finite (X :\: U).
      { exact (andER (U :e UFam) (finite (X :\: U)) Hpair). }
      claim Hsubset : X :\: Union UFam c= X :\: U.
      { let x. assume Hx.
        claim HxX : x :e X.
        { exact (setminusE1 X (Union UFam) x Hx). }
        claim HnotUnion : x /:e Union UFam.
        { exact (setminusE2 X (Union UFam) x Hx). }
        claim HnotU : x /:e U.
        { assume HxU.
          apply HnotUnion.
          apply UnionI UFam x U HxU HUin.
        }
        apply setminusI X U x HxX HnotU.
      }
      exact (Subq_finite (X :\: U) HUfin (X :\: Union UFam) Hsubset).
    }
    exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) (Union UFam) HUnionInPower HUnionPred).
  - assume Hnone: ~exists U:set, U :e UFam /\ finite (X :\: U).
    claim HUnionEmpty : Union UFam = Empty.
    { apply Empty_Subq_eq.
      let x. assume HxUnion.
      apply UnionE_impred UFam x HxUnion.
      let U. assume HxU HUin.
      claim HUdata : finite (X :\: U) \/ U = Empty.
      { exact (SepE2 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U (Hsub U HUin)). }
      apply HUdata (x :e Empty).
      - assume HUfin.
        apply FalseE.
        apply Hnone.
        witness U.
        apply andI.
        + exact HUin.
        + exact HUfin.
      - assume HUempty : U = Empty.
        rewrite <- HUempty.
        exact HxU.
    }
    rewrite HUnionEmpty.
    exact HEmptyOpen.
- prove forall U :e finite_complement_topology X, forall V :e finite_complement_topology X, U :/\: V :e finite_complement_topology X.
  let U. assume HU: U :e finite_complement_topology X.
  let V. assume HV: V :e finite_complement_topology X.
  claim HUdata : finite (X :\: U) \/ U = Empty.
  { exact (SepE2 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU). }
  claim HVdata : finite (X :\: V) \/ V = Empty.
  { exact (SepE2 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) V HV). }
  apply HUdata (U :/\: V :e finite_complement_topology X).
  * assume HUfin.
    apply HVdata (U :/\: V :e finite_complement_topology X).
    { assume HVfin.
      claim HcapInPower : U :/\: V :e Power X.
      { claim HUsub : U c= X.
        { exact (PowerE X U (SepE1 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU)). }
        apply PowerI X (U :/\: V).
        let x. assume HxCap.
        apply binintersectE U V x HxCap.
        assume HxU HxV.
        exact (HUsub x HxU).
      }
      claim HcapPred : finite (X :\: (U :/\: V)) \/ U :/\: V = Empty.
      { apply orIL.
        claim HfinUnion : finite ((X :\: U) :\/: (X :\: V)).
        { exact (binunion_finite (X :\: U) HUfin (X :\: V) HVfin). }
        claim Hsubset : X :\: (U :/\: V) c= (X :\: U) :\/: (X :\: V).
        { let x. assume Hx.
          claim HxX : x :e X.
          { exact (setminusE1 X (U :/\: V) x Hx). }
          claim HnotCap : x /:e U :/\: V.
          { exact (setminusE2 X (U :/\: V) x Hx). }
          apply xm (x :e U).
          - assume HxU.
            claim HnotV : x /:e V.
            { assume HxV.
              apply HnotCap.
              exact (binintersectI U V x HxU HxV).
            }
            apply binunionI2 (X :\: U) (X :\: V).
            apply setminusI X V x HxX HnotV.
          - assume HnotU.
            apply binunionI1 (X :\: U) (X :\: V).
            apply setminusI X U x HxX HnotU.
        }
        exact (Subq_finite ((X :\: U) :\/: (X :\: V)) HfinUnion (X :\: (U :/\: V)) Hsubset).
      }
      exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) (U :/\: V) HcapInPower HcapPred).
    }
    { assume HVempty : V = Empty.
      claim Hcap_empty : U :/\: V = Empty.
      { rewrite HVempty.
        apply Empty_Subq_eq.
        exact (binintersect_Subq_2 U Empty).
      }
      rewrite Hcap_empty.
      exact HEmptyOpen.
    }
  * assume HUempty : U = Empty.
    claim Hcap_empty : U :/\: V = Empty.
    { rewrite HUempty.
      apply Empty_Subq_eq.
      exact (binintersect_Subq_1 Empty V).
    }
    rewrite Hcap_empty.
    exact HEmptyOpen.
Qed.

(** from §12: finer_than reflexive **)
(** LATEX VERSION: Any topology is finer than itself. **)
Theorem finer_than_refl : forall T:set, finer_than T T.
let T.
exact (Subq_ref T).
Qed.

(** from §12: finer_than transitive **)
(** LATEX VERSION: Finer-than is transitive: if T'' finer than T' and T' finer than T, then T'' finer than T. **)
Theorem finer_than_trans : forall A B C:set, finer_than B A -> finer_than C B -> finer_than C A.
let A B C.
assume H1: finer_than B A.
assume H2: finer_than C B.
exact (Subq_tra A B C H1 H2).
Qed.

(** from §12: equivalence of finer/coarser phrasing **)
(** LATEX VERSION: Saying T' is finer than T is equivalent to saying T is coarser than T'. **)
Theorem finer_coarser_dual : forall T T':set, finer_than T' T -> coarser_than T T'.
let T T'.
assume H.
exact H.
Qed.

(** from §12: comparability of topologies **)
(** LATEX VERSION: Two topologies are comparable if one contains the other. **)
(** SUSPICIOUS DEFINITION: This is defined for arbitrary families `T1,T2`; it does not assert either is a topology on any `X` unless added separately. **)
Definition comparable_topologies : set -> set -> prop := fun T1 T2 =>
  finer_than T1 T2 \/ finer_than T2 T1.

(** from §12: equality of topologies **)
(** LATEX VERSION: Topology equality on X means both are topologies on X and have identical collections of opens. **)
(** SUSPICIOUS DEFINITION: This is literal set equality `T1 = T2` bundled with `topology_on` assumptions; statements using this should not confuse it with extensional “same open sets” without equality, but in this development sets are extensional anyway. **)
Definition topology_eq : set -> set -> set -> prop := fun X T1 T2 =>
  topology_on X T1 /\ topology_on X T2 /\ T1 = T2.

(** from §12: symmetry of topology equality **)
(** LATEX VERSION: Equality of topologies is symmetric. **)
Theorem topology_eq_sym : forall X T1 T2:set, topology_eq X T1 T2 -> topology_eq X T2 T1.
let X T1 T2. assume H.
claim Hpair: topology_on X T1 /\ topology_on X T2.
{ exact (andEL (topology_on X T1 /\ topology_on X T2) (T1 = T2) H). }
claim Heq: T1 = T2.
{ exact (andER (topology_on X T1 /\ topology_on X T2) (T1 = T2) H). }
claim HT1: topology_on X T1.
{ exact (andEL (topology_on X T1) (topology_on X T2) Hpair). }
claim HT2: topology_on X T2.
{ exact (andER (topology_on X T1) (topology_on X T2) Hpair). }
prove topology_on X T2 /\ topology_on X T1 /\ T2 = T1.
apply and3I.
- exact HT2.
- exact HT1.
- rewrite <- Heq. reflexivity.
Qed.

(** from §12: transitivity of topology equality **)
(** LATEX VERSION: Equality of topologies is transitive. **)
Theorem topology_eq_trans : forall X T1 T2 T3:set, topology_eq X T1 T2 -> topology_eq X T2 T3 -> topology_eq X T1 T3.
let X T1 T2 T3.
assume H12 H23.
claim H12pair: topology_on X T1 /\ topology_on X T2.
{ exact (andEL (topology_on X T1 /\ topology_on X T2) (T1 = T2) H12). }
claim H12eq: T1 = T2.
{ exact (andER (topology_on X T1 /\ topology_on X T2) (T1 = T2) H12). }
claim HT1: topology_on X T1.
{ exact (andEL (topology_on X T1) (topology_on X T2) H12pair). }
claim HT2: topology_on X T2.
{ exact (andER (topology_on X T1) (topology_on X T2) H12pair). }
claim H23pair: topology_on X T2 /\ topology_on X T3.
{ exact (andEL (topology_on X T2 /\ topology_on X T3) (T2 = T3) H23). }
claim H23eq: T2 = T3.
{ exact (andER (topology_on X T2 /\ topology_on X T3) (T2 = T3) H23). }
claim HT3: topology_on X T3.
{ exact (andER (topology_on X T2) (topology_on X T3) H23pair). }
prove topology_on X T1 /\ topology_on X T3 /\ T1 = T3.
apply and3I.
- exact HT1.
- exact HT3.
- rewrite H12eq. rewrite H23eq. reflexivity.
Qed.

(** from §12: reflexivity of topology equality **)
(** LATEX VERSION: Any topology equals itself (with the requisite topology_on hypotheses). **)
Theorem topology_eq_refl : forall X T:set, topology_on X T -> topology_eq X T T.
let X T. assume HT.
prove topology_on X T /\ topology_on X T /\ T = T.
apply and3I.
- exact HT.
- exact HT.
- reflexivity.
Qed.

(** from §12: strict fineness/coarseness **)
(** LATEX VERSION: T' is strictly finer than T if T'⊃T and not conversely; strictly coarser is the dual. **)
(** SUSPICIOUS DEFINITION: This is stated for arbitrary sets of subsets; it does not require `T` or `T'` to satisfy `topology_on` unless added separately. **)
Definition strictly_finer_than : set -> set -> prop := fun T' T => finer_than T' T /\ ~finer_than T T'.

Definition strictly_coarser_than : set -> set -> prop := fun T' T => coarser_than T' T /\ ~coarser_than T T'.

(** from §12 examples: auxiliary aliases **)
(** LATEX VERSION: Alternate notation: discrete topology and trivial (indiscrete) topology. **)
Definition discrete_topology_alt : set -> set := discrete_topology.
Definition trivial_topology : set -> set := indiscrete_topology.

(** from §12: finer_than between topologies on same X **)
(** LATEX VERSION: A notion of T' finer than T together with both being topologies on X. **)
(** SUSPICIOUS DEFINITION: This bundles `topology_on` hypotheses; in proofs it is easy to accidentally use only the inclusion `finer_than T' T` without carrying those hypotheses along. **)
Definition finer_than_topology : set -> set -> set -> prop := fun X T' T =>
  topology_on X T' /\ topology_on X T /\ finer_than T' T.

(** from §12: finer/coarser equivalence **)
(** LATEX VERSION: Finer-than and coarser-than are logically equivalent statements with reversed arguments. **)
Theorem finer_than_def : forall T T':set, finer_than T' T <-> coarser_than T T'.
let T T'.
apply iffI.
- assume H. exact H.
- assume H. exact H.
Qed.

(** from §12: discrete topology is the finest **)
(** LATEX VERSION: The discrete topology on X is finer than any other topology on X. **)
Theorem discrete_topology_finest : forall X T:set,
  topology_on X T -> finer_than (discrete_topology X) T.
let X T. assume HT.
exact (topology_sub_Power X T HT).
Qed.

(** from §12: indiscrete topology is the coarsest **)
(** LATEX VERSION: The indiscrete topology on X is coarser than any other topology on X. **)
Theorem indiscrete_topology_coarsest : forall X T:set,
  topology_on X T -> coarser_than (indiscrete_topology X) T.
let X T. assume HT.
claim Hempty : Empty :e T.
{ exact (topology_has_empty X T HT). }
claim HX : X :e T.
{ exact (topology_has_X X T HT). }
let U. assume HU : U :e indiscrete_topology X.
apply UPairE U Empty X HU.
- assume HUempty : U = Empty. rewrite HUempty. exact Hempty.
- assume HUX : U = X. rewrite HUX. exact HX.
Qed.

(** from §12: every subset is open in discrete topology **)
(** LATEX VERSION: In the discrete topology on X, every subset U⊂X is open. **)
Theorem discrete_open_all : forall X U:set, U c= X -> U :e discrete_topology X.
let X U. assume HUsub.
apply PowerI X U HUsub.
Qed.

(** from §12: opens in indiscrete topology are Empty or X **)
(** LATEX VERSION: In the indiscrete topology, the only open sets are ∅ and X. **)
Theorem indiscrete_open_iff : forall X U:set,
  U :e indiscrete_topology X <-> (U = Empty \/ U = X).
let X U.
apply iffI.
- assume HU. exact (UPairE U Empty X HU).
- assume Hcases : U = Empty \/ U = X.
  claim HUempty_branch : U = Empty -> U :e indiscrete_topology X.
  { assume HUE : U = Empty. rewrite HUE. exact (UPairI1 Empty X). }
  claim HUx_branch : U = X -> U :e indiscrete_topology X.
  { assume HUX : U = X. rewrite HUX. exact (UPairI2 Empty X). }
  exact (Hcases (U :e indiscrete_topology X) HUempty_branch HUx_branch).
Qed.

(** from §12 Example 3: finite complement openness criterion **)
(** LATEX VERSION: In the finite complement topology, an open set U satisfies that X\\U is finite or U=∅. **)
Theorem finite_complement_topology_open_criterion : forall X U:set,
  open_in X (finite_complement_topology X) U ->
  finite (X :\: U) \/ U = Empty.
let X U. assume Hopen.
claim HUin : U :e finite_complement_topology X.
{ exact (andER (topology_on X (finite_complement_topology X)) (U :e finite_complement_topology X) Hopen). }
exact (SepE2 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HUin).
Qed.

(** from §12 Example 3: Empty is open in finite complement topology **)
(** LATEX VERSION: ∅ is an open set in the finite complement topology. **)
Theorem finite_complement_topology_contains_empty : forall X:set,
  Empty :e finite_complement_topology X.
let X.
exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) Empty (Empty_In_Power X) (orIR (finite (X :\: Empty)) (Empty = Empty) (fun P H => H))).
Qed.

(** from §12 Example 3: X is open in finite complement topology **)
(** LATEX VERSION: X itself is open in the finite complement topology. **)
Theorem finite_complement_topology_contains_full : forall X:set,
  X :e finite_complement_topology X.
let X.
claim Hdiff_empty : X :\: X = Empty.
{ apply Empty_Subq_eq.
  let x. assume Hx.
  claim Hxin : x :e X.
  { exact (setminusE1 X X x Hx). }
  claim Hxnot : x /:e X.
  { exact (setminusE2 X X x Hx). }
  apply FalseE.
  exact (Hxnot Hxin).
}
claim HfinDiff : finite (X :\: X).
{ rewrite Hdiff_empty. exact finite_Empty. }
exact (SepI (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) X (Self_In_Power X) (orIL (finite (X :\: X)) (X = Empty) HfinDiff)).
Qed.

(** from §12 Example 4: openness via countable complement **) 
(** LATEX VERSION: In the countable complement topology, an open set U has X\\U countable or U=∅. **)
Theorem countable_complement_topology_open_iff : forall X U:set,
  open_in X (countable_complement_topology X) U ->
  countable (X :\: U) \/ U = Empty.
let X U. assume Hopen.
claim HUin : U :e countable_complement_topology X.
{ exact (andER (topology_on X (countable_complement_topology X)) (U :e countable_complement_topology X) Hopen). }
exact (SepE2 (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U HUin).
Qed.

(** from §12 Example 4: Empty is open in countable complement topology **)
(** LATEX VERSION: ∅ is open in the countable complement topology. **)
Theorem countable_complement_topology_contains_empty : forall X:set,
  Empty :e countable_complement_topology X.
let X.
exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) Empty (Empty_In_Power X) (orIR (countable (X :\: Empty)) (Empty = Empty) (fun P H => H))).
Qed.

(** from §12 Example 4: X is open in countable complement topology **) 
(** LATEX VERSION: X is open in the countable complement topology. **)
Theorem countable_complement_topology_contains_full : forall X:set,
  X :e countable_complement_topology X.
let X.
claim Hdiff_empty : X :\: X = Empty.
{ apply Empty_Subq_eq.
  let x. assume Hx.
  claim HxX : x :e X.
  { exact (setminusE1 X X x Hx). }
  claim Hxnot : x /:e X.
  { exact (setminusE2 X X x Hx). }
  apply FalseE.
  exact (Hxnot HxX).
}
claim HcountDiff : countable (X :\: X).
{ rewrite Hdiff_empty. exact (Subq_atleastp Empty omega (Subq_Empty omega)). }
exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) X (Self_In_Power X) (orIL (countable (X :\: X)) (X = Empty) HcountDiff)).
Qed.

(** from §12 Example comparison: countable vs finite complement **)
(** LATEX VERSION: The countable complement topology is finer than the finite complement topology. **)
Theorem countable_complement_finer_than_finite_complement : forall X:set,
  finer_than (countable_complement_topology X) (finite_complement_topology X).
let X.
prove finite_complement_topology X c= countable_complement_topology X.
let U. assume HU: U :e finite_complement_topology X.
claim HUinPow : U :e Power X.
{ exact (SepE1 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU). }
claim HUdata : finite (X :\: U) \/ U = Empty.
{ exact (SepE2 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU). }
claim HUpred : countable (X :\: U) \/ U = Empty.
{ apply HUdata (countable (X :\: U) \/ U = Empty).
  - assume HUfin : finite (X :\: U).
    apply orIL.
    exact (finite_countable (X :\: U) HUfin).
  - assume HUemp : U = Empty.
    apply orIR.
    exact HUemp.
}
exact (SepI (Power X) (fun U0 : set => countable (X :\: U0) \/ U0 = Empty) U HUinPow HUpred).
Qed.

(** from §12 examples: finite complement coarser than discrete **)
(** LATEX VERSION: The finite complement topology is coarser than the discrete topology. **)
Theorem finite_complement_coarser_than_discrete : forall X:set,
  coarser_than (finite_complement_topology X) (discrete_topology X).
let X.
prove finite_complement_topology X c= discrete_topology X.
let U. assume HU.
exact (SepE1 (Power X) (fun U0 : set => finite (X :\: U0) \/ U0 = Empty) U HU).
Qed.

(** from §12 examples: indiscrete coarser than countable complement **) 
(** LATEX VERSION: The indiscrete topology is coarser than the countable complement topology. **)
Theorem indiscrete_coarser_than_countable_complement : forall X:set,
  coarser_than (indiscrete_topology X) (countable_complement_topology X).
let X.
prove indiscrete_topology X c= countable_complement_topology X.
let U. assume HU: U :e indiscrete_topology X.
apply UPairE U Empty X HU.
- assume HUempty: U = Empty. rewrite HUempty. exact (countable_complement_topology_contains_empty X).
- assume HUX: U = X. rewrite HUX. exact (countable_complement_topology_contains_full X).
Qed.

(** from §12: fineness via set inclusion of topologies **)
(** LATEX VERSION: A restatement of fineness between topologies on X as inclusion of their open sets. **)
Definition finer_than_topology_by_inclusion : set -> set -> set -> prop := finer_than_topology.

(** from §12: fineness via inclusion characterization **)
(** LATEX VERSION: The earlier fineness notion between topologies on X is equivalent to plain inclusion of their open sets. **)
Theorem finer_than_topology_by_inclusion_eq : forall X T' T:set,
  finer_than_topology X T' T <-> finer_than_topology_by_inclusion X T' T.
let X T' T.
apply iffI.
- assume H. exact H.
- assume H. exact H.
Qed.

(** from §12 axiom: arbitrary unions of opens are open **)
(** LATEX VERSION: In any topology, the union of any subfamily of open sets is open. **)
Theorem lemma_union_of_topology_family_open : forall X T UFam:set,
  topology_on X T ->
  UFam :e Power T ->
  Union UFam :e T.
let X T UFam. assume HT Hfam.
claim Hchunk1 : ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam' :e Power T, Union UFam' :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam' :e Power T, Union UFam' :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) HT). }
claim Hunion_axiom : forall UFam' :e Power T, Union UFam' :e T.
{ exact (andER ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam' :e Power T, Union UFam' :e T) Hchunk1). }
exact (Hunion_axiom UFam Hfam).
Qed.

(** from §12 axiom: finite intersections of opens are open **)
(** LATEX VERSION: In any topology, the intersection of two open sets is open (and hence any finite intersection). **)
Theorem lemma_intersection_two_open : forall X T U V:set,
  topology_on X T ->
  U :e T -> V :e T ->
  U :/\: V :e T.
let X T U V. assume HT HU HV.
exact (topology_binintersect_closed X T U V HT HU HV).
Qed.

(** from §12: alternative naming for topological space **)
(** LATEX VERSION: Using notation topological_space X T for topology_on X T and open_set_family/open_set for opens. **)
(** NOTE: `open_set` is defined as an alias of `open_in` to avoid duplicate bookkeeping. **)
Definition topological_space : set -> set -> prop := topology_on.

(** from §12: alternative naming for topology family **)
(** LATEX VERSION: We write T for the family of open sets, and call it the open_set_family. **)
Definition open_set_family : set -> set -> set := fun _ T => T.

(** from §12: alternative naming for open sets **)
(** LATEX VERSION: A subset U of X is open iff U is in the topology T; we name this predicate open_set. **)
Definition open_set : set -> set -> set -> prop := open_in.

(** from §13 Definition: basis for a topology **) 
(** LATEX VERSION: A basis on X is a collection B⊂P(X) such that every x∈X lies in some b∈B and intersections around a point refine to another basis element. **)
(** SUSPICIOUS DEFINITION: This is a left-associated conjunction; proofs must destruct it as (A /\ B) /\ C, not A /\ (B /\ C). **)
Definition basis_on : set -> set -> prop := fun X B =>
  B c= Power X
  /\ (forall x :e X, exists b :e B, x :e b)
  /\ (forall b1 :e B, forall b2 :e B, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).

(** Helper: extract B c= Power X from basis_on **)
Theorem basis_on_sub_Power : forall X B:set,
  basis_on X B -> B c= Power X.
let X B.
assume H: basis_on X B.
set A := B c= Power X.
set Bcov := (forall x :e X, exists b :e B, x :e b).
set Bref := (forall b1 :e B, forall b2 :e B, forall x:set,
              x :e b1 -> x :e b2 ->
              exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).
claim Hab: A /\ Bcov.
{ exact (andEL (A /\ Bcov) Bref H). }
exact (andEL A Bcov Hab).
Qed.

(** Helper: extract cover property from basis_on **)
Theorem basis_on_cover : forall X B:set,
  basis_on X B -> forall x :e X, exists b :e B, x :e b.
let X B.
assume H: basis_on X B.
set A := B c= Power X.
set Bcov := (forall x :e X, exists b :e B, x :e b).
set Bref := (forall b1 :e B, forall b2 :e B, forall x:set,
              x :e b1 -> x :e b2 ->
              exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).
claim Hab: A /\ Bcov.
{ exact (andEL (A /\ Bcov) Bref H). }
exact (andER A Bcov Hab).
Qed.

(** Helper: extract refinement property from basis_on **)
Theorem basis_on_refine : forall X B:set,
  basis_on X B ->
  forall b1 :e B, forall b2 :e B, forall x:set,
    x :e b1 -> x :e b2 ->
    exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2.
let X B.
assume H: basis_on X B.
set A := B c= Power X.
set Bcov := (forall x :e X, exists b :e B, x :e b).
set Bref := (forall b1 :e B, forall b2 :e B, forall x:set,
              x :e b1 -> x :e b2 ->
              exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).
exact (andER (A /\ Bcov) Bref H).
Qed.

(** from §13 Definition: topology generated by a basis **)
(** LATEX VERSION: The topology generated by basis B on X consists of all U⊂X such that every x∈U lies in some b∈B with b⊂U. **)
(** SUSPICIOUS DEFINITION: Membership is encoded by a local basis refinement condition; later set ext proofs often need to rewrite this definition and then destruct nested existentials carefully. **)
Definition generated_topology : set -> set -> set := fun X B =>
  {U :e Power X | forall x :e U, exists b :e B, x :e b /\ b c= U}.

(** helper: unfold membership in generated topology **)
(** LATEX VERSION: If U is open in the topology generated by B and x∈U, then some b∈B contains x and is contained in U. **)
Theorem generated_topology_local_refine : forall X B U x:set,
  U :e generated_topology X B ->
  x :e U ->
  exists b :e B, x :e b /\ b c= U.
let X B U x.
assume HU: U :e generated_topology X B.
assume HxU: x :e U.
claim Hprop: forall y :e U, exists b :e B, y :e b /\ b c= U.
{ exact (SepE2 (Power X)
               (fun U0:set => forall y :e U0, exists b :e B, y :e b /\ b c= U0)
               U
               HU). }
exact (Hprop x HxU).
Qed.

(** Helper: Any declared generator element is open in the generated topology **)
(** LATEX VERSION: If U is one of the designated generators and U ⊂ X, then U is open in the generated topology. **)
Theorem generated_topology_contains_elem : forall X B U:set,
  U :e Power X ->
  U :e B ->
  U :e generated_topology X B.
let X B U.
assume HUpow: U :e Power X.
assume HUinB: U :e B.
prove U :e generated_topology X B.
claim HUprop : forall x :e U, exists b :e B, x :e b /\ b c= U.
{ let x. assume HxU: x :e U.
  witness U.
  apply andI.
  - exact HUinB.
  - apply andI.
    + exact HxU.
    + exact (Subq_ref U). }
exact (SepI (Power X)
            (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0)
            U
            HUpow
            HUprop).
Qed.

(** Helper: Basis elements are subsets of X **)
Theorem basis_elem_subset : forall X B b:set,
  basis_on X B -> b :e B -> b c= X.
let X B b.
assume HB: basis_on X B.
assume Hb: b :e B.
prove b c= X.
(** basis_on X B = (B c= Power X) /\ (coverage /\ intersection property) **)
(** Left-associative: ((B c= Power X) /\ coverage) /\ intersection **)
claim H1: (B c= Power X /\ (forall x :e X, exists b0 :e B, x :e b0)) /\ (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).
{ exact HB. }
claim H2: B c= Power X /\ (forall x :e X, exists b0 :e B, x :e b0).
{ exact (andEL (B c= Power X /\ (forall x :e X, exists b0 :e B, x :e b0)) (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2) H1). }
claim HBPower: B c= Power X.
{ exact (andEL (B c= Power X) (forall x :e X, exists b0 :e B, x :e b0) H2). }
claim HbPower: b :e Power X.
{ exact (HBPower b Hb). }
exact (PowerE X b HbPower).
Qed.

(** Helper: Basis elements are in generated topology **)
Theorem basis_in_generated : forall X B b:set,
  basis_on X B -> b :e B -> b :e generated_topology X B.
let X B b.
assume HB: basis_on X B.
assume Hb: b :e B.
prove b :e generated_topology X B.
(** generated_topology X B = {U :e Power X | forall x :e U, exists b0 :e B, x :e b0 /\ b0 c= U} **)
(** Need: b :e Power X and forall x :e b, exists b0 :e B, x :e b0 /\ b0 c= b **)
claim HbPower: b :e Power X.
{ claim HbsubX: b c= X.
  { exact (basis_elem_subset X B b HB Hb). }
  exact (PowerI X b HbsubX). }
claim HbCond: forall x :e b, exists b0 :e B, x :e b0 /\ b0 c= b.
{ let x. assume Hx: x :e b.
  (** Use b itself as the witness **)
  witness b.
  apply andI.
  - exact Hb.
  - apply andI.
    + exact Hx.
    + apply Subq_ref. }
exact (SepI (Power X) (fun U => forall x :e U, exists b0 :e B, x :e b0 /\ b0 c= U) b HbPower HbCond).
Qed.

(** Helper: Elements of generated topology are subsets of X **)
Theorem generated_topology_subset : forall X B U:set,
  U :e generated_topology X B -> U c= X.
let X B U.
assume HU: U :e generated_topology X B.
prove U c= X.
(** generated_topology X B = {U :e Power X | ...} **)
claim HUPower: U :e Power X.
{ exact (SepE1 (Power X) (fun U0 => forall x :e U0, exists b :e B, x :e b /\ b c= U0) U HU). }
exact (PowerE X U HUPower).
Qed.

(** from §13: generated family is a topology **) 
(** LATEX VERSION: The collection generated by a basis indeed satisfies the topology axioms. **)
Theorem lemma_topology_from_basis : forall X B:set,
  basis_on X B ->
  topology_on X (generated_topology X B).
let X B. assume HBasis.
claim HBleft : B c= Power X /\ (forall x :e X, exists b :e B, x :e b).
{ exact (andEL (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
               (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
               HBasis). }
claim HBint : forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2.
{ exact (andER (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
               (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
               HBasis). }
claim HBsub : B c= Power X.
{ exact (andEL (B c= Power X) (forall x :e X, exists b :e B, x :e b) HBleft). }
claim HBcov : forall x :e X, exists b :e B, x :e b.
{ exact (andER (B c= Power X) (forall x :e X, exists b :e B, x :e b) HBleft). }
claim proofA : generated_topology X B c= Power X.
{ let U. assume HU: U :e generated_topology X B.
  exact (SepE1 (Power X) (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0) U HU). }
claim proofB : Empty :e generated_topology X B.
{ exact (SepI (Power X) (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0) Empty (Empty_In_Power X) (fun x HxEmpty => EmptyE x HxEmpty (exists b :e B, x :e b /\ b c= Empty))). }
claim proofC : X :e generated_topology X B.
  { claim HXprop : forall x :e X, exists b :e B, x :e b /\ b c= X.
    { let x. assume HxX.
      claim Hexb : exists b :e B, x :e b.
      { exact (HBcov x HxX). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbB : b :e B.
      { exact (andEL (b :e B) (x :e b) Hbpair). }
      claim Hxb : x :e b.
      { exact (andER (b :e B) (x :e b) Hbpair). }
      claim HbsubX : b c= X.
      { exact (PowerE X b (HBsub b HbB)). }
      witness b.
      apply andI.
      - exact HbB.
      - apply andI.
        * exact Hxb.
        * exact HbsubX. }
  exact (SepI (Power X) (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0) X (Self_In_Power X) HXprop). }
claim proofD : forall UFam :e Power (generated_topology X B), Union UFam :e generated_topology X B.
{ let UFam. assume Hfam: UFam :e Power (generated_topology X B).
  claim HsubFam : UFam c= generated_topology X B.
  { exact (PowerE (generated_topology X B) UFam Hfam). }
  claim HPowUnion : Union UFam :e Power X.
  { apply PowerI X (Union UFam).
    let x. assume HxUnion.
    apply UnionE_impred UFam x HxUnion.
    let U. assume HxU HUin.
    claim HUtop : U :e generated_topology X B.
    { exact (HsubFam U HUin). }
    claim HUsubX : U c= X.
    { exact (PowerE X U (SepE1 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop)). }
    exact (HUsubX x HxU). }
  claim HUnionProp : forall x :e Union UFam, exists b :e B, x :e b /\ b c= Union UFam.
  { let x. assume HxUnion.
    apply UnionE_impred UFam x HxUnion.
    let U. assume HxU HUin.
    claim HUtop : U :e generated_topology X B.
    { exact (HsubFam U HUin). }
    claim HUprop : forall x0 :e U, exists b :e B, x0 :e b /\ b c= U.
    { exact (SepE2 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop). }
    claim Hexb : exists b :e B, x :e b /\ b c= U.
    { exact (HUprop x HxU). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbB : b :e B.
    { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hbprop : x :e b /\ b c= U.
    { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hxb : x :e b.
    { exact (andEL (x :e b) (b c= U) Hbprop). }
    claim HbSubU : b c= U.
    { exact (andER (x :e b) (b c= U) Hbprop). }
    witness b.
    apply andI.
    - exact HbB.
    - apply andI.
      * exact Hxb.
      * let y. assume Hyb.
        apply UnionI UFam y U (HbSubU y Hyb) HUin. }
  exact (SepI (Power X) (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0) (Union UFam) HPowUnion HUnionProp). }
claim proofE : forall U :e generated_topology X B, forall V :e generated_topology X B, U :/\: V :e generated_topology X B.
{ let U. assume HUtop.
  let V. assume HVtop.
  claim HUprop : forall x0 :e U, exists b :e B, x0 :e b /\ b c= U.
  { exact (SepE2 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop). }
  claim HVprop : forall x0 :e V, exists b :e B, x0 :e b /\ b c= V.
  { exact (SepE2 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) V HVtop). }
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop)). }
  claim HPowCap : U :/\: V :e Power X.
  { apply PowerI X (U :/\: V).
    let x. assume HxCap.
    apply binintersectE U V x HxCap.
    assume HxU HxV.
    exact (HUsubX x HxU). }
  claim HCapProp : forall x :e U :/\: V, exists b :e B, x :e b /\ b c= U :/\: V.
  { let x. assume HxCap.
    apply binintersectE U V x HxCap.
    assume HxU HxV.
    claim Hexb1 : exists b1 :e B, x :e b1 /\ b1 c= U.
    { exact (HUprop x HxU). }
    claim Hexb2 : exists b2 :e B, x :e b2 /\ b2 c= V.
    { exact (HVprop x HxV). }
    apply Hexb1.
    let b1. assume Hbpair1.
    claim Hb1 : b1 :e B.
    { exact (andEL (b1 :e B) (x :e b1 /\ b1 c= U) Hbpair1). }
    claim Hb1prop : x :e b1 /\ b1 c= U.
    { exact (andER (b1 :e B) (x :e b1 /\ b1 c= U) Hbpair1). }
    claim Hb1x : x :e b1.
    { exact (andEL (x :e b1) (b1 c= U) Hb1prop). }
    claim Hb1Sub : b1 c= U.
    { exact (andER (x :e b1) (b1 c= U) Hb1prop). }
    apply Hexb2.
    let b2. assume Hbpair2.
    claim Hb2 : b2 :e B.
    { exact (andEL (b2 :e B) (x :e b2 /\ b2 c= V) Hbpair2). }
    claim Hb2prop : x :e b2 /\ b2 c= V.
    { exact (andER (b2 :e B) (x :e b2 /\ b2 c= V) Hbpair2). }
    claim Hb2x : x :e b2.
    { exact (andEL (x :e b2) (b2 c= V) Hb2prop). }
    claim Hb2Sub : b2 c= V.
    { exact (andER (x :e b2) (b2 c= V) Hb2prop). }
    claim Hexb3 : exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2.
    { exact (HBint b1 Hb1 b2 Hb2 x Hb1x Hb2x). }
    apply Hexb3.
    let b3. assume Hbpair3.
    claim Hb3 : b3 :e B.
    { exact (andEL (b3 :e B) (x :e b3 /\ b3 c= b1 :/\: b2) Hbpair3). }
    claim Hb3prop : x :e b3 /\ b3 c= b1 :/\: b2.
    { exact (andER (b3 :e B) (x :e b3 /\ b3 c= b1 :/\: b2) Hbpair3). }
	    claim HxB3 : x :e b3.
	    { exact (andEL (x :e b3) (b3 c= b1 :/\: b2) Hb3prop). }
	    claim Hb3Sub : b3 c= b1 :/\: b2.
	  { exact (andER (x :e b3) (b3 c= b1 :/\: b2) Hb3prop). }
	    witness b3.
	    apply andI.
	    - exact Hb3.
	    - apply andI.
	      * exact HxB3.
	      * let y. assume Hyb3.
	        claim Hy_in_b1b2 : y :e b1 :/\: b2.
	        { exact (Hb3Sub y Hyb3). }
	        apply binintersectE b1 b2 y Hy_in_b1b2.
	        assume Hyb1 Hyb2.
	        apply binintersectI U V y (Hb1Sub y Hyb1) (Hb2Sub y Hyb2). }
	  exact (SepI (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) (U :/\: V) HPowCap HCapProp). }
prove generated_topology X B c= Power X
/\ Empty :e generated_topology X B
/\ X :e generated_topology X B
/\ (forall UFam :e Power (generated_topology X B), Union UFam :e generated_topology X B)
/\ (forall U :e generated_topology X B, forall V :e generated_topology X B, U :/\: V :e generated_topology X B).
apply and5I.
- exact proofA.
- exact proofB.
- exact proofC.
- exact proofD.
- exact proofE.
Qed.

(** from §13: basis elements belong to generated topology **) 
(** LATEX VERSION: Every basis element b∈B is itself open in the topology generated by B. **)
Theorem generated_topology_contains_basis : forall X B:set,
  basis_on X B -> forall b:set, b :e B -> b :e generated_topology X B.
let X B. assume HBasis.
claim HBsub : B c= Power X.
{ exact (andEL (B c= Power X) (forall x :e X, exists b :e B, x :e b) (andEL (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
               (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
               HBasis)). }
claim HBint : forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2.
{ exact (andER (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
               (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
               HBasis). }
let b0. assume Hb0.
claim Hb0_subX : b0 c= X.
{ exact (PowerE X b0 (HBsub b0 Hb0)). }
claim Hb0prop : forall x :e b0, exists b :e B, x :e b /\ b c= b0.
{ let x. assume Hxb0.
  claim Hexb3 : exists b3 :e B, x :e b3 /\ b3 c= b0 :/\: b0.
  { exact (HBint b0 Hb0 b0 Hb0 x Hxb0 Hxb0). }
  apply Hexb3.
  let b3. assume Hb3pair.
  claim Hb3 : b3 :e B.
  { exact (andEL (b3 :e B) (x :e b3 /\ b3 c= b0 :/\: b0) Hb3pair). }
  claim Hb3prop : x :e b3 /\ b3 c= b0 :/\: b0.
  { exact (andER (b3 :e B) (x :e b3 /\ b3 c= b0 :/\: b0) Hb3pair). }
  claim Hxb3 : x :e b3.
  { exact (andEL (x :e b3) (b3 c= b0 :/\: b0) Hb3prop). }
  claim Hb3sub_inter : b3 c= b0 :/\: b0.
  { exact (andER (x :e b3) (b3 c= b0 :/\: b0) Hb3prop). }
  claim Hb3subb0 : b3 c= b0.
  { let y. assume Hyb3.
    claim Hycap : y :e b0 :/\: b0.
    { exact (Hb3sub_inter y Hyb3). }
    apply binintersectE b0 b0 y Hycap.
    assume Hy1 Hy2.
    exact Hy1. }
  witness b3.
  apply andI.
  - exact Hb3.
  - apply andI.
    * exact Hxb3.
    * exact Hb3subb0. }
exact (SepI (Power X) (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0) b0 (PowerI X b0 Hb0_subX) Hb0prop).
Qed.

(** Helper: generated topology is contained in any topology that contains the generators **)
(** LATEX VERSION: If T is a topology on X and every generator b∈B is in T, then every set generated from B is in T. **)
(** NOTE: This does not require B to satisfy the basis axioms; it is a general “generated topology is minimal” direction. **)
Theorem generated_topology_finer_weak : forall X B T:set,
  topology_on X T ->
  (forall b :e B, b :e T) ->
  finer_than T (generated_topology X B).
let X B T.
assume HT: topology_on X T.
assume HBsub: forall b :e B, b :e T.
prove finer_than T (generated_topology X B).
prove generated_topology X B c= T.
let U. assume HU: U :e generated_topology X B.
prove U :e T.
claim HUsubX : U c= X.
{ exact (PowerE X U
         (SepE1 (Power X)
               (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
               U HU)). }
claim HUprop : forall x :e U, exists b :e B, x :e b /\ b c= U.
{ exact (SepE2 (Power X)
              (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
              U HU). }
set Fam : set := {b :e B|b c= U}.
claim HFamSubT : Fam c= T.
{ let b. assume HbFam: b :e Fam.
  claim HbB: b :e B.
  { exact (SepE1 B (fun b0 : set => b0 c= U) b HbFam). }
  exact (HBsub b HbB). }
claim HFamPowT : Fam :e Power T.
{ apply PowerI.
  exact HFamSubT. }
claim HUnionInT : Union Fam :e T.
{ exact (topology_union_axiom X T HT Fam HFamPowT). }
claim HUnionEq : Union Fam = U.
{ apply set_ext.
  - let x. assume HxUnion: x :e Union Fam.
    apply (UnionE_impred Fam x HxUnion).
    let b. assume Hxb: x :e b.
    assume HbFam: b :e Fam.
    claim HbsubU: b c= U.
    { exact (SepE2 B (fun b0 : set => b0 c= U) b HbFam). }
    exact (HbsubU x Hxb).
  - let x. assume HxU: x :e U.
    claim Hexb: exists b :e B, x :e b /\ b c= U.
    { exact (HUprop x HxU). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbB : b :e B.
    { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hbprop : x :e b /\ b c= U.
    { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hxb : x :e b.
    { exact (andEL (x :e b) (b c= U) Hbprop). }
    claim HbsubU : b c= U.
    { exact (andER (x :e b) (b c= U) Hbprop). }
    claim HbFam : b :e Fam.
    { exact (SepI B (fun b0 : set => b0 c= U) b HbB HbsubU). }
    exact (UnionI Fam x b Hxb HbFam). }
rewrite <- HUnionEq.
exact HUnionInT.
Qed.

(** from §13: shorthand for basis generating topology **) 
(** LATEX VERSION: basis_generates X B T abbreviates “B is a basis on X and the generated topology equals T.” **)
Definition basis_generates : set -> set -> set -> prop := fun X B T =>
  basis_on X B /\ generated_topology X B = T.

(** from §13: shorthand that a family refines all opens **) 
(** LATEX VERSION: basis_refines X B T means T is a topology on X and every x in any U∈T lies in some b∈B with b⊂U. **)
Definition basis_refines : set -> set -> set -> prop := fun X B T =>
  topology_on X T /\ (forall U :e T, forall x :e U, exists b :e B, x :e b /\ b c= U).

(** from §13: generated topology characterization **) 
(** LATEX VERSION: Characterization of generated_topology as the comprehension of subsets U⊂X with the basis neighborhood property. **)
Theorem lemma_generated_topology_characterization : forall X B:set,
  basis_on X B ->
  generated_topology X B
  = {U :e Power X | forall x :e U, exists b :e B, x :e b /\ b c= U}.
let X B. assume HBasis.
reflexivity.
Qed.

(** from §13 Lemma 13.1: open sets are unions of basis elements **) 
(** LATEX VERSION: Lemma 13.1: For a basis B on X, every open set is a union of elements of B. **)
Theorem open_sets_as_unions_of_basis : forall X B:set,
  basis_on X B ->
  forall U:set, open_in X (generated_topology X B) U ->
    exists Fam :e Power B, Union Fam = U.
let X B. assume HBasis.
claim HBsub : B c= Power X.
{ exact (andEL (B c= Power X) (forall x :e X, exists b :e B, x :e b)
               (andEL (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
                     (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
                     HBasis)). }
let U. assume HUopen.
claim HUtop : U :e generated_topology X B.
{ exact (andER (topology_on X (generated_topology X B)) (U :e generated_topology X B) HUopen). }
claim HUprop : forall x :e U, exists b :e B, x :e b /\ b c= U.
{ exact (SepE2 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop). }
set Fam : set := {b :e B|b c= U}.
claim HFamPow : Fam :e Power B.
{ apply PowerI B Fam.
  let b. assume HbFam.
  exact (SepE1 B (fun b0 : set => b0 c= U) b HbFam). }
claim HUnion_eq : Union Fam = U.
{ apply set_ext.
  - let x. assume HxUnion.
    apply UnionE_impred Fam x HxUnion.
    let b. assume Hxb HbFam.
    claim HbsubU : b c= U.
    { exact (SepE2 B (fun b0 : set => b0 c= U) b HbFam). }
    exact (HbsubU x Hxb).
  - let x. assume HxU.
    claim Hexb : exists b :e B, x :e b /\ b c= U.
    { exact (HUprop x HxU). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbB : b :e B.
    { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hbprop : x :e b /\ b c= U.
    { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hxb : x :e b.
    { exact (andEL (x :e b) (b c= U) Hbprop). }
    claim HbsubU : b c= U.
    { exact (andER (x :e b) (b c= U) Hbprop). }
    claim HbFam : b :e Fam.
    { exact (SepI B (fun b0 : set => b0 c= U) b HbB HbsubU). }
    exact (UnionI Fam x b Hxb HbFam). }
witness Fam.
apply andI.
- exact HFamPow.
- exact HUnion_eq.
Qed.

(** from §13 Lemma 13.1 converse direction **) 
(** LATEX VERSION: Conversely, any union of basis elements is open in the topology generated by the basis. **)
Theorem basis_generates_open_sets : forall X B:set,
  basis_on X B ->
  forall U:set, (exists Fam :e Power B, Union Fam = U) ->
    open_in X (generated_topology X B) U.
let X B. assume HBasis.
claim HBsub : B c= Power X.
{ exact (andEL (B c= Power X) (forall x :e X, exists b :e B, x :e b)
               (andEL (B c= Power X /\ (forall x :e X, exists b :e B, x :e b))
                     (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
                     HBasis)). }
let U. assume Hex.
claim HUGen : U :e generated_topology X B.
{ apply Hex.
  let Fam. assume HFampair.
  claim HFamPow : Fam :e Power B.
  { exact (andEL (Fam :e Power B) (Union Fam = U) HFampair). }
  claim HUnionEq : Union Fam = U.
  { exact (andER (Fam :e Power B) (Union Fam = U) HFampair). }
  claim HFamSubB : Fam c= B.
  { exact (PowerE B Fam HFamPow). }
  claim HFamSubX : Fam c= Power X.
  { let b. assume HbFam.
    claim HbB : b :e B.
    { exact (HFamSubB b HbFam). }
    exact (HBsub b HbB). }
  claim HUnionSubX : Union Fam c= X.
  { let x. assume HxUnion.
    apply UnionE_impred Fam x HxUnion.
    let b. assume Hxb HbFam.
    claim HbSubX : b c= X.
    { exact (PowerE X b (HFamSubX b HbFam)). }
    exact (HbSubX x Hxb). }
  claim HUnionSubU : Union Fam c= U.
  { rewrite HUnionEq.
    exact (Subq_ref U). }
  claim HUsubUnion : U c= Union Fam.
  { rewrite <- HUnionEq.
    exact (Subq_ref (Union Fam)). }
  claim HUsubX : U c= X.
  { exact (Subq_tra U (Union Fam) X HUsubUnion HUnionSubX). }
  claim HUpropU : forall x :e U, exists b :e B, x :e b /\ b c= U.
  { let x. assume HxU.
    claim HxUnion : x :e Union Fam.
    { exact (HUsubUnion x HxU). }
    apply UnionE_impred Fam x HxUnion.
    let b. assume Hxb HbFam.
    claim HbB : b :e B.
    { exact (HFamSubB b HbFam). }
    claim HbSubUnion : b c= Union Fam.
    { let y. assume Hyb.
      exact (UnionI Fam y b Hyb HbFam). }
    claim HbSubU : b c= U.
    { exact (Subq_tra b (Union Fam) U HbSubUnion HUnionSubU). }
    witness b.
    apply andI.
    - exact HbB.
    - apply andI.
      * exact Hxb.
      * exact HbSubU. }
  exact (SepI (Power X) (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0) U (PowerI X U HUsubX) HUpropU). }
exact (andI (topology_on X (generated_topology X B)) (U :e generated_topology X B) (lemma_topology_from_basis X B HBasis) HUGen).
Qed.

(** from §13 Lemma 13.1 corollary **) 
(** LATEX VERSION: Corollary: For U open in topology generated by B, U equals the union of all basis elements contained in U. **)
Theorem open_as_union_of_basis_elements : forall X B:set,
  basis_on X B ->
  forall U:set, open_in X (generated_topology X B) U ->
    U = Union {b :e B|b c= U}.
let X B. assume HBasis.
let U. assume HUopen.
claim HUtop : U :e generated_topology X B.
{ exact (andER (topology_on X (generated_topology X B)) (U :e generated_topology X B) HUopen). }
claim HUprop : forall x :e U, exists b :e B, x :e b /\ b c= U.
{ exact (SepE2 (Power X) (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0) U HUtop). }
set Fam : set := {b :e B|b c= U}.
apply set_ext.
- let x. assume HxU.
  claim Hexb : exists b :e B, x :e b /\ b c= U.
  { exact (HUprop x HxU). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB : b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hbprop : x :e b /\ b c= U.
  { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hxb : x :e b.
  { exact (andEL (x :e b) (b c= U) Hbprop). }
  claim HbsubU : b c= U.
  { exact (andER (x :e b) (b c= U) Hbprop). }
  claim HbFam : b :e Fam.
  { exact (SepI B (fun b0 : set => b0 c= U) b HbB HbsubU). }
  exact (UnionI Fam x b Hxb HbFam).
- let x. assume HxUnion.
  apply UnionE_impred Fam x HxUnion.
  let b. assume Hxb HbFam.
  claim HbsubU : b c= U.
  { exact (SepE2 B (fun b0 : set => b0 c= U) b HbFam). }
  exact (HbsubU x Hxb).
Qed.

(** from §13 Lemma 13.2: extracting a basis from an open refinement condition **) 
(** LATEX VERSION: Lemma 13.2: If every open set of topology T on X is locally contained in some element of C⊂T, then C is a basis and generates T. **)
Theorem basis_refines_topology : forall X T C:set,
  topology_on X T ->
  (forall c :e C, c :e T) ->
  (forall U :e T, forall x :e U, exists Cx :e C, x :e Cx /\ Cx c= U) ->
  basis_on X C /\ generated_topology X C = T.
let X T C. assume Htop HCsub Href.
claim Hleft : ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
{ exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))
               (forall U :e T, forall V :e T, U :/\: V :e T)
               Htop). }
claim Hcore : (T c= Power X /\ Empty :e T) /\ X :e T.
{ exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T)
               (forall UFam :e Power T, Union UFam :e T)
               Hleft). }
claim HTPowEmpty : T c= Power X /\ Empty :e T.
{ exact (andEL (T c= Power X /\ Empty :e T) (X :e T) Hcore). }
claim HTsubPow : T c= Power X.
{ exact (andEL (T c= Power X) (Empty :e T) HTPowEmpty). }
claim HXT : X :e T.
{ exact (andER (T c= Power X /\ Empty :e T) (X :e T) Hcore). }
claim HUnionClosed : forall UFam :e Power T, Union UFam :e T.
{ exact (andER ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) Hleft). }
claim HInterClosed : forall U :e T, forall V :e T, U :/\: V :e T.
{ exact (andER (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))
               (forall U :e T, forall V :e T, U :/\: V :e T)
               Htop). }
claim HBasis : basis_on X C.
{ prove (C c= Power X
         /\ (forall x :e X, exists c :e C, x :e c)
         /\ (forall b1 :e C, forall b2 :e C, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e C, x :e b3 /\ b3 c= b1 :/\: b2)).
  apply and3I.
  - let c. assume HcC.
    exact (HTsubPow c (HCsub c HcC)).
  - let x. assume HxX.
    claim Hex : exists c :e C, x :e c /\ c c= X.
    { exact (Href X HXT x HxX). }
    apply Hex.
    let c. assume Hpair.
    claim HcC : c :e C.
    { exact (andEL (c :e C) (x :e c /\ c c= X) Hpair). }
    claim Hcprop : x :e c /\ c c= X.
    { exact (andER (c :e C) (x :e c /\ c c= X) Hpair). }
    claim Hxc : x :e c.
    { exact (andEL (x :e c) (c c= X) Hcprop). }
    witness c.
    apply andI.
    - exact HcC.
    - exact Hxc.
  - let c1. assume Hc1C.
    let c2. assume Hc2C.
    let x. assume Hxc1 Hxc2.
    claim Hc1T : c1 :e T.
    { exact (HCsub c1 Hc1C). }
    claim Hc2T : c2 :e T.
    { exact (HCsub c2 Hc2C). }
    claim HcapT : c1 :/\: c2 :e T.
    { exact (HInterClosed c1 Hc1T c2 Hc2T). }
    claim HxCap : x :e c1 :/\: c2.
    { exact (binintersectI c1 c2 x Hxc1 Hxc2). }
    claim Hex : exists c3 :e C, x :e c3 /\ c3 c= c1 :/\: c2.
    { exact (Href (c1 :/\: c2) HcapT x HxCap). }
    exact Hex. }
claim Hgen_sub_T : generated_topology X C c= T.
{ let U. assume HUgen : U :e generated_topology X C.
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X)
                            (fun U0 : set => forall x0 :e U0, exists b0 :e C, x0 :e b0 /\ b0 c= U0)
                            U HUgen)). }
  claim HUprop : forall x :e U, exists c :e C, x :e c /\ c c= U.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall x0 :e U0, exists b0 :e C, x0 :e b0 /\ b0 c= U0)
                 U HUgen). }
  set Fam : set := {c :e C|c c= U}.
  claim HFamSubC : Fam c= C.
  { let c. assume HcFam.
    exact (SepE1 C (fun c0 : set => c0 c= U) c HcFam). }
  claim HFamSubT : Fam c= T.
  { let c. assume HcFam.
    claim HcC : c :e C.
    { exact (HFamSubC c HcFam). }
    exact (HCsub c HcC). }
  claim HFamPowT : Fam :e Power T.
  { exact (PowerI T Fam HFamSubT). }
  claim HUnionSubU : Union Fam c= U.
  { let x. assume HxUnion.
    apply UnionE_impred Fam x HxUnion.
    let c. assume Hxc HcFam.
    claim Hcprop : c c= U.
    { exact (SepE2 C (fun c0 : set => c0 c= U) c HcFam). }
    exact (Hcprop x Hxc). }
  claim HUsubUnion : U c= Union Fam.
  { let x. assume HxU.
    claim Hex : exists c :e C, x :e c /\ c c= U.
    { exact (HUprop x HxU). }
    apply Hex.
    let c. assume Hcpair.
    claim HcC : c :e C.
    { exact (andEL (c :e C) (x :e c /\ c c= U) Hcpair). }
    claim Hcprop : x :e c /\ c c= U.
    { exact (andER (c :e C) (x :e c /\ c c= U) Hcpair). }
    claim Hxc : x :e c.
    { exact (andEL (x :e c) (c c= U) Hcprop). }
    claim HcsubU : c c= U.
    { exact (andER (x :e c) (c c= U) Hcprop). }
    claim HcFam : c :e Fam.
    { exact (SepI C (fun c0 : set => c0 c= U) c HcC HcsubU). }
    exact (UnionI Fam x c Hxc HcFam). }
  claim HUnionEqU : Union Fam = U.
  { apply set_ext.
    - let x. assume HxUnion.
      exact (HUnionSubU x HxUnion).
    - let x. assume HxU.
      exact (HUsubUnion x HxU). }
  claim HUnionInT : Union Fam :e T.
  { exact (HUnionClosed Fam HFamPowT). }
  rewrite <- HUnionEqU.
  exact HUnionInT. }
claim HT_sub_gen : T c= generated_topology X C.
{ let U. assume HU : U :e T.
  claim HUsubX : U c= X.
  { exact (PowerE X U (HTsubPow U HU)). }
  claim HUprop : forall x :e U, exists c :e C, x :e c /\ c c= U.
  { let x. assume HxU.
    exact (Href U HU x HxU). }
  exact (SepI (Power X)
              (fun U0 : set => forall x0 :e U0, exists b0 :e C, x0 :e b0 /\ b0 c= U0)
              U
              (PowerI X U HUsubX)
              HUprop). }
claim HEqual : generated_topology X C = T.
{ apply set_ext.
  - let U. assume HUgen.
    exact (Hgen_sub_T U HUgen).
  - let U. assume HU.
    exact (HT_sub_gen U HU). }
apply andI.
- exact HBasis.
- exact HEqual.
Qed.

(** from §13 Lemma 13.2 (alias): open refinement family yields a basis **) 
(** LATEX VERSION: Rephrasing Lemma 13.2: a subcollection C of opens that locally refines every open is a basis generating T. **)
Theorem lemma13_2_basis_from_open_subcollection : forall X T C:set,
  topology_on X T ->
  (forall c :e C, c :e T) ->
  (forall U :e T, forall x :e U, exists c :e C, x :e c /\ c c= U) ->
  basis_on X C /\ generated_topology X C = T.
let X T C. assume Htop HCsub Href.
exact (basis_refines_topology X T C Htop HCsub Href).
Qed.

(** from §13: criterion for fineness via bases **) 
(** LATEX VERSION: Lemma 13.3 (⇒ direction): If every basis element of B around x contains a basis element of B′ at x, then the topology from B′ is finer than that from B. **)
Theorem finer_via_basis : forall X B B':set,
  basis_on X B -> basis_on X B' ->
  (forall x :e X, forall b:set, b :e B -> x :e b ->
      exists b' :e B', x :e b' /\ b' c= b) ->
  finer_than (generated_topology X B') (generated_topology X B).
let X B B'. assume HB HB' Hcond.
claim HT : topology_on X (generated_topology X B).
{ exact (lemma_topology_from_basis X B HB). }
claim HRefProp : forall U :e generated_topology X B, forall x :e U, exists b' :e B', x :e b' /\ b' c= U.
{ let U. assume HU : U :e generated_topology X B.
  let x. assume HxU.
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X)
                             (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0)
                             U HU)). }
  claim HxX : x :e X.
  { exact (HUsubX x HxU). }
  claim HUprop : forall x0 :e U, exists b :e B, x0 :e b /\ b c= U.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall x0 :e U0, exists b :e B, x0 :e b /\ b c= U0)
                 U HU). }
  claim Hexb : exists b :e B, x :e b /\ b c= U.
  { exact (HUprop x HxU). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB : b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hbprop : x :e b /\ b c= U.
  { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hxb : x :e b.
  { exact (andEL (x :e b) (b c= U) Hbprop). }
  claim HbsubU : b c= U.
  { exact (andER (x :e b) (b c= U) Hbprop). }
  claim Hexb' : exists b' :e B', x :e b' /\ b' c= b.
  { exact (Hcond x HxX b HbB Hxb). }
  apply Hexb'.
  let b'. assume Hb'pair.
  claim Hb'B : b' :e B'.
  { exact (andEL (b' :e B') (x :e b' /\ b' c= b) Hb'pair). }
  claim Hb'prop : x :e b' /\ b' c= b.
  { exact (andER (b' :e B') (x :e b' /\ b' c= b) Hb'pair). }
  claim Hxb' : x :e b'.
  { exact (andEL (x :e b') (b' c= b) Hb'prop). }
  claim Hb'subb : b' c= b.
  { exact (andER (x :e b') (b' c= b) Hb'prop). }
  witness b'.
  apply andI.
  - exact Hb'B.
  - apply andI.
    * exact Hxb'.
    * exact (Subq_tra b' b U Hb'subb HbsubU). }
prove generated_topology X B c= generated_topology X B'.
  let U. assume HU.
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X)
                             (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
                             U HU)). }
  claim HUprop : forall x :e U, exists b' :e B', x :e b' /\ b' c= U.
  { exact (HRefProp U HU). }
  exact (SepI (Power X)
              (fun U0 : set => forall x0 :e U0, exists b0 :e B', x0 :e b0 /\ b0 c= U0)
              U
              (PowerI X U HUsubX)
              HUprop).
Qed.

(** from §13 Lemma 13.3: basis inclusion criterion for fineness **) 
(** LATEX VERSION: Lemma 13.3: T(B′) finer than T(B) iff each basis element of B has for every x∈b some b′∈B′ with x∈b′⊂b. **)
Theorem basis_finer_equiv_condition : forall X B B':set,
  basis_on X B -> basis_on X B' ->
  ((forall x :e X, forall b :e B, x :e b -> exists b' :e B', x :e b' /\ b' c= b) <->
  finer_than (generated_topology X B') (generated_topology X B)).
let X B B'. assume HB HB'.
apply iffI.
- assume Hcond.
  exact (finer_via_basis X B B' HB HB' Hcond).
- assume Hfiner.
  let x. assume HxX. let b. assume HbB Hxb.
  claim HbGen : b :e generated_topology X B.
  { exact (generated_topology_contains_basis X B HB b HbB). }
  claim HbGen' : b :e generated_topology X B'.
  { exact (Hfiner b HbGen). }
  claim Hbprop : forall x0 :e b, exists b' :e B', x0 :e b' /\ b' c= b.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall x0 :e U0, exists b0 :e B', x0 :e b0 /\ b0 c= U0)
                 b HbGen'). }
  exact (Hbprop x Hxb).
Qed.

(** from §13 Lemma 13.3 (direction): generated topology is minimal containing basis **) 
(** LATEX VERSION: If T is a topology on X containing every basis element of B, then T is finer than the topology generated by B. **)
Theorem generated_topology_finer : forall X B T:set,
  basis_on X B -> topology_on X T ->
  (forall b :e B, b :e T) ->
  finer_than T (generated_topology X B).
let X B T. assume HBasis HT HBsub.
claim HUnionClosed : forall Fam :e Power T, Union Fam :e T.
{ exact (andER ((T c= Power X /\ Empty :e T) /\ X :e T) (forall Fam :e Power T, Union Fam :e T)
               (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall Fam :e Power T, Union Fam :e T))
                      (forall U :e T, forall V :e T, U :/\: V :e T)
                      HT)). }
prove generated_topology X B c= T.
  let U. assume HU.
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X)
                             (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
                             U HU)). }
  claim HUprop : forall x :e U, exists b :e B, x :e b /\ b c= U.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
                 U HU). }
  set Fam : set := {b :e B|b c= U}.
  claim HFamPowB : Fam :e Power B.
  { apply PowerI B Fam.
    let b. assume HbFam.
    exact (SepE1 B (fun b0 : set => b0 c= U) b HbFam). }
  claim HUnionEq : Union Fam = U.
  { apply set_ext.
    - let x. assume HxUnion.
      apply UnionE_impred Fam x HxUnion.
      let b. assume Hxb HbFam.
      claim HbsubU : b c= U.
      { exact (SepE2 B (fun b0 : set => b0 c= U) b HbFam). }
      exact (HbsubU x Hxb).
    - let x. assume HxU.
      claim Hexb : exists b :e B, x :e b /\ b c= U.
      { exact (HUprop x HxU). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbB : b :e B.
      { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
      claim Hbprop : x :e b /\ b c= U.
      { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
      claim Hxb : x :e b.
      { exact (andEL (x :e b) (b c= U) Hbprop). }
      claim HbsubU : b c= U.
      { exact (andER (x :e b) (b c= U) Hbprop). }
      claim HbT : b :e T.
      { exact (HBsub b HbB). }
      claim HbFam : b :e Fam.
      { exact (SepI B (fun b0 : set => b0 c= U) b HbB HbsubU). }
      exact (UnionI Fam x b Hxb HbFam). }
  claim HFamPowT : Fam :e Power T.
  { apply PowerI T Fam.
    let b. assume HbFam.
    claim HbB : b :e B.
    { exact (SepE1 B (fun b0 : set => b0 c= U) b HbFam). }
    exact (HBsub b HbB). }
  claim HUnionT : Union Fam :e T.
  { exact (HUnionClosed Fam HFamPowT). }
  rewrite <- HUnionEq.
  exact HUnionT.
Qed.

(** from §13 Lemma 13.3 (direction): generated topology is smallest with given basis **) 
(** LATEX VERSION: Restates previous direction: the topology generated by B is the smallest topology containing B. **)
Theorem topology_generated_by_basis_is_smallest : forall X B T:set,
  basis_on X B -> topology_on X T ->
  (forall b :e B, b :e T) ->
  finer_than T (generated_topology X B).
let X B T. assume HBasis HT HBsub.
exact (generated_topology_finer X B T HBasis HT HBsub).
Qed.

(** from §13 Lemma 13.4: generated topology equals unions of basis elements **) 
(** LATEX VERSION: Lemma 13.4: The topology generated by B consists exactly of unions of subfamilies of B. **)
Theorem union_of_basis_equals_open :
  forall X B:set, basis_on X B ->
  generated_topology X B = {Union Fam | Fam :e Power B}.
let X B. assume HBasis.
apply set_ext.
- let U. assume HU.
  claim HUopen : open_in X (generated_topology X B) U.
  { exact (andI (topology_on X (generated_topology X B))
                 (U :e generated_topology X B)
                 (lemma_topology_from_basis X B HBasis)
                 HU). }
  claim HexFam : exists Fam :e Power B, Union Fam = U.
  { exact (open_sets_as_unions_of_basis X B HBasis U HUopen). }
  apply HexFam.
  let Fam. assume HFampair.
  claim HFamPow : Fam :e Power B.
  { exact (andEL (Fam :e Power B) (Union Fam = U) HFampair). }
  claim HUnion : Union Fam = U.
  { exact (andER (Fam :e Power B) (Union Fam = U) HFampair). }
  claim HUnionFam : Union Fam :e {Union Fam0 | Fam0 :e Power B}.
  { exact (ReplI (Power B) (fun Fam0 : set => Union Fam0) Fam HFamPow). }
  rewrite <- HUnion.
  exact HUnionFam.
- let U. assume HUUnion.
  claim HexFamPowRaw : exists Fam :e Power B, U = Union Fam.
  { exact (ReplE (Power B) (fun Fam0 : set => Union Fam0) U HUUnion). }
  claim HexFamPow : exists Fam :e Power B, Union Fam = U.
  { apply HexFamPowRaw.
    let Fam. assume HFamPair.
    claim HFamPow : Fam :e Power B.
    { exact (andEL (Fam :e Power B) (U = Union Fam) HFamPair). }
    claim HUnion : U = Union Fam.
    { exact (andER (Fam :e Power B) (U = Union Fam) HFamPair). }
    witness Fam.
    apply andI.
    - exact HFamPow.
    - rewrite <- HUnion.
      reflexivity. }
  claim HUopen : open_in X (generated_topology X B) U.
  { exact (basis_generates_open_sets X B HBasis U HexFamPow). }
  exact (andER (topology_on X (generated_topology X B))
               (U :e generated_topology X B)
               HUopen).
Qed.

(** from §13 Example 3: singleton basis **) 
(** LATEX VERSION: Example 3: the collection of all one-point subsets of X forms a basis. **)
(** FIXED: Use `{x}` directly rather than `{x,x}`. **)
Definition singleton_basis : set -> set := fun X => {{x}|x :e X}.

(** from §13 Example 3: singleton collection forms a basis **) 
(** LATEX VERSION: The collection of singletons on X satisfies the two basis axioms. **)
Theorem singleton_basis_is_basis : forall X:set, basis_on X (singleton_basis X).
let X.
prove ((singleton_basis X c= Power X
        /\ (forall x :e X, exists b :e singleton_basis X, x :e b))
       /\ (forall b1 :e singleton_basis X, forall b2 :e singleton_basis X, forall x:set,
              x :e b1 -> x :e b2 ->
              exists b3 :e singleton_basis X, x :e b3 /\ b3 c= b1 :/\: b2)).
apply and3I.
- prove singleton_basis X c= Power X.
  let s. assume Hs.
  apply (ReplE_impred X (fun x0 : set => {x0}) s Hs).
  let x. assume HxX Hseq.
  rewrite Hseq.
  apply PowerI.
  let y. assume Hy: y :e {x}.
  claim Hyx: y = x.
  { exact (SingE x y Hy). }
  rewrite Hyx.
  exact HxX.
- prove forall x :e X, exists b :e singleton_basis X, x :e b.
  let x. assume HxX.
  witness {x}.
  apply andI.
  - exact (ReplI X (fun x0 : set => {x0}) x HxX).
  - exact (SingI x).
- prove forall b1 :e singleton_basis X, forall b2 :e singleton_basis X, forall x:set,
          x :e b1 -> x :e b2 ->
          exists b3 :e singleton_basis X, x :e b3 /\ b3 c= b1 :/\: b2.
  let b1. assume Hb1.
  let b2. assume Hb2.
  let x. assume Hx1 Hx2.
  apply (ReplE_impred X (fun x0 : set => {x0}) b1 Hb1).
  let x1. assume Hx1X Hb1eq.
  apply (ReplE_impred X (fun x0 : set => {x0}) b2 Hb2).
  let x2. assume Hx2X Hb2eq.
  claim Hx1in : x :e {x1}.
  { rewrite <- Hb1eq. exact Hx1. }
  claim Hx2in : x :e {x2}.
  { rewrite <- Hb2eq. exact Hx2. }
  claim Hx_eq_x1 : x = x1.
  { exact (SingE x1 x Hx1in). }
  claim Hx_eq_x2 : x = x2.
  { exact (SingE x2 x Hx2in). }
  claim HxX : x :e X.
  { rewrite Hx_eq_x1. exact Hx1X. }
  witness {x}.
  apply andI.
  - exact (ReplI X (fun x0 : set => {x0}) x HxX).
  - apply andI.
    + exact (SingI x).
    + prove {x} c= b1 :/\: b2.
      let y. assume Hy.
      claim Hyx: y = x.
      { exact (SingE x y Hy). }
      rewrite Hyx.
      exact (binintersectI b1 b2 x Hx1 Hx2).
Qed.

(** from §13 Example 3: topology generated by singletons is discrete **) 
(** LATEX VERSION: The topology generated by the singleton basis is the discrete topology on X. **)
Theorem generated_topology_singletons_discrete : forall X:set,
  generated_topology X (singleton_basis X) = discrete_topology X.
let X.
apply set_ext.
- let U. assume HUgen.
  exact (SepE1 (Power X)
               (fun U0 : set => forall x0 :e U0, exists b :e singleton_basis X, x0 :e b /\ b c= U0)
               U HUgen).
- let U. assume HUinPow : U :e Power X.
  claim HUsubX : U c= X.
  { exact (PowerE X U HUinPow). }
  claim HUprop : forall x :e U, exists b :e singleton_basis X, x :e b /\ b c= U.
{ let x. assume HxU.
  witness {x}.
  apply andI.
  - exact (ReplI X (fun x0 : set => {x0}) x (HUsubX x HxU)).
  - apply andI.
    * exact (SingI x).
    * let y. assume Hy.
      claim Hyx: y = x.
      { exact (SingE x y Hy). }
      rewrite Hyx.
      exact HxU. }
  exact (SepI (Power X)
              (fun U0 : set => forall x0 :e U0, exists b :e singleton_basis X, x0 :e b /\ b c= U0)
              U
              HUinPow
              HUprop).
Qed.

(** Misleading "OrderedPair" definition eliminated. Cartesian products use setprod (defined at line 2717). Individual ordered pairs use tuple notation (x,y). **)

(** from §13: the real line as ambient set for the standard and related topologies **)
(** LATEX VERSION: We consider the real line R and define standard, lower limit, and K-topologies on it. **)
(** ambient real line **)
Definition R : set := real.

(** rational numbers as subset of reals **)
(** LATEX VERSION: The rationals ℚ as a subset of ℝ. **)
(** FIXED: Now uses proper rational definition from line 6202. rational = {x :e real | exists m :e int, exists n :e omega\\{0}, x = m/n}. **)
Definition Q : set := rational.

(** from §13: the usual order on the real line **)
(** LATEX VERSION: We use the standard relations < and ≤ on the real line. **)
(** ordering relation on the reals **)
Definition Rlt : set -> set -> prop := fun a b =>
  a :e R /\ b :e R /\ a < b.

(** helper: non-strict order on the reals by negating strict order **)
(** LATEX VERSION: Write a ≤ b for not(b < a) in the ambient strict order on ℝ. **)
(** SUSPICIOUS DEFINITION: This defines `a <= b` as `~(b < a)`, not as `a=b \/ a<b`; later uses rely on the trichotomy properties of `<` on reals. **)
Definition Rle : set -> set -> prop := fun a b =>
  a :e R /\ b :e R /\ ~(Rlt b a).

(** helper introduction rule for Rle **)
Theorem RleI : forall a b:set, a :e R -> b :e R -> ~(Rlt b a) -> Rle a b.
let a b. assume Ha Hb Hnlt.
prove a :e R /\ b :e R /\ ~(Rlt b a).
apply and3I.
- exact Ha.
- exact Hb.
- exact Hnlt.
Qed.

(** helper elimination rules for Rle **)
Theorem RleE_left : forall a b:set, Rle a b -> a :e R.
let a b. assume H.
exact (andEL (a :e R) (b :e R) (andEL (a :e R /\ b :e R) (~(Rlt b a)) H)).
Qed.

(** helper elimination rules for Rle **)
Theorem RleE_right : forall a b:set, Rle a b -> b :e R.
let a b. assume H.
exact (andER (a :e R) (b :e R) (andEL (a :e R /\ b :e R) (~(Rlt b a)) H)).
Qed.

(** helper elimination rules for Rle **)
Theorem RleE_nlt : forall a b:set, Rle a b -> ~(Rlt b a).
let a b. assume H.
exact (andER (a :e R /\ b :e R) (~(Rlt b a)) H).
Qed.

(** helper: strictness from non-equality **)
(** LATEX VERSION: If a<=b and a<>b then a<b. **)
Theorem Rle_neq_implies_Rlt : forall a b:set, Rle a b -> ~(a = b) -> Rlt a b.
let a b.
assume Hab: Rle a b.
assume Hneq: ~(a = b).
prove Rlt a b.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hnlt: ~(Rlt b a).
{ exact (RleE_nlt a b Hab). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (Rlt a b)).
- assume Hablt: a < b.
  prove a :e R /\ b :e R /\ a < b.
  apply and3I.
  + exact HaR.
  + exact HbR.
  + exact Hablt.
- assume Habeq: a = b.
  apply FalseE.
  exact (Hneq Habeq).
- assume Hblt: b < a.
  claim Hba: Rlt b a.
  { prove b :e R /\ a :e R /\ b < a.
    apply and3I.
    - exact HbR.
    - exact HaR.
    - exact Hblt. }
  apply FalseE.
  exact (Hnlt Hba).
Qed.

(** helper: nonneg implies neg is nonpos **)
(** LATEX VERSION: If t is real and not(t<0), then -t <= 0. **)
Theorem Rle_minus_nonneg : forall t:set,
  t :e R -> ~(Rlt t 0) -> Rle (minus_SNo t) 0.
let t.
assume HtR: t :e R.
assume Hnlt: ~(Rlt t 0).
prove Rle (minus_SNo t) 0.
apply (RleI (minus_SNo t) 0 (real_minus_SNo t HtR) real_0).
assume Hlt: Rlt 0 (minus_SNo t).
prove False.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HmtS: SNo (minus_SNo t).
{ exact (SNo_minus_SNo t HtS). }
claim HltS: 0 < minus_SNo t.
{ exact (andER (0 :e R /\ minus_SNo t :e R) (0 < minus_SNo t) Hlt). }
claim Hflip: minus_SNo (minus_SNo t) < minus_SNo 0.
{ exact (minus_SNo_Lt_contra 0 (minus_SNo t) SNo_0 HmtS HltS). }
claim Htlt0: t < 0.
{ rewrite <- (minus_SNo_invol t HtS) at 1.
  rewrite <- (minus_SNo_0) at 1.
  exact Hflip. }
claim Hbad: Rlt t 0.
{ prove t :e R /\ 0 :e R /\ t < 0.
  apply and3I.
  - exact HtR.
  - exact real_0.
  - exact Htlt0. }
exact (Hnlt Hbad).
Qed.

(** from §13 Example 4: helper introduction rule for Rlt **)
(** LATEX VERSION: We use the usual convention a<b implies a and b are reals and a<b. **)
Theorem RltI : forall a b:set, a :e R -> b :e R -> a < b -> Rlt a b.
let a b. assume Ha Hb Hab.
prove a :e R /\ b :e R /\ a < b.
apply and3I.
- exact Ha.
- exact Hb.
- exact Hab.
Qed.

(** from §13 Example 4: helper elimination rules for Rlt **)
(** LATEX VERSION: If Rlt a b then a and b are reals and a<b. **)
Theorem RltE_left : forall a b:set, Rlt a b -> a :e R.
let a b. assume H.
exact (andEL (a :e R) (b :e R) (andEL (a :e R /\ b :e R) (a < b) H)).
Qed.

(** from §13 Example 4: helper elimination rules for Rlt **)
(** LATEX VERSION: If Rlt a b then a and b are reals and a<b. **)
Theorem RltE_right : forall a b:set, Rlt a b -> b :e R.
let a b. assume H.
exact (andER (a :e R) (b :e R) (andEL (a :e R /\ b :e R) (a < b) H)).
Qed.

(** from §13 Example 4: helper elimination rules for Rlt **)
(** LATEX VERSION: If Rlt a b then a and b are reals and a<b. **)
Theorem RltE_lt : forall a b:set, Rlt a b -> a < b.
let a b. assume H.
exact (andER (a :e R /\ b :e R) (a < b) H).
Qed.

(** helper: transitivity of Rlt **)
(** LATEX VERSION: If a<b and b<c then a<c. **)
Theorem Rlt_tra : forall a b c:set, Rlt a b -> Rlt b c -> Rlt a c.
let a b c. assume Hab Hbc.
claim HaR : a :e R.
{ exact (RltE_left a b Hab). }
claim HbR : b :e R.
{ exact (RltE_right a b Hab). }
claim HcR : c :e R.
{ exact (RltE_right b c Hbc). }
claim Hablt : a < b.
{ exact (RltE_lt a b Hab). }
claim Hbclt : b < c.
{ exact (RltE_lt b c Hbc). }
claim HaS : SNo a.
{ exact (real_SNo a HaR). }
claim HbS : SNo b.
{ exact (real_SNo b HbR). }
claim HcS : SNo c.
{ exact (real_SNo c HcR). }
claim Haclt : a < c.
{ exact (SNoLt_tra a b c HaS HbS HcS Hablt Hbclt). }
exact (RltI a c HaR HcR Haclt).
Qed.

(** from §13 Example 4: Rlt is irreflexive **)
(** LATEX VERSION: We use that a<a is impossible. **)
Theorem not_Rlt_refl : forall a:set, a :e R -> ~(Rlt a a).
let a. assume Ha.
assume Haa.
claim Hlt : a < a.
{ exact (RltE_lt a a Haa). }
exact ((SNoLt_irref a) Hlt).
Qed.

(** helper: asymmetry of Rlt **)
(** LATEX VERSION: If a<b then not(b<a). **)
Theorem not_Rlt_sym : forall a b:set, Rlt a b -> ~(Rlt b a).
let a b. assume Hab.
assume Hba.
claim Haa: Rlt a a.
{ exact (Rlt_tra a b a Hab Hba). }
exact (not_Rlt_refl a (RltE_left a b Hab) Haa).
Qed.

(** helper: if a<b then 0 < (b-a) in Rlt form **)
(** LATEX VERSION: If a<b in R then b-a is positive. **)
Theorem Rlt_0_diff_of_lt : forall a b:set,
  Rlt a b -> Rlt 0 (add_SNo b (minus_SNo a)).
let a b.
assume Hab: Rlt a b.
claim HaR: a :e R.
{ exact (RltE_left a b Hab). }
claim HbR: b :e R.
{ exact (RltE_right a b Hab). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hablt: a < b.
{ exact (RltE_lt a b Hab). }
claim HmaS: SNo (minus_SNo a).
{ exact (SNo_minus_SNo a HaS). }
claim Hmablt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) b.
{ exact (add_SNo_Lt2 (minus_SNo a) a b HmaS HaS HbS Hablt). }
claim H0lt: 0 < add_SNo (minus_SNo a) b.
{ rewrite <- (add_SNo_minus_SNo_linv a HaS) at 1.
  exact Hmablt. }
claim HmabR: add_SNo (minus_SNo a) b :e R.
{ exact (real_add_SNo (minus_SNo a) (real_minus_SNo a HaR) b HbR). }
claim Hcom: add_SNo (minus_SNo a) b = add_SNo b (minus_SNo a).
{ exact (add_SNo_com (minus_SNo a) b HmaS HbS). }
claim HbaR: add_SNo b (minus_SNo a) :e R.
{ exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
claim H0lt2: 0 < add_SNo b (minus_SNo a).
{ rewrite <- Hcom.
  exact H0lt. }
exact (RltI 0 (add_SNo b (minus_SNo a)) real_0 HbaR H0lt2).
Qed.

(** helper: strict order implies non-strict order **)
Theorem Rlt_implies_Rle : forall a b:set, Rlt a b -> Rle a b.
let a b. assume Hab.
apply (RleI a b (RltE_left a b Hab) (RltE_right a b Hab)).
exact (not_Rlt_sym a b Hab).
Qed.

(** helper: reflexivity of Rle **)
(** LATEX VERSION: a ≤ a. **)
Theorem Rle_refl : forall a:set, a :e R -> Rle a a.
let a. assume Ha.
apply (RleI a a Ha Ha).
exact (not_Rlt_refl a Ha).
Qed.

(** helper: antisymmetry for Rle, via SNo trichotomy on reals **)
Theorem R_eq_of_not_Rlt : forall a b:set,
  a :e R -> b :e R -> ~(Rlt a b) -> ~(Rlt b a) -> a = b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Hnltab: ~(Rlt a b).
assume Hnltba: ~(Rlt b a).
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (a = b)).
- assume Hab: a < b.
  claim Hr: Rlt a b.
  { exact (RltI a b HaR HbR Hab). }
  exact (FalseE (Hnltab Hr) (a = b)).
- assume Heq: a = b.
  exact Heq.
- assume Hba: b < a.
  claim Hr: Rlt b a.
  { exact (RltI b a HbR HaR Hba). }
  exact (FalseE (Hnltba Hr) (a = b)).
Qed.

(** helper: antisymmetry of Rle **)
(** LATEX VERSION: If a ≤ b and b ≤ a then a = b. **)
Theorem Rle_antisym : forall a b:set, Rle a b -> Rle b a -> a = b.
let a b.
assume Hab: Rle a b.
assume Hba: Rle b a.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hnltab: ~(Rlt a b).
{ exact (RleE_nlt b a Hba). }
claim Hnltba: ~(Rlt b a).
{ exact (RleE_nlt a b Hab). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (a = b)).
- assume Hablt: a < b.
  apply FalseE.
  exact (Hnltab (RltI a b HaR HbR Hablt)).
- assume HabEq: a = b.
  exact HabEq.
- assume Hbalt: b < a.
  apply FalseE.
  exact (Hnltba (RltI b a HbR HaR Hbalt)).
Qed.

(** helper: convert non-strict real order to SNo order **)
Theorem SNoLe_of_Rle : forall a b:set, Rle a b -> a <= b.
let a b.
assume Hab: Rle a b.
prove a <= b.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hnlt: ~(Rlt b a).
{ exact (RleE_nlt a b Hab). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (a <= b)).
- assume Hablt: a < b.
  exact (SNoLtLe a b Hablt).
- assume Habeq: a = b.
  rewrite Habeq.
  exact (SNoLe_ref b).
- assume Hbalt: b < a.
  claim HbaltR: Rlt b a.
  { exact (RltI b a HbR HaR Hbalt). }
  exact (FalseE (Hnlt HbaltR) (a <= b)).
Qed.

(** helper for §13 Example 4: 0 < 1 in Rlt form **)
(** LATEX VERSION: We use 0<1 in the usual order on R. **)
Theorem Rlt_0_1 : Rlt 0 1.
exact (RltI 0 1 real_0 real_1 SNoLt_0_1).
Qed.

(** from §13 Example 4: -1 is less than 0 in ℝ **)
(** LATEX VERSION: We use that -1 < 0. **)
Theorem minus_1_lt_0 : minus_SNo 1 < 0.
claim H01 : 0 < 1.
{ exact SNoLt_0_1. }
claim Hm1ltm0 : minus_SNo 1 < minus_SNo 0.
{ exact (minus_SNo_Lt_contra 0 1 SNo_0 SNo_1 H01). }
rewrite <- (minus_SNo_0) at 2.
exact Hm1ltm0.
Qed.

(** from §13 Example 4: circular vs rectangular region bases **)
(** LATEX VERSION: Example 4: circular regions and axis-parallel rectangular regions in ℝ² both form bases generating the same topology. **)
(** FIXED: EuclidPlane is now correctly R×R (Cartesian product), since `setprod` is the Σ-encoding used throughout for X×Y. **)
Definition EuclidPlane : set := setprod R R.
(** from §13 Examples 1-2: coordinates on the plane **)
(** LATEX VERSION: A point in the plane is described by its x and y coordinates. **)
(** Coordinate selectors for points in EuclidPlane. **)
Definition R2_xcoord : set -> set := fun p => p 0.

(** from §13 Examples 1-2: coordinates on the plane **)
(** LATEX VERSION: A point in the plane is described by its x and y coordinates. **)
Definition R2_ycoord : set -> set := fun p => p 1.

(** from §13 Example 4: coordinates of a point in R×R are real **)
(** LATEX VERSION: If p ∈ ℝ×ℝ then its coordinates lie in ℝ. **)
Theorem EuclidPlane_xcoord_in_R : forall p:set, p :e EuclidPlane -> R2_xcoord p :e R.
let p. assume Hp.
prove p 0 :e R.
exact (ap0_Sigma R (fun _ : set => R) p Hp).
Qed.

(** from §13 Example 4: coordinates of a point in R×R are real **)
(** LATEX VERSION: If p ∈ ℝ×ℝ then its coordinates lie in ℝ. **)
Theorem EuclidPlane_ycoord_in_R : forall p:set, p :e EuclidPlane -> R2_ycoord p :e R.
let p. assume Hp.
prove p 1 :e R.
claim Hp1 : p 1 :e (fun _ : set => R) (p 0).
{ exact (ap1_Sigma R (fun _ : set => R) p Hp). }
exact Hp1.
Qed.

(** from §13 Example 4: coordinate selectors on tuples **)
(** LATEX VERSION: For a point (x,y), the coordinate maps return x and y. **)
Theorem R2_xcoord_tuple : forall x y:set, R2_xcoord (x,y) = x.
let x y.
prove (x,y) 0 = x.
rewrite <- (tuple_pair x y).
exact (pair_ap_0 x y).
Qed.

(** from §13 Example 4: coordinate selectors on tuples **)
(** LATEX VERSION: For a point (x,y), the coordinate maps return x and y. **)
Theorem R2_ycoord_tuple : forall x y:set, R2_ycoord (x,y) = y.
let x y.
prove (x,y) 1 = y.
rewrite <- (tuple_pair x y).
exact (pair_ap_1 x y).
Qed.

(** helper: equality of ordered pairs is coordinatewise **)
(** LATEX VERSION: If (x1,y1) = (x2,y2) then x1=x2 and y1=y2. **)
Theorem tuple_eq_coords : forall x1 y1 x2 y2:set,
  (x1,y1) = (x2,y2) -> x1 = x2 /\ y1 = y2.
let x1 y1 x2 y2. assume Heq.
apply andI.
- prove x1 = x2.
  claim Hproj0: (x1,y1) 0 = (x2,y2) 0.
  { rewrite Heq. reflexivity. }
  claim Hx1: (x1,y1) 0 = x1.
  { exact (tuple_2_0_eq x1 y1). }
  claim Hx2: (x2,y2) 0 = x2.
  { exact (tuple_2_0_eq x2 y2). }
  rewrite <- Hx1.
  rewrite <- Hx2.
  exact Hproj0.
- prove y1 = y2.
  claim Hproj1: (x1,y1) 1 = (x2,y2) 1.
  { rewrite Heq. reflexivity. }
  claim Hy1: (x1,y1) 1 = y1.
  { exact (tuple_2_1_eq x1 y1). }
  claim Hy2: (x2,y2) 1 = y2.
  { exact (tuple_2_1_eq x2 y2). }
  rewrite <- Hy1.
  rewrite <- Hy2.
  exact Hproj1.
Qed.

(** helper: equality of ordered pairs from coordinate equalities **)
(** LATEX VERSION: If x1=x2 and y1=y2 then (x1,y1)=(x2,y2). **)
Theorem tuple_coords_eq : forall x1 y1 x2 y2:set,
  x1 = x2 -> y1 = y2 -> (x1,y1) = (x2,y2).
let x1 y1 x2 y2.
assume Hx: x1 = x2.
assume Hy: y1 = y2.
rewrite Hx.
rewrite Hy.
reflexivity.
Qed.

(** helper: equality of ordered pairs from coordinate equalities **)
(** LATEX VERSION: If x1=x2 and y1=y2 then (x1,y1)=(x2,y2). **)
Theorem coords_eq_tuple : forall x1 y1 x2 y2:set,
  x1 = x2 -> y1 = y2 -> (x1,y1) = (x2,y2).
let x1 y1 x2 y2.
assume Hx: x1 = x2.
assume Hy: y1 = y2.
rewrite <- (tuple_pair x1 y1) at 1.
rewrite <- (tuple_pair x2 y2).
rewrite Hx.
rewrite Hy.
reflexivity.
Qed.

(** helper: eta law for points in EuclidPlane **)
(** LATEX VERSION: Every point p in R×R is equal to the ordered pair of its coordinates. **)
Theorem EuclidPlane_eta : forall p:set, p :e EuclidPlane -> (R2_xcoord p, R2_ycoord p) = p.
let p. assume Hp.
prove (R2_xcoord p, R2_ycoord p) = p.
apply (Sigma_E R (fun _ : set => R) p Hp).
let x.
assume Hx_pair.
apply Hx_pair.
assume HxR Hexy.
apply Hexy.
let y.
assume Hy_pair.
apply Hy_pair.
assume HyR Hpeq.
claim HeqT: p = (x,y).
{ prove p = (x,y).
  rewrite <- (tuple_pair x y).
  exact Hpeq. }
rewrite HeqT.
rewrite (R2_xcoord_tuple x y).
rewrite (R2_ycoord_tuple x y).
reflexivity.
Qed.

(** from §13 Example 4: equality of points in R×R is coordinatewise **)
(** LATEX VERSION: If (x1,y1) = (x2,y2) then x1=x2 and y1=y2. **)
Theorem tuple_eq_coords_R2 : forall x1 y1 x2 y2:set,
  (x1,y1) = (x2,y2) -> x1 = x2 /\ y1 = y2.
let x1 y1 x2 y2. assume Heq.
apply andI.
- prove x1 = x2.
  rewrite <- (R2_xcoord_tuple x1 y1).
  rewrite <- (R2_xcoord_tuple x2 y2).
  rewrite Heq.
  reflexivity.
- prove y1 = y2.
  rewrite <- (R2_ycoord_tuple x1 y1).
  rewrite <- (R2_ycoord_tuple x2 y2).
  rewrite Heq.
  reflexivity.
Qed.

(** from §13 Examples 1-2: circular and rectangular regions in the plane **)
(** LATEX VERSION: Circular regions are interiors of circles in the plane; they are described using a distance function d(p,c) < r. **)
(** Euclidean distance in ℝ²: sqrt((x1-x2)^2 + (y1-y2)^2), implemented using pre-topology surreal and real operations. **)
Definition distance_R2 : set -> set -> set := fun p c =>
  sqrt_SNo_nonneg
    (add_SNo
      (mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)))
              (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
      (mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))
              (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c))))).

(** from §13 Example 4: distance is real-valued **)
(** LATEX VERSION: For points p,c in R×R, the distance d(p,c) is a real number. **)
Theorem distance_R2_in_R : forall p c:set, p :e EuclidPlane -> c :e EuclidPlane -> distance_R2 p c :e R.
let p c. assume Hp Hc.
(** coordinates are real **)
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
(** differences in R **)
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
(** squares and sum in R **)
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
claim Hdx2def : dx2 = mul_SNo dx dx.
{ reflexivity. }
claim Hdy2def : dy2 = mul_SNo dy dy.
{ reflexivity. }
claim Hdx2R : dx2 :e R.
{ exact (real_mul_SNo dx HdxR dx HdxR). }
claim Hdy2R : dy2 :e R.
{ exact (real_mul_SNo dy HdyR dy HdyR). }
set sum := add_SNo dx2 dy2.
claim Hsumdef : sum = add_SNo dx2 dy2.
{ reflexivity. }
claim HsumR : sum :e R.
{ exact (real_add_SNo dx2 Hdx2R dy2 Hdy2R). }
(** nonnegativity of squares and of the sum **)
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hdy2S : SNo dy2.
{ exact (real_SNo dy2 Hdy2R). }
claim Hdx2nonneg : 0 <= dx2.
{ claim H0or : dx = 0 \/ 0 < (mul_SNo dx dx).
  { exact (SNo_zero_or_sqr_pos dx HdxS). }
  apply H0or.
  - assume Hdx0 : dx = 0.
    rewrite Hdx2def.
    rewrite Hdx0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dx dx).
    rewrite Hdx2def.
    exact (SNoLtLe 0 (mul_SNo dx dx) Hpos).
}
claim Hdy2nonneg : 0 <= dy2.
{ claim H0or : dy = 0 \/ 0 < (mul_SNo dy dy).
  { exact (SNo_zero_or_sqr_pos dy HdyS). }
  apply H0or.
  - assume Hdy0 : dy = 0.
    rewrite Hdy2def.
    rewrite Hdy0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dy dy).
    rewrite Hdy2def.
    exact (SNoLtLe 0 (mul_SNo dy dy) Hpos).
}
claim HsumNonneg : 0 <= sum.
{ rewrite Hsumdef.
  rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact (add_SNo_Le3 0 0 dx2 dy2 SNo_0 SNo_0 Hdx2S Hdy2S Hdx2nonneg Hdy2nonneg).
}
(** unfold distance_R2 and apply sqrt real lemma **)
claim Hdef : distance_R2 p c = sqrt_SNo_nonneg sum.
{ reflexivity. }
rewrite Hdef.
exact (sqrt_SNo_nonneg_real sum HsumR HsumNonneg).
Qed.

(** from §13 Example 4: distance is nonnegative **)
(** LATEX VERSION: The distance function takes nonnegative values. **)
Theorem distance_R2_nonneg : forall p c:set, p :e EuclidPlane -> c :e EuclidPlane -> 0 <= distance_R2 p c.
let p c. assume Hp Hc.
(** coordinates are real **)
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
(** differences **)
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
(** squares and sum **)
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
claim Hdx2R : dx2 :e R.
{ exact (real_mul_SNo dx HdxR dx HdxR). }
claim Hdy2R : dy2 :e R.
{ exact (real_mul_SNo dy HdyR dy HdyR). }
set sum := add_SNo dx2 dy2.
claim HsumR : sum :e R.
{ exact (real_add_SNo dx2 Hdx2R dy2 Hdy2R). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hdy2S : SNo dy2.
{ exact (real_SNo dy2 Hdy2R). }
claim HsumS : SNo sum.
{ exact (real_SNo sum HsumR). }
(** nonnegativity of squares and of the sum **)
claim Hdx2nonneg : 0 <= dx2.
{ claim H0or : dx = 0 \/ 0 < (mul_SNo dx dx).
  { exact (SNo_zero_or_sqr_pos dx HdxS). }
  apply H0or.
  - assume Hdx0 : dx = 0.
    rewrite Hdx0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dx dx).
    exact (SNoLtLe 0 (mul_SNo dx dx) Hpos).
}
claim Hdy2nonneg : 0 <= dy2.
{ claim H0or : dy = 0 \/ 0 < (mul_SNo dy dy).
  { exact (SNo_zero_or_sqr_pos dy HdyS). }
  apply H0or.
  - assume Hdy0 : dy = 0.
    rewrite Hdy0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dy dy).
    exact (SNoLtLe 0 (mul_SNo dy dy) Hpos).
}
claim HsumNonneg : 0 <= sum.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact (add_SNo_Le3 0 0 dx2 dy2 SNo_0 SNo_0 Hdx2S Hdy2S Hdx2nonneg Hdy2nonneg).
}
(** conclude using sqrt nonnegativity **)
claim Hdef : distance_R2 p c = sqrt_SNo_nonneg sum.
{ reflexivity. }
rewrite Hdef.
exact (sqrt_SNo_nonneg_nonneg sum HsumS HsumNonneg).
Qed.

(** from §13 Example 4: squared distance formula **)
(** LATEX VERSION: d(p,c) squared equals (xp-xc) squared plus (yp-yc) squared. **)
Theorem distance_R2_sqr : forall p c:set, p :e EuclidPlane -> c :e EuclidPlane ->
  mul_SNo (distance_R2 p c) (distance_R2 p c)
  = add_SNo
      (mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)))
              (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
      (mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))
              (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))).
let p c. assume Hp Hc.
(** establish that the sum under the square root is surreal and nonnegative **)
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
claim Hdx2R : dx2 :e R.
{ exact (real_mul_SNo dx HdxR dx HdxR). }
claim Hdy2R : dy2 :e R.
{ exact (real_mul_SNo dy HdyR dy HdyR). }
set sum := add_SNo dx2 dy2.
claim HsumR : sum :e R.
{ exact (real_add_SNo dx2 Hdx2R dy2 Hdy2R). }
claim HsumS : SNo sum.
{ exact (real_SNo sum HsumR). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hdy2S : SNo dy2.
{ exact (real_SNo dy2 Hdy2R). }
claim Hdx2nonneg : 0 <= dx2.
{ claim H0or : dx = 0 \/ 0 < (mul_SNo dx dx).
  { exact (SNo_zero_or_sqr_pos dx HdxS). }
  apply H0or.
  - assume Hdx0 : dx = 0.
    rewrite Hdx0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dx dx).
    exact (SNoLtLe 0 (mul_SNo dx dx) Hpos).
}
claim Hdy2nonneg : 0 <= dy2.
{ claim H0or : dy = 0 \/ 0 < (mul_SNo dy dy).
  { exact (SNo_zero_or_sqr_pos dy HdyS). }
  apply H0or.
  - assume Hdy0 : dy = 0.
    rewrite Hdy0.
    rewrite (mul_SNo_zeroL 0 SNo_0).
    exact (SNoLe_ref 0).
  - assume Hpos : 0 < (mul_SNo dy dy).
    exact (SNoLtLe 0 (mul_SNo dy dy) Hpos).
}
claim HsumNonneg : 0 <= sum.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact (add_SNo_Le3 0 0 dx2 dy2 SNo_0 SNo_0 Hdx2S Hdy2S Hdx2nonneg Hdy2nonneg).
}
(** unfold distance_R2 and use the square root squaring lemma **)
claim Hdef : distance_R2 p c = sqrt_SNo_nonneg sum.
{ reflexivity. }
rewrite Hdef.
rewrite (sqrt_SNo_nonneg_sqr sum HsumS HsumNonneg).
(** unfold sum, dx2, dy2 **)
reflexivity.
Qed.

(** helper: the square of abs equals the square of the original **)
(** LATEX VERSION: For real numbers, abs(x) squared equals x squared. **)
Theorem abs_SNo_sqr_eq : forall x:set,
  SNo x ->
  mul_SNo (abs_SNo x) (abs_SNo x) = mul_SNo x x.
let x.
assume HxS: SNo x.
apply (xm (0 <= x)).
- assume H0le: 0 <= x.
  rewrite (nonneg_abs_SNo x H0le).
  reflexivity.
- assume Hn0le: ~(0 <= x).
  rewrite (not_nonneg_abs_SNo x Hn0le).
  rewrite (mul_SNo_minus_minus x x HxS HxS).
  reflexivity.
Qed.

(** helper: adding a nonnegative term preserves order on the right **)
(** LATEX VERSION: If y is nonnegative then x <= x + y. **)
Theorem SNoLe_add_nonneg_right : forall x y:set,
  SNo x -> SNo y -> 0 <= y -> x <= add_SNo x y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0ley: 0 <= y.
claim H0S: SNo 0.
{ exact SNo_0. }
claim Hle: add_SNo x 0 <= add_SNo x y.
{ exact (add_SNo_Le2 x 0 y HxS H0S HyS H0ley). }
claim Hx0: add_SNo x 0 = x.
{ exact (add_SNo_0R x HxS). }
prove x <= add_SNo x y.
rewrite <- Hx0 at 1.
exact Hle.
Qed.

(** helper: a square is nonnegative **)
(** LATEX VERSION: For real numbers, x squared is nonnegative. **)
Theorem SNo_sqr_nonneg : forall x:set,
  SNo x ->
  0 <= mul_SNo x x.
let x.
assume HxS: SNo x.
claim Hcases: x = 0 \/ 0 < mul_SNo x x.
{ exact (SNo_zero_or_sqr_pos x HxS). }
apply Hcases.
- assume Hx0: x = 0.
  rewrite Hx0.
  rewrite (mul_SNo_zeroL 0 SNo_0).
  exact (SNoLe_ref 0).
- assume Hpos: 0 < mul_SNo x x.
  exact (SNoLtLe 0 (mul_SNo x x) Hpos).
Qed.

(** Helper: first squared coordinate difference bounded by squared distance **)
(** LATEX VERSION: If d(p,c) is the Euclidean distance then (xp-xc) squared is at most d(p,c) squared. **)
Theorem dx2_le_distance_R2_sqr : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)))
         (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)))
  <= mul_SNo (distance_R2 p c) (distance_R2 p c).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
claim Hdx2R : dx2 :e R.
{ exact (real_mul_SNo dx HdxR dx HdxR). }
claim Hdy2R : dy2 :e R.
{ exact (real_mul_SNo dy HdyR dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hdy2S : SNo dy2.
{ exact (real_SNo dy2 Hdy2R). }
claim Hdy2nonneg : 0 <= dy2.
{ exact (SNo_sqr_nonneg dy HdyS). }
prove mul_SNo dx dx <= mul_SNo (distance_R2 p c) (distance_R2 p c).
rewrite (distance_R2_sqr p c Hp Hc).
exact (SNoLe_add_nonneg_right dx2 dy2 Hdx2S Hdy2S Hdy2nonneg).
Qed.

(** Helper: second squared coordinate difference bounded by squared distance **)
(** LATEX VERSION: If d(p,c) is the Euclidean distance then (yp-yc) squared is at most d(p,c) squared. **)
Theorem dy2_le_distance_R2_sqr : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))
         (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))
  <= mul_SNo (distance_R2 p c) (distance_R2 p c).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
claim Hdx2R : dx2 :e R.
{ exact (real_mul_SNo dx HdxR dx HdxR). }
claim Hdy2R : dy2 :e R.
{ exact (real_mul_SNo dy HdyR dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hdy2S : SNo dy2.
{ exact (real_SNo dy2 Hdy2R). }
claim Hdx2nonneg : 0 <= dx2.
{ exact (SNo_sqr_nonneg dx HdxS). }
prove mul_SNo dy dy <= mul_SNo (distance_R2 p c) (distance_R2 p c).
rewrite (distance_R2_sqr p c Hp Hc).
rewrite (add_SNo_com dx2 dy2 Hdx2S Hdy2S).
exact (SNoLe_add_nonneg_right dy2 dx2 Hdy2S Hdx2S Hdx2nonneg).
Qed.

(** Helper: absolute x coordinate difference squared bounded by squared distance **)
(** LATEX VERSION: The square of abs(xp-xc) is at most d(p,c) squared. **)
Theorem abs_dx2_le_distance_R2_sqr : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  mul_SNo
    (abs_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
    (abs_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
  <= mul_SNo (distance_R2 p c) (distance_R2 p c).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
rewrite (abs_SNo_sqr_eq dx HdxS).
exact (dx2_le_distance_R2_sqr p c Hp Hc).
Qed.

(** Helper: absolute y coordinate difference squared bounded by squared distance **)
(** LATEX VERSION: The square of abs(yp-yc) is at most d(p,c) squared. **)
Theorem abs_dy2_le_distance_R2_sqr : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  mul_SNo
    (abs_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c))))
    (abs_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c))))
  <= mul_SNo (distance_R2 p c) (distance_R2 p c).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
rewrite (abs_SNo_sqr_eq dy HdyS).
exact (dy2_le_distance_R2_sqr p c Hp Hc).
Qed.

(** Helper: absolute value is nonnegative **)
(** LATEX VERSION: For real numbers, abs(x) is always nonnegative. **)
Theorem abs_SNo_nonneg : forall x:set,
  SNo x ->
  0 <= abs_SNo x.
let x.
assume HxS: SNo x.
apply (xm (0 <= x)).
- assume H0le: 0 <= x.
  rewrite (nonneg_abs_SNo x H0le).
  exact H0le.
- assume Hn0le: ~(0 <= x).
  rewrite (not_nonneg_abs_SNo x Hn0le).
  (** show x < 0 by trichotomy, since neither 0<=x nor x=0 can hold **)
  claim Hxlt0: x < 0.
  { apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (x < 0)).
    - assume H: x < 0.
      exact H.
    - assume Hx0: x = 0.
      claim H0le0: 0 <= x.
      { rewrite Hx0.
        exact (SNoLe_ref 0). }
      prove x < 0.
      exact (FalseE (Hn0le H0le0) (x < 0)).
    - assume H0ltx: 0 < x.
      claim H0lex: 0 <= x.
      { exact (SNoLtLe 0 x H0ltx). }
      prove x < 0.
      exact (FalseE (Hn0le H0lex) (x < 0)). }
  claim Hxle0: x <= 0.
  { exact (SNoLtLe x 0 Hxlt0). }
  claim Hneg0le: minus_SNo 0 <= minus_SNo x.
  { exact (minus_SNo_Le_contra x 0 HxS SNo_0 Hxle0). }
  rewrite <- minus_SNo_0 at 1.
  exact Hneg0le.
Qed.

(** Helper: strict inequality implies strict inequality of squares for nonnegative numbers **)
(** LATEX VERSION: If 0<=x<y then x squared is less than y squared. **)
Theorem SNo_sqr_lt_of_lt_nonneg : forall x y:set,
  SNo x ->
  SNo y ->
  0 <= x ->
  x < y ->
  mul_SNo x x < mul_SNo y y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0lex: 0 <= x.
assume Hxlt: x < y.
claim H0lt_or_eq: 0 < x \/ 0 = x.
{ claim H0x: 0 < x \/ 0 = x.
  { exact (SNoLeE 0 x SNo_0 HxS H0lex). }
  exact H0x. }
apply H0lt_or_eq.
- assume H0ltx: 0 < x.
  claim H0lty: 0 < y.
  { exact (SNoLt_tra 0 x y SNo_0 HxS HyS H0ltx Hxlt). }
  exact (pos_mul_SNo_Lt2 x x y y HxS HxS HyS HyS H0ltx H0ltx Hxlt Hxlt).
- assume H0eqx: 0 = x.
  claim H0lt_y: 0 < y.
  { rewrite H0eqx at 1.
    exact Hxlt. }
  rewrite <- H0eqx.
  rewrite (mul_SNo_zeroL 0 SNo_0).
  exact (mul_SNo_pos_pos y y HyS HyS H0lt_y H0lt_y).
Qed.

(** Helper: coordinate absolute difference bounded by distance **)
(** LATEX VERSION: In Euclidean plane, abs(xp-xc) is at most d(p,c). **)
Theorem abs_dx_le_distance_R2 : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  abs_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))) <= distance_R2 p c.
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set a := abs_SNo dx.
set d := distance_R2 p c.
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hc0R : R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim Hmx : minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) Hc0R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord c)) Hmx). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HaS : SNo a.
{ exact (SNo_abs_SNo dx HdxS). }
claim Ha0le : 0 <= a.
{ exact (abs_SNo_nonneg dx HdxS). }
claim HdR : d :e R.
{ exact (distance_R2_in_R p c Hp Hc). }
claim HdS : SNo d.
{ exact (real_SNo d HdR). }
claim Hd0le : 0 <= d.
{ exact (distance_R2_nonneg p c Hp Hc). }
claim Hsqle : mul_SNo a a <= mul_SNo d d.
{ exact (abs_dx2_le_distance_R2_sqr p c Hp Hc). }
apply (SNoLtLe_or d a HdS HaS).
- assume Hlt: d < a.
  claim Hsqrlt : mul_SNo d d < mul_SNo a a.
  { exact (SNo_sqr_lt_of_lt_nonneg d a HdS HaS Hd0le Hlt). }
  claim Hd2S: SNo (mul_SNo d d).
  { exact (SNo_mul_SNo d d HdS HdS). }
  claim Ha2S: SNo (mul_SNo a a).
  { exact (SNo_mul_SNo a a HaS HaS). }
  claim Hbad: mul_SNo d d < mul_SNo d d.
  { exact (SNoLtLe_tra (mul_SNo d d) (mul_SNo a a) (mul_SNo d d) Hd2S Ha2S Hd2S Hsqrlt Hsqle). }
  exact (FalseE ((SNoLt_irref (mul_SNo d d)) Hbad) (a <= d)).
- assume Hle: a <= d.
  exact Hle.
Qed.

(** Helper: coordinate absolute difference bounded by distance **)
(** LATEX VERSION: In Euclidean plane, abs(yp-yc) is at most d(p,c). **)
Theorem abs_dy_le_distance_R2 : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  abs_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c))) <= distance_R2 p c.
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
set a := abs_SNo dy.
set d := distance_R2 p c.
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hc1R : R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim Hmy : minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) Hc1R). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord c)) Hmy). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim HaS : SNo a.
{ exact (SNo_abs_SNo dy HdyS). }
claim Ha0le : 0 <= a.
{ exact (abs_SNo_nonneg dy HdyS). }
claim HdR : d :e R.
{ exact (distance_R2_in_R p c Hp Hc). }
claim HdS : SNo d.
{ exact (real_SNo d HdR). }
claim Hd0le : 0 <= d.
{ exact (distance_R2_nonneg p c Hp Hc). }
claim Hsqle : mul_SNo a a <= mul_SNo d d.
{ exact (abs_dy2_le_distance_R2_sqr p c Hp Hc). }
apply (SNoLtLe_or d a HdS HaS).
- assume Hlt: d < a.
  claim Hsqrlt : mul_SNo d d < mul_SNo a a.
  { exact (SNo_sqr_lt_of_lt_nonneg d a HdS HaS Hd0le Hlt). }
  claim Hd2S: SNo (mul_SNo d d).
  { exact (SNo_mul_SNo d d HdS HdS). }
  claim Ha2S: SNo (mul_SNo a a).
  { exact (SNo_mul_SNo a a HaS HaS). }
  claim Hbad: mul_SNo d d < mul_SNo d d.
  { exact (SNoLtLe_tra (mul_SNo d d) (mul_SNo a a) (mul_SNo d d) Hd2S Ha2S Hd2S Hsqrlt Hsqle). }
  exact (FalseE ((SNoLt_irref (mul_SNo d d)) Hbad) (a <= d)).
- assume Hle: a <= d.
  exact Hle.
Qed.

(** Helper: from abs(t)<r and r>0 infer t<r **)
(** LATEX VERSION: If abs(t) < r and r is positive then t < r. **)
Theorem abs_SNo_lt_imp_lt : forall t r:set,
  SNo t ->
  SNo r ->
  0 < r ->
  abs_SNo t < r ->
  t < r.
let t r.
assume HtS: SNo t.
assume HrS: SNo r.
assume Hrpos: 0 < r.
assume Hab: abs_SNo t < r.
apply (xm (0 <= t)).
- assume H0let: 0 <= t.
  rewrite <- (nonneg_abs_SNo t H0let) at 1.
  exact Hab.
- assume Hn0let: ~(0 <= t).
  (** if t is negative then t<0<r, hence t<r **)
  claim Htlt0: t < 0.
  { apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (t < 0)).
    - assume H: t < 0.
      exact H.
    - assume Ht0: t = 0.
      claim H0let: 0 <= t.
      { rewrite Ht0.
        exact (SNoLe_ref 0). }
      prove t < 0.
      exact (FalseE (Hn0let H0let) (t < 0)).
    - assume H0ltt: 0 < t.
      claim H0let: 0 <= t.
      { exact (SNoLtLe 0 t H0ltt). }
      prove t < 0.
      exact (FalseE (Hn0let H0let) (t < 0)). }
  exact (SNoLt_tra t 0 r HtS SNo_0 HrS Htlt0 Hrpos).
Qed.

(** Helper: from abs(t)<r and r>0 infer -t<r **)
(** LATEX VERSION: If abs(t) < r and r is positive then -t < r. **)
Theorem abs_SNo_lt_imp_neg_lt : forall t r:set,
  SNo t ->
  SNo r ->
  0 < r ->
  abs_SNo t < r ->
  minus_SNo t < r.
let t r.
assume HtS: SNo t.
assume HrS: SNo r.
assume Hrpos: 0 < r.
assume Hab: abs_SNo t < r.
apply (xm (0 <= t)).
- assume H0let: 0 <= t.
  claim HnegS: SNo (minus_SNo t).
  { exact (SNo_minus_SNo t HtS). }
  claim Hle: minus_SNo t <= 0.
  { claim H0S: SNo 0.
    { exact SNo_0. }
    claim HnegLe: minus_SNo t <= minus_SNo 0.
    { exact (minus_SNo_Le_contra 0 t SNo_0 HtS H0let). }
    rewrite <- minus_SNo_0.
    exact HnegLe. }
  exact (SNoLeLt_tra (minus_SNo t) 0 r HnegS SNo_0 HrS Hle Hrpos).
- assume Hn0let: ~(0 <= t).
  rewrite <- (not_nonneg_abs_SNo t Hn0let) at 1.
  exact Hab.
Qed.

(** helper: propagate strict lower bound through an abs-difference bound **)
(** If a < x-r and abs(x-y) < r with r>0, then a < y. **)
Theorem SNo_lt_of_abs_diff_and_margin : forall a x y r:set,
  SNo a ->
  SNo x ->
  SNo y ->
  SNo r ->
  0 < r ->
  a < add_SNo x (minus_SNo r) ->
  abs_SNo (add_SNo x (minus_SNo y)) < r ->
  a < y.
let a x y r.
assume HaS: SNo a.
assume HxS: SNo x.
assume HyS: SNo y.
assume HrS: SNo r.
assume Hrpos: 0 < r.
assume Hamargin: a < add_SNo x (minus_SNo r).
assume Hab: abs_SNo (add_SNo x (minus_SNo y)) < r.
claim HxmrS: SNo (add_SNo x (minus_SNo r)).
{ exact (SNo_add_SNo x (minus_SNo r) HxS (SNo_minus_SNo r HrS)). }
claim HtS: SNo (add_SNo x (minus_SNo y)).
{ exact (SNo_add_SNo x (minus_SNo y) HxS (SNo_minus_SNo y HyS)). }
claim Hxy_lt_r: add_SNo x (minus_SNo y) < r.
{ exact (abs_SNo_lt_imp_lt (add_SNo x (minus_SNo y)) r HtS HrS Hrpos Hab). }
claim Hx_lt_ry: x < add_SNo r y.
{ exact (add_SNo_minus_Lt1 x y r HxS HyS HrS Hxy_lt_r). }
claim Hx_lt_yr: x < add_SNo y r.
{ rewrite <- (add_SNo_com r y HrS HyS).
  exact Hx_lt_ry. }
claim Hxmr_lt_y: add_SNo x (minus_SNo r) < y.
{ exact (add_SNo_minus_Lt1b x r y HxS HrS HyS Hx_lt_yr). }
exact (SNoLt_tra a (add_SNo x (minus_SNo r)) y HaS HxmrS HyS Hamargin Hxmr_lt_y).
Qed.

(** Helper: distance bound gives x coordinate abs bound **)
(** LATEX VERSION: If d(p,x) < r then abs(xp-xx) < r. **)
Theorem abs_xcoord_lt_of_distance_lt : forall p x r:set,
  p :e EuclidPlane ->
  x :e EuclidPlane ->
  r :e R ->
  Rlt (distance_R2 p x) r ->
  abs_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord x))) < r.
let p x r.
assume Hp: p :e EuclidPlane.
assume Hx: x :e EuclidPlane.
assume HrR: r :e R.
assume Hdr: Rlt (distance_R2 p x) r.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord x)).
set a := abs_SNo dx.
set d := distance_R2 p x.
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hx0R : R2_xcoord x :e R.
{ exact (EuclidPlane_xcoord_in_R x Hx). }
claim Hmx : minus_SNo (R2_xcoord x) :e R.
{ exact (real_minus_SNo (R2_xcoord x) Hx0R). }
claim HdxR : dx :e R.
{ exact (real_add_SNo (R2_xcoord p) Hp0R (minus_SNo (R2_xcoord x)) Hmx). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HaS : SNo a.
{ exact (SNo_abs_SNo dx HdxS). }
claim HdR : d :e R.
{ exact (distance_R2_in_R p x Hp Hx). }
claim HdS : SNo d.
{ exact (real_SNo d HdR). }
claim HrS : SNo r.
{ exact (real_SNo r HrR). }
claim Hle: a <= d.
{ exact (abs_dx_le_distance_R2 p x Hp Hx). }
claim Hdlt: d < r.
{ exact (RltE_lt d r Hdr). }
exact (SNoLeLt_tra a d r HaS HdS HrS Hle Hdlt).
Qed.

(** Helper: distance bound gives y coordinate abs bound **)
(** LATEX VERSION: If d(p,x) < r then abs(yp-yx) < r. **)
Theorem abs_ycoord_lt_of_distance_lt : forall p x r:set,
  p :e EuclidPlane ->
  x :e EuclidPlane ->
  r :e R ->
  Rlt (distance_R2 p x) r ->
  abs_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord x))) < r.
let p x r.
assume Hp: p :e EuclidPlane.
assume Hx: x :e EuclidPlane.
assume HrR: r :e R.
assume Hdr: Rlt (distance_R2 p x) r.
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord x)).
set a := abs_SNo dy.
set d := distance_R2 p x.
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hx1R : R2_ycoord x :e R.
{ exact (EuclidPlane_ycoord_in_R x Hx). }
claim Hmy : minus_SNo (R2_ycoord x) :e R.
{ exact (real_minus_SNo (R2_ycoord x) Hx1R). }
claim HdyR : dy :e R.
{ exact (real_add_SNo (R2_ycoord p) Hp1R (minus_SNo (R2_ycoord x)) Hmy). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim HaS : SNo a.
{ exact (SNo_abs_SNo dy HdyS). }
claim HdR : d :e R.
{ exact (distance_R2_in_R p x Hp Hx). }
claim HdS : SNo d.
{ exact (real_SNo d HdR). }
claim HrS : SNo r.
{ exact (real_SNo r HrR). }
claim Hle: a <= d.
{ exact (abs_dy_le_distance_R2 p x Hp Hx). }
claim Hdlt: d < r.
{ exact (RltE_lt d r Hdr). }
exact (SNoLeLt_tra a d r HaS HdS HrS Hle Hdlt).
Qed.

(** from §13 Example 4: distance from a point to itself is 0 **)
(** LATEX VERSION: d(p,p) = 0. **)
Theorem distance_R2_refl_0 : forall p:set, p :e EuclidPlane -> distance_R2 p p = 0.
let p. assume Hp.
claim Hp0R : R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim Hp1R : R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim Hp0S : SNo (R2_xcoord p).
{ exact (real_SNo (R2_xcoord p) Hp0R). }
claim Hp1S : SNo (R2_ycoord p).
{ exact (real_SNo (R2_ycoord p) Hp1R). }
claim Hdx : add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p)) = 0.
{ exact (add_SNo_minus_SNo_rinv (R2_xcoord p) Hp0S). }
claim Hdy : add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p)) = 0.
{ exact (add_SNo_minus_SNo_rinv (R2_ycoord p) Hp1S). }
claim Hdx2 : mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p)))
                     (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p))) = 0.
{ rewrite Hdx.
  exact (mul_SNo_zeroR 0 SNo_0). }
claim Hdy2 : mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p)))
                     (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p))) = 0.
{ rewrite Hdy.
  exact (mul_SNo_zeroR 0 SNo_0). }
claim Hsum : add_SNo (mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p)))
                              (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p))))
                     (mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p)))
                              (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p)))) = 0.
{ rewrite Hdx2.
  rewrite Hdy2.
  exact (add_SNo_0L 0 SNo_0). }
claim Hdef : distance_R2 p p =
  sqrt_SNo_nonneg
    (add_SNo
      (mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p)))
              (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord p))))
      (mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p)))
              (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord p))))).
{ reflexivity. }
rewrite Hdef.
rewrite Hsum.
rewrite sqrt_SNo_nonneg_0.
reflexivity.
Qed.

(** from §13 Example 4: symmetry of Euclidean distance in R^2 **)
(** LATEX VERSION: The distance function satisfies d(p,c)=d(c,p). **)
Theorem distance_R2_sym : forall p c:set, p :e EuclidPlane -> c :e EuclidPlane -> distance_R2 p c = distance_R2 c p.
let p c. assume Hp Hc.
(** Coordinate realness and SNo-ness **)
set xp := R2_xcoord p.
set yp := R2_ycoord p.
set xc := R2_xcoord c.
set yc := R2_ycoord c.
claim HxpR : xp :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim HypR : yp :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim HxcR : xc :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim HycR : yc :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim HxpS : SNo xp.
{ exact (real_SNo xp HxpR). }
claim HypS : SNo yp.
{ exact (real_SNo yp HypR). }
claim HxcS : SNo xc.
{ exact (real_SNo xc HxcR). }
claim HycS : SNo yc.
{ exact (real_SNo yc HycR). }
claim HmxpR : minus_SNo xp :e R.
{ exact (real_minus_SNo xp HxpR). }
claim HmypR : minus_SNo yp :e R.
{ exact (real_minus_SNo yp HypR). }
claim HmxcR : minus_SNo xc :e R.
{ exact (real_minus_SNo xc HxcR). }
claim HmycR : minus_SNo yc :e R.
{ exact (real_minus_SNo yc HycR). }
claim HmxpS : SNo (minus_SNo xp).
{ exact (real_SNo (minus_SNo xp) HmxpR). }
claim HmypS : SNo (minus_SNo yp).
{ exact (real_SNo (minus_SNo yp) HmypR). }
claim HmxcS : SNo (minus_SNo xc).
{ exact (real_SNo (minus_SNo xc) HmxcR). }
claim HmycS : SNo (minus_SNo yc).
{ exact (real_SNo (minus_SNo yc) HmycR). }

(** Show the swapped coordinate differences are negatives of the original ones **)
claim Hswapx : add_SNo xc (minus_SNo xp) = minus_SNo (add_SNo xp (minus_SNo xc)).
{ claim Hneg : minus_SNo (add_SNo xp (minus_SNo xc)) = add_SNo (minus_SNo xp) (minus_SNo (minus_SNo xc)).
  { exact (minus_add_SNo_distr xp (minus_SNo xc) HxpS HmxcS). }
  claim Hinv : minus_SNo (minus_SNo xc) = xc.
  { exact (minus_SNo_invol xc HxcS). }
  claim Hneg2 : minus_SNo (add_SNo xp (minus_SNo xc)) = add_SNo (minus_SNo xp) xc.
  { rewrite <- Hinv at 2.
    exact Hneg. }
  claim Hcom : add_SNo (minus_SNo xp) xc = add_SNo xc (minus_SNo xp).
  { exact (add_SNo_com (minus_SNo xp) xc HmxpS HxcS). }
  prove add_SNo xc (minus_SNo xp) = minus_SNo (add_SNo xp (minus_SNo xc)).
  rewrite <- Hcom.
  rewrite <- Hneg2.
  reflexivity. }

claim Hswapy : add_SNo yc (minus_SNo yp) = minus_SNo (add_SNo yp (minus_SNo yc)).
{ claim Hneg : minus_SNo (add_SNo yp (minus_SNo yc)) = add_SNo (minus_SNo yp) (minus_SNo (minus_SNo yc)).
  { exact (minus_add_SNo_distr yp (minus_SNo yc) HypS HmycS). }
  claim Hinv : minus_SNo (minus_SNo yc) = yc.
  { exact (minus_SNo_invol yc HycS). }
  claim Hneg2 : minus_SNo (add_SNo yp (minus_SNo yc)) = add_SNo (minus_SNo yp) yc.
  { rewrite <- Hinv at 2.
    exact Hneg. }
  claim Hcom : add_SNo (minus_SNo yp) yc = add_SNo yc (minus_SNo yp).
  { exact (add_SNo_com (minus_SNo yp) yc HmypS HycS). }
  prove add_SNo yc (minus_SNo yp) = minus_SNo (add_SNo yp (minus_SNo yc)).
  rewrite <- Hcom.
  rewrite <- Hneg2.
  reflexivity. }

(** SNo-ness of the original differences **)
claim HdxR : add_SNo xp (minus_SNo xc) :e R.
{ exact (real_add_SNo xp HxpR (minus_SNo xc) HmxcR). }
claim HdyR : add_SNo yp (minus_SNo yc) :e R.
{ exact (real_add_SNo yp HypR (minus_SNo yc) HmycR). }
claim HdxS : SNo (add_SNo xp (minus_SNo xc)).
{ exact (real_SNo (add_SNo xp (minus_SNo xc)) HdxR). }
claim HdyS : SNo (add_SNo yp (minus_SNo yc)).
{ exact (real_SNo (add_SNo yp (minus_SNo yc)) HdyR). }

(** Square terms are equal after swapping p and c **)
claim Hsqx :
  mul_SNo (add_SNo xc (minus_SNo xp)) (add_SNo xc (minus_SNo xp))
  = mul_SNo (add_SNo xp (minus_SNo xc)) (add_SNo xp (minus_SNo xc)).
{ rewrite Hswapx.
  rewrite (mul_SNo_minus_minus (add_SNo xp (minus_SNo xc)) (add_SNo xp (minus_SNo xc)) HdxS HdxS).
  reflexivity. }
claim Hsqy :
  mul_SNo (add_SNo yc (minus_SNo yp)) (add_SNo yc (minus_SNo yp))
  = mul_SNo (add_SNo yp (minus_SNo yc)) (add_SNo yp (minus_SNo yc)).
{ rewrite Hswapy.
  rewrite (mul_SNo_minus_minus (add_SNo yp (minus_SNo yc)) (add_SNo yp (minus_SNo yc)) HdyS HdyS).
  reflexivity. }

(** Expand both sides to the same sqrt expression **)
claim Hdefpc : distance_R2 p c =
  sqrt_SNo_nonneg
    (add_SNo
      (mul_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)))
              (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
      (mul_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))
              (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c))))).
{ reflexivity. }
claim Hdefcp : distance_R2 c p =
  sqrt_SNo_nonneg
    (add_SNo
      (mul_SNo (add_SNo (R2_xcoord c) (minus_SNo (R2_xcoord p)))
              (add_SNo (R2_xcoord c) (minus_SNo (R2_xcoord p))))
      (mul_SNo (add_SNo (R2_ycoord c) (minus_SNo (R2_ycoord p)))
              (add_SNo (R2_ycoord c) (minus_SNo (R2_ycoord p))))).
{ reflexivity. }
rewrite Hdefpc.
rewrite Hdefcp.
rewrite Hsqx.
rewrite Hsqy.
reflexivity.
Qed.

(** helper: nonnegative and nonzero implies positive **)
Theorem SNo_nonneg_ne0_pos : forall x:set,
  SNo x -> 0 <= x -> x <> 0 -> 0 < x.
let x.
assume HxS: SNo x.
assume H0lex: 0 <= x.
assume Hxne0: x <> 0.
apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (0 < x)).
- assume Hxlt0: x < 0.
  claim Hxle0: x <= 0.
  { exact (SNoLtLe x 0 Hxlt0). }
  claim H0lex': 0 <= x.
  { exact H0lex. }
  claim Heq0: x = 0.
  { exact (SNoLe_antisym x 0 HxS SNo_0 Hxle0 H0lex'). }
  exact (FalseE (Hxne0 Heq0) (0 < x)).
- assume Hx0: x = 0.
  exact (FalseE (Hxne0 Hx0) (0 < x)).
- assume H0ltx: 0 < x.
  exact H0ltx.
Qed.

(** helper: strict inequality is preserved by squaring for nonnegative numbers **)
Theorem SNoLt_sqr_nonneg : forall x y:set,
  SNo x -> SNo y -> 0 <= x -> 0 <= y -> x < y ->
  mul_SNo x x < mul_SNo y y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0lex: 0 <= x.
assume H0ley: 0 <= y.
assume Hxlt: x < y.
apply (xm (x = 0)).
- assume Hx0: x = 0.
  claim H0lty: 0 < y.
  { rewrite <- Hx0 at 1.
    exact Hxlt. }
  claim Hy2pos: 0 < mul_SNo y y.
  { exact (mul_SNo_pos_pos y y HyS HyS H0lty H0lty). }
  rewrite Hx0.
  rewrite (mul_SNo_zeroL 0 SNo_0).
  exact Hy2pos.
- assume Hxne0: x <> 0.
  claim H0ltx: 0 < x.
  { exact (SNo_nonneg_ne0_pos x HxS H0lex Hxne0). }
  claim H0lty: 0 < y.
  { exact (SNoLt_tra 0 x y SNo_0 HxS HyS H0ltx Hxlt). }
  exact (pos_mul_SNo_Lt2 x x y y HxS HxS HyS HyS H0ltx H0ltx Hxlt Hxlt).
Qed.

(** helper: for nonnegative numbers, an inequality on squares implies an inequality **)
Theorem SNo_nonneg_sqr_Le_imp_Le : forall x y:set,
  SNo x -> SNo y -> 0 <= x -> 0 <= y ->
  mul_SNo x x <= mul_SNo y y -> x <= y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0lex: 0 <= x.
assume H0ley: 0 <= y.
assume Hsqle: mul_SNo x x <= mul_SNo y y.
apply (SNoLt_trichotomy_or_impred y x HyS HxS (x <= y)).
- assume Hyltx: y < x.
  claim HysqLt: mul_SNo y y < mul_SNo x x.
  { exact (SNoLt_sqr_nonneg y x HyS HxS H0ley H0lex Hyltx). }
  claim Hbad: mul_SNo y y < mul_SNo y y.
  { exact (SNoLtLe_tra (mul_SNo y y) (mul_SNo x x) (mul_SNo y y)
            (SNo_mul_SNo y y HyS HyS) (SNo_mul_SNo x x HxS HxS) (SNo_mul_SNo y y HyS HyS)
            HysqLt Hsqle). }
  exact (FalseE ((SNoLt_irref (mul_SNo y y)) Hbad) (x <= y)).
- assume Hyx: y = x.
  rewrite Hyx.
  exact (SNoLe_ref x).
- assume Hxley: x < y.
  exact (SNoLtLe x y Hxley).
Qed.

(** helper: two-variable Cauchy-Schwarz inequality in squared form **)
Theorem CauchySchwarz2_sq : forall a b c d:set,
  SNo a -> SNo b -> SNo c -> SNo d ->
  mul_SNo (add_SNo (mul_SNo a c) (mul_SNo b d))
         (add_SNo (mul_SNo a c) (mul_SNo b d))
  <= mul_SNo (add_SNo (mul_SNo a a) (mul_SNo b b))
            (add_SNo (mul_SNo c c) (mul_SNo d d)).
let a b c d.
assume HaS: SNo a.
assume HbS: SNo b.
assume HcS: SNo c.
assume HdS: SNo d.
set ac := mul_SNo a c.
set bd := mul_SNo b d.
set ad := mul_SNo a d.
set bc := mul_SNo b c.
set lhs := mul_SNo (add_SNo ac bd) (add_SNo ac bd).
set rhs := mul_SNo (add_SNo (mul_SNo a a) (mul_SNo b b))
                   (add_SNo (mul_SNo c c) (mul_SNo d d)).
set diff := add_SNo ad (minus_SNo bc).
set diff2 := mul_SNo diff diff.

claim HacS: SNo ac.
{ exact (SNo_mul_SNo a c HaS HcS). }
claim HbdS: SNo bd.
{ exact (SNo_mul_SNo b d HbS HdS). }
claim HadS: SNo ad.
{ exact (SNo_mul_SNo a d HaS HdS). }
claim HbcS: SNo bc.
{ exact (SNo_mul_SNo b c HbS HcS). }
claim HdiffS: SNo diff.
{ exact (SNo_add_SNo ad (minus_SNo bc) HadS (SNo_minus_SNo bc HbcS)). }
claim Hdiff2S: SNo diff2.
{ exact (SNo_mul_SNo diff diff HdiffS HdiffS). }
claim Hdiff2NN: 0 <= diff2.
{ exact (SNo_sqr_nonneg diff HdiffS). }

claim Hrhs_eq: rhs = add_SNo lhs diff2.
{ (** This is a long algebraic rearrangement; reduce to explicit expansions first. **)
  claim HaaS: SNo (mul_SNo a a).
  { exact (SNo_mul_SNo a a HaS HaS). }
  claim HbbS: SNo (mul_SNo b b).
  { exact (SNo_mul_SNo b b HbS HbS). }
  claim HccS: SNo (mul_SNo c c).
  { exact (SNo_mul_SNo c c HcS HcS). }
  claim HddS: SNo (mul_SNo d d).
  { exact (SNo_mul_SNo d d HdS HdS). }

  claim HlhsDef: lhs = mul_SNo (add_SNo ac bd) (add_SNo ac bd).
  { reflexivity. }
  claim HdiffDef: diff = add_SNo ad (minus_SNo bc).
  { reflexivity. }
  claim Hdiff2Def: diff2 = mul_SNo diff diff.
  { reflexivity. }

  rewrite HlhsDef.
  rewrite Hdiff2Def.
  rewrite HdiffDef.

  rewrite (SNo_foil (mul_SNo a a) (mul_SNo b b) (mul_SNo c c) (mul_SNo d d) HaaS HbbS HccS HddS).
  rewrite (SNo_foil ac bd ac bd HacS HbdS HacS HbdS).
  rewrite (SNo_foil_mm ad bc ad bc HadS HbcS HadS HbcS).

  (** the remaining goal is a purely algebraic reassociation and cancellation step **)
  (** normalize the mixed products so that the cross terms are syntactically cancellable **)
  claim HabS: SNo (mul_SNo a b).
  { exact (SNo_mul_SNo a b HaS HbS). }
  claim HcdS: SNo (mul_SNo c d).
  { exact (SNo_mul_SNo c d HcS HdS). }
  claim HdcS: SNo (mul_SNo d c).
  { exact (SNo_mul_SNo d c HdS HcS). }
  claim Hdc_eq_cd: mul_SNo d c = mul_SNo c d.
  { exact (mul_SNo_com d c HdS HcS). }

  claim Hadbc_eq_acbd: mul_SNo ad bc = mul_SNo ac bd.
  { claim HadDef: ad = mul_SNo a d.
    { reflexivity. }
    claim HbcDef: bc = mul_SNo b c.
    { reflexivity. }
    claim HacDef: ac = mul_SNo a c.
    { reflexivity. }
    claim HbdDef: bd = mul_SNo b d.
    { reflexivity. }
    rewrite HadDef.
    rewrite HbcDef.
    rewrite HacDef.
    rewrite HbdDef.
    rewrite (mul_SNo_com_4_inner_mid a d b c HaS HdS HbS HcS).
    rewrite Hdc_eq_cd.
    rewrite <- (mul_SNo_com_4_inner_mid a c b d HaS HcS HbS HdS).
    reflexivity. }

  claim Hbcad_eq_bdac: mul_SNo bc ad = mul_SNo bd ac.
  { claim HadDef: ad = mul_SNo a d.
    { reflexivity. }
    claim HbcDef: bc = mul_SNo b c.
    { reflexivity. }
    claim HacDef: ac = mul_SNo a c.
    { reflexivity. }
    claim HbdDef: bd = mul_SNo b d.
    { reflexivity. }
    rewrite HadDef.
    rewrite HbcDef.
	    rewrite HacDef.
	    rewrite HbdDef.
	    rewrite (mul_SNo_com_4_inner_mid b c a d HbS HcS HaS HdS).
	    rewrite <- Hdc_eq_cd.
	    rewrite <- (mul_SNo_com_4_inner_mid b d a c HbS HdS HaS HcS).
	    reflexivity. }

	  rewrite Hadbc_eq_acbd.
	  rewrite Hbcad_eq_bdac.

	  (** rewrite the four square terms on the left to the corresponding (ac,ad,bc,bd) squares **)
	  rewrite (mul_SNo_com_4_inner_mid a a c c HaS HaS HcS HcS).
	  rewrite (mul_SNo_com_4_inner_mid a a d d HaS HaS HdS HdS).
	  rewrite (mul_SNo_com_4_inner_mid b b c c HbS HbS HcS HcS).
	  rewrite (mul_SNo_com_4_inner_mid b b d d HbS HbS HdS HdS).

	  (** pending: finish by associativity/commutativity and cancellation of z + -z **)
	  claim HacacS2: SNo (mul_SNo ac ac).
	  { exact (SNo_mul_SNo ac ac HacS HacS). }
	  claim HadadS2: SNo (mul_SNo ad ad).
	  { exact (SNo_mul_SNo ad ad HadS HadS). }
	  claim HbcbcS2: SNo (mul_SNo bc bc).
	  { exact (SNo_mul_SNo bc bc HbcS HbcS). }
	  claim HbdbdS2: SNo (mul_SNo bd bd).
	  { exact (SNo_mul_SNo bd bd HbdS HbdS). }
	  claim HacbdS2: SNo (mul_SNo ac bd).
	  { exact (SNo_mul_SNo ac bd HacS HbdS). }
	  claim HbdacS2: SNo (mul_SNo bd ac).
	  { exact (SNo_mul_SNo bd ac HbdS HacS). }
	  claim HmacbdS2: SNo (minus_SNo (mul_SNo ac bd)).
	  { exact (SNo_minus_SNo (mul_SNo ac bd) HacbdS2). }
	  claim HmbdacS2: SNo (minus_SNo (mul_SNo bd ac)).
	  { exact (SNo_minus_SNo (mul_SNo bd ac) HbdacS2). }

	  claim Hbdac_bdbdS: SNo (add_SNo (mul_SNo bd ac) (mul_SNo bd bd)).
	  { exact (SNo_add_SNo (mul_SNo bd ac) (mul_SNo bd bd) HbdacS2 HbdbdS2). }
	  claim Hmbdac_bcbcS: SNo (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc)).
	  { exact (SNo_add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc) HmbdacS2 HbcbcS2). }

	  (** reshape the right-hand side for cross-term cancellation **)
	  rewrite (add_SNo_com (mul_SNo ac bd) (add_SNo (mul_SNo bd ac) (mul_SNo bd bd)) HacbdS2 Hbdac_bdbdS).
	  rewrite (add_SNo_assoc (mul_SNo ac ac) (add_SNo (mul_SNo bd ac) (mul_SNo bd bd)) (mul_SNo ac bd) HacacS2 Hbdac_bdbdS HacbdS2).

	  claim HinnerR1S: SNo (add_SNo (minus_SNo (mul_SNo ac bd))
	                               (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))).
	  { exact (SNo_add_SNo (minus_SNo (mul_SNo ac bd))
	                       (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))
	                       HmacbdS2 Hmbdac_bcbcS). }
	  rewrite (add_SNo_com (mul_SNo ad ad)
	                       (add_SNo (minus_SNo (mul_SNo ac bd))
	                               (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc)))
	                       HadadS2 HinnerR1S).
	  rewrite <- (add_SNo_assoc (minus_SNo (mul_SNo ac bd))
	                            (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))
	                            (mul_SNo ad ad)
	                            HmacbdS2 Hmbdac_bcbcS HadadS2).

	  (** pending: apply cancellation lemmas and finish reassociation **)
	  claim Hw1S: SNo (add_SNo (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))
	                           (mul_SNo ad ad)).
	  { exact (SNo_add_SNo (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))
	                       (mul_SNo ad ad)
	                       Hmbdac_bcbcS HadadS2). }

	  rewrite <- (add_SNo_assoc (mul_SNo ac ac)
	                            (add_SNo (mul_SNo bd ac) (mul_SNo bd bd))
	                            (mul_SNo ac bd)
	                            HacacS2 Hbdac_bdbdS HacbdS2).
	  rewrite (add_SNo_minus_SNo_prop3 (mul_SNo ac ac)
	                                  (add_SNo (mul_SNo bd ac) (mul_SNo bd bd))
	                                  (mul_SNo ac bd)
	                                  (add_SNo (add_SNo (minus_SNo (mul_SNo bd ac)) (mul_SNo bc bc))
	                                           (mul_SNo ad ad))
	                                  HacacS2 Hbdac_bdbdS HacbdS2 Hw1S).

	  (** cancel bdac and finish reassociation **)
	  claim Hbcbc_adadS: SNo (add_SNo (mul_SNo bc bc) (mul_SNo ad ad)).
	  { exact (SNo_add_SNo (mul_SNo bc bc) (mul_SNo ad ad) HbcbcS2 HadadS2). }
	  rewrite <- (add_SNo_assoc (minus_SNo (mul_SNo bd ac))
	                            (mul_SNo bc bc)
	                            (mul_SNo ad ad)
	                            HmbdacS2 HbcbcS2 HadadS2).

	  rewrite (add_SNo_com_4_inner_mid (mul_SNo bd ac)
	                                   (mul_SNo bd bd)
	                                   (minus_SNo (mul_SNo bd ac))
	                                   (add_SNo (mul_SNo bc bc) (mul_SNo ad ad))
	                                   HbdacS2 HbdbdS2 HmbdacS2 Hbcbc_adadS).
	  rewrite (add_SNo_minus_SNo_rinv (mul_SNo bd ac) HbdacS2).
	  rewrite (add_SNo_0L (add_SNo (mul_SNo bd bd) (add_SNo (mul_SNo bc bc) (mul_SNo ad ad)))
	                      (SNo_add_SNo (mul_SNo bd bd)
	                                   (add_SNo (mul_SNo bc bc) (mul_SNo ad ad))
	                                   HbdbdS2 Hbcbc_adadS)).

	  rewrite (add_SNo_com (mul_SNo bc bc) (mul_SNo ad ad) HbcbcS2 HadadS2).
	  claim Hadad_bcbcS: SNo (add_SNo (mul_SNo ad ad) (mul_SNo bc bc)).
	  { exact (SNo_add_SNo (mul_SNo ad ad) (mul_SNo bc bc) HadadS2 HbcbcS2). }
	  rewrite (add_SNo_com (mul_SNo bd bd)
	                       (add_SNo (mul_SNo ad ad) (mul_SNo bc bc))
	                       HbdbdS2 Hadad_bcbcS).
	  rewrite <- (add_SNo_assoc (mul_SNo ad ad) (mul_SNo bc bc) (mul_SNo bd bd) HadadS2 HbcbcS2 HbdbdS2).
	  reflexivity. }

rewrite Hrhs_eq.
claim HlhsS: SNo lhs.
{ exact (SNo_mul_SNo (add_SNo ac bd) (add_SNo ac bd)
          (SNo_add_SNo ac bd HacS HbdS) (SNo_add_SNo ac bd HacS HbdS)). }
exact (SNoLe_add_nonneg_right lhs diff2 HlhsS Hdiff2S Hdiff2NN).
Qed.

(** helper: triangle inequality for distance_R2 in Rle form **)
(** LATEX VERSION: For points x,y,z in R^2, d(x,z) <= d(x,y) + d(y,z). **)
(** SUSPICIOUS THEOREM: This requires Minkowski style inequalities; it is not proved in this development yet. **)
(** helper: squared Minkowski inequality for distance_R2 **)
Theorem distance_R2_triangle_sqr_Le : forall x y z:set,
  x :e EuclidPlane -> y :e EuclidPlane -> z :e EuclidPlane ->
  mul_SNo (distance_R2 x z) (distance_R2 x z)
  <= mul_SNo (add_SNo (distance_R2 x y) (distance_R2 y z))
            (add_SNo (distance_R2 x y) (distance_R2 y z)).
let x y z.
assume Hx: x :e EuclidPlane.
assume Hy: y :e EuclidPlane.
assume Hz: z :e EuclidPlane.
(** Pending: implement Minkowski squared inequality using CauchySchwarz2_sq and coordinate algebra. **)
set dxy := distance_R2 x y.
set dyz := distance_R2 y z.
set dxz := distance_R2 x z.
set s := add_SNo dxy dyz.

(** coordinate differences **)
set dx_xy := add_SNo (R2_xcoord x) (minus_SNo (R2_xcoord y)).
set dy_xy := add_SNo (R2_ycoord x) (minus_SNo (R2_ycoord y)).
set dx_yz := add_SNo (R2_xcoord y) (minus_SNo (R2_xcoord z)).
set dy_yz := add_SNo (R2_ycoord y) (minus_SNo (R2_ycoord z)).
set dx_xz := add_SNo (R2_xcoord x) (minus_SNo (R2_xcoord z)).
set dy_xz := add_SNo (R2_ycoord x) (minus_SNo (R2_ycoord z)).

(** basic real and surreal facts **)
claim HdxyR: dxy :e R.
{ exact (distance_R2_in_R x y Hx Hy). }
claim HdyzR: dyz :e R.
{ exact (distance_R2_in_R y z Hy Hz). }
claim HdxzR: dxz :e R.
{ exact (distance_R2_in_R x z Hx Hz). }
claim HdxyS: SNo dxy.
{ exact (real_SNo dxy HdxyR). }
claim HdyzS: SNo dyz.
{ exact (real_SNo dyz HdyzR). }
claim HdxzS: SNo dxz.
{ exact (real_SNo dxz HdxzR). }

claim H0ledxy: 0 <= dxy.
{ exact (distance_R2_nonneg x y Hx Hy). }
claim H0ledyz: 0 <= dyz.
{ exact (distance_R2_nonneg y z Hy Hz). }
claim H0ledxz: 0 <= dxz.
{ exact (distance_R2_nonneg x z Hx Hz). }

claim Hx0R: R2_xcoord x :e R.
{ exact (EuclidPlane_xcoord_in_R x Hx). }
claim Hx1R: R2_ycoord x :e R.
{ exact (EuclidPlane_ycoord_in_R x Hx). }
claim Hy0R: R2_xcoord y :e R.
{ exact (EuclidPlane_xcoord_in_R y Hy). }
claim Hy1R: R2_ycoord y :e R.
{ exact (EuclidPlane_ycoord_in_R y Hy). }
claim Hz0R: R2_xcoord z :e R.
{ exact (EuclidPlane_xcoord_in_R z Hz). }
claim Hz1R: R2_ycoord z :e R.
{ exact (EuclidPlane_ycoord_in_R z Hz). }

claim Hdx_xyR: dx_xy :e R.
{ exact (real_add_SNo (R2_xcoord x) Hx0R (minus_SNo (R2_xcoord y)) (real_minus_SNo (R2_xcoord y) Hy0R)). }
claim Hdy_xyR: dy_xy :e R.
{ exact (real_add_SNo (R2_ycoord x) Hx1R (minus_SNo (R2_ycoord y)) (real_minus_SNo (R2_ycoord y) Hy1R)). }
claim Hdx_yzR: dx_yz :e R.
{ exact (real_add_SNo (R2_xcoord y) Hy0R (minus_SNo (R2_xcoord z)) (real_minus_SNo (R2_xcoord z) Hz0R)). }
claim Hdy_yzR: dy_yz :e R.
{ exact (real_add_SNo (R2_ycoord y) Hy1R (minus_SNo (R2_ycoord z)) (real_minus_SNo (R2_ycoord z) Hz1R)). }
claim Hdx_xzR: dx_xz :e R.
{ exact (real_add_SNo (R2_xcoord x) Hx0R (minus_SNo (R2_xcoord z)) (real_minus_SNo (R2_xcoord z) Hz0R)). }
claim Hdy_xzR: dy_xz :e R.
{ exact (real_add_SNo (R2_ycoord x) Hx1R (minus_SNo (R2_ycoord z)) (real_minus_SNo (R2_ycoord z) Hz1R)). }

claim Hdx_xyS: SNo dx_xy.
{ exact (real_SNo dx_xy Hdx_xyR). }
claim Hdy_xyS: SNo dy_xy.
{ exact (real_SNo dy_xy Hdy_xyR). }
claim Hdx_yzS: SNo dx_yz.
{ exact (real_SNo dx_yz Hdx_yzR). }
claim Hdy_yzS: SNo dy_yz.
{ exact (real_SNo dy_yz Hdy_yzR). }
claim Hdx_xzS: SNo dx_xz.
{ exact (real_SNo dx_xz Hdx_xzR). }
claim Hdy_xzS: SNo dy_xz.
{ exact (real_SNo dy_xz Hdy_xzR). }

(** decompose differences: (x-z) = (x-y) + (y-z) coordinatewise **)
claim Hdx_decomp: dx_xz = add_SNo dx_xy dx_yz.
{ (** (x0 - z0) = (x0 - y0) + (y0 - z0) by associativity and inverse laws **)
  prove dx_xz = add_SNo dx_xy dx_yz.
  claim Hx0S: SNo (R2_xcoord x).
  { exact (real_SNo (R2_xcoord x) Hx0R). }
  claim Hy0S: SNo (R2_xcoord y).
  { exact (real_SNo (R2_xcoord y) Hy0R). }
  claim Hz0S: SNo (R2_xcoord z).
  { exact (real_SNo (R2_xcoord z) Hz0R). }
  claim Hmy0S: SNo (minus_SNo (R2_xcoord y)).
  { exact (SNo_minus_SNo (R2_xcoord y) Hy0S). }
  claim Hmz0S: SNo (minus_SNo (R2_xcoord z)).
  { exact (SNo_minus_SNo (R2_xcoord z) Hz0S). }
  claim Hdx_xy_def: dx_xy = add_SNo (R2_xcoord x) (minus_SNo (R2_xcoord y)).
  { reflexivity. }
  claim Hdx_yz_def: dx_yz = add_SNo (R2_xcoord y) (minus_SNo (R2_xcoord z)).
  { reflexivity. }
  claim Hdx_xz_def: dx_xz = add_SNo (R2_xcoord x) (minus_SNo (R2_xcoord z)).
  { reflexivity. }
  rewrite Hdx_xz_def.
  rewrite Hdx_xy_def.
  rewrite Hdx_yz_def.
  rewrite <- (add_SNo_assoc (R2_xcoord x) (minus_SNo (R2_xcoord y))
          (add_SNo (R2_xcoord y) (minus_SNo (R2_xcoord z))) Hx0S Hmy0S
          (SNo_add_SNo (R2_xcoord y) (minus_SNo (R2_xcoord z)) Hy0S Hmz0S)).
  rewrite (add_SNo_assoc (minus_SNo (R2_xcoord y)) (R2_xcoord y) (minus_SNo (R2_xcoord z))
          Hmy0S Hy0S Hmz0S).
  rewrite (add_SNo_minus_SNo_linv (R2_xcoord y) Hy0S).
  rewrite (add_SNo_0L (minus_SNo (R2_xcoord z)) Hmz0S).
  reflexivity. }
claim Hdy_decomp: dy_xz = add_SNo dy_xy dy_yz.
{ (** (x1 - z1) = (x1 - y1) + (y1 - z1) **)
  prove dy_xz = add_SNo dy_xy dy_yz.
  claim Hx1S: SNo (R2_ycoord x).
  { exact (real_SNo (R2_ycoord x) Hx1R). }
  claim Hy1S: SNo (R2_ycoord y).
  { exact (real_SNo (R2_ycoord y) Hy1R). }
  claim Hz1S: SNo (R2_ycoord z).
  { exact (real_SNo (R2_ycoord z) Hz1R). }
  claim Hmy1S: SNo (minus_SNo (R2_ycoord y)).
  { exact (SNo_minus_SNo (R2_ycoord y) Hy1S). }
  claim Hmz1S: SNo (minus_SNo (R2_ycoord z)).
  { exact (SNo_minus_SNo (R2_ycoord z) Hz1S). }
  claim Hdy_xy_def: dy_xy = add_SNo (R2_ycoord x) (minus_SNo (R2_ycoord y)).
  { reflexivity. }
  claim Hdy_yz_def: dy_yz = add_SNo (R2_ycoord y) (minus_SNo (R2_ycoord z)).
  { reflexivity. }
  claim Hdy_xz_def: dy_xz = add_SNo (R2_ycoord x) (minus_SNo (R2_ycoord z)).
  { reflexivity. }
  rewrite Hdy_xz_def.
  rewrite Hdy_xy_def.
  rewrite Hdy_yz_def.
  rewrite <- (add_SNo_assoc (R2_ycoord x) (minus_SNo (R2_ycoord y))
          (add_SNo (R2_ycoord y) (minus_SNo (R2_ycoord z))) Hx1S Hmy1S
          (SNo_add_SNo (R2_ycoord y) (minus_SNo (R2_ycoord z)) Hy1S Hmz1S)).
  rewrite (add_SNo_assoc (minus_SNo (R2_ycoord y)) (R2_ycoord y) (minus_SNo (R2_ycoord z))
          Hmy1S Hy1S Hmz1S).
  rewrite (add_SNo_minus_SNo_linv (R2_ycoord y) Hy1S).
  rewrite (add_SNo_0L (minus_SNo (R2_ycoord z)) Hmz1S).
  reflexivity. }

(** rewrite squared distance for dxz, and expand the coordinate squares **)
rewrite (distance_R2_sqr x z Hx Hz).
	rewrite Hdx_decomp.
	rewrite Hdy_decomp.

	(** After expansion, the goal becomes a Minkowski inequality; keep it as a dedicated subgoal for now. **)
	set dx2_xy := mul_SNo dx_xy dx_xy.
	set dy2_xy := mul_SNo dy_xy dy_xy.
	set dx2_yz := mul_SNo dx_yz dx_yz.
	set dy2_yz := mul_SNo dy_yz dy_yz.
	set A := add_SNo dx2_xy dy2_xy.
	set B := add_SNo dx2_yz dy2_yz.
	set dot := add_SNo (mul_SNo dx_xy dx_yz) (mul_SNo dy_xy dy_yz).
	set prod := mul_SNo dxy dyz.

	claim Hdx2xyS: SNo dx2_xy.
	{ exact (SNo_mul_SNo dx_xy dx_xy Hdx_xyS Hdx_xyS). }
	claim Hdy2xyS: SNo dy2_xy.
	{ exact (SNo_mul_SNo dy_xy dy_xy Hdy_xyS Hdy_xyS). }
	claim Hdx2yzS: SNo dx2_yz.
	{ exact (SNo_mul_SNo dx_yz dx_yz Hdx_yzS Hdx_yzS). }
	claim Hdy2yzS: SNo dy2_yz.
	{ exact (SNo_mul_SNo dy_yz dy_yz Hdy_yzS Hdy_yzS). }
	claim HAS: SNo A.
	{ exact (SNo_add_SNo dx2_xy dy2_xy Hdx2xyS Hdy2xyS). }
	claim HBS: SNo B.
	{ exact (SNo_add_SNo dx2_yz dy2_yz Hdx2yzS Hdy2yzS). }
	claim HdotS: SNo dot.
	{ exact (SNo_add_SNo (mul_SNo dx_xy dx_yz) (mul_SNo dy_xy dy_yz)
	          (SNo_mul_SNo dx_xy dx_yz Hdx_xyS Hdx_yzS)
	          (SNo_mul_SNo dy_xy dy_yz Hdy_xyS Hdy_yzS)). }
	claim HprodS: SNo prod.
	{ exact (SNo_mul_SNo dxy dyz HdxyS HdyzS). }

	(** relate dxy squared and dyz squared to A and B **)
	claim Hdxy2: mul_SNo dxy dxy = A.
	{ claim HdxyDef: dxy = distance_R2 x y.
	  { reflexivity. }
	  rewrite HdxyDef.
	  rewrite (distance_R2_sqr x y Hx Hy).
	  reflexivity. }
	claim Hdyz2: mul_SNo dyz dyz = B.
	{ claim HdyzDef: dyz = distance_R2 y z.
	  { reflexivity. }
	  rewrite HdyzDef.
	  rewrite (distance_R2_sqr y z Hy Hz).
	  reflexivity. }

	(** prepare the key estimate: abs(dot) bounded by product of distances using Cauchy-Schwarz **)
	claim HabsdotS: SNo (abs_SNo dot).
	{ exact (SNo_abs_SNo dot HdotS). }
	claim HabsdotNN: 0 <= abs_SNo dot.
	{ exact (abs_SNo_nonneg dot HdotS). }
	claim HprodNN: 0 <= prod.
	{ exact (mul_SNo_nonneg_nonneg dxy dyz HdxyS HdyzS H0ledxy H0ledyz). }
	claim Hcs: mul_SNo dot dot <= mul_SNo A B.
	{ exact (CauchySchwarz2_sq dx_xy dy_xy dx_yz dy_yz Hdx_xyS Hdy_xyS Hdx_yzS Hdy_yzS). }
	claim Hprod2: mul_SNo prod prod = mul_SNo A B.
	{ (** square of a product equals product of squares **)
	  claim HprodDef: prod = mul_SNo dxy dyz.
	  { reflexivity. }
	  rewrite HprodDef at 1.
	  rewrite HprodDef at 2.
	  claim Hdxy_dyzS: SNo (mul_SNo dxy dyz).
	  { exact (SNo_mul_SNo dxy dyz HdxyS HdyzS). }
		  (** (dxy mul dyz) mul (dxy mul dyz) = dxy mul (dyz mul (dxy mul dyz)) **)
	  rewrite <- (mul_SNo_assoc dxy dyz (mul_SNo dxy dyz) HdxyS HdyzS Hdxy_dyzS).
		  (** dyz mul (dxy mul dyz) = (dyz mul dxy) mul dyz **)
	  rewrite (mul_SNo_assoc dyz dxy dyz HdyzS HdxyS HdyzS).
		  (** dyz mul dxy = dxy mul dyz **)
	  rewrite (mul_SNo_com dyz dxy HdyzS HdxyS).
		  (** dxy mul ((dxy mul dyz) mul dyz) = (dxy mul (dxy mul dyz)) mul dyz **)
	  rewrite (mul_SNo_assoc dxy (mul_SNo dxy dyz) dyz HdxyS Hdxy_dyzS HdyzS).
		  (** dxy mul (dxy mul dyz) = (dxy mul dxy) mul dyz **)
	  rewrite (mul_SNo_assoc dxy dxy dyz HdxyS HdxyS HdyzS).
		  (** ((dxy mul dxy) mul dyz) mul dyz = (dxy mul dxy) mul (dyz mul dyz) **)
	  rewrite <- (mul_SNo_assoc (mul_SNo dxy dxy) dyz dyz
	            (SNo_mul_SNo dxy dxy HdxyS HdxyS) HdyzS HdyzS).
	  rewrite Hdxy2.
	  rewrite Hdyz2.
	  reflexivity. }
	claim Habsdot2le: mul_SNo (abs_SNo dot) (abs_SNo dot) <= mul_SNo prod prod.
	{ rewrite (abs_SNo_sqr_eq dot HdotS).
	  rewrite Hprod2.
	  exact Hcs. }
	claim HabsdotLe: abs_SNo dot <= prod.
	{ exact (SNo_nonneg_sqr_Le_imp_Le (abs_SNo dot) prod HabsdotS HprodS HabsdotNN HprodNN Habsdot2le). }
	
	(** finish Minkowski-squared: expand both sides and bound the dot term by abs(dot) <= dxy mul dyz **)
	claim HdotLeAbs: dot <= abs_SNo dot.
	{ apply (xm (0 <= dot)).
	  - assume H0le: 0 <= dot.
	    rewrite (nonneg_abs_SNo dot H0le).
	    exact (SNoLe_ref dot).
	  - assume Hn0le: ~(0 <= dot).
	    rewrite (not_nonneg_abs_SNo dot Hn0le).
	    (** show dot < 0 **)
	    claim Hdotlt0: dot < 0.
	    { apply (SNoLt_trichotomy_or_impred dot 0 HdotS SNo_0 (dot < 0)).
	      - assume H: dot < 0.
	        exact H.
	      - assume Hdot0: dot = 0.
	        claim H0le0: 0 <= dot.
	        { rewrite Hdot0.
	          exact (SNoLe_ref 0). }
	        exact (FalseE (Hn0le H0le0) (dot < 0)).
	      - assume H0ltdot: 0 < dot.
	        claim H0ledot: 0 <= dot.
	        { exact (SNoLtLe 0 dot H0ltdot). }
	        exact (FalseE (Hn0le H0ledot) (dot < 0)).
	    }
	    claim Hdotle0: dot <= 0.
	    { exact (SNoLtLe dot 0 Hdotlt0). }
	    claim H0lemdot: 0 <= minus_SNo dot.
	    { claim Hle: minus_SNo 0 <= minus_SNo dot.
	      { exact (minus_SNo_Le_contra dot 0 HdotS SNo_0 Hdotle0). }
	      rewrite <- minus_SNo_0 at 1.
	      exact Hle. }
	    exact (SNoLe_tra dot 0 (minus_SNo dot) HdotS SNo_0 (SNo_minus_SNo dot HdotS) Hdotle0 H0lemdot).
	}
	claim HdotLeProd: dot <= prod.
	{ exact (SNoLe_tra dot (abs_SNo dot) prod HdotS HabsdotS HprodS HdotLeAbs HabsdotLe). }
	claim Hdot2Le: add_SNo dot dot <= add_SNo prod prod.
	{ exact (add_SNo_Le3 dot dot prod prod HdotS HdotS HprodS HprodS HdotLeProd HdotLeProd). }

	claim HrhsExp: mul_SNo s s = add_SNo (add_SNo A B) (add_SNo prod prod).
	{ claim HsDef: s = add_SNo dxy dyz.
	  { reflexivity. }
	  rewrite HsDef.
	  rewrite (SNo_foil dxy dyz dxy dyz HdxyS HdyzS HdxyS HdyzS).
	  rewrite Hdxy2.
	  rewrite Hdyz2.
	  rewrite (mul_SNo_com dyz dxy HdyzS HdxyS).
	  (** A + (prod + (prod + B)) = A + ((prod + prod) + B) **)
	  rewrite (add_SNo_assoc prod prod B HprodS HprodS HBS).
	  rewrite (add_SNo_com (add_SNo prod prod) B (SNo_add_SNo prod prod HprodS HprodS) HBS).
	  rewrite <- (add_SNo_assoc A B (add_SNo prod prod) HAS HBS (SNo_add_SNo prod prod HprodS HprodS)).
	  reflexivity. }

		(** pending: explicit expansion of dxz squared into A, B, and dot terms **)
		claim HlhsExp: mul_SNo dxz dxz = add_SNo (add_SNo A B) (add_SNo dot dot).
		{ claim HdxzDef2: dxz = distance_R2 x z.
		  { reflexivity. }
		  rewrite HdxzDef2.
		  rewrite (distance_R2_sqr x z Hx Hz).
		  rewrite Hdx_decomp.
			  rewrite Hdy_decomp.
			  rewrite (SNo_foil dx_xy dx_yz dx_xy dx_yz Hdx_xyS Hdx_yzS Hdx_xyS Hdx_yzS).
			  rewrite (SNo_foil dy_xy dy_yz dy_xy dy_yz Hdy_xyS Hdy_yzS Hdy_xyS Hdy_yzS).
			  (** normalize the commuted cross terms **)
			  rewrite (mul_SNo_com dx_yz dx_xy Hdx_yzS Hdx_xyS).
			  rewrite (mul_SNo_com dy_yz dy_xy Hdy_yzS Hdy_xyS).
			  (** fold squares and dot-product pieces back into the named abbreviations **)
			  claim Hdx2xyDef: dx2_xy = mul_SNo dx_xy dx_xy.
			  { reflexivity. }
			  claim Hdy2xyDef: dy2_xy = mul_SNo dy_xy dy_xy.
			  { reflexivity. }
			  claim Hdx2yzDef: dx2_yz = mul_SNo dx_yz dx_yz.
			  { reflexivity. }
			  claim Hdy2yzDef: dy2_yz = mul_SNo dy_yz dy_yz.
			  { reflexivity. }
			  claim HdotDef: dot = add_SNo (mul_SNo dx_xy dx_yz) (mul_SNo dy_xy dy_yz).
			  { reflexivity. }
			  claim HAdef: A = add_SNo dx2_xy dy2_xy.
			  { reflexivity. }
			  claim HBdef: B = add_SNo dx2_yz dy2_yz.
			  { reflexivity. }
			  rewrite <- Hdx2xyDef.
			  rewrite <- Hdy2xyDef.
			  rewrite <- Hdx2yzDef.
			  rewrite <- Hdy2yzDef.
			  rewrite <- HdotDef.
			  rewrite <- HdotDef.
			  rewrite <- HAdef.
			  rewrite <- HAdef.
			  rewrite <- HBdef.
			  rewrite <- HBdef.
			  (** the remaining goal is a purely algebraic reassociation/commutation step **)
			  claim Hdot2S: SNo (add_SNo dot dot).
			  { exact (SNo_add_SNo dot dot HdotS HdotS). }
			  (** expose the explicit right-associative shape on the RHS **)
			  rewrite <- (add_SNo_assoc A B (add_SNo dot dot) HAS HBS Hdot2S).
			  (** now commute/associate the fully expanded LHS into A + (B + (dot + dot)) **)
			  claim HcrossxS: SNo (mul_SNo dx_xy dx_yz).
			  { exact (SNo_mul_SNo dx_xy dx_yz Hdx_xyS Hdx_yzS). }
			  claim HcrossyS: SNo (mul_SNo dy_xy dy_yz).
			  { exact (SNo_mul_SNo dy_xy dy_yz Hdy_xyS Hdy_yzS). }
			  claim Hcrossx_plus_dx2yzS: SNo (add_SNo (mul_SNo dx_xy dx_yz) dx2_yz).
			  { exact (SNo_add_SNo (mul_SNo dx_xy dx_yz) dx2_yz HcrossxS Hdx2yzS). }
			  claim Hcrossy_plus_dy2yzS: SNo (add_SNo (mul_SNo dy_xy dy_yz) dy2_yz).
			  { exact (SNo_add_SNo (mul_SNo dy_xy dy_yz) dy2_yz HcrossyS Hdy2yzS). }
			  claim HrestxS: SNo (add_SNo (mul_SNo dx_xy dx_yz) (add_SNo (mul_SNo dx_xy dx_yz) dx2_yz)).
			  { exact (SNo_add_SNo (mul_SNo dx_xy dx_yz)
			                      (add_SNo (mul_SNo dx_xy dx_yz) dx2_yz)
			                      HcrossxS
			                      Hcrossx_plus_dx2yzS). }
			  claim HrestyS: SNo (add_SNo (mul_SNo dy_xy dy_yz) (add_SNo (mul_SNo dy_xy dy_yz) dy2_yz)).
			  { exact (SNo_add_SNo (mul_SNo dy_xy dy_yz)
			                      (add_SNo (mul_SNo dy_xy dy_yz) dy2_yz)
			                      HcrossyS
			                      Hcrossy_plus_dy2yzS). }

			  (** interleave the x and y expansions: (x0 + rx) + (y0 + ry) = (x0 + y0) + (rx + ry) **)
			  rewrite (add_SNo_com_4_inner_mid dx2_xy
			          (add_SNo (mul_SNo dx_xy dx_yz) (add_SNo (mul_SNo dx_xy dx_yz) dx2_yz))
			          dy2_xy
			          (add_SNo (mul_SNo dy_xy dy_yz) (add_SNo (mul_SNo dy_xy dy_yz) dy2_yz))
			          Hdx2xyS HrestxS Hdy2xyS HrestyS).
			  (** fold dx2_xy + dy2_xy back to A **)
			  rewrite <- HAdef.

			  (** process rx + ry similarly, extracting dot twice and B **)
			  rewrite (add_SNo_com_4_inner_mid (mul_SNo dx_xy dx_yz)
			          (add_SNo (mul_SNo dx_xy dx_yz) dx2_yz)
			          (mul_SNo dy_xy dy_yz)
			          (add_SNo (mul_SNo dy_xy dy_yz) dy2_yz)
			          HcrossxS Hcrossx_plus_dx2yzS HcrossyS Hcrossy_plus_dy2yzS).
			  rewrite <- HdotDef.

			  rewrite (add_SNo_com_4_inner_mid (mul_SNo dx_xy dx_yz) dx2_yz
			          (mul_SNo dy_xy dy_yz) dy2_yz
			          HcrossxS Hdx2yzS HcrossyS Hdy2yzS).
			  rewrite <- HdotDef.
			  rewrite <- HBdef.

			  (** dot + (dot + B) = B + (dot + dot) by assoc/com **)
			  rewrite (add_SNo_assoc dot dot B HdotS HdotS HBS).
			  rewrite (add_SNo_com (add_SNo dot dot) B Hdot2S HBS).
			  reflexivity. }

	claim HmainLe: add_SNo (add_SNo A B) (add_SNo dot dot) <= add_SNo (add_SNo A B) (add_SNo prod prod).
	{ exact (add_SNo_Le3 (add_SNo A B) (add_SNo dot dot) (add_SNo A B) (add_SNo prod prod)
	          (SNo_add_SNo A B HAS HBS) (SNo_add_SNo dot dot HdotS HdotS)
	          (SNo_add_SNo A B HAS HBS) (SNo_add_SNo prod prod HprodS HprodS)
	          (SNoLe_ref (add_SNo A B)) Hdot2Le). }
	claim HdxzDef: dxz = distance_R2 x z.
	{ reflexivity. }
	claim HdxyDef: dxy = distance_R2 x y.
	{ reflexivity. }
	claim HdyzDef: dyz = distance_R2 y z.
	{ reflexivity. }
	claim HsDef2: s = add_SNo dxy dyz.
	{ reflexivity. }

	(** reduce the main goal to HmainLe via the established expansions **)
	(** undo the earlier goal rewrites for dxz, then replay the clean dxz,s rewriting route **)
	rewrite <- Hdx_decomp.
	rewrite <- Hdy_decomp.
	rewrite <- (distance_R2_sqr x z Hx Hz).
	rewrite <- HdxzDef.

	rewrite <- HdxyDef.
	rewrite <- HdyzDef.
	rewrite <- HsDef2.

	rewrite HlhsExp.
	rewrite HrhsExp.
	exact HmainLe.
Qed.

Theorem distance_R2_triangle_Rle : forall x y z:set,
  x :e EuclidPlane -> y :e EuclidPlane -> z :e EuclidPlane ->
  Rle (distance_R2 x z) (add_SNo (distance_R2 x y) (distance_R2 y z)).
let x y z.
assume Hx: x :e EuclidPlane.
assume Hy: y :e EuclidPlane.
assume Hz: z :e EuclidPlane.
prove Rle (distance_R2 x z) (add_SNo (distance_R2 x y) (distance_R2 y z)).
(** Pending: Minkowski/Cauchy-Schwarz style inequalities for `sqrt_SNo_nonneg` and sums of squares. **)
apply (RleI (distance_R2 x z) (add_SNo (distance_R2 x y) (distance_R2 y z))).
- exact (distance_R2_in_R x z Hx Hz).
- (** sum is real **)
  claim HxyR: distance_R2 x y :e R.
  { exact (distance_R2_in_R x y Hx Hy). }
  claim HyzR: distance_R2 y z :e R.
  { exact (distance_R2_in_R y z Hy Hz). }
  exact (real_add_SNo (distance_R2 x y) HxyR (distance_R2 y z) HyzR).
	- (** show not(Rlt (d(x,y)+d(y,z)) d(x,z)) **)
	  assume Hlt: Rlt (add_SNo (distance_R2 x y) (distance_R2 y z)) (distance_R2 x z).
	  prove False.
	  (** unpack the strict inequality **)
	  set dxy := distance_R2 x y.
	  set dyz := distance_R2 y z.
	  set dxz := distance_R2 x z.
	  set s := add_SNo dxy dyz.
	  claim HpairR: s :e R /\ dxz :e R.
	  { exact (andEL (s :e R /\ dxz :e R) (s < dxz) Hlt). }
	  claim Hslt: s < dxz.
	  { exact (andER (s :e R /\ dxz :e R) (s < dxz) Hlt). }
	  claim HsumR: s :e R.
	  { exact (andEL (s :e R) (dxz :e R) HpairR). }
	  claim HxzR: dxz :e R.
	  { exact (andER (s :e R) (dxz :e R) HpairR). }
	  claim HdxyR: dxy :e R.
	  { exact (distance_R2_in_R x y Hx Hy). }
	  claim HdyzR: dyz :e R.
	  { exact (distance_R2_in_R y z Hy Hz). }
	  claim HdxzR: dxz :e R.
	  { exact HxzR. }
  claim HdxyS: SNo dxy.
  { exact (real_SNo dxy HdxyR). }
  claim HdyzS: SNo dyz.
  { exact (real_SNo dyz HdyzR). }
  claim HdxzS: SNo dxz.
  { exact (real_SNo dxz HdxzR). }
  claim HsS: SNo s.
  { exact (SNo_add_SNo dxy dyz HdxyS HdyzS). }
  claim H0ledxy: 0 <= dxy.
  { exact (distance_R2_nonneg x y Hx Hy). }
  claim H0ledyz: 0 <= dyz.
  { exact (distance_R2_nonneg y z Hy Hz). }
  claim H0les: 0 <= s.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact (add_SNo_Le3 0 0 dxy dyz SNo_0 SNo_0 HdxyS HdyzS H0ledxy H0ledyz). }
  claim H0ledxz: 0 <= dxz.
  { exact (distance_R2_nonneg x z Hx Hz). }

  (** square the assumed strict inequality s < dxz **)
  claim HsqLt: mul_SNo s s < mul_SNo dxz dxz.
  { exact (SNoLt_sqr_nonneg s dxz HsS HdxzS H0les H0ledxz Hslt). }

  (** show the reverse inequality dxz^2 <= s^2 by Minkowski in squared form **)
  claim HsqLe: mul_SNo dxz dxz <= mul_SNo s s.
  { exact (distance_R2_triangle_sqr_Le x y z Hx Hy Hz). }

  claim Hbad: mul_SNo s s < mul_SNo s s.
  { exact (SNoLtLe_tra (mul_SNo s s) (mul_SNo dxz dxz) (mul_SNo s s)
            (SNo_mul_SNo s s HsS HsS)
            (SNo_mul_SNo dxz dxz HdxzS HdxzS)
            (SNo_mul_SNo s s HsS HsS)
            HsqLt HsqLe). }
  exact (FalseE ((SNoLt_irref (mul_SNo s s)) Hbad) False).
Qed.

(** helper: distance_R2 = 0 implies equality of points **)
(** LATEX VERSION: In ℝ², d(p,c)=0 implies p=c. **)
Theorem distance_R2_eq0 : forall p c:set,
  p :e EuclidPlane -> c :e EuclidPlane ->
  distance_R2 p c = 0 -> p = c.
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
assume Hd0: distance_R2 p c = 0.
set xp := R2_xcoord p.
set yp := R2_ycoord p.
set xc := R2_xcoord c.
set yc := R2_ycoord c.
set dx := add_SNo xp (minus_SNo xc).
set dy := add_SNo yp (minus_SNo yc).
set dx2 := mul_SNo dx dx.
set dy2 := mul_SNo dy dy.
set sum := add_SNo dx2 dy2.

claim HxpR : xp :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim HypR : yp :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim HxcR : xc :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim HycR : yc :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim HmxR : minus_SNo xc :e R.
{ exact (real_minus_SNo xc HxcR). }
claim HmyR : minus_SNo yc :e R.
{ exact (real_minus_SNo yc HycR). }
claim HdxR : dx :e R.
{ exact (real_add_SNo xp HxpR (minus_SNo xc) HmxR). }
claim HdyR : dy :e R.
{ exact (real_add_SNo yp HypR (minus_SNo yc) HmyR). }
claim HdxS : SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS : SNo dy.
{ exact (real_SNo dy HdyR). }
claim Hdx2S : SNo dx2.
{ exact (SNo_mul_SNo dx dx HdxS HdxS). }
claim Hdy2S : SNo dy2.
{ exact (SNo_mul_SNo dy dy HdyS HdyS). }
claim HsumS : SNo sum.
{ exact (SNo_add_SNo dx2 dy2 Hdx2S Hdy2S). }

(** From d(p,c)=0 derive dx2+dy2=0 using the squared distance formula **)
claim Hd2eq0 : mul_SNo (distance_R2 p c) (distance_R2 p c) = 0.
{ rewrite Hd0.
  rewrite (mul_SNo_zeroL 0 SNo_0).
  reflexivity. }
claim Hsqr : mul_SNo (distance_R2 p c) (distance_R2 p c) = sum.
{ prove mul_SNo (distance_R2 p c) (distance_R2 p c) = sum.
  rewrite (distance_R2_sqr p c Hp Hc).
  reflexivity. }
claim Hsum0 : sum = 0.
{ rewrite <- Hsqr.
  exact Hd2eq0. }

(** Each square is nonnegative; compare each to the sum **)
claim Hdx2nonneg : 0 <= dx2.
{ exact (SNo_sqr_nonneg dx HdxS). }
claim Hdy2nonneg : 0 <= dy2.
{ exact (SNo_sqr_nonneg dy HdyS). }
claim Hdx2_le_sum : dx2 <= sum.
{ exact (SNoLe_add_nonneg_right dx2 dy2 Hdx2S Hdy2S Hdy2nonneg). }
claim Hdy2_le_sum : dy2 <= sum.
{ rewrite (add_SNo_com dx2 dy2 Hdx2S Hdy2S).
  exact (SNoLe_add_nonneg_right dy2 dx2 Hdy2S Hdx2S Hdx2nonneg). }
claim Hdx2le0 : dx2 <= 0.
{ prove dx2 <= 0.
  rewrite <- Hsum0 at 1.
  exact Hdx2_le_sum. }
claim Hdy2le0 : dy2 <= 0.
{ prove dy2 <= 0.
  rewrite <- Hsum0 at 1.
  exact Hdy2_le_sum. }
claim H0S : SNo 0.
{ exact SNo_0. }
claim Hdx2eq0 : dx2 = 0.
{ exact (SNoLe_antisym dx2 0 Hdx2S H0S Hdx2le0 Hdx2nonneg). }
claim Hdy2eq0 : dy2 = 0.
{ exact (SNoLe_antisym dy2 0 Hdy2S H0S Hdy2le0 Hdy2nonneg). }

(** A square is 0 iff the number is 0 **)
claim Hdx0 : dx = 0.
{ claim Hcases: dx = 0 \/ 0 < mul_SNo dx dx.
  { exact (SNo_zero_or_sqr_pos dx HdxS). }
  apply Hcases.
  - assume H0: dx = 0.
    exact H0.
  - assume Hpos: 0 < mul_SNo dx dx.
    claim Hbad: mul_SNo dx dx < mul_SNo dx dx.
    { claim Hdx2def: dx2 = mul_SNo dx dx.
      { reflexivity. }
      claim Hdx2zero: mul_SNo dx dx = 0.
      { rewrite <- Hdx2def at 1.
        exact Hdx2eq0. }
      claim Hpos0: 0 < 0.
      { rewrite <- Hdx2zero at 2.
        exact Hpos. }
      rewrite Hdx2zero at 2.
      rewrite Hdx2zero at 1.
      exact Hpos0. }
    exact (FalseE ((SNoLt_irref (mul_SNo dx dx)) Hbad) (dx = 0)). }
claim Hdy0 : dy = 0.
{ claim Hcases: dy = 0 \/ 0 < mul_SNo dy dy.
  { exact (SNo_zero_or_sqr_pos dy HdyS). }
  apply Hcases.
  - assume H0: dy = 0.
    exact H0.
  - assume Hpos: 0 < mul_SNo dy dy.
    claim Hbad: mul_SNo dy dy < mul_SNo dy dy.
    { claim Hdy2def: dy2 = mul_SNo dy dy.
      { reflexivity. }
      claim Hdy2zero: mul_SNo dy dy = 0.
      { rewrite <- Hdy2def at 1.
        exact Hdy2eq0. }
      claim Hpos0: 0 < 0.
      { rewrite <- Hdy2zero at 2.
        exact Hpos. }
      rewrite Hdy2zero at 2.
      rewrite Hdy2zero at 1.
      exact Hpos0. }
    exact (FalseE ((SNoLt_irref (mul_SNo dy dy)) Hbad) (dy = 0)). }

(** Convert dx=0,dy=0 into coordinate equalities xp=xc and yp=yc **)
claim HxpS : SNo xp.
{ exact (real_SNo xp HxpR). }
claim HypS : SNo yp.
{ exact (real_SNo yp HypR). }
claim HxcS : SNo xc.
{ exact (real_SNo xc HxcR). }
claim HycS : SNo yc.
{ exact (real_SNo yc HycR). }
claim HmxcS : SNo (minus_SNo xc).
{ exact (SNo_minus_SNo xc HxcS). }
claim HmycS : SNo (minus_SNo yc).
{ exact (SNo_minus_SNo yc HycS). }
claim Hxp_eq_xc : xp = xc.
{ claim HdxDef: dx = add_SNo xp (minus_SNo xc).
  { reflexivity. }
  claim Hdx0': add_SNo xp (minus_SNo xc) = 0.
  { rewrite <- HdxDef.
    exact Hdx0. }
  claim Hl_to_xc: add_SNo (add_SNo xp (minus_SNo xc)) xc = xc.
  { rewrite Hdx0' at 1.
    exact (add_SNo_0L xc HxcS). }
  claim Hl_to_xp: add_SNo (add_SNo xp (minus_SNo xc)) xc = xp.
  { rewrite <- (add_SNo_assoc xp (minus_SNo xc) xc HxpS HmxcS HxcS).
    rewrite (add_SNo_com (minus_SNo xc) xc HmxcS HxcS).
    rewrite (add_SNo_assoc xp xc (minus_SNo xc) HxpS HxcS HmxcS).
    rewrite (add_SNo_minus_R2 xp xc HxpS HxcS).
    reflexivity. }
  prove xp = xc.
  rewrite <- Hl_to_xp at 1.
  exact Hl_to_xc. }
claim Hyp_eq_yc : yp = yc.
{ claim HdyDef: dy = add_SNo yp (minus_SNo yc).
  { reflexivity. }
  claim Hdy0': add_SNo yp (minus_SNo yc) = 0.
  { rewrite <- HdyDef.
    exact Hdy0. }
  claim Hl_to_yc: add_SNo (add_SNo yp (minus_SNo yc)) yc = yc.
  { rewrite Hdy0' at 1.
    exact (add_SNo_0L yc HycS). }
  claim Hl_to_yp: add_SNo (add_SNo yp (minus_SNo yc)) yc = yp.
  { rewrite <- (add_SNo_assoc yp (minus_SNo yc) yc HypS HmycS HycS).
    rewrite (add_SNo_com (minus_SNo yc) yc HmycS HycS).
    rewrite (add_SNo_assoc yp yc (minus_SNo yc) HypS HycS HmycS).
    rewrite (add_SNo_minus_R2 yp yc HypS HycS).
    reflexivity. }
  prove yp = yc.
  rewrite <- Hl_to_yp at 1.
  exact Hl_to_yc. }

(** Conclude p=c by eta expansion on EuclidPlane **)
claim Hp_eta : (xp, yp) = p.
{ exact (EuclidPlane_eta p Hp). }
claim Hc_eta : (xc, yc) = c.
{ exact (EuclidPlane_eta c Hc). }
rewrite <- Hp_eta.
rewrite <- Hc_eta.
rewrite Hxp_eq_xc.
rewrite Hyp_eq_yc.
reflexivity.
Qed.

(** helper: distance_R2 is never negative **)
(** LATEX VERSION: d(p,c) is not < 0. **)
Theorem distance_R2_not_Rlt_0 : forall p c:set,
  p :e EuclidPlane -> c :e EuclidPlane -> ~(Rlt (distance_R2 p c) 0).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
assume Hlt: Rlt (distance_R2 p c) 0.
claim Hdlt0: distance_R2 p c < 0.
{ exact (RltE_lt (distance_R2 p c) 0 Hlt). }
claim HdR: distance_R2 p c :e R.
{ exact (distance_R2_in_R p c Hp Hc). }
claim HdS: SNo (distance_R2 p c).
{ exact (real_SNo (distance_R2 p c) HdR). }
claim Hd0le: 0 <= distance_R2 p c.
{ exact (distance_R2_nonneg p c Hp Hc). }
claim Hdle0: distance_R2 p c <= 0.
{ exact (SNoLtLe (distance_R2 p c) 0 Hdlt0). }
claim Hd0: distance_R2 p c = 0.
{ exact (SNoLe_antisym (distance_R2 p c) 0 HdS SNo_0 Hdle0 Hd0le). }
claim Hbad: 0 < 0.
{ rewrite <- Hd0 at 1.
  exact Hdlt0. }
exact ((SNoLt_irref 0) Hbad).
Qed.

(** from §13 Example 4: circular region basis elements in EuclidPlane **)
(** LATEX VERSION: Circular regions: sets of the form {p in R^2 | d(p,c) < r} with c in R^2 and 0<r. **)
Definition circular_regions : set :=
  {U :e Power EuclidPlane |
     exists c:set, exists r:set,
       c :e EuclidPlane /\ Rlt 0 r /\
       U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}}.

(** helper for §13 Example 4: introduce a circular region from center and radius **)
(** LATEX VERSION: If c∈R^2 and 0<r then {p∈R^2|d(p,c)<r} is a circular region. **)
Theorem circular_regionI : forall c r:set,
  c :e EuclidPlane ->
  Rlt 0 r ->
  {p :e EuclidPlane|Rlt (distance_R2 p c) r} :e circular_regions.
let c r. assume Hc Hr.
prove {p :e EuclidPlane|Rlt (distance_R2 p c) r} :e circular_regions.
claim HPow : {p :e EuclidPlane|Rlt (distance_R2 p c) r} :e Power EuclidPlane.
{ apply PowerI EuclidPlane {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
  let p. assume Hp.
  exact (SepE1 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c) r) p Hp). }
claim HPred :
  exists c0:set, exists r0:set,
    c0 :e EuclidPlane /\ Rlt 0 r0 /\
    {p :e EuclidPlane|Rlt (distance_R2 p c) r} = {p :e EuclidPlane|Rlt (distance_R2 p c0) r0}.
{ witness c. witness r.
  apply and3I.
  - exact Hc.
  - exact Hr.
  - reflexivity. }
exact (SepI (Power EuclidPlane)
            (fun U0 : set =>
              exists c0:set, exists r0:set,
                c0 :e EuclidPlane /\ Rlt 0 r0 /\
                U0 = {p :e EuclidPlane|Rlt (distance_R2 p c0) r0})
            {p :e EuclidPlane|Rlt (distance_R2 p c) r}
            HPow
            HPred).
Qed.

(** from §13 Example 4: rectangular region basis elements in EuclidPlane **)
(** LATEX VERSION: Rectangular regions: axis-parallel rectangles (a,b)x(c,d) in R^2 described by inequalities on coordinates. **)
Definition rectangular_regions : set :=
  {U :e Power EuclidPlane |
     exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
       U = {p :e EuclidPlane|
              exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}}.

(** helper for §13 Example 4: introduce a rectangular region from endpoints **)
(** LATEX VERSION: If a<b and c<d then {(x,y)∈R^2|a<x<b and c<y<d} is a rectangular region. **)
Theorem rectangular_regionI : forall a b c d:set,
  a :e R -> b :e R -> c :e R -> d :e R ->
  Rlt a b -> Rlt c d ->
  {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
    :e rectangular_regions.
let a b c d. assume Ha Hb Hc Hd Hab Hcd.
prove {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d} :e rectangular_regions.
claim HPow :
  {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
    :e Power EuclidPlane.
{ apply PowerI EuclidPlane {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
  let p. assume Hp.
  exact (SepE1 EuclidPlane
              (fun p0 : set => exists x y:set, p0 = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d)
              p
              Hp). }
claim HPred :
  exists a0 b0 c0 d0:set,
    a0 :e R /\ b0 :e R /\ c0 :e R /\ d0 :e R /\ Rlt a0 b0 /\ Rlt c0 d0 /\
      {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
        = {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a0 x /\ Rlt x b0 /\ Rlt c0 y /\ Rlt y d0}.
{ witness a. witness b. witness c. witness d.
  apply andI.
  - apply and6I.
    + exact Ha.
    + exact Hb.
    + exact Hc.
    + exact Hd.
    + exact Hab.
    + exact Hcd.
  - reflexivity. }
exact (SepI (Power EuclidPlane)
            (fun U0 : set =>
              exists a0 b0 c0 d0:set, a0 :e R /\ b0 :e R /\ c0 :e R /\ d0 :e R /\ Rlt a0 b0 /\ Rlt c0 d0 /\
                U0 = {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a0 x /\ Rlt x b0 /\ Rlt c0 y /\ Rlt y d0})
            {p :e EuclidPlane|exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
            HPow
            HPred).
Qed.

(** Helper: for any positive real d, some eps_N is smaller than d **)
Theorem exists_eps_lt_pos_Euclid : forall d:set, d :e R -> Rlt 0 d -> exists N :e omega, eps_ N < d.
let d.
assume HdR: d :e R.
assume Hdpos: Rlt 0 d.
claim HdS: SNo d.
{ exact (real_SNo d HdR). }
claim H0ltd: 0 < d.
{ exact (RltE_lt 0 d Hdpos). }
set invd := recip_SNo_pos d.
claim HinvdDef: invd = recip_SNo_pos d.
{ reflexivity. }
claim HinvdR: invd :e R.
{ rewrite HinvdDef.
  exact (real_recip_SNo_pos d HdR H0ltd). }
claim HinvdS: SNo invd.
{ exact (real_SNo invd HinvdR). }
claim Hinvdpos: 0 < invd.
{ exact (recip_SNo_pos_is_pos d HdS H0ltd). }
apply (real_E invd HinvdR (exists N :e omega, eps_ N < d)).
assume HinvS: SNo invd.
assume Hlev.
assume HinS.
assume Hlow.
assume Hup.
assume Huniq.
assume Happrox.
claim HexNlt: exists N :e omega, mul_SNo (eps_ N) invd < 1.
{ exact (SNoS_ordsucc_omega_bdd_eps_pos invd HinS Hinvdpos Hup). }
apply HexNlt.
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
claim HmulLt: mul_SNo (eps_ N) invd < 1.
{ exact (andER (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
witness N.
apply andI.
- exact HNomega.
- claim HepsS: SNo (eps_ N).
  { exact (SNo_eps_ N HNomega). }
  claim HepsLtDiv: eps_ N < div_SNo 1 invd.
  { exact (div_SNo_pos_LtR 1 invd (eps_ N) SNo_1 HinvS HepsS Hinvdpos HmulLt). }
  claim HdivEq: div_SNo 1 invd = d.
  { claim Hposcase: recip_SNo invd = recip_SNo_pos invd.
    { exact (recip_SNo_poscase invd Hinvdpos). }
    claim HrecipInv: recip_SNo_pos invd = d.
    { rewrite HinvdDef.
      exact (recip_SNo_pos_invol d HdS H0ltd). }
    claim HdivDef: div_SNo 1 invd = mul_SNo 1 (recip_SNo invd).
    { reflexivity. }
    rewrite HdivDef.
    rewrite Hposcase.
    rewrite HrecipInv.
    exact (mul_SNo_oneL d HdS). }
  rewrite <- HdivEq.
  exact HepsLtDiv.
Qed.

(** Helper: choose a single eps below two positive reals **)
(** LATEX VERSION: Given two positive real numbers, there is a positive eps radius smaller than both. **)
Theorem exists_eps_lt_two_pos_Euclid : forall a b:set,
  a :e R -> b :e R ->
  Rlt 0 a -> Rlt 0 b ->
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Ha0: Rlt 0 a.
assume Hb0: Rlt 0 b.
claim Hex1: exists N1 :e omega, eps_ N1 < a.
{ exact (exists_eps_lt_pos_Euclid a HaR Ha0). }
apply Hex1.
let N1. assume HN1pair.
claim HN1o: N1 :e omega.
{ exact (andEL (N1 :e omega) (eps_ N1 < a) HN1pair). }
claim Heps1lt_a: eps_ N1 < a.
{ exact (andER (N1 :e omega) (eps_ N1 < a) HN1pair). }
claim Heps1R: eps_ N1 :e R.
{ exact (SNoS_omega_real (eps_ N1) (SNo_eps_SNoS_omega N1 HN1o)). }
claim Heps1Rlt: Rlt (eps_ N1) a.
{ exact (RltI (eps_ N1) a Heps1R HaR Heps1lt_a). }

claim Hex2: exists N2 :e omega, eps_ N2 < b.
{ exact (exists_eps_lt_pos_Euclid b HbR Hb0). }
apply Hex2.
let N2. assume HN2pair.
claim HN2o: N2 :e omega.
{ exact (andEL (N2 :e omega) (eps_ N2 < b) HN2pair). }
claim Heps2lt_b: eps_ N2 < b.
{ exact (andER (N2 :e omega) (eps_ N2 < b) HN2pair). }
claim Heps2R: eps_ N2 :e R.
{ exact (SNoS_omega_real (eps_ N2) (SNo_eps_SNoS_omega N2 HN2o)). }
claim Heps2Rlt: Rlt (eps_ N2) b.
{ exact (RltI (eps_ N2) b Heps2R HbR Heps2lt_b). }

(** choose an index N above both N1 and N2 by trichotomy, then take eps_N **)
claim Hord1: ordinal N1.
{ exact (nat_p_ordinal N1 (omega_nat_p N1 HN1o)). }
claim Hord2: ordinal N2.
{ exact (nat_p_ordinal N2 (omega_nat_p N2 HN2o)). }
apply (ordinal_trichotomy_or_impred N1 N2 Hord1 Hord2
  (exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b)).
- assume H12: N1 :e N2.
  set N := ordsucc N2.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N2 HN2o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN2in: N2 :e N.
  { exact (ordsuccI2 N2). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI1 N2 N1 H12). }
  claim HepsNlt2: r3 < eps_ N2.
  { exact (SNo_eps_decr N HNo N2 HN2in). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt2Rlt: Rlt r3 (eps_ N2).
  { exact (RltI r3 (eps_ N2) Hr3R Heps2R HepsNlt2). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  witness r3.
  apply and4I.
  - exact Hr3R.
  - exact Hr3pos.
  - exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - exact (Rlt_tra r3 (eps_ N2) b HepsNlt2Rlt Heps2Rlt).
- assume Heq: N1 = N2.
  set N := ordsucc N1.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N1 HN1o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI2 N1). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  witness r3.
  apply and4I.
  - exact Hr3R.
  - exact Hr3pos.
  - exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - claim Heps1Rltb: Rlt (eps_ N1) b.
    { prove Rlt (eps_ N1) b.
      rewrite Heq at 1.
      exact Heps2Rlt. }
    exact (Rlt_tra r3 (eps_ N1) b HepsNlt1Rlt Heps1Rltb).
- assume H21: N2 :e N1.
  set N := ordsucc N1.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N1 HN1o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI2 N1). }
  claim HN2in: N2 :e N.
  { exact (ordsuccI1 N1 N2 H21). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt2: r3 < eps_ N2.
  { exact (SNo_eps_decr N HNo N2 HN2in). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  claim HepsNlt2Rlt: Rlt r3 (eps_ N2).
  { exact (RltI r3 (eps_ N2) Hr3R Heps2R HepsNlt2). }
  witness r3.
  apply and4I.
  - exact Hr3R.
  - exact Hr3pos.
  - exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - exact (Rlt_tra r3 (eps_ N2) b HepsNlt2Rlt Heps2Rlt).
Qed.

(** Helper: choose a single eps below four positive reals **)
(** LATEX VERSION: Given finitely many positive reals, there is a positive eps radius smaller than all of them. **)
Theorem exists_eps_lt_four_pos_Euclid : forall a b c d:set,
  a :e R -> b :e R -> c :e R -> d :e R ->
  Rlt 0 a -> Rlt 0 b -> Rlt 0 c -> Rlt 0 d ->
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b /\ Rlt r3 c /\ Rlt r3 d.
let a b c d.
assume HaR HbR HcR HdR.
assume Ha0 Hb0 Hc0 Hd0.
claim Hexab: exists r:set, r :e R /\ Rlt 0 r /\ Rlt r a /\ Rlt r b.
{ exact (exists_eps_lt_two_pos_Euclid a b HaR HbR Ha0 Hb0). }
apply Hexab.
let r12. assume Hr12.
claim Hr12b: Rlt r12 b.
{ exact (andER ((r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a) (Rlt r12 b) Hr12). }
claim Hr12left: (r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a.
{ exact (andEL ((r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a) (Rlt r12 b) Hr12). }
claim Hr12a: Rlt r12 a.
{ exact (andER (r12 :e R /\ Rlt 0 r12) (Rlt r12 a) Hr12left). }
claim Hr12pair: r12 :e R /\ Rlt 0 r12.
{ exact (andEL (r12 :e R /\ Rlt 0 r12) (Rlt r12 a) Hr12left). }
claim Hr12R: r12 :e R.
{ exact (andEL (r12 :e R) (Rlt 0 r12) Hr12pair). }
claim Hr12pos: Rlt 0 r12.
{ exact (andER (r12 :e R) (Rlt 0 r12) Hr12pair). }

claim Hexcd: exists r:set, r :e R /\ Rlt 0 r /\ Rlt r c /\ Rlt r d.
{ exact (exists_eps_lt_two_pos_Euclid c d HcR HdR Hc0 Hd0). }
apply Hexcd.
let r34. assume Hr34.
claim Hr34d: Rlt r34 d.
{ exact (andER ((r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c) (Rlt r34 d) Hr34). }
claim Hr34left: (r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c.
{ exact (andEL ((r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c) (Rlt r34 d) Hr34). }
claim Hr34c: Rlt r34 c.
{ exact (andER (r34 :e R /\ Rlt 0 r34) (Rlt r34 c) Hr34left). }
claim Hr34pair: r34 :e R /\ Rlt 0 r34.
{ exact (andEL (r34 :e R /\ Rlt 0 r34) (Rlt r34 c) Hr34left). }
claim Hr34R: r34 :e R.
{ exact (andEL (r34 :e R) (Rlt 0 r34) Hr34pair). }
claim Hr34pos: Rlt 0 r34.
{ exact (andER (r34 :e R) (Rlt 0 r34) Hr34pair). }

claim Hex: exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 r12 /\ Rlt r3 r34.
{ exact (exists_eps_lt_two_pos_Euclid r12 r34 Hr12R Hr34R Hr12pos Hr34pos). }
apply Hex.
let r3. assume Hr3.
claim Hr3lt34: Rlt r3 r34.
{ exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12) (Rlt r3 r34) Hr3). }
claim Hr3left: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12.
{ exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12) (Rlt r3 r34) Hr3). }
claim Hr3lt12: Rlt r3 r12.
{ exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 r12) Hr3left). }
claim Hr3pair: r3 :e R /\ Rlt 0 r3.
{ exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 r12) Hr3left). }
claim Hr3R: r3 :e R.
{ exact (andEL (r3 :e R) (Rlt 0 r3) Hr3pair). }
claim Hr3pos: Rlt 0 r3.
{ exact (andER (r3 :e R) (Rlt 0 r3) Hr3pair). }
witness r3.
apply and6I.
- exact Hr3R.
- exact Hr3pos.
- exact (Rlt_tra r3 r12 a Hr3lt12 Hr12a).
- exact (Rlt_tra r3 r12 b Hr3lt12 Hr12b).
- exact (Rlt_tra r3 r34 c Hr3lt34 Hr34c).
- exact (Rlt_tra r3 r34 d Hr3lt34 Hr34d).
Qed.

(** Helper: if a <= b and b < c then a < c **)
Theorem Rle_Rlt_tra_Euclid : forall a b c:set, Rle a b -> Rlt b c -> Rlt a c.
let a b c.
assume Hab: Rle a b.
assume Hbc: Rlt b c.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HcR: c :e R.
{ exact (RltE_right b c Hbc). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (Rlt a c)).
- assume Hablt: a < b.
  claim HabRlt: Rlt a b.
  { exact (RltI a b HaR HbR Hablt). }
  exact (Rlt_tra a b c HabRlt Hbc).
- assume Habeq: a = b.
  rewrite Habeq.
  exact Hbc.
- assume Hbalt: b < a.
  claim HbaRlt: Rlt b a.
  { exact (RltI b a HbR HaR Hbalt). }
  claim Hnlt: ~(Rlt b a).
  { exact (RleE_nlt a b Hab). }
  claim Hfalse: False.
  { exact (Hnlt HbaRlt). }
  apply FalseE.
  exact Hfalse.
Qed.

(** helper for §13 Example 4: two-ball refinement around a point **)
(** LATEX VERSION: If x lies in two open balls B(c1,r1) and B(c2,r2), then there is a smaller ball B(x,r3) contained in their intersection. **)
(** SUSPICIOUS THEOREM: The intended proof needs a triangle inequality for distance_R2 and monotonicity style estimates for sqrt and squares; those are not yet available here, so this lemma is currently admitted. **)
(** NOTE: An automated proof attempt at this admit timed out. **)
Theorem ball_refine_two_balls :
  forall x c1 c2 r1 r2:set,
    x :e EuclidPlane ->
    c1 :e EuclidPlane ->
    c2 :e EuclidPlane ->
    Rlt 0 r1 ->
    Rlt 0 r2 ->
    Rlt (distance_R2 x c1) r1 ->
    Rlt (distance_R2 x c2) r2 ->
    exists r3:set,
      Rlt 0 r3 /\
      (forall p:set,
        p :e EuclidPlane ->
        Rlt (distance_R2 p x) r3 ->
        Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2).
let x c1 c2 r1 r2.
assume Hx: x :e EuclidPlane.
assume Hc1: c1 :e EuclidPlane.
assume Hc2: c2 :e EuclidPlane.
assume Hr1: Rlt 0 r1.
assume Hr2: Rlt 0 r2.
assume Hx1: Rlt (distance_R2 x c1) r1.
assume Hx2: Rlt (distance_R2 x c2) r2.
set d1 := distance_R2 x c1.
set d2 := distance_R2 x c2.
claim Hd1R: d1 :e R.
{ exact (distance_R2_in_R x c1 Hx Hc1). }
claim Hd2R: d2 :e R.
{ exact (distance_R2_in_R x c2 Hx Hc2). }
claim Hr1R: r1 :e R.
{ exact (RltE_right 0 r1 Hr1). }
claim Hr2R: r2 :e R.
{ exact (RltE_right 0 r2 Hr2). }
claim Hd1S: SNo d1.
{ exact (real_SNo d1 Hd1R). }
claim Hd2S: SNo d2.
{ exact (real_SNo d2 Hd2R). }
claim Hr1S: SNo r1.
{ exact (real_SNo r1 Hr1R). }
claim Hr2S: SNo r2.
{ exact (real_SNo r2 Hr2R). }

set m1 := add_SNo r1 (minus_SNo d1).
set m2 := add_SNo r2 (minus_SNo d2).
claim Hm1R: m1 :e R.
{ exact (real_add_SNo r1 Hr1R (minus_SNo d1) (real_minus_SNo d1 Hd1R)). }
claim Hm2R: m2 :e R.
{ exact (real_add_SNo r2 Hr2R (minus_SNo d2) (real_minus_SNo d2 Hd2R)). }
claim Hm1S: SNo m1.
{ exact (real_SNo m1 Hm1R). }
claim Hm2S: SNo m2.
{ exact (real_SNo m2 Hm2R). }

(** positivity of margins from strict inequalities d(x,ci) < ri **)
claim Hd1lt: d1 < r1.
{ exact (RltE_lt d1 r1 Hx1). }
claim Hd2lt: d2 < r2.
{ exact (RltE_lt d2 r2 Hx2). }
claim Hm1posS: 0 < m1.
{ exact (SNoLt_minus_pos d1 r1 Hd1S Hr1S Hd1lt). }
claim Hm2posS: 0 < m2.
{ exact (SNoLt_minus_pos d2 r2 Hd2S Hr2S Hd2lt). }
claim Hm1pos: Rlt 0 m1.
{ exact (RltI 0 m1 real_0 Hm1R Hm1posS). }
claim Hm2pos: Rlt 0 m2.
{ exact (RltI 0 m2 real_0 Hm2R Hm2posS). }

(** choose r3 smaller than both positive margins **)
apply (exists_eps_lt_two_pos_Euclid m1 m2 Hm1R Hm2R Hm1pos Hm2pos).
let r3. assume Hr3core.
claim Hr3Left1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1.
{ exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) (Rlt r3 m2) Hr3core). }
claim Hr3m2: Rlt r3 m2.
{ exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) (Rlt r3 m2) Hr3core). }
claim Hr3pair: r3 :e R /\ Rlt 0 r3.
{ exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 m1) Hr3Left1). }
claim Hr3m1: Rlt r3 m1.
{ exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 m1) Hr3Left1). }
claim Hr3R: r3 :e R.
{ exact (andEL (r3 :e R) (Rlt 0 r3) Hr3pair). }
claim Hr3pos: Rlt 0 r3.
{ exact (andER (r3 :e R) (Rlt 0 r3) Hr3pair). }

witness r3.
apply andI.
- exact Hr3pos.
- let p. assume Hp: p :e EuclidPlane.
  assume Hpx: Rlt (distance_R2 p x) r3.
  prove Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2.
  apply andI.
  * (** first ball around c1 **)
    set dpx := distance_R2 p x.
    claim HdpxR: dpx :e R.
    { exact (distance_R2_in_R p x Hp Hx). }
    claim HdpxS: SNo dpx.
    { exact (real_SNo dpx HdpxR). }
    claim Hr3S: SNo r3.
    { exact (real_SNo r3 Hr3R). }
    claim Hpxlt: dpx < r3.
    { exact (RltE_lt dpx r3 Hpx). }
    claim Hdpxm1: Rlt dpx m1.
    { exact (Rlt_tra dpx r3 m1 Hpx Hr3m1). }
    claim Hdpxm1lt: dpx < m1.
    { exact (RltE_lt dpx m1 Hdpxm1). }
    claim HsumLt: Rlt (add_SNo dpx d1) r1.
    { prove Rlt (add_SNo dpx d1) r1.
      claim HsumS: SNo (add_SNo d1 dpx).
      { exact (real_SNo (add_SNo d1 dpx) (real_add_SNo d1 Hd1R dpx HdpxR)). }
      claim HsumS2: SNo (add_SNo dpx d1).
      { exact (real_SNo (add_SNo dpx d1) (real_add_SNo dpx HdpxR d1 Hd1R)). }
      claim HtmpS: add_SNo d1 dpx < add_SNo d1 m1.
      { exact (add_SNo_Lt2 d1 dpx m1 Hd1S HdpxS Hm1S Hdpxm1lt). }
      claim HtmpR: Rlt (add_SNo d1 dpx) (add_SNo d1 m1).
      { exact (RltI (add_SNo d1 dpx) (add_SNo d1 m1)
                    (real_add_SNo d1 Hd1R dpx HdpxR)
                    (real_add_SNo d1 Hd1R m1 Hm1R)
                    HtmpS). }
      claim Heq: add_SNo d1 m1 = r1.
      { prove add_SNo d1 m1 = r1.
        claim Hmd1S: SNo (minus_SNo d1).
        { exact (SNo_minus_SNo d1 Hd1S). }
        claim Hassoc1: add_SNo d1 (add_SNo r1 (minus_SNo d1)) = add_SNo (add_SNo d1 r1) (minus_SNo d1).
        { exact (add_SNo_assoc d1 r1 (minus_SNo d1) Hd1S Hr1S Hmd1S). }
        claim Hcom1: add_SNo d1 r1 = add_SNo r1 d1.
        { exact (add_SNo_com d1 r1 Hd1S Hr1S). }
        claim Hassoc2: add_SNo (add_SNo r1 d1) (minus_SNo d1) = add_SNo r1 (add_SNo d1 (minus_SNo d1)).
        { symmetry.
          exact (add_SNo_assoc r1 d1 (minus_SNo d1) Hr1S Hd1S Hmd1S). }
        claim Hinv: add_SNo d1 (minus_SNo d1) = 0.
        { exact (add_SNo_minus_SNo_rinv d1 Hd1S). }
        prove add_SNo d1 m1 = r1.
        claim Hm1Def: m1 = add_SNo r1 (minus_SNo d1).
        { reflexivity. }
        rewrite Hm1Def.
        rewrite Hassoc1.
        rewrite Hcom1.
        rewrite Hassoc2.
        rewrite Hinv.
        exact (add_SNo_0R r1 Hr1S). }
      rewrite (add_SNo_com dpx d1 HdpxS Hd1S) at 1.
      rewrite <- Heq.
      exact HtmpR. }
    claim Htri: Rle (distance_R2 p c1) (add_SNo dpx d1).
    { exact (distance_R2_triangle_Rle p x c1 Hp Hx Hc1). }
    exact (Rle_Rlt_tra_Euclid (distance_R2 p c1) (add_SNo dpx d1) r1 Htri HsumLt).
  * (** second ball around c2 **)
    set dpx := distance_R2 p x.
    claim HdpxR: dpx :e R.
    { exact (distance_R2_in_R p x Hp Hx). }
    claim HdpxS: SNo dpx.
    { exact (real_SNo dpx HdpxR). }
    claim Hdpxm2: Rlt dpx m2.
    { exact (Rlt_tra dpx r3 m2 Hpx Hr3m2). }
    claim Hdpxm2lt: dpx < m2.
    { exact (RltE_lt dpx m2 Hdpxm2). }
    claim HsumLt: Rlt (add_SNo dpx d2) r2.
    { prove Rlt (add_SNo dpx d2) r2.
      claim HtmpS: add_SNo d2 dpx < add_SNo d2 m2.
      { exact (add_SNo_Lt2 d2 dpx m2 Hd2S HdpxS Hm2S Hdpxm2lt). }
      claim HtmpR: Rlt (add_SNo d2 dpx) (add_SNo d2 m2).
      { exact (RltI (add_SNo d2 dpx) (add_SNo d2 m2)
                    (real_add_SNo d2 Hd2R dpx HdpxR)
                    (real_add_SNo d2 Hd2R m2 Hm2R)
                    HtmpS). }
      claim Heq: add_SNo d2 m2 = r2.
      { prove add_SNo d2 m2 = r2.
        claim Hmd2S: SNo (minus_SNo d2).
        { exact (SNo_minus_SNo d2 Hd2S). }
        claim Hassoc1: add_SNo d2 (add_SNo r2 (minus_SNo d2)) = add_SNo (add_SNo d2 r2) (minus_SNo d2).
        { exact (add_SNo_assoc d2 r2 (minus_SNo d2) Hd2S Hr2S Hmd2S). }
        claim Hcom1: add_SNo d2 r2 = add_SNo r2 d2.
        { exact (add_SNo_com d2 r2 Hd2S Hr2S). }
        claim Hassoc2: add_SNo (add_SNo r2 d2) (minus_SNo d2) = add_SNo r2 (add_SNo d2 (minus_SNo d2)).
        { symmetry.
          exact (add_SNo_assoc r2 d2 (minus_SNo d2) Hr2S Hd2S Hmd2S). }
        claim Hinv: add_SNo d2 (minus_SNo d2) = 0.
        { exact (add_SNo_minus_SNo_rinv d2 Hd2S). }
        prove add_SNo d2 m2 = r2.
        claim Hm2Def: m2 = add_SNo r2 (minus_SNo d2).
        { reflexivity. }
        rewrite Hm2Def.
        rewrite Hassoc1.
        rewrite Hcom1.
        rewrite Hassoc2.
        rewrite Hinv.
        exact (add_SNo_0R r2 Hr2S). }
      rewrite (add_SNo_com dpx d2 HdpxS Hd2S) at 1.
      rewrite <- Heq.
      exact HtmpR. }
    claim Htri: Rle (distance_R2 p c2) (add_SNo dpx d2).
    { exact (distance_R2_triangle_Rle p x c2 Hp Hx Hc2). }
    exact (Rle_Rlt_tra_Euclid (distance_R2 p c2) (add_SNo dpx d2) r2 Htri HsumLt).
Qed.

(** helper for §13 Example 4: from two-sided bounds to an abs bound **)
(** LATEX VERSION: If y-r < x < y+r and r>0 then |x-y| < r. **)
Theorem abs_diff_lt_of_between : forall x y r:set,
  x :e R ->
  y :e R ->
  r :e R ->
  Rlt 0 r ->
  Rlt (add_SNo y (minus_SNo r)) x ->
  Rlt x (add_SNo y r) ->
  abs_SNo (add_SNo x (minus_SNo y)) < r.
let x y r.
assume HxR: x :e R.
assume HyR: y :e R.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
assume Hlo: Rlt (add_SNo y (minus_SNo r)) x.
assume Hhi: Rlt x (add_SNo y r).
set t := add_SNo x (minus_SNo y).
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HtS: SNo t.
{ exact (SNo_add_SNo x (minus_SNo y) HxS (SNo_minus_SNo y HyS)). }
claim HrposS: 0 < r.
{ exact (RltE_lt 0 r Hrpos). }
claim HhiLt: x < add_SNo y r.
{ exact (RltE_lt x (add_SNo y r) Hhi). }
claim Hx_lt_ry: x < add_SNo r y.
{ rewrite <- (add_SNo_com y r HyS HrS).
  exact HhiLt. }
claim Ht_lt_r: t < r.
{ exact (add_SNo_minus_Lt1b x y r HxS HyS HrS Hx_lt_ry). }
claim HloLt: add_SNo y (minus_SNo r) < x.
{ exact (RltE_lt (add_SNo y (minus_SNo r)) x Hlo). }
claim Hyr_lt_x: y < add_SNo x r.
{ exact (add_SNo_minus_Lt1 y r x HyS HrS HxS HloLt). }
claim Hy_lt_rx: y < add_SNo r x.
{ rewrite <- (add_SNo_com x r HxS HrS).
  exact Hyr_lt_x. }
claim Hy_minus_x_lt_r: add_SNo y (minus_SNo x) < r.
{ exact (add_SNo_minus_Lt1b y x r HyS HxS HrS Hy_lt_rx). }
claim HmtEq: minus_SNo t = add_SNo y (minus_SNo x).
{ prove minus_SNo t = add_SNo y (minus_SNo x).
  claim HtDef: t = add_SNo x (minus_SNo y).
  { reflexivity. }
  rewrite HtDef at 1.
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim Hneg0: minus_SNo (add_SNo x (minus_SNo y))
               = add_SNo (minus_SNo x) (minus_SNo (minus_SNo y)).
  { exact (minus_add_SNo_distr x (minus_SNo y) HxS HmyS). }
  rewrite Hneg0 at 1.
  rewrite (minus_SNo_invol y HyS).
  claim Hcom: add_SNo (minus_SNo x) y = add_SNo y (minus_SNo x).
  { exact (add_SNo_com (minus_SNo x) y (SNo_minus_SNo x HxS) HyS). }
  rewrite Hcom.
  reflexivity. }
apply (xm (0 <= t)).
- assume H0let: 0 <= t.
  rewrite (nonneg_abs_SNo t H0let) at 1.
  exact Ht_lt_r.
- assume Hn0let: ~(0 <= t).
  rewrite (not_nonneg_abs_SNo t Hn0let) at 1.
  rewrite HmtEq at 1.
  exact Hy_minus_x_lt_r.
Qed.

(** helper for §13 Example 4: distance bounded by sum of coordinate absolute differences **)
(** LATEX VERSION: In R2, d(p,c) is at most |xp-xc| plus |yp-yc|. **)
Theorem distance_R2_le_absdx_plus_absdy : forall p c:set,
  p :e EuclidPlane ->
  c :e EuclidPlane ->
  distance_R2 p c
  <= add_SNo (abs_SNo (add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c))))
            (abs_SNo (add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)))).
let p c.
assume Hp: p :e EuclidPlane.
assume Hc: c :e EuclidPlane.
set dx := add_SNo (R2_xcoord p) (minus_SNo (R2_xcoord c)).
set dy := add_SNo (R2_ycoord p) (minus_SNo (R2_ycoord c)).
set ax := abs_SNo dx.
set ay := abs_SNo dy.
set s := add_SNo ax ay.
set d := distance_R2 p c.
claim HpxR: R2_xcoord p :e R.
{ exact (EuclidPlane_xcoord_in_R p Hp). }
claim HpyR: R2_ycoord p :e R.
{ exact (EuclidPlane_ycoord_in_R p Hp). }
claim HcxR: R2_xcoord c :e R.
{ exact (EuclidPlane_xcoord_in_R c Hc). }
claim HcyR: R2_ycoord c :e R.
{ exact (EuclidPlane_ycoord_in_R c Hc). }
claim HmxR: minus_SNo (R2_xcoord c) :e R.
{ exact (real_minus_SNo (R2_xcoord c) HcxR). }
claim HmyR: minus_SNo (R2_ycoord c) :e R.
{ exact (real_minus_SNo (R2_ycoord c) HcyR). }
claim HdxR: dx :e R.
{ exact (real_add_SNo (R2_xcoord p) HpxR (minus_SNo (R2_xcoord c)) HmxR). }
claim HdyR: dy :e R.
{ exact (real_add_SNo (R2_ycoord p) HpyR (minus_SNo (R2_ycoord c)) HmyR). }
claim HdxS: SNo dx.
{ exact (real_SNo dx HdxR). }
claim HdyS: SNo dy.
{ exact (real_SNo dy HdyR). }
claim HaxS: SNo ax.
{ exact (SNo_abs_SNo dx HdxS). }
claim HayS: SNo ay.
{ exact (SNo_abs_SNo dy HdyS). }
claim HdR: d :e R.
{ exact (distance_R2_in_R p c Hp Hc). }
claim HdS: SNo d.
{ exact (real_SNo d HdR). }
claim HsS: SNo s.
{ exact (SNo_add_SNo ax ay HaxS HayS). }
claim HaxNN: 0 <= ax.
{ exact (abs_SNo_nonneg dx HdxS). }
claim HayNN: 0 <= ay.
{ exact (abs_SNo_nonneg dy HdyS). }
claim HdNN: 0 <= d.
{ exact (distance_R2_nonneg p c Hp Hc). }
claim HsNN: 0 <= s.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact (add_SNo_Le3 0 0 ax ay SNo_0 SNo_0 HaxS HayS HaxNN HayNN). }

(** square the claimed inequality using the squared distance formula **)
set ax2 := mul_SNo ax ax.
set ay2 := mul_SNo ay ay.
set d2 := mul_SNo d d.
set s2 := mul_SNo s s.
claim Hax2S: SNo ax2.
{ exact (SNo_mul_SNo ax ax HaxS HaxS). }
claim Hay2S: SNo ay2.
{ exact (SNo_mul_SNo ay ay HayS HayS). }
claim Hd2S: SNo d2.
{ exact (SNo_mul_SNo d d HdS HdS). }
claim Hs2S: SNo s2.
{ exact (SNo_mul_SNo s s HsS HsS). }

claim Hd2Eq: d2 = add_SNo ax2 ay2.
{ prove d2 = add_SNo ax2 ay2.
  claim Hd2Def: d2 = mul_SNo (distance_R2 p c) (distance_R2 p c).
  { reflexivity. }
  rewrite Hd2Def at 1.
  claim Hdsqr: mul_SNo (distance_R2 p c) (distance_R2 p c)
               = add_SNo (mul_SNo dx dx) (mul_SNo dy dy).
  { exact (distance_R2_sqr p c Hp Hc). }
  rewrite Hdsqr.
  rewrite <- (abs_SNo_sqr_eq dx HdxS) at 1.
  rewrite <- (abs_SNo_sqr_eq dy HdyS) at 1.
  reflexivity. }

claim Hs2Eq: s2 = add_SNo ax2 (add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2)).
{ prove s2 = add_SNo ax2 (add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2)).
  rewrite <- (SNo_foil ax ay ax ay HaxS HayS HaxS HayS).
  reflexivity. }

claim Hm1S: SNo (mul_SNo ax ay).
{ exact (SNo_mul_SNo ax ay HaxS HayS). }
claim Hm2S: SNo (mul_SNo ay ax).
{ exact (SNo_mul_SNo ay ax HayS HaxS). }
claim Hm1NN: 0 <= mul_SNo ax ay.
{ exact (mul_SNo_nonneg_nonneg ax ay HaxS HayS HaxNN HayNN). }
claim Hm2NN: 0 <= mul_SNo ay ax.
{ exact (mul_SNo_nonneg_nonneg ay ax HayS HaxS HayNN HaxNN). }

claim Hay2_le_m2ay2: ay2 <= add_SNo (mul_SNo ay ax) ay2.
{ claim H0le_m2: 0 <= mul_SNo ay ax.
  { exact Hm2NN. }
  claim Htmp: add_SNo 0 ay2 <= add_SNo (mul_SNo ay ax) ay2.
  { exact (add_SNo_Le1 0 ay2 (mul_SNo ay ax) SNo_0 Hay2S Hm2S H0le_m2). }
	  rewrite <- (add_SNo_0L ay2 Hay2S) at 1.
  exact Htmp. }

claim Hm2ay2_le_m1m2ay2: add_SNo (mul_SNo ay ax) ay2 <= add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2).
{ claim H0le_m1: 0 <= mul_SNo ax ay.
  { exact Hm1NN. }
  claim Htmp: add_SNo 0 (add_SNo (mul_SNo ay ax) ay2)
              <= add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2).
  { exact (add_SNo_Le1 0 (add_SNo (mul_SNo ay ax) ay2) (mul_SNo ax ay)
                      SNo_0 (SNo_add_SNo (mul_SNo ay ax) ay2 Hm2S Hay2S) Hm1S H0le_m1). }
	  rewrite <- (add_SNo_0L (add_SNo (mul_SNo ay ax) ay2) (SNo_add_SNo (mul_SNo ay ax) ay2 Hm2S Hay2S)) at 1.
  exact Htmp. }

claim Hay2_le_tail: ay2 <= add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2).
{ exact (SNoLe_tra ay2 (add_SNo (mul_SNo ay ax) ay2)
                 (add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2))
                 Hay2S
                 (SNo_add_SNo (mul_SNo ay ax) ay2 Hm2S Hay2S)
                 (SNo_add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2) Hm1S
                              (SNo_add_SNo (mul_SNo ay ax) ay2 Hm2S Hay2S))
                 Hay2_le_m2ay2
                 Hm2ay2_le_m1m2ay2). }

claim Hd2Le_s2: d2 <= s2.
{ rewrite Hd2Eq.
  rewrite Hs2Eq.
  exact (add_SNo_Le2 ax2 ay2 (add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2))
                   Hax2S Hay2S
                   (SNo_add_SNo (mul_SNo ax ay) (add_SNo (mul_SNo ay ax) ay2) Hm1S
                                (SNo_add_SNo (mul_SNo ay ax) ay2 Hm2S Hay2S))
                   Hay2_le_tail). }

(** conclude by monotonicity of sqrt via nonneg-squares **)
apply (SNo_nonneg_sqr_Le_imp_Le d s HdS HsS HdNN HsNN).
claim Hd2Def: d2 = mul_SNo d d.
{ reflexivity. }
claim Hs2Def: s2 = mul_SNo s s.
{ reflexivity. }
rewrite <- Hd2Def.
rewrite <- Hs2Def.
exact Hd2Le_s2.
Qed.

(** helper for §13 Example 4: rectangle inside a ball around a center **)
(** LATEX VERSION: Every point x in a ball B(c,r0) has a rectangular neighborhood contained in B(c,r0). **)
Theorem rectangle_inside_ball :
  forall x c r0:set,
    x :e EuclidPlane ->
    c :e EuclidPlane ->
    Rlt 0 r0 ->
    Rlt (distance_R2 x c) r0 ->
    exists r :e rectangular_regions,
      x :e r /\ r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
let x c r0.
assume Hx: x :e EuclidPlane.
assume Hc: c :e EuclidPlane.
assume Hr0: Rlt 0 r0.
assume Hxc: Rlt (distance_R2 x c) r0.
set x0 := R2_xcoord x.
set y0 := R2_ycoord x.
set dxc := distance_R2 x c.
claim Hr0R: r0 :e R.
{ exact (RltE_right 0 r0 Hr0). }
claim HdxcR: dxc :e R.
{ exact (distance_R2_in_R x c Hx Hc). }
claim Hr0S: SNo r0.
{ exact (real_SNo r0 Hr0R). }
claim HdxcS: SNo dxc.
{ exact (real_SNo dxc HdxcR). }
set diff := add_SNo r0 (minus_SNo dxc).
claim HdiffR: diff :e R.
{ exact (real_add_SNo r0 Hr0R (minus_SNo dxc) (real_minus_SNo dxc HdxcR)). }
claim HdiffPos: Rlt 0 diff.
{ exact (Rlt_0_diff_of_lt dxc r0 Hxc). }

(** choose eps = eps_N with eps < r0 - d(x,c) **)
claim HexN: exists N :e omega, eps_ N < diff.
{ exact (exists_eps_lt_pos_Euclid diff HdiffR HdiffPos). }
apply HexN.
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (eps_ N < diff) HNpair). }
claim HepsLtDiffS: eps_ N < diff.
{ exact (andER (N :e omega) (eps_ N < diff) HNpair). }
set eps := eps_ N.
claim HepsR: eps :e R.
{ exact (SNoS_omega_real eps (SNo_eps_SNoS_omega N HNomega)). }
claim HepsS: SNo eps.
{ exact (real_SNo eps HepsR). }

(** show d(x,c) + eps < r0 **)
claim HsumLtS: add_SNo dxc eps < r0.
{ claim HdiffS: SNo diff.
  { exact (real_SNo diff HdiffR). }
  claim HepsLtR: Rlt eps diff.
  { exact (RltI eps diff HepsR HdiffR HepsLtDiffS). }
  claim HepsLt: eps < diff.
  { exact (RltE_lt eps diff HepsLtR). }
  claim Hdxc_eps_lt: add_SNo dxc eps < add_SNo dxc diff.
  { exact (add_SNo_Lt2 dxc eps diff HdxcS HepsS HdiffS HepsLt). }
  claim HdxcDiffEq: add_SNo dxc diff = r0.
  { prove add_SNo dxc diff = r0.
    rewrite (add_SNo_assoc dxc r0 (minus_SNo dxc) HdxcS Hr0S (SNo_minus_SNo dxc HdxcS)).
    rewrite (add_SNo_com dxc r0 HdxcS Hr0S).
    rewrite <- (add_SNo_assoc r0 dxc (minus_SNo dxc) Hr0S HdxcS (SNo_minus_SNo dxc HdxcS)).
    rewrite (add_SNo_minus_SNo_rinv dxc HdxcS).
    exact (add_SNo_0R r0 Hr0S). }
  rewrite <- HdxcDiffEq.
  exact Hdxc_eps_lt. }
claim HsumLt: Rlt (add_SNo dxc eps) r0.
{ claim HsumR: add_SNo dxc eps :e R.
  { exact (real_add_SNo dxc HdxcR eps HepsR). }
  exact (RltI (add_SNo dxc eps) r0 HsumR Hr0R HsumLtS). }

(** take a smaller rectangle radius r3 with r3 + r3 = eps **)
claim HsuccOmega: ordsucc N :e omega.
{ exact (omega_ordsucc N HNomega). }
set r3 := eps_ (ordsucc N).
claim Hr3R: r3 :e R.
{ exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
claim Hr3S: SNo r3.
{ exact (real_SNo r3 Hr3R). }
claim Hr3PosS: 0 < r3.
{ exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
claim Hr3Pos: Rlt 0 r3.
{ exact (RltI 0 r3 real_0 Hr3R Hr3PosS). }
claim HNnat: nat_p N.
{ exact (omega_nat_p N HNomega). }
claim Hr3Half: add_SNo r3 r3 = eps.
{ exact (eps_ordsucc_half_add N HNnat). }

(** define the rectangle around x with margin r3 **)
set a := add_SNo x0 (minus_SNo r3).
set b := add_SNo x0 r3.
set c1 := add_SNo y0 (minus_SNo r3).
set d1 := add_SNo y0 r3.
set Rect := {p :e EuclidPlane|exists x1 y1:set, p = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b /\ Rlt c1 y1 /\ Rlt y1 d1}.

claim Hx0R: x0 :e R.
{ exact (EuclidPlane_xcoord_in_R x Hx). }
claim Hy0R: y0 :e R.
{ exact (EuclidPlane_ycoord_in_R x Hx). }
claim Hx0S: SNo x0.
{ exact (real_SNo x0 Hx0R). }
claim Hy0S: SNo y0.
{ exact (real_SNo y0 Hy0R). }
claim HaR: a :e R.
{ exact (real_add_SNo x0 Hx0R (minus_SNo r3) (real_minus_SNo r3 Hr3R)). }
claim HbR: b :e R.
{ exact (real_add_SNo x0 Hx0R r3 Hr3R). }
claim Hc1R: c1 :e R.
{ exact (real_add_SNo y0 Hy0R (minus_SNo r3) (real_minus_SNo r3 Hr3R)). }
claim Hd1R: d1 :e R.
{ exact (real_add_SNo y0 Hy0R r3 Hr3R). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hc1S: SNo c1.
{ exact (real_SNo c1 Hc1R). }
claim Hd1S: SNo d1.
{ exact (real_SNo d1 Hd1R). }

claim Hm_r3_lt_0: minus_SNo r3 < 0.
{ rewrite <- minus_SNo_0.
  exact (minus_SNo_Lt_contra 0 r3 SNo_0 Hr3S Hr3PosS). }
claim Hm_r3S: SNo (minus_SNo r3).
{ exact (SNo_minus_SNo r3 Hr3S). }
claim Hm_r3_lt_r3: minus_SNo r3 < r3.
{ exact (SNoLt_tra (minus_SNo r3) 0 r3 Hm_r3S SNo_0 Hr3S Hm_r3_lt_0 Hr3PosS). }

claim HabSlt: a < b.
{ claim Htmp: add_SNo x0 (minus_SNo r3) < add_SNo x0 r3.
  { exact (add_SNo_Lt2 x0 (minus_SNo r3) r3 Hx0S Hm_r3S Hr3S Hm_r3_lt_r3). }
  exact Htmp. }
claim HcdSlt: c1 < d1.
{ claim Htmp: add_SNo y0 (minus_SNo r3) < add_SNo y0 r3.
  { exact (add_SNo_Lt2 y0 (minus_SNo r3) r3 Hy0S Hm_r3S Hr3S Hm_r3_lt_r3). }
  exact Htmp. }
claim HabRlt: Rlt a b.
{ exact (RltI a b HaR HbR HabSlt). }
claim HcdRlt: Rlt c1 d1.
{ exact (RltI c1 d1 Hc1R Hd1R HcdSlt). }

claim HRect: Rect :e rectangular_regions.
{ exact (rectangular_regionI a b c1 d1 HaR HbR Hc1R Hd1R HabRlt HcdRlt). }

claim Hx_in_Rect: x :e Rect.
{ rewrite <- (EuclidPlane_eta x Hx) at 1.
  claim HxyE: (x0,y0) :e EuclidPlane.
  { exact (tuple_2_setprod_by_pair_Sigma R R x0 y0 Hx0R Hy0R). }
  apply (SepI EuclidPlane
              (fun p0 : set => exists x1 y1:set,
                 p0 = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b /\ Rlt c1 y1 /\ Rlt y1 d1)
              (x0,y0)
              HxyE).
  witness x0. witness y0.
  claim Hax0: Rlt a x0.
  { claim Hx0plus0: add_SNo x0 0 = x0.
    { exact (add_SNo_0R x0 Hx0S). }
    claim Hax0S': add_SNo x0 (minus_SNo r3) < add_SNo x0 0.
    { exact (add_SNo_Lt2 x0 (minus_SNo r3) 0 Hx0S Hm_r3S SNo_0 Hm_r3_lt_0). }
    claim Hax0Eq: add_SNo x0 (minus_SNo r3) = a.
    { reflexivity. }
    claim Hax0S: a < x0.
    { rewrite <- Hax0Eq.
      rewrite <- Hx0plus0 at 2.
      exact Hax0S'. }
    rewrite <- Hax0Eq at 1.
    exact (RltI (add_SNo x0 (minus_SNo r3)) x0 HaR Hx0R Hax0S). }
  claim Hx0b: Rlt x0 b.
  { claim Hx0bS: x0 < add_SNo x0 r3.
    { exact (add_SNo_eps_Lt x0 Hx0S (ordsucc N) HsuccOmega). }
    exact (RltI x0 b Hx0R HbR Hx0bS). }
  claim Hcy0: Rlt c1 y0.
  { claim Hy0plus0: add_SNo y0 0 = y0.
    { exact (add_SNo_0R y0 Hy0S). }
    claim Hcy0S': add_SNo y0 (minus_SNo r3) < add_SNo y0 0.
    { exact (add_SNo_Lt2 y0 (minus_SNo r3) 0 Hy0S Hm_r3S SNo_0 Hm_r3_lt_0). }
    claim Hcy0Eq: add_SNo y0 (minus_SNo r3) = c1.
    { reflexivity. }
    claim Hcy0S: c1 < y0.
    { rewrite <- Hcy0Eq.
      rewrite <- Hy0plus0 at 2.
      exact Hcy0S'. }
    rewrite <- Hcy0Eq at 1.
    exact (RltI (add_SNo y0 (minus_SNo r3)) y0 Hc1R Hy0R Hcy0S). }
  claim Hy0d: Rlt y0 d1.
  { claim Hy0dS: y0 < add_SNo y0 r3.
    { exact (add_SNo_eps_Lt y0 Hy0S (ordsucc N) HsuccOmega). }
    exact (RltI y0 d1 Hy0R Hd1R Hy0dS). }
  claim Hrefl: (x0,y0) = (x0,y0).
  { reflexivity. }
  claim Hpair: (x0,y0) = (x0,y0) /\ Rlt a x0.
  { exact (andI ((x0,y0) = (x0,y0)) (Rlt a x0) Hrefl Hax0). }
  claim H1: ( (x0,y0) = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b.
  { exact (andI ((x0,y0) = (x0,y0) /\ Rlt a x0) (Rlt x0 b) Hpair Hx0b). }
  claim H2: (((x0,y0) = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b) /\ Rlt c1 y0.
  { exact (andI (((x0,y0) = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b) (Rlt c1 y0) H1 Hcy0). }
  exact (andI ((((x0,y0) = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b) /\ Rlt c1 y0) (Rlt y0 d1) H2 Hy0d). }

claim HRectSub: Rect c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ let p. assume HpRect: p :e Rect.
  claim HpE: p :e EuclidPlane.
  { exact (SepE1 EuclidPlane
                (fun p0 : set => exists x1 y1:set,
                   p0 = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b /\ Rlt c1 y1 /\ Rlt y1 d1)
                p
                HpRect). }
  claim HpPred:
    exists x1 y1:set, p = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b /\ Rlt c1 y1 /\ Rlt y1 d1.
  { exact (SepE2 EuclidPlane
                (fun p0 : set => exists x1 y1:set,
                   p0 = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b /\ Rlt c1 y1 /\ Rlt y1 d1)
                p
                HpRect). }
  apply HpPred.
  let x1. assume HpPred2.
  apply HpPred2.
  let y1. assume HpCore.
  claim Hcore1: (((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b) /\ Rlt c1 y1).
  { exact (andEL (((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b) /\ Rlt c1 y1)
                (Rlt y1 d1)
                HpCore). }
  claim Hy1d: Rlt y1 d1.
  { exact (andER (((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b) /\ Rlt c1 y1)
                (Rlt y1 d1)
                HpCore). }
  claim Hcore2: ((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b).
  { exact (andEL ((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b)
                (Rlt c1 y1)
                Hcore1). }
  claim Hcy1: Rlt c1 y1.
  { exact (andER ((p = (x1,y1) /\ Rlt a x1) /\ Rlt x1 b)
                (Rlt c1 y1)
                Hcore1). }
  claim Hcore3: (p = (x1,y1) /\ Rlt a x1).
  { exact (andEL (p = (x1,y1) /\ Rlt a x1)
                (Rlt x1 b)
                Hcore2). }
  claim Hx1b: Rlt x1 b.
  { exact (andER (p = (x1,y1) /\ Rlt a x1)
                (Rlt x1 b)
                Hcore2). }
  claim HpEq: p = (x1,y1).
  { exact (andEL (p = (x1,y1))
                (Rlt a x1)
                Hcore3). }
  claim Hax1: Rlt a x1.
  { exact (andER (p = (x1,y1))
                (Rlt a x1)
                Hcore3). }

  claim HxpEq: R2_xcoord p = x1.
  { rewrite HpEq at 1.
    exact (R2_xcoord_tuple x1 y1). }
  claim HypEq: R2_ycoord p = y1.
  { rewrite HpEq at 1.
    exact (R2_ycoord_tuple x1 y1). }

  claim Hx1R: x1 :e R.
  { rewrite <- HxpEq at 1.
    exact (EuclidPlane_xcoord_in_R p HpE). }
  claim Hy1R: y1 :e R.
  { rewrite <- HypEq at 1.
    exact (EuclidPlane_ycoord_in_R p HpE). }

  claim HabsdxLt: abs_SNo (add_SNo (R2_xcoord p) (minus_SNo x0)) < r3.
  { rewrite HxpEq at 1.
    exact (abs_diff_lt_of_between x1 x0 r3 Hx1R Hx0R Hr3R Hr3Pos Hax1 Hx1b). }

  claim HabsdyLt: abs_SNo (add_SNo (R2_ycoord p) (minus_SNo y0)) < r3.
  { rewrite HypEq at 1.
    exact (abs_diff_lt_of_between y1 y0 r3 Hy1R Hy0R Hr3R Hr3Pos Hcy1 Hy1d). }

  set axp := abs_SNo (add_SNo (R2_xcoord p) (minus_SNo x0)).
  set ayp := abs_SNo (add_SNo (R2_ycoord p) (minus_SNo y0)).
  claim HaxpS: SNo axp.
  { exact (SNo_abs_SNo (add_SNo (R2_xcoord p) (minus_SNo x0))
                      (real_SNo (add_SNo (R2_xcoord p) (minus_SNo x0))
                               (real_add_SNo (R2_xcoord p) (EuclidPlane_xcoord_in_R p HpE)
                                            (minus_SNo x0) (real_minus_SNo x0 Hx0R)))). }
  claim HaypS: SNo ayp.
  { exact (SNo_abs_SNo (add_SNo (R2_ycoord p) (minus_SNo y0))
                      (real_SNo (add_SNo (R2_ycoord p) (minus_SNo y0))
                               (real_add_SNo (R2_ycoord p) (EuclidPlane_ycoord_in_R p HpE)
                                            (minus_SNo y0) (real_minus_SNo y0 Hy0R)))). }
  claim HsumAbsLt: add_SNo axp ayp < eps.
  { claim HsumLt0: add_SNo axp ayp < add_SNo r3 r3.
    { exact (add_SNo_Lt3 axp ayp r3 r3 HaxpS HaypS Hr3S Hr3S HabsdxLt HabsdyLt). }
    rewrite <- Hr3Half.
    exact HsumLt0. }

  claim HdistLeSum: distance_R2 p x <= add_SNo axp ayp.
  { exact (distance_R2_le_absdx_plus_absdy p x HpE Hx). }
  claim HdistS: SNo (distance_R2 p x).
  { exact (real_SNo (distance_R2 p x) (distance_R2_in_R p x HpE Hx)). }
  claim HepsS2: SNo eps.
  { exact HepsS. }
  claim HdistLtEpsS: distance_R2 p x < eps.
  { exact (SNoLeLt_tra (distance_R2 p x) (add_SNo axp ayp) eps
                      HdistS (SNo_add_SNo axp ayp HaxpS HaypS) HepsS2
                      HdistLeSum HsumAbsLt). }
  claim HdistLtEps: Rlt (distance_R2 p x) eps.
  { exact (RltI (distance_R2 p x) eps
               (distance_R2_in_R p x HpE Hx) HepsR HdistLtEpsS). }

  claim Htri: Rle (distance_R2 p c) (add_SNo (distance_R2 p x) dxc).
  { exact (distance_R2_triangle_Rle p x c HpE Hx Hc). }
  claim HdistLtEpsS2: distance_R2 p x < eps.
  { exact HdistLtEpsS. }
  claim Hsum2Lt: add_SNo (distance_R2 p x) dxc < r0.
  { claim Hcom: add_SNo (distance_R2 p x) dxc = add_SNo dxc (distance_R2 p x).
    { exact (add_SNo_com (distance_R2 p x) dxc
                         (real_SNo (distance_R2 p x) (distance_R2_in_R p x HpE Hx))
                         HdxcS). }
    rewrite Hcom.
    claim Htmp: add_SNo dxc (distance_R2 p x) < add_SNo dxc eps.
    { exact (add_SNo_Lt2 dxc (distance_R2 p x) eps HdxcS
                        (real_SNo (distance_R2 p x) (distance_R2_in_R p x HpE Hx))
                        HepsS
                        HdistLtEpsS2). }
    claim HsumEq: add_SNo dxc eps = add_SNo dxc eps.
    { reflexivity. }
    exact (SNoLt_tra (add_SNo dxc (distance_R2 p x)) (add_SNo dxc eps) r0
                     (SNo_add_SNo dxc (distance_R2 p x) HdxcS (real_SNo (distance_R2 p x) (distance_R2_in_R p x HpE Hx)))
                     (SNo_add_SNo dxc eps HdxcS HepsS)
                     Hr0S
                     Htmp
                     HsumLtS). }
  claim Hsum2Rlt: Rlt (add_SNo (distance_R2 p x) dxc) r0.
  { exact (RltI (add_SNo (distance_R2 p x) dxc) r0
               (real_add_SNo (distance_R2 p x) (distance_R2_in_R p x HpE Hx) dxc HdxcR)
               Hr0R
               Hsum2Lt). }
  claim HpcLt: Rlt (distance_R2 p c) r0.
  { exact (Rle_Rlt_tra_Euclid (distance_R2 p c) (add_SNo (distance_R2 p x) dxc) r0 Htri Hsum2Rlt). }

  exact (SepI EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c) r0) p HpE HpcLt). }

witness Rect.
apply andI.
- exact HRect.
- apply andI.
  + exact Hx_in_Rect.
  + exact HRectSub.
Qed.

(** helper for §13 Example 4: ball inside a rectangle around a point **)
(** LATEX VERSION: Every point x in a rectangle has a circular neighborhood contained in it. **)
(** NOTE: This lemma is proved below using abs bounds from distance_R2 and epsilon selection below finitely many positive margins. **)
Theorem ball_inside_rectangle :
  forall b x:set,
    b :e rectangular_regions ->
    x :e EuclidPlane ->
    x :e b ->
    exists r3:set,
      Rlt 0 r3 /\
      (forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> p :e b).
let b x.
assume Hb: b :e rectangular_regions.
assume HxE: x :e EuclidPlane.
assume Hxb: x :e b.
claim HbPred:
  exists a b0 c d0:set,
    a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0 /\
      b = {p :e EuclidPlane|exists x1 y1:set, p = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b0 /\ Rlt c y1 /\ Rlt y1 d0}.
{ exact (SepE2 (Power EuclidPlane)
               (fun U0 : set =>
                 exists a0 b0 c0 d0:set, a0 :e R /\ b0 :e R /\ c0 :e R /\ d0 :e R /\ Rlt a0 b0 /\ Rlt c0 d0 /\
                   U0 = {p :e EuclidPlane|exists x1 y1:set, p = (x1,y1) /\ Rlt a0 x1 /\ Rlt x1 b0 /\ Rlt c0 y1 /\ Rlt y1 d0})
               b
               Hb). }
apply HbPred.
let a. assume HbPred2.
apply HbPred2.
let b0. assume HbPred3.
apply HbPred3.
let c. assume HbPred4.
apply HbPred4.
let d0. assume Habcd.
set Rect := {p :e EuclidPlane|exists x1 y1:set, p = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b0 /\ Rlt c y1 /\ Rlt y1 d0}.
claim HbEq: b = Rect.
{ exact (andER
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0)
          (b = Rect)
          Habcd). }
claim HabcdLeft: a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0.
{ exact (andEL
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0)
          (b = Rect)
          Habcd). }
claim Hcd: Rlt c d0.
{ exact (andER
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0)
          (Rlt c d0)
          HabcdLeft). }
claim HabcdLeft2: a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0.
{ exact (andEL
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0)
          (Rlt c d0)
          HabcdLeft). }
claim Hab: Rlt a b0.
{ exact (andER
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R)
          (Rlt a b0)
          HabcdLeft2). }
claim HabcdLeft3: a :e R /\ b0 :e R /\ c :e R /\ d0 :e R.
{ exact (andEL
          (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R)
          (Rlt a b0)
          HabcdLeft2). }
claim Hd0R: d0 :e R.
{ exact (andER
          (a :e R /\ b0 :e R /\ c :e R)
          (d0 :e R)
          HabcdLeft3). }
claim HabcdLeft4: a :e R /\ b0 :e R /\ c :e R.
{ exact (andEL
          (a :e R /\ b0 :e R /\ c :e R)
          (d0 :e R)
          HabcdLeft3). }
claim HcR: c :e R.
{ exact (andER
          (a :e R /\ b0 :e R)
          (c :e R)
          HabcdLeft4). }
claim HabR: a :e R /\ b0 :e R.
{ exact (andEL
          (a :e R /\ b0 :e R)
          (c :e R)
          HabcdLeft4). }
claim HaR: a :e R.
{ exact (andEL (a :e R) (b0 :e R) HabR). }
claim Hb0R: b0 :e R.
{ exact (andER (a :e R) (b0 :e R) HabR). }

claim HxRect: x :e Rect.
{ prove x :e Rect.
  rewrite <- HbEq.
  exact Hxb. }
claim HxRectPred: exists x0 y0:set,
  x = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0.
{ exact (SepE2 EuclidPlane
              (fun p0 : set => exists x0 y0:set, p0 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0)
              x
              HxRect). }
apply HxRectPred.
let x0. assume HxRectPred2.
apply HxRectPred2.
let y0. assume Hxy0.
claim Hy0d0: Rlt y0 d0.
{ exact (andER (((x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0) /\ Rlt c y0) (Rlt y0 d0) Hxy0). }
claim HxyLeft3: ((x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0) /\ Rlt c y0.
{ exact (andEL (((x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0) /\ Rlt c y0) (Rlt y0 d0) Hxy0). }
claim Hcy0: Rlt c y0.
{ exact (andER ((x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0) (Rlt c y0) HxyLeft3). }
claim HxyLeft2: (x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0.
{ exact (andEL ((x = (x0,y0) /\ Rlt a x0) /\ Rlt x0 b0) (Rlt c y0) HxyLeft3). }
claim Hx0b0: Rlt x0 b0.
{ exact (andER (x = (x0,y0) /\ Rlt a x0) (Rlt x0 b0) HxyLeft2). }
claim HxyLeft1: x = (x0,y0) /\ Rlt a x0.
{ exact (andEL (x = (x0,y0) /\ Rlt a x0) (Rlt x0 b0) HxyLeft2). }
claim Hax0: Rlt a x0.
{ exact (andER (x = (x0,y0)) (Rlt a x0) HxyLeft1). }
claim HxEq: x = (x0,y0).
{ exact (andEL (x = (x0,y0)) (Rlt a x0) HxyLeft1). }

claim Hx0R: x0 :e R.
{ exact (RltE_right a x0 Hax0). }
claim Hy0R: y0 :e R.
{ exact (RltE_right c y0 Hcy0). }
claim Hx0S: SNo x0.
{ exact (real_SNo x0 Hx0R). }
claim Hy0S: SNo y0.
{ exact (real_SNo y0 Hy0R). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim Hb0S: SNo b0.
{ exact (real_SNo b0 Hb0R). }
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim Hd0S: SNo d0.
{ exact (real_SNo d0 Hd0R). }

set m1 := add_SNo x0 (minus_SNo a).
set m2 := add_SNo b0 (minus_SNo x0).
set m3 := add_SNo y0 (minus_SNo c).
set m4 := add_SNo d0 (minus_SNo y0).
claim Hm1R: m1 :e R.
{ exact (real_add_SNo x0 Hx0R (minus_SNo a) (real_minus_SNo a HaR)). }
claim Hm2R: m2 :e R.
{ exact (real_add_SNo b0 Hb0R (minus_SNo x0) (real_minus_SNo x0 Hx0R)). }
claim Hm3R: m3 :e R.
{ exact (real_add_SNo y0 Hy0R (minus_SNo c) (real_minus_SNo c HcR)). }
claim Hm4R: m4 :e R.
{ exact (real_add_SNo d0 Hd0R (minus_SNo y0) (real_minus_SNo y0 Hy0R)). }
claim Hm1S: SNo m1.
{ exact (real_SNo m1 Hm1R). }
claim Hm2S: SNo m2.
{ exact (real_SNo m2 Hm2R). }
claim Hm3S: SNo m3.
{ exact (real_SNo m3 Hm3R). }
claim Hm4S: SNo m4.
{ exact (real_SNo m4 Hm4R). }

(** positivity of margins from strict inequalities **)
claim Hax0Slt: a < x0.
{ exact (RltE_lt a x0 Hax0). }
claim Hx0b0Slt: x0 < b0.
{ exact (RltE_lt x0 b0 Hx0b0). }
claim Hcy0Slt: c < y0.
{ exact (RltE_lt c y0 Hcy0). }
claim Hy0d0Slt: y0 < d0.
{ exact (RltE_lt y0 d0 Hy0d0). }
claim HmaS: SNo (minus_SNo a).
{ exact (SNo_minus_SNo a HaS). }
claim Hmx0S: SNo (minus_SNo x0).
{ exact (SNo_minus_SNo x0 Hx0S). }
claim HmcS: SNo (minus_SNo c).
{ exact (SNo_minus_SNo c HcS). }
claim Hmy0S: SNo (minus_SNo y0).
{ exact (SNo_minus_SNo y0 Hy0S). }

claim Hm1posS: 0 < m1.
{ claim Hlt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) x0.
  { exact (add_SNo_Lt2 (minus_SNo a) a x0 HmaS HaS Hx0S Hax0Slt). }
  claim H0eq: add_SNo (minus_SNo a) a = 0.
  { exact (add_SNo_minus_SNo_linv a HaS). }
  claim Hm1eq: add_SNo (minus_SNo a) x0 = m1.
  { claim Hcom: add_SNo (minus_SNo a) x0 = add_SNo x0 (minus_SNo a).
    { exact (add_SNo_com (minus_SNo a) x0 HmaS Hx0S). }
    rewrite Hcom.
    reflexivity. }
  rewrite <- H0eq at 1.
  rewrite <- Hm1eq at 1.
  exact Hlt. }
claim Hm2posS: 0 < m2.
{ claim Hlt: add_SNo (minus_SNo x0) x0 < add_SNo (minus_SNo x0) b0.
  { exact (add_SNo_Lt2 (minus_SNo x0) x0 b0 Hmx0S Hx0S Hb0S Hx0b0Slt). }
  claim H0eq: add_SNo (minus_SNo x0) x0 = 0.
  { exact (add_SNo_minus_SNo_linv x0 Hx0S). }
  claim Hm2eq: add_SNo (minus_SNo x0) b0 = m2.
  { claim Hcom: add_SNo (minus_SNo x0) b0 = add_SNo b0 (minus_SNo x0).
    { exact (add_SNo_com (minus_SNo x0) b0 Hmx0S Hb0S). }
    rewrite Hcom.
    reflexivity. }
  rewrite <- H0eq at 1.
  rewrite <- Hm2eq at 1.
  exact Hlt. }
claim Hm3posS: 0 < m3.
{ claim Hlt: add_SNo (minus_SNo c) c < add_SNo (minus_SNo c) y0.
  { exact (add_SNo_Lt2 (minus_SNo c) c y0 HmcS HcS Hy0S Hcy0Slt). }
  claim H0eq: add_SNo (minus_SNo c) c = 0.
  { exact (add_SNo_minus_SNo_linv c HcS). }
  claim Hm3eq: add_SNo (minus_SNo c) y0 = m3.
  { claim Hcom: add_SNo (minus_SNo c) y0 = add_SNo y0 (minus_SNo c).
    { exact (add_SNo_com (minus_SNo c) y0 HmcS Hy0S). }
    rewrite Hcom.
    reflexivity. }
  rewrite <- H0eq at 1.
  rewrite <- Hm3eq at 1.
  exact Hlt. }
claim Hm4posS: 0 < m4.
{ claim Hlt: add_SNo (minus_SNo y0) y0 < add_SNo (minus_SNo y0) d0.
  { exact (add_SNo_Lt2 (minus_SNo y0) y0 d0 Hmy0S Hy0S Hd0S Hy0d0Slt). }
  claim H0eq: add_SNo (minus_SNo y0) y0 = 0.
  { exact (add_SNo_minus_SNo_linv y0 Hy0S). }
  claim Hm4eq: add_SNo (minus_SNo y0) d0 = m4.
  { claim Hcom: add_SNo (minus_SNo y0) d0 = add_SNo d0 (minus_SNo y0).
    { exact (add_SNo_com (minus_SNo y0) d0 Hmy0S Hd0S). }
    rewrite Hcom.
    reflexivity. }
  rewrite <- H0eq at 1.
  rewrite <- Hm4eq at 1.
  exact Hlt. }
claim Hm1pos: Rlt 0 m1.
{ exact (RltI 0 m1 real_0 Hm1R Hm1posS). }
claim Hm2pos: Rlt 0 m2.
{ exact (RltI 0 m2 real_0 Hm2R Hm2posS). }
claim Hm3pos: Rlt 0 m3.
{ exact (RltI 0 m3 real_0 Hm3R Hm3posS). }
claim Hm4pos: Rlt 0 m4.
{ exact (RltI 0 m4 real_0 Hm4R Hm4posS). }

claim Hexr3:
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 m1 /\ Rlt r3 m2 /\ Rlt r3 m3 /\ Rlt r3 m4.
{ exact (exists_eps_lt_four_pos_Euclid m1 m2 m3 m4 Hm1R Hm2R Hm3R Hm4R Hm1pos Hm2pos Hm3pos Hm4pos). }
apply Hexr3.
let r3. assume Hr3.
claim Hr3m4: Rlt r3 m4.
{ exact (andER
          ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) /\ Rlt r3 m3)
          (Rlt r3 m4)
          Hr3). }
claim Hr3Left5: (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) /\ Rlt r3 m3.
{ exact (andEL
          ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) /\ Rlt r3 m3)
          (Rlt r3 m4)
          Hr3). }
claim Hr3m3: Rlt r3 m3.
{ exact (andER (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) (Rlt r3 m3) Hr3Left5). }
claim Hr3Left4: ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2.
{ exact (andEL
          (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2)
          (Rlt r3 m3)
          Hr3Left5). }
claim Hr3m2: Rlt r3 m2.
{ exact (andER
          ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1)
          (Rlt r3 m2)
          Hr3Left4). }
claim Hr3Left3: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1.
{ exact (andEL
          ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1)
          (Rlt r3 m2)
          Hr3Left4). }
claim Hr3m1: Rlt r3 m1.
{ exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 m1) Hr3Left3). }
claim Hr3Pair: r3 :e R /\ Rlt 0 r3.
{ exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 m1) Hr3Left3). }
claim Hr3R: r3 :e R.
{ exact (andEL (r3 :e R) (Rlt 0 r3) Hr3Pair). }
claim Hr3pos: Rlt 0 r3.
{ exact (andER (r3 :e R) (Rlt 0 r3) Hr3Pair). }

witness r3.
apply andI.
- exact Hr3pos.
- let p. assume HpE: p :e EuclidPlane.
	  assume Hdp: Rlt (distance_R2 p x) r3.
	  prove p :e b.
	  rewrite HbEq.
	  prove p :e Rect.
	  set xp := R2_xcoord p.
	  set yp := R2_ycoord p.
	  claim HxpDef: xp = R2_xcoord p.
	  { reflexivity. }
	  claim HypDef: yp = R2_ycoord p.
	  { reflexivity. }
	  claim HxpR: xp :e R.
	  { rewrite HxpDef.
	    exact (EuclidPlane_xcoord_in_R p HpE). }
	  claim HypR: yp :e R.
	  { rewrite HypDef.
	    exact (EuclidPlane_ycoord_in_R p HpE). }
	  claim HxpS: SNo xp.
	  { exact (real_SNo xp HxpR). }
	  claim HypS: SNo yp.
	  { exact (real_SNo yp HypR). }

	  claim Hxcoord: R2_xcoord x = x0.
	  { prove R2_xcoord x = x0.
	    rewrite HxEq at 1.
	    exact (R2_xcoord_tuple x0 y0). }
	  claim Hycoord: R2_ycoord x = y0.
	  { prove R2_ycoord x = y0.
	    rewrite HxEq at 1.
	    exact (R2_ycoord_tuple x0 y0). }

	  claim Hr3S: SNo r3.
	  { exact (real_SNo r3 Hr3R). }
	  claim Hr3posS: 0 < r3.
	  { exact (RltE_lt 0 r3 Hr3pos). }

	  claim Habsdx: abs_SNo (add_SNo xp (minus_SNo x0)) < r3.
	  { prove abs_SNo (add_SNo xp (minus_SNo x0)) < r3.
	    rewrite HxpDef at 1.
	    rewrite <- Hxcoord at 1.
	    exact (abs_xcoord_lt_of_distance_lt p x r3 HpE HxE Hr3R Hdp). }
	  claim Habsdy: abs_SNo (add_SNo yp (minus_SNo y0)) < r3.
	  { prove abs_SNo (add_SNo yp (minus_SNo y0)) < r3.
	    rewrite HypDef at 1.
	    rewrite <- Hycoord at 1.
	    exact (abs_ycoord_lt_of_distance_lt p x r3 HpE HxE Hr3R Hdp). }

	  set dx := add_SNo xp (minus_SNo x0).
	  set dy := add_SNo yp (minus_SNo y0).
	  claim HdxDef: dx = add_SNo xp (minus_SNo x0).
	  { reflexivity. }
	  claim HdyDef: dy = add_SNo yp (minus_SNo y0).
	  { reflexivity. }
	  claim HdxR: dx :e R.
	  { rewrite HdxDef.
	    exact (real_add_SNo xp HxpR (minus_SNo x0) (real_minus_SNo x0 Hx0R)). }
	  claim HdyR: dy :e R.
	  { rewrite HdyDef.
	    exact (real_add_SNo yp HypR (minus_SNo y0) (real_minus_SNo y0 Hy0R)). }
	  claim HdxS: SNo dx.
	  { exact (real_SNo dx HdxR). }
	  claim HdyS: SNo dy.
	  { exact (real_SNo dy HdyR). }

	  claim HdxLt: dx < r3.
	  { rewrite HdxDef at 1.
	    exact (abs_SNo_lt_imp_lt
	            (add_SNo xp (minus_SNo x0)) r3
	            (real_SNo (add_SNo xp (minus_SNo x0)) HdxR)
	            Hr3S Hr3posS Habsdx). }
	  claim HdyLt: dy < r3.
	  { rewrite HdyDef at 1.
	    exact (abs_SNo_lt_imp_lt
	            (add_SNo yp (minus_SNo y0)) r3
	            (real_SNo (add_SNo yp (minus_SNo y0)) HdyR)
	            Hr3S Hr3posS Habsdy). }

	  claim HnegdxLt: minus_SNo dx < r3.
	  { rewrite HdxDef at 1.
	    exact (abs_SNo_lt_imp_neg_lt
	            (add_SNo xp (minus_SNo x0)) r3
	            (real_SNo (add_SNo xp (minus_SNo x0)) HdxR)
	            Hr3S Hr3posS Habsdx). }
	  claim HnegdyLt: minus_SNo dy < r3.
	  { rewrite HdyDef at 1.
	    exact (abs_SNo_lt_imp_neg_lt
	            (add_SNo yp (minus_SNo y0)) r3
	            (real_SNo (add_SNo yp (minus_SNo y0)) HdyR)
	            Hr3S Hr3posS Habsdy). }

	  claim HnegdxEq: minus_SNo dx = add_SNo x0 (minus_SNo xp).
	  { prove minus_SNo dx = add_SNo x0 (minus_SNo xp).
	    rewrite HdxDef at 1.
	    claim Hmx0S: SNo (minus_SNo x0).
	    { exact (SNo_minus_SNo x0 Hx0S). }
	    claim HmxpS: SNo (minus_SNo xp).
	    { exact (SNo_minus_SNo xp HxpS). }
	    claim Hneg : minus_SNo (add_SNo xp (minus_SNo x0))
	              = add_SNo (minus_SNo xp) (minus_SNo (minus_SNo x0)).
	    { exact (minus_add_SNo_distr xp (minus_SNo x0) HxpS Hmx0S). }
	    claim Hinv : minus_SNo (minus_SNo x0) = x0.
	    { exact (minus_SNo_invol x0 Hx0S). }
	    claim Hneg2 : minus_SNo (add_SNo xp (minus_SNo x0)) = add_SNo (minus_SNo xp) x0.
	    { rewrite <- Hinv at 2.
	      exact Hneg. }
	    claim Hcom : add_SNo (minus_SNo xp) x0 = add_SNo x0 (minus_SNo xp).
	    { exact (add_SNo_com (minus_SNo xp) x0 HmxpS Hx0S). }
	    rewrite <- Hcom.
	    exact Hneg2. }

	  claim HnegdyEq: minus_SNo dy = add_SNo y0 (minus_SNo yp).
	  { prove minus_SNo dy = add_SNo y0 (minus_SNo yp).
	    rewrite HdyDef at 1.
	    claim Hmy0S: SNo (minus_SNo y0).
	    { exact (SNo_minus_SNo y0 Hy0S). }
	    claim HmypS: SNo (minus_SNo yp).
	    { exact (SNo_minus_SNo yp HypS). }
	    claim Hneg : minus_SNo (add_SNo yp (minus_SNo y0))
	              = add_SNo (minus_SNo yp) (minus_SNo (minus_SNo y0)).
	    { exact (minus_add_SNo_distr yp (minus_SNo y0) HypS Hmy0S). }
	    claim Hinv : minus_SNo (minus_SNo y0) = y0.
	    { exact (minus_SNo_invol y0 Hy0S). }
	    claim Hneg2 : minus_SNo (add_SNo yp (minus_SNo y0)) = add_SNo (minus_SNo yp) y0.
	    { rewrite <- Hinv at 2.
	      exact Hneg. }
	    claim Hcom : add_SNo (minus_SNo yp) y0 = add_SNo y0 (minus_SNo yp).
	    { exact (add_SNo_com (minus_SNo yp) y0 HmypS Hy0S). }
	    rewrite <- Hcom.
	    exact Hneg2. }

	  claim Hr3m1S: r3 < m1.
	  { exact (RltE_lt r3 m1 Hr3m1). }
	  claim Hr3m2S: r3 < m2.
	  { exact (RltE_lt r3 m2 Hr3m2). }
	  claim Hr3m3S: r3 < m3.
	  { exact (RltE_lt r3 m3 Hr3m3). }
	  claim Hr3m4S: r3 < m4.
	  { exact (RltE_lt r3 m4 Hr3m4). }

	  (** x0 < xp + r3 from x0 - xp < r3 **)
	  claim Hx0Lt_xpr3: x0 < add_SNo xp r3.
	  { prove x0 < add_SNo xp r3.
	    claim Hx0mxpLt: add_SNo x0 (minus_SNo xp) < r3.
	    { prove add_SNo x0 (minus_SNo xp) < r3.
	      rewrite <- HnegdxEq at 1.
	      exact HnegdxLt. }
	    claim Hx0mxpS: SNo (add_SNo x0 (minus_SNo xp)).
	    { exact (real_SNo (add_SNo x0 (minus_SNo xp))
	                      (real_add_SNo x0 Hx0R (minus_SNo xp) (real_minus_SNo xp HxpR))). }
	    claim Htmp: add_SNo xp (add_SNo x0 (minus_SNo xp)) < add_SNo xp r3.
	    { exact (add_SNo_Lt2 xp (add_SNo x0 (minus_SNo xp)) r3 HxpS Hx0mxpS Hr3S Hx0mxpLt). }
	    claim HlhsEq: add_SNo xp (add_SNo x0 (minus_SNo xp)) = x0.
	    { claim HmxpS: SNo (minus_SNo xp).
	      { exact (SNo_minus_SNo xp HxpS). }
	      claim Hassoc1: add_SNo xp (add_SNo x0 (minus_SNo xp)) = add_SNo (add_SNo xp x0) (minus_SNo xp).
	      { exact (add_SNo_assoc xp x0 (minus_SNo xp) HxpS Hx0S HmxpS). }
	      claim Hcom1: add_SNo xp x0 = add_SNo x0 xp.
	      { exact (add_SNo_com xp x0 HxpS Hx0S). }
	      claim Hassoc2: add_SNo (add_SNo x0 xp) (minus_SNo xp) = add_SNo x0 (add_SNo xp (minus_SNo xp)).
	      { symmetry.
	        exact (add_SNo_assoc x0 xp (minus_SNo xp) Hx0S HxpS HmxpS). }
	      claim Hinv: add_SNo xp (minus_SNo xp) = 0.
	      { exact (add_SNo_minus_SNo_rinv xp HxpS). }
	      claim Hz: add_SNo x0 0 = x0.
	      { exact (add_SNo_0R x0 Hx0S). }
	      prove add_SNo xp (add_SNo x0 (minus_SNo xp)) = x0.
	      rewrite Hassoc1.
	      rewrite Hcom1.
	      rewrite Hassoc2.
	      rewrite Hinv.
	      exact Hz. }
	    rewrite <- HlhsEq at 1.
	    exact Htmp. }

	  (** xp < x0 + r3 from xp - x0 < r3 **)
	  claim HxpLt_x0r3: xp < add_SNo x0 r3.
	  { prove xp < add_SNo x0 r3.
	    claim HdxSlt: add_SNo xp (minus_SNo x0) < r3.
	    { rewrite <- HdxDef at 1.
	      exact HdxLt. }
	    claim HdxtermS: SNo (add_SNo xp (minus_SNo x0)).
	    { exact (real_SNo (add_SNo xp (minus_SNo x0)) HdxR). }
	    claim Htmp: add_SNo x0 (add_SNo xp (minus_SNo x0)) < add_SNo x0 r3.
	    { exact (add_SNo_Lt2 x0 (add_SNo xp (minus_SNo x0)) r3 Hx0S HdxtermS Hr3S HdxSlt). }
	    claim HlhsEq: add_SNo x0 (add_SNo xp (minus_SNo x0)) = xp.
	    { claim Hmx0S: SNo (minus_SNo x0).
	      { exact (SNo_minus_SNo x0 Hx0S). }
	      claim Hassoc1: add_SNo x0 (add_SNo xp (minus_SNo x0)) = add_SNo (add_SNo x0 xp) (minus_SNo x0).
	      { exact (add_SNo_assoc x0 xp (minus_SNo x0) Hx0S HxpS Hmx0S). }
	      claim Hcom1: add_SNo x0 xp = add_SNo xp x0.
	      { exact (add_SNo_com x0 xp Hx0S HxpS). }
	      claim Hassoc2: add_SNo (add_SNo xp x0) (minus_SNo x0) = add_SNo xp (add_SNo x0 (minus_SNo x0)).
	      { symmetry.
	        exact (add_SNo_assoc xp x0 (minus_SNo x0) HxpS Hx0S Hmx0S). }
	      claim Hinv: add_SNo x0 (minus_SNo x0) = 0.
	      { exact (add_SNo_minus_SNo_rinv x0 Hx0S). }
	      claim Hz: add_SNo xp 0 = xp.
	      { exact (add_SNo_0R xp HxpS). }
	      prove add_SNo x0 (add_SNo xp (minus_SNo x0)) = xp.
	      rewrite Hassoc1.
	      rewrite Hcom1.
	      rewrite Hassoc2.
	      rewrite Hinv.
	      exact Hz. }
	    rewrite <- HlhsEq at 1.
	    exact Htmp. }

	  (** x0 + r3 < b0 from r3 < b0 - x0 **)
	  claim Hx0r3Lt_b0: add_SNo x0 r3 < b0.
	  { prove add_SNo x0 r3 < b0.
	    claim Htmp: add_SNo x0 r3 < add_SNo x0 m2.
	    { exact (add_SNo_Lt2 x0 r3 m2 Hx0S Hr3S Hm2S Hr3m2S). }
	    claim HrhsEq: add_SNo x0 m2 = b0.
	    { prove add_SNo x0 m2 = b0.
	      rewrite (add_SNo_com x0 m2 Hx0S Hm2S).
	      rewrite <- (add_SNo_assoc b0 (minus_SNo x0) x0 Hb0S Hmx0S Hx0S) at 1.
	      claim Hinv: add_SNo (minus_SNo x0) x0 = 0.
	      { exact (add_SNo_minus_SNo_linv x0 Hx0S). }
	      rewrite Hinv at 1.
	      exact (add_SNo_0R b0 Hb0S). }
		    prove add_SNo x0 r3 < b0.
		    rewrite <- HrhsEq.
		    exact Htmp. }

		  (** a < xp via (a+r3) < x0 < (xp+r3) and cancellation **)
		  claim Hm1Def: m1 = add_SNo x0 (minus_SNo a).
		  { reflexivity. }
		  claim Hr3m1Lt: r3 < m1.
		  { exact Hr3m1S. }
		  claim Har3Lt_am1: add_SNo a r3 < add_SNo a m1.
		  { exact (add_SNo_Lt2 a r3 m1 HaS Hr3S Hm1S Hr3m1Lt). }
		  claim Ham1Eq: add_SNo a m1 = x0.
		  { prove add_SNo a m1 = x0.
		    rewrite Hm1Def.
		    claim HmaS: SNo (minus_SNo a).
		    { exact (SNo_minus_SNo a HaS). }
		    claim Hassoc1: add_SNo a (add_SNo x0 (minus_SNo a)) = add_SNo (add_SNo a x0) (minus_SNo a).
		    { exact (add_SNo_assoc a x0 (minus_SNo a) HaS Hx0S HmaS). }
		    claim Hcom1: add_SNo a x0 = add_SNo x0 a.
		    { exact (add_SNo_com a x0 HaS Hx0S). }
		    claim Hassoc2: add_SNo (add_SNo x0 a) (minus_SNo a) = add_SNo x0 (add_SNo a (minus_SNo a)).
		    { symmetry.
		      exact (add_SNo_assoc x0 a (minus_SNo a) Hx0S HaS HmaS). }
		    claim Hinv: add_SNo a (minus_SNo a) = 0.
		    { exact (add_SNo_minus_SNo_rinv a HaS). }
		    rewrite Hassoc1.
		    rewrite Hcom1.
		    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R x0 Hx0S). }
		  claim Har3Lt_x0: add_SNo a r3 < x0.
		  { prove add_SNo a r3 < x0.
		    rewrite <- Ham1Eq.
		    exact Har3Lt_am1. }
		  claim Har3S: SNo (add_SNo a r3).
		  { exact (real_SNo (add_SNo a r3) (real_add_SNo a HaR r3 Hr3R)). }
		  claim Hx0Lt_xpr3S: x0 < add_SNo xp r3.
		  { exact Hx0Lt_xpr3. }
		  claim Hxpr3S: SNo (add_SNo xp r3).
		  { exact (real_SNo (add_SNo xp r3) (real_add_SNo xp HxpR r3 Hr3R)). }
		  claim Har3Lt_xpr3: add_SNo a r3 < add_SNo xp r3.
		  { exact (SNoLt_tra (add_SNo a r3) x0 (add_SNo xp r3) Har3S Hx0S Hxpr3S Har3Lt_x0 Hx0Lt_xpr3S). }
		  claim Hmr3S: SNo (minus_SNo r3).
		  { exact (SNo_minus_SNo r3 Hr3S). }
		  claim HcancelL: add_SNo (minus_SNo r3) (add_SNo a r3) = a.
		  { claim Hassoc1: add_SNo (minus_SNo r3) (add_SNo a r3) = add_SNo (add_SNo (minus_SNo r3) a) r3.
		    { exact (add_SNo_assoc (minus_SNo r3) a r3 Hmr3S HaS Hr3S). }
		    claim Hcom1: add_SNo (minus_SNo r3) a = add_SNo a (minus_SNo r3).
		    { exact (add_SNo_com (minus_SNo r3) a Hmr3S HaS). }
		    claim Hassoc2: add_SNo (add_SNo a (minus_SNo r3)) r3 = add_SNo a (add_SNo (minus_SNo r3) r3).
		    { symmetry.
		      exact (add_SNo_assoc a (minus_SNo r3) r3 HaS Hmr3S Hr3S). }
		    claim Hinv: add_SNo (minus_SNo r3) r3 = 0.
		    { exact (add_SNo_minus_SNo_linv r3 Hr3S). }
		    rewrite Hassoc1.
		    rewrite Hcom1.
		    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R a HaS). }
		  claim HcancelR: add_SNo (minus_SNo r3) (add_SNo xp r3) = xp.
		  { claim Hassoc1: add_SNo (minus_SNo r3) (add_SNo xp r3) = add_SNo (add_SNo (minus_SNo r3) xp) r3.
		    { exact (add_SNo_assoc (minus_SNo r3) xp r3 Hmr3S HxpS Hr3S). }
		    claim Hcom1: add_SNo (minus_SNo r3) xp = add_SNo xp (minus_SNo r3).
		    { exact (add_SNo_com (minus_SNo r3) xp Hmr3S HxpS). }
		    claim Hassoc2: add_SNo (add_SNo xp (minus_SNo r3)) r3 = add_SNo xp (add_SNo (minus_SNo r3) r3).
		    { symmetry.
		      exact (add_SNo_assoc xp (minus_SNo r3) r3 HxpS Hmr3S Hr3S). }
		    claim Hinv: add_SNo (minus_SNo r3) r3 = 0.
		    { exact (add_SNo_minus_SNo_linv r3 Hr3S). }
		    rewrite Hassoc1.
		    rewrite Hcom1.
		    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R xp HxpS). }
		  claim HtmpAx: add_SNo (minus_SNo r3) (add_SNo a r3) < add_SNo (minus_SNo r3) (add_SNo xp r3).
		  { exact (add_SNo_Lt2 (minus_SNo r3) (add_SNo a r3) (add_SNo xp r3) Hmr3S Har3S Hxpr3S Har3Lt_xpr3). }
		  claim HaxSlt: a < xp.
		  { prove a < xp.
		    rewrite <- HcancelL at 1.
		    rewrite <- HcancelR.
		    exact HtmpAx. }
		  claim HaxRlt: Rlt a xp.
		  { exact (RltI a xp HaR HxpR HaxSlt). }

		  (** xp < b0 via xp < x0+r3 < b0 **)
		  claim Hx0r3S: SNo (add_SNo x0 r3).
		  { exact (real_SNo (add_SNo x0 r3) (real_add_SNo x0 Hx0R r3 Hr3R)). }
		  claim HxpLt_b0S: xp < b0.
		  { exact (SNoLt_tra xp (add_SNo x0 r3) b0 HxpS Hx0r3S Hb0S HxpLt_x0r3 Hx0r3Lt_b0). }
		  claim HxpLt_b0: Rlt xp b0.
		  { exact (RltI xp b0 HxpR Hb0R HxpLt_b0S). }

		  (** y0 < yp + r3 from y0 - yp < r3 **)
		  claim Hy0Lt_ypr3: y0 < add_SNo yp r3.
		  { prove y0 < add_SNo yp r3.
		    claim Hy0mypLt: add_SNo y0 (minus_SNo yp) < r3.
		    { prove add_SNo y0 (minus_SNo yp) < r3.
		      rewrite <- HnegdyEq at 1.
		      exact HnegdyLt. }
		    claim Hy0mypS: SNo (add_SNo y0 (minus_SNo yp)).
		    { exact (real_SNo (add_SNo y0 (minus_SNo yp))
		              (real_add_SNo y0 Hy0R (minus_SNo yp) (real_minus_SNo yp HypR))). }
		    claim Htmp: add_SNo yp (add_SNo y0 (minus_SNo yp)) < add_SNo yp r3.
		    { exact (add_SNo_Lt2 yp (add_SNo y0 (minus_SNo yp)) r3 HypS Hy0mypS Hr3S Hy0mypLt). }
		    claim HlhsEq: add_SNo yp (add_SNo y0 (minus_SNo yp)) = y0.
		    { claim HmypS: SNo (minus_SNo yp).
		      { exact (SNo_minus_SNo yp HypS). }
		      claim Hassoc1: add_SNo yp (add_SNo y0 (minus_SNo yp)) = add_SNo (add_SNo yp y0) (minus_SNo yp).
		      { exact (add_SNo_assoc yp y0 (minus_SNo yp) HypS Hy0S HmypS). }
		      claim Hcom1: add_SNo yp y0 = add_SNo y0 yp.
		      { exact (add_SNo_com yp y0 HypS Hy0S). }
		      claim Hassoc2: add_SNo (add_SNo y0 yp) (minus_SNo yp) = add_SNo y0 (add_SNo yp (minus_SNo yp)).
		      { symmetry.
		        exact (add_SNo_assoc y0 yp (minus_SNo yp) Hy0S HypS HmypS). }
		      claim Hinv: add_SNo yp (minus_SNo yp) = 0.
		      { exact (add_SNo_minus_SNo_rinv yp HypS). }
		      prove add_SNo yp (add_SNo y0 (minus_SNo yp)) = y0.
		      rewrite Hassoc1.
		      rewrite Hcom1.
		      rewrite Hassoc2.
		      rewrite Hinv.
		      exact (add_SNo_0R y0 Hy0S). }
		    rewrite <- HlhsEq at 1.
		    exact Htmp. }

		  (** yp < y0 + r3 from yp - y0 < r3 **)
		  claim HypLt_y0r3: yp < add_SNo y0 r3.
		  { prove yp < add_SNo y0 r3.
		    claim Hypmy0Lt: add_SNo yp (minus_SNo y0) < r3.
		    { prove add_SNo yp (minus_SNo y0) < r3.
		      rewrite <- HdyDef at 1.
		      exact HdyLt. }
		    claim Hypmy0S: SNo (add_SNo yp (minus_SNo y0)).
		    { exact (real_SNo (add_SNo yp (minus_SNo y0))
		              (real_add_SNo yp HypR (minus_SNo y0) (real_minus_SNo y0 Hy0R))). }
		    claim Htmp: add_SNo y0 (add_SNo yp (minus_SNo y0)) < add_SNo y0 r3.
		    { exact (add_SNo_Lt2 y0 (add_SNo yp (minus_SNo y0)) r3 Hy0S Hypmy0S Hr3S Hypmy0Lt). }
		    claim HlhsEq: add_SNo y0 (add_SNo yp (minus_SNo y0)) = yp.
		    { claim Hmy0S: SNo (minus_SNo y0).
		      { exact (SNo_minus_SNo y0 Hy0S). }
		      claim Hassoc1: add_SNo y0 (add_SNo yp (minus_SNo y0)) = add_SNo (add_SNo y0 yp) (minus_SNo y0).
		      { exact (add_SNo_assoc y0 yp (minus_SNo y0) Hy0S HypS Hmy0S). }
		      claim Hcom1: add_SNo y0 yp = add_SNo yp y0.
		      { exact (add_SNo_com y0 yp Hy0S HypS). }
		      claim Hassoc2: add_SNo (add_SNo yp y0) (minus_SNo y0) = add_SNo yp (add_SNo y0 (minus_SNo y0)).
		      { symmetry.
		        exact (add_SNo_assoc yp y0 (minus_SNo y0) HypS Hy0S Hmy0S). }
		      claim Hinv: add_SNo y0 (minus_SNo y0) = 0.
		      { exact (add_SNo_minus_SNo_rinv y0 Hy0S). }
		      prove add_SNo y0 (add_SNo yp (minus_SNo y0)) = yp.
		      rewrite Hassoc1.
		      rewrite Hcom1.
		      rewrite Hassoc2.
		      rewrite Hinv.
		      exact (add_SNo_0R yp HypS). }
		    rewrite <- HlhsEq at 1.
		    exact Htmp. }

		  (** y0 + r3 < d0 from r3 < d0 - y0 **)
		  claim Hy0r3Lt_d0: add_SNo y0 r3 < d0.
		  { prove add_SNo y0 r3 < d0.
		    claim Htmp: add_SNo y0 r3 < add_SNo y0 m4.
		    { exact (add_SNo_Lt2 y0 r3 m4 Hy0S Hr3S Hm4S Hr3m4S). }
		    claim HrhsEq: add_SNo y0 m4 = d0.
		    { prove add_SNo y0 m4 = d0.
		      claim Hmy0S: SNo (minus_SNo y0).
		      { exact (SNo_minus_SNo y0 Hy0S). }
		      rewrite (add_SNo_com y0 m4 Hy0S Hm4S).
		      rewrite <- (add_SNo_assoc d0 (minus_SNo y0) y0 Hd0S Hmy0S Hy0S) at 1.
		      claim Hinv: add_SNo (minus_SNo y0) y0 = 0.
		      { exact (add_SNo_minus_SNo_linv y0 Hy0S). }
		      rewrite Hinv at 1.
		      exact (add_SNo_0R d0 Hd0S). }
		    prove add_SNo y0 r3 < d0.
		    rewrite <- HrhsEq.
		    exact Htmp. }

		  claim Hy0r3S: SNo (add_SNo y0 r3).
		  { exact (real_SNo (add_SNo y0 r3) (real_add_SNo y0 Hy0R r3 Hr3R)). }
		  claim HypLt_d0S: yp < d0.
		  { exact (SNoLt_tra yp (add_SNo y0 r3) d0 HypS Hy0r3S Hd0S HypLt_y0r3 Hy0r3Lt_d0). }
		  claim HypLt_d0: Rlt yp d0.
		  { exact (RltI yp d0 HypR Hd0R HypLt_d0S). }

		  (** c < yp via (c+r3) < y0 < (yp+r3) and cancellation **)
		  claim Hr3m3Lt: r3 < m3.
		  { exact Hr3m3S. }
		  claim Hcr3Lt_cm3: add_SNo c r3 < add_SNo c m3.
		  { exact (add_SNo_Lt2 c r3 m3 HcS Hr3S Hm3S Hr3m3Lt). }
		  claim Hcm3Eq: add_SNo c m3 = y0.
		  { prove add_SNo c m3 = y0.
		    claim HmcS: SNo (minus_SNo c).
		    { exact (SNo_minus_SNo c HcS). }
		    claim Hassoc1: add_SNo c (add_SNo y0 (minus_SNo c)) = add_SNo (add_SNo c y0) (minus_SNo c).
		    { exact (add_SNo_assoc c y0 (minus_SNo c) HcS Hy0S HmcS). }
		    claim Hcom1: add_SNo c y0 = add_SNo y0 c.
		    { exact (add_SNo_com c y0 HcS Hy0S). }
		    claim Hassoc2: add_SNo (add_SNo y0 c) (minus_SNo c) = add_SNo y0 (add_SNo c (minus_SNo c)).
		    { symmetry.
		      exact (add_SNo_assoc y0 c (minus_SNo c) Hy0S HcS HmcS). }
			    claim Hinv: add_SNo c (minus_SNo c) = 0.
			    { exact (add_SNo_minus_SNo_rinv c HcS). }
			    prove add_SNo c m3 = y0.
			    claim Hm3Def: m3 = add_SNo y0 (minus_SNo c).
			    { reflexivity. }
			    rewrite Hm3Def.
			    rewrite Hassoc1.
			    rewrite Hcom1.
			    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R y0 Hy0S). }
		  claim Hcr3Lt_y0: add_SNo c r3 < y0.
		  { prove add_SNo c r3 < y0.
		    rewrite <- Hcm3Eq.
		    exact Hcr3Lt_cm3. }
		  claim Hcr3S: SNo (add_SNo c r3).
		  { exact (real_SNo (add_SNo c r3) (real_add_SNo c HcR r3 Hr3R)). }
		  claim Hypr3S: SNo (add_SNo yp r3).
		  { exact (real_SNo (add_SNo yp r3) (real_add_SNo yp HypR r3 Hr3R)). }
		  claim Hcr3Lt_ypr3: add_SNo c r3 < add_SNo yp r3.
		  { exact (SNoLt_tra (add_SNo c r3) y0 (add_SNo yp r3) Hcr3S Hy0S Hypr3S Hcr3Lt_y0 Hy0Lt_ypr3). }
		  claim HcancelLc: add_SNo (minus_SNo r3) (add_SNo c r3) = c.
		  { claim Hassoc1: add_SNo (minus_SNo r3) (add_SNo c r3) = add_SNo (add_SNo (minus_SNo r3) c) r3.
		    { exact (add_SNo_assoc (minus_SNo r3) c r3 Hmr3S HcS Hr3S). }
		    claim Hcom1: add_SNo (minus_SNo r3) c = add_SNo c (minus_SNo r3).
		    { exact (add_SNo_com (minus_SNo r3) c Hmr3S HcS). }
		    claim Hassoc2: add_SNo (add_SNo c (minus_SNo r3)) r3 = add_SNo c (add_SNo (minus_SNo r3) r3).
		    { symmetry.
		      exact (add_SNo_assoc c (minus_SNo r3) r3 HcS Hmr3S Hr3S). }
		    claim Hinv: add_SNo (minus_SNo r3) r3 = 0.
		    { exact (add_SNo_minus_SNo_linv r3 Hr3S). }
		    rewrite Hassoc1.
		    rewrite Hcom1.
		    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R c HcS). }
		  claim HcancelRyp: add_SNo (minus_SNo r3) (add_SNo yp r3) = yp.
		  { claim Hassoc1: add_SNo (minus_SNo r3) (add_SNo yp r3) = add_SNo (add_SNo (minus_SNo r3) yp) r3.
		    { exact (add_SNo_assoc (minus_SNo r3) yp r3 Hmr3S HypS Hr3S). }
		    claim Hcom1: add_SNo (minus_SNo r3) yp = add_SNo yp (minus_SNo r3).
		    { exact (add_SNo_com (minus_SNo r3) yp Hmr3S HypS). }
		    claim Hassoc2: add_SNo (add_SNo yp (minus_SNo r3)) r3 = add_SNo yp (add_SNo (minus_SNo r3) r3).
		    { symmetry.
		      exact (add_SNo_assoc yp (minus_SNo r3) r3 HypS Hmr3S Hr3S). }
		    claim Hinv: add_SNo (minus_SNo r3) r3 = 0.
		    { exact (add_SNo_minus_SNo_linv r3 Hr3S). }
		    rewrite Hassoc1.
		    rewrite Hcom1.
		    rewrite Hassoc2.
		    rewrite Hinv.
		    exact (add_SNo_0R yp HypS). }
		  claim HtmpCy: add_SNo (minus_SNo r3) (add_SNo c r3) < add_SNo (minus_SNo r3) (add_SNo yp r3).
		  { exact (add_SNo_Lt2 (minus_SNo r3) (add_SNo c r3) (add_SNo yp r3) Hmr3S Hcr3S Hypr3S Hcr3Lt_ypr3). }
		  claim HcySlt: c < yp.
		  { prove c < yp.
		    rewrite <- HcancelLc at 1.
		    rewrite <- HcancelRyp.
		    exact HtmpCy. }
		  claim HcyRlt: Rlt c yp.
		  { exact (RltI c yp HcR HypR HcySlt). }

		  claim HpEq: p = (xp,yp).
		  { prove p = (xp,yp).
		    claim Heta: (R2_xcoord p, R2_ycoord p) = p.
		    { exact (EuclidPlane_eta p HpE). }
		    claim HxpEq: R2_xcoord p = xp.
		    { symmetry.
		      exact HxpDef. }
		    claim HypEq: R2_ycoord p = yp.
		    { symmetry.
		      exact HypDef. }
		    symmetry.
		    rewrite HxpEq at 1.
		    rewrite HypEq at 1.
		    exact Heta. }

		  claim HpProp:
		    exists x1 y1:set,
		      p = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b0 /\ Rlt c y1 /\ Rlt y1 d0.
			  { witness xp.
			    witness yp.
			    apply and5I.
			    - exact HpEq.
			    - exact HaxRlt.
			    - exact HxpLt_b0.
			    - exact HcyRlt.
			    - exact HypLt_d0. }
		  exact (SepI EuclidPlane
		              (fun p0 : set =>
		                exists x1 y1:set,
		                  p0 = (x1,y1) /\ Rlt a x1 /\ Rlt x1 b0 /\ Rlt c y1 /\ Rlt y1 d0)
		              p
		              HpE
		              HpProp).
Qed.

(** from §13 Example 4: circular regions form a basis on EuclidPlane **)
(** LATEX VERSION: The family of circular regions is a basis for a topology on R^2. **)
Theorem circular_regions_basis_plane : basis_on EuclidPlane circular_regions.
prove basis_on EuclidPlane circular_regions.
(** basis_on has three clauses: subset, cover, intersection refinement **)
prove circular_regions c= Power EuclidPlane
  /\ (forall x :e EuclidPlane, exists b :e circular_regions, x :e b)
  /\ (forall b1 :e circular_regions, forall b2 :e circular_regions, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e circular_regions, x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- let U. assume HU: U :e circular_regions.
  prove U :e Power EuclidPlane.
  exact (SepE1 (Power EuclidPlane)
               (fun U0 : set => exists c:set, exists r:set,
                 c :e EuclidPlane /\ Rlt 0 r /\
                 U0 = {p :e EuclidPlane|Rlt (distance_R2 p c) r})
               U
               HU).
- prove forall x :e EuclidPlane, exists b :e circular_regions, x :e b.
  let x. assume Hx.
  witness {p :e EuclidPlane|Rlt (distance_R2 p x) 1}.
  apply andI.
  * prove {p :e EuclidPlane|Rlt (distance_R2 p x) 1} :e circular_regions.
    exact (circular_regionI x 1 Hx Rlt_0_1).
  * claim Hlt : Rlt (distance_R2 x x) 1.
    { rewrite (distance_R2_refl_0 x Hx).
      claim HR : 0 :e R /\ 1 :e R /\ 0 < 1.
      { apply and3I.
        - exact real_0.
        - exact real_1.
        - exact SNoLt_0_1. }
      exact HR. }
    exact (SepI EuclidPlane
                (fun p0 : set => Rlt (distance_R2 p0 x) 1)
                x
                Hx
                Hlt).
- (** intersection refinement for circular regions **)
  let b1. assume Hb1 : b1 :e circular_regions.
  let b2. assume Hb2 : b2 :e circular_regions.
  let x. assume Hx1 : x :e b1. assume Hx2 : x :e b2.
  prove exists b3 :e circular_regions, x :e b3 /\ b3 c= b1 :/\: b2.
	  claim Hb1prop :
	    exists c1:set, exists r1:set,
	      c1 :e EuclidPlane /\ Rlt 0 r1 /\
	      b1 = {p :e EuclidPlane|Rlt (distance_R2 p c1) r1}.
	  { exact (SepE2 (Power EuclidPlane)
	                 (fun U0 : set => exists c:set, exists r:set,
	                   c :e EuclidPlane /\ Rlt 0 r /\
	                   U0 = {p :e EuclidPlane|Rlt (distance_R2 p c) r})
	                 b1
	                 Hb1). }
	  claim Hb2prop :
	    exists c2:set, exists r2:set,
	      c2 :e EuclidPlane /\ Rlt 0 r2 /\
	      b2 = {p :e EuclidPlane|Rlt (distance_R2 p c2) r2}.
	  { exact (SepE2 (Power EuclidPlane)
	                 (fun U0 : set => exists c:set, exists r:set,
	                   c :e EuclidPlane /\ Rlt 0 r /\
	                   U0 = {p :e EuclidPlane|Rlt (distance_R2 p c) r})
	                 b2
	                 Hb2). }
	  apply Hb1prop.
	  let c1. assume Hb1prop2.
	  apply Hb1prop2.
	  let r1. assume Hb1core.
	  apply Hb2prop.
	  let c2. assume Hb2prop2.
		  apply Hb2prop2.
		  let r2. assume Hb2core.
		  claim Hc1r1 : c1 :e EuclidPlane /\ Rlt 0 r1.
		  { exact (andEL (c1 :e EuclidPlane /\ Rlt 0 r1)
		                (b1 = {p :e EuclidPlane|Rlt (distance_R2 p c1) r1})
		                Hb1core). }
		  claim Hc1 : c1 :e EuclidPlane.
		  { exact (andEL (c1 :e EuclidPlane) (Rlt 0 r1) Hc1r1). }
		  claim Hr1 : Rlt 0 r1.
		  { exact (andER (c1 :e EuclidPlane) (Rlt 0 r1) Hc1r1). }
		  claim Hb1eq : b1 = {p :e EuclidPlane|Rlt (distance_R2 p c1) r1}.
		  { exact (andER (c1 :e EuclidPlane /\ Rlt 0 r1)
		                (b1 = {p :e EuclidPlane|Rlt (distance_R2 p c1) r1})
		                Hb1core). }
		  claim Hc2r2 : c2 :e EuclidPlane /\ Rlt 0 r2.
		  { exact (andEL (c2 :e EuclidPlane /\ Rlt 0 r2)
		                (b2 = {p :e EuclidPlane|Rlt (distance_R2 p c2) r2})
		                Hb2core). }
		  claim Hc2 : c2 :e EuclidPlane.
		  { exact (andEL (c2 :e EuclidPlane) (Rlt 0 r2) Hc2r2). }
		  claim Hr2 : Rlt 0 r2.
		  { exact (andER (c2 :e EuclidPlane) (Rlt 0 r2) Hc2r2). }
		  claim Hb2eq : b2 = {p :e EuclidPlane|Rlt (distance_R2 p c2) r2}.
		  { exact (andER (c2 :e EuclidPlane /\ Rlt 0 r2)
		                (b2 = {p :e EuclidPlane|Rlt (distance_R2 p c2) r2})
		                Hb2core). }
	  claim Hx1' : x :e {p :e EuclidPlane|Rlt (distance_R2 p c1) r1}.
	  { rewrite <- Hb1eq. exact Hx1. }
	  claim Hx2' : x :e {p :e EuclidPlane|Rlt (distance_R2 p c2) r2}.
	  { rewrite <- Hb2eq. exact Hx2. }
	  claim HxEuclid : x :e EuclidPlane.
	  { exact (SepE1 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c1) r1) x Hx1'). }
	  claim Hxball1 : Rlt (distance_R2 x c1) r1.
	  { exact (SepE2 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c1) r1) x Hx1'). }
	  claim Hxball2 : Rlt (distance_R2 x c2) r2.
	  { exact (SepE2 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c2) r2) x Hx2'). }

		  (** Metric refinement lemma for EuclidPlane balls around x **)
			  apply (ball_refine_two_balls x c1 c2 r1 r2 HxEuclid Hc1 Hc2 Hr1 Hr2 Hxball1 Hxball2).
			  let r3. assume Hrefine2.
	  claim Hr3 : Rlt 0 r3.
	  { exact (andEL (Rlt 0 r3)
	                (forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2)
	                Hrefine2). }
	  claim HrefineP :
	    forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2.
	  { exact (andER (Rlt 0 r3)
	                (forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2)
	                Hrefine2). }

		  set b3 := {p :e EuclidPlane|Rlt (distance_R2 p x) r3}.
		  witness b3.
		  apply andI.
		  - prove b3 :e circular_regions.
		    claim Hb3def : b3 = {p :e EuclidPlane|Rlt (distance_R2 p x) r3}.
		    { reflexivity. }
		    rewrite Hb3def.
		    exact (circular_regionI x r3 HxEuclid Hr3).
		  - apply andI.
	    + prove x :e b3.
	      claim Hdx : Rlt (distance_R2 x x) r3.
	      { rewrite (distance_R2_refl_0 x HxEuclid).
	        exact Hr3. }
	      exact (SepI EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) x HxEuclid Hdx).
	    + prove b3 c= b1 :/\: b2.
	      let p. assume Hp3 : p :e b3.
	      prove p :e b1 :/\: b2.
	      claim HpE : p :e EuclidPlane.
	      { exact (SepE1 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) p Hp3). }
	      claim Hpball : Rlt (distance_R2 p x) r3.
	      { exact (SepE2 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) p Hp3). }
	      claim Hboth : Rlt (distance_R2 p c1) r1 /\ Rlt (distance_R2 p c2) r2.
	      { exact (HrefineP p HpE Hpball). }
	      claim Hpball1 : Rlt (distance_R2 p c1) r1.
	      { exact (andEL (Rlt (distance_R2 p c1) r1) (Rlt (distance_R2 p c2) r2) Hboth). }
	      claim Hpball2 : Rlt (distance_R2 p c2) r2.
	      { exact (andER (Rlt (distance_R2 p c1) r1) (Rlt (distance_R2 p c2) r2) Hboth). }
	      claim Hpb1 : p :e b1.
	      { rewrite Hb1eq.
	        exact (SepI EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c1) r1) p HpE Hpball1). }
	      claim Hpb2 : p :e b2.
	      { rewrite Hb2eq.
	        exact (SepI EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c2) r2) p HpE Hpball2). }
	      exact (binintersectI b1 b2 p Hpb1 Hpb2).
Qed.

(** from §13 Example 4: rectangular regions form a basis on EuclidPlane **)
(** LATEX VERSION: The family of axis-parallel open rectangles is a basis for a topology on R^2. **)
Theorem rectangular_regions_basis_plane : basis_on EuclidPlane rectangular_regions.
prove basis_on EuclidPlane rectangular_regions.
prove rectangular_regions c= Power EuclidPlane
  /\ (forall x :e EuclidPlane, exists b :e rectangular_regions, x :e b)
  /\ (forall b1 :e rectangular_regions, forall b2 :e rectangular_regions, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e rectangular_regions, x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- let U. assume HU: U :e rectangular_regions.
  prove U :e Power EuclidPlane.
  exact (SepE1 (Power EuclidPlane)
               (fun U0 : set =>
                 exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
                   U0 = {p :e EuclidPlane|
                          exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d})
               U
               HU).
- prove forall p :e EuclidPlane, exists b :e rectangular_regions, p :e b.
  let p. assume Hp : p :e EuclidPlane.
  apply (Sigma_E R (fun _ : set => R) p Hp).
  let x. assume Hx_pair.
  apply Hx_pair.
  assume HxR Hexy.
  apply Hexy.
  let y. assume Hy_pair.
  apply Hy_pair.
  assume HyR Hpeq.
  set a := add_SNo x (minus_SNo 1).
  set b := add_SNo x 1.
  set c := add_SNo y (minus_SNo 1).
  set d := add_SNo y 1.
  set U := {p0 :e EuclidPlane|
              exists x0:set, exists y0:set,
                p0 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d}.
  witness U.
  apply andI.
  - prove U :e rectangular_regions.
    claim HxS : SNo x.
    { exact (real_SNo x HxR). }
    claim HyS : SNo y.
    { exact (real_SNo y HyR). }
    claim Hm1R : minus_SNo 1 :e R.
    { exact (real_minus_SNo 1 real_1). }
    claim Hm1S : SNo (minus_SNo 1).
    { exact (real_SNo (minus_SNo 1) Hm1R). }
    claim HaR : a :e R.
    { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
    claim HbR : b :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim HcR : c :e R.
    { exact (real_add_SNo y HyR (minus_SNo 1) Hm1R). }
    claim HdR : d :e R.
    { exact (real_add_SNo y HyR 1 real_1). }
    claim Hm1lt1 : minus_SNo 1 < 1.
    { exact (SNoLt_tra (minus_SNo 1) 0 1 Hm1S SNo_0 SNo_1 minus_1_lt_0 SNoLt_0_1). }
    claim Hablt : a < b.
    { exact (add_SNo_Lt2 x (minus_SNo 1) 1 HxS Hm1S SNo_1 Hm1lt1). }
    claim Hcdlt : c < d.
    { exact (add_SNo_Lt2 y (minus_SNo 1) 1 HyS Hm1S SNo_1 Hm1lt1). }
    claim HabRlt : Rlt a b.
    { exact (RltI a b HaR HbR Hablt). }
    claim HcdRlt : Rlt c d.
    { exact (RltI c d HcR HdR Hcdlt). }
    claim HUdef :
      U = {p0 :e EuclidPlane|
             exists x0:set, exists y0:set,
               p0 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d}.
    { reflexivity. }
    rewrite HUdef.
    exact (rectangular_regionI a b c d HaR HbR HcR HdR HabRlt HcdRlt).
  - prove p :e U.
    claim Hptup : p = (x,y).
    { rewrite Hpeq. exact (tuple_pair x y). }
    claim HaR : a :e R.
    { exact (real_add_SNo x HxR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
    claim HbR : b :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim HcR : c :e R.
    { exact (real_add_SNo y HyR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
    claim HdR : d :e R.
    { exact (real_add_SNo y HyR 1 real_1). }
    claim HxS : SNo x.
    { exact (real_SNo x HxR). }
    claim HyS : SNo y.
    { exact (real_SNo y HyR). }
    claim Hm1S : SNo (minus_SNo 1).
    { exact (real_SNo (minus_SNo 1) (real_minus_SNo 1 real_1)). }
    claim Hx0eq : add_SNo x 0 = x.
    { exact (add_SNo_0R x HxS). }
    claim Hy0eq : add_SNo y 0 = y.
    { exact (add_SNo_0R y HyS). }
    claim Haxlt0 : add_SNo x (minus_SNo 1) < add_SNo x 0.
    { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
    claim Haxlt : a < x.
    { rewrite <- Hx0eq at 2. exact Haxlt0. }
    claim Hxltb0 : add_SNo x 0 < add_SNo x 1.
    { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
    claim Hxltb : x < b.
    { rewrite <- Hx0eq at 1. exact Hxltb0. }
    claim Hcylt0 : add_SNo y (minus_SNo 1) < add_SNo y 0.
    { exact (add_SNo_Lt2 y (minus_SNo 1) 0 HyS Hm1S SNo_0 minus_1_lt_0). }
    claim Hcylt : c < y.
    { rewrite <- Hy0eq at 2. exact Hcylt0. }
    claim HyLtd0 : add_SNo y 0 < add_SNo y 1.
    { exact (add_SNo_Lt2 y 0 1 HyS SNo_0 SNo_1 SNoLt_0_1). }
    claim HyLtd : y < d.
    { rewrite <- Hy0eq at 1. exact HyLtd0. }
    claim HaRltx : Rlt a x.
    { exact (RltI a x HaR HxR Haxlt). }
    claim HxRltb : Rlt x b.
    { exact (RltI x b HxR HbR Hxltb). }
    claim HcRlty : Rlt c y.
    { exact (RltI c y HcR HyR Hcylt). }
    claim HyRltd : Rlt y d.
    { exact (RltI y d HyR HdR HyLtd). }
    claim Hpred :
      exists x0:set, exists y0:set,
        p = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d.
    { witness x. witness y.
      claim H1 : p = (x,y) /\ Rlt a x.
      { exact (andI (p = (x,y)) (Rlt a x) Hptup HaRltx). }
      claim H12 : (p = (x,y) /\ Rlt a x) /\ Rlt x b.
      { exact (andI (p = (x,y) /\ Rlt a x) (Rlt x b) H1 HxRltb). }
      claim H123 : ((p = (x,y) /\ Rlt a x) /\ Rlt x b) /\ Rlt c y.
      { exact (andI ((p = (x,y) /\ Rlt a x) /\ Rlt x b) (Rlt c y) H12 HcRlty). }
      exact (andI (((p = (x,y) /\ Rlt a x) /\ Rlt x b) /\ Rlt c y)
                 (Rlt y d)
                 H123
                 HyRltd). }
    exact (SepI EuclidPlane
                (fun p1 : set =>
                  exists x0:set, exists y0:set,
                    p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d)
                p
                Hp
                Hpred).
  - let b1. assume Hb1 : b1 :e rectangular_regions.
    let b2. assume Hb2 : b2 :e rectangular_regions.
    let p. assume Hp1 : p :e b1. assume Hp2 : p :e b2.
    prove exists b3 :e rectangular_regions, p :e b3 /\ b3 c= b1 :/\: b2.
    (** Unpack b1 as a rectangle with parameters a1,b1x,c1,d1 **)
    claim Hb1prop :
      exists a1:set, exists b1x:set, exists c1:set, exists d1:set,
        a1 :e R /\ b1x :e R /\ c1 :e R /\ d1 :e R /\ Rlt a1 b1x /\ Rlt c1 d1 /\
          b1 = {q :e EuclidPlane|
                  exists x0:set, exists y0:set,
                    q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1}.
    { exact (SepE2 (Power EuclidPlane)
                   (fun U0 : set =>
                     exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
                       U0 = {p1 :e EuclidPlane|
                              exists x0:set, exists y0:set,
                                p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d})
                   b1
                   Hb1). }
    apply Hb1prop.
    let a1. assume Hb1prop2.
    apply Hb1prop2.
    let b1x. assume Hb1prop3.
    apply Hb1prop3.
    let c1. assume Hb1prop4.
    apply Hb1prop4.
    let d1. assume Hb1core.
    (** Unpack b2 similarly **)
    claim Hb2prop :
      exists a2:set, exists b2x:set, exists c2:set, exists d2:set,
        a2 :e R /\ b2x :e R /\ c2 :e R /\ d2 :e R /\ Rlt a2 b2x /\ Rlt c2 d2 /\
          b2 = {q :e EuclidPlane|
                  exists x0:set, exists y0:set,
                    q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2}.
    { exact (SepE2 (Power EuclidPlane)
                   (fun U0 : set =>
                     exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
                       U0 = {p1 :e EuclidPlane|
                              exists x0:set, exists y0:set,
                                p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d})
                   b2
                   Hb2). }
    apply Hb2prop.
    let a2. assume Hb2prop2.
    apply Hb2prop2.
    let b2x. assume Hb2prop3.
    apply Hb2prop3.
    let c2. assume Hb2prop4.
    apply Hb2prop4.
    let d2. assume Hb2core.
    (** Extract equations and point coordinates from membership hypotheses Hp1 and Hp2 **)
    claim Hb1eq :
      b1 = {q :e EuclidPlane|
              exists x0:set, exists y0:set,
                q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1}.
    { exact (andER (a1 :e R /\ b1x :e R /\ c1 :e R /\ d1 :e R /\ Rlt a1 b1x /\ Rlt c1 d1)
                  (b1 = {q :e EuclidPlane|
                          exists x0:set, exists y0:set,
                            q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1})
                  Hb1core). }
    claim Hb2eq :
      b2 = {q :e EuclidPlane|
              exists x0:set, exists y0:set,
                q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2}.
    { exact (andER (a2 :e R /\ b2x :e R /\ c2 :e R /\ d2 :e R /\ Rlt a2 b2x /\ Rlt c2 d2)
                  (b2 = {q :e EuclidPlane|
                          exists x0:set, exists y0:set,
                            q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2})
                  Hb2core). }
    claim Hp1' : p :e {q :e EuclidPlane|
                        exists x0:set, exists y0:set,
                          q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1}.
    { rewrite <- Hb1eq. exact Hp1. }
    claim Hp2' : p :e {q :e EuclidPlane|
                        exists x0:set, exists y0:set,
                          q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2}.
    { rewrite <- Hb2eq. exact Hp2. }
    claim Hp1coords :
      exists x1:set, exists y1:set,
        p = (x1,y1) /\ Rlt a1 x1 /\ Rlt x1 b1x /\ Rlt c1 y1 /\ Rlt y1 d1.
    { exact (SepE2 EuclidPlane
                   (fun q : set =>
                     exists x0:set, exists y0:set,
                       q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1)
                   p
                   Hp1'). }
    claim Hp2coords :
      exists x2:set, exists y2:set,
        p = (x2,y2) /\ Rlt a2 x2 /\ Rlt x2 b2x /\ Rlt c2 y2 /\ Rlt y2 d2.
    { exact (SepE2 EuclidPlane
                   (fun q : set =>
                     exists x0:set, exists y0:set,
                       q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2)
                   p
                   Hp2'). }
    (** Reduce to the usual coordinate inequalities at p **)
    apply Hp1coords.
    let x1. assume Hp1coords2.
    apply Hp1coords2.
    let y1. assume Hp1ineq.
    apply Hp2coords.
    let x2. assume Hp2coords2.
    apply Hp2coords2.
    let y2. assume Hp2ineq.
    (** Identify x1=x2 and y1=y2 via tuple equality **)
    claim Hp_tup1 : p = (x1,y1).
    { claim H1 : (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1).
      { exact (andEL (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1)
                    (Rlt y1 d1)
                    Hp1ineq). }
      claim H2 : ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x).
      { exact (andEL ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x)
                    (Rlt c1 y1)
                    H1). }
      claim H3 : (p = (x1,y1) /\ Rlt a1 x1).
      { exact (andEL (p = (x1,y1) /\ Rlt a1 x1)
                    (Rlt x1 b1x)
                    H2). }
      exact (andEL (p = (x1,y1)) (Rlt a1 x1) H3). }
    claim Hp_tup2 : p = (x2,y2).
    { claim H1 : (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2).
      { exact (andEL (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2)
                    (Rlt y2 d2)
                    Hp2ineq). }
      claim H2 : ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x).
      { exact (andEL ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x)
                    (Rlt c2 y2)
                    H1). }
      claim H3 : (p = (x2,y2) /\ Rlt a2 x2).
      { exact (andEL (p = (x2,y2) /\ Rlt a2 x2)
                    (Rlt x2 b2x)
                    H2). }
      exact (andEL (p = (x2,y2)) (Rlt a2 x2) H3). }
    claim Heq12 : (x1,y1) = (x2,y2).
    { rewrite <- Hp_tup1. rewrite <- Hp_tup2. reflexivity. }
    claim Hcoords : x1 = x2 /\ y1 = y2.
    { exact (tuple_eq_coords_R2 x1 y1 x2 y2 Heq12). }
    (** At this point we have x1,y1 and inequalities from both rectangles; the remaining task is to pick new endpoints a3,b3,c3,d3 giving a rectangle around (x1,y1) contained in the intersection. **)
    claim Hx1eq : x1 = x2.
    { exact (andEL (x1 = x2) (y1 = y2) Hcoords). }
    claim Hy1eq : y1 = y2.
    { exact (andER (x1 = x2) (y1 = y2) Hcoords). }

    (** Extract coordinate inequalities for p from Hp1ineq and Hp2ineq **)
    claim Ha1x1 : Rlt a1 x1.
    { claim H1 : (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1).
      { exact (andEL (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1)
                    (Rlt y1 d1)
                    Hp1ineq). }
      claim H2 : ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x).
      { exact (andEL ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x)
                    (Rlt c1 y1)
                    H1). }
      claim H3 : (p = (x1,y1) /\ Rlt a1 x1).
      { exact (andEL (p = (x1,y1) /\ Rlt a1 x1)
                    (Rlt x1 b1x)
                    H2). }
      exact (andER (p = (x1,y1)) (Rlt a1 x1) H3). }
    claim Hx1b1 : Rlt x1 b1x.
    { claim H1 : (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1).
      { exact (andEL (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1)
                    (Rlt y1 d1)
                    Hp1ineq). }
      claim H2 : ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x).
      { exact (andEL ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x)
                    (Rlt c1 y1)
                    H1). }
      exact (andER (p = (x1,y1) /\ Rlt a1 x1) (Rlt x1 b1x) H2). }
    claim Hc1y1 : Rlt c1 y1.
    { claim H1 : (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1).
      { exact (andEL (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1)
                    (Rlt y1 d1)
                    Hp1ineq). }
      exact (andER ((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) (Rlt c1 y1) H1). }
    claim Hy1d1 : Rlt y1 d1.
    { exact (andER (((p = (x1,y1) /\ Rlt a1 x1) /\ Rlt x1 b1x) /\ Rlt c1 y1) (Rlt y1 d1) Hp1ineq). }

    claim Ha2x2 : Rlt a2 x2.
    { claim H1 : (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2).
      { exact (andEL (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2)
                    (Rlt y2 d2)
                    Hp2ineq). }
      claim H2 : ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x).
      { exact (andEL ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x)
                    (Rlt c2 y2)
                    H1). }
      claim H3 : (p = (x2,y2) /\ Rlt a2 x2).
      { exact (andEL (p = (x2,y2) /\ Rlt a2 x2)
                    (Rlt x2 b2x)
                    H2). }
      exact (andER (p = (x2,y2)) (Rlt a2 x2) H3). }
    claim Hx2b2 : Rlt x2 b2x.
    { claim H1 : (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2).
      { exact (andEL (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2)
                    (Rlt y2 d2)
                    Hp2ineq). }
      claim H2 : ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x).
      { exact (andEL ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x)
                    (Rlt c2 y2)
                    H1). }
      exact (andER (p = (x2,y2) /\ Rlt a2 x2) (Rlt x2 b2x) H2). }
    claim Hc2y2 : Rlt c2 y2.
    { claim H1 : (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2).
      { exact (andEL (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2)
                    (Rlt y2 d2)
                    Hp2ineq). }
      exact (andER ((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) (Rlt c2 y2) H1). }
    claim Hy2d2 : Rlt y2 d2.
    { exact (andER (((p = (x2,y2) /\ Rlt a2 x2) /\ Rlt x2 b2x) /\ Rlt c2 y2) (Rlt y2 d2) Hp2ineq). }

    (** Rewrite the second rectangle inequalities to x1,y1 **)
    claim Ha2x1 : Rlt a2 x1.
    { rewrite Hx1eq. exact Ha2x2. }
    claim Hx1b2 : Rlt x1 b2x.
    { rewrite Hx1eq at 1. exact Hx2b2. }
    claim Hc2y1 : Rlt c2 y1.
    { rewrite Hy1eq. exact Hc2y2. }
    claim Hy1d2 : Rlt y1 d2.
    { rewrite Hy1eq at 1. exact Hy2d2. }

    (** Define endpoints as max/min choices using if-then-else **)
    set a3 := if a1 < a2 then a2 else a1.
    set b3x := if b1x < b2x then b1x else b2x.
    set c3 := if c1 < c2 then c2 else c1.
    set d3 := if d1 < d2 then d1 else d2.

    claim Ha3def : a3 = if a1 < a2 then a2 else a1.
    { reflexivity. }
    claim Hb3def : b3x = if b1x < b2x then b1x else b2x.
    { reflexivity. }
    claim Hc3def : c3 = if c1 < c2 then c2 else c1.
    { reflexivity. }
    claim Hd3def : d3 = if d1 < d2 then d1 else d2.
    { reflexivity. }

    (** Extract endpoint realness once from Hb1core and Hb2core **)
    claim Hb1params :
      a1 :e R /\ b1x :e R /\ c1 :e R /\ d1 :e R /\ Rlt a1 b1x /\ Rlt c1 d1.
    { exact (andEL (a1 :e R /\ b1x :e R /\ c1 :e R /\ d1 :e R /\ Rlt a1 b1x /\ Rlt c1 d1)
                  (b1 = {q :e EuclidPlane|
                          exists x0:set, exists y0:set,
                            q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1})
                  Hb1core). }
    claim Hb2params :
      a2 :e R /\ b2x :e R /\ c2 :e R /\ d2 :e R /\ Rlt a2 b2x /\ Rlt c2 d2.
    { exact (andEL (a2 :e R /\ b2x :e R /\ c2 :e R /\ d2 :e R /\ Rlt a2 b2x /\ Rlt c2 d2)
                  (b2 = {q :e EuclidPlane|
                          exists x0:set, exists y0:set,
                            q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2})
                  Hb2core). }

    claim Hb1left : ((((a1 :e R /\ b1x :e R) /\ c1 :e R) /\ d1 :e R) /\ Rlt a1 b1x).
    { exact (andEL ((((a1 :e R /\ b1x :e R) /\ c1 :e R) /\ d1 :e R) /\ Rlt a1 b1x)
                  (Rlt c1 d1)
                  Hb1params). }
    claim Hb2left : ((((a2 :e R /\ b2x :e R) /\ c2 :e R) /\ d2 :e R) /\ Rlt a2 b2x).
    { exact (andEL ((((a2 :e R /\ b2x :e R) /\ c2 :e R) /\ d2 :e R) /\ Rlt a2 b2x)
                  (Rlt c2 d2)
                  Hb2params). }

    claim Ha1b1x_c1_d1 : (((a1 :e R /\ b1x :e R) /\ c1 :e R) /\ d1 :e R).
    { exact (andEL (((a1 :e R /\ b1x :e R) /\ c1 :e R) /\ d1 :e R)
                  (Rlt a1 b1x)
                  Hb1left). }
    claim Ha2b2x_c2_d2 : (((a2 :e R /\ b2x :e R) /\ c2 :e R) /\ d2 :e R).
    { exact (andEL (((a2 :e R /\ b2x :e R) /\ c2 :e R) /\ d2 :e R)
                  (Rlt a2 b2x)
                  Hb2left). }

    claim Ha1b1x_c1 : ((a1 :e R /\ b1x :e R) /\ c1 :e R).
    { exact (andEL ((a1 :e R /\ b1x :e R) /\ c1 :e R)
                  (d1 :e R)
                  Ha1b1x_c1_d1). }
    claim Ha2b2x_c2 : ((a2 :e R /\ b2x :e R) /\ c2 :e R).
    { exact (andEL ((a2 :e R /\ b2x :e R) /\ c2 :e R)
                  (d2 :e R)
                  Ha2b2x_c2_d2). }

    claim Ha1b1x : a1 :e R /\ b1x :e R.
    { exact (andEL (a1 :e R /\ b1x :e R) (c1 :e R) Ha1b1x_c1). }
    claim Ha2b2x : a2 :e R /\ b2x :e R.
    { exact (andEL (a2 :e R /\ b2x :e R) (c2 :e R) Ha2b2x_c2). }

    claim Ha1R : a1 :e R.
    { exact (andEL (a1 :e R) (b1x :e R) Ha1b1x). }
    claim Hb1xR : b1x :e R.
    { exact (andER (a1 :e R) (b1x :e R) Ha1b1x). }
    claim Hc1R : c1 :e R.
    { exact (andER (a1 :e R /\ b1x :e R) (c1 :e R) Ha1b1x_c1). }
    claim Hd1R : d1 :e R.
    { exact (andER ((a1 :e R /\ b1x :e R) /\ c1 :e R) (d1 :e R) Ha1b1x_c1_d1). }

    claim Ha2R : a2 :e R.
    { exact (andEL (a2 :e R) (b2x :e R) Ha2b2x). }
    claim Hb2xR : b2x :e R.
    { exact (andER (a2 :e R) (b2x :e R) Ha2b2x). }
    claim Hc2R : c2 :e R.
    { exact (andER (a2 :e R /\ b2x :e R) (c2 :e R) Ha2b2x_c2). }
    claim Hd2R : d2 :e R.
    { exact (andER ((a2 :e R /\ b2x :e R) /\ c2 :e R) (d2 :e R) Ha2b2x_c2_d2). }

    (** Show the chosen endpoints are real numbers **)
    claim Ha3R : a3 :e R.
    { rewrite Ha3def.
      apply (xm (a1 < a2)).
      - assume Hlt. rewrite (If_i_1 (a1 < a2) a2 a1 Hlt). exact Ha2R.
      - assume Hnlt. rewrite (If_i_0 (a1 < a2) a2 a1 Hnlt). exact Ha1R. }
    claim Hb3xR : b3x :e R.
    { rewrite Hb3def.
      apply (xm (b1x < b2x)).
      - assume Hlt. rewrite (If_i_1 (b1x < b2x) b1x b2x Hlt). exact Hb1xR.
      - assume Hnlt. rewrite (If_i_0 (b1x < b2x) b1x b2x Hnlt). exact Hb2xR. }
    claim Hc3R : c3 :e R.
    { rewrite Hc3def.
      apply (xm (c1 < c2)).
      - assume Hlt. rewrite (If_i_1 (c1 < c2) c2 c1 Hlt). exact Hc2R.
      - assume Hnlt. rewrite (If_i_0 (c1 < c2) c2 c1 Hnlt). exact Hc1R. }
    claim Hd3R : d3 :e R.
    { rewrite Hd3def.
      apply (xm (d1 < d2)).
      - assume Hlt. rewrite (If_i_1 (d1 < d2) d1 d2 Hlt). exact Hd1R.
      - assume Hnlt. rewrite (If_i_0 (d1 < d2) d1 d2 Hnlt). exact Hd2R. }

    (** Show x1,y1 are between the chosen endpoints **)
    claim Hax3 : Rlt a3 x1.
    { rewrite Ha3def.
      apply (xm (a1 < a2)).
      - assume Hlt. rewrite (If_i_1 (a1 < a2) a2 a1 Hlt). exact Ha2x1.
      - assume Hnlt. rewrite (If_i_0 (a1 < a2) a2 a1 Hnlt). exact Ha1x1. }
    claim Hxb3 : Rlt x1 b3x.
    { rewrite Hb3def.
      apply (xm (b1x < b2x)).
      - assume Hlt. rewrite (If_i_1 (b1x < b2x) b1x b2x Hlt). exact Hx1b1.
      - assume Hnlt. rewrite (If_i_0 (b1x < b2x) b1x b2x Hnlt). exact Hx1b2. }
    claim Hcy3 : Rlt c3 y1.
    { rewrite Hc3def.
      apply (xm (c1 < c2)).
      - assume Hlt. rewrite (If_i_1 (c1 < c2) c2 c1 Hlt). exact Hc2y1.
      - assume Hnlt. rewrite (If_i_0 (c1 < c2) c2 c1 Hnlt). exact Hc1y1. }
    claim Hyd3 : Rlt y1 d3.
    { rewrite Hd3def.
      apply (xm (d1 < d2)).
      - assume Hlt. rewrite (If_i_1 (d1 < d2) d1 d2 Hlt). exact Hy1d1.
      - assume Hnlt. rewrite (If_i_0 (d1 < d2) d1 d2 Hnlt). exact Hy1d2. }

    (** Define the rectangle b3rect with these endpoints **)
    set b3rect := {q :e EuclidPlane|
                     exists x0:set, exists y0:set,
                       q = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3}.

    witness b3rect.
    apply andI.
    - (** b3rect in rectangular_regions **)
      claim Hb3pow : b3rect :e Power EuclidPlane.
      { apply PowerI EuclidPlane b3rect.
        let q. assume Hq : q :e b3rect.
        exact (SepE1 EuclidPlane
                     (fun q0 : set =>
                       exists x0:set, exists y0:set,
                         q0 = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3)
                     q
                     Hq). }
      claim Hab3 : Rlt a3 b3x.
      { exact (Rlt_tra a3 x1 b3x Hax3 Hxb3). }
      claim Hcd3 : Rlt c3 d3.
      { exact (Rlt_tra c3 y1 d3 Hcy3 Hyd3). }
      claim Hprop :
        exists a0:set, exists b0:set, exists c0:set, exists d0:set,
          a0 :e R /\ b0 :e R /\ c0 :e R /\ d0 :e R /\ Rlt a0 b0 /\ Rlt c0 d0 /\
            b3rect = {p1 :e EuclidPlane|
                       exists x0:set, exists y0:set,
                         p1 = (x0,y0) /\ Rlt a0 x0 /\ Rlt x0 b0 /\ Rlt c0 y0 /\ Rlt y0 d0}.
	      { witness a3. witness b3x. witness c3. witness d3.
	        apply andI.
	        - claim H12345 : a3 :e R /\ b3x :e R /\ c3 :e R /\ d3 :e R /\ Rlt a3 b3x /\ Rlt c3 d3.
	          { apply and6I.
	            + exact Ha3R.
	            + exact Hb3xR.
	            + exact Hc3R.
	            + exact Hd3R.
	            + exact Hab3.
	            + exact Hcd3. }
	          exact H12345.
	        - reflexivity. }
      exact (SepI (Power EuclidPlane)
                  (fun U0 : set =>
                    exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
                      U0 = {p1 :e EuclidPlane|
                             exists x0:set, exists y0:set,
                               p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d})
                  b3rect
                  Hb3pow
                  Hprop).
    - apply andI.
      + (** p is in b3rect **)
        claim HpEuclid : p :e EuclidPlane.
        { exact (SepE1 EuclidPlane
                     (fun q : set =>
                       exists x0:set, exists y0:set,
                         q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1)
                     p
                     Hp1'). }
        claim Hpred :
          exists x0:set, exists y0:set,
            p = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3.
	        { witness x1. witness y1.
	          apply and5I.
	          - exact Hp_tup1.
	          - exact Hax3.
	          - exact Hxb3.
	          - exact Hcy3.
	          - exact Hyd3. }
        exact (SepI EuclidPlane
                    (fun q : set =>
                      exists x0:set, exists y0:set,
                        q = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3)
                    p
                    HpEuclid
                    Hpred).
      + (** b3rect is contained in b1 ∩ b2 **)
        let q. assume Hq : q :e b3rect.
        prove q :e b1 :/\: b2.
        claim HqEuclid : q :e EuclidPlane.
        { exact (SepE1 EuclidPlane
                     (fun q0 : set =>
                       exists x0:set, exists y0:set,
                         q0 = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3)
                     q
                     Hq). }
        claim Hqcoords :
          exists xq:set, exists yq:set,
            q = (xq,yq) /\ Rlt a3 xq /\ Rlt xq b3x /\ Rlt c3 yq /\ Rlt yq d3.
        { exact (SepE2 EuclidPlane
                       (fun q0 : set =>
                         exists x0:set, exists y0:set,
                           q0 = (x0,y0) /\ Rlt a3 x0 /\ Rlt x0 b3x /\ Rlt c3 y0 /\ Rlt y0 d3)
                       q
                       Hq). }
        apply Hqcoords.
        let xq. assume Hqcoords2.
        apply Hqcoords2.
        let yq. assume Hqineq.
        claim Hqtup : q = (xq,yq).
        { claim H1 : (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq).
          { exact (andEL (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq)
                        (Rlt yq d3)
                        Hqineq). }
          claim H2 : ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x).
          { exact (andEL ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x)
                        (Rlt c3 yq)
                        H1). }
          claim H3 : (q = (xq,yq) /\ Rlt a3 xq).
          { exact (andEL (q = (xq,yq) /\ Rlt a3 xq)
                        (Rlt xq b3x)
                        H2). }
          exact (andEL (q = (xq,yq)) (Rlt a3 xq) H3). }
        claim Ha3xq : Rlt a3 xq.
        { claim H1 : (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq).
          { exact (andEL (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq)
                        (Rlt yq d3)
                        Hqineq). }
          claim H2 : ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x).
          { exact (andEL ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x)
                        (Rlt c3 yq)
                        H1). }
          claim H3 : (q = (xq,yq) /\ Rlt a3 xq).
          { exact (andEL (q = (xq,yq) /\ Rlt a3 xq)
                        (Rlt xq b3x)
                        H2). }
          exact (andER (q = (xq,yq)) (Rlt a3 xq) H3). }
        claim Hxqb3 : Rlt xq b3x.
        { claim H1 : (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq).
          { exact (andEL (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq)
                        (Rlt yq d3)
                        Hqineq). }
          claim H2 : ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x).
          { exact (andEL ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x)
                        (Rlt c3 yq)
                        H1). }
          exact (andER (q = (xq,yq) /\ Rlt a3 xq) (Rlt xq b3x) H2). }
        claim Hc3yq : Rlt c3 yq.
        { claim H1 : (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq).
          { exact (andEL (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq)
                        (Rlt yq d3)
                        Hqineq). }
          exact (andER ((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) (Rlt c3 yq) H1). }
        claim Hyqd3 : Rlt yq d3.
        { exact (andER (((q = (xq,yq) /\ Rlt a3 xq) /\ Rlt xq b3x) /\ Rlt c3 yq) (Rlt yq d3) Hqineq). }

        (** Derive inequalities needed for membership in b1 and b2 **)
        claim Haxq : Rlt a1 xq /\ Rlt a2 xq.
        { claim HxqR : xq :e R.
          { exact (RltE_right a3 xq Ha3xq). }
          claim Ha1S : SNo a1.
          { exact (real_SNo a1 Ha1R). }
          claim Ha2S : SNo a2.
          { exact (real_SNo a2 Ha2R). }
          claim Ha3xq_if : Rlt (if a1 < a2 then a2 else a1) xq.
          { rewrite <- Ha3def. exact Ha3xq. }
          apply (SNoLt_trichotomy_or_impred a1 a2 Ha1S Ha2S (Rlt a1 xq /\ Rlt a2 xq)).
          - assume Ha1lt : a1 < a2.
            claim Ha1a2 : Rlt a1 a2.
            { exact (RltI a1 a2 Ha1R Ha2R Ha1lt). }
            claim Ha2xq : Rlt a2 xq.
            { rewrite <- (If_i_1 (a1 < a2) a2 a1 Ha1lt). exact Ha3xq_if. }
            claim Ha1xq : Rlt a1 xq.
            { exact (Rlt_tra a1 a2 xq Ha1a2 Ha2xq). }
            apply andI.
            - exact Ha1xq.
            - exact Ha2xq.
          - assume Haeq : a1 = a2.
            claim Hnlt : ~(a1 < a2).
            { assume Hlt.
              claim Hlt' : a1 < a1.
              { rewrite Haeq at 2. exact Hlt. }
              exact ((SNoLt_irref a1) Hlt'). }
            claim Ha1xq : Rlt a1 xq.
            { rewrite <- (If_i_0 (a1 < a2) a2 a1 Hnlt). exact Ha3xq_if. }
            claim Ha2xq : Rlt a2 xq.
            { rewrite <- Haeq. exact Ha1xq. }
            apply andI.
            - exact Ha1xq.
            - exact Ha2xq.
          - assume Ha2lt : a2 < a1.
            claim Hnlt : ~(a1 < a2).
            { assume Hlt.
              claim Ha2S' : SNo a2.
              { exact Ha2S. }
              claim Ha1S' : SNo a1.
              { exact Ha1S. }
              claim Ha2lt2 : a2 < a2.
              { exact (SNoLt_tra a2 a1 a2 Ha2S' Ha1S' Ha2S' Ha2lt Hlt). }
              exact ((SNoLt_irref a2) Ha2lt2). }
            claim Ha2a1 : Rlt a2 a1.
            { exact (RltI a2 a1 Ha2R Ha1R Ha2lt). }
            claim Ha1xq : Rlt a1 xq.
            { rewrite <- (If_i_0 (a1 < a2) a2 a1 Hnlt). exact Ha3xq_if. }
            claim Ha2xq : Rlt a2 xq.
            { exact (Rlt_tra a2 a1 xq Ha2a1 Ha1xq). }
            apply andI.
            - exact Ha1xq.
            - exact Ha2xq. }

        claim Hxbq : Rlt xq b1x /\ Rlt xq b2x.
        { claim HxqR : xq :e R.
          { exact (RltE_left xq b3x Hxqb3). }
          claim Hb1S : SNo b1x.
          { exact (real_SNo b1x Hb1xR). }
          claim Hb2S : SNo b2x.
          { exact (real_SNo b2x Hb2xR). }
          claim HxqS : SNo xq.
          { exact (real_SNo xq HxqR). }
          claim Hxqb3_if : Rlt xq (if b1x < b2x then b1x else b2x).
          { rewrite <- Hb3def. exact Hxqb3. }
          apply (SNoLt_trichotomy_or_impred b1x b2x Hb1S Hb2S (Rlt xq b1x /\ Rlt xq b2x)).
          - assume Hb1lt : b1x < b2x.
            claim Hb1b2 : Rlt b1x b2x.
            { exact (RltI b1x b2x Hb1xR Hb2xR Hb1lt). }
            claim Hxqb1 : Rlt xq b1x.
            { rewrite <- (If_i_1 (b1x < b2x) b1x b2x Hb1lt). exact Hxqb3_if. }
            claim Hxqb2 : Rlt xq b2x.
            { exact (Rlt_tra xq b1x b2x Hxqb1 Hb1b2). }
            apply andI.
            - exact Hxqb1.
            - exact Hxqb2.
          - assume Hbeq : b1x = b2x.
            claim Hnlt : ~(b1x < b2x).
            { assume Hlt.
              claim Hlt' : b1x < b1x.
              { rewrite Hbeq at 2. exact Hlt. }
              exact ((SNoLt_irref b1x) Hlt'). }
            claim Hxqb2 : Rlt xq b2x.
            { rewrite <- (If_i_0 (b1x < b2x) b1x b2x Hnlt). exact Hxqb3_if. }
            claim Hxqb1 : Rlt xq b1x.
            { rewrite Hbeq. exact Hxqb2. }
            apply andI.
            - exact Hxqb1.
            - exact Hxqb2.
          - assume Hb2lt : b2x < b1x.
            claim Hnlt : ~(b1x < b2x).
            { assume Hlt.
              claim Hb2lt2 : b2x < b2x.
              { exact (SNoLt_tra b2x b1x b2x Hb2S Hb1S Hb2S Hb2lt Hlt). }
              exact ((SNoLt_irref b2x) Hb2lt2). }
            claim Hb2b1 : Rlt b2x b1x.
            { exact (RltI b2x b1x Hb2xR Hb1xR Hb2lt). }
            claim Hxqb2 : Rlt xq b2x.
            { rewrite <- (If_i_0 (b1x < b2x) b1x b2x Hnlt). exact Hxqb3_if. }
            claim Hxqb1 : Rlt xq b1x.
            { exact (Rlt_tra xq b2x b1x Hxqb2 Hb2b1). }
            apply andI.
            - exact Hxqb1.
            - exact Hxqb2. }

        claim Hcyq : Rlt c1 yq /\ Rlt c2 yq.
        { claim HyqR : yq :e R.
          { exact (RltE_right c3 yq Hc3yq). }
          claim Hc1S : SNo c1.
          { exact (real_SNo c1 Hc1R). }
          claim Hc2S : SNo c2.
          { exact (real_SNo c2 Hc2R). }
          claim Hc3yq_if : Rlt (if c1 < c2 then c2 else c1) yq.
          { rewrite <- Hc3def. exact Hc3yq. }
          apply (SNoLt_trichotomy_or_impred c1 c2 Hc1S Hc2S (Rlt c1 yq /\ Rlt c2 yq)).
          - assume Hc1lt : c1 < c2.
            claim Hc1c2 : Rlt c1 c2.
            { exact (RltI c1 c2 Hc1R Hc2R Hc1lt). }
            claim Hc2yq : Rlt c2 yq.
            { rewrite <- (If_i_1 (c1 < c2) c2 c1 Hc1lt). exact Hc3yq_if. }
            claim Hc1yq : Rlt c1 yq.
            { exact (Rlt_tra c1 c2 yq Hc1c2 Hc2yq). }
            apply andI.
            - exact Hc1yq.
            - exact Hc2yq.
          - assume Hceq : c1 = c2.
            claim Hnlt : ~(c1 < c2).
            { assume Hlt.
              claim Hlt' : c1 < c1.
              { rewrite Hceq at 2. exact Hlt. }
              exact ((SNoLt_irref c1) Hlt'). }
            claim Hc1yq : Rlt c1 yq.
            { rewrite <- (If_i_0 (c1 < c2) c2 c1 Hnlt). exact Hc3yq_if. }
            claim Hc2yq : Rlt c2 yq.
            { rewrite <- Hceq. exact Hc1yq. }
            apply andI.
            - exact Hc1yq.
            - exact Hc2yq.
          - assume Hc2lt : c2 < c1.
            claim Hnlt : ~(c1 < c2).
            { assume Hlt.
              claim Hc2lt2 : c2 < c2.
              { exact (SNoLt_tra c2 c1 c2 Hc2S Hc1S Hc2S Hc2lt Hlt). }
              exact ((SNoLt_irref c2) Hc2lt2). }
            claim Hc2c1 : Rlt c2 c1.
            { exact (RltI c2 c1 Hc2R Hc1R Hc2lt). }
            claim Hc1yq : Rlt c1 yq.
            { rewrite <- (If_i_0 (c1 < c2) c2 c1 Hnlt). exact Hc3yq_if. }
            claim Hc2yq : Rlt c2 yq.
            { exact (Rlt_tra c2 c1 yq Hc2c1 Hc1yq). }
            apply andI.
            - exact Hc1yq.
            - exact Hc2yq. }

        claim Hydq : Rlt yq d1 /\ Rlt yq d2.
        { claim HyqR : yq :e R.
          { exact (RltE_left yq d3 Hyqd3). }
          claim Hd1S : SNo d1.
          { exact (real_SNo d1 Hd1R). }
          claim Hd2S : SNo d2.
          { exact (real_SNo d2 Hd2R). }
          claim HyqS : SNo yq.
          { exact (real_SNo yq HyqR). }
          claim Hyqd3_if : Rlt yq (if d1 < d2 then d1 else d2).
          { rewrite <- Hd3def. exact Hyqd3. }
          apply (SNoLt_trichotomy_or_impred d1 d2 Hd1S Hd2S (Rlt yq d1 /\ Rlt yq d2)).
          - assume Hd1lt : d1 < d2.
            claim Hd1d2 : Rlt d1 d2.
            { exact (RltI d1 d2 Hd1R Hd2R Hd1lt). }
            claim Hyqd1 : Rlt yq d1.
            { rewrite <- (If_i_1 (d1 < d2) d1 d2 Hd1lt). exact Hyqd3_if. }
            claim Hyqd2 : Rlt yq d2.
            { exact (Rlt_tra yq d1 d2 Hyqd1 Hd1d2). }
            apply andI.
            - exact Hyqd1.
            - exact Hyqd2.
          - assume Hdeq : d1 = d2.
            claim Hnlt : ~(d1 < d2).
            { assume Hlt.
              claim Hlt' : d1 < d1.
              { rewrite Hdeq at 2. exact Hlt. }
              exact ((SNoLt_irref d1) Hlt'). }
            claim Hyqd2 : Rlt yq d2.
            { rewrite <- (If_i_0 (d1 < d2) d1 d2 Hnlt). exact Hyqd3_if. }
            claim Hyqd1 : Rlt yq d1.
            { rewrite Hdeq. exact Hyqd2. }
            apply andI.
            - exact Hyqd1.
            - exact Hyqd2.
          - assume Hd2lt : d2 < d1.
            claim Hnlt : ~(d1 < d2).
            { assume Hlt.
              claim Hd2lt2 : d2 < d2.
              { exact (SNoLt_tra d2 d1 d2 Hd2S Hd1S Hd2S Hd2lt Hlt). }
              exact ((SNoLt_irref d2) Hd2lt2). }
            claim Hd2d1 : Rlt d2 d1.
            { exact (RltI d2 d1 Hd2R Hd1R Hd2lt). }
            claim Hyqd2 : Rlt yq d2.
            { rewrite <- (If_i_0 (d1 < d2) d1 d2 Hnlt). exact Hyqd3_if. }
            claim Hyqd1 : Rlt yq d1.
            { exact (Rlt_tra yq d2 d1 Hyqd2 Hd2d1). }
            apply andI.
            - exact Hyqd1.
            - exact Hyqd2. }

        (** Build membership in b1 and b2 using Hb1eq and Hb2eq **)
        claim Ha1xq : Rlt a1 xq.
        { exact (andEL (Rlt a1 xq) (Rlt a2 xq) Haxq). }
        claim Ha2xq : Rlt a2 xq.
        { exact (andER (Rlt a1 xq) (Rlt a2 xq) Haxq). }
        claim Hxqb1 : Rlt xq b1x.
        { exact (andEL (Rlt xq b1x) (Rlt xq b2x) Hxbq). }
        claim Hxqb2 : Rlt xq b2x.
        { exact (andER (Rlt xq b1x) (Rlt xq b2x) Hxbq). }
        claim Hc1yq : Rlt c1 yq.
        { exact (andEL (Rlt c1 yq) (Rlt c2 yq) Hcyq). }
        claim Hc2yq : Rlt c2 yq.
        { exact (andER (Rlt c1 yq) (Rlt c2 yq) Hcyq). }
        claim Hyqd1 : Rlt yq d1.
        { exact (andEL (Rlt yq d1) (Rlt yq d2) Hydq). }
        claim Hyqd2 : Rlt yq d2.
        { exact (andER (Rlt yq d1) (Rlt yq d2) Hydq). }

        claim Hpred1 :
          exists x0:set, exists y0:set,
            q = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1.
        { witness xq. witness yq.
          claim H1 : q = (xq,yq) /\ Rlt a1 xq.
          { exact (andI (q = (xq,yq)) (Rlt a1 xq) Hqtup Ha1xq). }
          claim H12 : (q = (xq,yq) /\ Rlt a1 xq) /\ Rlt xq b1x.
          { exact (andI (q = (xq,yq) /\ Rlt a1 xq) (Rlt xq b1x) H1 Hxqb1). }
          claim H123 : ((q = (xq,yq) /\ Rlt a1 xq) /\ Rlt xq b1x) /\ Rlt c1 yq.
          { exact (andI ((q = (xq,yq) /\ Rlt a1 xq) /\ Rlt xq b1x) (Rlt c1 yq) H12 Hc1yq). }
          exact (andI (((q = (xq,yq) /\ Rlt a1 xq) /\ Rlt xq b1x) /\ Rlt c1 yq) (Rlt yq d1) H123 Hyqd1). }
        claim Hpred2 :
          exists x0:set, exists y0:set,
            q = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2.
        { witness xq. witness yq.
          claim H1 : q = (xq,yq) /\ Rlt a2 xq.
          { exact (andI (q = (xq,yq)) (Rlt a2 xq) Hqtup Ha2xq). }
          claim H12 : (q = (xq,yq) /\ Rlt a2 xq) /\ Rlt xq b2x.
          { exact (andI (q = (xq,yq) /\ Rlt a2 xq) (Rlt xq b2x) H1 Hxqb2). }
          claim H123 : ((q = (xq,yq) /\ Rlt a2 xq) /\ Rlt xq b2x) /\ Rlt c2 yq.
          { exact (andI ((q = (xq,yq) /\ Rlt a2 xq) /\ Rlt xq b2x) (Rlt c2 yq) H12 Hc2yq). }
          exact (andI (((q = (xq,yq) /\ Rlt a2 xq) /\ Rlt xq b2x) /\ Rlt c2 yq) (Rlt yq d2) H123 Hyqd2). }

        claim Hqb1 : q :e b1.
        { rewrite Hb1eq.
          exact (SepI EuclidPlane
                      (fun q0 : set =>
                        exists x0:set, exists y0:set,
                          q0 = (x0,y0) /\ Rlt a1 x0 /\ Rlt x0 b1x /\ Rlt c1 y0 /\ Rlt y0 d1)
                      q
                      HqEuclid
                      Hpred1). }
        claim Hqb2 : q :e b2.
        { rewrite Hb2eq.
          exact (SepI EuclidPlane
                      (fun q0 : set =>
                        exists x0:set, exists y0:set,
                          q0 = (x0,y0) /\ Rlt a2 x0 /\ Rlt x0 b2x /\ Rlt c2 y0 /\ Rlt y0 d2)
                      q
                      HqEuclid
                      Hpred2). }
        exact (binintersectI b1 b2 q Hqb1 Hqb2).
Qed.

(** from §13 Example 4: circular and rectangular bases generate the same topology **)
(** LATEX VERSION: The topology generated by circular regions equals the topology generated by rectangular regions in R^2. **)
(** LATEX VERSION: This is shown by local refinement in both directions: each circular neighborhood contains a rectangular one, and each rectangular neighborhood contains a circular one. **)

(** from §13 Example 4: rectangular neighborhoods inside circular neighborhoods **)
(** LATEX VERSION: For any point x in a circular region, there is an open rectangle containing x and contained in that circular region. **)
Theorem rectangular_refines_circular_plane :
  forall b :e circular_regions, forall x:set,
    x :e b -> exists r :e rectangular_regions, x :e r /\ r c= b.
let b. assume Hb.
let x. assume Hxb.
prove exists r :e rectangular_regions, x :e r /\ r c= b.
(** Unpack b as a circular region around some center c with radius r0 **)
claim Hbprop :
  exists c:set, exists r0:set,
    c :e EuclidPlane /\ Rlt 0 r0 /\
    b = {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ exact (SepE2 (Power EuclidPlane)
               (fun U0 : set => exists c:set, exists r:set,
                 c :e EuclidPlane /\ Rlt 0 r /\
                 U0 = {p :e EuclidPlane|Rlt (distance_R2 p c) r})
               b
               Hb). }
apply Hbprop.
let c. assume Hbprop2.
apply Hbprop2.
let r0. assume Hbcore.
claim Hcr0 : c :e EuclidPlane /\ Rlt 0 r0.
{ exact (andEL (c :e EuclidPlane /\ Rlt 0 r0)
              (b = {p :e EuclidPlane|Rlt (distance_R2 p c) r0})
              Hbcore). }
claim Hc : c :e EuclidPlane.
{ exact (andEL (c :e EuclidPlane) (Rlt 0 r0) Hcr0). }
claim Hr0 : Rlt 0 r0.
{ exact (andER (c :e EuclidPlane) (Rlt 0 r0) Hcr0). }
claim HbEq : b = {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ exact (andER (c :e EuclidPlane /\ Rlt 0 r0)
              (b = {p :e EuclidPlane|Rlt (distance_R2 p c) r0})
              Hbcore). }
claim Hxb' : x :e {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ rewrite <- HbEq. exact Hxb. }
claim HxE : x :e EuclidPlane.
{ exact (SepE1 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c) r0) x Hxb'). }
claim Hxball : Rlt (distance_R2 x c) r0.
{ exact (SepE2 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 c) r0) x Hxb'). }

(** Core refinement: build a rectangle around x inside the ball around c **)
apply (rectangle_inside_ball x c r0 HxE Hc Hr0 Hxball).
let r. assume Hrpair.
witness r.
claim Hr : r :e rectangular_regions.
{ exact (andEL (r :e rectangular_regions) (x :e r /\ r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}) Hrpair). }
claim Hrprop : x :e r /\ r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ exact (andER (r :e rectangular_regions) (x :e r /\ r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}) Hrpair). }
claim Hxr : x :e r.
{ exact (andEL (x :e r) (r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}) Hrprop). }
claim Hrsub : r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}.
{ exact (andER (x :e r) (r c= {p :e EuclidPlane|Rlt (distance_R2 p c) r0}) Hrprop). }
claim Hrsubb : r c= b.
{ rewrite HbEq. exact Hrsub. }
apply andI.
- exact Hr.
- apply andI.
  + exact Hxr.
  + exact Hrsubb.
Qed.

(** from §13 Example 4: circular neighborhoods inside rectangular neighborhoods **)
(** LATEX VERSION: For any point x in an open rectangle, there is a circular region containing x and contained in that rectangle. **)
Theorem circular_refines_rectangular_plane :
  forall b :e rectangular_regions, forall x:set,
    x :e b -> exists u :e circular_regions, x :e u /\ u c= b.
let b. assume Hb.
let x. assume Hxb.
prove exists u :e circular_regions, x :e u /\ u c= b.
(** Unpack b as a rectangle with endpoints a,b0,c,d0 **)
claim Hbprop :
  exists a:set, exists b0:set, exists c:set, exists d0:set,
    a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0 /\
      b = {p :e EuclidPlane|
             exists x0:set, exists y0:set,
               p = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0}.
{ exact (SepE2 (Power EuclidPlane)
               (fun U0 : set =>
                 exists a b c d:set, a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
                   U0 = {p1 :e EuclidPlane|
                          exists x0:set, exists y0:set,
                            p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b /\ Rlt c y0 /\ Rlt y0 d})
               b
               Hb). }
apply Hbprop.
let a. assume Hbprop2.
apply Hbprop2.
let b0. assume Hbprop3.
apply Hbprop3.
let c. assume Hbprop4.
apply Hbprop4.
let d0. assume Hbcore.
claim HbEq :
  b = {p :e EuclidPlane|
         exists x0:set, exists y0:set,
           p = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0}.
{ exact (andER (a :e R /\ b0 :e R /\ c :e R /\ d0 :e R /\ Rlt a b0 /\ Rlt c d0)
              (b = {p :e EuclidPlane|
                     exists x0:set, exists y0:set,
                       p = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0})
              Hbcore). }
claim Hxb' : x :e {p :e EuclidPlane|
                    exists x0:set, exists y0:set,
                      p = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0}.
{ rewrite <- HbEq. exact Hxb. }
claim HxE : x :e EuclidPlane.
{ exact (SepE1 EuclidPlane
             (fun p1 : set =>
               exists x0:set, exists y0:set,
                 p1 = (x0,y0) /\ Rlt a x0 /\ Rlt x0 b0 /\ Rlt c y0 /\ Rlt y0 d0)
             x
             Hxb'). }

(** Core refinement: build a small circular region around x contained in the rectangle **)
apply (ball_inside_rectangle b x Hb HxE Hxb).
let r3. assume Hrad2.
claim Hr3 : Rlt 0 r3.
{ exact (andEL (Rlt 0 r3)
              (forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> p :e b)
              Hrad2). }
claim HradP : forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> p :e b.
{ exact (andER (Rlt 0 r3)
              (forall p:set, p :e EuclidPlane -> Rlt (distance_R2 p x) r3 -> p :e b)
              Hrad2). }
set u := {p :e EuclidPlane|Rlt (distance_R2 p x) r3}.
witness u.
apply andI.
- prove u :e circular_regions.
  claim HuDef : u = {p :e EuclidPlane|Rlt (distance_R2 p x) r3}.
  { reflexivity. }
  rewrite HuDef.
  exact (circular_regionI x r3 HxE Hr3).
- apply andI.
  + prove x :e u.
    claim HxBall : Rlt (distance_R2 x x) r3.
    { rewrite (distance_R2_refl_0 x HxE).
      exact Hr3. }
    exact (SepI EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) x HxE HxBall).
  + prove u c= b.
    let p. assume Hp : p :e u.
    claim HpE : p :e EuclidPlane.
    { exact (SepE1 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) p Hp). }
    claim HpBall : Rlt (distance_R2 p x) r3.
    { exact (SepE2 EuclidPlane (fun p0 : set => Rlt (distance_R2 p0 x) r3) p Hp). }
    exact (HradP p HpE HpBall).
Qed.

Theorem circular_rectangular_same_topology_plane :
  generated_topology EuclidPlane circular_regions = generated_topology EuclidPlane rectangular_regions.
prove generated_topology EuclidPlane circular_regions = generated_topology EuclidPlane rectangular_regions.
apply set_ext.
- (** inclusion: generated_topology EuclidPlane circular_regions c= generated_topology EuclidPlane rectangular_regions **)
  let U. assume HU : U :e generated_topology EuclidPlane circular_regions.
  prove U :e generated_topology EuclidPlane rectangular_regions.
  claim HUPow : U :e Power EuclidPlane.
  { exact (SepE1 (Power EuclidPlane)
                 (fun U0 : set =>
                   forall x0 :e U0, exists b :e circular_regions, x0 :e b /\ b c= U0)
                 U
                 HU). }
  claim HUprop : forall x0 :e U, exists b :e circular_regions, x0 :e b /\ b c= U.
  { exact (SepE2 (Power EuclidPlane)
                 (fun U0 : set =>
                   forall x0 :e U0, exists b :e circular_regions, x0 :e b /\ b c= U0)
                 U
                 HU). }
  claim HUsub : U c= EuclidPlane.
  { exact (PowerE EuclidPlane U HUPow). }
  claim HUrect : forall x0 :e U, exists r :e rectangular_regions, x0 :e r /\ r c= U.
  { let x0. assume Hx0U.
    claim Hexb : exists b :e circular_regions, x0 :e b /\ b c= U.
    { exact (HUprop x0 Hx0U). }
    apply Hexb.
    let b. assume Hbpair.
    claim Hb : b :e circular_regions.
    { exact (andEL (b :e circular_regions) (x0 :e b /\ b c= U) Hbpair). }
    claim Hbprop : x0 :e b /\ b c= U.
    { exact (andER (b :e circular_regions) (x0 :e b /\ b c= U) Hbpair). }
    claim Hx0b : x0 :e b.
    { exact (andEL (x0 :e b) (b c= U) Hbprop). }
    claim HbsubU : b c= U.
    { exact (andER (x0 :e b) (b c= U) Hbprop). }
    claim Hexr : exists r :e rectangular_regions, x0 :e r /\ r c= b.
    { exact (rectangular_refines_circular_plane b Hb x0 Hx0b). }
    apply Hexr.
    let r. assume Hrpair.
    claim Hr : r :e rectangular_regions.
    { exact (andEL (r :e rectangular_regions) (x0 :e r /\ r c= b) Hrpair). }
    claim Hrprop : x0 :e r /\ r c= b.
    { exact (andER (r :e rectangular_regions) (x0 :e r /\ r c= b) Hrpair). }
    claim Hx0r : x0 :e r.
    { exact (andEL (x0 :e r) (r c= b) Hrprop). }
    claim Hrsubb : r c= b.
    { exact (andER (x0 :e r) (r c= b) Hrprop). }
    claim HrsubU : r c= U.
    { exact (Subq_tra r b U Hrsubb HbsubU). }
    witness r.
    apply andI.
    - exact Hr.
    - apply andI.
      + exact Hx0r.
      + exact HrsubU. }
  exact (SepI (Power EuclidPlane)
              (fun U0 : set =>
                forall x0 :e U0, exists r :e rectangular_regions, x0 :e r /\ r c= U0)
              U
              HUPow
              HUrect).
- (** inclusion: generated_topology EuclidPlane rectangular_regions c= generated_topology EuclidPlane circular_regions **)
  let U. assume HU : U :e generated_topology EuclidPlane rectangular_regions.
  prove U :e generated_topology EuclidPlane circular_regions.
  claim HUPow : U :e Power EuclidPlane.
  { exact (SepE1 (Power EuclidPlane)
                 (fun U0 : set =>
                   forall x0 :e U0, exists b :e rectangular_regions, x0 :e b /\ b c= U0)
                 U
                 HU). }
  claim HUprop : forall x0 :e U, exists b :e rectangular_regions, x0 :e b /\ b c= U.
  { exact (SepE2 (Power EuclidPlane)
                 (fun U0 : set =>
                   forall x0 :e U0, exists b :e rectangular_regions, x0 :e b /\ b c= U0)
                 U
                 HU). }
  claim HUcirc : forall x0 :e U, exists u :e circular_regions, x0 :e u /\ u c= U.
  { let x0. assume Hx0U.
    claim Hexb : exists b :e rectangular_regions, x0 :e b /\ b c= U.
    { exact (HUprop x0 Hx0U). }
    apply Hexb.
    let b. assume Hbpair.
    claim Hb : b :e rectangular_regions.
    { exact (andEL (b :e rectangular_regions) (x0 :e b /\ b c= U) Hbpair). }
    claim Hbprop : x0 :e b /\ b c= U.
    { exact (andER (b :e rectangular_regions) (x0 :e b /\ b c= U) Hbpair). }
    claim Hx0b : x0 :e b.
    { exact (andEL (x0 :e b) (b c= U) Hbprop). }
    claim HbsubU : b c= U.
    { exact (andER (x0 :e b) (b c= U) Hbprop). }
    claim Hexu : exists u :e circular_regions, x0 :e u /\ u c= b.
    { exact (circular_refines_rectangular_plane b Hb x0 Hx0b). }
    apply Hexu.
    let u. assume Hupair.
    claim Hu : u :e circular_regions.
    { exact (andEL (u :e circular_regions) (x0 :e u /\ u c= b) Hupair). }
    claim Huprop : x0 :e u /\ u c= b.
    { exact (andER (u :e circular_regions) (x0 :e u /\ u c= b) Hupair). }
    claim Hx0u : x0 :e u.
    { exact (andEL (x0 :e u) (u c= b) Huprop). }
    claim Husubb : u c= b.
    { exact (andER (x0 :e u) (u c= b) Huprop). }
    claim HusubU : u c= U.
    { exact (Subq_tra u b U Husubb HbsubU). }
    witness u.
    apply andI.
    - exact Hu.
    - apply andI.
      + exact Hx0u.
      + exact HusubU. }
  exact (SepI (Power EuclidPlane)
              (fun U0 : set =>
                forall x0 :e U0, exists b :e circular_regions, x0 :e b /\ b c= U0)
              U
              HUPow
              HUcirc).
Qed.

(** from §13: refinement of basis yields finer topology **) 
(** LATEX VERSION: If B′ refines every open set of the topology generated by B, then T(B′) is finer than T(B). **)
Theorem lemma_finer_if_basis_refines : forall X B B':set,
  basis_on X B -> basis_refines X B' (generated_topology X B) ->
  finer_than (generated_topology X B') (generated_topology X B).
let X B B'. assume HBasis Href.
claim Hprop : forall U :e generated_topology X B, forall x :e U, exists b' :e B', x :e b' /\ b' c= U.
{ exact (andER (topology_on X (generated_topology X B))
               (forall U :e generated_topology X B, forall x :e U, exists b' :e B', x :e b' /\ b' c= U)
               Href). }
prove generated_topology X B c= generated_topology X B'.
  let U. assume HU.
  claim HUsubX : U c= X.
  { exact (PowerE X U (SepE1 (Power X)
                             (fun U0 : set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
                             U HU)). }
  claim HUprop : forall x :e U, exists b' :e B', x :e b' /\ b' c= U.
  { exact (Hprop U HU). }
  exact (SepI (Power X)
              (fun U0 : set => forall x0 :e U0, exists b0 :e B', x0 :e b0 /\ b0 c= U0)
              U
              (PowerI X U HUsubX)
              HUprop).
Qed.

(** from §13 Definition: subbasis and its generated topology **) 
(** LATEX VERSION: A subbasis S for a topology on X is a collection of subsets of X whose union equals X. **)
(** SUSPICIOUS DEFINITION: The condition is `Union S = X`; in later uses it is easy to accidentally only show `Union S c= X`, which is weaker. **)
Definition subbasis_on : set -> set -> prop := fun X S =>
  S c= Power X /\ Union S = X.

(** from §13: finite intersections of subbasis elements **)
(** LATEX VERSION: intersection_of_family collects common points of all sets in a family; finite_subcollections picks finite families; finite_intersections_of X S takes intersections of finite subfamilies of S. **)
(** FIXED: Now takes ambient set X as first parameter. Empty family correctly gives X; nonempty Fam gives the usual intersection inside X. **)
(** SUSPICIOUS DEFINITION: `intersection_of_family X Fam` does not require `Fam c= Power X`; it relies on the ambient restriction `x :e X` to force the intersection to lie in X. **)
Definition intersection_of_family : set -> set -> set :=
  fun X Fam => {x :e X|forall U:set, U :e Fam -> x :e U}.

(** helper: intersection of a family stays in the ambient union **) 
(** LATEX VERSION: Placeholder lemma: each member of an intersection lies in the union of the family (to be proved properly). **)
Definition finite_subcollections : set -> set :=
  fun S => {F :e Power S|finite F}.

(** helper: introduction and eliminations for intersection_of_family **)
Theorem intersection_of_familyI : forall X Fam x:set,
  x :e X ->
  (forall U:set, U :e Fam -> x :e U) ->
  x :e intersection_of_family X Fam.
let X Fam x.
assume HxX: x :e X.
assume Hall: forall U:set, U :e Fam -> x :e U.
exact (SepI X (fun x0:set => forall U:set, U :e Fam -> x0 :e U) x HxX Hall).
Qed.

Theorem intersection_of_familyE1 : forall X Fam x:set,
  x :e intersection_of_family X Fam -> x :e X.
let X Fam x.
assume Hx: x :e intersection_of_family X Fam.
exact (SepE1 X (fun x0:set => forall U:set, U :e Fam -> x0 :e U) x Hx).
Qed.

Theorem intersection_of_familyE2 : forall X Fam x:set,
  x :e intersection_of_family X Fam ->
  forall U:set, U :e Fam -> x :e U.
let X Fam x.
assume Hx: x :e intersection_of_family X Fam.
exact (SepE2 X (fun x0:set => forall U:set, U :e Fam -> x0 :e U) x Hx).
Qed.

(** FIXED: Now takes X to pass to intersection_of_family. **)
Definition finite_intersections_of : set -> set -> set := fun X S =>
  {intersection_of_family X F|F :e finite_subcollections S}.

(** from §13: basis obtained from a subbasis by finite intersections **)
(** LATEX VERSION: basis_of_subbasis X S is the set of nonempty finite intersections of elements of S. **)
(** FIXED: Now properly uses X parameter. Empty intersection gives X; the filter keeps only nonempty intersections. **)
(** SUSPICIOUS DEFINITION: `basis_of_subbasis` removes `Empty`; this matches the usual convention but means `X` appears only via the empty intersection and only when `X <> Empty`. **)
Definition basis_of_subbasis : set -> set -> set := fun X S =>
  {b :e finite_intersections_of X S | b <> Empty}.

(** Helper: Finite intersection of a family is in the basis_of_subbasis **)
Theorem finite_intersection_in_basis : forall X S F:set,
  F :e finite_subcollections S ->
  intersection_of_family X F <> Empty ->
  intersection_of_family X F :e basis_of_subbasis X S.
let X S F. assume HF Hnon.
prove intersection_of_family X F :e basis_of_subbasis X S.
(** basis_of_subbasis X S = {b :e finite_intersections_of X S | b <> Empty} **)
exact (SepI (finite_intersections_of X S) (fun b:set => b <> Empty) (intersection_of_family X F)
            (ReplI (finite_subcollections S) (fun F0 : set => intersection_of_family X F0) F HF)
            Hnon).
 
Qed.

(** Helper: empty family intersection equals X **)
Theorem intersection_of_family_empty_eq : forall X:set,
  intersection_of_family X Empty = X.
let X.
apply set_ext.
- let x. assume Hx: x :e intersection_of_family X Empty.
  prove x :e X.
  exact (SepE1 X (fun x0 : set => forall U:set, U :e Empty -> x0 :e U) x Hx).
- let x. assume HxX: x :e X.
  prove x :e intersection_of_family X Empty.
  exact (SepI X (fun x0 : set => forall U:set, U :e Empty -> x0 :e U) x
              HxX
              (fun U HU => EmptyE U HU (x :e U))).
Qed.

(** Helper: singleton family intersection equals the set when it is a subset of X **)
Theorem intersection_of_family_singleton_eq : forall X s:set,
  s c= X ->
  intersection_of_family X {s} = s.
let X s. assume HsSubX.
apply set_ext.
- let x. assume Hx: x :e intersection_of_family X {s}.
  prove x :e s.
  claim Hall: forall U:set, U :e {s} -> x :e U.
  { exact (SepE2 X (fun x0 : set => forall U:set, U :e {s} -> x0 :e U) x Hx). }
  exact (Hall s (SingI s)).
- let x. assume Hx: x :e s.
  prove x :e intersection_of_family X {s}.
  claim HxX: x :e X.
  { exact (HsSubX x Hx). }
  claim Hprop: forall U:set, U :e {s} -> x :e U.
  { let U. assume HU: U :e {s}.
    prove x :e U.
    claim HUeq: U = s.
    { exact (SingE s U HU). }
    rewrite HUeq.
    exact Hx.
  }
  exact (SepI X (fun x0 : set => forall U:set, U :e {s} -> x0 :e U) x HxX Hprop).
Qed.

(** Helper: Elements of subbasis are in the generated basis **)
Theorem subbasis_elem_in_basis : forall X S s:set,
  subbasis_on X S ->
  s :e S ->
  s <> Empty ->
  s :e basis_of_subbasis X S.
let X S s. assume HSsub HsS HsNonempty.
prove s :e basis_of_subbasis X S.
claim HS: S c= Power X.
{ exact (andEL (S c= Power X) (Union S = X) HSsub). }
claim HsPow: s :e Power X.
{ exact (HS s HsS). }
claim HsSubX: s c= X.
{ exact (PowerE X s HsPow). }
set F := {s}.
claim HFPower: F :e Power S.
{ apply PowerI S F.
  let t. assume Ht: t :e F.
  prove t :e S.
  claim HtEq: t = s.
  { exact (SingE s t Ht). }
  rewrite HtEq.
  exact HsS.
}
claim HFinF: finite F.
{ exact (Sing_finite s). }
claim HFsubcol: F :e finite_subcollections S.
{ exact (SepI (Power S) (fun F0 : set => finite F0) F HFPower HFinF). }
claim HinterEq: intersection_of_family X F = s.
{ exact (intersection_of_family_singleton_eq X s HsSubX). }
claim HinterNonempty: intersection_of_family X F <> Empty.
{ rewrite HinterEq. exact HsNonempty. }
claim HinterInBasis: intersection_of_family X F :e basis_of_subbasis X S.
{ exact (finite_intersection_in_basis X S F HFsubcol HinterNonempty). }
rewrite <- HinterEq at 1.
exact HinterInBasis.
Qed.

(** Helper: X itself (empty intersection) is in the basis when nonempty **)
Theorem X_in_basis_of_subbasis : forall X S:set,
  X <> Empty ->
  X :e basis_of_subbasis X S.
let X S. assume HXnonempty.
prove X :e basis_of_subbasis X S.
set F := Empty.
claim HFPower: F :e Power S.
{ exact (Empty_In_Power S). }
claim HFinF: finite F.
{ exact finite_Empty. }
claim HFsubcol: F :e finite_subcollections S.
{ exact (SepI (Power S) (fun F0 : set => finite F0) F HFPower HFinF). }
claim HinterEq: intersection_of_family X F = X.
{ exact (intersection_of_family_empty_eq X). }
claim HinterNonempty: intersection_of_family X F <> Empty.
{ rewrite HinterEq. exact HXnonempty. }
claim HinterInBasis: intersection_of_family X F :e basis_of_subbasis X S.
{ exact (finite_intersection_in_basis X S F HFsubcol HinterNonempty). }
rewrite <- HinterEq at 1.
exact HinterInBasis.
Qed.

(** Helper: Finite intersection of topology elements is in the topology **)
Theorem intersection_of_family_adjoin : forall X F U:set,
  intersection_of_family X (F :\/: {U}) = (intersection_of_family X F) :/\: U.
let X F U.
apply set_ext.
- let x. assume Hx: x :e intersection_of_family X (F :\/: {U}).
  prove x :e (intersection_of_family X F) :/\: U.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0 : set => forall T:set, T :e (F :\/: {U}) -> x0 :e T) x Hx). }
  claim Hall: forall T:set, T :e (F :\/: {U}) -> x :e T.
  { exact (SepE2 X (fun x0 : set => forall T:set, T :e (F :\/: {U}) -> x0 :e T) x Hx). }
  claim HxInF: x :e intersection_of_family X F.
  { exact (SepI X (fun x0 : set => forall T:set, T :e F -> x0 :e T) x
                HxX
                (fun T HT => Hall T (binunionI1 F {U} T HT))). }
  claim HxU: x :e U.
  { exact (Hall U (binunionI2 F {U} U (SingI U))). }
  exact (binintersectI (intersection_of_family X F) U x HxInF HxU).
- let x. assume Hx: x :e (intersection_of_family X F) :/\: U.
  prove x :e intersection_of_family X (F :\/: {U}).
  claim HxInF: x :e intersection_of_family X F.
  { exact (binintersectE1 (intersection_of_family X F) U x Hx). }
  claim HxU: x :e U.
  { exact (binintersectE2 (intersection_of_family X F) U x Hx). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0 : set => forall T:set, T :e F -> x0 :e T) x HxInF). }
  claim HallF: forall T:set, T :e F -> x :e T.
  { exact (SepE2 X (fun x0 : set => forall T:set, T :e F -> x0 :e T) x HxInF). }
  claim Hall: forall T:set, T :e (F :\/: {U}) -> x :e T.
  { let T. assume HT.
    prove x :e T.
    apply (binunionE' F {U} T (x :e T)).
    - assume HTF: T :e F.
      exact (HallF T HTF).
    - assume HTU: T :e {U}.
      claim HUeq: T = U.
      { exact (SingE U T HTU). }
      rewrite HUeq.
      exact HxU.
    - exact HT.
  }
  exact (SepI X (fun x0 : set => forall T:set, T :e (F :\/: {U}) -> x0 :e T) x
              HxX
              Hall).
Qed.

Theorem finite_intersection_in_topology : forall X T F:set,
  topology_on X T ->
  F :e Power T ->
  finite F ->
  intersection_of_family X F :e T.
let X T F.
assume HTtop: topology_on X T.
assume HFpow: F :e Power T.
assume HFin: finite F.
prove intersection_of_family X F :e T.
(** Use finite induction on F with property: if F c= T then intersection is open **)
claim HpEmpty: Empty :e Power T -> intersection_of_family X Empty :e T.
{ assume HpowEmpty.
  rewrite (intersection_of_family_empty_eq X).
  exact (topology_has_X X T HTtop).
}
claim HpStep: forall F0 y:set,
  finite F0 ->
  y /:e F0 ->
  (F0 :e Power T -> intersection_of_family X F0 :e T) ->
  ((F0 :\/: {y}) :e Power T -> intersection_of_family X (F0 :\/: {y}) :e T).
{ let F0 y.
  assume HFin0 HyNotin IH.
  assume HpowUnion: (F0 :\/: {y}) :e Power T.
  claim HsubUnion: F0 :\/: {y} c= T.
  { exact (PowerE T (F0 :\/: {y}) HpowUnion). }
  claim HsubF0: F0 c= T.
  { let U. assume HU: U :e F0.
    exact (HsubUnion U (binunionI1 F0 {y} U HU)). }
  claim HF0pow: F0 :e Power T.
  { exact (PowerI T F0 HsubF0). }
  claim HinterF0: intersection_of_family X F0 :e T.
  { exact (IH HF0pow). }
  claim HyT: y :e T.
  { exact (HsubUnion y (binunionI2 F0 {y} y (SingI y))). }
  rewrite (intersection_of_family_adjoin X F0 y).
  exact (topology_binintersect_closed X T (intersection_of_family X F0) y HTtop HinterF0 HyT).
}
claim Hall: forall F0:set, finite F0 -> (F0 :e Power T -> intersection_of_family X F0 :e T).
{ exact (finite_ind (fun F0:set => F0 :e Power T -> intersection_of_family X F0 :e T) HpEmpty HpStep). }
claim Hspec: F :e Power T -> intersection_of_family X F :e T.
{ exact (Hall F HFin). }
exact (Hspec HFpow).
Qed.

(** from §13: topology generated by a subbasis **) 
(** LATEX VERSION: generated_topology_from_subbasis X S is the topology generated by the basis arising from S. **)
Definition generated_topology_from_subbasis : set -> set -> set :=
  fun X S => generated_topology X (basis_of_subbasis X S).

(** from §13: finite intersections of a subbasis form a basis **) 
(** LATEX VERSION: The set of nonempty finite intersections of subbasis elements forms a basis. **)
Theorem finite_intersections_basis_of_subbasis : forall X S:set,
  subbasis_on X S -> basis_on X (basis_of_subbasis X S).
let X S.
assume HS.
prove basis_on X (basis_of_subbasis X S).
(** basis_on X B requires: B c= Power X, covering, and intersection property **)
prove basis_of_subbasis X S c= Power X
  /\ (forall x :e X, exists b :e basis_of_subbasis X S, x :e b)
  /\ (forall b1 :e basis_of_subbasis X S, forall b2 :e basis_of_subbasis X S, forall x:set,
        x :e b1 -> x :e b2 -> exists b3 :e basis_of_subbasis X S, x :e b3 /\ b3 c= b1 :/\: b2).
apply andI.
- (** Build left-associative conjunction **)
  apply andI.
  + (** Axiom 1: basis_of_subbasis X S c= Power X **)
    let b. assume Hb: b :e basis_of_subbasis X S.
    prove b :e Power X.
    (** b is a nonempty finite intersection of subbasis elements **)
    (** basis_of_subbasis X S = {b :e finite_intersections_of X S | b <> Empty} **)
    claim Hb_in_finite: b :e finite_intersections_of X S.
    { exact (SepE1 (finite_intersections_of X S) (fun b0 => b0 <> Empty) b Hb). }
    (** finite_intersections_of X S = {intersection_of_family F | F :e finite_subcollections S} **)
    (** So b = intersection_of_family F for some finite F c= S **)
    claim Hex: exists F :e finite_subcollections S, b = intersection_of_family X F.
    { exact (ReplE (finite_subcollections S) (fun F => intersection_of_family X F) b Hb_in_finite). }
    apply Hex.
    let F. assume HF_and_eq. apply HF_and_eq.
    assume HF: F :e finite_subcollections S.
    assume Hbeq: b = intersection_of_family X F.
    prove b :e Power X.
    apply PowerI.
    (** Need to show b c= X **)
    let x. assume Hx: x :e b.
    prove x :e X.
    (** With new definition: intersection_of_family X F = {x :e X | forall U :e F, x :e U}. So x :e intersection_of_family X F directly gives x :e X. **)
    claim Hx_intersect: x :e intersection_of_family X F.
    { rewrite <- Hbeq. exact Hx. }
    exact (SepE1 X (fun x0 => forall U:set, U :e F -> x0 :e U) x Hx_intersect).
  + (** Axiom 2: covering property - forall x :e X, exists b :e basis_of_subbasis X S, x :e b **)
    let x. assume Hx: x :e X.
    prove exists b :e basis_of_subbasis X S, x :e b.
    (** Use Union S = X from subbasis_on: pick s :e S with x :e s, then s is a nonempty finite intersection **)
    claim HSsub: S c= Power X.
    { exact (andEL (S c= Power X) (Union S = X) HS). }
    claim HUnionS: Union S = X.
    { exact (andER (S c= Power X) (Union S = X) HS). }
    claim HxUnionS: x :e Union S.
    { rewrite HUnionS. exact Hx. }
    apply (UnionE_impred S x HxUnionS).
    let s. assume Hxs: x :e s. assume HsS: s :e S.
    claim HsNe: s <> Empty.
    { assume Hseq: s = Empty.
      claim HxEmpty: x :e Empty.
      { rewrite <- Hseq. exact Hxs. }
      exact (EmptyE x HxEmpty).
    }
    claim HsInBasis: s :e basis_of_subbasis X S.
    { exact (subbasis_elem_in_basis X S s HS HsS HsNe). }
    witness s.
    apply andI.
    * exact HsInBasis.
    * exact Hxs.
- (** Axiom 3: intersection property **)
  let b1. assume Hb1: b1 :e basis_of_subbasis X S.
  let b2. assume Hb2: b2 :e basis_of_subbasis X S.
  let x. assume Hxb1: x :e b1. assume Hxb2: x :e b2.
  prove exists b3 :e basis_of_subbasis X S, x :e b3 /\ b3 c= b1 :/\: b2.
  (** b1 and b2 are finite intersections; their intersection is also a finite intersection **)
  (** Take b3 = b1 :/\: b2 if nonempty **)
  set b3 := b1 :/\: b2.
  claim Hxb3: x :e b3.
  { apply binintersectI. exact Hxb1. exact Hxb2. }
  claim Hb3_ne: b3 <> Empty.
  { assume Hempty: b3 = Empty.
    claim Hx_in_empty: x :e Empty.
    { rewrite <- Hempty. exact Hxb3. }
    exact (EmptyE x Hx_in_empty).
  }
  (** Need to show b3 :e basis_of_subbasis X S **)
  (** b3 = b1 :/\: b2 where b1, b2 are finite intersections **)
  witness b3.
  apply andI.
  + (** b3 :e basis_of_subbasis X S **)
    prove b3 :e basis_of_subbasis X S.
    (** Extract that b1, b2 are finite intersections **)
    claim Hb1_finite: b1 :e finite_intersections_of X S.
    { exact (SepE1 (finite_intersections_of X S) (fun b0 => b0 <> Empty) b1 Hb1). }
    claim Hb2_finite: b2 :e finite_intersections_of X S.
    { exact (SepE1 (finite_intersections_of X S) (fun b0 => b0 <> Empty) b2 Hb2). }
    (** Get witnesses F1, F2 **)
    claim Hex1: exists F1 :e finite_subcollections S, b1 = intersection_of_family X F1.
    { exact (ReplE (finite_subcollections S) (fun F => intersection_of_family X F) b1 Hb1_finite). }
    apply Hex1.
    let F1. assume HF1_and_eq1. apply HF1_and_eq1.
    assume HF1: F1 :e finite_subcollections S.
    assume Hb1eq: b1 = intersection_of_family X F1.
    claim Hex2: exists F2 :e finite_subcollections S, b2 = intersection_of_family X F2.
    { exact (ReplE (finite_subcollections S) (fun F => intersection_of_family X F) b2 Hb2_finite). }
    apply Hex2.
    let F2. assume HF2_and_eq2. apply HF2_and_eq2.
    assume HF2: F2 :e finite_subcollections S.
    assume Hb2eq: b2 = intersection_of_family X F2.
    (** With new definition: intersection_of_family X Empty = X. So F1 and F2 may be empty without causing ill-defined intersections. **)
    (** Now b3 = b1 :/\: b2 = intersection_of_family X (F1 :\/: F2) **)
    set F12 := F1 :\/: F2.
    (** Show F12 :e finite_subcollections S **)
    claim HF12_finite: F12 :e finite_subcollections S.
    { prove F12 :e {F :e Power S | finite F}.
      claim HF12_sub: F12 c= S.
      { claim HF1_sub: F1 c= S.
        { claim HF1_power: F1 :e Power S.
          { exact (SepE1 (Power S) (fun F0 => finite F0) F1 HF1). }
          exact (PowerE S F1 HF1_power).
        }
        claim HF2_sub: F2 c= S.
        { claim HF2_power: F2 :e Power S.
          { exact (SepE1 (Power S) (fun F0 => finite F0) F2 HF2). }
          exact (PowerE S F2 HF2_power).
        }
        exact (binunion_Subq_min F1 F2 S HF1_sub HF2_sub).
      }
      claim HF12_power: F12 :e Power S.
      { apply PowerI. exact HF12_sub. }
      claim HF12_is_finite: finite F12.
      { claim HF1_is_finite: finite F1.
        { exact (SepE2 (Power S) (fun F0 => finite F0) F1 HF1). }
        claim HF2_is_finite: finite F2.
        { exact (SepE2 (Power S) (fun F0 => finite F0) F2 HF2). }
        exact (binunion_finite F1 HF1_is_finite F2 HF2_is_finite).
      }
      exact (SepI (Power S) (fun F => finite F) F12 HF12_power HF12_is_finite).
    }
    (** Show b3 = intersection_of_family F12 **)
    claim Hb3_eq: b3 = intersection_of_family X F12.
    { (** b3 = b1 :/\: b2 = (intersection_of_family F1) :/\: (intersection_of_family F2)                        = intersection_of_family (F1 :\/: F2) = intersection_of_family F12 **)
      apply set_ext.
      - (** b3 c= intersection_of_family F12 **)
        let z. assume Hz: z :e b3.
        prove z :e intersection_of_family X F12.
        claim Hzb1: z :e b1.
        { exact (binintersectE1 b1 b2 z Hz). }
        claim Hzb2: z :e b2.
        { exact (binintersectE2 b1 b2 z Hz). }
        (** z :e intersection_of_family F1 **)
        claim Hz_intersect1: z :e intersection_of_family X F1.
        { rewrite <- Hb1eq. exact Hzb1. }
        (** z :e intersection_of_family F2 **)
        claim Hz_intersect2: z :e intersection_of_family X F2.
        { rewrite <- Hb2eq. exact Hzb2. }
        (** Show z :e intersection_of_family X F12 **)
        prove z :e intersection_of_family X F12.
        (** New definition: intersection_of_family X F = {x :e X | forall U :e F, x :e U} **)
        claim Hz_in_X: z :e X.
        { exact (SepE1 X (fun x => forall U:set, U :e F1 -> x :e U) z Hz_intersect1). }
        claim Hz_all1: forall U:set, U :e F1 -> z :e U.
        { exact (SepE2 X (fun x => forall U:set, U :e F1 -> x :e U) z Hz_intersect1). }
        claim Hz_all2: forall U:set, U :e F2 -> z :e U.
        { exact (SepE2 X (fun x => forall U:set, U :e F2 -> x :e U) z Hz_intersect2). }
        claim Hz_all12: forall U:set, U :e F12 -> z :e U.
        { let U. assume HU: U :e F12.
          prove z :e U.
          apply (binunionE F1 F2 U HU).
          - assume HUF1: U :e F1. exact (Hz_all1 U HUF1).
          - assume HUF2: U :e F2. exact (Hz_all2 U HUF2).
        }
        exact (SepI X (fun x => forall U:set, U :e F12 -> x :e U) z Hz_in_X Hz_all12).
      - (** intersection_of_family X F12 c= b3 **)
        let z. assume Hz: z :e intersection_of_family X F12.
        prove z :e b3.
        (** New definition gives us z :e X and forall U :e F12, z :e U **)
        claim Hz_in_X: z :e X.
        { exact (SepE1 X (fun x => forall U:set, U :e F12 -> x :e U) z Hz). }
        claim Hz_all12: forall U:set, U :e F12 -> z :e U.
        { exact (SepE2 X (fun x => forall U:set, U :e F12 -> x :e U) z Hz). }
        claim Hz_all1: forall U:set, U :e F1 -> z :e U.
        { let U. assume HU: U :e F1.
          prove z :e U.
          exact (Hz_all12 U (binunionI1 F1 F2 U HU)).
        }
        claim Hz_all2: forall U:set, U :e F2 -> z :e U.
        { let U. assume HU: U :e F2.
          prove z :e U.
          exact (Hz_all12 U (binunionI2 F1 F2 U HU)).
        }
        (** Use Hz_all1 and Hz_all2 to show z :e b1 and z :e b2 **)
        (** New definition: intersection_of_family X F = {x :e X | forall U :e F, x :e U} **)
        claim Hz_intersect1: z :e intersection_of_family X F1.
        { exact (SepI X (fun x => forall U:set, U :e F1 -> x :e U) z Hz_in_X Hz_all1). }
        claim Hz_intersect2: z :e intersection_of_family X F2.
        { exact (SepI X (fun x => forall U:set, U :e F2 -> x :e U) z Hz_in_X Hz_all2). }
        claim Hzb1: z :e b1.
        { rewrite Hb1eq. exact Hz_intersect1. }
        claim Hzb2: z :e b2.
        { rewrite Hb2eq. exact Hz_intersect2. }
        exact (binintersectI b1 b2 z Hzb1 Hzb2).
    }
    (** Now show b3 :e basis_of_subbasis X S using finite_intersection_in_basis **)
    claim H_intersect_ne: intersection_of_family X F12 <> Empty.
    { assume Hempty_intersect: intersection_of_family X F12 = Empty.
      claim Hb3_empty: b3 = Empty.
      { rewrite Hb3_eq. exact Hempty_intersect. }
      exact (Hb3_ne Hb3_empty).
    }
    claim H_intersect_in_basis: intersection_of_family X F12 :e basis_of_subbasis X S.
    { exact (finite_intersection_in_basis X S F12 HF12_finite H_intersect_ne). }
    claim Hb3_in_basis: b3 :e basis_of_subbasis X S.
    { rewrite Hb3_eq. exact H_intersect_in_basis. }
    exact Hb3_in_basis.
  + (** x :e b3 /\ b3 c= b1 :/\: b2 **)
    apply andI.
    * exact Hxb3.
    * exact (Subq_ref (b1 :/\: b2)).
Qed.

(** from §13: topology generated by a subbasis is a topology **) 
(** LATEX VERSION: The topology generated from a subbasis S on X satisfies the topology axioms. **)
Theorem topology_from_subbasis_is_topology : forall X S:set,
  subbasis_on X S -> topology_on X (generated_topology_from_subbasis X S).
let X S.
assume HS.
prove topology_on X (generated_topology_from_subbasis X S).
(** Strategy: Show basis_of_subbasis X S is a basis, then apply lemma_topology_from_basis **)
claim HBasis: basis_on X (basis_of_subbasis X S).
{ exact (finite_intersections_basis_of_subbasis X S HS). }
claim HTopo: topology_on X (generated_topology X (basis_of_subbasis X S)).
{ exact (lemma_topology_from_basis X (basis_of_subbasis X S) HBasis). }
(** generated_topology_from_subbasis X S = generated_topology X (basis_of_subbasis X S) by definition **)
exact HTopo.
Qed.

(** from §13: generated topology from subbasis is minimal among topologies containing S **) 
(** LATEX VERSION: Among all topologies containing a subbasis S, the generated one is the smallest/finer-than criterion. **)
Theorem topology_generated_by_basis_is_minimal : forall X S T:set,
  subbasis_on X S -> topology_on X T -> S c= T ->
  finer_than T (generated_topology_from_subbasis X S).
let X S T.
assume HS HT HST.
prove finer_than T (generated_topology_from_subbasis X S).
(** finer_than T (generated_topology_from_subbasis X S) = generated_topology_from_subbasis X S c= T **)
prove generated_topology_from_subbasis X S c= T.
(** generated_topology_from_subbasis X S = generated_topology X (basis_of_subbasis X S) **)
prove generated_topology X (basis_of_subbasis X S) c= T.
(** Strategy: show every basis element is in T, then every generated open set is in T **)
let U. assume HU: U :e generated_topology X (basis_of_subbasis X S).
prove U :e T.
(** U :e generated_topology X B means U c= X and forall x :e U, exists b :e B with x :e b, b c= U **)
claim HU_def: U c= X /\ (forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U).
{ (** generated_topology X B = {U :e Power X | forall x :e U, exists b :e B, x :e b /\ b c= U} **)
  claim HU_power: U :e Power X.
  { exact (SepE1 (Power X) (fun U0 => forall x :e U0, exists b :e basis_of_subbasis X S, x :e b /\ b c= U0) U HU). }
  claim HUsub_X: U c= X.
  { exact (PowerE X U HU_power). }
  claim HU_local: forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U.
  { exact (SepE2 (Power X) (fun U0 => forall x :e U0, exists b :e basis_of_subbasis X S, x :e b /\ b c= U0) U HU). }
  exact (andI (U c= X) (forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U) HUsub_X HU_local).
}
claim HUsub: U c= X.
{ exact (andEL (U c= X) (forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U) HU_def). }
claim HUlocal: forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U.
{ exact (andER (U c= X) (forall x :e U, exists b :e basis_of_subbasis X S, x :e b /\ b c= U) HU_def). }
(** Show: every basis element is in T **)
claim Hbasis_in_T: forall b :e basis_of_subbasis X S, b :e T.
{ let b. assume Hb: b :e basis_of_subbasis X S.
  prove b :e T.
  (** b is either X itself or a nonempty finite intersection of elements from S **)
  (** Case 1: if b = X, then X :e T since T is a topology **)
  (** Case 2: if b is a finite intersection of S elements, use that T is closed under finite intersections **)
  apply (xm (b = X)).
  - assume Hb_eq_X: b = X.
    (** X :e T since T is a topology on X **)
    claim HX_in_T: X :e T.
    { (** Extract from topology_on X T **)
      claim H1: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
      { exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) HT). }
      claim H2: (T c= Power X /\ Empty :e T) /\ X :e T.
      { exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) H1). }
      exact (andER (T c= Power X /\ Empty :e T) (X :e T) H2).
    }
    claim Hb_in_T_case1: b :e T.
    { rewrite Hb_eq_X. exact HX_in_T. }
    exact Hb_in_T_case1.
  - assume Hb_ne_X: b <> X.
    (** b is a nonempty finite intersection of S elements **)
    (** b :e basis_of_subbasis X S = {b :e finite_intersections_of X S | b <> Empty} **)
    claim Hb_finite_inter: b :e finite_intersections_of X S.
    { exact (SepE1 (finite_intersections_of X S) (fun b0 => b0 <> Empty) b Hb). }
    (** finite_intersections_of X S = {intersection_of_family F | F :e finite_subcollections S} **)
    claim Hex_F: exists F :e finite_subcollections S, b = intersection_of_family X F.
    { exact (ReplE (finite_subcollections S) (fun F => intersection_of_family X F) b Hb_finite_inter). }
    apply Hex_F.
    let F. assume HF_and_eq. apply HF_and_eq.
    assume HF: F :e finite_subcollections S.
    assume Hb_eq: b = intersection_of_family X F.
    (** F is a finite subcollection of S, so F c= S and finite F **)
    claim HF_sub_S: F c= S.
    { claim HF_power: F :e Power S.
      { exact (SepE1 (Power S) (fun F0 => finite F0) F HF). }
      exact (PowerE S F HF_power).
    }
    claim HF_finite: finite F.
    { exact (SepE2 (Power S) (fun F0 => finite F0) F HF). }
    (** Now b = intersection_of_family F where each element of F is in S, hence in T **)
    (** All elements of F are in T since F c= S c= T **)
    claim HF_sub_T: F c= T.
    { let s. assume Hs: s :e F.
      claim Hs_in_S: s :e S.
      { exact (HF_sub_S s Hs). }
      exact (HST s Hs_in_S).
    }
    claim HF_in_PowerT: F :e Power T.
    { apply PowerI. exact HF_sub_T. }
    (** Apply finite_intersection_in_topology **)
    claim Hb_inter_in_T: intersection_of_family X F :e T.
    { exact (finite_intersection_in_topology X T F HT HF_in_PowerT HF_finite). }
    claim Hb_in_T_case2: b :e T.
    { rewrite Hb_eq. exact Hb_inter_in_T. }
    exact Hb_in_T_case2.
}
(** Now show U is union of basis elements, hence in T **)
(** Strategy: U = Union {b :e basis_of_subbasis X S | b c= U}, and this is a union of T elements **)
set Fam := {b :e basis_of_subbasis X S | b c= U}.
claim HU_eq_union: U = Union Fam.
{ apply set_ext.
  - (** U c= Union Fam **)
    let x. assume Hx: x :e U.
    (** By HUlocal, exists b :e basis_of_subbasis X S with x :e b /\ b c= U **)
    claim Hex_b: exists b :e basis_of_subbasis X S, x :e b /\ b c= U.
    { exact (HUlocal x Hx). }
    apply Hex_b.
    let b. assume Hb_and_props. apply Hb_and_props.
    assume Hb_basis: b :e basis_of_subbasis X S.
    assume Hxb_and_sub. apply Hxb_and_sub.
    assume Hxb: x :e b.
    assume Hb_sub_U: b c= U.
    claim Hb_in_Fam: b :e Fam.
    { exact (SepI (basis_of_subbasis X S) (fun b0 => b0 c= U) b Hb_basis Hb_sub_U). }
    exact (UnionI Fam x b Hxb Hb_in_Fam).
  - (** Union Fam c= U **)
    let x. assume Hx: x :e Union Fam.
    apply UnionE_impred Fam x Hx.
    let b. assume Hxb: x :e b. assume Hb_Fam: b :e Fam.
    claim Hb_sub_U: b c= U.
    { exact (SepE2 (basis_of_subbasis X S) (fun b0 => b0 c= U) b Hb_Fam). }
    exact (Hb_sub_U x Hxb).
}
(** Now show U :e T using that U = Union Fam and Fam c= T **)
claim HFam_sub_T: Fam c= T.
{ let b. assume Hb: b :e Fam.
  claim Hb_basis: b :e basis_of_subbasis X S.
  { exact (SepE1 (basis_of_subbasis X S) (fun b0 => b0 c= U) b Hb). }
  exact (Hbasis_in_T b Hb_basis).
}
claim HFam_in_PowerT: Fam :e Power T.
{ apply PowerI. exact HFam_sub_T. }
(** T is closed under unions, so Union Fam :e T **)
claim HUnion_Fam_in_T: Union Fam :e T.
{ (** Extract union closure from topology_on X T **)
  claim H1: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
  { exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U :e T, forall V :e T, U :/\: V :e T) HT). }
  claim H_union_closure: forall UFam :e Power T, Union UFam :e T.
  { exact (andER (((T c= Power X /\ Empty :e T) /\ X :e T)) (forall UFam :e Power T, Union UFam :e T) H1). }
  exact (H_union_closure Fam HFam_in_PowerT).
}
claim HU_in_T: U :e T.
{ rewrite HU_eq_union. exact HUnion_Fam_in_T. }
exact HU_in_T.
Qed.

(** from §13 Exercise 1: local openness implies set is open **)
(** LATEX VERSION: Exercise 1: If every x∈A lies in some open U⊂A, then A is open. **)
Theorem ex13_1_local_open_subset : forall X T A:set,
  topology_on X T ->
  (forall x :e A, exists U :e T, x :e U /\ U c= A) ->
  open_in X T A.
let X T A.
assume HT Hlocal.
prove open_in X T A.
(** Strategy: show A = Union of family of open sets, then A is open **)
set Fam : set := {U :e T | U c= A}.
claim HFam_sub : Fam c= T.
{ let U. assume HU. exact (SepE1 T (fun U0 => U0 c= A) U HU). }
claim HUnion_eq : Union Fam = A.
{ apply set_ext.
  - (** Union Fam c= A **)
    let x. assume Hx.
    apply UnionE_impred Fam x Hx.
    let U. assume HxU HUFam.
    claim HUsub : U c= A.
    { exact (SepE2 T (fun U0 => U0 c= A) U HUFam). }
    exact (HUsub x HxU).
  - (** A c= Union Fam **)
    let x. assume HxA.
    claim Hex : exists U :e T, x :e U /\ U c= A.
    { exact (Hlocal x HxA). }
    apply Hex.
    let U. assume HU.
    claim HUT : U :e T.
    { exact (andEL (U :e T) (x :e U /\ U c= A) HU). }
    claim Hrest : x :e U /\ U c= A.
    { exact (andER (U :e T) (x :e U /\ U c= A) HU). }
    claim HxU : x :e U.
    { exact (andEL (x :e U) (U c= A) Hrest). }
    claim HUsub : U c= A.
    { exact (andER (x :e U) (U c= A) Hrest). }
    claim HUFam : U :e Fam.
    { exact (SepI T (fun U0 => U0 c= A) U HUT HUsub). }
    exact (UnionI Fam x U HxU HUFam).
}
claim HUnionT : Union Fam :e T.
{ exact (topology_union_closed X T Fam HT HFam_sub). }
claim HAT : A :e T.
{ rewrite <- HUnion_eq. exact HUnionT. }
prove topology_on X T /\ A :e T.
apply andI.
- exact HT.
- exact HAT.
Qed.

(** from §13 Exercise 2: comparison of nine topologies on {a,b,c} **) 
(** LATEX VERSION: Exercise 2 constructs nine topologies on {a,b,c} and compares which are topologies and their fineness relations. **)
Definition a_elt : set := Empty.
Definition b_elt : set := {Empty}.
Definition c_elt : set := {{Empty}}.
(** FIXED: Use binunion to create proper 3-element set {a,b,c}; old UPair a_elt (UPair b_elt c_elt) gave {a,{b,c}}, new UPair a_elt b_elt :\/: {c_elt} gives {a,b,c}. **)
Definition abc_set : set := UPair a_elt b_elt :\/: {c_elt}.

(** from §13 Exercise 2: topology on three element set **)
(** LATEX VERSION: One of the nine candidate families is the indiscrete topology {Empty, X}. **)
Definition top_abc_1 : set := UPair Empty abc_set.
(** from §13 Exercise 2: topology on three element set **)
(** LATEX VERSION: One of the nine candidate families is the discrete topology Power(X). **)
Definition top_abc_2 : set := Power abc_set.
(** FIXED: Nested `UPair` does not create a 3- or 4-element family; use unions with singletons. **)
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {a}, {a,b,c}}. **)
Definition top_abc_3 : set := UPair Empty {a_elt} :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {b}, {a,b,c}}. **)
Definition top_abc_4 : set := UPair Empty {b_elt} :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {c}, {a,b,c}}. **)
Definition top_abc_5 : set := UPair Empty {c_elt} :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {a,b}, {a,b,c}}. **)
Definition top_abc_6 : set := UPair Empty (UPair a_elt b_elt) :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {a,c}, {a,b,c}}. **)
Definition top_abc_7 : set := UPair Empty (UPair a_elt c_elt) :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {b,c}, {a,b,c}}. **)
Definition top_abc_8 : set := UPair Empty (UPair b_elt c_elt) :\/: {abc_set}.
  (** from §13 Exercise 2: topology on three element set **)
  (** LATEX VERSION: One of the nine candidate families of open sets on {a,b,c} is {Empty, {a}, {a,b}, {a,b,c}}. **)
Definition top_abc_9 : set := (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) :\/: {abc_set}.

(** Helper: topology of the form {Empty, A, X} **)
Theorem topology_three_sets : forall X A:set,
  A c= X ->
  topology_on X (UPair Empty A :\/: {X}).
let X A. assume HA.
set T := UPair Empty A :\/: {X}.
claim HTPow: T c= Power X.
{ let U. assume HU: U :e T.
  prove U :e Power X.
  apply (binunionE' (UPair Empty A) {X} U (U :e Power X)).
  - assume HU0: U :e UPair Empty A.
    apply (UPairE U Empty A HU0).
    + assume HUeq: U = Empty. rewrite HUeq. exact (Empty_In_Power X).
    + assume HUeq: U = A. rewrite HUeq. exact (PowerI X A HA).
  - assume HU0: U :e {X}.
    claim HUeq: U = X.
    { exact (SingE X U HU0). }
    rewrite HUeq.
    exact (Self_In_Power X).
  - exact HU.
}
claim HEmptyIn: Empty :e T.
{ exact (binunionI1 (UPair Empty A) {X} Empty (UPairI1 Empty A)). }
claim HXIn: X :e T.
{ exact (binunionI2 (UPair Empty A) {X} X (SingI X)). }
prove topology_on X T.
prove (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))
  /\ (forall U :e T, forall V :e T, U :/\: V :e T).
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - exact HTPow.
      - exact HEmptyIn.
    * exact HXIn.
  + let UFam. assume HUFam: UFam :e Power T.
    prove Union UFam :e T.
    claim HUFsub: UFam c= T.
    { exact (PowerE T UFam HUFam). }
    apply (xm (X :e UFam)).
    * assume HXUF: X :e UFam.
      claim HUnionSub: Union UFam c= X.
      { claim HUFpowX: UFam c= Power X.
        { let U. assume HU: U :e UFam.
          exact (HTPow U (HUFsub U HU)).
        }
        exact (Union_Power X UFam HUFpowX).
      }
      claim HUnionEq: Union UFam = X.
      { apply set_ext.
        - exact HUnionSub.
        - let x. assume HxX: x :e X.
          exact (UnionI UFam x X HxX HXUF).
      }
      rewrite HUnionEq.
      exact HXIn.
    * assume HXnot: X /:e UFam.
      apply (xm (A :e UFam)).
	      - assume HAUF: A :e UFam.
         claim HUnionSub: Union UFam c= A.
         { let x. assume Hx: x :e Union UFam.
           prove x :e A.
           apply UnionE_impred UFam x Hx.
           let U. assume HxU: x :e U. assume HUUF: U :e UFam.
           claim HUinT: U :e T.
           { exact (HUFsub U HUUF). }
           apply (binunionE' (UPair Empty A) {X} U (x :e A)).
           - assume HU0: U :e UPair Empty A.
	             apply (UPairE U Empty A HU0).
	             + assume HUeq: U = Empty.
	               claim HxEmpty: x :e Empty.
	               { rewrite <- HUeq. exact HxU. }
	               exact (EmptyE x HxEmpty (x :e A)).
	             + assume HUeq: U = A.
	               rewrite <- HUeq.
	               exact HxU.
           - assume HU0: U :e {X}.
	             claim HUeq: U = X.
	             { exact (SingE X U HU0). }
	             apply FalseE.
	             claim HXUF2: X :e UFam.
	             { rewrite <- HUeq. exact HUUF. }
	             exact (HXnot HXUF2).
           - exact HUinT.
         }
         claim HUnionEq: Union UFam = A.
         { apply set_ext.
           - exact HUnionSub.
           - let x. assume HxA: x :e A.
             exact (UnionI UFam x A HxA HAUF).
         }
         rewrite HUnionEq.
         exact (binunionI1 (UPair Empty A) {X} A (UPairI2 Empty A)).
	      - assume HAnot: A /:e UFam.
         claim HUnionEq: Union UFam = Empty.
         { apply set_ext.
           - let x. assume Hx: x :e Union UFam.
             prove x :e Empty.
             apply UnionE_impred UFam x Hx.
             let U. assume HxU: x :e U. assume HUUF: U :e UFam.
             claim HUinT: U :e T.
             { exact (HUFsub U HUUF). }
             apply (binunionE' (UPair Empty A) {X} U (x :e Empty)).
             + assume HU0: U :e UPair Empty A.
	               apply (UPairE U Empty A HU0).
	               * assume HUeq: U = Empty.
	                 rewrite <- HUeq.
	                 exact HxU.
	               * assume HUeq: U = A.
	                 apply FalseE.
	                 claim HAUF2: A :e UFam.
	                 { rewrite <- HUeq. exact HUUF. }
	                 exact (HAnot HAUF2).
             + assume HU0: U :e {X}.
	               claim HUeq: U = X.
	               { exact (SingE X U HU0). }
	               apply FalseE.
	               claim HXUF2: X :e UFam.
	               { rewrite <- HUeq. exact HUUF. }
	               exact (HXnot HXUF2).
             + exact HUinT.
           - let x. assume Hx: x :e Empty.
             exact (EmptyE x Hx (x :e Union UFam)).
         }
         rewrite HUnionEq.
         exact HEmptyIn.
- let U. assume HU: U :e T.
  let V. assume HV: V :e T.
  prove U :/\: V :e T.
  apply (binunionE' (UPair Empty A) {X} U (U :/\: V :e T)).
  - assume HU0: U :e UPair Empty A.
    apply (UPairE U Empty A HU0).
	    + assume HUeq: U = Empty.
	      rewrite HUeq.
	      claim HcapEq: Empty :/\: V = Empty.
	      { exact (binintersect_Empty_left V). }
	      rewrite HcapEq.
	      exact HEmptyIn.
    + assume HUeq: U = A.
      rewrite HUeq.
      apply (binunionE' (UPair Empty A) {X} V (A :/\: V :e T)).
      * assume HV0: V :e UPair Empty A.
        apply (UPairE V Empty A HV0).
	        - assume HVeq: V = Empty.
	           rewrite HVeq.
	           claim HcapEq: A :/\: Empty = Empty.
	           { exact (binintersect_Empty_right A). }
	           rewrite HcapEq.
	           exact HEmptyIn.
        - assume HVeq: V = A.
           rewrite HVeq.
           claim HcapEq: A :/\: A = A.
           { exact (binintersect_Subq_eq_1 A A (Subq_ref A)). }
           rewrite HcapEq.
           exact (binunionI1 (UPair Empty A) {X} A (UPairI2 Empty A)).
      * assume HV0: V :e {X}.
        claim HVeq: V = X.
        { exact (SingE X V HV0). }
        rewrite HVeq.
        claim HcapEq: A :/\: X = A.
        { exact (binintersect_Subq_eq_1 A X HA). }
        rewrite HcapEq.
        exact (binunionI1 (UPair Empty A) {X} A (UPairI2 Empty A)).
      * exact HV.
  - assume HU0: U :e {X}.
    claim HUeq: U = X.
    { exact (SingE X U HU0). }
    rewrite HUeq.
    claim HVpow: V :e Power X.
    { exact (HTPow V HV). }
    claim HVsub: V c= X.
    { exact (PowerE X V HVpow). }
    claim HcapEq: X :/\: V = V.
    { rewrite (binintersect_com X V). exact (binintersect_Subq_eq_1 V X HVsub). }
    rewrite HcapEq.
    exact HV.
  - exact HU.
Qed.

(** Helper: topology of the form {Empty, A, B, X} with A c= B c= X **)
Theorem topology_chain_four_sets : forall X A B:set,
  A c= B ->
  B c= X ->
  topology_on X ((UPair Empty A :\/: {B}) :\/: {X}).
let X A B. assume HAB HBX.
set T0 := UPair Empty A :\/: {B}.
set T := T0 :\/: {X}.
claim HA_X: A c= X.
{ exact (Subq_tra A B X HAB HBX). }
claim HTPow: T c= Power X.
{ let U. assume HU: U :e T.
  prove U :e Power X.
  apply (binunionE' T0 {X} U (U :e Power X)).
  - assume HU0: U :e T0.
    apply (binunionE' (UPair Empty A) {B} U (U :e Power X)).
    + assume HU1: U :e UPair Empty A.
      apply (UPairE U Empty A HU1).
      * assume HUeq: U = Empty. rewrite HUeq. exact (Empty_In_Power X).
      * assume HUeq: U = A. rewrite HUeq. exact (PowerI X A HA_X).
    + assume HU1: U :e {B}.
      claim HUeq: U = B.
      { exact (SingE B U HU1). }
      rewrite HUeq.
      exact (PowerI X B HBX).
    + exact HU0.
  - assume HU0: U :e {X}.
    claim HUeq: U = X.
    { exact (SingE X U HU0). }
    rewrite HUeq.
    exact (Self_In_Power X).
  - exact HU.
}
claim HEmptyIn: Empty :e T.
{ exact (binunionI1 T0 {X} Empty (binunionI1 (UPair Empty A) {B} Empty (UPairI1 Empty A))). }
claim HXIn: X :e T.
{ exact (binunionI2 T0 {X} X (SingI X)). }
prove topology_on X T.
prove (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T))
  /\ (forall U :e T, forall V :e T, U :/\: V :e T).
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - exact HTPow.
      - exact HEmptyIn.
    * exact HXIn.
  + let UFam. assume HUFam: UFam :e Power T.
    prove Union UFam :e T.
    claim HUFsub: UFam c= T.
    { exact (PowerE T UFam HUFam). }
    apply (xm (X :e UFam)).
    * assume HXUF: X :e UFam.
      claim HUnionSub: Union UFam c= X.
      { claim HUFpowX: UFam c= Power X.
        { let U. assume HU: U :e UFam.
          exact (HTPow U (HUFsub U HU)).
        }
        exact (Union_Power X UFam HUFpowX).
      }
      claim HUnionEq: Union UFam = X.
      { apply set_ext.
        - exact HUnionSub.
        - let x. assume HxX: x :e X.
          exact (UnionI UFam x X HxX HXUF).
      }
      rewrite HUnionEq.
      exact HXIn.
    * assume HXnot: X /:e UFam.
      apply (xm (B :e UFam)).
      - assume HBUF: B :e UFam.
         claim HUnionSub: Union UFam c= B.
         { let x. assume Hx: x :e Union UFam.
           prove x :e B.
           apply UnionE_impred UFam x Hx.
           let U. assume HxU: x :e U. assume HUUF: U :e UFam.
           claim HUinT: U :e T.
           { exact (HUFsub U HUUF). }
           apply (binunionE' T0 {X} U (x :e B)).
           - assume HU0: U :e T0.
             apply (binunionE' (UPair Empty A) {B} U (x :e B)).
             + assume HU1: U :e UPair Empty A.
	               apply (UPairE U Empty A HU1).
	               * assume HUeq: U = Empty.
		                 claim HxEmpty: x :e Empty.
		                 { rewrite <- HUeq. exact HxU. }
		                 exact (EmptyE x HxEmpty (x :e B)).
	               * assume HUeq: U = A.
	                 claim HxA: x :e A.
	                 { rewrite <- HUeq. exact HxU. }
	                 exact (HAB x HxA).
             + assume HU1: U :e {B}.
	               claim HUeq: U = B.
	               { exact (SingE B U HU1). }
	               rewrite <- HUeq.
	               exact HxU.
             + exact HU0.
           - assume HU0: U :e {X}.
	             claim HUeq: U = X.
	             { exact (SingE X U HU0). }
	             apply FalseE.
	             claim HXUF2: X :e UFam.
	             { rewrite <- HUeq. exact HUUF. }
	             exact (HXnot HXUF2).
           - exact HUinT.
         }
         claim HUnionEq: Union UFam = B.
         { apply set_ext.
           - exact HUnionSub.
           - let x. assume HxB: x :e B.
             exact (UnionI UFam x B HxB HBUF).
         }
         rewrite HUnionEq.
         exact (binunionI1 T0 {X} B (binunionI2 (UPair Empty A) {B} B (SingI B))).
      - assume HBnot: B /:e UFam.
         apply (xm (A :e UFam)).
         - assume HAUF: A :e UFam.
             claim HUnionSub: Union UFam c= A.
             { let x. assume Hx: x :e Union UFam.
               prove x :e A.
               apply UnionE_impred UFam x Hx.
               let U. assume HxU: x :e U. assume HUUF: U :e UFam.
               claim HUinT: U :e T.
               { exact (HUFsub U HUUF). }
               apply (binunionE' T0 {X} U (x :e A)).
               * assume HU0: U :e T0.
                 apply (binunionE' (UPair Empty A) {B} U (x :e A)).
                 + assume HU1: U :e UPair Empty A.
	                   apply (UPairE U Empty A HU1).
	                   - assume HUeq: U = Empty.
	                      claim HxEmpty: x :e Empty.
	                      { rewrite <- HUeq. exact HxU. }
	                      exact (EmptyE x HxEmpty (x :e A)).
	                   - assume HUeq: U = A.
	                      rewrite <- HUeq.
	                      exact HxU.
                 + assume HU1: U :e {B}.
	                   claim HUeq: U = B.
	                   { exact (SingE B U HU1). }
	                   apply FalseE.
	                   claim HBUF2: B :e UFam.
	                   { rewrite <- HUeq. exact HUUF. }
	                   exact (HBnot HBUF2).
                 + exact HU0.
               * assume HU0: U :e {X}.
	                 claim HUeq: U = X.
	                 { exact (SingE X U HU0). }
	                 apply FalseE.
	                 claim HXUF2: X :e UFam.
	                 { rewrite <- HUeq. exact HUUF. }
	                 exact (HXnot HXUF2).
               * exact HUinT.
             }
             claim HUnionEq: Union UFam = A.
             { apply set_ext.
               - exact HUnionSub.
               - let x. assume HxA: x :e A.
                 exact (UnionI UFam x A HxA HAUF).
             }
             rewrite HUnionEq.
             exact (binunionI1 T0 {X} A (binunionI1 (UPair Empty A) {B} A (UPairI2 Empty A))).
         - assume HAnot: A /:e UFam.
             claim HUnionEq: Union UFam = Empty.
             { apply set_ext.
               - let x. assume Hx: x :e Union UFam.
                 prove x :e Empty.
                 apply UnionE_impred UFam x Hx.
                 let U. assume HxU: x :e U. assume HUUF: U :e UFam.
                 claim HUinT: U :e T.
                 { exact (HUFsub U HUUF). }
                 apply (binunionE' T0 {X} U (x :e Empty)).
                 + assume HU0: U :e T0.
                   apply (binunionE' (UPair Empty A) {B} U (x :e Empty)).
                   * assume HU1: U :e UPair Empty A.
	                     apply (UPairE U Empty A HU1).
	                     - assume HUeq: U = Empty.
	                        rewrite <- HUeq.
	                        exact HxU.
	                     - assume HUeq: U = A.
	                        apply FalseE.
	                        claim HAUF2: A :e UFam.
	                        { rewrite <- HUeq. exact HUUF. }
	                        exact (HAnot HAUF2).
                   * assume HU1: U :e {B}.
	                     claim HUeq: U = B.
	                     { exact (SingE B U HU1). }
	                     apply FalseE.
	                     claim HBUF2: B :e UFam.
	                     { rewrite <- HUeq. exact HUUF. }
	                     exact (HBnot HBUF2).
                   * exact HU0.
                 + assume HU0: U :e {X}.
	                   claim HUeq: U = X.
	                   { exact (SingE X U HU0). }
	                   apply FalseE.
	                   claim HXUF2: X :e UFam.
	                   { rewrite <- HUeq. exact HUUF. }
	                   exact (HXnot HXUF2).
                 + exact HUinT.
               - let x. assume Hx: x :e Empty.
                 exact (EmptyE x Hx (x :e Union UFam)).
             }
             rewrite HUnionEq.
             exact HEmptyIn.
- let U. assume HU: U :e T.
  let V. assume HV: V :e T.
  prove U :/\: V :e T.
  apply (binunionE' T0 {X} U (U :/\: V :e T)).
  - assume HU0: U :e T0.
    apply (binunionE' (UPair Empty A) {B} U (U :/\: V :e T)).
    + assume HU1: U :e UPair Empty A.
      apply (UPairE U Empty A HU1).
	      * assume HUeq: U = Empty.
	        rewrite HUeq.
	        claim HcapEq: Empty :/\: V = Empty.
	        { exact (binintersect_Empty_left V). }
	        rewrite HcapEq.
	        exact HEmptyIn.
      * assume HUeq: U = A.
        rewrite HUeq.
        apply (binunionE' T0 {X} V (A :/\: V :e T)).
        - assume HV0: V :e T0.
           apply (binunionE' (UPair Empty A) {B} V (A :/\: V :e T)).
           - assume HV1: V :e UPair Empty A.
               apply (UPairE V Empty A HV1).
	               * assume HVeq: V = Empty.
	                 rewrite HVeq.
	                 claim HcapEq: A :/\: Empty = Empty.
	                 { exact (binintersect_Empty_right A). }
	                 rewrite HcapEq.
	                 exact HEmptyIn.
               * assume HVeq: V = A.
                 rewrite HVeq.
                 claim HcapEq: A :/\: A = A.
                 { exact (binintersect_Subq_eq_1 A A (Subq_ref A)). }
                 rewrite HcapEq.
                 exact (binunionI1 T0 {X} A (binunionI1 (UPair Empty A) {B} A (UPairI2 Empty A))).
           - assume HV1: V :e {B}.
               claim HVeq: V = B.
               { exact (SingE B V HV1). }
               rewrite HVeq.
               claim HcapEq: A :/\: B = A.
               { exact (binintersect_Subq_eq_1 A B HAB). }
               rewrite HcapEq.
               exact (binunionI1 T0 {X} A (binunionI1 (UPair Empty A) {B} A (UPairI2 Empty A))).
           - exact HV0.
        - assume HV0: V :e {X}.
           claim HVeq: V = X.
           { exact (SingE X V HV0). }
           rewrite HVeq.
           claim HcapEq: A :/\: X = A.
           { exact (binintersect_Subq_eq_1 A X HA_X). }
           rewrite HcapEq.
           exact (binunionI1 T0 {X} A (binunionI1 (UPair Empty A) {B} A (UPairI2 Empty A))).
        - exact HV.
    + assume HU1: U :e {B}.
      claim HUeq: U = B.
      { exact (SingE B U HU1). }
      rewrite HUeq.
      apply (binunionE' T0 {X} V (B :/\: V :e T)).
      * assume HV0: V :e T0.
        apply (binunionE' (UPair Empty A) {B} V (B :/\: V :e T)).
        - assume HV1: V :e UPair Empty A.
           apply (UPairE V Empty A HV1).
	           - assume HVeq: V = Empty.
	               rewrite HVeq.
	               claim HcapEq: B :/\: Empty = Empty.
	               { exact (binintersect_Empty_right B). }
	               rewrite HcapEq.
	               exact HEmptyIn.
           - assume HVeq: V = A.
               rewrite HVeq.
               claim HcapEq: B :/\: A = A.
               { rewrite (binintersect_com B A). exact (binintersect_Subq_eq_1 A B HAB). }
               rewrite HcapEq.
               exact (binunionI1 T0 {X} A (binunionI1 (UPair Empty A) {B} A (UPairI2 Empty A))).
        - assume HV1: V :e {B}.
           claim HVeq: V = B.
           { exact (SingE B V HV1). }
           rewrite HVeq.
           claim HcapEq: B :/\: B = B.
           { exact (binintersect_Subq_eq_1 B B (Subq_ref B)). }
           rewrite HcapEq.
           exact (binunionI1 T0 {X} B (binunionI2 (UPair Empty A) {B} B (SingI B))).
        - exact HV0.
      * assume HV0: V :e {X}.
        claim HVeq: V = X.
        { exact (SingE X V HV0). }
        rewrite HVeq.
        claim HcapEq: B :/\: X = B.
        { exact (binintersect_Subq_eq_1 B X HBX). }
        rewrite HcapEq.
        exact (binunionI1 T0 {X} B (binunionI2 (UPair Empty A) {B} B (SingI B))).
      * exact HV.
    + exact HU0.
  - assume HU0: U :e {X}.
    claim HUeq: U = X.
    { exact (SingE X U HU0). }
    rewrite HUeq.
    claim HVpow: V :e Power X.
    { exact (HTPow V HV). }
    claim HVsub: V c= X.
    { exact (PowerE X V HVpow). }
    claim HcapEq: X :/\: V = V.
    { rewrite (binintersect_com X V). exact (binintersect_Subq_eq_1 V X HVsub). }
    rewrite HcapEq.
    exact HV.
  - exact HU.
Qed.

Theorem ex13_2_compare_nine_topologies :
  topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
  topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
  topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6 /\
  topology_on abc_set top_abc_7 /\ topology_on abc_set top_abc_8 /\
  topology_on abc_set top_abc_9 /\
  exists finer_pairs:set,
    finer_pairs =
      {p :e Power (Power (Power abc_set))|
         exists T1 T2:set, p = setprod T1 T2 /\
           (T1 = top_abc_1 \/ T1 = top_abc_2 \/ T1 = top_abc_3 \/
            T1 = top_abc_4 \/ T1 = top_abc_5 \/ T1 = top_abc_6 \/
            T1 = top_abc_7 \/ T1 = top_abc_8 \/ T1 = top_abc_9) /\
           (T2 = top_abc_1 \/ T2 = top_abc_2 \/ T2 = top_abc_3 \/
            T2 = top_abc_4 \/ T2 = top_abc_5 \/ T2 = top_abc_6 \/
           T2 = top_abc_7 \/ T2 = top_abc_8 \/ T2 = top_abc_9) /\
           T1 c= T2}.
prove topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
  topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
  topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6 /\
  topology_on abc_set top_abc_7 /\ topology_on abc_set top_abc_8 /\
  topology_on abc_set top_abc_9 /\
  exists finer_pairs:set,
    finer_pairs =
      {p :e Power (Power (Power abc_set))|
         exists T1 T2:set, p = setprod T1 T2 /\
           (T1 = top_abc_1 \/ T1 = top_abc_2 \/ T1 = top_abc_3 \/
            T1 = top_abc_4 \/ T1 = top_abc_5 \/ T1 = top_abc_6 \/
            T1 = top_abc_7 \/ T1 = top_abc_8 \/ T1 = top_abc_9) /\
           (T2 = top_abc_1 \/ T2 = top_abc_2 \/ T2 = top_abc_3 \/
            T2 = top_abc_4 \/ T2 = top_abc_5 \/ T2 = top_abc_6 \/
           T2 = top_abc_7 \/ T2 = top_abc_8 \/ T2 = top_abc_9) /\
           T1 c= T2}.
apply andI.
- (** nine topology axioms **)
  claim proof1 : topology_on abc_set top_abc_1.
  { claim Ht1: top_abc_1 = indiscrete_topology abc_set.
    { reflexivity. }
    rewrite Ht1.
    exact (indiscrete_topology_on abc_set). }
  claim proof2 : topology_on abc_set top_abc_2.
  { claim Ht2: top_abc_2 = discrete_topology abc_set.
    { reflexivity. }
    rewrite Ht2.
    exact (discrete_topology_on abc_set). }
  claim proof3 : topology_on abc_set top_abc_3.
  { claim HA: {a_elt} c= abc_set.
    { let x. assume Hx: x :e {a_elt}.
      prove x :e abc_set.
      claim Hxeq: x = a_elt.
      { exact (SingE a_elt x Hx). }
      rewrite Hxeq.
      exact (binunionI1 (UPair a_elt b_elt) {c_elt} a_elt (UPairI1 a_elt b_elt)).
    }
    exact (topology_three_sets abc_set {a_elt} HA). }
  claim proof4 : topology_on abc_set top_abc_4.
  { claim HB: {b_elt} c= abc_set.
    { let x. assume Hx: x :e {b_elt}.
      prove x :e abc_set.
      claim Hxeq: x = b_elt.
      { exact (SingE b_elt x Hx). }
      rewrite Hxeq.
      exact (binunionI1 (UPair a_elt b_elt) {c_elt} b_elt (UPairI2 a_elt b_elt)).
    }
    exact (topology_three_sets abc_set {b_elt} HB). }
  claim proof5 : topology_on abc_set top_abc_5.
  { claim HC: {c_elt} c= abc_set.
    { let x. assume Hx: x :e {c_elt}.
      prove x :e abc_set.
      claim Hxeq: x = c_elt.
      { exact (SingE c_elt x Hx). }
      rewrite Hxeq.
      exact (binunionI2 (UPair a_elt b_elt) {c_elt} c_elt (SingI c_elt)).
    }
    exact (topology_three_sets abc_set {c_elt} HC). }
  claim proof6 : topology_on abc_set top_abc_6.
  { claim HAB: (UPair a_elt b_elt) c= abc_set.
    { let x. assume Hx: x :e UPair a_elt b_elt.
      prove x :e abc_set.
      apply (UPairE x a_elt b_elt Hx).
      - assume Hxeq: x = a_elt.
        rewrite Hxeq.
        exact (binunionI1 (UPair a_elt b_elt) {c_elt} a_elt (UPairI1 a_elt b_elt)).
      - assume Hxeq: x = b_elt.
        rewrite Hxeq.
        exact (binunionI1 (UPair a_elt b_elt) {c_elt} b_elt (UPairI2 a_elt b_elt)).
    }
    exact (topology_three_sets abc_set (UPair a_elt b_elt) HAB). }
  claim proof7 : topology_on abc_set top_abc_7.
  { claim HAC: (UPair a_elt c_elt) c= abc_set.
    { let x. assume Hx: x :e UPair a_elt c_elt.
      prove x :e abc_set.
      apply (UPairE x a_elt c_elt Hx).
      - assume Hxeq: x = a_elt.
        rewrite Hxeq.
        exact (binunionI1 (UPair a_elt b_elt) {c_elt} a_elt (UPairI1 a_elt b_elt)).
      - assume Hxeq: x = c_elt.
        rewrite Hxeq.
        exact (binunionI2 (UPair a_elt b_elt) {c_elt} c_elt (SingI c_elt)).
    }
    exact (topology_three_sets abc_set (UPair a_elt c_elt) HAC). }
  claim proof8 : topology_on abc_set top_abc_8.
  { claim HBC: (UPair b_elt c_elt) c= abc_set.
    { let x. assume Hx: x :e UPair b_elt c_elt.
      prove x :e abc_set.
      apply (UPairE x b_elt c_elt Hx).
      - assume Hxeq: x = b_elt.
        rewrite Hxeq.
        exact (binunionI1 (UPair a_elt b_elt) {c_elt} b_elt (UPairI2 a_elt b_elt)).
      - assume Hxeq: x = c_elt.
        rewrite Hxeq.
        exact (binunionI2 (UPair a_elt b_elt) {c_elt} c_elt (SingI c_elt)).
    }
    exact (topology_three_sets abc_set (UPair b_elt c_elt) HBC). }
  claim proof9 : topology_on abc_set top_abc_9.
  { claim HAinAB: {a_elt} c= UPair a_elt b_elt.
    { let x. assume Hx: x :e {a_elt}.
      prove x :e UPair a_elt b_elt.
      claim Hxeq: x = a_elt.
      { exact (SingE a_elt x Hx). }
      rewrite Hxeq.
      exact (UPairI1 a_elt b_elt).
    }
    claim HABsubX: UPair a_elt b_elt c= abc_set.
    { let x. assume Hx: x :e UPair a_elt b_elt.
      prove x :e abc_set.
      exact (binunionI1 (UPair a_elt b_elt) {c_elt} x Hx).
    }
    exact (topology_chain_four_sets abc_set {a_elt} (UPair a_elt b_elt) HAinAB HABsubX). }
  claim H6 :
    topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
    topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
    topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6.
  { apply and6I.
    + exact proof1.
    + exact proof2.
    + exact proof3.
    + exact proof4.
    + exact proof5.
    + exact proof6. }
  claim H7 :
    (topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
     topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
     topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6)
    /\ topology_on abc_set top_abc_7.
  { apply andI.
    - exact H6.
    - exact proof7. }
  claim H8 :
    ((topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
      topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
      topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6)
     /\ topology_on abc_set top_abc_7)
    /\ topology_on abc_set top_abc_8.
  { apply andI.
    - exact H7.
    - exact proof8. }
  claim H9 :
    (((topology_on abc_set top_abc_1 /\ topology_on abc_set top_abc_2 /\
       topology_on abc_set top_abc_3 /\ topology_on abc_set top_abc_4 /\
       topology_on abc_set top_abc_5 /\ topology_on abc_set top_abc_6)
      /\ topology_on abc_set top_abc_7)
     /\ topology_on abc_set top_abc_8)
    /\ topology_on abc_set top_abc_9.
  { apply andI.
    - exact H8.
    - exact proof9. }
  exact H9.
- (** finer_pairs set of refinement pairs **)
  witness
    {p :e Power (Power (Power abc_set))|
       exists T1 T2:set, p = setprod T1 T2 /\
         (T1 = top_abc_1 \/ T1 = top_abc_2 \/ T1 = top_abc_3 \/
          T1 = top_abc_4 \/ T1 = top_abc_5 \/ T1 = top_abc_6 \/
          T1 = top_abc_7 \/ T1 = top_abc_8 \/ T1 = top_abc_9) /\
         (T2 = top_abc_1 \/ T2 = top_abc_2 \/ T2 = top_abc_3 \/
          T2 = top_abc_4 \/ T2 = top_abc_5 \/ T2 = top_abc_6 \/
          T2 = top_abc_7 \/ T2 = top_abc_8 \/ T2 = top_abc_9) /\
         T1 c= T2}.
  reflexivity.
Qed.

(** from §13 Exercise 2: some basic fineness relations between the nine examples **)
(** LATEX VERSION: Exercise 2 asks to compare the nine topologies by inclusion (finer/coarser). **)
Theorem top_abc_3_finer_than_top_abc_1 : finer_than top_abc_3 top_abc_1.
let U. assume HU: U :e top_abc_1.
prove U :e top_abc_3.
apply (UPairE U Empty abc_set HU).
- assume HUeq: U = Empty.
  rewrite HUeq.
  exact (binunionI1 (UPair Empty {a_elt}) {abc_set} Empty (UPairI1 Empty {a_elt})).
- assume HUeq: U = abc_set.
  rewrite HUeq.
  exact (binunionI2 (UPair Empty {a_elt}) {abc_set} abc_set (SingI abc_set)).
Qed.

Theorem top_abc_2_finer_than_top_abc_3 : finer_than top_abc_2 top_abc_3.
let U. assume HU: U :e top_abc_3.
prove U :e top_abc_2.
(** top_abc_2 = Power abc_set; show U c= abc_set **)
claim Ht2: top_abc_2 = Power abc_set.
{ reflexivity. }
rewrite Ht2.
apply PowerI.
let x. assume Hx: x :e U.
prove x :e abc_set.
apply (binunionE' (UPair Empty {a_elt}) {abc_set} U (x :e abc_set)).
- assume HU0: U :e UPair Empty {a_elt}.
  apply (UPairE U Empty {a_elt} HU0).
  + assume HUeq: U = Empty.
    claim HxEmpty: x :e Empty.
    { rewrite <- HUeq. exact Hx. }
    exact (EmptyE x HxEmpty (x :e abc_set)).
  + assume HUeq: U = {a_elt}.
    claim HxSing: x :e {a_elt}.
    { rewrite <- HUeq. exact Hx. }
    claim Hxeq: x = a_elt.
    { exact (SingE a_elt x HxSing). }
    rewrite Hxeq.
    exact (binunionI1 (UPair a_elt b_elt) {c_elt} a_elt (UPairI1 a_elt b_elt)).
- assume HU0: U :e {abc_set}.
  claim HUeq: U = abc_set.
  { exact (SingE abc_set U HU0). }
  rewrite <- HUeq.
  exact Hx.
- exact HU.
Qed.

Theorem top_abc_9_finer_than_top_abc_3 : finer_than top_abc_9 top_abc_3.
let U. assume HU: U :e top_abc_3.
prove U :e top_abc_9.
apply (binunionE' (UPair Empty {a_elt}) {abc_set} U (U :e top_abc_9)).
- assume HU0: U :e UPair Empty {a_elt}.
  exact (binunionI1 (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) {abc_set} U
          (binunionI1 (UPair Empty {a_elt}) {UPair a_elt b_elt} U HU0)).
- assume HU0: U :e {abc_set}.
  claim HUeq: U = abc_set.
  { exact (SingE abc_set U HU0). }
  rewrite HUeq.
  exact (binunionI2 (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) {abc_set} abc_set (SingI abc_set)).
- exact HU.
Qed.

Theorem top_abc_9_finer_than_top_abc_6 : finer_than top_abc_9 top_abc_6.
let U. assume HU: U :e top_abc_6.
prove U :e top_abc_9.
apply (binunionE' (UPair Empty (UPair a_elt b_elt)) {abc_set} U (U :e top_abc_9)).
- assume HU0: U :e UPair Empty (UPair a_elt b_elt).
  apply (UPairE U Empty (UPair a_elt b_elt) HU0).
  + assume HUeq: U = Empty.
    rewrite HUeq.
    exact (binunionI1 (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) {abc_set} Empty
            (binunionI1 (UPair Empty {a_elt}) {UPair a_elt b_elt} Empty (UPairI1 Empty {a_elt}))).
  + assume HUeq: U = UPair a_elt b_elt.
    rewrite HUeq.
    exact (binunionI1 (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) {abc_set} (UPair a_elt b_elt)
            (binunionI2 (UPair Empty {a_elt}) {UPair a_elt b_elt} (UPair a_elt b_elt) (SingI (UPair a_elt b_elt)))).
- assume HU0: U :e {abc_set}.
  claim HUeq: U = abc_set.
  { exact (SingE abc_set U HU0). }
  rewrite HUeq.
  exact (binunionI2 (UPair Empty {a_elt} :\/: {UPair a_elt b_elt}) {abc_set} abc_set (SingI abc_set)).
- exact HU.
Qed.

(** helper for §13 exercises: intersection of a family of topologies (placeholder) **)
(** LATEX VERSION: Intersection_Fam X Fam denotes the intersection (common opens) of all topologies in Fam. **)
(** FIXED: `Intersection_Fam X Fam` is the collection of common open sets, as subsets of the given ambient set `X`; for `Fam = Empty`, `Intersection_Fam X Fam = Power X`. **)
Definition Intersection_Fam : set -> set -> set :=
  fun X Fam => {U :e Power X|forall T:set, T :e Fam -> U :e T}.

(** helper: empty family gives discrete topology **)
Theorem Intersection_Fam_empty_eq : forall X Fam:set,
  ~(exists T:set, T :e Fam) ->
  Intersection_Fam X Fam = Power X.
let X Fam.
assume HFamEmpty: ~(exists T:set, T :e Fam).
apply set_ext.
- let U. assume HU: U :e Intersection_Fam X Fam.
  exact (SepE1 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HU).
- let U. assume HU: U :e Power X.
  claim HAllT: forall T:set, T :e Fam -> U :e T.
  { let T. assume HT: T :e Fam.
    apply FalseE.
    apply HFamEmpty.
    witness T. exact HT.
  }
  exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HU HAllT).
Qed.

(** helper: intersection of a family stays within X (updated for new signature) **)
Theorem intersection_of_family_sub_X : forall X Fam:set,
  intersection_of_family X Fam c= X.
let X Fam.
let x. assume Hx.
exact (SepE1 X (fun x0 => forall U:set, U :e Fam -> x0 :e U) x Hx).
Qed.

(** helper: empty set is in intersection family when all members contain Empty **)
Theorem intersection_of_family_empty : forall Fam:set,
  (forall T:set, T :e Fam -> Empty :e T) ->
  forall X:set, Empty :e Intersection_Fam X Fam.
let Fam.
assume HFamEmpty: forall T:set, T :e Fam -> Empty :e T.
let X.
prove Empty :e Intersection_Fam X Fam.
(** Intersection_Fam X Fam = {U :e Power X | forall T :e Fam, U :e T} **)
claim HEmptyPower: Empty :e Power X.
{ apply PowerI. apply Subq_Empty. }
exact (SepI (Power X) (fun U => forall T:set, T :e Fam -> U :e T) Empty HEmptyPower HFamEmpty).
Qed.

(** from §12 Exercises Item 3: countable complement topology and Tinfty **) 
(** LATEX VERSION: Show that the collection Tc from Example 4 of §12 is a topology on X. Is the collection Tinfty = {U | X-U is infinite or empty or all of X} a topology on X. **)
Definition infinite_complement_family : set -> set :=
  fun X => {U :e Power X | infinite (X :\: U) \/ U = Empty \/ U = X}.

(** LATEX VERSION: Exercise 3: The countable-complement topology Tc on X is a topology. **)
Theorem ex13_3a_Tc_topology : forall X:set, topology_on X (countable_complement_topology X).
let X.
exact (countable_complement_topology_on X).
Qed.

(** helper: nonempty open sets in T_c have countable complement (placeholder) **) 
Theorem ex13_3a_countable_complement_open : forall X:set, forall U :e countable_complement_topology X,
  U <> Empty -> countable (X :\: U).
let X U.
assume HU: U :e countable_complement_topology X.
assume Hnemp: U <> Empty.
prove countable (X :\: U).
(** By definition, U ∈ countable_complement_topology X means countable(X\\U) ∨ U = Empty; since U ≠ Empty, we get countable(X\\U). **)
claim Hprop: countable (X :\: U) \/ U = Empty.
{ exact (SepE2 (Power X) (fun V:set => countable (X :\: V) \/ V = Empty) U HU). }
claim Hcount_branch: countable (X :\: U) -> countable (X :\: U).
{ assume Hcount. exact Hcount. }
claim Hempty_branch: U = Empty -> countable (X :\: U).
{ assume HUeq.
  apply FalseE.
  exact (Hnemp HUeq). }
exact (Hprop (countable (X :\: U)) Hcount_branch Hempty_branch).
Qed.

(** helper: unions of Tc open families remain Tc-open (placeholder) **) 
Theorem ex13_3a_union_helper : forall X:set, forall UFam :e Power (countable_complement_topology X),
  Union UFam :e countable_complement_topology X.
let X UFam.
assume HUFam: UFam :e Power (countable_complement_topology X).
prove Union UFam :e countable_complement_topology X.
(** This follows from countable_complement_topology_on plus the union axiom of topology_on **)
claim Htop : topology_on X (countable_complement_topology X).
{ exact (countable_complement_topology_on X). }
exact (topology_union_axiom X (countable_complement_topology X) Htop UFam HUFam).
Qed.

(** helper: removing a finite subset from an infinite set leaves an infinite set **)
(** LATEX VERSION: If X is infinite and F is finite, then X\\F is infinite. **)
Theorem infinite_setminus_finite : forall X F:set,
  infinite X -> finite F -> infinite (X :\: F).
let X F.
assume HinfX: infinite X.
assume HfinF: finite F.
prove infinite (X :\: F).
assume HfinXF: finite (X :\: F).
claim HfinU: finite ((X :\: F) :\/: F).
{ exact (binunion_finite (X :\: F) HfinXF F HfinF). }
claim HXsubU: X c= (X :\: F) :\/: F.
{ let x. assume HxX: x :e X.
  apply (xm (x :e F)).
  - assume HxF: x :e F.
    exact (binunionI2 (X :\: F) F x HxF).
  - assume HxnotF: ~(x :e F).
    claim HxXF: x :e X :\: F.
    { exact (setminusI X F x HxX HxnotF). }
    exact (binunionI1 (X :\: F) F x HxXF).
}
claim HfinX: finite X.
{ exact (Subq_finite ((X :\: F) :\/: F) HfinU X HXsubU). }
exact (HinfX HfinX).
Qed.

(** helper: infinite sets are nonempty **)
(** LATEX VERSION: (set theory) An infinite set cannot be empty. **)
Theorem infinite_nonempty : forall X:set, infinite X -> exists x:set, x :e X.
let X.
assume HinfX: infinite X.
apply (xm (exists x:set, x :e X)).
- assume Hex. exact Hex.
- assume Hno: ~(exists x:set, x :e X).
  prove exists x:set, x :e X.
  apply FalseE.
  claim HXeq: X = Empty.
  { apply set_ext.
    - let x. assume HxX: x :e X.
      prove x :e Empty.
      apply FalseE.
      apply Hno.
      witness x.
      exact HxX.
    - let x. assume HxE: x :e Empty.
      prove x :e X.
      apply FalseE.
      exact (EmptyE x HxE).
  }
  claim HfinX: finite X.
  { rewrite HXeq.
    exact finite_Empty. }
  exact (HinfX HfinX).
Qed.

(** helper: unordered pairs are finite **)
(** LATEX VERSION: (set theory) A two-element set {a,b} is finite. **)
Theorem finite_UPair : forall a b:set, finite (UPair a b).
let a b.
set Y := {a} :\/: {b}.
claim HfinY: finite Y.
{ exact (binunion_finite {a} (Sing_finite a) {b} (Sing_finite b)). }
claim Hsub: (UPair a b) c= Y.
{ let x. assume Hx: x :e UPair a b.
  apply (UPairE x a b Hx (x :e Y)).
  - assume Hxa: x = a.
    rewrite Hxa.
    exact (binunionI1 {a} {b} a (SingI a)).
  - assume Hxb: x = b.
    rewrite Hxb.
    exact (binunionI2 {a} {b} b (SingI b)).
}
exact (Subq_finite Y HfinY (UPair a b) Hsub).
Qed.

(** helper: removing two points from an infinite set leaves an infinite set **)
(** LATEX VERSION: (set theory) If X is infinite then X\\{a,b} is infinite. **)
Theorem infinite_remove2 : forall X a b:set, infinite X -> infinite (X :\: UPair a b).
let X a b.
assume HinfX: infinite X.
exact (infinite_setminus_finite X (UPair a b) HinfX (finite_UPair a b)).
Qed.

(** helper: infinite sets contain two distinct elements **)
(** LATEX VERSION: (set theory) If X is infinite then there exist a,b in X with a ≠ b. **)
Theorem infinite_two_distinct : forall X:set,
  infinite X -> exists a b:set, a :e X /\ b :e X /\ ~(a = b).
let X.
assume HinfX: infinite X.
apply (infinite_nonempty X HinfX).
let a.
assume HaX.
apply (xm (exists b:set, b :e X /\ ~(b = a))).
- assume Hex.
  apply Hex.
  let b. assume Hb.
  witness a.
  witness b.
  apply andI.
  - (** a :e X /\ b :e X **)
    apply andI.
    + exact HaX.
    + exact (andEL (b :e X) (~(b = a)) Hb).
  - (** ~(a=b) **)
    assume Hab: a = b.
    claim Hba: b = a.
    { prove b = a.
      rewrite <- Hab.
      reflexivity. }
    exact ((andER (b :e X) (~(b = a)) Hb) Hba).
- assume Hno: ~(exists b:set, b :e X /\ ~(b = a)).
  prove exists a b:set, a :e X /\ b :e X /\ ~(a = b).
  apply FalseE.
  (** show X = {a} **)
  claim HXeq: X = {a}.
  { apply set_ext.
    - let x. assume HxX: x :e X.
      prove x :e {a}.
      claim Hxeq: x = a.
      { apply (xm (x = a)).
        - assume Hxa. exact Hxa.
        - assume Hxna: ~(x = a).
          apply FalseE.
          apply Hno.
          witness x.
          apply andI.
          + exact HxX.
          + exact Hxna.
      }
      rewrite Hxeq.
      exact (SingI a).
    - let x. assume HxS: x :e {a}.
      prove x :e X.
      claim Hxeq: x = a.
      { exact (SingE a x HxS). }
      rewrite Hxeq.
      exact HaX.
  }
  claim HfinX: finite X.
  { rewrite HXeq.
    exact (Sing_finite a). }
  exact (HinfX HfinX).
Qed.

(** helper: infinite minus finite is nonempty **)
(** LATEX VERSION: (set theory) If X is infinite and F is finite then X\\F is nonempty. **)
Theorem infinite_setminus_finite_nonempty : forall X F:set,
  infinite X -> finite F -> exists x:set, x :e X :\: F.
let X F.
assume HinfX: infinite X.
assume HfinF: finite F.
claim HinfXF: infinite (X :\: F).
{ exact (infinite_setminus_finite X F HinfX HfinF). }
exact (infinite_nonempty (X :\: F) HinfXF).
Qed.

(** helper: removing one point from an infinite set leaves an infinite set (proved in topology section) **)
(** LATEX VERSION: (set theory) If X is infinite then X\\{y} is infinite. **)
Theorem infinite_remove1_top : forall X y:set, infinite X -> infinite (X :\: {y}).
let X y.
assume HinfX: infinite X.
exact (infinite_setminus_finite X {y} HinfX (Sing_finite y)).
Qed.

(** LATEX VERSION: Exercise 3: For infinite X, Tinfty is not a topology (union-closure fails). **)
Theorem ex13_3b_Tinfty_not_topology : forall X:set,
  infinite X ->
  ~topology_on X (infinite_complement_family X).
let X.
assume HinfX: infinite X.
assume Htop: topology_on X (infinite_complement_family X).
prove False.
(** Extract union-closure axiom from topology_on **)
claim H1:
  ((infinite_complement_family X c= Power X /\ Empty :e infinite_complement_family X) /\ X :e infinite_complement_family X) /\
  (forall UFam :e Power (infinite_complement_family X), Union UFam :e infinite_complement_family X).
{ exact (andEL (((infinite_complement_family X c= Power X /\ Empty :e infinite_complement_family X) /\ X :e infinite_complement_family X) /\
               (forall UFam :e Power (infinite_complement_family X), Union UFam :e infinite_complement_family X))
              (forall U :e infinite_complement_family X,
                 forall V :e infinite_complement_family X,
                   U :/\: V :e infinite_complement_family X)
              Htop). }
claim HUnionClosure: forall UFam :e Power (infinite_complement_family X),
  Union UFam :e infinite_complement_family X.
{ exact (andER ((infinite_complement_family X c= Power X /\ Empty :e infinite_complement_family X) /\ X :e infinite_complement_family X)
              (forall UFam :e Power (infinite_complement_family X), Union UFam :e infinite_complement_family X)
              H1). }
(** Build a family of finite subsets of X\\{p}; each is Tinfty-open, but the union is X\\{p}, which is not Tinfty-open. **)
apply (infinite_nonempty X HinfX).
let p. assume HpX: p :e X.
set Y := X :\: {p}.
set Fam := {F :e Power Y | finite F}.

(** Fam is a subfamily of Tinfty-open sets **)
claim HFamSub: Fam c= infinite_complement_family X.
{ let F. assume HF: F :e Fam.
  claim HFpowY: F :e Power Y.
  { exact (SepE1 (Power Y) (fun F0:set => finite F0) F HF). }
  claim HFsubY: F c= Y.
  { exact (PowerE Y F HFpowY). }
  claim HYsubX: Y c= X.
  { let x. assume HxY: x :e Y.
    exact (setminusE1 X {p} x HxY). }
  claim HFsubX: F c= X.
  { exact (Subq_tra F Y X HFsubY HYsubX). }
  claim HFpowX: F :e Power X.
  { exact (PowerI X F HFsubX). }
  claim HfinF: finite F.
  { exact (SepE2 (Power Y) (fun F0:set => finite F0) F HF). }
  claim HinfComp: infinite (X :\: F).
  { exact (infinite_setminus_finite X F HinfX HfinF). }
  claim Hpred: infinite (X :\: F) \/ F = Empty \/ F = X.
  { apply orIL.
    apply orIL.
    exact HinfComp. }
  exact (SepI (Power X)
              (fun U0 : set => infinite (X :\: U0) \/ U0 = Empty \/ U0 = X)
              F
              HFpowX
              Hpred).
}
claim HFamPow: Fam :e Power (infinite_complement_family X).
{ apply PowerI.
  exact HFamSub. }

(** Union Fam = Y **)
claim HUnionEq: Union Fam = Y.
{ apply set_ext.
  - let x. assume HxU: x :e Union Fam.
    prove x :e Y.
    apply UnionE_impred Fam x HxU.
    let F. assume HxF: x :e F. assume HF: F :e Fam.
    claim HFpowY: F :e Power Y.
    { exact (SepE1 (Power Y) (fun F0:set => finite F0) F HF). }
    claim HFsubY: F c= Y.
    { exact (PowerE Y F HFpowY). }
    exact (HFsubY x HxF).
  - let x. assume HxY: x :e Y.
    prove x :e Union Fam.
    (** singleton {x} is in Fam **)
    claim HxYsub: {x} c= Y.
    { let z. assume Hz: z :e {x}.
      prove z :e Y.
      claim Hzeq: z = x.
      { exact (SingE x z Hz). }
      rewrite Hzeq.
      exact HxY. }
    claim HxPowY: {x} :e Power Y.
    { exact (PowerI Y {x} HxYsub). }
    claim HxFin: finite {x}.
    { exact (Sing_finite x). }
    claim HsingFam: {x} :e Fam.
    { exact (SepI (Power Y) (fun F0:set => finite F0) {x} HxPowY HxFin). }
    exact (UnionI Fam x {x} (SingI x) HsingFam).
}

(** Y is not Tinfty-open: its complement is {p}, finite, and Y is neither Empty nor X **)
claim HYneX: ~(Y = X).
{ assume Heq: Y = X.
  claim HpY: p :e Y.
  { rewrite Heq. exact HpX. }
  claim Hpnot: p /:e {p}.
  { exact (setminusE2 X {p} p HpY). }
  exact (Hpnot (SingI p)). }
claim HYneEmpty: ~(Y = Empty).
{ assume Heq: Y = Empty.
  claim HyEx: exists x:set, x :e Y.
  { exact (infinite_setminus_finite_nonempty X {p} HinfX (Sing_finite p)). }
  apply HyEx.
  let x. assume HxY.
  claim HxE: x :e Empty.
  { rewrite <- Heq. exact HxY. }
  exact (EmptyE x HxE). }
claim HnotOpenY: ~(Y :e infinite_complement_family X).
{ assume HYopen: Y :e infinite_complement_family X.
  claim HYdisj: infinite (X :\: Y) \/ Y = Empty \/ Y = X.
  { exact (SepE2 (Power X) (fun U0:set => infinite (X :\: U0) \/ U0 = Empty \/ U0 = X) Y HYopen). }
  apply HYdisj.
  - assume Hleft: infinite (X :\: Y) \/ Y = Empty.
    apply Hleft.
	    + (** show ~(infinite (X\\Y)) since X\\Y = {p} is finite **)
	      assume HinfComp: infinite (X :\: Y).
	      claim HcompEq: X :\: Y = {p}.
	      { (** Y = X\\{p} so X\\Y = {p} **)
	        claim HYdef: Y = X :\: {p}.
	        { reflexivity. }
	        rewrite HYdef.
	        apply set_ext.
	        - let x. assume Hx: x :e X :\: (X :\: {p}).
	          prove x :e {p}.
	          claim HxX: x :e X.
	          { exact (setminusE1 X (X :\: {p}) x Hx). }
	          claim HxnotY: x /:e X :\: {p}.
	          { exact (setminusE2 X (X :\: {p}) x Hx). }
	          apply (xm (x :e {p})).
	          * assume HxS. exact HxS.
	          * assume HxnotS: ~(x :e {p}).
	            apply FalseE.
	            apply HxnotY.
	            exact (setminusI X {p} x HxX HxnotS).
	        - let x. assume Hx: x :e {p}.
	          prove x :e X :\: (X :\: {p}).
	          claim Hxeq: x = p.
	          { exact (SingE p x Hx). }
	          rewrite Hxeq.
	          apply setminusI.
	          * exact HpX.
	          * assume HpY: p :e X :\: {p}.
	            claim HpnotS: p /:e {p}.
	            { exact (setminusE2 X {p} p HpY). }
	            exact (HpnotS (SingI p)).
	      }
	      claim HinfSing: infinite {p}.
	      { rewrite <- HcompEq.
	        exact HinfComp. }
	      exact (HinfSing (Sing_finite p)).
    + assume HYemp. exact (HYneEmpty HYemp).
  - assume HYX. exact (HYneX HYX).
}

(** Now the union-closure axiom yields Y open, contradiction **)
claim HUnionIn: Union Fam :e infinite_complement_family X.
{ exact (HUnionClosure Fam HFamPow). }
claim HYopen: Y :e infinite_complement_family X.
{ rewrite <- HUnionEq.
  exact HUnionIn. }
exact (HnotOpenY HYopen).
Qed.

(** helper: structured witness outline for Tinfty failure, for infinite ambient sets **) 
Theorem ex13_3b_witness_outline : forall X:set,
  infinite X -> exists U V:set, U :e infinite_complement_family X /\ V :e infinite_complement_family X.
let X.
assume HinfX: infinite X.
prove exists U V:set, U :e infinite_complement_family X /\ V :e infinite_complement_family X.
witness Empty.
witness X.
apply andI.
- (** Empty is in the family by the defining disjunction **)
  prove Empty :e infinite_complement_family X.
  claim Hdisj : infinite (X :\: Empty) \/ Empty = Empty \/ Empty = X.
  { apply orIL.
    apply orIR.
    reflexivity. }
  exact (SepI (Power X)
              (fun U0 : set => infinite (X :\: U0) \/ U0 = Empty \/ U0 = X)
              Empty
              (Empty_In_Power X)
              Hdisj).
- (** X is in the family by the defining disjunction **)
  prove X :e infinite_complement_family X.
  claim Hdisj : infinite (X :\: X) \/ X = Empty \/ X = X.
  { apply orIR.
    reflexivity. }
  exact (SepI (Power X)
              (fun U0 : set => infinite (X :\: U0) \/ U0 = Empty \/ U0 = X)
              X
              (Self_In_Power X)
              Hdisj).
Qed.

(** from §13 Exercise 4(a): intersection of topologies **)
(** LATEX VERSION: Exercise 4(a): The intersection of a nonempty family of topologies on X is a topology. **)
Theorem ex13_4a_intersection_topology : forall X Fam:set,
  (exists T:set, T :e Fam) ->
  (forall T :e Fam, topology_on X T) ->
  topology_on X (Intersection_Fam X Fam).
let X Fam.
assume HFamNonempty: exists T:set, T :e Fam.
assume HfamTop: forall T :e Fam, topology_on X T.
prove topology_on X (Intersection_Fam X Fam).
prove Intersection_Fam X Fam c= Power X
  /\ Empty :e Intersection_Fam X Fam
  /\ X :e Intersection_Fam X Fam
  /\ (forall UFam :e Power (Intersection_Fam X Fam), Union UFam :e Intersection_Fam X Fam)
  /\ (forall U :e Intersection_Fam X Fam, forall V :e Intersection_Fam X Fam, U :/\: V :e Intersection_Fam X Fam).
apply andI.
- (** Left part: subset, empty, X, union **)
  apply andI.
  + (** Left part: subset, empty, X **)
    apply andI.
    * (** Left part: subset and empty **)
      apply andI.
      { (** Axiom 1: Intersection_Fam X Fam c= Power X **)
        let U. assume HU: U :e Intersection_Fam X Fam.
        prove U :e Power X.
        exact (SepE1 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HU).
      }
      { (** Axiom 2: Empty :e Intersection_Fam X Fam **)
        prove Empty :e Intersection_Fam X Fam.
        claim HEmptyPower: Empty :e Power X.
        { exact (Empty_In_Power X). }
        claim HEmptyAllT: forall T:set, T :e Fam -> Empty :e T.
        { let T. assume HT: T :e Fam.
          exact (topology_has_empty X T (HfamTop T HT)).
        }
        exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) Empty HEmptyPower HEmptyAllT).
      }
    * (** Axiom 3: X :e Intersection_Fam X Fam **)
      prove X :e Intersection_Fam X Fam.
      claim HXPower: X :e Power X.
      { exact (Self_In_Power X). }
      claim HXAllT: forall T:set, T :e Fam -> X :e T.
      { let T. assume HT: T :e Fam.
        exact (topology_has_X X T (HfamTop T HT)).
      }
      exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) X HXPower HXAllT).
  + (** Axiom 4: unions preserved **)
    let UFam. assume HUFamPow: UFam :e Power (Intersection_Fam X Fam).
    prove Union UFam :e Intersection_Fam X Fam.
    claim HUFamSubInter: UFam c= Intersection_Fam X Fam.
    { exact (PowerE (Intersection_Fam X Fam) UFam HUFamPow). }
    claim HUFamSubPowX: UFam c= Power X.
    { let U. assume HUinUFam: U :e UFam.
      claim HUinInter: U :e Intersection_Fam X Fam.
      { exact (HUFamSubInter U HUinUFam). }
      exact (SepE1 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HUinInter).
    }
    claim HUnionPower: Union UFam :e Power X.
    { apply PowerI.
      exact (Union_Power X UFam HUFamSubPowX).
    }
    claim HUnionAllT: forall T:set, T :e Fam -> Union UFam :e T.
    { let T. assume HT: T :e Fam.
      claim HTtop: topology_on X T.
      { exact (HfamTop T HT). }
      claim HUFamSubT: UFam c= T.
      { let U. assume HUinUFam: U :e UFam.
        claim HUinInter: U :e Intersection_Fam X Fam.
        { exact (HUFamSubInter U HUinUFam). }
        claim HUinAllT: forall T0:set, T0 :e Fam -> U :e T0.
        { exact (SepE2 (Power X) (fun U0 => forall T0:set, T0 :e Fam -> U0 :e T0) U HUinInter). }
        exact (HUinAllT T HT).
      }
      claim HUFamPowT: UFam :e Power T.
      { apply PowerI. exact HUFamSubT. }
      exact (topology_union_axiom X T HTtop UFam HUFamPowT).
    }
    exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) (Union UFam) HUnionPower HUnionAllT).
- (** Axiom 5: binary intersections preserved **)
  let U. assume HU: U :e Intersection_Fam X Fam.
  let V. assume HV: V :e Intersection_Fam X Fam.
  prove U :/\: V :e Intersection_Fam X Fam.
  claim HUinPower: U :e Power X.
  { exact (SepE1 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HU). }
  claim HVinPower: V :e Power X.
  { exact (SepE1 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) V HV). }
  claim HUVPower: U :/\: V :e Power X.
  { exact (binintersect_Power X U V HUinPower HVinPower). }
  claim HUVinAllT: forall T:set, T :e Fam -> U :/\: V :e T.
  { let T. assume HT: T :e Fam.
    claim HTtop: topology_on X T.
    { exact (HfamTop T HT). }
    claim HUT: U :e T.
    { exact ((SepE2 (Power X) (fun U0 => forall T0:set, T0 :e Fam -> U0 :e T0) U HU) T HT). }
    claim HVT: V :e T.
    { exact ((SepE2 (Power X) (fun U0 => forall T0:set, T0 :e Fam -> U0 :e T0) V HV) T HT). }
    exact (topology_binintersect_axiom X T HTtop U HUT V HVT).
  }
  exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) (U :/\: V) HUVPower HUVinAllT).
Qed.

(** from §13 Exercise 4(b): smallest/largest topology containing a family **) 
(** LATEX VERSION: Exercise 4(b): There exist smallest and largest topologies containing a given family of topologies on X. **)
Theorem ex13_4b_smallest_largest : forall X Fam:set,
  (forall T :e Fam, topology_on X T) ->
  exists Tmin, topology_on X Tmin /\ (forall T :e Fam, T c= Tmin) /\
    (forall T', topology_on X T' /\ (forall T :e Fam, T c= T') -> Tmin c= T') /\
  exists Tmax, topology_on X Tmax /\ (forall T :e Fam, Tmax c= T) /\
    (forall T', topology_on X T' /\ (forall T :e Fam, T' c= T) -> T' c= Tmax).
let X Fam.
assume HfamTop: forall T :e Fam, topology_on X T.
prove exists Tmin, topology_on X Tmin /\ (forall T :e Fam, T c= Tmin) /\ (forall T', topology_on X T' /\ (forall T :e Fam, T c= T') -> Tmin c= T') /\ exists Tmax, topology_on X Tmax /\ (forall T :e Fam, Tmax c= T) /\ (forall T', topology_on X T' /\ (forall T :e Fam, T' c= T) -> T' c= Tmax).
		(** Strategy: Tmax = Intersection_Fam X Fam (by ex13_4a_intersection_topology); Tmin = generated_topology_from_subbasis X (Union Fam :\/: {X}) (adding X so the subbasis union equals X even if Fam is empty). **)
set Tmax := Intersection_Fam X Fam.
set Tmin := generated_topology_from_subbasis X (Union Fam :\/: {X}).
(** First prove Tmax properties **)
claim HTmax_topology: topology_on X Tmax.
{ apply (xm (exists T:set, T :e Fam)).
  - assume HFamNonempty: exists T:set, T :e Fam.
    exact (ex13_4a_intersection_topology X Fam HFamNonempty HfamTop).
  - assume HFamEmpty: ~(exists T:set, T :e Fam).
    (** If `Fam` is empty then `Intersection_Fam X Fam = Power X`, i.e. the discrete topology. **)
    rewrite (Intersection_Fam_empty_eq X Fam HFamEmpty).
    exact (discrete_topology_on X).
}
claim HTmax_subset_all: forall T :e Fam, Tmax c= T.
{ let T. assume HT: T :e Fam.
  (** Tmax = Intersection_Fam X Fam = {U :e Power X | forall T :e Fam, U :e T} **)
  (** So every U in Tmax is in every T in Fam, hence Tmax c= T **)
  let U. assume HU: U :e Tmax.
  claim HUinT: U :e T.
  { claim HUinAllT: forall T0:set, T0 :e Fam -> U :e T0.
    { exact (SepE2 (Power X) (fun U0 => forall T0:set, T0 :e Fam -> U0 :e T0) U HU). }
    exact (HUinAllT T HT).
  }
  exact HUinT.
}
claim HTmax_maximal: forall T', topology_on X T' /\ (forall T :e Fam, T' c= T) -> T' c= Tmax.
{ let T'. assume HT'_cond.
  claim HT'_top: topology_on X T'.
  { exact (andEL (topology_on X T') (forall T :e Fam, T' c= T) HT'_cond). }
  claim HT'_sub_all: forall T :e Fam, T' c= T.
  { exact (andER (topology_on X T') (forall T :e Fam, T' c= T) HT'_cond). }
  (** Need to show T' c= Tmax, i.e., every U in T' is in Tmax **)
  (** U :e Tmax iff U :e Power X and forall T :e Fam, U :e T **)
  let U. assume HU: U :e T'.
  (** Show U :e Tmax = Intersection_Fam X Fam **)
  claim HUinPower: U :e Power X.
  { claim HT'_sub_PowerX: T' c= Power X.
    { claim H1: ((T' c= Power X /\ Empty :e T') /\ X :e T') /\ (forall UFam :e Power T', Union UFam :e T').
      { exact (andEL (((T' c= Power X /\ Empty :e T') /\ X :e T') /\ (forall UFam :e Power T', Union UFam :e T')) (forall U0 :e T', forall V :e T', U0 :/\: V :e T') HT'_top). }
      claim H2: (T' c= Power X /\ Empty :e T') /\ X :e T'.
      { exact (andEL ((T' c= Power X /\ Empty :e T') /\ X :e T') (forall UFam :e Power T', Union UFam :e T') H1). }
      claim H3: T' c= Power X /\ Empty :e T'.
      { exact (andEL (T' c= Power X /\ Empty :e T') (X :e T') H2). }
      exact (andEL (T' c= Power X) (Empty :e T') H3).
    }
    exact (HT'_sub_PowerX U HU).
  }
  claim HUinAllT: forall T :e Fam, U :e T.
  { let T. assume HT: T :e Fam.
    claim HT'subT: T' c= T.
    { exact (HT'_sub_all T HT). }
    exact (HT'subT U HU).
  }
  exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HUinPower HUinAllT).
}
(** Now prove Tmin properties **)
(** First show Union Fam is a subbasis **)
claim HUnionFam_subbasis: subbasis_on X (Union Fam :\/: {X}).
{ (** subbasis_on X S := (S c= Power X) /\ Union S = X **)
  prove (Union Fam :\/: {X}) c= Power X /\ Union (Union Fam :\/: {X}) = X.
  apply andI.
  - (** Union Fam :\/: {X} c= Power X **)
    let U. assume HU: U :e Union Fam :\/: {X}.
    prove U :e Power X.
    apply (binunionE' (Union Fam) {X} U (U :e Power X)).
    + assume HUinUnion: U :e Union Fam.
      apply UnionE_impred Fam U HUinUnion.
      let T. assume HUT: U :e T. assume HT: T :e Fam.
      claim HTtop: topology_on X T.
      { exact (HfamTop T HT). }
      claim H1: ((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T).
      { exact (andEL (((T c= Power X /\ Empty :e T) /\ X :e T) /\ (forall UFam :e Power T, Union UFam :e T)) (forall U0 :e T, forall V :e T, U0 :/\: V :e T) HTtop). }
      claim H2: (T c= Power X /\ Empty :e T) /\ X :e T.
      { exact (andEL ((T c= Power X /\ Empty :e T) /\ X :e T) (forall UFam :e Power T, Union UFam :e T) H1). }
      claim H3: T c= Power X /\ Empty :e T.
      { exact (andEL (T c= Power X /\ Empty :e T) (X :e T) H2). }
      claim HTsub: T c= Power X.
      { exact (andEL (T c= Power X) (Empty :e T) H3). }
      exact (HTsub U HUT).
    + assume HUinSing: U :e {X}.
      claim HUeq: U = X.
      { exact (SingE X U HUinSing). }
      rewrite HUeq.
      exact (PowerI X X (Subq_ref X)).
    + exact HU.
  - (** Union (Union Fam :\/: {X}) = X **)
    apply set_ext.
    + (** Union (Union Fam :\/: {X}) c= X **)
      let x. assume Hx: x :e Union (Union Fam :\/: {X}).
      prove x :e X.
      apply UnionE_impred (Union Fam :\/: {X}) x Hx.
      let U. assume HxU: x :e U. assume HU: U :e Union Fam :\/: {X}.
      apply (binunionE' (Union Fam) {X} U (x :e X)).
      - assume HUinUnion: U :e Union Fam.
        apply UnionE_impred Fam U HUinUnion.
        let T. assume HUT: U :e T. assume HT: T :e Fam.
        claim HTtop: topology_on X T.
        { exact (HfamTop T HT). }
        claim HUsubX: U c= X.
        { exact (topology_elem_subset X T U HTtop HUT). }
        exact (HUsubX x HxU).
      - assume HUinSing: U :e {X}.
        claim HUeq: U = X.
        { exact (SingE X U HUinSing). }
        rewrite <- HUeq.
        exact HxU.
      - exact HU.
    + (** X c= Union (Union Fam :\/: {X}) **)
      let x. assume HxX: x :e X.
      prove x :e Union (Union Fam :\/: {X}).
      claim HX_in_subbasis: X :e Union Fam :\/: {X}.
      { exact (binunionI2 (Union Fam) {X} X (SingI X)). }
      exact (UnionI (Union Fam :\/: {X}) x X HxX HX_in_subbasis).
}
claim HTmin_topology: topology_on X Tmin.
{ exact (topology_from_subbasis_is_topology X (Union Fam :\/: {X}) HUnionFam_subbasis). }
claim HTmin_contains_all: forall T :e Fam, T c= Tmin.
{ let T. assume HT: T :e Fam.
  (** Need to show every open set in T is in Tmin = generated_topology_from_subbasis X (Union Fam) **)
  let U. assume HU: U :e T.
  (** Show U :e generated_topology_from_subbasis X (Union Fam :\/: {X}) **)
  (** = generated_topology X (basis_of_subbasis X (Union Fam :\/: {X})) **)
  (** = {V :e Power X | forall x :e V, exists b :e basis_of_subbasis X (Union Fam :\/: {X}), x :e b /\ b c= V} **)
  (** Since U :e T and T :e Fam, we have U :e Union Fam and hence U :e Union Fam :\/: {X} **)
  claim HUinUnionFam: U :e Union Fam.
  { exact (UnionI Fam U T HU HT). }
  (** U is in the subbasis, so by subbasis_elem_in_basis, it's in the basis **)
  apply (xm (U = Empty)).
  - assume HUempty: U = Empty.
    (** Empty is in every topology **)
    claim HEmptyinTmin: Empty :e Tmin.
    { claim H1: ((Tmin c= Power X /\ Empty :e Tmin) /\ X :e Tmin) /\ (forall UFam :e Power Tmin, Union UFam :e Tmin).
      { exact (andEL (((Tmin c= Power X /\ Empty :e Tmin) /\ X :e Tmin) /\ (forall UFam :e Power Tmin, Union UFam :e Tmin)) (forall U0 :e Tmin, forall V :e Tmin, U0 :/\: V :e Tmin) HTmin_topology). }
      claim H2: (Tmin c= Power X /\ Empty :e Tmin) /\ X :e Tmin.
      { exact (andEL ((Tmin c= Power X /\ Empty :e Tmin) /\ X :e Tmin) (forall UFam :e Power Tmin, Union UFam :e Tmin) H1). }
      claim H3: Tmin c= Power X /\ Empty :e Tmin.
      { exact (andEL (Tmin c= Power X /\ Empty :e Tmin) (X :e Tmin) H2). }
      exact (andER (Tmin c= Power X) (Empty :e Tmin) H3).
    }
    rewrite HUempty.
    exact HEmptyinTmin.
  - assume HUnonempty: U <> Empty.
    claim HUinSubbasis: U :e Union Fam :\/: {X}.
    { exact (binunionI1 (Union Fam) {X} U HUinUnionFam). }
    claim HUinBasis: U :e basis_of_subbasis X (Union Fam :\/: {X}).
    { exact (subbasis_elem_in_basis X (Union Fam :\/: {X}) U HUnionFam_subbasis HUinSubbasis HUnonempty). }
    (** Now use basis_in_generated **)
    claim HBasis: basis_on X (basis_of_subbasis X (Union Fam :\/: {X})).
    { exact (finite_intersections_basis_of_subbasis X (Union Fam :\/: {X}) HUnionFam_subbasis). }
    exact (basis_in_generated X (basis_of_subbasis X (Union Fam :\/: {X})) U HBasis HUinBasis).
}
claim HTmin_minimal: forall T', topology_on X T' /\ (forall T :e Fam, T c= T') -> Tmin c= T'.
{ let T'. assume HT'_cond.
  claim HT'_top: topology_on X T'.
  { exact (andEL (topology_on X T') (forall T :e Fam, T c= T') HT'_cond). }
  claim HT'_contains_all: forall T :e Fam, T c= T'.
  { exact (andER (topology_on X T') (forall T :e Fam, T c= T') HT'_cond). }
  (** Show Union Fam :\/: {X} c= T' **)
  claim HSubbasis_sub_T': Union Fam :\/: {X} c= T'.
  { let U. assume HU: U :e Union Fam :\/: {X}.
    apply (binunionE' (Union Fam) {X} U (U :e T')).
    - assume HUinUnion: U :e Union Fam.
      apply UnionE_impred Fam U HUinUnion.
      let T. assume HUT: U :e T. assume HT: T :e Fam.
      claim HTsubT': T c= T'.
      { exact (HT'_contains_all T HT). }
      exact (HTsubT' U HUT).
    - assume HUinSing: U :e {X}.
      claim HUeq: U = X.
      { exact (SingE X U HUinSing). }
      rewrite HUeq.
      exact (topology_has_X X T' HT'_top).
    - exact HU.
  }
  (** Apply topology_generated_by_basis_is_minimal **)
  exact (topology_generated_by_basis_is_minimal X (Union Fam :\/: {X}) T' HUnionFam_subbasis HT'_top HSubbasis_sub_T').
}
(** Combine all parts with existential introductions **)
witness Tmin.
apply andI.
- apply andI.
  + (** topology_on X Tmin /\ (forall T :e Fam, T c= Tmin) **)
    apply andI.
    * exact HTmin_topology.
    * exact HTmin_contains_all.
  + exact HTmin_minimal.
- (** exists Tmax... **)
  witness Tmax.
  apply andI.
  + (** topology_on X Tmax /\ (forall T :e Fam, Tmax c= T) **)
    apply andI.
    * exact HTmax_topology.
    * exact HTmax_subset_all.
  + exact HTmax_maximal.
Qed.

(** from §13 Exercise 4(c): specific smallest/largest topology on {a,b,c} **) 
(** LATEX VERSION: Exercise 4(c): Determine the smallest and largest topologies on {a,b,c} containing given families (continuation of Exercise 4). **)
Theorem ex13_4c_specific_topologies :
  exists Tsmall Tall:set, topology_on abc_set Tsmall /\ topology_on abc_set Tall.
prove exists Tsmall Tall:set, topology_on abc_set Tsmall /\ topology_on abc_set Tall.
witness (indiscrete_topology abc_set).
witness (discrete_topology abc_set).
apply andI.
- exact (indiscrete_topology_on abc_set).
- exact (discrete_topology_on abc_set).
Qed.

(** from §13 Exercise 5: topology generated by a basis is intersection of topologies containing it **) 
(** LATEX VERSION: Exercise 5: The topology generated by a basis A equals the intersection of all topologies on X containing A. **)
Theorem ex13_5_basis_intersection : forall X A:set,
  basis_on X A ->
  generated_topology X A =
    Intersection_Fam X {T :e Power (Power X)|topology_on X T /\ A c= T}.
let X A.
assume HA: basis_on X A.
prove generated_topology X A = Intersection_Fam X {T :e Power (Power X)|topology_on X T /\ A c= T}.
set Fam := {T :e Power (Power X)|topology_on X T /\ A c= T}.
apply set_ext.
- (** generated_topology X A c= Intersection_Fam X Fam **)
  let U. assume HU: U :e generated_topology X A.
  (** Show U :e Intersection_Fam X Fam, i.e., U :e every T in Fam **)
  claim HUinPower: U :e Power X.
  { claim HUsub: U c= X.
    { exact (generated_topology_subset X A U HU). }
    exact (PowerI X U HUsub).
  }
  claim HUinAllT: forall T :e Fam, U :e T.
  { let T. assume HT: T :e Fam.
    (** Extract topology_on X T and A c= T from HT **)
    claim HTinPowerPower: T :e Power (Power X).
    { exact (SepE1 (Power (Power X)) (fun T0 => topology_on X T0 /\ A c= T0) T HT). }
    claim HTcond: topology_on X T /\ A c= T.
    { exact (SepE2 (Power (Power X)) (fun T0 => topology_on X T0 /\ A c= T0) T HT). }
    claim HTtop: topology_on X T.
    { exact (andEL (topology_on X T) (A c= T) HTcond). }
    claim HAinT: A c= T.
    { exact (andER (topology_on X T) (A c= T) HTcond). }
    (** Apply generated_topology_finer_weak: if T contains all generators in A, generated_topology X A c= T **)
    claim HGenSubT: generated_topology X A c= T.
    { claim HAllAinT: forall a :e A, a :e T.
      { let a. assume Ha: a :e A.
        exact (HAinT a Ha).
      }
      exact (generated_topology_finer_weak X A T HTtop HAllAinT).
    }
    exact (HGenSubT U HU).
  }
  exact (SepI (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HUinPower HUinAllT).
- (** Intersection_Fam X Fam c= generated_topology X A **)
  let U. assume HU: U :e Intersection_Fam X Fam.
  (** U is in every topology containing A, in particular in generated_topology X A **)
  claim HGenTop: topology_on X (generated_topology X A).
  { exact (lemma_topology_from_basis X A HA). }
  claim HAinGen: A c= generated_topology X A.
  { let a. assume Ha: a :e A.
    exact (basis_in_generated X A a HA Ha).
  }
  claim HGenInFam: generated_topology X A :e Fam.
  { (** Need to show generated_topology X A :e Power (Power X) and satisfies the condition **)
    claim HGenInPowerPower: generated_topology X A :e Power (Power X).
    { apply PowerI.
      let V. assume HV: V :e generated_topology X A.
      claim HVsub: V c= X.
      { exact (generated_topology_subset X A V HV). }
      exact (PowerI X V HVsub).
    }
    exact (SepI (Power (Power X)) (fun T => topology_on X T /\ A c= T) (generated_topology X A) HGenInPowerPower (andI (topology_on X (generated_topology X A)) (A c= generated_topology X A) HGenTop HAinGen)).
  }
  (** Now U :e Intersection_Fam X Fam means U :e every T in Fam **)
  claim HUinAllT: forall T :e Fam, U :e T.
  { exact (SepE2 (Power X) (fun U0 => forall T:set, T :e Fam -> U0 :e T) U HU). }
  exact (HUinAllT (generated_topology X A) HGenInFam).
Qed.

(** from §13 Exercise 6: incomparability of two real line topologies **)
(** LATEX VERSION: Exercise 6: Compare the standard, lower limit, and K-topologies on ℝ; standard vs lower-limit and standard vs K are incomparable. **)
(** FIXED: Now uses proper rational definition (same as Q); rational = {x :e real | exists m :e int, exists n :e omega\\{0}, x = m/n} from line 6202. **)
(** NOTE: `rational_numbers` is an alias of `Q`. **)
Definition rational_numbers : set := Q.

(** from §13: rationals are reals **)
(** LATEX VERSION: Q is a subset of R. **)
Theorem rational_numbers_Subq_R : rational_numbers c= R.
exact (Subq_rational_real).
Qed.

(** from §13: elements of Q are in R **)
(** LATEX VERSION: If q is rational then q is real. **)
Theorem rational_numbers_in_R : forall q :e rational_numbers, q :e R.
let q. assume Hq.
exact (rational_numbers_Subq_R q Hq).
Qed.

(** from §13: open intervals in ℝ **)
(** LATEX VERSION: For a<b in ℝ, the open interval (a,b) is {x∈ℝ | a<x and x<b}. **)
Definition open_interval : set -> set -> set := fun a b => {x :e R|Rlt a x /\ Rlt x b}.
(** SUSPICIOUS DEFINITION: The endpoints `a,b` are not required to be in `R` explicitly; membership uses `Rlt` so ill-typed endpoints make the interval behave like `Empty`. **)

(** helper: membership in open_interval implies left endpoint is real **)
(** LATEX VERSION: If x∈(a,b), then a is a real number (since a<x in ℝ). **)
Theorem open_interval_left_in_R : forall a b x:set, x :e open_interval a b -> a :e R.
let a b x.
assume Hx: x :e open_interval a b.
claim Hprop: Rlt a x /\ Rlt x b.
{ exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
exact (RltE_left a x (andEL (Rlt a x) (Rlt x b) Hprop)).
Qed.

(** helper: membership in open_interval implies right endpoint is real **)
(** LATEX VERSION: If x∈(a,b), then b is a real number (since x<b in ℝ). **)
Theorem open_interval_right_in_R : forall a b x:set, x :e open_interval a b -> b :e R.
let a b x.
assume Hx: x :e open_interval a b.
claim Hprop: Rlt a x /\ Rlt x b.
{ exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
exact (RltE_right x b (andER (Rlt a x) (Rlt x b) Hprop)).
Qed.
(** from §13 Exercise 6: lower limit basis element **)
(** LATEX VERSION: Lower limit topology uses half open intervals [a,b). **)
Definition halfopen_interval_left : set -> set -> set := fun a b => {x :e R|~(Rlt x a) /\ Rlt x b}.

(** from §13 Exercise 7: upper limit basis element **)
(** LATEX VERSION: Upper limit topology uses half open intervals (a,b]. **)
Definition halfopen_interval_right : set -> set -> set := fun a b => {x :e R|Rlt a x /\ ~(Rlt b x)}.
(** SUSPICIOUS DEFINITION: These half-open intervals use `~(Rlt x a)` and `~(Rlt b x)` as non-strict bounds; later proofs rely on the linearity of `<` on `R` to relate this to equality. **)

(** from §13 Exercise 7: upper limit interval is a subset of R **)
(** LATEX VERSION: (a,b] is a subset of R. **)
Theorem halfopen_interval_right_Subq_R : forall a b:set, halfopen_interval_right a b c= R.
let a b.
let x. assume Hx.
exact (SepE1 R (fun x0 : set => Rlt a x0 /\ ~(Rlt b x0)) x Hx).
Qed.

(** from §13 Exercise 7: right endpoint belongs to (a,b] when a<b **)
(** LATEX VERSION: If a<b then b is in (a,b]. **)
Theorem halfopen_interval_right_rightmem : forall a b:set, Rlt a b -> b :e halfopen_interval_right a b.
let a b. assume Hab.
claim HbR : b :e R.
{ exact (RltE_right a b Hab). }
claim Hprop : Rlt a b /\ ~(Rlt b b).
{ apply andI.
  - exact Hab.
  - exact (not_Rlt_refl b HbR). }
exact (SepI R (fun x0 : set => Rlt a x0 /\ ~(Rlt b x0)) b HbR Hprop).
Qed.

(** from §13 Exercise 6: open interval is a subset of ℝ **)
(** LATEX VERSION: (a,b) is a subset of ℝ. **)
Theorem open_interval_Subq_R : forall a b:set, open_interval a b c= R.
let a b.
let x. assume Hx.
exact (SepE1 R (fun x0 : set => Rlt a x0 /\ Rlt x0 b) x Hx).
Qed.

(** from §13: every real lies in some standard open interval **)
(** LATEX VERSION: For any x in R, x is contained in (x-1,x+1). **)
Theorem real_in_open_interval_minus1_plus1 : forall x:set,
  x :e R ->
  x :e open_interval (add_SNo x (minus_SNo 1)) (add_SNo x 1).
let x. assume HxR.
set a0 := add_SNo x (minus_SNo 1).
set b0 := add_SNo x 1.
claim Hm1R : minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Ha0R : a0 :e R.
{ exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
claim Hb0R : b0 :e R.
{ exact (real_add_SNo x HxR 1 real_1). }
claim HxS : SNo x.
{ exact (real_SNo x HxR). }
claim Hm1S : SNo (minus_SNo 1).
{ exact (real_SNo (minus_SNo 1) Hm1R). }
claim H1S : SNo 1.
{ exact (real_SNo 1 real_1). }
claim Ha0ltx : a0 < x.
{ claim Hlt : a0 < add_SNo x 0.
  { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
  rewrite <- (add_SNo_0R x HxS) at 2.
  exact Hlt. }
claim Hxltb0 : x < b0.
{ claim Hlt : add_SNo x 0 < b0.
  { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 H1S SNoLt_0_1). }
  rewrite <- (add_SNo_0R x HxS) at 1.
  exact Hlt. }
claim Ha0x : Rlt a0 x.
{ exact (RltI a0 x Ha0R HxR Ha0ltx). }
claim Hxb0 : Rlt x b0.
{ exact (RltI x b0 HxR Hb0R Hxltb0). }
claim Hconj : Rlt a0 x /\ Rlt x b0.
{ apply andI.
  - exact Ha0x.
  - exact Hxb0. }
exact (SepI R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b0) x HxR Hconj).
Qed.

(** from §13 Exercise 6: half open interval is a subset of ℝ **)
(** LATEX VERSION: [a,b) is a subset of ℝ. **)
Theorem halfopen_interval_left_Subq_R : forall a b:set, halfopen_interval_left a b c= R.
let a b.
let x. assume Hx.
exact (SepE1 R (fun x0 : set => ~(Rlt x0 a) /\ Rlt x0 b) x Hx).
Qed.

(** from §13 Exercise 6: left endpoint belongs to [a,b) when a<b **)
(** LATEX VERSION: If a<b then a∈[a,b). **)
Theorem halfopen_interval_left_leftmem : forall a b:set, Rlt a b -> a :e halfopen_interval_left a b.
let a b. assume Hab.
claim HaR : a :e R.
{ exact (RltE_left a b Hab). }
claim Hb : ~(Rlt a a) /\ Rlt a b.
{ apply andI.
  - exact (not_Rlt_refl a HaR).
  - exact Hab. }
exact (SepI R (fun x0 : set => ~(Rlt x0 a) /\ Rlt x0 b) a HaR Hb).
Qed.

(** helper: if a <= x then [x,b) c= [a,b) **)
(** LATEX VERSION: If a≤x<b then [x,b) ⊂ [a,b). **)
Theorem halfopen_interval_left_leftmonotone : forall a x b:set,
  a :e R -> x :e R -> b :e R ->
  Rle a x ->
  halfopen_interval_left x b c= halfopen_interval_left a b.
let a x b.
assume HaR: a :e R.
assume HxR: x :e R.
assume HbR: b :e R.
assume Hax: Rle a x.
let y. assume Hy: y :e halfopen_interval_left x b.
prove y :e halfopen_interval_left a b.
claim HyR: y :e R.
{ exact (SepE1 R (fun t:set => ~(Rlt t x) /\ Rlt t b) y Hy). }
claim Hyprop: ~(Rlt y x) /\ Rlt y b.
{ exact (SepE2 R (fun t:set => ~(Rlt t x) /\ Rlt t b) y Hy). }
claim Hynltx: ~(Rlt y x).
{ exact (andEL (~(Rlt y x)) (Rlt y b) Hyprop). }
claim Hyltb: Rlt y b.
{ exact (andER (~(Rlt y x)) (Rlt y b) Hyprop). }
claim Hynlta: ~(Rlt y a).
{ assume Hlt: Rlt y a.
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim Hnltxa: ~(Rlt x a).
  { exact (RleE_nlt a x Hax). }
  claim Hyltx: Rlt y x.
  { apply (SNoLt_trichotomy_or_impred x a HxS HaS (Rlt y x)).
    - assume Hxa: x < a.
      claim Hxlt: Rlt x a.
      { exact (RltI x a HxR HaR Hxa). }
      apply FalseE.
      exact (Hnltxa Hxlt).
    - assume Hxeq: x = a.
      rewrite Hxeq.
      exact Hlt.
    - assume Haxlt: a < x.
      claim Hylt_a: y < a.
      { exact (RltE_lt y a Hlt). }
      claim Hylt_x: y < x.
      { exact (SNoLt_tra y a x HyS HaS HxS Hylt_a Haxlt). }
      exact (RltI y x HyR HxR Hylt_x). }
  exact (Hynltx Hyltx). }
claim Hyprop2: ~(Rlt y a) /\ Rlt y b.
{ apply andI.
  - exact Hynlta.
  - exact Hyltb. }
exact (SepI R (fun t:set => ~(Rlt t a) /\ Rlt t b) y HyR Hyprop2).
Qed.

  (** from §13 Definition: standard topology basis on R **)
  (** LATEX VERSION: If B is the collection of all open intervals (a,b) in R, the topology generated by B is the standard topology on R. **)
Definition R_standard_basis : set :=
  \/_ a :e R, {open_interval a b|b :e R}.

  (** from §13 Definition: standard topology on R **)
  (** LATEX VERSION: The topology generated by the open-interval basis is called the standard topology on R. **)
Definition R_standard_topology : set :=
  generated_topology R R_standard_basis.
(** SUSPICIOUS DEFINITION: This basis includes all `open_interval a b` with `a,b :e R` without requiring `Rlt a b`; empty intervals are allowed as basis elements, which is harmless but can complicate refinement arguments. **)

(** Helper: unfold the definition of the standard topology on R. **)
Theorem R_standard_topology_def_eq : R_standard_topology = generated_topology R R_standard_basis.
prove R_standard_topology = generated_topology R R_standard_basis.
reflexivity.
Qed.

(** from §13: standard open intervals form a basis on R **)
(** LATEX VERSION: The collection of open intervals (a,b) is a basis for the standard topology on R. **)
Theorem R_standard_basis_is_basis_local : basis_on R R_standard_basis.
prove basis_on R R_standard_basis.
prove R_standard_basis c= Power R
  /\ (forall x :e R, exists b :e R_standard_basis, x :e b)
  /\ (forall b1 :e R_standard_basis, forall b2 :e R_standard_basis, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e R_standard_basis, x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- (** basis elements are subsets of R **)
  let U. assume HU : U :e R_standard_basis.
  prove U :e Power R.
  (** destruct U ∈ ⋃_{a∈R} {open_interval a b | b∈R} **)
  claim Hexa : exists a :e R, U :e {open_interval a b|b :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) U HU). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR : a :e R.
  { exact (andEL (a :e R) (U :e {open_interval a b|b :e R}) Hapair). }
  claim HUfam : U :e {open_interval a b|b :e R}.
  { exact (andER (a :e R) (U :e {open_interval a b|b :e R}) Hapair). }
  claim Hexb : exists b :e R, U = open_interval a b.
  { exact (ReplE R (fun b0 : set => open_interval a b0) U HUfam). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbR : b :e R.
  { exact (andEL (b :e R) (U = open_interval a b) Hbpair). }
  claim HUeq : U = open_interval a b.
  { exact (andER (b :e R) (U = open_interval a b) Hbpair). }
  rewrite HUeq.
  exact (PowerI R (open_interval a b) (open_interval_Subq_R a b)).
- (** coverage: every x has a basis neighborhood **)
  let x. assume HxR.
  (** choose (x-1, x+1) **)
  claim Hm1R : minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  set a0 := add_SNo x (minus_SNo 1).
  set b0 := add_SNo x 1.
  claim Ha0R : a0 :e R.
  { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
  claim Hb0R : b0 :e R.
  { exact (real_add_SNo x HxR 1 real_1). }
  set I := open_interval a0 b0.
  witness I.
  apply andI.
  - (** I is in the standard basis **)
    prove I :e R_standard_basis.
    claim HIa : I :e {open_interval a0 bb|bb :e R}.
    { exact (ReplI R (fun bb : set => open_interval a0 bb) b0 Hb0R). }
    exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a0 I Ha0R HIa).
  - (** x is in I **)
      claim HxS : SNo x.
      { exact (real_SNo x HxR). }
      claim Hm1S : SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim Hxltb0 : x < b0.
      { claim Hx0lt : 0 < 1.
        { exact SNoLt_0_1. }
	      claim Hx0eq : add_SNo x 0 = x.
	      { exact (add_SNo_0R x HxS). }
	      claim Hlt : add_SNo x 0 < add_SNo x 1.
	      { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 Hx0lt). }
	      rewrite <- Hx0eq at 1.
	      exact Hlt. }
      claim Ha0ltx : a0 < x.
      { claim Hlt : add_SNo x (minus_SNo 1) < add_SNo x 0.
        { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
        rewrite <- (add_SNo_0R x HxS) at 2.
        exact Hlt. }
      claim Ha0x : Rlt a0 x.
      { exact (RltI a0 x Ha0R HxR Ha0ltx). }
      claim Hxb0 : Rlt x b0.
      { exact (RltI x b0 HxR Hb0R Hxltb0). }
      claim Hconj : Rlt a0 x /\ Rlt x b0.
      { apply andI.
        - exact Ha0x.
        - exact Hxb0. }
      exact (SepI R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b0) x HxR Hconj).
- (** intersection refinement **)
  let b1. assume Hb1.
  let b2. assume Hb2.
  let x. assume Hx1 Hx2.
  (** destruct b1 = (a1,b1') and b2 = (a2,b2') with endpoints in R **)
  claim Hexa1 : exists a1 :e R, b1 :e {open_interval a1 b|b :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) b1 Hb1). }
  claim Hexa2 : exists a2 :e R, b2 :e {open_interval a2 b|b :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) b2 Hb2). }
  apply Hexa1.
  let a1. assume Ha1pair.
  claim Ha1R : a1 :e R.
  { exact (andEL (a1 :e R) (b1 :e {open_interval a1 b|b :e R}) Ha1pair). }
  claim Hb1fam : b1 :e {open_interval a1 b|b :e R}.
  { exact (andER (a1 :e R) (b1 :e {open_interval a1 b|b :e R}) Ha1pair). }
  claim Hexb1 : exists bb1 :e R, b1 = open_interval a1 bb1.
  { exact (ReplE R (fun bb : set => open_interval a1 bb) b1 Hb1fam). }
  apply Hexb1.
  let bb1. assume Hbb1pair.
  claim Hbb1R : bb1 :e R.
  { exact (andEL (bb1 :e R) (b1 = open_interval a1 bb1) Hbb1pair). }
  claim Hb1eq : b1 = open_interval a1 bb1.
  { exact (andER (bb1 :e R) (b1 = open_interval a1 bb1) Hbb1pair). }
  apply Hexa2.
  let a2. assume Ha2pair.
  claim Ha2R : a2 :e R.
  { exact (andEL (a2 :e R) (b2 :e {open_interval a2 b|b :e R}) Ha2pair). }
  claim Hb2fam : b2 :e {open_interval a2 b|b :e R}.
  { exact (andER (a2 :e R) (b2 :e {open_interval a2 b|b :e R}) Ha2pair). }
  claim Hexb2 : exists bb2 :e R, b2 = open_interval a2 bb2.
  { exact (ReplE R (fun bb : set => open_interval a2 bb) b2 Hb2fam). }
  apply Hexb2.
  let bb2. assume Hbb2pair.
  claim Hbb2R : bb2 :e R.
  { exact (andEL (bb2 :e R) (b2 = open_interval a2 bb2) Hbb2pair). }
  claim Hb2eq : b2 = open_interval a2 bb2.
  { exact (andER (bb2 :e R) (b2 = open_interval a2 bb2) Hbb2pair). }
  (** extract inequalities from x ∈ intervals **)
  claim HxIn1 : x :e open_interval a1 bb1.
  { rewrite <- Hb1eq. exact Hx1. }
  claim HxIn2 : x :e open_interval a2 bb2.
  { rewrite <- Hb2eq. exact Hx2. }
  claim HxR : x :e R.
  { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ Rlt x0 bb1) x HxIn1). }
  claim HxProp1 : Rlt a1 x /\ Rlt x bb1.
  { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ Rlt x0 bb1) x HxIn1). }
  claim HxProp2 : Rlt a2 x /\ Rlt x bb2.
  { exact (SepE2 R (fun x0 : set => Rlt a2 x0 /\ Rlt x0 bb2) x HxIn2). }
  claim Ha1x : Rlt a1 x.
  { exact (andEL (Rlt a1 x) (Rlt x bb1) HxProp1). }
  claim Hxbb1 : Rlt x bb1.
  { exact (andER (Rlt a1 x) (Rlt x bb1) HxProp1). }
  claim Ha2x : Rlt a2 x.
  { exact (andEL (Rlt a2 x) (Rlt x bb2) HxProp2). }
  claim Hxbb2 : Rlt x bb2.
  { exact (andER (Rlt a2 x) (Rlt x bb2) HxProp2). }
  (** choose endpoints a3 = max(a1,a2) and b3 = min(bb1,bb2) by trichotomy **)
  claim Ha1S : SNo a1.
  { exact (real_SNo a1 Ha1R). }
  claim Ha2S : SNo a2.
  { exact (real_SNo a2 Ha2R). }
  claim Hb1S : SNo bb1.
  { exact (real_SNo bb1 Hbb1R). }
  claim Hb2S : SNo bb2.
  { exact (real_SNo bb2 Hbb2R). }
  claim HxS : SNo x.
  { exact (real_SNo x HxR). }
  (** a3 and b3 are selected by case splits; proof is classical but long **)
  claim Ha1xlt : a1 < x.
  { exact (RltE_lt a1 x Ha1x). }
  claim Ha2xlt : a2 < x.
  { exact (RltE_lt a2 x Ha2x). }
  claim Hxltbb1 : x < bb1.
  { exact (RltE_lt x bb1 Hxbb1). }
  claim Hxltbb2 : x < bb2.
  { exact (RltE_lt x bb2 Hxbb2). }
  (** Decide which left endpoint is larger **)
  apply (SNoLt_trichotomy_or_impred a1 a2 Ha1S Ha2S
           (exists b3 :e R_standard_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
  - assume Ha1lt : a1 < a2.
    (** left endpoint a2 **)
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_standard_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      (** right endpoint bb1 **)
      set I3 := open_interval a2 bb1.
      witness I3.
      apply andI.
      * (** I3 in basis **)
        claim HI3fam : I3 :e {open_interval a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { (** x in I3 **)
          claim Hax : Rlt a2 x.
          { exact Ha2x. }
          claim Hxb : Rlt x bb1.
          { exact Hxbb1. }
          claim Hconj : Rlt a2 x /\ Rlt x bb1.
          { apply andI.
            - exact Hax.
            - exact Hxb. }
          exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb1) x HxR Hconj). }
        { (** I3 subset b1 ∩ b2 **)
          let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a2 z /\ Rlt z bb1) y HyI3). }
          claim HyProp : Rlt a2 y /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => Rlt a2 z /\ Rlt z bb1) y HyI3). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (Rlt a2 y) (Rlt y bb1) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha1S' : SNo a1.
          { exact Ha1S. }
          claim Ha2S' : SNo a2.
          { exact Ha2S. }
          claim Hbb1S' : SNo bb1.
          { exact Hb1S. }
          claim Hbb2S' : SNo bb2.
          { exact Hb2S. }
          claim Ha2ylt : a2 < y.
          { exact (RltE_lt a2 y Ha2y). }
          claim Hybb1lt : y < bb1.
          { exact (RltE_lt y bb1 Hybb1). }
          (** y in b2 = (a2,bb2) **)
          claim Hybb2lt : y < bb2.
          { exact (SNoLt_tra y bb1 bb2 HyS Hbb1S' Hbb2S' Hybb1lt Hb1lt). }
          claim Hybb2 : Rlt y bb2.
          { exact (RltI y bb2 HyR Hbb2R Hybb2lt). }
          claim HyIn2 : y :e open_interval a2 bb2.
          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq. exact HyIn2. }
          (** y in b1 = (a1,bb1) **)
          claim Ha1ylt : a1 < y.
          { exact (SNoLt_tra a1 a2 y Ha1S' Ha2S' HyS Ha1lt Ha2ylt). }
          claim Ha1y : Rlt a1 y.
          { exact (RltI a1 y Ha1R HyR Ha1ylt). }
          claim HyIn1 : y :e open_interval a1 bb1.
          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq. exact HyIn1. }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := open_interval a2 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a2 x /\ Rlt x bb1.
          { apply andI.
            - exact Ha2x.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a2 z /\ Rlt z bb1) y HyI3). }
          claim HyProp : Rlt a2 y /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => Rlt a2 z /\ Rlt z bb1) y HyI3). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (Rlt a2 y) (Rlt y bb1) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha2ylt : a2 < y.
          { exact (RltE_lt a2 y Ha2y). }
          claim Hybb1lt : y < bb1.
          { exact (RltE_lt y bb1 Hybb1). }
          (** y in b2 using bb2=bb1 **)
          claim Hybb2 : Rlt y bb2.
          { rewrite <- Hbeq. exact Hybb1. }
          claim HyIn2 : y :e open_interval a2 bb2.
          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq. exact HyIn2. }
          (** y in b1 using a1<a2 **)
          claim Ha1ylt : a1 < y.
          { exact (SNoLt_tra a1 a2 y Ha1S Ha2S HyS Ha1lt Ha2ylt). }
          claim Ha1y : Rlt a1 y.
          { exact (RltI a1 y Ha1R HyR Ha1ylt). }
          claim HyIn1 : y :e open_interval a1 bb1.
          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq. exact HyIn1. }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      (** right endpoint bb2 **)
      set I3 := open_interval a2 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a2 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a2 x /\ Rlt x bb2.
          { apply andI.
            - exact Ha2x.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyI3). }
          claim HyProp : Rlt a2 y /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyI3). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (Rlt a2 y) (Rlt y bb2) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha2ylt : a2 < y.
          { exact (RltE_lt a2 y Ha2y). }
          claim Hybb2lt : y < bb2.
          { exact (RltE_lt y bb2 Hybb2). }
          (** y in b1 uses bb2<bb1 **)
          claim Hybb1lt : y < bb1.
          { exact (SNoLt_tra y bb2 bb1 HyS Hb2S Hb1S Hybb2lt Hb2lt). }
          claim Hybb1 : Rlt y bb1.
          { exact (RltI y bb1 HyR Hbb1R Hybb1lt). }
          claim Ha1ylt : a1 < y.
          { exact (SNoLt_tra a1 a2 y Ha1S Ha2S HyS Ha1lt Ha2ylt). }
          claim Ha1y : Rlt a1 y.
          { exact (RltI a1 y Ha1R HyR Ha1ylt). }
          claim HyIn1 : y :e open_interval a1 bb1.
          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq. exact HyIn1. }
          claim HyIn2 : y :e open_interval a2 bb2.
          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq. exact HyIn2. }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume Haeq : a1 = a2.
    (** left endpoint a1 **)
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_standard_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      set I3 := open_interval a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hax : Rlt a1 x.
          { exact Ha1x. }
          claim Hconj : Rlt a1 x /\ Rlt x bb1.
          { apply andI.
            - exact Hax.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Hybb1lt : y < bb1.
          { exact (RltE_lt y bb1 Hybb1). }
          claim Hybb2lt : y < bb2.
          { exact (SNoLt_tra y bb1 bb2 HyS Hb1S Hb2S Hybb1lt Hb1lt). }
	          claim Hybb2 : Rlt y bb2.
	          { exact (RltI y bb2 HyR Hbb2R Hybb2lt). }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { rewrite <- Haeq.
	            exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyR (andI (Rlt a1 y) (Rlt y bb2) Ha1y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := open_interval a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ Rlt x bb1.
          { apply andI.
            - exact Ha1x.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { rewrite <- Hbeq. exact Hybb1. }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { rewrite <- Haeq.
	            exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyR (andI (Rlt a1 y) (Rlt y bb2) Ha1y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      set I3 := open_interval a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ Rlt x bb2.
          { apply andI.
            - exact Ha1x.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (Rlt a1 y) (Rlt y bb2) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Hybb2lt : y < bb2.
          { exact (RltE_lt y bb2 Hybb2). }
          claim Hybb1lt : y < bb1.
          { exact (SNoLt_tra y bb2 bb1 HyS Hb2S Hb1S Hybb2lt Hb2lt). }
          claim Hybb1 : Rlt y bb1.
          { exact (RltI y bb1 HyR Hbb1R Hybb1lt). }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { rewrite <- Haeq.
	            exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyR (andI (Rlt a1 y) (Rlt y bb2) Ha1y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume Ha2lt : a2 < a1.
    (** symmetric to first main case; use left endpoint a1 **)
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_standard_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      set I3 := open_interval a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ Rlt x bb1.
          { apply andI.
            - exact Ha1x.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (Rlt a1 y) (Rlt y bb1) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha1ylt : a1 < y.
          { exact (RltE_lt a1 y Ha1y). }
          claim Hybb1lt : y < bb1.
          { exact (RltE_lt y bb1 Hybb1). }
          (** y in b2: need a2<y and y<bb2 **)
          claim Ha2ylt : a2 < y.
          { exact (SNoLt_tra a2 a1 y Ha2S Ha1S HyS Ha2lt Ha1ylt). }
          claim Ha2y : Rlt a2 y.
          { exact (RltI a2 y Ha2R HyR Ha2ylt). }
          claim Hybb2lt : y < bb2.
          { exact (SNoLt_tra y bb1 bb2 HyS Hb1S Hb2S Hybb1lt Hb1lt). }
          claim Hybb2 : Rlt y bb2.
          { exact (RltI y bb2 HyR Hbb2R Hybb2lt). }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := open_interval a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ Rlt x bb2.
          { apply andI.
            - exact Ha1x.
            - rewrite <- Hbeq.
              exact Hxbb1. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb2) HyProp). }
	          claim Hybb2 : Rlt y bb2.
	          { exact (andER (Rlt a1 y) (Rlt y bb2) HyProp). }
	          claim Hybb1 : Rlt y bb1.
	          { rewrite Hbeq. exact Hybb2. }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha1ylt : a1 < y.
          { exact (RltE_lt a1 y Ha1y). }
          claim Ha2ylt : a2 < y.
          { exact (SNoLt_tra a2 a1 y Ha2S Ha1S HyS Ha2lt Ha1ylt). }
          claim Ha2y : Rlt a2 y.
          { exact (RltI a2 y Ha2R HyR Ha2ylt). }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      set I3 := open_interval a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {open_interval a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ Rlt x bb2.
          { apply andI.
            - exact Ha1x.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume HyI3 : y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim HyProp : Rlt a1 y /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => Rlt a1 z /\ Rlt z bb2) y HyI3). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (Rlt a1 y) (Rlt y bb2) HyProp). }
          claim HyS : SNo y.
          { exact (real_SNo y HyR). }
          claim Ha1ylt : a1 < y.
          { exact (RltE_lt a1 y Ha1y). }
          claim Ha2ylt : a2 < y.
          { exact (SNoLt_tra a2 a1 y Ha2S Ha1S HyS Ha2lt Ha1ylt). }
          claim Ha2y : Rlt a2 y.
          { exact (RltI a2 y Ha2R HyR Ha2ylt). }
          claim Hybb2lt : y < bb2.
          { exact (RltE_lt y bb2 Hybb2). }
          claim Hybb1lt : y < bb1.
          { exact (SNoLt_tra y bb2 bb1 HyS Hb2S Hb1S Hybb2lt Hb2lt). }
          claim Hybb1 : Rlt y bb1.
          { exact (RltI y bb1 HyR Hbb1R Hybb1lt). }
	          claim HyIn1 : y :e open_interval a1 bb1.
	          { exact (SepI R (fun z : set => Rlt a1 z /\ Rlt z bb1) y HyR (andI (Rlt a1 y) (Rlt y bb1) Ha1y Hybb1)). }
	          claim HyIn2 : y :e open_interval a2 bb2.
	          { exact (SepI R (fun z : set => Rlt a2 z /\ Rlt z bb2) y HyR (andI (Rlt a2 y) (Rlt y bb2) Ha2y Hybb2)). }
	          claim Hyb1 : y :e b1.
	          { rewrite Hb1eq. exact HyIn1. }
	          claim Hyb2 : y :e b2.
	          { rewrite Hb2eq. exact HyIn2. }
	          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
Qed.

(** helper: any open interval is open in the standard topology **)
(** LATEX VERSION: Every interval (a,b) is open in the standard topology on ℝ. **)
Theorem open_interval_in_R_standard_topology : forall a b:set,
  Rlt a b -> open_interval a b :e R_standard_topology.
let a b. assume Hab.
claim HaR: a :e R.
{ exact (RltE_left a b Hab). }
claim HbR: b :e R.
{ exact (RltE_right a b Hab). }
claim HbFam : open_interval a b :e {open_interval a b0|b0 :e R}.
{ exact (ReplI R (fun b0:set => open_interval a b0) b HbR). }
claim HbStd : open_interval a b :e R_standard_basis.
{ exact (famunionI R (fun a0:set => {open_interval a0 b0|b0 :e R}) a (open_interval a b) HaR HbFam). }
claim HPow: open_interval a b :e Power R.
{ exact (PowerI R (open_interval a b) (open_interval_Subq_R a b)). }
exact (generated_topology_contains_elem R R_standard_basis (open_interval a b) HPow HbStd).
Qed.

(** from §13: the standard topology on R is a topology **)
(** LATEX VERSION: The topology generated by the standard basis satisfies the topology axioms. **)
Theorem R_standard_topology_is_topology_local : topology_on R R_standard_topology.
exact (lemma_topology_from_basis R R_standard_basis R_standard_basis_is_basis_local).
Qed.

(** helper: open set in R_standard_topology contains a basic open interval **)
(** LATEX VERSION: If U is open and x∈U, then some open interval (a,b) satisfies x∈(a,b)⊆U. **)
Theorem R_standard_open_refine_interval : forall U x:set,
  U :e R_standard_topology ->
  x :e U ->
  exists a b:set,
    a :e R /\ b :e R /\
    x :e open_interval a b /\
    open_interval a b c= U /\
    Rlt a x /\ Rlt x b.
let U x.
assume HU: U :e R_standard_topology.
assume HxU: x :e U.
(** Unpack membership in the generated topology **)
claim HUpow: U :e Power R.
{ exact (SepE1 (Power R)
         (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
         U
         HU). }
claim HUsubR: U c= R.
{ exact (PowerE R U HUpow). }
claim HxR: x :e R.
{ exact (HUsubR x HxU). }
claim HUprop: exists I :e R_standard_basis, x :e I /\ I c= U.
{ exact (SepE2 (Power R)
         (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
         U
         HU
         x
         HxU). }
apply HUprop.
let I. assume HIpair.
claim HIStd: I :e R_standard_basis.
{ exact (andEL (I :e R_standard_basis) (x :e I /\ I c= U) HIpair). }
claim HIprop: x :e I /\ I c= U.
{ exact (andER (I :e R_standard_basis) (x :e I /\ I c= U) HIpair). }
claim HxI: x :e I.
{ exact (andEL (x :e I) (I c= U) HIprop). }
claim HIsubU: I c= U.
{ exact (andER (x :e I) (I c= U) HIprop). }
(** Destruct I as an open interval (a,b) with a,b in R **)
claim Hexa: exists a :e R, I :e {open_interval a b|b :e R}.
{ exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) I HIStd). }
apply Hexa.
let a. assume Hapair. apply Hapair.
assume HaR: a :e R.
assume HIfam: I :e {open_interval a b|b :e R}.
claim Hexb: exists b :e R, I = open_interval a b.
{ exact (ReplE R (fun b0 : set => open_interval a b0) I HIfam). }
apply Hexb.
let b. assume Hbpair. apply Hbpair.
assume HbR: b :e R.
assume HIeq: I = open_interval a b.
(** Build the witnesses **)
witness a.
witness b.
claim HxIn: x :e open_interval a b.
{ rewrite <- HIeq. exact HxI. }
claim HxProp: Rlt a x /\ Rlt x b.
{ exact (SepE2 R (fun z:set => Rlt a z /\ Rlt z b) x HxIn). }
apply andI.
- (** left part: ((((a∈R /\ b∈R) /\ x∈(a,b)) /\ (a,b)⊆U) /\ Rlt a x) **)
  apply andI.
  - (** left part: (((a∈R /\ b∈R) /\ x∈(a,b)) /\ (a,b)⊆U) **)
    apply andI.
    + (** left part: ((a∈R /\ b∈R) /\ x∈(a,b)) **)
      apply andI.
      * (** left part: (a∈R /\ b∈R) **)
        apply andI.
        { exact HaR. }
        { exact HbR. }
      * (** x∈(a,b) **)
        exact HxIn.
    + (** (a,b) ⊆ U **)
      rewrite <- HIeq.
      exact HIsubU.
  - (** Rlt a x **)
    exact (andEL (Rlt a x) (Rlt x b) HxProp).
- (** right part: Rlt x b **)
  exact (andER (Rlt a x) (Rlt x b) HxProp).
Qed.

  (** from §13 Definition: lower limit topology basis on R **)
  (** LATEX VERSION: If B' is the collection of all half-open intervals [a,b) in R with a<b, the topology generated by B' is the lower limit topology on R. **)
Definition R_lower_limit_basis : set :=
  \/_ a :e R, {halfopen_interval_left a b|b :e R}.

  (** from §13 Definition: lower limit topology on R **)
  (** LATEX VERSION: When R is given the lower limit topology, it is denoted R_l. **)
Definition R_lower_limit_topology : set :=
  generated_topology R R_lower_limit_basis.

  (** from §13: the described families are bases **)
  (** LATEX VERSION: It is easy to see the half-open interval family is a basis; intersections are basis elements or empty. **)
  (** helper: the lower limit basis is a basis on R **)
Theorem R_lower_limit_basis_is_basis_local : basis_on R R_lower_limit_basis.
prove basis_on R R_lower_limit_basis.
prove R_lower_limit_basis c= Power R
  /\ (forall x :e R, exists b :e R_lower_limit_basis, x :e b)
  /\ (forall b1 :e R_lower_limit_basis, forall b2 :e R_lower_limit_basis, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- (** basis elements are subsets of R **)
  let U. assume HU : U :e R_lower_limit_basis.
  prove U :e Power R.
  claim Hexa : exists a :e R, U :e {halfopen_interval_left a b|b :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) U HU). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR : a :e R.
  { exact (andEL (a :e R) (U :e {halfopen_interval_left a b|b :e R}) Hapair). }
  claim HUfam : U :e {halfopen_interval_left a b|b :e R}.
  { exact (andER (a :e R) (U :e {halfopen_interval_left a b|b :e R}) Hapair). }
  claim Hexb : exists b :e R, U = halfopen_interval_left a b.
  { exact (ReplE R (fun b0 : set => halfopen_interval_left a b0) U HUfam). }
  apply Hexb.
  let b. assume Hbpair.
  claim HUeq : U = halfopen_interval_left a b.
  { exact (andER (b :e R) (U = halfopen_interval_left a b) Hbpair). }
  rewrite HUeq.
  exact (PowerI R (halfopen_interval_left a b) (halfopen_interval_left_Subq_R a b)).
- (** coverage: every x has a basis neighborhood [x,x+1) **)
  let x. assume HxR.
  claim HxS : SNo x.
  { exact (real_SNo x HxR). }
  set b0 := add_SNo x 1.
  claim Hb0R : b0 :e R.
  { exact (real_add_SNo x HxR 1 real_1). }
  claim Hb0S : SNo b0.
  { exact (real_SNo b0 Hb0R). }
  claim Hxltb0 : x < b0.
  { claim Hx0lt : add_SNo x 0 < add_SNo x 1.
    { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
    rewrite <- (add_SNo_0R x HxS) at 1.
    exact Hx0lt. }
  claim Hxb0 : Rlt x b0.
  { exact (RltI x b0 HxR Hb0R Hxltb0). }
  set I := halfopen_interval_left x b0.
  witness I.
  apply andI.
  - (** I is in the lower limit basis **)
    prove I :e R_lower_limit_basis.
    claim HIa : I :e {halfopen_interval_left x bb|bb :e R}.
    { exact (ReplI R (fun bb : set => halfopen_interval_left x bb) b0 Hb0R). }
    exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) x I HxR HIa).
  - (** x is in I **)
    exact (halfopen_interval_left_leftmem x b0 Hxb0).
- (** intersection refinement **)
  let b1. assume Hb1.
  let b2. assume Hb2.
  let x. assume Hx1 Hx2.
  prove exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2.
  (** destruct b1 = halfopen_interval_left a1 bb1 with a1,bb1 in R **)
  claim Hexa1 : exists a1 :e R, b1 :e {halfopen_interval_left a1 b|b :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) b1 Hb1). }
  apply Hexa1.
  let a1. assume Ha1pair. apply Ha1pair.
  assume Ha1R : a1 :e R.
  assume Hb1fam : b1 :e {halfopen_interval_left a1 b|b :e R}.
  claim Hexb1 : exists bb1 :e R, b1 = halfopen_interval_left a1 bb1.
  { exact (ReplE R (fun bb : set => halfopen_interval_left a1 bb) b1 Hb1fam). }
  apply Hexb1.
  let bb1. assume Hbb1pair. apply Hbb1pair.
  assume Hbb1R : bb1 :e R.
  assume Hb1eq : b1 = halfopen_interval_left a1 bb1.

  (** destruct b2 = halfopen_interval_left a2 bb2 with a2,bb2 in R **)
  claim Hexa2 : exists a2 :e R, b2 :e {halfopen_interval_left a2 b|b :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) b2 Hb2). }
  apply Hexa2.
  let a2. assume Ha2pair. apply Ha2pair.
  assume Ha2R : a2 :e R.
  assume Hb2fam : b2 :e {halfopen_interval_left a2 b|b :e R}.
  claim Hexb2 : exists bb2 :e R, b2 = halfopen_interval_left a2 bb2.
  { exact (ReplE R (fun bb : set => halfopen_interval_left a2 bb) b2 Hb2fam). }
  apply Hexb2.
  let bb2. assume Hbb2pair. apply Hbb2pair.
  assume Hbb2R : bb2 :e R.
  assume Hb2eq : b2 = halfopen_interval_left a2 bb2.

  (** extract constraints from x membership **)
  claim HxIn1 : x :e halfopen_interval_left a1 bb1.
  { rewrite <- Hb1eq. exact Hx1. }
  claim HxIn2 : x :e halfopen_interval_left a2 bb2.
  { rewrite <- Hb2eq. exact Hx2. }
  claim HxR : x :e R.
  { exact (SepE1 R (fun x0 : set => ~(Rlt x0 a1) /\ Rlt x0 bb1) x HxIn1). }
  claim HxProp1 : ~(Rlt x a1) /\ Rlt x bb1.
  { exact (SepE2 R (fun x0 : set => ~(Rlt x0 a1) /\ Rlt x0 bb1) x HxIn1). }
  claim HxProp2 : ~(Rlt x a2) /\ Rlt x bb2.
  { exact (SepE2 R (fun x0 : set => ~(Rlt x0 a2) /\ Rlt x0 bb2) x HxIn2). }
  claim Hnxa1 : ~(Rlt x a1).
  { exact (andEL (~(Rlt x a1)) (Rlt x bb1) HxProp1). }
  claim Hxbb1 : Rlt x bb1.
  { exact (andER (~(Rlt x a1)) (Rlt x bb1) HxProp1). }
  claim Hnxa2 : ~(Rlt x a2).
  { exact (andEL (~(Rlt x a2)) (Rlt x bb2) HxProp2). }
  claim Hxbb2 : Rlt x bb2.
  { exact (andER (~(Rlt x a2)) (Rlt x bb2) HxProp2). }

  claim Ha1S : SNo a1.
  { exact (real_SNo a1 Ha1R). }
  claim Ha2S : SNo a2.
  { exact (real_SNo a2 Ha2R). }
  claim Hb1S : SNo bb1.
  { exact (real_SNo bb1 Hbb1R). }
  claim Hb2S : SNo bb2.
  { exact (real_SNo bb2 Hbb2R). }

  (** choose max left endpoint and min right endpoint by trichotomy **)
  apply (SNoLt_trichotomy_or_impred a1 a2 Ha1S Ha2S
           (exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
  - assume Ha1lt : a1 < a2.
    claim Ha1a2 : Rlt a1 a2.
    { exact (RltI a1 a2 Ha1R Ha2R Ha1lt). }
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_left a2 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { (** x in I3 **)
          claim Hconj : ~(Rlt x a2) /\ Rlt x bb1.
          { apply andI.
            - exact Hnxa2.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) x HxR Hconj). }
        { (** I3 subset b1 ∩ b2 **)
          let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) y Hy). }
          claim HyProp : ~(Rlt y a2) /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) y Hy). }
          claim Hnya2 : ~(Rlt y a2).
          { exact (andEL (~(Rlt y a2)) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (~(Rlt y a2)) (Rlt y bb1) HyProp). }
          claim Hnya1 : ~(Rlt y a1).
          { assume Hya1 : Rlt y a1.
            claim Hya2 : Rlt y a2.
            { exact (Rlt_tra y a1 a2 Hya1 Ha1a2). }
            exact (Hnya2 Hya2). }
          claim Hybb2 : Rlt y bb2.
          { exact (Rlt_tra y bb1 bb2 Hybb1 Hbb1bb2). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq at 1.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume HbbEq : bb1 = bb2.
      set I3 := halfopen_interval_left a2 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : ~(Rlt x a2) /\ Rlt x bb1.
          { apply andI.
            - exact Hnxa2.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) y Hy). }
          claim HyProp : ~(Rlt y a2) /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb1) y Hy). }
          claim Hnya2 : ~(Rlt y a2).
          { exact (andEL (~(Rlt y a2)) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (~(Rlt y a2)) (Rlt y bb1) HyProp). }
          claim Hnya1 : ~(Rlt y a1).
          { assume Hya1 : Rlt y a1.
            claim Hya2 : Rlt y a2.
            { exact (Rlt_tra y a1 a2 Hya1 Ha1a2). }
            exact (Hnya2 Hya2). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hybb2 : Rlt y bb2.
            { rewrite <- HbbEq.
              exact Hybb1. }
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_left a2 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a2 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : ~(Rlt x a2) /\ Rlt x bb2.
          { apply andI.
            - exact Hnxa2.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y Hy). }
          claim HyProp : ~(Rlt y a2) /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y Hy). }
          claim Hnya2 : ~(Rlt y a2).
          { exact (andEL (~(Rlt y a2)) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (~(Rlt y a2)) (Rlt y bb2) HyProp). }
          claim Hnya1 : ~(Rlt y a1).
          { assume Hya1 : Rlt y a1.
            claim Hya2 : Rlt y a2.
            { exact (Rlt_tra y a1 a2 Hya1 Ha1a2). }
            exact (Hnya2 Hya2). }
          claim Hybb1 : Rlt y bb1.
          { exact (Rlt_tra y bb2 bb1 Hybb2 Hbb2bb1). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume HaEq : a1 = a2.
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_left a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { exact HxIn1. }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim HyProp : ~(Rlt y a1) /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim Hnya1 : ~(Rlt y a1).
          { exact (andEL (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (Rlt_tra y bb1 bb2 Hybb1 Hbb1bb2). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hnya2 : ~(Rlt y a2).
            { rewrite <- HaEq.
              exact Hnya1. }
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume HbEq : bb1 = bb2.
      witness b1.
      apply andI.
      * exact Hb1.
      * apply andI.
        { exact Hx1. }
        { let y. assume Hy: y :e b1.
          prove y :e b1 :/\: b2.
          claim Hyb2: y :e b2.
          { claim Hb1b2 : b1 = b2.
            { rewrite Hb1eq.
              rewrite Hb2eq.
              rewrite HaEq.
              rewrite HbEq.
              reflexivity. }
            rewrite <- Hb1b2.
            exact Hy. }
          exact (binintersectI b1 b2 y Hy Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_left a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : ~(Rlt x a1) /\ Rlt x bb2.
          { apply andI.
            - exact Hnxa1.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) y Hy). }
          claim HyProp : ~(Rlt y a1) /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) y Hy). }
          claim Hnya1 : ~(Rlt y a1).
          { exact (andEL (~(Rlt y a1)) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (~(Rlt y a1)) (Rlt y bb2) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (Rlt_tra y bb2 bb1 Hybb2 Hbb2bb1). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hnya2 : ~(Rlt y a2).
            { rewrite <- HaEq.
              exact Hnya1. }
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume Ha2lt : a2 < a1.
    claim Ha2a1 : Rlt a2 a1.
    { exact (RltI a2 a1 Ha2R Ha1R Ha2lt). }
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_lower_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_left a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : ~(Rlt x a1) /\ Rlt x bb1.
          { apply andI.
            - exact Hnxa1.
            - exact Hxbb1. }
          exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim HyProp : ~(Rlt y a1) /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim Hnya1 : ~(Rlt y a1).
          { exact (andEL (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hnya2 : ~(Rlt y a2).
          { assume Hya2 : Rlt y a2.
            claim Hya1 : Rlt y a1.
            { exact (Rlt_tra y a2 a1 Hya2 Ha2a1). }
            exact (Hnya1 Hya1). }
          claim Hybb2 : Rlt y bb2.
          { exact (Rlt_tra y bb1 bb2 Hybb1 Hbb1bb2). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume HbEq : bb1 = bb2.
      set I3 := halfopen_interval_left a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { exact HxIn1. }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim HyProp : ~(Rlt y a1) /\ Rlt y bb1.
          { exact (SepE2 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y Hy). }
          claim Hnya1 : ~(Rlt y a1).
          { exact (andEL (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hybb1 : Rlt y bb1.
          { exact (andER (~(Rlt y a1)) (Rlt y bb1) HyProp). }
          claim Hnya2 : ~(Rlt y a2).
          { assume Hya2 : Rlt y a2.
            claim Hya1 : Rlt y a1.
            { exact (Rlt_tra y a2 a1 Hya2 Ha2a1). }
            exact (Hnya1 Hya1). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hybb2 : Rlt y bb2.
            { rewrite <- HbEq.
              exact Hybb1. }
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_left a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_left a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_left a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : ~(Rlt x a1) /\ Rlt x bb2.
          { apply andI.
            - exact Hnxa1.
            - exact Hxbb2. }
          exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) y Hy). }
          claim HyProp : ~(Rlt y a1) /\ Rlt y bb2.
          { exact (SepE2 R (fun z : set => ~(Rlt z a1) /\ Rlt z bb2) y Hy). }
          claim Hnya1 : ~(Rlt y a1).
          { exact (andEL (~(Rlt y a1)) (Rlt y bb2) HyProp). }
          claim Hybb2 : Rlt y bb2.
          { exact (andER (~(Rlt y a1)) (Rlt y bb2) HyProp). }
          claim Hnya2 : ~(Rlt y a2).
          { assume Hya2 : Rlt y a2.
            claim Hya1 : Rlt y a1.
            { exact (Rlt_tra y a2 a1 Hya2 Ha2a1). }
            exact (Hnya1 Hya1). }
          claim Hybb1 : Rlt y bb1.
          { exact (Rlt_tra y bb2 bb1 Hybb2 Hbb2bb1). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            exact (SepI R (fun z : set => ~(Rlt z a1) /\ Rlt z bb1) y HyR (andI (~(Rlt y a1)) (Rlt y bb1) Hnya1 Hybb1)). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            exact (SepI R (fun z : set => ~(Rlt z a2) /\ Rlt z bb2) y HyR (andI (~(Rlt y a2)) (Rlt y bb2) Hnya2 Hybb2)). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
Qed.

(** from §13: the lower limit topology on R is a topology **)
(** LATEX VERSION: The topology generated by the lower limit basis satisfies the topology axioms. **)
Theorem R_lower_limit_topology_is_topology : topology_on R R_lower_limit_topology.
exact (lemma_topology_from_basis R R_lower_limit_basis R_lower_limit_basis_is_basis_local).
Qed.

(** Helper: half-open intervals [a,b) are open in the lower limit topology **)
(** LATEX VERSION: Every basic lower-limit interval [a,b) is open in the topology generated by the lower-limit basis. **)
Theorem halfopen_interval_left_in_R_lower_limit_topology : forall a b:set,
  a :e R -> b :e R ->
  halfopen_interval_left a b :e R_lower_limit_topology.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
prove halfopen_interval_left a b :e R_lower_limit_topology.
(** show it is a basis element **)
claim HbFam: halfopen_interval_left a b :e {halfopen_interval_left a bb|bb :e R}.
{ exact (ReplI R (fun bb : set => halfopen_interval_left a bb) b HbR). }
claim HbBasis: halfopen_interval_left a b :e R_lower_limit_basis.
{ exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R})
         a
         (halfopen_interval_left a b)
         HaR
         HbFam). }
exact (generated_topology_contains_basis R R_lower_limit_basis
       R_lower_limit_basis_is_basis_local
       (halfopen_interval_left a b)
       HbBasis).
Qed.

(** Helper: open intervals (a,b) are open in the lower limit topology **)
(** LATEX VERSION: Every standard open interval (a,b) is a union of half open intervals [x,b) with x in (a,b), hence is open in R_ell. **)
Theorem open_interval_in_R_lower_limit_topology : forall a b:set,
  a :e R -> b :e R ->
  open_interval a b :e R_lower_limit_topology.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
set Fam := {halfopen_interval_left x b|x :e open_interval a b}.
claim HTlower: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HFamSub: Fam c= R_lower_limit_topology.
{ let U. assume HU: U :e Fam.
  prove U :e R_lower_limit_topology.
  apply (ReplE_impred (open_interval a b) (fun x0:set => halfopen_interval_left x0 b) U HU (U :e R_lower_limit_topology)).
  let x. assume HxI: x :e open_interval a b.
  assume HUeq: U = halfopen_interval_left x b.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x HxI). }
  rewrite HUeq.
  exact (halfopen_interval_left_in_R_lower_limit_topology x b HxR HbR). }
claim Heq: open_interval a b = Union Fam.
{ apply set_ext.
  - let y. assume Hy: y :e open_interval a b.
    prove y :e Union Fam.
    claim HyR: y :e R.
    { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) y Hy). }
    claim HyProp: Rlt a y /\ Rlt y b.
    { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) y Hy). }
    claim Hyb: Rlt y b.
    { exact (andER (Rlt a y) (Rlt y b) HyProp). }
    set U0 := halfopen_interval_left y b.
    claim HyU0: y :e U0.
    { exact (halfopen_interval_left_leftmem y b Hyb). }
    claim HU0Fam: U0 :e Fam.
    { exact (ReplI (open_interval a b) (fun x0:set => halfopen_interval_left x0 b) y Hy). }
    exact (UnionI Fam y U0 HyU0 HU0Fam).
  - let y. assume HyU: y :e Union Fam.
    prove y :e open_interval a b.
    apply (UnionE_impred Fam y HyU (y :e open_interval a b)).
    let U. assume HyU0: y :e U.
    assume HUFam: U :e Fam.
    claim Hexx: exists x:set, x :e open_interval a b /\ U = halfopen_interval_left x b.
    { exact (ReplE (open_interval a b) (fun x0:set => halfopen_interval_left x0 b) U HUFam). }
    apply Hexx.
    let x. assume Hxpair.
    claim HxI: x :e open_interval a b.
    { exact (andEL (x :e open_interval a b) (U = halfopen_interval_left x b) Hxpair). }
    claim HUeq: U = halfopen_interval_left x b.
    { exact (andER (x :e open_interval a b) (U = halfopen_interval_left x b) Hxpair). }
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x HxI). }
    claim HxProp: Rlt a x /\ Rlt x b.
    { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x HxI). }
    claim Hax: Rlt a x.
    { exact (andEL (Rlt a x) (Rlt x b) HxProp). }
    claim HyHx: y :e halfopen_interval_left x b.
    { rewrite <- HUeq.
      exact HyU0. }
    claim HyR: y :e R.
    { exact (SepE1 R (fun z:set => ~(Rlt z x) /\ Rlt z b) y HyHx). }
    claim HyProp: ~(Rlt y x) /\ Rlt y b.
    { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z b) y HyHx). }
    claim Hnyx: ~(Rlt y x).
    { exact (andEL (~(Rlt y x)) (Rlt y b) HyProp). }
    claim Hyb: Rlt y b.
    { exact (andER (~(Rlt y x)) (Rlt y b) HyProp). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HyS: SNo y.
    { exact (real_SNo y HyR). }
    claim Hay: Rlt a y.
    { apply (SNoLt_trichotomy_or_impred a y HaS HyS (Rlt a y)).
      - assume Halt: a < y.
        exact (RltI a y HaR HyR Halt).
      - assume HaEq: a = y.
        claim Hyx: Rlt y x.
        { rewrite <- HaEq. exact Hax. }
        apply FalseE.
        exact (Hnyx Hyx).
      - assume Hylt: y < a.
        claim Hya: Rlt y a.
        { exact (RltI y a HyR HaR Hylt). }
        claim Hyx: Rlt y x.
        { exact (Rlt_tra y a x Hya Hax). }
        apply FalseE.
        exact (Hnyx Hyx). }
    claim Hop_def: open_interval a b = {z :e R | Rlt a z /\ Rlt z b}.
    { reflexivity. }
    rewrite Hop_def.
    apply (SepI R (fun z:set => Rlt a z /\ Rlt z b) y HyR).
    apply andI.
    - exact Hay.
    - exact Hyb. }
rewrite Heq.
exact (topology_union_closed R R_lower_limit_topology Fam HTlower HFamSub).
Qed.

(** Helper: the lower limit topology is finer than the standard topology **)
(** LATEX VERSION: Every standard open interval (a,b) is open in R_ell, hence R_ell is finer than the standard topology. **)
Theorem R_lower_limit_finer_than_R_standard : finer_than R_lower_limit_topology R_standard_topology.
prove finer_than R_lower_limit_topology R_standard_topology.
claim HBstd: basis_on R R_standard_basis.
{ exact R_standard_basis_is_basis_local. }
claim HTlower: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HBsub: forall U :e R_standard_basis, U :e R_lower_limit_topology.
{ let U. assume HU: U :e R_standard_basis.
  (** destruct U = open_interval a b with a,b in R **)
  claim Hexa: exists a0 :e R, U :e {open_interval a0 b0|b0 :e R}.
  { exact (famunionE R (fun a1:set => {open_interval a1 b1|b1 :e R}) U HU). }
  apply Hexa.
  let a0. assume Ha0pair.
  claim Ha0R: a0 :e R.
  { exact (andEL (a0 :e R) (U :e {open_interval a0 b0|b0 :e R}) Ha0pair). }
  claim HUfam: U :e {open_interval a0 b0|b0 :e R}.
  { exact (andER (a0 :e R) (U :e {open_interval a0 b0|b0 :e R}) Ha0pair). }
  claim Hexb: exists b0 :e R, U = open_interval a0 b0.
  { exact (ReplE R (fun b1:set => open_interval a0 b1) U HUfam). }
  apply Hexb.
  let b0. assume Hb0pair.
  claim Hb0R: b0 :e R.
  { exact (andEL (b0 :e R) (U = open_interval a0 b0) Hb0pair). }
  claim HUeq: U = open_interval a0 b0.
  { exact (andER (b0 :e R) (U = open_interval a0 b0) Hb0pair). }
  rewrite HUeq.
  exact (open_interval_in_R_lower_limit_topology a0 b0 Ha0R Hb0R). }
(** generated_topology R R_standard_basis = R_standard_topology **)
exact (generated_topology_finer R R_standard_basis R_lower_limit_topology HBstd HTlower HBsub).
Qed.

(** from §13 Exercise 7: basis for the upper limit topology on R **)
(** LATEX VERSION: The upper limit topology on R is generated by half open intervals (a,b]. **)
Definition R_upper_limit_basis : set :=
  \/_ a :e R, {halfopen_interval_right a b|b :e R}.

(** helper: the upper limit basis is a basis on R **)
Theorem R_upper_limit_basis_is_basis_local : basis_on R R_upper_limit_basis.
prove basis_on R R_upper_limit_basis.
prove R_upper_limit_basis c= Power R
  /\ (forall x :e R, exists b :e R_upper_limit_basis, x :e b)
  /\ (forall b1 :e R_upper_limit_basis, forall b2 :e R_upper_limit_basis, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e R_upper_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- (** basis elements are subsets of R **)
  let U. assume HU : U :e R_upper_limit_basis.
  prove U :e Power R.
  claim Hexa : exists a :e R, U :e {halfopen_interval_right a b|b :e R}.
  { exact (famunionE R (fun a0 : set => {halfopen_interval_right a0 b|b :e R}) U HU). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR : a :e R.
  { exact (andEL (a :e R) (U :e {halfopen_interval_right a b|b :e R}) Hapair). }
  claim HUfam : U :e {halfopen_interval_right a b|b :e R}.
  { exact (andER (a :e R) (U :e {halfopen_interval_right a b|b :e R}) Hapair). }
  claim Hexb : exists b :e R, U = halfopen_interval_right a b.
  { exact (ReplE R (fun b0 : set => halfopen_interval_right a b0) U HUfam). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbR : b :e R.
  { exact (andEL (b :e R) (U = halfopen_interval_right a b) Hbpair). }
  claim HUeq : U = halfopen_interval_right a b.
  { exact (andER (b :e R) (U = halfopen_interval_right a b) Hbpair). }
  rewrite HUeq.
  exact (PowerI R (halfopen_interval_right a b) (halfopen_interval_right_Subq_R a b)).
- (** coverage: every x has a basis neighborhood (x-1,x] **)
  let x. assume HxR.
  claim Hm1R : minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  set a0 := add_SNo x (minus_SNo 1).
  claim Ha0R : a0 :e R.
  { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
  set I := halfopen_interval_right a0 x.
  witness I.
  apply andI.
  - (** I is in the upper limit basis **)
    prove I :e R_upper_limit_basis.
    claim HIa : I :e {halfopen_interval_right a0 bb|bb :e R}.
    { exact (ReplI R (fun bb : set => halfopen_interval_right a0 bb) x HxR). }
    exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a0 I Ha0R HIa).
  - (** x is in I **)
    claim HxS : SNo x.
    { exact (real_SNo x HxR). }
    claim Hm1S : SNo (minus_SNo 1).
    { exact (SNo_minus_SNo 1 SNo_1). }
    claim Ha0ltx : a0 < x.
    { claim Hlt : add_SNo x (minus_SNo 1) < add_SNo x 0.
      { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
      rewrite <- (add_SNo_0R x HxS) at 2.
      exact Hlt. }
    claim Ha0x : Rlt a0 x.
    { exact (RltI a0 x Ha0R HxR Ha0ltx). }
    claim Hnx : ~(Rlt x x).
    { exact (not_Rlt_refl x HxR). }
    claim Hconj : Rlt a0 x /\ ~(Rlt x x).
    { apply andI.
      - exact Ha0x.
      - exact Hnx. }
    exact (SepI R (fun x0 : set => Rlt a0 x0 /\ ~(Rlt x x0)) x HxR Hconj).
- (** intersection refinement **)
  let b1. assume Hb1.
  let b2. assume Hb2.
  let x. assume Hx1 Hx2.
  (** destruct b1 and b2 as halfopen intervals (a,bb] **)
  claim Hexa1 : exists a1 :e R, b1 :e {halfopen_interval_right a1 b|b :e R}.
  { exact (famunionE R (fun a0 : set => {halfopen_interval_right a0 b|b :e R}) b1 Hb1). }
  claim Hexa2 : exists a2 :e R, b2 :e {halfopen_interval_right a2 b|b :e R}.
  { exact (famunionE R (fun a0 : set => {halfopen_interval_right a0 b|b :e R}) b2 Hb2). }
  apply Hexa1.
  let a1. assume Ha1pair.
  claim Ha1R : a1 :e R.
  { exact (andEL (a1 :e R) (b1 :e {halfopen_interval_right a1 b|b :e R}) Ha1pair). }
  claim Hb1fam : b1 :e {halfopen_interval_right a1 b|b :e R}.
  { exact (andER (a1 :e R) (b1 :e {halfopen_interval_right a1 b|b :e R}) Ha1pair). }
  claim Hexb1 : exists bb1 :e R, b1 = halfopen_interval_right a1 bb1.
  { exact (ReplE R (fun bb : set => halfopen_interval_right a1 bb) b1 Hb1fam). }
  apply Hexb1.
  let bb1. assume Hbb1pair.
  claim Hbb1R : bb1 :e R.
  { exact (andEL (bb1 :e R) (b1 = halfopen_interval_right a1 bb1) Hbb1pair). }
  claim Hb1eq : b1 = halfopen_interval_right a1 bb1.
  { exact (andER (bb1 :e R) (b1 = halfopen_interval_right a1 bb1) Hbb1pair). }
  apply Hexa2.
  let a2. assume Ha2pair.
  claim Ha2R : a2 :e R.
  { exact (andEL (a2 :e R) (b2 :e {halfopen_interval_right a2 b|b :e R}) Ha2pair). }
  claim Hb2fam : b2 :e {halfopen_interval_right a2 b|b :e R}.
  { exact (andER (a2 :e R) (b2 :e {halfopen_interval_right a2 b|b :e R}) Ha2pair). }
  claim Hexb2 : exists bb2 :e R, b2 = halfopen_interval_right a2 bb2.
  { exact (ReplE R (fun bb : set => halfopen_interval_right a2 bb) b2 Hb2fam). }
  apply Hexb2.
  let bb2. assume Hbb2pair.
  claim Hbb2R : bb2 :e R.
  { exact (andEL (bb2 :e R) (b2 = halfopen_interval_right a2 bb2) Hbb2pair). }
  claim Hb2eq : b2 = halfopen_interval_right a2 bb2.
  { exact (andER (bb2 :e R) (b2 = halfopen_interval_right a2 bb2) Hbb2pair). }
  (** extract constraints from x membership **)
  claim HxIn1 : x :e halfopen_interval_right a1 bb1.
  { rewrite <- Hb1eq. exact Hx1. }
  claim HxIn2 : x :e halfopen_interval_right a2 bb2.
  { rewrite <- Hb2eq. exact Hx2. }
  claim HxR : x :e R.
  { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxIn1). }
  claim HxProp1 : Rlt a1 x /\ ~(Rlt bb1 x).
  { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxIn1). }
  claim HxProp2 : Rlt a2 x /\ ~(Rlt bb2 x).
  { exact (SepE2 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) x HxIn2). }
  claim Ha1x : Rlt a1 x.
  { exact (andEL (Rlt a1 x) (~(Rlt bb1 x)) HxProp1). }
  claim Hnbb1x : ~(Rlt bb1 x).
  { exact (andER (Rlt a1 x) (~(Rlt bb1 x)) HxProp1). }
  claim Ha2x : Rlt a2 x.
  { exact (andEL (Rlt a2 x) (~(Rlt bb2 x)) HxProp2). }
  claim Hnbb2x : ~(Rlt bb2 x).
  { exact (andER (Rlt a2 x) (~(Rlt bb2 x)) HxProp2). }
  claim Ha1S : SNo a1.
  { exact (real_SNo a1 Ha1R). }
  claim Ha2S : SNo a2.
  { exact (real_SNo a2 Ha2R). }
  claim Hb1S : SNo bb1.
  { exact (real_SNo bb1 Hbb1R). }
  claim Hb2S : SNo bb2.
  { exact (real_SNo bb2 Hbb2R). }
  (** choose max left endpoint and min right endpoint by trichotomy **)
  apply (SNoLt_trichotomy_or_impred a1 a2 Ha1S Ha2S
           (exists b3 :e R_upper_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
  - assume Ha1lt : a1 < a2.
    claim Ha1a2 : Rlt a1 a2.
    { exact (RltI a1 a2 Ha1R Ha2R Ha1lt). }
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_upper_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_right a2 bb1.
      witness I3.
      apply andI.
      * (** I3 is in the basis **)
        claim HI3fam : I3 :e {halfopen_interval_right a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { (** x in I3 **)
          claim Hconj : Rlt a2 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha2x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { (** I3 subset b1 ∩ b2 **)
          let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim HyProp : Rlt a2 y /\ ~(Rlt bb1 y).
          { exact (SepE2 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { exact (andER (Rlt a2 y) (~(Rlt bb1 y)) HyProp). }
          claim Ha1y : Rlt a1 y.
          { exact (Rlt_tra a1 a2 y Ha1a2 Ha2y). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { assume Hbb2y : Rlt bb2 y.
            claim Hbb1y : Rlt bb1 y.
            { exact (Rlt_tra bb1 bb2 y Hbb1bb2 Hbb2y). }
            exact (Hnbb1y Hbb1y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := halfopen_interval_right a2 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a2 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a2 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha2x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim HyProp : Rlt a2 y /\ ~(Rlt bb1 y).
          { exact (SepE2 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { exact (andER (Rlt a2 y) (~(Rlt bb1 y)) HyProp). }
          claim Ha1y : Rlt a1 y.
          { exact (Rlt_tra a1 a2 y Ha1a2 Ha2y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            rewrite <- Hbeq.
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb1 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_right a2 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a2 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a2 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a2 I3 Ha2R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a2 x /\ ~(Rlt bb2 x).
          { apply andI.
            - exact Ha2x.
            - exact Hnbb2x. }
          exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim HyProp : Rlt a2 y /\ ~(Rlt bb2 y).
          { exact (SepE2 R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim Ha2y : Rlt a2 y.
          { exact (andEL (Rlt a2 y) (~(Rlt bb2 y)) HyProp). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { exact (andER (Rlt a2 y) (~(Rlt bb2 y)) HyProp). }
          claim Ha1y : Rlt a1 y.
          { exact (Rlt_tra a1 a2 y Ha1a2 Ha2y). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { assume Hbb1y : Rlt bb1 y.
            claim Hbb2y : Rlt bb2 y.
            { exact (Rlt_tra bb2 bb1 y Hbb2bb1 Hbb1y). }
            exact (Hnbb2y Hbb2y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume Haeq : a1 = a2.
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_upper_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_right a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim HyProp : Rlt a1 y /\ ~(Rlt bb1 y).
          { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { exact (andER (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { assume Hbb2y : Rlt bb2 y.
            claim Hbb1y : Rlt bb1 y.
            { exact (Rlt_tra bb1 bb2 y Hbb1bb2 Hbb2y). }
            exact (Hnbb1y Hbb1y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            rewrite <- Haeq.
            claim Hc2 : Rlt a1 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := halfopen_interval_right a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq. exact Hy. }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            rewrite <- Haeq.
            rewrite <- Hbeq.
            exact Hy. }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_right a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb2 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb2x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim HyProp : Rlt a1 y /\ ~(Rlt bb2 y).
          { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (~(Rlt bb2 y)) HyProp). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { exact (andER (Rlt a1 y) (~(Rlt bb2 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { assume Hbb1y : Rlt bb1 y.
            claim Hbb2y : Rlt bb2 y.
            { exact (Rlt_tra bb2 bb1 y Hbb2bb1 Hbb1y). }
            exact (Hnbb2y Hbb2y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            rewrite <- Haeq.
            claim Hc2 : Rlt a1 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
  - assume Ha2lt : a2 < a1.
    claim Ha2a1 : Rlt a2 a1.
    { exact (RltI a2 a1 Ha2R Ha1R Ha2lt). }
    apply (SNoLt_trichotomy_or_impred bb1 bb2 Hb1S Hb2S
             (exists b3 :e R_upper_limit_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb1lt : bb1 < bb2.
      claim Hbb1bb2 : Rlt bb1 bb2.
      { exact (RltI bb1 bb2 Hbb1R Hbb2R Hb1lt). }
      set I3 := halfopen_interval_right a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim HyProp : Rlt a1 y /\ ~(Rlt bb1 y).
          { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { exact (andER (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Ha2y : Rlt a2 y.
          { exact (Rlt_tra a2 a1 y Ha2a1 Ha1y). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { assume Hbb2y : Rlt bb2 y.
            claim Hbb1y : Rlt bb1 y.
            { exact (Rlt_tra bb1 bb2 y Hbb1bb2 Hbb2y). }
            exact (Hnbb1y Hbb1y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hbeq : bb1 = bb2.
      set I3 := halfopen_interval_right a1 bb1.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb1 Hbb1R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb1 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb1x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim HyProp : Rlt a1 y /\ ~(Rlt bb1 y).
          { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y Hy). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { exact (andER (Rlt a1 y) (~(Rlt bb1 y)) HyProp). }
          claim Ha2y : Rlt a2 y.
          { exact (Rlt_tra a2 a1 y Ha2a1 Ha1y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq. exact Hy. }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hnbb2y : ~(Rlt bb2 y).
              { assume Hbb2y : Rlt bb2 y.
                claim Hbb1y : Rlt bb1 y.
              { rewrite Hbeq at 1.
                exact Hbb2y. }
                exact (Hnbb1y Hbb1y). }
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2lt : bb2 < bb1.
      claim Hbb2bb1 : Rlt bb2 bb1.
      { exact (RltI bb2 bb1 Hbb2R Hbb1R Hb2lt). }
      set I3 := halfopen_interval_right a1 bb2.
      witness I3.
      apply andI.
      * claim HI3fam : I3 :e {halfopen_interval_right a1 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => halfopen_interval_right a1 bb) bb2 Hbb2R). }
        exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R}) a1 I3 Ha1R HI3fam).
      * apply andI.
        { claim Hconj : Rlt a1 x /\ ~(Rlt bb2 x).
          { apply andI.
            - exact Ha1x.
            - exact Hnbb2x. }
          exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) x HxR Hconj). }
        { let y. assume Hy: y :e I3.
          prove y :e b1 :/\: b2.
          claim HyR : y :e R.
          { exact (SepE1 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim HyProp : Rlt a1 y /\ ~(Rlt bb2 y).
          { exact (SepE2 R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb2 x0)) y Hy). }
          claim Ha1y : Rlt a1 y.
          { exact (andEL (Rlt a1 y) (~(Rlt bb2 y)) HyProp). }
          claim Hnbb2y : ~(Rlt bb2 y).
          { exact (andER (Rlt a1 y) (~(Rlt bb2 y)) HyProp). }
          claim Ha2y : Rlt a2 y.
          { exact (Rlt_tra a2 a1 y Ha2a1 Ha1y). }
          claim Hnbb1y : ~(Rlt bb1 y).
          { assume Hbb1y : Rlt bb1 y.
            claim Hbb2y : Rlt bb2 y.
            { exact (Rlt_tra bb2 bb1 y Hbb2bb1 Hbb1y). }
            exact (Hnbb2y Hbb2y). }
          claim Hyb1 : y :e b1.
          { rewrite Hb1eq.
            claim Hc1 : Rlt a1 y /\ ~(Rlt bb1 y).
            { apply andI.
              - exact Ha1y.
              - exact Hnbb1y. }
            exact (SepI R (fun x0 : set => Rlt a1 x0 /\ ~(Rlt bb1 x0)) y HyR Hc1). }
          claim Hyb2 : y :e b2.
          { rewrite Hb2eq.
            claim Hc2 : Rlt a2 y /\ ~(Rlt bb2 y).
            { apply andI.
              - exact Ha2y.
              - exact Hnbb2y. }
            exact (SepI R (fun x0 : set => Rlt a2 x0 /\ ~(Rlt bb2 x0)) y HyR Hc2). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
Qed.

(** from §13 Exercise 7: upper limit topology on R **)
(** LATEX VERSION: The upper limit topology is the topology generated by that basis. **)
Definition R_upper_limit_topology : set :=
  generated_topology R R_upper_limit_basis.

(** helper: the upper limit topology on R is a topology **)
Theorem R_upper_limit_topology_is_topology_local : topology_on R R_upper_limit_topology.
exact (lemma_topology_from_basis R R_upper_limit_basis R_upper_limit_basis_is_basis_local).
Qed.

(** from §13 Definition: K subset of R via reciprocals **)
(** LATEX VERSION: Let K be the set of all numbers of the form 1/n, for n in Z_+. **)
(** FIXED: Now uses proper reciprocal from line 5762; recip_SNo computes 1/x for surreal numbers (including naturals), so for n∈ω, recip_SNo n computes 1/n. **)
Definition inv_nat : set -> set := recip_SNo.

(** helper: 1/n is real for n in omega **)
Theorem inv_nat_real : forall n:set, n :e omega -> inv_nat n :e R.
let n. assume Hn: n :e omega.
prove inv_nat n :e R.
(** omega is included in SNoS_ omega, and SNoS_ omega is included in real **)
claim HnSNoS: n :e SNoS_ omega.
{ exact (omega_SNoS_omega n Hn). }
claim HnR: n :e real.
{ exact (SNoS_omega_real n HnSNoS). }
exact (real_recip_SNo n HnR).
Qed.

(** from §13 Exercise 6: the set K={1/n | n in omega and n not 0} used in the K-topology **)
(** LATEX VERSION: Let K={1/n : n in N} as a subset of R (excluding n=0). **)
Definition K_set : set := {inv_nat n|n :e omega :\: {0}}.

(** helper: 0 is not in K_set **)
Theorem zero_not_in_K_set : 0 /:e K_set.
assume H0K: 0 :e K_set.
apply (ReplE (omega :\: {0}) (fun n:set => inv_nat n) 0 H0K).
let n. assume Hnconj.
claim HnIn: n :e omega :\: {0}.
{ exact (andEL (n :e omega :\: {0}) (0 = inv_nat n) Hnconj). }
claim H0eq: 0 = inv_nat n.
{ exact (andER (n :e omega :\: {0}) (0 = inv_nat n) Hnconj). }
claim HnO: n :e omega.
{ exact (setminusE1 omega {0} n HnIn). }
claim Hnnot0: n /:e {0}.
{ exact (setminusE2 omega {0} n HnIn). }
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnO). }
claim HnCase: n = 0 \/ exists k:set, nat_p k /\ n = ordsucc k.
{ exact (nat_inv n HnNat). }
claim Hexk: exists k:set, nat_p k /\ n = ordsucc k.
{ apply (HnCase (exists k:set, nat_p k /\ n = ordsucc k)).
  - assume Hn0: n = 0.
    apply FalseE.
    claim Hnin0: n :e {0}.
    { rewrite Hn0. exact (SingI 0). }
    exact (Hnnot0 Hnin0).
  - assume H. exact H. }
apply Hexk.
let k. assume Hkconj.
claim Hkeq: n = ordsucc k.
{ exact (andER (nat_p k) (n = ordsucc k) Hkconj). }
claim HkNat: nat_p k.
{ exact (andEL (nat_p k) (n = ordsucc k) Hkconj). }
claim HkOrd: ordinal k.
{ exact (nat_p_ordinal k HkNat). }
claim Hpos: 0 < n.
{ rewrite Hkeq.
  exact (ordinal_ordsucc_pos k HkOrd). }
claim HSn: SNo n.
{ exact (omega_SNo n HnO). }
claim Hposcase: inv_nat n = recip_SNo_pos n.
{ exact (recip_SNo_poscase n Hpos). }
claim HrecipPos: 0 < recip_SNo_pos n.
{ exact (recip_SNo_pos_is_pos n HSn Hpos). }
claim HinvPos: 0 < inv_nat n.
{ rewrite Hposcase.
  exact HrecipPos. }
claim H0lt0: 0 < 0.
{ rewrite H0eq at 2.
  exact HinvPos. }
exact ((SNoLt_irref 0) H0lt0).
Qed.

(** helper: K_set is a subset of R **)
Theorem K_set_Subq_R : K_set c= R.
let x. assume Hx: x :e K_set.
apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) x Hx (x :e R)).
let n. assume HnIn: n :e omega :\: {0}. assume Heq: x = inv_nat n.
claim HnO: n :e omega.
{ exact (setminusE1 omega {0} n HnIn). }
rewrite Heq.
exact (inv_nat_real n HnO).
Qed.

(** helper: elements of K_set are positive reals **)
Theorem inv_nat_pos : forall n:set, n :e omega :\: {0} -> Rlt 0 (inv_nat n).
let n. assume HnIn: n :e omega :\: {0}.
claim HnO: n :e omega.
{ exact (setminusE1 omega {0} n HnIn). }
claim Hnnot0: n /:e {0}.
{ exact (setminusE2 omega {0} n HnIn). }
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnO). }
claim HnCase: n = 0 \/ exists k:set, nat_p k /\ n = ordsucc k.
{ exact (nat_inv n HnNat). }
claim Hexk: exists k:set, nat_p k /\ n = ordsucc k.
{ apply (HnCase (exists k:set, nat_p k /\ n = ordsucc k)).
  - assume Hn0: n = 0.
    apply FalseE.
    claim Hnin0: n :e {0}.
    { rewrite Hn0. exact (SingI 0). }
    exact (Hnnot0 Hnin0).
  - assume H. exact H. }
apply Hexk.
let k. assume Hkconj.
claim Hkeq: n = ordsucc k.
{ exact (andER (nat_p k) (n = ordsucc k) Hkconj). }
claim HkNat: nat_p k.
{ exact (andEL (nat_p k) (n = ordsucc k) Hkconj). }
claim HkOrd: ordinal k.
{ exact (nat_p_ordinal k HkNat). }
claim Hpos: 0 < n.
{ rewrite Hkeq.
  exact (ordinal_ordsucc_pos k HkOrd). }
claim HSn: SNo n.
{ exact (omega_SNo n HnO). }
claim Hposcase: inv_nat n = recip_SNo_pos n.
{ exact (recip_SNo_poscase n Hpos). }
claim HrecipPos: 0 < recip_SNo_pos n.
{ exact (recip_SNo_pos_is_pos n HSn Hpos). }
claim HinvPos: 0 < inv_nat n.
{ rewrite Hposcase.
  exact HrecipPos. }
claim HinvR: inv_nat n :e R.
{ exact (inv_nat_real n HnO). }
exact (RltI 0 (inv_nat n) real_0 HinvR HinvPos).
Qed.

  (** from §13 Definition: K-topology basis family on R **)
  (** LATEX VERSION: Let K be {1/n | n in Z_+}; let B'' be all open intervals (a,b) and all sets (a,b)-K. **)
Definition R_K_basis : set :=
  \/_ a :e R, {open_interval a b :\: K_set|b :e R}.

  (** from §13 Definition: K-topology on R **)
  (** LATEX VERSION: The topology generated by B'' is called the K-topology on R, denoted R_K. **)
Definition R_K_topology : set :=
  generated_topology R (R_standard_basis :\/: R_K_basis).

  (** from §13: the described families are bases **)
  (** LATEX VERSION: It is easy to see the three collections are bases; intersections are basis elements or empty. **)
  (** helper: the K topology basis is a basis on R **)
Theorem R_standard_plus_K_basis_is_basis_local : basis_on R (R_standard_basis :\/: R_K_basis).
prove basis_on R (R_standard_basis :\/: R_K_basis).
prove (R_standard_basis :\/: R_K_basis) c= Power R
  /\ (forall x :e R, exists b :e (R_standard_basis :\/: R_K_basis), x :e b)
  /\ (forall b1 :e (R_standard_basis :\/: R_K_basis), forall b2 :e (R_standard_basis :\/: R_K_basis), forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e (R_standard_basis :\/: R_K_basis), x :e b3 /\ b3 c= b1 :/\: b2).
apply and3I.
- (** basis elements are subsets of R **)
    let U. assume HU: U :e (R_standard_basis :\/: R_K_basis).
    apply (binunionE' R_standard_basis R_K_basis U (U :e Power R)).
    - (** U from standard basis **)
      assume HUstd: U :e R_standard_basis.
      claim HUsubR: U c= R.
      { exact (basis_elem_subset R R_standard_basis U R_standard_basis_is_basis_local HUstd). }
      exact (PowerI R U HUsubR).
    - (** U from K basis **)
      assume HUk: U :e R_K_basis.
      claim Hexa : exists a :e R, U :e {open_interval a b :\: K_set|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) U HUk). }
      apply Hexa.
      let a. assume Hapair.
      claim HaR: a :e R.
      { exact (andEL (a :e R) (U :e {open_interval a b :\: K_set|b :e R}) Hapair). }
      claim HUfam: U :e {open_interval a b :\: K_set|b :e R}.
      { exact (andER (a :e R) (U :e {open_interval a b :\: K_set|b :e R}) Hapair). }
      claim Hexb: exists b :e R, U = open_interval a b :\: K_set.
      { exact (ReplE R (fun b0 : set => open_interval a b0 :\: K_set) U HUfam). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbR: b :e R.
      { exact (andEL (b :e R) (U = open_interval a b :\: K_set) Hbpair). }
      claim HUeq: U = open_interval a b :\: K_set.
      { exact (andER (b :e R) (U = open_interval a b :\: K_set) Hbpair). }
      rewrite HUeq.
      claim Hsub1: (open_interval a b :\: K_set) c= open_interval a b.
      { exact (setminus_Subq (open_interval a b) K_set). }
      claim Hsub2: open_interval a b c= R.
      { exact (open_interval_Subq_R a b). }
      exact (PowerI R (open_interval a b :\: K_set) (Subq_tra (open_interval a b :\: K_set) (open_interval a b) R Hsub1 Hsub2)).
    - exact HU.
- (** coverage: inherit from standard basis **)
    let x. assume HxR: x :e R.
    claim Hcov: forall x0 :e R, exists b :e R_standard_basis, x0 :e b.
    { exact (andER (R_standard_basis c= Power R)
                   (forall x0 :e R, exists b :e R_standard_basis, x0 :e b)
                   (andEL (R_standard_basis c= Power R /\
                           (forall x0 :e R, exists b :e R_standard_basis, x0 :e b))
                          (forall b1 :e R_standard_basis, forall b2 :e R_standard_basis, forall x0:set,
                            x0 :e b1 -> x0 :e b2 ->
                            exists b3 :e R_standard_basis, x0 :e b3 /\ b3 c= b1 :/\: b2)
                          R_standard_basis_is_basis_local)). }
    claim Hex: exists b :e R_standard_basis, x :e b.
    { exact (Hcov x HxR). }
    apply Hex.
    let b. assume Hbpair.
    witness b.
    apply andI.
    * exact (binunionI1 R_standard_basis R_K_basis b (andEL (b :e R_standard_basis) (x :e b) Hbpair)).
    * exact (andER (b :e R_standard_basis) (x :e b) Hbpair).
- (** intersection refinement **)
  let b1. assume Hb1.
  let b2. assume Hb2.
  let x. assume Hx1 Hx2.
  prove exists b3 :e (R_standard_basis :\/: R_K_basis), x :e b3 /\ b3 c= b1 :/\: b2.
  claim HstdInt:
    forall u1 :e R_standard_basis, forall u2 :e R_standard_basis, forall x0:set,
      x0 :e u1 -> x0 :e u2 ->
      exists u3 :e R_standard_basis, x0 :e u3 /\ u3 c= u1 :/\: u2.
  { exact (andER (R_standard_basis c= Power R /\ (forall x0 :e R, exists b :e R_standard_basis, x0 :e b))
                 (forall u1 :e R_standard_basis, forall u2 :e R_standard_basis, forall x0:set,
                   x0 :e u1 -> x0 :e u2 ->
                   exists u3 :e R_standard_basis, x0 :e u3 /\ u3 c= u1 :/\: u2)
                 R_standard_basis_is_basis_local). }
  apply (binunionE' R_standard_basis R_K_basis b1 (exists b3 :e (R_standard_basis :\/: R_K_basis), x :e b3 /\ b3 c= b1 :/\: b2)).
  - assume Hb1Std: b1 :e R_standard_basis.
    apply (binunionE' R_standard_basis R_K_basis b2 (exists b3 :e (R_standard_basis :\/: R_K_basis), x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb2Std: b2 :e R_standard_basis.
      apply (HstdInt b1 Hb1Std b2 Hb2Std x Hx1 Hx2).
      let b3std. assume Hb3pair.
      witness b3std.
      apply andI.
      * exact (binunionI1 R_standard_basis R_K_basis b3std (andEL (b3std :e R_standard_basis) (x :e b3std /\ b3std c= b1 :/\: b2) Hb3pair)).
      * exact (andER (b3std :e R_standard_basis) (x :e b3std /\ b3std c= b1 :/\: b2) Hb3pair).
    + assume Hb2K: b2 :e R_K_basis.
      (** destruct b2 = open_interval a2 bb2 \\ K_set **)
      claim Hexa2 : exists a2 :e R, b2 :e {open_interval a2 b :\: K_set|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) b2 Hb2K). }
      apply Hexa2.
      let a2. assume Ha2pair.
      claim Ha2R : a2 :e R.
      { exact (andEL (a2 :e R) (b2 :e {open_interval a2 b :\: K_set|b :e R}) Ha2pair). }
      claim Hb2fam : b2 :e {open_interval a2 b :\: K_set|b :e R}.
      { exact (andER (a2 :e R) (b2 :e {open_interval a2 b :\: K_set|b :e R}) Ha2pair). }
      claim Hexb2 : exists bb2 :e R, b2 = open_interval a2 bb2 :\: K_set.
      { exact (ReplE R (fun bb : set => open_interval a2 bb :\: K_set) b2 Hb2fam). }
      apply Hexb2.
      let bb2. assume Hbb2pair.
      claim Hbb2R : bb2 :e R.
      { exact (andEL (bb2 :e R) (b2 = open_interval a2 bb2 :\: K_set) Hbb2pair). }
      claim Hb2eq : b2 = open_interval a2 bb2 :\: K_set.
      { exact (andER (bb2 :e R) (b2 = open_interval a2 bb2 :\: K_set) Hbb2pair). }
      set I2 := open_interval a2 bb2.
      claim HI2Std: I2 :e R_standard_basis.
      { claim HI2fam : I2 :e {open_interval a2 b|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval a2 b0) bb2 Hbb2R). }
        exact (famunionI R (fun a0 : set => {open_interval a0 b|b :e R}) a2 I2 Ha2R HI2fam). }
      claim HxInB2: x :e I2 :\: K_set.
      { rewrite <- Hb2eq.
        exact Hx2. }
      claim HxInI2: x :e I2.
      { exact (setminusE1 I2 K_set x HxInB2). }
      claim HxNotK: x /:e K_set.
      { exact (setminusE2 I2 K_set x HxInB2). }
      apply (HstdInt b1 Hb1Std I2 HI2Std x Hx1 HxInI2).
      let I0. assume HI0pair.
      claim HI0Std: I0 :e R_standard_basis.
      { exact (andEL (I0 :e R_standard_basis) (x :e I0 /\ I0 c= b1 :/\: I2) HI0pair). }
      claim HI0rest: x :e I0 /\ I0 c= b1 :/\: I2.
      { exact (andER (I0 :e R_standard_basis) (x :e I0 /\ I0 c= b1 :/\: I2) HI0pair). }
      claim HxI0: x :e I0.
      { exact (andEL (x :e I0) (I0 c= b1 :/\: I2) HI0rest). }
      claim HI0sub: I0 c= b1 :/\: I2.
      { exact (andER (x :e I0) (I0 c= b1 :/\: I2) HI0rest). }
      (** destruct I0 = open_interval c d **)
      claim Hexc : exists c :e R, I0 :e {open_interval c b|b :e R}.
      { exact (famunionE R (fun c0 : set => {open_interval c0 b|b :e R}) I0 HI0Std). }
      apply Hexc.
      let c. assume Hcpair.
      claim HcR: c :e R.
      { exact (andEL (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim HI0fam: I0 :e {open_interval c b|b :e R}.
      { exact (andER (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim Hexd : exists d :e R, I0 = open_interval c d.
      { exact (ReplE R (fun d0 : set => open_interval c d0) I0 HI0fam). }
      apply Hexd.
      let d. assume Hdpair.
      claim HdR: d :e R.
      { exact (andEL (d :e R) (I0 = open_interval c d) Hdpair). }
      claim HI0eq: I0 = open_interval c d.
      { exact (andER (d :e R) (I0 = open_interval c d) Hdpair). }
      set Kint := open_interval c d :\: K_set.
      witness Kint.
      apply andI.
      * (** Kint is in the union basis via the K basis **)
        claim HKfam : Kint :e {open_interval c b :\: K_set|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval c b0 :\: K_set) d HdR). }
        claim HKinK : Kint :e R_K_basis.
        { exact (famunionI R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) c Kint HcR HKfam). }
        exact (binunionI2 R_standard_basis R_K_basis Kint HKinK).
      * apply andI.
        { (** x in Kint **)
          prove x :e open_interval c d :\: K_set.
          apply setminusI.
          - prove x :e open_interval c d.
            rewrite <- HI0eq.
            exact HxI0.
          - exact HxNotK. }
        { (** subset property **)
          let y. assume Hy: y :e Kint.
          prove y :e b1 :/\: b2.
          claim HyOpen: y :e open_interval c d.
          { exact (setminusE1 (open_interval c d) K_set y Hy). }
          claim HyI0: y :e I0.
          { rewrite HI0eq.
            exact HyOpen. }
          claim HyNotK: y /:e K_set.
          { exact (setminusE2 (open_interval c d) K_set y Hy). }
          claim Hyb1I2: y :e b1 :/\: I2.
          { exact (HI0sub y HyI0). }
          claim Hyb1: y :e b1.
          { exact (binintersectE1 b1 I2 y Hyb1I2). }
          claim HyI2: y :e I2.
          { exact (binintersectE2 b1 I2 y Hyb1I2). }
          claim Hyb2: y :e b2.
          { rewrite Hb2eq.
            exact (setminusI I2 K_set y HyI2 HyNotK). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + exact Hb2.
  - assume Hb1K: b1 :e R_K_basis.
    apply (binunionE' R_standard_basis R_K_basis b2 (exists b3 :e (R_standard_basis :\/: R_K_basis), x :e b3 /\ b3 c= b1 :/\: b2)).
    + assume Hb2Std: b2 :e R_standard_basis.
      (** symmetric to the previous mixed case **)
      claim Hexa1 : exists a1 :e R, b1 :e {open_interval a1 b :\: K_set|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) b1 Hb1K). }
      apply Hexa1.
      let a1. assume Ha1pair.
      claim Ha1R : a1 :e R.
      { exact (andEL (a1 :e R) (b1 :e {open_interval a1 b :\: K_set|b :e R}) Ha1pair). }
      claim Hb1fam : b1 :e {open_interval a1 b :\: K_set|b :e R}.
      { exact (andER (a1 :e R) (b1 :e {open_interval a1 b :\: K_set|b :e R}) Ha1pair). }
      claim Hexb1 : exists bb1 :e R, b1 = open_interval a1 bb1 :\: K_set.
      { exact (ReplE R (fun bb : set => open_interval a1 bb :\: K_set) b1 Hb1fam). }
      apply Hexb1.
      let bb1. assume Hbb1pair.
      claim Hbb1R : bb1 :e R.
      { exact (andEL (bb1 :e R) (b1 = open_interval a1 bb1 :\: K_set) Hbb1pair). }
      claim Hb1eq : b1 = open_interval a1 bb1 :\: K_set.
      { exact (andER (bb1 :e R) (b1 = open_interval a1 bb1 :\: K_set) Hbb1pair). }
      set I1 := open_interval a1 bb1.
      claim HI1Std: I1 :e R_standard_basis.
      { claim HI1fam : I1 :e {open_interval a1 b|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval a1 b0) bb1 Hbb1R). }
        exact (famunionI R (fun a0 : set => {open_interval a0 b|b :e R}) a1 I1 Ha1R HI1fam). }
      claim HxInB1: x :e I1 :\: K_set.
      { rewrite <- Hb1eq.
        exact Hx1. }
      claim HxInI1: x :e I1.
      { exact (setminusE1 I1 K_set x HxInB1). }
      claim HxNotK: x /:e K_set.
      { exact (setminusE2 I1 K_set x HxInB1). }
      apply (HstdInt I1 HI1Std b2 Hb2Std x HxInI1 Hx2).
      let I0. assume HI0pair.
      claim HI0Std: I0 :e R_standard_basis.
      { exact (andEL (I0 :e R_standard_basis) (x :e I0 /\ I0 c= I1 :/\: b2) HI0pair). }
      claim HI0rest: x :e I0 /\ I0 c= I1 :/\: b2.
      { exact (andER (I0 :e R_standard_basis) (x :e I0 /\ I0 c= I1 :/\: b2) HI0pair). }
      claim HxI0: x :e I0.
      { exact (andEL (x :e I0) (I0 c= I1 :/\: b2) HI0rest). }
      claim HI0sub: I0 c= I1 :/\: b2.
      { exact (andER (x :e I0) (I0 c= I1 :/\: b2) HI0rest). }
      claim Hexc : exists c :e R, I0 :e {open_interval c b|b :e R}.
      { exact (famunionE R (fun c0 : set => {open_interval c0 b|b :e R}) I0 HI0Std). }
      apply Hexc.
      let c. assume Hcpair.
      claim HcR: c :e R.
      { exact (andEL (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim HI0fam: I0 :e {open_interval c b|b :e R}.
      { exact (andER (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim Hexd : exists d :e R, I0 = open_interval c d.
      { exact (ReplE R (fun d0 : set => open_interval c d0) I0 HI0fam). }
      apply Hexd.
      let d. assume Hdpair.
      claim HdR: d :e R.
      { exact (andEL (d :e R) (I0 = open_interval c d) Hdpair). }
      claim HI0eq: I0 = open_interval c d.
      { exact (andER (d :e R) (I0 = open_interval c d) Hdpair). }
      set Kint := open_interval c d :\: K_set.
      witness Kint.
      apply andI.
      * claim HKfam : Kint :e {open_interval c b :\: K_set|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval c b0 :\: K_set) d HdR). }
        claim HKinK : Kint :e R_K_basis.
        { exact (famunionI R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) c Kint HcR HKfam). }
        exact (binunionI2 R_standard_basis R_K_basis Kint HKinK).
      * apply andI.
        { prove x :e open_interval c d :\: K_set.
          apply setminusI.
          - prove x :e open_interval c d.
            rewrite <- HI0eq.
            exact HxI0.
          - exact HxNotK. }
        { let y. assume Hy: y :e Kint.
          prove y :e b1 :/\: b2.
          claim HyOpen: y :e open_interval c d.
          { exact (setminusE1 (open_interval c d) K_set y Hy). }
          claim HyI0: y :e I0.
          { rewrite HI0eq.
            exact HyOpen. }
          claim HyNotK: y /:e K_set.
          { exact (setminusE2 (open_interval c d) K_set y Hy). }
          claim HyI1b2: y :e I1 :/\: b2.
          { exact (HI0sub y HyI0). }
          claim HyI1: y :e I1.
          { exact (binintersectE1 I1 b2 y HyI1b2). }
          claim Hyb2: y :e b2.
          { exact (binintersectE2 I1 b2 y HyI1b2). }
          claim Hyb1: y :e b1.
          { rewrite Hb1eq.
            exact (setminusI I1 K_set y HyI1 HyNotK). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + assume Hb2K: b2 :e R_K_basis.
      (** both K basis elements; refine using their open-interval parts **)
      claim Hexa1 : exists a1 :e R, b1 :e {open_interval a1 b :\: K_set|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) b1 Hb1K). }
      claim Hexa2 : exists a2 :e R, b2 :e {open_interval a2 b :\: K_set|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) b2 Hb2K). }
      apply Hexa1.
      let a1. assume Ha1pair.
      claim Ha1R : a1 :e R.
      { exact (andEL (a1 :e R) (b1 :e {open_interval a1 b :\: K_set|b :e R}) Ha1pair). }
      claim Hb1fam : b1 :e {open_interval a1 b :\: K_set|b :e R}.
      { exact (andER (a1 :e R) (b1 :e {open_interval a1 b :\: K_set|b :e R}) Ha1pair). }
      claim Hexb1 : exists bb1 :e R, b1 = open_interval a1 bb1 :\: K_set.
      { exact (ReplE R (fun bb : set => open_interval a1 bb :\: K_set) b1 Hb1fam). }
      apply Hexb1.
      let bb1. assume Hbb1pair.
      claim Hbb1R : bb1 :e R.
      { exact (andEL (bb1 :e R) (b1 = open_interval a1 bb1 :\: K_set) Hbb1pair). }
      claim Hb1eq : b1 = open_interval a1 bb1 :\: K_set.
      { exact (andER (bb1 :e R) (b1 = open_interval a1 bb1 :\: K_set) Hbb1pair). }
      apply Hexa2.
      let a2. assume Ha2pair.
      claim Ha2R : a2 :e R.
      { exact (andEL (a2 :e R) (b2 :e {open_interval a2 b :\: K_set|b :e R}) Ha2pair). }
      claim Hb2fam : b2 :e {open_interval a2 b :\: K_set|b :e R}.
      { exact (andER (a2 :e R) (b2 :e {open_interval a2 b :\: K_set|b :e R}) Ha2pair). }
      claim Hexb2 : exists bb2 :e R, b2 = open_interval a2 bb2 :\: K_set.
      { exact (ReplE R (fun bb : set => open_interval a2 bb :\: K_set) b2 Hb2fam). }
      apply Hexb2.
      let bb2. assume Hbb2pair.
      claim Hbb2R : bb2 :e R.
      { exact (andEL (bb2 :e R) (b2 = open_interval a2 bb2 :\: K_set) Hbb2pair). }
      claim Hb2eq : b2 = open_interval a2 bb2 :\: K_set.
      { exact (andER (bb2 :e R) (b2 = open_interval a2 bb2 :\: K_set) Hbb2pair). }
      set I1 := open_interval a1 bb1.
      set I2 := open_interval a2 bb2.
      claim HI1Std: I1 :e R_standard_basis.
      { claim HI1fam : I1 :e {open_interval a1 b|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval a1 b0) bb1 Hbb1R). }
        exact (famunionI R (fun a0 : set => {open_interval a0 b|b :e R}) a1 I1 Ha1R HI1fam). }
      claim HI2Std: I2 :e R_standard_basis.
      { claim HI2fam : I2 :e {open_interval a2 b|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval a2 b0) bb2 Hbb2R). }
        exact (famunionI R (fun a0 : set => {open_interval a0 b|b :e R}) a2 I2 Ha2R HI2fam). }
      claim HxInB1: x :e I1 :\: K_set.
      { rewrite <- Hb1eq.
        exact Hx1. }
      claim HxInB2: x :e I2 :\: K_set.
      { rewrite <- Hb2eq.
        exact Hx2. }
      claim HxInI1: x :e I1.
      { exact (setminusE1 I1 K_set x HxInB1). }
      claim HxInI2: x :e I2.
      { exact (setminusE1 I2 K_set x HxInB2). }
      claim HxNotK: x /:e K_set.
      { exact (setminusE2 I1 K_set x HxInB1). }
      apply (HstdInt I1 HI1Std I2 HI2Std x HxInI1 HxInI2).
      let I0. assume HI0pair.
      claim HI0Std: I0 :e R_standard_basis.
      { exact (andEL (I0 :e R_standard_basis) (x :e I0 /\ I0 c= I1 :/\: I2) HI0pair). }
      claim HI0rest: x :e I0 /\ I0 c= I1 :/\: I2.
      { exact (andER (I0 :e R_standard_basis) (x :e I0 /\ I0 c= I1 :/\: I2) HI0pair). }
      claim HxI0: x :e I0.
      { exact (andEL (x :e I0) (I0 c= I1 :/\: I2) HI0rest). }
      claim HI0sub: I0 c= I1 :/\: I2.
      { exact (andER (x :e I0) (I0 c= I1 :/\: I2) HI0rest). }
      claim Hexc : exists c :e R, I0 :e {open_interval c b|b :e R}.
      { exact (famunionE R (fun c0 : set => {open_interval c0 b|b :e R}) I0 HI0Std). }
      apply Hexc.
      let c. assume Hcpair.
      claim HcR: c :e R.
      { exact (andEL (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim HI0fam: I0 :e {open_interval c b|b :e R}.
      { exact (andER (c :e R) (I0 :e {open_interval c b|b :e R}) Hcpair). }
      claim Hexd : exists d :e R, I0 = open_interval c d.
      { exact (ReplE R (fun d0 : set => open_interval c d0) I0 HI0fam). }
      apply Hexd.
      let d. assume Hdpair.
      claim HdR: d :e R.
      { exact (andEL (d :e R) (I0 = open_interval c d) Hdpair). }
      claim HI0eq: I0 = open_interval c d.
      { exact (andER (d :e R) (I0 = open_interval c d) Hdpair). }
      set Kint := open_interval c d :\: K_set.
      witness Kint.
      apply andI.
      * claim HKfam : Kint :e {open_interval c b :\: K_set|b :e R}.
        { exact (ReplI R (fun b0 : set => open_interval c b0 :\: K_set) d HdR). }
        claim HKinK : Kint :e R_K_basis.
        { exact (famunionI R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) c Kint HcR HKfam). }
        exact (binunionI2 R_standard_basis R_K_basis Kint HKinK).
      * apply andI.
        { prove x :e open_interval c d :\: K_set.
          apply setminusI.
          - prove x :e open_interval c d.
            rewrite <- HI0eq.
            exact HxI0.
          - exact HxNotK. }
        { let y. assume Hy: y :e Kint.
          prove y :e b1 :/\: b2.
          claim HyOpen: y :e open_interval c d.
          { exact (setminusE1 (open_interval c d) K_set y Hy). }
          claim HyI0: y :e I0.
          { rewrite HI0eq.
            exact HyOpen. }
          claim HyNotK: y /:e K_set.
          { exact (setminusE2 (open_interval c d) K_set y Hy). }
          claim HyI1I2: y :e I1 :/\: I2.
          { exact (HI0sub y HyI0). }
          claim HyI1: y :e I1.
          { exact (binintersectE1 I1 I2 y HyI1I2). }
          claim HyI2: y :e I2.
          { exact (binintersectE2 I1 I2 y HyI1I2). }
          claim Hyb1: y :e b1.
          { rewrite Hb1eq.
            exact (setminusI I1 K_set y HyI1 HyNotK). }
          claim Hyb2: y :e b2.
          { rewrite Hb2eq.
            exact (setminusI I2 K_set y HyI2 HyNotK). }
          exact (binintersectI b1 b2 y Hyb1 Hyb2). }
    + exact Hb2.
  - exact Hb1.
Qed.

(** helper: the K topology on R is a topology **)
Theorem R_K_topology_is_topology_local : topology_on R R_K_topology.
exact (lemma_topology_from_basis R (R_standard_basis :\/: R_K_basis) R_standard_plus_K_basis_is_basis_local).
Qed.

(** helper: K_set meets any lower limit neighborhood of 0 **)
(** LATEX VERSION: In the lower limit topology, every basic neighborhood [a,b) of 0 contains some element of K={1/n}. **)
Theorem K_set_meets_lower_limit_neighborhood_0 :
  forall a b:set,
    a :e R -> b :e R ->
    ~(Rlt 0 a) ->
    Rlt 0 b ->
    exists y:set, y :e halfopen_interval_left a b /\ y :e K_set.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Hnot0a: ~(Rlt 0 a).
assume H0b: Rlt 0 b.
set r := recip_SNo b.
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim H0ltb: 0 < b.
{ exact (RltE_lt 0 b H0b). }
claim Hbne0: b <> 0.
{ assume Hb0: b = 0.
  claim H00: 0 < 0.
  { rewrite <- Hb0 at 2.
    exact H0ltb. }
  exact ((SNoLt_irref 0) H00). }
claim HrS: SNo r.
{ exact (SNo_recip_SNo b HbS). }
claim HrR: r :e R.
{ exact (real_recip_SNo b HbR). }
claim Hrpos: 0 < r.
{ exact (recip_SNo_of_pos_is_pos b HbS H0ltb). }
claim Hrnonneg: 0 <= r.
{ exact (SNoLtLe 0 r Hrpos). }
claim Hexn: exists n :e omega, n <= r /\ r < ordsucc n.
{ exact (nonneg_real_nat_interval r HrR Hrnonneg). }
apply Hexn.
let n.
assume Hnpair: n :e omega /\ (n <= r /\ r < ordsucc n).
claim HnOmega: n :e omega.
{ exact (andEL (n :e omega) (n <= r /\ r < ordsucc n) Hnpair). }
claim Hnrest: n <= r /\ r < ordsucc n.
{ exact (andER (n :e omega) (n <= r /\ r < ordsucc n) Hnpair). }
claim HrltN: r < ordsucc n.
{ exact (andER (n <= r) (r < ordsucc n) Hnrest). }
set N := ordsucc n.
claim HNOmega: N :e omega.
{ exact (omega_ordsucc n HnOmega). }
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnOmega). }
claim HnOrd: ordinal n.
{ exact (nat_p_ordinal n HnNat). }
claim H0ltN: 0 < N.
{ exact (ordinal_ordsucc_pos n HnOrd). }
claim HNS: SNo N.
{ exact (omega_SNo N HNOmega). }
claim Hineq: mul_SNo b r < mul_SNo b N.
{ exact (pos_mul_SNo_Lt b r N HbS H0ltb HrS HNS HrltN). }
claim Hbr1: mul_SNo b r = 1.
{ exact (recip_SNo_invR b HbS Hbne0). }
claim H1ltbN: 1 < mul_SNo b N.
{ rewrite <- Hbr1.
  exact Hineq. }
claim HinvLt: div_SNo 1 N < b.
{ exact (div_SNo_pos_LtL 1 N b SNo_1 HNS (real_SNo b HbR) H0ltN H1ltbN). }
claim HinvEq: div_SNo 1 N = inv_nat N.
{ prove div_SNo 1 N = inv_nat N.
  claim Hdivdef: div_SNo 1 N = mul_SNo 1 (recip_SNo N).
  { reflexivity. }
  claim Hinvdef: inv_nat N = recip_SNo N.
  { reflexivity. }
  rewrite Hdivdef.
  rewrite Hinvdef at 2.
  rewrite (mul_SNo_oneL (recip_SNo N) (SNo_recip_SNo N HNS)).
  reflexivity. }
claim Hyltb: inv_nat N < b.
{ rewrite <- HinvEq.
  exact HinvLt. }
claim HyR: inv_nat N :e R.
{ exact (inv_nat_real N HNOmega). }
claim HyRltb: Rlt (inv_nat N) b.
{ exact (RltI (inv_nat N) b HyR HbR Hyltb). }
claim HNnot0: N /:e {0}.
{ assume HNin: N :e {0}.
  claim HNeq0: N = 0.
  { exact (SingE 0 N HNin). }
  claim H00: 0 < 0.
  { rewrite <- HNeq0 at 2.
    exact H0ltN. }
  exact ((SNoLt_irref 0) H00). }
claim HNinSetminus: N :e omega :\: {0}.
{ apply setminusI.
  - exact HNOmega.
  - exact HNnot0. }
claim HyK: inv_nat N :e K_set.
{ exact (ReplI (omega :\: {0}) (fun m:set => inv_nat m) N HNinSetminus). }
claim Hypos: Rlt 0 (inv_nat N).
{ exact (inv_nat_pos N HNinSetminus). }
claim HnotHyLta: ~(Rlt (inv_nat N) a).
{ assume Hylta: Rlt (inv_nat N) a.
  claim H0lta: Rlt 0 a.
  { exact (Rlt_tra 0 (inv_nat N) a Hypos Hylta). }
  exact (Hnot0a H0lta). }
witness (inv_nat N).
apply andI.
- prove inv_nat N :e halfopen_interval_left a b.
  exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) (inv_nat N) HyR
          (andI (~(Rlt (inv_nat N) a)) (Rlt (inv_nat N) b) HnotHyLta HyRltb)).
- exact HyK.
Qed.

(** LATEX VERSION: Exercise 6: The lower-limit topology and the K-topology on ℝ are incomparable. **)
Theorem ex13_6_Rl_RK_not_comparable :
  ~finer_than R_lower_limit_topology R_K_topology /\
  ~finer_than R_K_topology R_lower_limit_topology.
prove ~finer_than R_lower_limit_topology R_K_topology /\ ~finer_than R_K_topology R_lower_limit_topology.
apply andI.
- (** not finer_than R_lower_limit_topology R_K_topology **)
  assume Hf: finer_than R_lower_limit_topology R_K_topology.
  prove False.
  set U := open_interval (minus_SNo 1) 1 :\: K_set.
  claim HUm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim HU1R: 1 :e R.
  { exact real_1. }
  claim HUinKbasis: U :e R_K_basis.
  { prove U :e R_K_basis.
    apply (famunionI R (fun a0:set => {open_interval a0 b :\: K_set|b :e R})
             (minus_SNo 1) U HUm1R).
    claim HUfam: U :e {open_interval (minus_SNo 1) b :\: K_set|b :e R}.
    { exact (ReplI R (fun b0:set => open_interval (minus_SNo 1) b0 :\: K_set) 1 HU1R). }
    exact HUfam. }
  claim HUinB: U :e (R_standard_basis :\/: R_K_basis).
  { exact (binunionI2 R_standard_basis R_K_basis U HUinKbasis). }
  claim HUinKtop: U :e R_K_topology.
  { exact (basis_in_generated R (R_standard_basis :\/: R_K_basis) U
            R_standard_plus_K_basis_is_basis_local HUinB). }
  claim HUinLower: U :e R_lower_limit_topology.
  { exact (Hf U HUinKtop). }
  claim H0inU: 0 :e U.
  { prove 0 :e U.
    apply setminusI.
    - prove 0 :e open_interval (minus_SNo 1) 1.
      claim Hm10: Rlt (minus_SNo 1) 0.
      { apply RltI.
        - exact HUm1R.
        - exact real_0.
        - exact minus_1_lt_0. }
      claim H01: Rlt 0 1.
      { exact Rlt_0_1. }
      claim H0prop: Rlt (minus_SNo 1) 0 /\ Rlt 0 1.
      { exact (andI (Rlt (minus_SNo 1) 0) (Rlt 0 1) Hm10 H01). }
      exact (SepI R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) 0 real_0 H0prop).
    - exact zero_not_in_K_set. }
  claim HUcond: forall x :e U, exists b :e R_lower_limit_basis, x :e b /\ b c= U.
  { exact (SepE2 (Power R)
            (fun U0:set => forall x0 :e U0, exists b0 :e R_lower_limit_basis, x0 :e b0 /\ b0 c= U0)
            U HUinLower). }
  claim Hexb0: exists b0 :e R_lower_limit_basis, 0 :e b0 /\ b0 c= U.
  { exact (HUcond 0 H0inU). }
  apply Hexb0.
  let b0. assume Hb0pair: b0 :e R_lower_limit_basis /\ (0 :e b0 /\ b0 c= U).
  claim Hb0inB: b0 :e R_lower_limit_basis.
  { exact (andEL (b0 :e R_lower_limit_basis) (0 :e b0 /\ b0 c= U) Hb0pair). }
  claim Hb0rest: 0 :e b0 /\ b0 c= U.
  { exact (andER (b0 :e R_lower_limit_basis) (0 :e b0 /\ b0 c= U) Hb0pair). }
  claim H0inb0: 0 :e b0.
  { exact (andEL (0 :e b0) (b0 c= U) Hb0rest). }
  claim Hb0subU: b0 c= U.
  { exact (andER (0 :e b0) (b0 c= U) Hb0rest). }
  claim Hexa0: exists a0 :e R, b0 :e {halfopen_interval_left a0 b|b :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) b0 Hb0inB). }
  apply Hexa0.
  let a0. assume Ha0pair: a0 :e R /\ b0 :e {halfopen_interval_left a0 b|b :e R}.
  claim Ha0R: a0 :e R.
  { exact (andEL (a0 :e R) (b0 :e {halfopen_interval_left a0 b|b :e R}) Ha0pair). }
  claim Hb0fam: b0 :e {halfopen_interval_left a0 b|b :e R}.
  { exact (andER (a0 :e R) (b0 :e {halfopen_interval_left a0 b|b :e R}) Ha0pair). }
  claim Hexb1: exists b1 :e R, b0 = halfopen_interval_left a0 b1.
  { exact (ReplE R (fun b1:set => halfopen_interval_left a0 b1) b0 Hb0fam). }
  apply Hexb1.
  let b1. assume Hb1pair: b1 :e R /\ b0 = halfopen_interval_left a0 b1.
  claim Hb1R: b1 :e R.
  { exact (andEL (b1 :e R) (b0 = halfopen_interval_left a0 b1) Hb1pair). }
  claim Hb0eq: b0 = halfopen_interval_left a0 b1.
  { exact (andER (b1 :e R) (b0 = halfopen_interval_left a0 b1) Hb1pair). }
  claim H0inHalf: 0 :e halfopen_interval_left a0 b1.
  { rewrite <- Hb0eq. exact H0inb0. }
  claim H0prop: ~(Rlt 0 a0) /\ Rlt 0 b1.
  { exact (SepE2 R (fun x0:set => ~(Rlt x0 a0) /\ Rlt x0 b1) 0 H0inHalf). }
  claim Hnot0lta0: ~(Rlt 0 a0).
  { exact (andEL (~(Rlt 0 a0)) (Rlt 0 b1) H0prop). }
  claim H0ltb1: Rlt 0 b1.
  { exact (andER (~(Rlt 0 a0)) (Rlt 0 b1) H0prop). }
  claim Hexy: exists y:set, y :e b0 /\ y :e K_set.
  { claim Hexy2: exists y:set, y :e halfopen_interval_left a0 b1 /\ y :e K_set.
    { exact (K_set_meets_lower_limit_neighborhood_0 a0 b1 Ha0R Hb1R Hnot0lta0 H0ltb1). }
    apply Hexy2.
    let y. assume Hyconj2: y :e halfopen_interval_left a0 b1 /\ y :e K_set.
    witness y.
    apply andI.
    - prove y :e b0.
      rewrite Hb0eq.
      exact (andEL (y :e halfopen_interval_left a0 b1) (y :e K_set) Hyconj2).
    - exact (andER (y :e halfopen_interval_left a0 b1) (y :e K_set) Hyconj2). }
  apply Hexy.
  let y. assume Hyconj: y :e b0 /\ y :e K_set.
  claim Hyb0: y :e b0.
  { exact (andEL (y :e b0) (y :e K_set) Hyconj). }
  claim HyK: y :e K_set.
  { exact (andER (y :e b0) (y :e K_set) Hyconj). }
  claim HyinU: y :e U.
  { exact (Hb0subU y Hyb0). }
  claim HynotK: y /:e K_set.
  { exact (setminusE2 (open_interval (minus_SNo 1) 1) K_set y HyinU). }
  exact (HynotK HyK).
- (** not finer_than R_K_topology R_lower_limit_topology **)
  assume Hf: finer_than R_K_topology R_lower_limit_topology.
  prove False.
  set U0 := halfopen_interval_left 0 1.
  claim HU0Lower: U0 :e R_lower_limit_topology.
  { prove U0 :e R_lower_limit_topology.
    (** R_lower_limit_topology = generated_topology R R_lower_limit_basis **)
    prove U0 :e generated_topology R R_lower_limit_basis.
    claim HU0Pow: U0 :e Power R.
    { exact (PowerI R U0 (halfopen_interval_left_Subq_R 0 1)). }
    claim HU0Prop: forall x :e U0, exists b0 :e R_lower_limit_basis, x :e b0 /\ b0 c= U0.
    { let x. assume HxU0: x :e U0.
      claim HxR: x :e R.
      { exact (SepE1 R (fun x0:set => ~(Rlt x0 0) /\ Rlt x0 1) x HxU0). }
      claim HxProp: ~(Rlt x 0) /\ Rlt x 1.
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ Rlt x0 1) x HxU0). }
      claim Hxlt1: Rlt x 1.
      { exact (andER (~(Rlt x 0)) (Rlt x 1) HxProp). }
      set bx := halfopen_interval_left x 1.
      witness bx.
      apply andI.
      - (** bx in the lower limit basis **)
        prove bx :e R_lower_limit_basis.
        apply (famunionI R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) x bx HxR).
        exact (ReplI R (fun b0:set => halfopen_interval_left x b0) 1 real_1).
      - apply andI.
        + (** x in bx **)
          prove x :e bx.
          claim Hnotxx: ~(Rlt x x).
          { exact (not_Rlt_refl x HxR). }
          claim Hxpropbx: ~(Rlt x x) /\ Rlt x 1.
          { exact (andI (~(Rlt x x)) (Rlt x 1) Hnotxx Hxlt1). }
          exact (SepI R (fun t:set => ~(Rlt t x) /\ Rlt t 1) x HxR Hxpropbx).
        + (** bx subset U0 **)
          prove bx c= U0.
          let y. assume Hybx: y :e bx.
          claim HyR: y :e R.
          { exact (SepE1 R (fun t:set => ~(Rlt t x) /\ Rlt t 1) y Hybx). }
          claim HyProp: ~(Rlt y x) /\ Rlt y 1.
          { exact (SepE2 R (fun t:set => ~(Rlt t x) /\ Rlt t 1) y Hybx). }
          claim Hylt1: Rlt y 1.
          { exact (andER (~(Rlt y x)) (Rlt y 1) HyProp). }
          claim Hnotyltx: ~(Rlt y x).
          { exact (andEL (~(Rlt y x)) (Rlt y 1) HyProp). }
          claim Hnotxlt0: ~(x < 0).
          { assume Hxlt0: x < 0.
            claim HxRlt0: Rlt x 0.
            { exact (RltI x 0 HxR real_0 Hxlt0). }
            exact ((andEL (~(Rlt x 0)) (Rlt x 1) HxProp) HxRlt0). }
          claim HxS: SNo x.
          { exact (real_SNo x HxR). }
          claim H0S: SNo 0.
          { exact SNo_0. }
          claim HxLe0or: x < 0 \/ 0 <= x.
          { exact (SNoLtLe_or x 0 HxS H0S). }
          claim H0Lex: 0 <= x.
          { apply (HxLe0or (0 <= x)).
            - assume Hxlt0: x < 0.
              apply FalseE.
              exact (Hnotxlt0 Hxlt0).
            - assume H. exact H. }
          claim Hnotylt0: ~(Rlt y 0).
          { assume Hylt0: Rlt y 0.
            claim Hylt0lt: y < 0.
            { exact (RltE_lt y 0 Hylt0). }
            claim HyS: SNo y.
            { exact (real_SNo y HyR). }
            claim Hyltx: y < x.
            { exact (SNoLtLe_tra y 0 x HyS H0S HxS Hylt0lt H0Lex). }
            claim HyRltx: Rlt y x.
            { exact (RltI y x HyR HxR Hyltx). }
            exact (Hnotyltx HyRltx). }
          claim HyPropU0: ~(Rlt y 0) /\ Rlt y 1.
          { exact (andI (~(Rlt y 0)) (Rlt y 1) Hnotylt0 Hylt1). }
          exact (SepI R (fun z:set => ~(Rlt z 0) /\ Rlt z 1) y HyR HyPropU0). }
    exact (SepI (Power R)
                (fun U:set => forall x :e U, exists b0 :e R_lower_limit_basis, x :e b0 /\ b0 c= U)
                U0
                HU0Pow
                HU0Prop). }
  claim HU0K: U0 :e R_K_topology.
  { exact (Hf U0 HU0Lower). }
  claim H0inU0: 0 :e U0.
  { prove 0 :e U0.
    claim Hnot00: ~(Rlt 0 0).
    { exact (not_Rlt_refl 0 real_0). }
    claim H0prop: ~(Rlt 0 0) /\ Rlt 0 1.
    { exact (andI (~(Rlt 0 0)) (Rlt 0 1) Hnot00 Rlt_0_1). }
    exact (SepI R (fun z:set => ~(Rlt z 0) /\ Rlt z 1) 0 real_0 H0prop). }
  claim HU0cond: forall x :e U0, exists b1 :e (R_standard_basis :\/: R_K_basis), x :e b1 /\ b1 c= U0.
  { exact (SepE2 (Power R)
            (fun U:set => forall x0 :e U, exists b1 :e (R_standard_basis :\/: R_K_basis), x0 :e b1 /\ b1 c= U)
            U0 HU0K). }
  claim Hexb1: exists b1 :e (R_standard_basis :\/: R_K_basis), 0 :e b1 /\ b1 c= U0.
  { exact (HU0cond 0 H0inU0). }
  apply Hexb1.
  let b1. assume Hb1pair.
  claim Hb1B: b1 :e (R_standard_basis :\/: R_K_basis).
  { exact (andEL (b1 :e (R_standard_basis :\/: R_K_basis)) (0 :e b1 /\ b1 c= U0) Hb1pair). }
  claim Hb1rest: 0 :e b1 /\ b1 c= U0.
  { exact (andER (b1 :e (R_standard_basis :\/: R_K_basis)) (0 :e b1 /\ b1 c= U0) Hb1pair). }
  claim H0inb1: 0 :e b1.
  { exact (andEL (0 :e b1) (b1 c= U0) Hb1rest). }
  claim Hb1subU0: b1 c= U0.
  { exact (andER (0 :e b1) (b1 c= U0) Hb1rest). }
	  apply (binunionE R_standard_basis R_K_basis b1 Hb1B).
	  - (** b1 from standard basis **)
	    assume Hb1Std: b1 :e R_standard_basis.
    (** destruct b1 = open_interval a c **)
    claim Hexa: exists a :e R, b1 :e {open_interval a b|b :e R}.
    { exact (famunionE R (fun a0:set => {open_interval a0 b|b :e R}) b1 Hb1Std). }
    apply Hexa.
    let a0. assume Ha0pair.
    claim Ha0R: a0 :e R.
    { exact (andEL (a0 :e R) (b1 :e {open_interval a0 b|b :e R}) Ha0pair). }
    claim Hb1Fam: b1 :e {open_interval a0 b|b :e R}.
    { exact (andER (a0 :e R) (b1 :e {open_interval a0 b|b :e R}) Ha0pair). }
    claim Hexc: exists c0 :e R, b1 = open_interval a0 c0.
    { exact (ReplE R (fun c:set => open_interval a0 c) b1 Hb1Fam). }
    apply Hexc.
    let c0. assume Hc0pair.
    claim Hc0R: c0 :e R.
    { exact (andEL (c0 :e R) (b1 = open_interval a0 c0) Hc0pair). }
    claim Hb1eq: b1 = open_interval a0 c0.
    { exact (andER (c0 :e R) (b1 = open_interval a0 c0) Hc0pair). }
    claim H0inInt: 0 :e open_interval a0 c0.
    { rewrite <- Hb1eq. exact H0inb1. }
    claim H0IntProp: Rlt a0 0 /\ Rlt 0 c0.
    { exact (SepE2 R (fun t:set => Rlt a0 t /\ Rlt t c0) 0 H0inInt). }
    claim Ha0lt0: Rlt a0 0.
    { exact (andEL (Rlt a0 0) (Rlt 0 c0) H0IntProp). }
    claim H0ltc0: Rlt 0 c0.
    { exact (andER (Rlt a0 0) (Rlt 0 c0) H0IntProp). }
    set e1 := eps_ 1.
    claim H1omega: 1 :e omega.
    { exact (nat_p_omega 1 nat_1). }
    claim He1SNoS: e1 :e SNoS_ omega.
    { exact (SNo_eps_SNoS_omega 1 H1omega). }
    claim He1R: e1 :e R.
    { exact (SNoS_omega_real e1 He1SNoS). }
    claim He1S: SNo e1.
    { exact (real_SNo e1 He1R). }
    claim He1pos: 0 < e1.
    { exact (SNo_eps_pos 1 H1omega). }
    claim H0Ord: ordinal 0.
    { exact (nat_p_ordinal 0 nat_0). }
    claim H0in1: 0 :e 1.
    { exact (ordinal_0_In_ordsucc 0 H0Ord). }
    claim He1lt1: e1 < 1.
    { claim He1ltE0: eps_ 1 < eps_ 0.
      { exact (SNo_eps_decr 1 H1omega 0 H0in1). }
      rewrite <- (eps_0_1) at 2.
      exact He1ltE0. }
	    set y := mul_SNo a0 e1.
	    claim HyR: y :e R.
	    { exact (real_mul_SNo a0 Ha0R e1 He1R). }
	    claim Ha0S: SNo a0.
	    { exact (real_SNo a0 Ha0R). }
    claim HyNeg: y < 0.
    { exact (mul_SNo_neg_pos a0 e1 Ha0S He1S (RltE_lt a0 0 Ha0lt0) He1pos). }
    claim Hyltc0: y < c0.
    { claim H0ltc0lt: 0 < c0.
      { exact (RltE_lt 0 c0 H0ltc0). }
      claim Hc0S: SNo c0.
      { exact (real_SNo c0 Hc0R). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      exact (SNoLt_tra y 0 c0 HyS SNo_0 Hc0S HyNeg H0ltc0lt). }
	    claim Ha0lty: a0 < y.
	    { claim Ha0lt: a0 < 0.
	      { exact (RltE_lt a0 0 Ha0lt0). }
	      claim Ha0mul: mul_SNo a0 1 < mul_SNo a0 e1.
	      { exact (neg_mul_SNo_Lt a0 1 e1 Ha0S Ha0lt SNo_1 He1S He1lt1). }
	      prove a0 < y.
	      rewrite <- (mul_SNo_oneR a0 Ha0S) at 1.
	      exact Ha0mul. }
	    claim HyInt: y :e open_interval a0 c0.
	    { prove y :e open_interval a0 c0.
	      claim Harlt: Rlt a0 y.
	      { exact (RltI a0 y Ha0R HyR Ha0lty). }
	      claim Hyrc0: Rlt y c0.
	      { exact (RltI y c0 HyR Hc0R Hyltc0). }
	      claim Hconj: Rlt a0 y /\ Rlt y c0.
	      { exact (andI (Rlt a0 y) (Rlt y c0) Harlt Hyrc0). }
	      exact (SepI R (fun t:set => Rlt a0 t /\ Rlt t c0) y HyR Hconj). }
    claim Hyinb1: y :e b1.
    { rewrite Hb1eq. exact HyInt. }
    claim HyinU0: y :e U0.
    { exact (Hb1subU0 y Hyinb1). }
    claim HyU0prop: ~(Rlt y 0) /\ Rlt y 1.
    { exact (SepE2 R (fun z:set => ~(Rlt z 0) /\ Rlt z 1) y HyinU0). }
    claim Hnotylt0: ~(Rlt y 0).
    { exact (andEL (~(Rlt y 0)) (Rlt y 1) HyU0prop). }
    claim HyRlt0: Rlt y 0.
    { exact (RltI y 0 HyR real_0 HyNeg). }
    exact (Hnotylt0 HyRlt0).
	  - (** b1 from K basis **)
	    assume Hb1K: b1 :e R_K_basis.
    (** destruct b1 = open_interval a c \\ K_set **)
    claim Hexa: exists a :e R, b1 :e {open_interval a b :\: K_set|b :e R}.
    { exact (famunionE R (fun a0:set => {open_interval a0 b :\: K_set|b :e R}) b1 Hb1K). }
    apply Hexa.
    let a0. assume Ha0pair.
    claim Ha0R: a0 :e R.
    { exact (andEL (a0 :e R) (b1 :e {open_interval a0 b :\: K_set|b :e R}) Ha0pair). }
    claim Hb1Fam: b1 :e {open_interval a0 b :\: K_set|b :e R}.
    { exact (andER (a0 :e R) (b1 :e {open_interval a0 b :\: K_set|b :e R}) Ha0pair). }
    claim Hexc: exists c0 :e R, b1 = open_interval a0 c0 :\: K_set.
    { exact (ReplE R (fun c:set => open_interval a0 c :\: K_set) b1 Hb1Fam). }
    apply Hexc.
    let c0. assume Hc0pair.
    claim Hc0R: c0 :e R.
    { exact (andEL (c0 :e R) (b1 = open_interval a0 c0 :\: K_set) Hc0pair). }
    claim Hb1eq: b1 = open_interval a0 c0 :\: K_set.
    { exact (andER (c0 :e R) (b1 = open_interval a0 c0 :\: K_set) Hc0pair). }
    claim H0inSetminus: 0 :e open_interval a0 c0 :\: K_set.
    { rewrite <- Hb1eq. exact H0inb1. }
    claim H0inInt: 0 :e open_interval a0 c0.
    { exact (setminusE1 (open_interval a0 c0) K_set 0 H0inSetminus). }
    claim H0IntProp: Rlt a0 0 /\ Rlt 0 c0.
    { exact (SepE2 R (fun t:set => Rlt a0 t /\ Rlt t c0) 0 H0inInt). }
    claim Ha0lt0: Rlt a0 0.
    { exact (andEL (Rlt a0 0) (Rlt 0 c0) H0IntProp). }
    claim H0ltc0: Rlt 0 c0.
    { exact (andER (Rlt a0 0) (Rlt 0 c0) H0IntProp). }
    set e1 := eps_ 1.
    claim H1omega: 1 :e omega.
    { exact (nat_p_omega 1 nat_1). }
    claim He1SNoS: e1 :e SNoS_ omega.
    { exact (SNo_eps_SNoS_omega 1 H1omega). }
    claim He1R: e1 :e R.
    { exact (SNoS_omega_real e1 He1SNoS). }
    claim He1S: SNo e1.
    { exact (real_SNo e1 He1R). }
    claim He1pos: 0 < e1.
    { exact (SNo_eps_pos 1 H1omega). }
    claim H0Ord: ordinal 0.
    { exact (nat_p_ordinal 0 nat_0). }
    claim H0in1: 0 :e 1.
    { exact (ordinal_0_In_ordsucc 0 H0Ord). }
    claim He1lt1: e1 < 1.
    { claim He1ltE0: eps_ 1 < eps_ 0.
      { exact (SNo_eps_decr 1 H1omega 0 H0in1). }
      rewrite <- (eps_0_1) at 2.
      exact He1ltE0. }
	    set y := mul_SNo a0 e1.
	    claim Ha0S: SNo a0.
	    { exact (real_SNo a0 Ha0R). }
	    claim HyR: y :e R.
	    { exact (real_mul_SNo a0 Ha0R e1 He1R). }
	    claim HyNeg: y < 0.
    { exact (mul_SNo_neg_pos a0 e1 Ha0S He1S (RltE_lt a0 0 Ha0lt0) He1pos). }
    claim Hyltc0: y < c0.
    { claim H0ltc0lt: 0 < c0.
      { exact (RltE_lt 0 c0 H0ltc0). }
      claim Hc0S: SNo c0.
      { exact (real_SNo c0 Hc0R). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      exact (SNoLt_tra y 0 c0 HyS SNo_0 Hc0S HyNeg H0ltc0lt). }
	    claim Ha0lty: a0 < y.
	    { claim Ha0lt: a0 < 0.
	      { exact (RltE_lt a0 0 Ha0lt0). }
	      claim Ha0mul: mul_SNo a0 1 < mul_SNo a0 e1.
	      { exact (neg_mul_SNo_Lt a0 1 e1 Ha0S Ha0lt SNo_1 He1S He1lt1). }
	      prove a0 < y.
	      rewrite <- (mul_SNo_oneR a0 Ha0S) at 1.
	      exact Ha0mul. }
	    claim HyInt: y :e open_interval a0 c0.
	    { prove y :e open_interval a0 c0.
	      claim Harlt: Rlt a0 y.
	      { exact (RltI a0 y Ha0R HyR Ha0lty). }
	      claim Hyrc0: Rlt y c0.
	      { exact (RltI y c0 HyR Hc0R Hyltc0). }
	      claim Hconj: Rlt a0 y /\ Rlt y c0.
	      { exact (andI (Rlt a0 y) (Rlt y c0) Harlt Hyrc0). }
	      exact (SepI R (fun t:set => Rlt a0 t /\ Rlt t c0) y HyR Hconj). }
    claim HynotK: y /:e K_set.
    { assume HyK: y :e K_set.
      apply (ReplE_impred (omega :\: {0}) (fun m:set => inv_nat m) y HyK False).
      let m. assume HmIn: m :e omega :\: {0}. assume Hyeq: y = inv_nat m.
      claim Hypos: Rlt 0 y.
      { rewrite Hyeq.
        exact (inv_nat_pos m HmIn). }
      claim Hyposlt: 0 < y.
      { exact (RltE_lt 0 y Hypos). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      claim H0lt0: 0 < 0.
      { exact (SNoLt_tra 0 y 0 SNo_0 HyS SNo_0 Hyposlt HyNeg). }
      exact ((SNoLt_irref 0) H0lt0). }
    claim HyinSetminus: y :e open_interval a0 c0 :\: K_set.
    { exact (setminusI (open_interval a0 c0) K_set y HyInt HynotK). }
    claim Hyinb1: y :e b1.
    { rewrite Hb1eq. exact HyinSetminus. }
    claim HyinU0: y :e U0.
    { exact (Hb1subU0 y Hyinb1). }
    claim HyU0prop: ~(Rlt y 0) /\ Rlt y 1.
    { exact (SepE2 R (fun z:set => ~(Rlt z 0) /\ Rlt z 1) y HyinU0). }
    claim Hnotylt0: ~(Rlt y 0).
    { exact (andEL (~(Rlt y 0)) (Rlt y 1) HyU0prop). }
    claim HyRlt0: Rlt y 0.
    { exact (RltI y 0 HyR real_0 HyNeg). }
    exact (Hnotylt0 HyRlt0).
Qed.

(** from §13 Exercise 7: containment relations among five ℝ topologies **) 
(** LATEX VERSION: Exercise 7 lists several standard ℝ topologies and records which contain which (upper limit finer than standard, etc.). **)
Definition R_finite_complement_topology : set := finite_complement_topology R.
Definition R_ray_topology : set :=
  {U :e Power R|U = Empty \/ U = R \/ (exists a :e R, U = {x :e R|Rlt x a})}.

(** from §13 Exercise 7: open rays are open in the standard topology **)
(** LATEX VERSION: The ray (a,∞) is open in the standard topology on ℝ. **)
Theorem open_ray_in_R_standard_topology : forall a:set, a :e R -> {x :e R|Rlt a x} :e R_standard_topology.
let a. assume HaR.
set U := {x :e R|Rlt a x}.
prove U :e R_standard_topology.
claim HUinPow : U :e Power R.
{ apply PowerI.
  let x. assume Hx.
  exact (SepE1 R (fun x0 : set => Rlt a x0) x Hx). }
claim HUprop : forall x :e U, exists b :e R_standard_basis, x :e b /\ b c= U.
{ let x. assume HxU.
  claim HxR : x :e R.
  { exact (SepE1 R (fun x0 : set => Rlt a x0) x HxU). }
  claim Hax : Rlt a x.
  { exact (SepE2 R (fun x0 : set => Rlt a x0) x HxU). }
  claim H0omega : 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  set e0 := eps_ 0.
  claim He0SNoS : e0 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega 0 H0omega). }
  claim He0R : e0 :e R.
  { exact (SNoS_omega_real e0 He0SNoS). }
  claim HbR : add_SNo x e0 :e R.
  { exact (real_add_SNo x HxR e0 He0R). }
  set b := open_interval a (add_SNo x e0).
  claim HbStd : b :e R_standard_basis.
  { claim HbFam : b :e {open_interval a b0|b0 :e R}.
    { exact (ReplI R (fun b0 : set => open_interval a b0) (add_SNo x e0) HbR). }
    exact (famunionI R
                      (fun a0 : set => {open_interval a0 b0|b0 :e R})
                      a
                      b
                      HaR
                      HbFam). }
  claim Hxinb : x :e b.
  { claim Hxlt : x < add_SNo x e0.
    { exact (add_SNo_eps_Lt x (real_SNo x HxR) 0 H0omega). }
    claim Hxxe0 : Rlt x (add_SNo x e0).
    { exact (RltI x (add_SNo x e0) HxR HbR Hxlt). }
    claim Hpropb : Rlt a x /\ Rlt x (add_SNo x e0).
    { apply andI.
      - exact Hax.
      - exact Hxxe0. }
    exact (SepI R (fun x0 : set => Rlt a x0 /\ Rlt x0 (add_SNo x e0)) x HxR Hpropb). }
  claim HbSubU : b c= U.
  { let y. assume Hyb.
    claim HyR : y :e R.
    { exact (SepE1 R (fun x0 : set => Rlt a x0 /\ Rlt x0 (add_SNo x e0)) y Hyb). }
    claim Hyprop : Rlt a y /\ Rlt y (add_SNo x e0).
    { exact (SepE2 R (fun x0 : set => Rlt a x0 /\ Rlt x0 (add_SNo x e0)) y Hyb). }
    claim Hay : Rlt a y.
    { exact (andEL (Rlt a y) (Rlt y (add_SNo x e0)) Hyprop). }
    exact (SepI R (fun x0 : set => Rlt a x0) y HyR Hay). }
  witness b.
  apply andI.
  - exact HbStd.
  - apply andI.
    + exact Hxinb.
    + exact HbSubU. }
exact (SepI (Power R)
            (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
            U
            HUinPow
            HUprop).
Qed.

(** from §13: left open ray is open in the standard topology on R **)
(** LATEX VERSION: The ray (-infty,b) is open in the standard topology on R. **)
Theorem open_left_ray_in_R_standard_topology : forall b:set, b :e R -> {x :e R|Rlt x b} :e R_standard_topology.
let b. assume HbR.
set U := {x :e R|Rlt x b}.
prove U :e R_standard_topology.
claim HUinPow : U :e Power R.
{ apply PowerI.
  let x. assume Hx.
  exact (SepE1 R (fun x0 : set => Rlt x0 b) x Hx). }
claim HUprop : forall x :e U, exists bb :e R_standard_basis, x :e bb /\ bb c= U.
{ let x. assume HxU.
  claim HxR : x :e R.
  { exact (SepE1 R (fun x0 : set => Rlt x0 b) x HxU). }
  claim Hxb : Rlt x b.
  { exact (SepE2 R (fun x0 : set => Rlt x0 b) x HxU). }
  claim H0omega : 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  set e0 := eps_ 0.
  claim He0SNoS : e0 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega 0 H0omega). }
  claim He0R : e0 :e R.
  { exact (SNoS_omega_real e0 He0SNoS). }
  claim He0S : SNo e0.
  { exact (real_SNo e0 He0R). }
  claim HxS : SNo x.
  { exact (real_SNo x HxR). }
  claim HmE0R : minus_SNo e0 :e R.
  { exact (real_minus_SNo e0 He0R). }
  claim HmE0S : SNo (minus_SNo e0).
  { exact (real_SNo (minus_SNo e0) HmE0R). }
  claim HaR : add_SNo x (minus_SNo e0) :e R.
  { exact (real_add_SNo x HxR (minus_SNo e0) HmE0R). }
  set a0 := add_SNo x (minus_SNo e0).
  set I := open_interval a0 b.
  claim HIStd : I :e R_standard_basis.
  { claim HIa : I :e {open_interval a0 bb|bb :e R}.
    { exact (ReplI R (fun bb : set => open_interval a0 bb) b HbR). }
    exact (famunionI R
                     (fun aa : set => {open_interval aa bb|bb :e R})
                     a0
                     I
                     HaR
                     HIa). }
  claim HxInI : x :e I.
  { claim Hxlt : x < add_SNo x e0.
    { exact (add_SNo_eps_Lt x HxS 0 H0omega). }
    claim Hxme0ltx : a0 < x.
    { exact (add_SNo_minus_Lt1b x e0 x HxS He0S HxS Hxlt). }
    claim Hax : Rlt a0 x.
    { exact (RltI a0 x HaR HxR Hxme0ltx). }
    claim HpropI : Rlt a0 x /\ Rlt x b.
    { apply andI.
      - exact Hax.
      - exact Hxb. }
    exact (SepI R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b) x HxR HpropI). }
  claim HISubU : I c= U.
  { let y. assume HyI.
    claim HyR : y :e R.
    { exact (SepE1 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 b) y HyI). }
    claim HyProp : Rlt a0 y /\ Rlt y b.
    { exact (SepE2 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 b) y HyI). }
    claim Hyb : Rlt y b.
    { exact (andER (Rlt a0 y) (Rlt y b) HyProp). }
    exact (SepI R (fun y0 : set => Rlt y0 b) y HyR Hyb). }
  witness I.
  apply andI.
  - exact HIStd.
  - apply andI.
    + exact HxInI.
    + exact HISubU. }
exact (SepI (Power R)
            (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
            U
            HUinPow
            HUprop).
Qed.

(** from §13: unions of standard open sets are standard open **)
(** LATEX VERSION: Arbitrary unions of open sets are open; in particular, unions of two open sets are open. **)
Theorem binunion_in_R_standard_topology : forall U V:set,
  U :e R_standard_topology ->
  V :e R_standard_topology ->
  U :\/: V :e R_standard_topology.
let U V. assume HU HV.
prove U :\/: V :e R_standard_topology.
claim HUpow : U :e Power R.
{ exact (SepE1 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
               U
               HU). }
claim HVpow : V :e Power R.
{ exact (SepE1 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
               V
               HV). }
claim HUprop : forall x :e U, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U.
{ exact (SepE2 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
               U
               HU). }
claim HVprop : forall x :e V, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= V.
{ exact (SepE2 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
               V
               HV). }
claim HUVpow : U :\/: V :e Power R.
{ apply PowerI.
  let x. assume HxUV : x :e U :\/: V.
  apply (binunionE U V x HxUV).
  - assume HxU : x :e U.
    exact (PowerE R U HUpow x HxU).
  - assume HxV : x :e V.
    exact (PowerE R V HVpow x HxV). }
claim HUVprop : forall x :e U :\/: V, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U :\/: V.
{ let x. assume HxUV : x :e U :\/: V.
  apply (binunionE U V x HxUV).
  - assume HxU : x :e U.
    claim Hexb : exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U.
    { exact (HUprop x HxU). }
    apply Hexb.
    let b0. assume Hb0pair.
    witness b0.
    apply andI.
    + exact (andEL (b0 :e R_standard_basis) (x :e b0 /\ b0 c= U) Hb0pair).
    + claim Hb0prop : x :e b0 /\ b0 c= U.
      { exact (andER (b0 :e R_standard_basis) (x :e b0 /\ b0 c= U) Hb0pair). }
      apply andI.
      - exact (andEL (x :e b0) (b0 c= U) Hb0prop).
      - claim Hb0subU : b0 c= U.
        { exact (andER (x :e b0) (b0 c= U) Hb0prop). }
        let y. assume Hyb0.
        claim HyU : y :e U.
        { exact (Hb0subU y Hyb0). }
        exact (binunionI1 U V y HyU).
  - assume HxV : x :e V.
    claim Hexb : exists b0 :e R_standard_basis, x :e b0 /\ b0 c= V.
    { exact (HVprop x HxV). }
    apply Hexb.
    let b0. assume Hb0pair.
    witness b0.
    apply andI.
    + exact (andEL (b0 :e R_standard_basis) (x :e b0 /\ b0 c= V) Hb0pair).
    + claim Hb0prop : x :e b0 /\ b0 c= V.
      { exact (andER (b0 :e R_standard_basis) (x :e b0 /\ b0 c= V) Hb0pair). }
      apply andI.
      - exact (andEL (x :e b0) (b0 c= V) Hb0prop).
      - claim Hb0subV : b0 c= V.
        { exact (andER (x :e b0) (b0 c= V) Hb0prop). }
        let y. assume Hyb0.
        claim HyV : y :e V.
        { exact (Hb0subV y Hyb0). }
        exact (binunionI2 U V y HyV). }
exact (SepI (Power R)
            (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
            (U :\/: V)
            HUVpow
            HUVprop).
Qed.

(** from §13: complement of a point in R equals union of two open rays **)
(** LATEX VERSION: R minus {a} is (-infty,a) union (a,infty). **)
Theorem R_minus_singleton_eq_rays_union : forall a:set, a :e R ->
  R :\: {a,a} = {x :e R|Rlt x a} :\/: {x :e R|Rlt a x}.
let a. assume HaR.
apply set_ext.
- let x. assume Hx : x :e R :\: {a,a}.
  prove x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|Rlt a x0}.
  claim Hxpair : x :e R /\ x /:e {a,a}.
  { exact (setminusE R {a,a} x Hx). }
  claim HxR : x :e R.
  { exact (andEL (x :e R) (x /:e {a,a}) Hxpair). }
  claim HxNot : x /:e {a,a}.
  { exact (andER (x :e R) (x /:e {a,a}) Hxpair). }
  claim HxS : SNo x.
  { exact (real_SNo x HxR). }
  claim HaS : SNo a.
  { exact (real_SNo a HaR). }
  apply (SNoLt_trichotomy_or_impred x a HxS HaS (x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|Rlt a x0})).
  - assume Hxlt : x < a.
    claim HxRlt : Rlt x a.
    { exact (RltI x a HxR HaR Hxlt). }
    claim HxLeft : x :e {x0 :e R|Rlt x0 a}.
    { exact (SepI R (fun x0 : set => Rlt x0 a) x HxR HxRlt). }
    exact (binunionI1 {x0 :e R|Rlt x0 a} {x0 :e R|Rlt a x0} x HxLeft).
  - assume Hxeq : x = a.
    claim Hxinpair : x :e {a,a}.
    { rewrite Hxeq.
      exact (UPairI1 a a). }
    claim Hfalse : False.
    { exact (HxNot Hxinpair). }
    exact (FalseE Hfalse (x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|Rlt a x0})).
  - assume Halt : a < x.
    claim HxRlt : Rlt a x.
    { exact (RltI a x HaR HxR Halt). }
    claim HxRight : x :e {x0 :e R|Rlt a x0}.
    { exact (SepI R (fun x0 : set => Rlt a x0) x HxR HxRlt). }
    exact (binunionI2 {x0 :e R|Rlt x0 a} {x0 :e R|Rlt a x0} x HxRight).
- let x. assume Hx : x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|Rlt a x0}.
  prove x :e R :\: {a,a}.
  apply (binunionE {x0 :e R|Rlt x0 a} {x0 :e R|Rlt a x0} x Hx).
  - assume HxLeft : x :e {x0 :e R|Rlt x0 a}.
    claim HxR : x :e R.
    { exact (SepE1 R (fun x0 : set => Rlt x0 a) x HxLeft). }
    claim HxRlt : Rlt x a.
    { exact (SepE2 R (fun x0 : set => Rlt x0 a) x HxLeft). }
    claim HxNot : x /:e {a,a}.
    { assume Hxin : x :e {a,a}.
      claim Hxeq : x = a.
      { apply (UPairE x a a Hxin (x = a)).
        - assume H1. exact H1.
        - assume H1. exact H1. }
      claim Haa : Rlt a a.
      { rewrite <- Hxeq at 1.
        exact HxRlt. }
      exact ((not_Rlt_refl a HaR) Haa). }
    exact (setminusI R {a,a} x HxR HxNot).
  - assume HxRight : x :e {x0 :e R|Rlt a x0}.
    claim HxR : x :e R.
    { exact (SepE1 R (fun x0 : set => Rlt a x0) x HxRight). }
    claim HxRlt : Rlt a x.
    { exact (SepE2 R (fun x0 : set => Rlt a x0) x HxRight). }
    claim HxNot : x /:e {a,a}.
    { assume Hxin : x :e {a,a}.
      claim Hxeq : x = a.
      { apply (UPairE x a a Hxin (x = a)).
        - assume H1. exact H1.
        - assume H1. exact H1. }
      claim Haa : Rlt a a.
      { rewrite <- Hxeq at 2.
        exact HxRlt. }
      exact ((not_Rlt_refl a HaR) Haa). }
    exact (setminusI R {a,a} x HxR HxNot).
Qed.

(** from §13: complement of a point is open in the standard topology on R **)
(** LATEX VERSION: Since (-infty,a) and (a,infty) are open, their union R minus {a} is open. **)
Theorem R_minus_singleton_in_R_standard_topology : forall a:set, a :e R -> R :\: {a,a} :e R_standard_topology.
let a. assume HaR.
rewrite (R_minus_singleton_eq_rays_union a HaR).
apply (binunion_in_R_standard_topology {x :e R|Rlt x a} {x :e R|Rlt a x}).
- exact (open_left_ray_in_R_standard_topology a HaR).
- exact (open_ray_in_R_standard_topology a HaR).
Qed.

(** from §13: complement of a union is intersection of complements **)
(** LATEX VERSION: X minus (A union B) equals (X minus A) intersect (X minus B). **)
Theorem setminus_binunion_eq_binintersect : forall X A B:set,
  X :\: (A :\/: B) = (X :\: A) :/\: (X :\: B).
let X A B.
apply set_ext.
- let x. assume Hx : x :e X :\: (A :\/: B).
  prove x :e (X :\: A) :/\: (X :\: B).
  claim Hxpair : x :e X /\ x /:e (A :\/: B).
  { exact (setminusE X (A :\/: B) x Hx). }
  claim HxX : x :e X.
  { exact (andEL (x :e X) (x /:e (A :\/: B)) Hxpair). }
  claim HxNot : x /:e (A :\/: B).
  { exact (andER (x :e X) (x /:e (A :\/: B)) Hxpair). }
  claim HxNotA : x /:e A.
  { assume HxA : x :e A.
    claim HxAB : x :e A :\/: B.
    { exact (binunionI1 A B x HxA). }
    exact (HxNot HxAB). }
  claim HxNotB : x /:e B.
  { assume HxB : x :e B.
    claim HxAB : x :e A :\/: B.
    { exact (binunionI2 A B x HxB). }
    exact (HxNot HxAB). }
  exact (binintersectI (X :\: A) (X :\: B) x (setminusI X A x HxX HxNotA) (setminusI X B x HxX HxNotB)).
- let x. assume Hx : x :e (X :\: A) :/\: (X :\: B).
  prove x :e X :\: (A :\/: B).
  claim HxXA : x :e X :\: A.
  { exact (binintersectE1 (X :\: A) (X :\: B) x Hx). }
  claim HxXB : x :e X :\: B.
  { exact (binintersectE2 (X :\: A) (X :\: B) x Hx). }
  claim HxX : x :e X.
  { exact (setminusE1 X A x HxXA). }
  claim HxNotA : x /:e A.
  { exact (setminusE2 X A x HxXA). }
  claim HxNotB : x /:e B.
  { exact (setminusE2 X B x HxXB). }
  claim HxNotAB : x /:e (A :\/: B).
  { assume HxAB : x :e A :\/: B.
    apply (binunionE A B x HxAB).
    - assume HxA. exact (HxNotA HxA).
    - assume HxB. exact (HxNotB HxB). }
  exact (setminusI X (A :\/: B) x HxX HxNotAB).
Qed.

(** from §13: complement of an intersection is union of complements **)
(** LATEX VERSION: X minus (A intersect B) equals (X minus A) union (X minus B). **)
Theorem setminus_binintersect_eq_binunion : forall X A B:set,
  X :\: (A :/\: B) = (X :\: A) :\/: (X :\: B).
let X A B.
apply set_ext.
- let x. assume Hx : x :e X :\: (A :/\: B).
  prove x :e (X :\: A) :\/: (X :\: B).
  claim Hxpair : x :e X /\ x /:e (A :/\: B).
  { exact (setminusE X (A :/\: B) x Hx). }
  claim HxX : x :e X.
  { exact (andEL (x :e X) (x /:e (A :/\: B)) Hxpair). }
  claim HxNotAB : x /:e (A :/\: B).
  { exact (andER (x :e X) (x /:e (A :/\: B)) Hxpair). }
  apply (xm (x :e A)).
  + assume HxA : x :e A.
    claim HxNotB : x /:e B.
    { assume HxB : x :e B.
      claim HxAB : x :e A :/\: B.
      { exact (binintersectI A B x HxA HxB). }
      exact (HxNotAB HxAB). }
    exact (binunionI2 (X :\: A) (X :\: B) x (setminusI X B x HxX HxNotB)).
  + assume HxNotA : ~(x :e A).
    exact (binunionI1 (X :\: A) (X :\: B) x (setminusI X A x HxX HxNotA)).
- let x. assume Hx : x :e (X :\: A) :\/: (X :\: B).
  prove x :e X :\: (A :/\: B).
  apply (binunionE (X :\: A) (X :\: B) x Hx).
  + assume HxXA : x :e X :\: A.
    claim HxX : x :e X.
    { exact (setminusE1 X A x HxXA). }
    claim HxNotAB : x /:e A :/\: B.
    { assume HxAB : x :e A :/\: B.
      claim HxA : x :e A.
      { exact (binintersectE1 A B x HxAB). }
      exact ((setminusE2 X A x HxXA) HxA). }
    exact (setminusI X (A :/\: B) x HxX HxNotAB).
  + assume HxXB : x :e X :\: B.
    claim HxX : x :e X.
    { exact (setminusE1 X B x HxXB). }
    claim HxNotAB : x /:e A :/\: B.
    { assume HxAB : x :e A :/\: B.
      claim HxB : x :e B.
      { exact (binintersectE2 A B x HxAB). }
      exact ((setminusE2 X B x HxXB) HxB). }
    exact (setminusI X (A :/\: B) x HxX HxNotAB).
Qed.

(** from §13: double complement inside X **)
(** LATEX VERSION: If U is a subset of X then X minus (X minus U) equals U. **)
Theorem setminus_setminus_eq : forall X U:set,
  U c= X ->
  X :\: (X :\: U) = U.
let X U. assume HUsub.
apply set_ext.
- let x. assume Hx : x :e X :\: (X :\: U).
  prove x :e U.
  claim Hxpair : x :e X /\ x /:e (X :\: U).
  { exact (setminusE X (X :\: U) x Hx). }
  claim HxX : x :e X.
  { exact (andEL (x :e X) (x /:e (X :\: U)) Hxpair). }
  claim HxNot : x /:e (X :\: U).
  { exact (andER (x :e X) (x /:e (X :\: U)) Hxpair). }
  apply (xm (x :e U)).
  - assume HxU. exact HxU.
  - assume HxNotU : ~(x :e U).
    claim HxXU : x :e X :\: U.
    { exact (setminusI X U x HxX HxNotU). }
    exact (FalseE (HxNot HxXU) (x :e U)).
- let x. assume HxU : x :e U.
  prove x :e X :\: (X :\: U).
  claim HxX : x :e X.
  { exact (HUsub x HxU). }
  claim HxNot : x /:e (X :\: U).
  { assume HxXU : x :e X :\: U.
    exact ((setminusE2 X U x HxXU) HxU). }
  exact (setminusI X (X :\: U) x HxX HxNot).
Qed.

(** from §12: finite intersections of closed sets are closed **)
(** LATEX VERSION: Finite intersections of closed sets are closed because their complements are finite unions of open sets. **)
Theorem binintersect_closed : forall X T C D:set,
  closed_in X T C ->
  closed_in X T D ->
  closed_in X T (C :/\: D).
let X T C D.
assume HC: closed_in X T C.
assume HD: closed_in X T D.
exact (closed_binintersect X T C D HC HD).
Qed.

(** from §12: finite unions of closed sets are closed **)
(** LATEX VERSION: Finite unions of closed sets are closed because their complements are finite intersections of open sets. **)
Theorem binunion_closed : forall X T C D:set,
  closed_in X T C ->
  closed_in X T D ->
  closed_in X T (C :\/: D).
let X T C D.
assume HC: closed_in X T C.
assume HD: closed_in X T D.
exact (closed_binunion X T C D HC HD).
Qed.

(** from §13: complements of finite sets are open in the standard topology on R **)
(** LATEX VERSION: In the standard topology, the complement of a finite set is open. **)
Theorem Sing_eq_UPair : forall x:set, {x} = {x,x}.
let x.
apply set_ext.
- let y. assume Hy : y :e {x}.
  claim Hyeq : y = x.
  { exact (SingE x y Hy). }
  rewrite Hyeq.
  exact (UPairI1 x x).
- let y. assume Hy : y :e {x,x}.
  claim Hyeq : y = x.
  { apply (UPairE y x x Hy (y = x)).
    - assume H1. exact H1.
    - assume H1. exact H1. }
  rewrite Hyeq.
  exact (SingI x).
Qed.

Theorem finite_complement_open_in_R_standard_topology : forall F:set,
  finite F ->
  F c= R ->
  R :\: F :e R_standard_topology.
let F. assume HFin.
assume HFsubR.
set p := fun F0:set => F0 c= R -> R :\: F0 :e R_standard_topology.
claim HpEmpty : p Empty.
{ assume Hsub : Empty c= R.
  claim Hreq : R :\: Empty = R.
  { apply set_ext.
    - let x. assume Hx : x :e R :\: Empty.
      exact (setminusE1 R Empty x Hx).
    - let x. assume HxR : x :e R.
      exact (setminusI R Empty x HxR (EmptyE x)). }
  rewrite Hreq.
  exact (topology_has_X R R_standard_topology (R_standard_topology_is_topology_local)).
}
claim HpStep : forall X y:set,
  finite X ->
  y /:e X ->
  p X ->
  p (X :\/: {y}).
{ let X y. assume HFinX HyNot HXind.
  assume HsubXY : (X :\/: {y}) c= R.
  claim HsubX : X c= R.
  { let z. assume HzX : z :e X.
    exact (HsubXY z (binunionI1 X {y} z HzX)). }
  claim HyR : y :e R.
  { exact (HsubXY y (binunionI2 X {y} y (SingI y))). }
  claim HXopen : R :\: X :e R_standard_topology.
  { exact (HXind HsubX). }
  claim Hyopen : R :\: {y} :e R_standard_topology.
  { rewrite (Sing_eq_UPair y).
    exact (R_minus_singleton_in_R_standard_topology y HyR). }
  claim Hdecomp : R :\: (X :\/: {y}) = (R :\: X) :/\: (R :\: {y}).
  { exact (setminus_binunion_eq_binintersect R X {y}). }
  rewrite Hdecomp.
  exact (topology_binintersect_closed R R_standard_topology (R :\: X) (R :\: {y})
         (R_standard_topology_is_topology_local)
         HXopen
         Hyopen).
}
claim Hall : forall F0:set, finite F0 -> p F0.
{ exact (finite_ind p HpEmpty HpStep). }
exact (Hall F HFin HFsubR).
Qed.

(** LATEX VERSION: Containment statements among the five ℝ topologies in Exercise 7. **)
Theorem ex13_7_R_topology_containments :
  finer_than R_upper_limit_topology R_standard_topology /\
  finer_than R_K_topology R_standard_topology /\
  finer_than R_standard_topology R_finite_complement_topology /\
  finer_than R_standard_topology R_ray_topology.
prove finer_than R_upper_limit_topology R_standard_topology /\ finer_than R_K_topology R_standard_topology /\ finer_than R_standard_topology R_finite_complement_topology /\ finer_than R_standard_topology R_ray_topology.
apply andI.
- apply andI.
  + apply andI.
    * prove finer_than R_upper_limit_topology R_standard_topology.
      (** finer_than T' T means T c= T' **)
      prove R_standard_topology c= R_upper_limit_topology.
      let U. assume HU: U :e R_standard_topology.
      (** Expand generated_topology membership for the standard topology **)
      claim HUinPow : U :e Power R.
      { exact (SepE1 (Power R)
                     (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                     U
                     HU). }
      claim HUprop : forall x :e U, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U.
      { exact (SepE2 (Power R)
                     (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                     U
                     HU). }
      (** Refine a standard basis neighborhood (a,b) to an upper-limit neighborhood (a,x] around x **)
      claim HUpropUpper : forall x :e U, exists b0 :e R_upper_limit_basis, x :e b0 /\ b0 c= U.
      { let x. assume HxU.
        claim HexStd : exists bStd :e R_standard_basis, x :e bStd /\ bStd c= U.
        { exact (HUprop x HxU). }
        apply HexStd.
        let bStd. assume HbStdPair.
        claim HbStdIn : bStd :e R_standard_basis.
        { exact (andEL (bStd :e R_standard_basis) (x :e bStd /\ bStd c= U) HbStdPair). }
        claim HbStdProp : x :e bStd /\ bStd c= U.
        { exact (andER (bStd :e R_standard_basis) (x :e bStd /\ bStd c= U) HbStdPair). }
        claim HxInbStd : x :e bStd.
        { exact (andEL (x :e bStd) (bStd c= U) HbStdProp). }
        claim HbStdSubU : bStd c= U.
        { exact (andER (x :e bStd) (bStd c= U) HbStdProp). }
        (** Unpack bStd as an open interval open_interval a0 b0 **)
        claim Hexa0 : exists a0 :e R, bStd :e {open_interval a0 b0|b0 :e R}.
        { exact (famunionE R (fun a0 : set => {open_interval a0 b0|b0 :e R}) bStd HbStdIn). }
        apply Hexa0.
        let a0. assume Ha0Pair.
        claim Ha0R : a0 :e R.
        { exact (andEL (a0 :e R) (bStd :e {open_interval a0 b0|b0 :e R}) Ha0Pair). }
        claim HbStdFam : bStd :e {open_interval a0 b0|b0 :e R}.
        { exact (andER (a0 :e R) (bStd :e {open_interval a0 b0|b0 :e R}) Ha0Pair). }
        claim Hexb0 : exists b0 :e R, bStd = open_interval a0 b0.
        { exact (ReplE R (fun b0 : set => open_interval a0 b0) bStd HbStdFam). }
        apply Hexb0.
        let b0. assume Hb0Pair.
        claim Hb0R : b0 :e R.
        { exact (andEL (b0 :e R) (bStd = open_interval a0 b0) Hb0Pair). }
        claim HbStdEq : bStd = open_interval a0 b0.
        { exact (andER (b0 :e R) (bStd = open_interval a0 b0) Hb0Pair). }
        (** From x in bStd, extract x in open_interval a0 b0 **)
        claim HxInI : x :e open_interval a0 b0.
        { rewrite <- HbStdEq.
          exact HxInbStd. }
        claim HxR : x :e R.
        { exact (SepE1 R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b0) x HxInI). }
        claim HxIProp : Rlt a0 x /\ Rlt x b0.
        { exact (SepE2 R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b0) x HxInI). }
        claim Ha0x : Rlt a0 x.
        { exact (andEL (Rlt a0 x) (Rlt x b0) HxIProp). }
        claim Hxb0 : Rlt x b0.
        { exact (andER (Rlt a0 x) (Rlt x b0) HxIProp). }
        (** Define the upper-limit neighborhood (a0,x] **)
        set bUpper := halfopen_interval_right a0 x.
        witness bUpper.
        apply andI.
        - (** bUpper is in the upper-limit basis **)
          claim HbFamUpper : bUpper :e {halfopen_interval_right a0 bb|bb :e R}.
          { exact (ReplI R (fun bb : set => halfopen_interval_right a0 bb) x HxR). }
          exact (famunionI R (fun aa : set => {halfopen_interval_right aa bb|bb :e R})
                           a0
                           bUpper
                           Ha0R
                           HbFamUpper).
        - apply andI.
          + (** x is in (a0,x] **)
            exact (halfopen_interval_right_rightmem a0 x Ha0x).
          + (** (a0,x] is contained in U **)
            let y. assume HyUpper : y :e bUpper.
            prove y :e U.
            claim HyR : y :e R.
            { exact (SepE1 R (fun y0 : set => Rlt a0 y0 /\ ~(Rlt x y0)) y HyUpper). }
            claim HyProp : Rlt a0 y /\ ~(Rlt x y).
            { exact (SepE2 R (fun y0 : set => Rlt a0 y0 /\ ~(Rlt x y0)) y HyUpper). }
            claim Ha0y : Rlt a0 y.
            { exact (andEL (Rlt a0 y) (~(Rlt x y)) HyProp). }
            claim HnotRltxy : ~(Rlt x y).
            { exact (andER (Rlt a0 y) (~(Rlt x y)) HyProp). }
            (** Convert ~(Rlt x y) into ~(x<y) using known realness of x and y **)
            claim Hnot_xlt_y : ~(x < y).
            { assume Hxy : x < y.
              claim HxyRlt : Rlt x y.
              { exact (RltI x y HxR HyR Hxy). }
              exact (HnotRltxy HxyRlt). }
            (** Show y < b0 using trichotomy between y and x, since x < b0 **)
            claim HyS : SNo y.
            { exact (real_SNo y HyR). }
            claim HxS : SNo x.
            { exact (real_SNo x HxR). }
            claim Hb0S : SNo b0.
            { exact (real_SNo b0 Hb0R). }
            claim Hxltb0 : x < b0.
            { exact (RltE_lt x b0 Hxb0). }
            claim Hyltb0 : y < b0.
            { apply (SNoLt_trichotomy_or_impred y x HyS HxS (y < b0)).
              - assume Hyltx : y < x.
                exact (SNoLt_tra y x b0 HyS HxS Hb0S Hyltx Hxltb0).
              - assume Heyx : y = x.
                rewrite Heyx.
                exact Hxltb0.
              - assume HxltY : x < y.
                claim HxyFalse : False.
                { exact (Hnot_xlt_y HxltY). }
                exact (FalseE HxyFalse (y < b0)). }
            claim HyRltb0 : Rlt y b0.
            { exact (RltI y b0 HyR Hb0R Hyltb0). }
            (** y is in the standard open interval (a0,b0) = bStd **)
            claim HyConj : Rlt a0 y /\ Rlt y b0.
            { apply andI.
              - exact Ha0y.
              - exact HyRltb0. }
            claim HyInI : y :e open_interval a0 b0.
            { exact (SepI R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 b0) y HyR HyConj). }
            claim HyInbStd : y :e bStd.
            { rewrite HbStdEq at 1.
              exact HyInI. }
            exact (HbStdSubU y HyInbStd).
      }
      (** Conclude: U is open in R_upper_limit_topology by definition **)
      exact (SepI (Power R)
                  (fun U0 : set => forall x0 :e U0, exists b0 :e R_upper_limit_basis, x0 :e b0 /\ b0 c= U0)
                  U
                  HUinPow
                  HUpropUpper).
    * prove finer_than R_K_topology R_standard_topology.
      (** finer_than T' T means T c= T' **)
      prove R_standard_topology c= R_K_topology.
      let U. assume HU: U :e R_standard_topology.
      (** Expand generated_topology membership for the standard topology **)
      claim HUinPow : U :e Power R.
      { exact (SepE1 (Power R)
                     (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                     U
                     HU). }
      claim HUprop : forall x :e U, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U.
      { exact (SepE2 (Power R)
                     (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                     U
                     HU). }
      (** Show U satisfies the defining property for generated_topology R (R_standard_basis :\/: R_K_basis) **)
      claim HUpropK : forall x :e U, exists b0 :e (R_standard_basis :\/: R_K_basis), x :e b0 /\ b0 c= U.
      { let x. assume HxU.
        claim Hexb : exists b0 :e R_standard_basis, x :e b0 /\ b0 c= U.
        { exact (HUprop x HxU). }
        apply Hexb.
        let b0. assume Hb0pair.
        claim Hb0Std : b0 :e R_standard_basis.
        { exact (andEL (b0 :e R_standard_basis) (x :e b0 /\ b0 c= U) Hb0pair). }
        claim Hb0prop : x :e b0 /\ b0 c= U.
        { exact (andER (b0 :e R_standard_basis) (x :e b0 /\ b0 c= U) Hb0pair). }
        claim Hxb0 : x :e b0.
        { exact (andEL (x :e b0) (b0 c= U) Hb0prop). }
        claim Hb0subU : b0 c= U.
        { exact (andER (x :e b0) (b0 c= U) Hb0prop). }
        witness b0.
        apply andI.
        - exact (binunionI1 R_standard_basis R_K_basis b0 Hb0Std).
        - apply andI.
          + exact Hxb0.
          + exact Hb0subU. }
      exact (SepI (Power R)
                  (fun U0 : set => forall x0 :e U0, exists b0 :e (R_standard_basis :\/: R_K_basis), x0 :e b0 /\ b0 c= U0)
                  U
                  HUinPow
                  HUpropK).
  + prove finer_than R_standard_topology R_finite_complement_topology.
    (** finer_than T' T means T c= T' **)
    prove R_finite_complement_topology c= R_standard_topology.
    let U. assume HU : U :e R_finite_complement_topology.
    (** Unpack membership in finite_complement_topology R **)
    claim HUpow : U :e Power R.
    { exact (SepE1 (Power R)
                   (fun U0 : set => finite (R :\: U0) \/ U0 = Empty)
                   U
                   HU). }
    claim HUsub : U c= R.
    { exact (PowerE R U HUpow). }
    claim HUcases : finite (R :\: U) \/ U = Empty.
    { exact (SepE2 (Power R)
                   (fun U0 : set => finite (R :\: U0) \/ U0 = Empty)
                   U
                   HU). }
    apply (HUcases (U :e R_standard_topology)).
    - assume HFin : finite (R :\: U).
      prove U :e R_standard_topology.
      claim HFsubR : (R :\: U) c= R.
      { exact (setminus_Subq R U). }
      claim Hopen : R :\: (R :\: U) :e R_standard_topology.
      { exact (finite_complement_open_in_R_standard_topology (R :\: U) HFin HFsubR). }
      rewrite <- (setminus_setminus_eq R U HUsub).
      exact Hopen.
    - assume HUe : U = Empty.
      rewrite HUe.
      exact (topology_has_empty R R_standard_topology (R_standard_topology_is_topology_local)).
- prove finer_than R_standard_topology R_ray_topology.
  let U. assume HU: U :e R_ray_topology.
  claim HUcases : U = Empty \/ U = R \/ exists a :e R, U = {x :e R|Rlt x a}.
  { exact (SepE2 (Power R) (fun U0 : set => U0 = Empty \/ U0 = R \/ exists a0 :e R, U0 = {x :e R|Rlt x a0}) U HU). }
  claim Hempty : Empty :e R_standard_topology.
  { exact (SepI (Power R)
                (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                Empty
                (Empty_In_Power R)
                (fun x0 Hx0 => EmptyE x0 Hx0 (exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= Empty))). }
  claim Hall : R :e R_standard_topology.
  { claim HRpow : R :e Power R.
    { apply PowerI.
      exact (Subq_ref R). }
    claim HRprop : forall x :e R, exists b0 :e R_standard_basis, x :e b0 /\ b0 c= R.
    { let x. assume HxR.
      set a0 := add_SNo x (minus_SNo 1).
      set b0 := add_SNo x 1.
      set I := open_interval a0 b0.
      claim Hm1R : minus_SNo 1 :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim Ha0R : a0 :e R.
      { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
      claim Hb0R : b0 :e R.
      { exact (real_add_SNo x HxR 1 real_1). }
      claim HxS : SNo x.
      { exact (real_SNo x HxR). }
      claim Hm1S : SNo (minus_SNo 1).
      { exact (real_SNo (minus_SNo 1) Hm1R). }
      claim Ha0lt : a0 < x.
      { claim Hlt : a0 < add_SNo x 0.
        { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
        rewrite <- (add_SNo_0R x HxS) at 2.
        exact Hlt. }
      claim Hxb0 : x < b0.
      { claim Hlt : add_SNo x 0 < b0.
        { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 (real_SNo 1 real_1) SNoLt_0_1). }
        rewrite <- (add_SNo_0R x HxS) at 1.
        exact Hlt. }
      claim HxInI : x :e I.
      { claim Hax : Rlt a0 x.
        { exact (RltI a0 x Ha0R HxR Ha0lt). }
        claim Hxb : Rlt x b0.
        { exact (RltI x b0 HxR Hb0R Hxb0). }
        claim Hconj : Rlt a0 x /\ Rlt x b0.
        { apply andI.
          - exact Hax.
          - exact Hxb. }
        exact (SepI R (fun x0 : set => Rlt a0 x0 /\ Rlt x0 b0) x HxR Hconj). }
      claim HIStd : I :e R_standard_basis.
      { claim HIa : I :e {open_interval a0 bb|bb :e R}.
        { exact (ReplI R (fun bb : set => open_interval a0 bb) b0 Hb0R). }
        exact (famunionI R
                         (fun aa : set => {open_interval aa bb|bb :e R})
                         a0
                         I
                         Ha0R
                         HIa). }
      witness I.
      apply andI.
      - exact HIStd.
      - apply andI.
        + exact HxInI.
        + exact (open_interval_Subq_R a0 b0). }
    exact (SepI (Power R)
                (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                R
                HRpow
                HRprop). }
  claim Hcase1 : U = Empty -> U :e R_standard_topology.
  { assume Heq. rewrite Heq. exact Hempty. }
  claim Hcase2 : U = R -> U :e R_standard_topology.
  { assume Heq. rewrite Heq. exact Hall. }
  claim Hcase3 : (exists a0 :e R, U = {x :e R|Rlt x a0}) -> U :e R_standard_topology.
  { assume Hex.
    apply Hex.
    let a0.
    assume Ha0pair : a0 :e R /\ U = {x :e R|Rlt x a0}.
    claim Ha0R : a0 :e R.
    { exact (andEL (a0 :e R) (U = {x :e R|Rlt x a0}) Ha0pair). }
    claim Heq : U = {x :e R|Rlt x a0}.
    { exact (andER (a0 :e R) (U = {x :e R|Rlt x a0}) Ha0pair). }
    rewrite Heq.
    exact (open_left_ray_in_R_standard_topology a0 Ha0R). }
  prove U :e R_standard_topology.
  apply (HUcases (U :e R_standard_topology)).
  - assume HUR : U = Empty \/ U = R.
    apply (HUR (U :e R_standard_topology)).
    + exact Hcase1.
    + exact Hcase2.
  - exact Hcase3.
Qed.

(** from §13 Exercise 8(a): rational open intervals generate standard topology on ℝ **) 
(** LATEX VERSION: Exercise 8(a): Basis of rational open intervals generates the standard topology on ℝ. **)
Definition rational_open_intervals_basis : set :=
  \/_ q1 :e rational_numbers, {open_interval q1 q2|q2 :e rational_numbers}.

(** from §13 Exercise 8(a): rational open intervals are standard open intervals **)
(** LATEX VERSION: Any rational open interval (q1,q2) is a standard basis element since q1,q2 are real. **)
Theorem rational_open_intervals_basis_Subq_R_standard_basis :
  rational_open_intervals_basis c= R_standard_basis.
prove rational_open_intervals_basis c= R_standard_basis.
let I. assume HI: I :e rational_open_intervals_basis.
apply (famunionE_impred rational_numbers
         (fun q1 : set => {open_interval q1 q2|q2 :e rational_numbers})
         I
         HI
         (I :e R_standard_basis)).
let q1. assume Hq1Q HIq1.
apply (ReplE_impred rational_numbers
         (fun q2 : set => open_interval q1 q2)
         I
         HIq1
         (I :e R_standard_basis)).
let q2. assume Hq2Q Heq.
rewrite Heq.
claim Hq1R : q1 :e R.
{ exact (rational_numbers_in_R q1 Hq1Q). }
claim Hq2R : q2 :e R.
{ exact (rational_numbers_in_R q2 Hq2Q). }
claim HIq2 : open_interval q1 q2 :e {open_interval q1 b|b :e R}.
{ exact (ReplI R (fun b : set => open_interval q1 b) q2 Hq2R). }
exact (famunionI R (fun a : set => {open_interval a b|b :e R}) q1 (open_interval q1 q2) Hq1R HIq2).
Qed.

(** from §13 Exercise 8(a): density of rationals in reals (in order sense) **)
(** LATEX VERSION: Between any two real numbers a<b there exists a rational q with a<q<b. **)
Theorem rational_dense_between_reals : forall a b:set,
  a :e R -> b :e R -> Rlt a b ->
  exists q :e rational_numbers, Rlt a q /\ Rlt q b.
let a b.
assume HaR HbR Hab.
prove exists q :e rational_numbers, Rlt a q /\ Rlt q b.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hablt: a < b.
{ exact (RltE_lt a b Hab). }
claim HmaR: minus_SNo a :e R.
{ exact (real_minus_SNo a HaR). }
claim HmaS: SNo (minus_SNo a).
{ exact (real_SNo (minus_SNo a) HmaR). }
set d := add_SNo b (minus_SNo a).
claim HdDef: d = add_SNo b (minus_SNo a).
{ reflexivity. }
claim HdR: d :e R.
{ rewrite HdDef.
  exact (real_add_SNo b HbR (minus_SNo a) HmaR). }
claim HdS: SNo d.
{ exact (real_SNo d HdR). }
claim H0ltd: 0 < d.
{ rewrite HdDef.
  claim Hlt: add_SNo a (minus_SNo a) < add_SNo b (minus_SNo a).
  { exact (add_SNo_Lt1 a (minus_SNo a) b HaS HmaS HbS Hablt). }
  claim H0eq: add_SNo a (minus_SNo a) = 0.
  { exact (add_SNo_minus_SNo_rinv a HaS). }
  rewrite <- H0eq.
  exact Hlt. }
(** choose N with eps_N < d using invd = 1/d and a bounded eps product **)
set invd := recip_SNo_pos d.
claim HinvdDef: invd = recip_SNo_pos d.
{ reflexivity. }
claim HinvdR: invd :e R.
{ rewrite HinvdDef.
  exact (real_recip_SNo_pos d HdR H0ltd). }
claim HinvdS: SNo invd.
{ exact (real_SNo invd HinvdR). }
claim Hinvdpos: 0 < invd.
{ exact (recip_SNo_pos_is_pos d HdS H0ltd). }
claim HexN: exists N :e omega, eps_ N < d.
{ apply (real_E invd HinvdR (exists N :e omega, eps_ N < d)).
  assume HinvS: SNo invd.
  assume Hlev.
  assume HinS.
  assume Hlow.
  assume Hup.
  assume Huniq.
  assume Happrox.
  claim HexNlt: exists N :e omega, mul_SNo (eps_ N) invd < 1.
  { exact (SNoS_ordsucc_omega_bdd_eps_pos invd HinS Hinvdpos Hup). }
  apply HexNlt.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
  claim HmulLt: mul_SNo (eps_ N) invd < 1.
  { exact (andER (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
  witness N.
  apply andI.
  - exact HNomega.
  - claim HepsS: SNo (eps_ N).
    { exact (SNo_eps_ N HNomega). }
    (** eps_N < 1/:/invd, then 1/:/invd = d **)
    claim HepsLtDiv: eps_ N < div_SNo 1 invd.
    { exact (div_SNo_pos_LtR 1 invd (eps_ N) SNo_1 HinvS HepsS Hinvdpos HmulLt). }
    claim HdivEq: div_SNo 1 invd = d.
    { claim Hposcase: recip_SNo invd = recip_SNo_pos invd.
      { exact (recip_SNo_poscase invd Hinvdpos). }
      claim HrecipInv: recip_SNo_pos invd = d.
      { rewrite HinvdDef.
        exact (recip_SNo_pos_invol d HdS H0ltd). }
      claim HdivDef: div_SNo 1 invd = mul_SNo 1 (recip_SNo invd).
      { reflexivity. }
      rewrite HdivDef.
      rewrite Hposcase.
      rewrite HrecipInv.
      exact (mul_SNo_oneL d HdS). }
    rewrite <- HdivEq.
    exact HepsLtDiv.
}
apply HexN.
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (eps_ N < d) HNpair). }
claim HepsNlt: eps_ N < d.
{ exact (andER (N :e omega) (eps_ N < d) HNpair). }
(** approximate b from below within eps_N using real_E, then show the approximant lies above a **)
claim Hexq: exists q :e SNoS_ omega, q < b /\ b < add_SNo q (eps_ N).
{ apply (real_E b HbR (exists q :e SNoS_ omega, q < b /\ b < add_SNo q (eps_ N))).
  assume HbS': SNo b.
  assume Hlev.
  assume HbInS.
  assume Hlow.
  assume Hup.
  assume Huniq.
  assume Happrox.
  exact (Happrox N HNomega). }
apply Hexq.
let q. assume Hqpair. apply Hqpair.
assume HqInS: q :e SNoS_ omega.
assume Hqprop: q < b /\ b < add_SNo q (eps_ N).
claim Hqltb: q < b.
{ exact (andEL (q < b) (b < add_SNo q (eps_ N)) Hqprop). }
claim Hbltqeps: b < add_SNo q (eps_ N).
{ exact (andER (q < b) (b < add_SNo q (eps_ N)) Hqprop). }
claim HqRat: q :e rational_numbers.
{ exact (Subq_SNoS_omega_rational q HqInS). }
claim HqR: q :e R.
{ exact (rational_numbers_in_R q HqRat). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim HepsR: eps_ N :e R.
{ exact (rational_numbers_in_R (eps_ N) (Subq_SNoS_omega_rational (eps_ N) (SNo_eps_SNoS_omega N HNomega))). }
claim HepsS: SNo (eps_ N).
{ exact (real_SNo (eps_ N) HepsR). }
claim Hbmepsltq: add_SNo b (minus_SNo (eps_ N)) < q.
{ exact (add_SNo_minus_Lt1b b (eps_ N) q HbS HepsS HqS Hbltqeps). }
claim Haepsltb: add_SNo a (eps_ N) < b.
{ prove add_SNo a (eps_ N) < b.
  claim Hlt1: add_SNo (eps_ N) a < add_SNo d a.
  { exact (add_SNo_Lt1 (eps_ N) a d HepsS HaS HdS HepsNlt). }
  claim Hdplus: add_SNo d a = b.
  { rewrite HdDef.
    exact (add_SNo_minus_R2' b a HbS HaS). }
  claim Hcom: add_SNo (eps_ N) a = add_SNo a (eps_ N).
  { exact (add_SNo_com (eps_ N) a HepsS HaS). }
  rewrite <- Hcom.
  rewrite <- Hdplus.
  exact Hlt1. }
claim Haltbmeps: a < add_SNo b (minus_SNo (eps_ N)).
{ exact (add_SNo_minus_Lt2b b (eps_ N) a HbS HepsS HaS Haepsltb). }
claim HbmepsS: SNo (add_SNo b (minus_SNo (eps_ N))).
{ exact (SNo_add_SNo b (minus_SNo (eps_ N)) HbS (SNo_minus_SNo (eps_ N) HepsS)). }
claim Hqlt: a < q.
{ exact (SNoLt_tra a (add_SNo b (minus_SNo (eps_ N))) q HaS HbmepsS HqS Haltbmeps Hbmepsltq). }
claim Haq: Rlt a q.
{ exact (RltI a q HaR HqR Hqlt). }
claim Hqb: Rlt q b.
{ exact (RltI q b HqR HbR Hqltb). }
witness q.
apply andI.
- exact HqRat.
- apply andI.
  - exact Haq.
  - exact Hqb.
Qed.

(** from §13 Exercise 8(a): rational endpoints around a point in a real open interval **)
(** LATEX VERSION: If x is in (a,b) then there are rationals q1,q2 with q1<x<q2 and (q1,q2) contained in (a,b). **)
Theorem rational_interval_refines_real_interval : forall a b x:set,
  a :e R -> b :e R -> x :e R ->
  x :e open_interval a b ->
  exists q1 :e rational_numbers, exists q2 :e rational_numbers,
    x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a b.
let a b x.
assume HaR HbR HxR HxInab.
claim HxabProp: Rlt a x /\ Rlt x b.
{ exact (SepE2 R (fun z : set => Rlt a z /\ Rlt z b) x HxInab). }
claim Hax: Rlt a x.
{ exact (andEL (Rlt a x) (Rlt x b) HxabProp). }
claim Hxb: Rlt x b.
{ exact (andER (Rlt a x) (Rlt x b) HxabProp). }
(** choose q1 rational with a<q1<x **)
apply (rational_dense_between_reals a x HaR HxR Hax).
let q1. assume Hq1pair. apply Hq1pair.
assume Hq1Q: q1 :e rational_numbers.
assume Hq1Prop: Rlt a q1 /\ Rlt q1 x.
claim Hq1R: q1 :e R.
{ exact (rational_numbers_in_R q1 Hq1Q). }
claim Haq1: Rlt a q1.
{ exact (andEL (Rlt a q1) (Rlt q1 x) Hq1Prop). }
claim Hq1x: Rlt q1 x.
{ exact (andER (Rlt a q1) (Rlt q1 x) Hq1Prop). }
(** choose q2 rational with x<q2<b **)
apply (rational_dense_between_reals x b HxR HbR Hxb).
let q2. assume Hq2pair. apply Hq2pair.
assume Hq2Q: q2 :e rational_numbers.
assume Hq2Prop: Rlt x q2 /\ Rlt q2 b.
claim Hq2R: q2 :e R.
{ exact (rational_numbers_in_R q2 Hq2Q). }
claim Hxq2: Rlt x q2.
{ exact (andEL (Rlt x q2) (Rlt q2 b) Hq2Prop). }
claim Hq2b: Rlt q2 b.
{ exact (andER (Rlt x q2) (Rlt q2 b) Hq2Prop). }
(** witness the rational interval (q1,q2) around x **)
witness q1.
apply andI.
- exact Hq1Q.
- witness q2.
  apply andI.
  * exact Hq2Q.
  * apply andI.
    { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxR
                   (andI (Rlt q1 x) (Rlt x q2) Hq1x Hxq2)). }
    { let y. assume Hy: y :e open_interval q1 q2.
      prove y :e open_interval a b.
      claim HyR: y :e R.
      { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z q2) y Hy). }
      claim HyProp: Rlt q1 y /\ Rlt y q2.
      { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) y Hy). }
      claim Hq1y: Rlt q1 y.
      { exact (andEL (Rlt q1 y) (Rlt y q2) HyProp). }
      claim Hyq2: Rlt y q2.
      { exact (andER (Rlt q1 y) (Rlt y q2) HyProp). }
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim Hq1S: SNo q1.
      { exact (real_SNo q1 Hq1R). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim Hq2S: SNo q2.
      { exact (real_SNo q2 Hq2R). }
      claim Haq1lt: a < q1.
      { exact (RltE_lt a q1 Haq1). }
      claim Hq1ylt: q1 < y.
      { exact (RltE_lt q1 y Hq1y). }
      claim Hyq2lt: y < q2.
      { exact (RltE_lt y q2 Hyq2). }
      claim Hq2blt: q2 < b.
      { exact (RltE_lt q2 b Hq2b). }
      claim Haylt: a < y.
      { exact (SNoLt_tra a q1 y HaS Hq1S HyS Haq1lt Hq1ylt). }
      claim Hyblt: y < b.
      { exact (SNoLt_tra y q2 b HyS Hq2S HbS Hyq2lt Hq2blt). }
      claim Hay: Rlt a y.
      { exact (RltI a y HaR HyR Haylt). }
      claim Hyb: Rlt y b.
      { exact (RltI y b HyR HbR Hyblt). }
      claim Hconj: Rlt a y /\ Rlt y b.
      { apply andI.
        - exact Hay.
        - exact Hyb. }
      exact (SepI R (fun z : set => Rlt a z /\ Rlt z b) y HyR Hconj). }
Qed.

Theorem ex13_8a_rational_intervals_basis_standard :
  basis_on R rational_open_intervals_basis /\
  generated_topology R rational_open_intervals_basis = R_standard_topology.
prove basis_on R rational_open_intervals_basis /\ generated_topology R rational_open_intervals_basis = R_standard_topology.
(** NOTE: This needs a density lemma for `rational_numbers` in `R`; a route is to use `real_E` to approximate reals by elements of `SNoS_ omega` and then `Subq_SNoS_omega_rational`, plus an inequality bridge using `eps_ k`. **)
apply andI.
- (** rational open intervals satisfy basis_on R (partial: subset property) **)
  prove rational_open_intervals_basis c= Power R
    /\ (forall x :e R, exists b :e rational_open_intervals_basis, x :e b)
    /\ (forall b1 :e rational_open_intervals_basis, forall b2 :e rational_open_intervals_basis, forall x:set,
          x :e b1 -> x :e b2 ->
          exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2).
  apply andI.
  - prove rational_open_intervals_basis c= Power R /\ (forall x :e R, exists b :e rational_open_intervals_basis, x :e b).
    apply andI.
    + (** every rational open interval is a subset of R **)
      prove rational_open_intervals_basis c= Power R.
      let b. assume Hb: b :e rational_open_intervals_basis.
      prove b :e Power R.
      apply (famunionE_impred rational_numbers
               (fun q1 : set => {open_interval q1 q2|q2 :e rational_numbers})
               b
               Hb
               (b :e Power R)).
      let q1. assume Hq1 Hbq1.
      apply (ReplE_impred rational_numbers
               (fun q2 : set => open_interval q1 q2)
               b
               Hbq1
               (b :e Power R)).
	      let q2. assume Hq2 Heq.
	      rewrite Heq.
	      exact (PowerI R (open_interval q1 q2) (open_interval_Subq_R q1 q2)).
	    + (** coverage of R by rational open intervals **)
	      let x. assume HxR.
	      set a0 := add_SNo x (minus_SNo 1).
	      set b0 := add_SNo x 1.
	      claim Hm1R : minus_SNo 1 :e R.
	      { exact (real_minus_SNo 1 real_1). }
	      claim Ha0R : a0 :e R.
	      { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
	      claim Hb0R : b0 :e R.
	      { exact (real_add_SNo x HxR 1 real_1). }
	      claim HxInI : x :e open_interval a0 b0.
	      { exact (real_in_open_interval_minus1_plus1 x HxR). }
	      claim HexRat : exists q1 :e rational_numbers, exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      { exact (rational_interval_refines_real_interval a0 b0 x Ha0R Hb0R HxR HxInI). }
	      apply HexRat.
	      let q1. assume Hq1pair. apply Hq1pair.
	      assume Hq1: q1 :e rational_numbers.
	      assume Hexq2: exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      apply Hexq2.
	      let q2. assume Hq2pair. apply Hq2pair.
	      assume Hq2: q2 :e rational_numbers.
	      assume HxInQ : x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      claim HxInQint : x :e open_interval q1 q2.
	      { exact (andEL (x :e open_interval q1 q2) (open_interval q1 q2 c= open_interval a0 b0) HxInQ). }
	      witness (open_interval q1 q2).
	      apply andI.
	      * (** open_interval q1 q2 is in the rational-open-interval basis **)
	        claim Hq2fam : open_interval q1 q2 :e {open_interval q1 q2'|q2' :e rational_numbers}.
	        { exact (ReplI rational_numbers (fun q2' : set => open_interval q1 q2') q2 Hq2). }
	        exact (famunionI rational_numbers
	                 (fun q1' : set => {open_interval q1' q2'|q2' :e rational_numbers})
	                 q1
	                 (open_interval q1 q2)
	                 Hq1
	                 Hq2fam).
	      * exact HxInQint.
	  - (** intersection refinement using rational endpoints **)
	    let b1. assume Hb1.
	    let b2. assume Hb2.
	    let x. assume Hx1 Hx2.
	    prove exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2.
	    (** destruct b1 = open_interval q1 q2 with q1,q2 rationals **)
	    claim Hexq1 : exists q1 :e rational_numbers, b1 :e {open_interval q1 q2|q2 :e rational_numbers}.
	    { exact (famunionE rational_numbers (fun q1 : set => {open_interval q1 q2|q2 :e rational_numbers}) b1 Hb1). }
	    apply Hexq1.
	    let q1. assume Hq1pair. apply Hq1pair.
	    assume Hq1Q : q1 :e rational_numbers.
	    assume Hb1fam : b1 :e {open_interval q1 q2|q2 :e rational_numbers}.
	    claim Hexq2 : exists q2 :e rational_numbers, b1 = open_interval q1 q2.
	    { exact (ReplE rational_numbers (fun q2 : set => open_interval q1 q2) b1 Hb1fam). }
	    apply Hexq2.
	    let q2. assume Hq2pair. apply Hq2pair.
	    assume Hq2Q : q2 :e rational_numbers.
	    assume Hb1eq : b1 = open_interval q1 q2.
	    (** destruct b2 = open_interval r1 r2 with r1,r2 rationals **)
	    claim Hexr1 : exists r1 :e rational_numbers, b2 :e {open_interval r1 r2|r2 :e rational_numbers}.
	    { exact (famunionE rational_numbers (fun r1 : set => {open_interval r1 r2|r2 :e rational_numbers}) b2 Hb2). }
	    apply Hexr1.
	    let r1. assume Hr1pair. apply Hr1pair.
	    assume Hr1Q : r1 :e rational_numbers.
	    assume Hb2fam : b2 :e {open_interval r1 r2|r2 :e rational_numbers}.
	    claim Hexr2 : exists r2 :e rational_numbers, b2 = open_interval r1 r2.
	    { exact (ReplE rational_numbers (fun r2 : set => open_interval r1 r2) b2 Hb2fam). }
	    apply Hexr2.
	    let r2. assume Hr2pair. apply Hr2pair.
	    assume Hr2Q : r2 :e rational_numbers.
	    assume Hb2eq : b2 = open_interval r1 r2.
	    (** x in the two intervals **)
	    claim HxIn1 : x :e open_interval q1 q2.
	    { rewrite <- Hb1eq. exact Hx1. }
	    claim HxIn2 : x :e open_interval r1 r2.
	    { rewrite <- Hb2eq. exact Hx2. }
	    claim HxR : x :e R.
	    { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxIn1). }
	    claim HxProp1 : Rlt q1 x /\ Rlt x q2.
	    { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxIn1). }
	    claim HxProp2 : Rlt r1 x /\ Rlt x r2.
	    { exact (SepE2 R (fun z : set => Rlt r1 z /\ Rlt z r2) x HxIn2). }
	    claim Hq1x : Rlt q1 x.
	    { exact (andEL (Rlt q1 x) (Rlt x q2) HxProp1). }
	    claim Hxq2 : Rlt x q2.
	    { exact (andER (Rlt q1 x) (Rlt x q2) HxProp1). }
	    claim Hr1x : Rlt r1 x.
	    { exact (andEL (Rlt r1 x) (Rlt x r2) HxProp2). }
	    claim Hxr2 : Rlt x r2.
	    { exact (andER (Rlt r1 x) (Rlt x r2) HxProp2). }
	    (** endpoint types **)
	    claim Hq1R : q1 :e R.
	    { exact (rational_numbers_in_R q1 Hq1Q). }
	    claim Hq2R : q2 :e R.
	    { exact (rational_numbers_in_R q2 Hq2Q). }
	    claim Hr1R : r1 :e R.
	    { exact (rational_numbers_in_R r1 Hr1Q). }
	    claim Hr2R : r2 :e R.
	    { exact (rational_numbers_in_R r2 Hr2Q). }
	    claim Hq1S : SNo q1.
	    { exact (real_SNo q1 Hq1R). }
	    claim Hq2S : SNo q2.
	    { exact (real_SNo q2 Hq2R). }
	    claim Hr1S : SNo r1.
	    { exact (real_SNo r1 Hr1R). }
	    claim Hr2S : SNo r2.
	    { exact (real_SNo r2 Hr2R). }
	    claim HxS : SNo x.
	    { exact (real_SNo x HxR). }
	    claim Hq1xlt : q1 < x.
	    { exact (RltE_lt q1 x Hq1x). }
	    claim Hr1xlt : r1 < x.
	    { exact (RltE_lt r1 x Hr1x). }
	    claim Hxq2lt : x < q2.
	    { exact (RltE_lt x q2 Hxq2). }
	    claim Hxr2lt : x < r2.
	    { exact (RltE_lt x r2 Hxr2). }
	    (** choose max left endpoint and min right endpoint by trichotomy **)
	    apply (SNoLt_trichotomy_or_impred q1 r1 Hq1S Hr1S
	             (exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	    - assume Hq1lt : q1 < r1.
	      (** left endpoint r1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        (** right endpoint q2 **)
	        set I3 := open_interval r1 q2.
	        witness I3.
	        apply andI.
	        * (** I3 in basis **)
	          claim HI3fam : I3 :e {open_interval r1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval r1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { (** x in I3 **)
	            claim Hr1xRlt : Rlt r1 x.
	            { exact Hr1x. }
	            claim Hxq2Rlt : Rlt x q2.
	            { exact Hxq2. }
	            exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z q2) x HxR
	                         (andI (Rlt r1 x) (Rlt x q2) Hr1xRlt Hxq2Rlt)). }
	          { (** I3 subset b1 ∩ b2 **)
	            let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt r1 z /\ Rlt z q2) y HyI3). }
	            claim HyProp : Rlt r1 y /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => Rlt r1 z /\ Rlt z q2) y HyI3). }
	            claim Hr1y : Rlt r1 y.
	            { exact (andEL (Rlt r1 y) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (Rlt r1 y) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hr1ylt : r1 < y.
	            { exact (RltE_lt r1 y Hr1y). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            (** y in b2 = (r1,r2) since q2<r2 **)
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
	                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            (** y in b1 = (q1,q2) since q1<r1 **)
	            claim Hq1ylt : q1 < y.
	            { exact (SNoLt_tra q1 r1 y Hq1S Hr1S HyS Hq1lt Hr1ylt). }
	            claim Hq1y : Rlt q1 y.
	            { exact (RltI q1 y Hq1R HyR Hq1ylt). }
	            claim HyIn1 : y :e open_interval q1 q2.
	            { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyR
	                         (andI (Rlt q1 y) (Rlt y q2) Hq1y Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := open_interval r1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval r1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval r1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z q2) x HxR
	                         (andI (Rlt r1 x) (Rlt x q2) Hr1x Hxq2)). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt r1 z /\ Rlt z q2) y HyI3). }
	            claim HyProp : Rlt r1 y /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => Rlt r1 z /\ Rlt z q2) y HyI3). }
	            claim Hr1y : Rlt r1 y.
	            { exact (andEL (Rlt r1 y) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (Rlt r1 y) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hr1ylt : r1 < y.
	            { exact (RltE_lt r1 y Hr1y). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            (** y in b2 using r2=q2 **)
	            claim Hyr2 : Rlt y r2.
	            { rewrite <- Hq2eq. exact Hyq2. }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
	                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            (** y in b1 since q1<r1 **)
	            claim Hq1ylt : q1 < y.
	            { exact (SNoLt_tra q1 r1 y Hq1S Hr1S HyS Hq1lt Hr1ylt). }
	            claim Hq1y : Rlt q1 y.
	            { exact (RltI q1 y Hq1R HyR Hq1ylt). }
	            claim HyIn1 : y :e open_interval q1 q2.
	            { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyR
	                         (andI (Rlt q1 y) (Rlt y q2) Hq1y Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        (** right endpoint r2 **)
	        set I3 := open_interval r1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval r1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval r1 qq) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) x HxR
	                         (andI (Rlt r1 x) (Rlt x r2) Hr1x Hxr2)). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyI3). }
	            claim HyProp : Rlt r1 y /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyI3). }
	            claim Hr1y : Rlt r1 y.
	            { exact (andEL (Rlt r1 y) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (Rlt r1 y) (Rlt y r2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hr1ylt : r1 < y.
	            { exact (RltE_lt r1 y Hr1y). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            (** y in b1: need y<q2 since r2<q2 **)
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim Hq1ylt : q1 < y.
	            { exact (SNoLt_tra q1 r1 y Hq1S Hr1S HyS Hq1lt Hr1ylt). }
	            claim Hq1y : Rlt q1 y.
	            { exact (RltI q1 y Hq1R HyR Hq1ylt). }
	            claim HyIn1 : y :e open_interval q1 q2.
	            { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyR
	                         (andI (Rlt q1 y) (Rlt y q2) Hq1y Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            (** y in b2 = (r1,r2) **)
	            claim HyIn2 : y :e open_interval r1 r2.
	            { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
	                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	    - assume Hq1eq : q1 = r1.
	      (** left endpoint q1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        set I3 := open_interval q1 q2.
	        witness I3.
	        apply andI.
	        * (** I3 in basis **)
	          claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxR HxProp1). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            (** y in b1 directly **)
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            (** y in b2 since r1=q1 and q2<r2 **)
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim HyProp : Rlt q1 y /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim Hqy : Rlt q1 y.
	            { exact (andEL (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { rewrite <- Hq1eq.
	              exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyR
	                           (andI (Rlt q1 y) (Rlt y r2) Hqy Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := open_interval q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxR HxProp1). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. rewrite <- Hq1eq. rewrite <- Hq2eq. exact HyI3. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        set I3 := open_interval q1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z r2) x HxR
	                         (andI (Rlt q1 x) (Rlt x r2) Hq1x Hxr2)). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyI3). }
	            claim HyProp : Rlt q1 y /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyI3). }
	            claim Hq1y : Rlt q1 y.
	            { exact (andEL (Rlt q1 y) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (Rlt q1 y) (Rlt y r2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim HyIn1 : y :e open_interval q1 q2.
	            { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyR
	                         (andI (Rlt q1 y) (Rlt y q2) Hq1y Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { rewrite <- Hq1eq.
	              exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyR
	                           (andI (Rlt q1 y) (Rlt y r2) Hq1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	    - assume Hr1lt : r1 < q1.
	      (** left endpoint q1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_open_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        set I3 := open_interval q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxR HxProp1). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            (** y in b1 directly **)
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            (** y in b2 since r1<q1 and q2<r2 **)
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim HyProp : Rlt q1 y /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim Hq1y : Rlt q1 y.
	            { exact (andEL (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hq1ylt : q1 < y.
	            { exact (RltE_lt q1 y Hq1y). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            claim Hr1ylt : r1 < y.
	            { exact (SNoLt_tra r1 q1 y Hr1S Hq1S HyS Hr1lt Hq1ylt). }
	            claim Hr1y : Rlt r1 y.
	            { exact (RltI r1 y Hr1R HyR Hr1ylt). }
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
	                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := open_interval q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxR HxProp1). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            (** y in b2 using r2=q2 and r1<q1 **)
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim HyProp : Rlt q1 y /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyI3). }
	            claim Hq1y : Rlt q1 y.
	            { exact (andEL (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (Rlt q1 y) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hq1ylt : q1 < y.
	            { exact (RltE_lt q1 y Hq1y). }
	            claim Hr1ylt : r1 < y.
	            { exact (SNoLt_tra r1 q1 y Hr1S Hq1S HyS Hr1lt Hq1ylt). }
	            claim Hr1y : Rlt r1 y.
	            { exact (RltI r1 y Hr1R HyR Hr1ylt). }
	            claim Hyr2 : Rlt y r2.
	            { rewrite <- Hq2eq. exact Hyq2. }
	            claim HyIn2 : y :e open_interval r1 r2.
	            { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
	                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        set I3 := open_interval q1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {open_interval q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => open_interval q1 qq) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {open_interval aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z r2) x HxR
	                         (andI (Rlt q1 x) (Rlt x r2) Hq1x Hxr2)). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyI3). }
	            claim HyProp : Rlt q1 y /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z r2) y HyI3). }
	            claim Hq1y : Rlt q1 y.
	            { exact (andEL (Rlt q1 y) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (Rlt q1 y) (Rlt y r2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hq1ylt : q1 < y.
	            { exact (RltE_lt q1 y Hq1y). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim HyIn1 : y :e open_interval q1 q2.
	            { exact (SepI R (fun z : set => Rlt q1 z /\ Rlt z q2) y HyR
	                         (andI (Rlt q1 y) (Rlt y q2) Hq1y Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            (** y in b2 since r1<q1 and y<r2 **)
	            claim Hr1ylt : r1 < y.
	            { exact (SNoLt_tra r1 q1 y Hr1S Hq1S HyS Hr1lt Hq1ylt). }
		    claim Hr1y : Rlt r1 y.
		    { exact (RltI r1 y Hr1R HyR Hr1ylt). }
		    claim HyIn2 : y :e open_interval r1 r2.
		    { exact (SepI R (fun z : set => Rlt r1 z /\ Rlt z r2) y HyR
		                         (andI (Rlt r1 y) (Rlt y r2) Hr1y Hyr2)). }
		    claim Hyb2 : y :e b2.
		    { rewrite Hb2eq. exact HyIn2. }
		    exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	- (** generated_topology R rational_open_intervals_basis equals R_standard_topology **)
	  prove generated_topology R rational_open_intervals_basis = R_standard_topology.
	  (** R_standard_topology = generated_topology R R_standard_basis **)
	  apply set_ext.
	  + let U. assume HU: U :e generated_topology R rational_open_intervals_basis.
	    prove U :e R_standard_topology.
	    (** Unpack U membership in generated_topology R rational_open_intervals_basis **)
	    claim HUpow: U :e Power R.
	    { exact (SepE1 (Power R)
	             (fun U0 : set => forall x0 :e U0, exists b :e rational_open_intervals_basis, x0 :e b /\ b c= U0)
	             U
	             HU). }
	    claim HUprop: forall x0 :e U, exists b :e rational_open_intervals_basis, x0 :e b /\ b c= U.
	    { exact (SepE2 (Power R)
	             (fun U0 : set => forall x0 :e U0, exists b :e rational_open_intervals_basis, x0 :e b /\ b c= U0)
	             U
	             HU). }
	    (** Show U satisfies the standard-basis neighborhood property **)
	    prove U :e generated_topology R R_standard_basis.
	    prove U :e {U0 :e Power R | forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0}.
	    claim HUstdprop: forall x0 :e U, exists b :e R_standard_basis, x0 :e b /\ b c= U.
	    { let x. assume HxU: x :e U.
	      apply (HUprop x HxU).
	      let b. assume Hbpair.
	      claim HbB: b :e rational_open_intervals_basis.
	      { exact (andEL (b :e rational_open_intervals_basis) (x :e b /\ b c= U) Hbpair). }
	      claim Hbprop: x :e b /\ b c= U.
	      { exact (andER (b :e rational_open_intervals_basis) (x :e b /\ b c= U) Hbpair). }
	      claim Hxb: x :e b.
	      { exact (andEL (x :e b) (b c= U) Hbprop). }
	      claim HbsubU: b c= U.
	      { exact (andER (x :e b) (b c= U) Hbprop). }
	      claim HbStd: b :e R_standard_basis.
	      { exact (rational_open_intervals_basis_Subq_R_standard_basis b HbB). }
	      witness b.
	      apply andI.
	      - exact HbStd.
	      - apply andI.
	        + exact Hxb.
	        + exact HbsubU.
	    }
	    exact (SepI (Power R)
	            (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
	            U
	            HUpow
	            HUstdprop).
	  + let U. assume HU: U :e R_standard_topology.
	    prove U :e generated_topology R rational_open_intervals_basis.
	    (** Unpack U membership in R_standard_topology = generated_topology R R_standard_basis **)
	    claim HUpow: U :e Power R.
	    { exact (SepE1 (Power R)
	             (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
	             U
	             HU). }
	    claim HUprop: forall x0 :e U, exists b :e R_standard_basis, x0 :e b /\ b c= U.
	    { exact (SepE2 (Power R)
	             (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
	             U
	             HU). }
	    claim HUsubR: U c= R.
	    { exact (PowerE R U HUpow). }
	    prove U :e {U0 :e Power R | forall x0 :e U0, exists b :e rational_open_intervals_basis, x0 :e b /\ b c= U0}.
	    apply SepI.
	    - exact HUpow.
	    - let x. assume HxU: x :e U.
	      claim HxR: x :e R.
	      { exact (HUsubR x HxU). }
	      apply (HUprop x HxU).
	      let I. assume HIpair.
	      claim HIStd: I :e R_standard_basis.
	      { exact (andEL (I :e R_standard_basis) (x :e I /\ I c= U) HIpair). }
	      claim HIprop: x :e I /\ I c= U.
	      { exact (andER (I :e R_standard_basis) (x :e I /\ I c= U) HIpair). }
	      claim HxI: x :e I.
	      { exact (andEL (x :e I) (I c= U) HIprop). }
	      claim HIsubU: I c= U.
	      { exact (andER (x :e I) (I c= U) HIprop). }
	      (** Destruct I as an open_interval a b with a,b in R **)
	      claim Hexa: exists a :e R, I :e {open_interval a b|b :e R}.
	      { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) I HIStd). }
	      apply Hexa.
	      let a. assume Hapair. apply Hapair.
	      assume HaR: a :e R.
	      assume HIfam: I :e {open_interval a b|b :e R}.
	      claim Hexb: exists b :e R, I = open_interval a b.
	      { exact (ReplE R (fun b0 : set => open_interval a b0) I HIfam). }
	      apply Hexb.
	      let b. assume Hbpair. apply Hbpair.
	      assume HbR: b :e R.
	      assume HIeq: I = open_interval a b.
	      claim HxInab: x :e open_interval a b.
	      { rewrite <- HIeq. exact HxI. }
	      (** refine the real interval (a,b) to a rational interval around x **)
	      claim HexRat: exists q1 :e rational_numbers, exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a b.
	      { exact (rational_interval_refines_real_interval a b x HaR HbR HxR HxInab). }
	      apply HexRat.
	      let q1. assume Hq1pair. apply Hq1pair.
	      assume Hq1Q: q1 :e rational_numbers.
	      assume Hexq2: exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a b.
	      apply Hexq2.
	      let q2. assume Hq2pair. apply Hq2pair.
	      assume Hq2Q: q2 :e rational_numbers.
	      assume HxInQ: x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a b.
	      claim HxInQint: x :e open_interval q1 q2.
	      { exact (andEL (x :e open_interval q1 q2) (open_interval q1 q2 c= open_interval a b) HxInQ). }
	      claim HQsub: open_interval q1 q2 c= open_interval a b.
	      { exact (andER (x :e open_interval q1 q2) (open_interval q1 q2 c= open_interval a b) HxInQ). }
	      claim HabsubU: open_interval a b c= U.
	      { rewrite <- HIeq.
	        exact HIsubU. }
	      claim HQsubU: open_interval q1 q2 c= U.
	      { exact (Subq_tra (open_interval q1 q2) (open_interval a b) U HQsub HabsubU). }
	      (** show open_interval q1 q2 is in rational_open_intervals_basis **)
	      claim Hq2fam : open_interval q1 q2 :e {open_interval q1 q2'|q2' :e rational_numbers}.
	      { exact (ReplI rational_numbers (fun q2' : set => open_interval q1 q2') q2 Hq2Q). }
	      claim HbInB: open_interval q1 q2 :e rational_open_intervals_basis.
	      { exact (famunionI rational_numbers
	               (fun q1' : set => {open_interval q1' q2'|q2' :e rational_numbers})
	               q1
	               (open_interval q1 q2)
	               Hq1Q
	               Hq2fam). }
	      witness (open_interval q1 q2).
	      apply andI.
	      * exact HbInB.
	      * apply andI.
	        { exact HxInQint. }
	        { exact HQsubU. }
Qed.

(** from §13 Exercise 8(b): half-open rational intervals generate a different topology **) 
(** LATEX VERSION: Exercise 8(b): Half-open rational intervals form a basis whose generated topology differs from the lower limit topology. **)
Definition rational_halfopen_intervals_basis : set :=
  \/_ q1 :e rational_numbers, {halfopen_interval_left q1 q2|q2 :e rational_numbers}.

(** LATEX VERSION: The half-open rational basis generates a topology distinct from the lower limit topology. **)
Theorem ex13_8b_halfopen_rational_basis_topology :
  basis_on R rational_halfopen_intervals_basis /\
  generated_topology R rational_halfopen_intervals_basis <> R_lower_limit_topology.
prove basis_on R rational_halfopen_intervals_basis /\ generated_topology R rational_halfopen_intervals_basis <> R_lower_limit_topology.
(** NOTE: This needs density of rationals plus a separation argument showing the generated topology from halfopen rational intervals differs from the lower limit topology; as in (a), use `real_E` and `Subq_SNoS_omega_rational` once order and epsilon inequalities are available. **)
apply andI.
- (** rational half-open intervals satisfy basis_on R (partial: subset property) **)
  prove rational_halfopen_intervals_basis c= Power R
    /\ (forall x :e R, exists b :e rational_halfopen_intervals_basis, x :e b)
    /\ (forall b1 :e rational_halfopen_intervals_basis, forall b2 :e rational_halfopen_intervals_basis, forall x:set,
          x :e b1 -> x :e b2 ->
          exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2).
  apply andI.
  - prove rational_halfopen_intervals_basis c= Power R /\ (forall x :e R, exists b :e rational_halfopen_intervals_basis, x :e b).
    apply andI.
	    + (** every rational half-open interval is a subset of R **)
	      prove rational_halfopen_intervals_basis c= Power R.
      let b. assume Hb: b :e rational_halfopen_intervals_basis.
      prove b :e Power R.
      apply (famunionE_impred rational_numbers
               (fun q1 : set => {halfopen_interval_left q1 q2|q2 :e rational_numbers})
               b
               Hb
               (b :e Power R)).
      let q1. assume Hq1 Hbq1.
      apply (ReplE_impred rational_numbers
               (fun q2 : set => halfopen_interval_left q1 q2)
               b
               Hbq1
               (b :e Power R)).
      let q2. assume Hq2 Heq.
	      rewrite Heq.
	      exact (PowerI R (halfopen_interval_left q1 q2) (halfopen_interval_left_Subq_R q1 q2)).
	    + (** coverage of R by rational half-open intervals **)
	      prove forall x :e R, exists b :e rational_halfopen_intervals_basis, x :e b.
	      let x. assume HxR.
	      set a0 := add_SNo x (minus_SNo 1).
	      set b0 := add_SNo x 1.
	      claim Hm1R : minus_SNo 1 :e R.
	      { exact (real_minus_SNo 1 real_1). }
	      claim Ha0R : a0 :e R.
	      { exact (real_add_SNo x HxR (minus_SNo 1) Hm1R). }
	      claim Hb0R : b0 :e R.
	      { exact (real_add_SNo x HxR 1 real_1). }
	      claim HxInab : x :e open_interval a0 b0.
	      { exact (real_in_open_interval_minus1_plus1 x HxR). }
	      claim HexRat: exists q1 :e rational_numbers, exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      { exact (rational_interval_refines_real_interval a0 b0 x Ha0R Hb0R HxR HxInab). }
	      apply HexRat.
	      let q1. assume Hq1pair. apply Hq1pair.
	      assume Hq1Q: q1 :e rational_numbers.
	      assume Hexq2: exists q2 :e rational_numbers,
	        x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      apply Hexq2.
	      let q2. assume Hq2pair. apply Hq2pair.
	      assume Hq2Q: q2 :e rational_numbers.
	      assume Hxpair: x :e open_interval q1 q2 /\ open_interval q1 q2 c= open_interval a0 b0.
	      claim HxInQ : x :e open_interval q1 q2.
	      { exact (andEL (x :e open_interval q1 q2) (open_interval q1 q2 c= open_interval a0 b0) Hxpair). }
	      claim HxInQprop : Rlt q1 x /\ Rlt x q2.
	      { exact (SepE2 R (fun z : set => Rlt q1 z /\ Rlt z q2) x HxInQ). }
	      claim Hq1x : Rlt q1 x.
	      { exact (andEL (Rlt q1 x) (Rlt x q2) HxInQprop). }
	      claim Hxq2 : Rlt x q2.
	      { exact (andER (Rlt q1 x) (Rlt x q2) HxInQprop). }
	      set I := halfopen_interval_left q1 q2.
	      claim HIinFam : I :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
	      { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left q1 qq) q2 Hq2Q). }
	      claim HIinB : I :e rational_halfopen_intervals_basis.
	      { exact (famunionI rational_numbers
	               (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	               q1
	               I
	               Hq1Q
	               HIinFam). }
	      claim Hnxq1 : ~(Rlt x q1).
	      { assume Hxq1 : Rlt x q1.
	        claim HxS : SNo x.
	        { exact (real_SNo x HxR). }
	        claim Hq1R : q1 :e R.
	        { exact (rational_numbers_in_R q1 Hq1Q). }
	        claim Hq1S : SNo q1.
	        { exact (real_SNo q1 Hq1R). }
	        claim Hxq1lt : x < q1.
	        { exact (RltE_lt x q1 Hxq1). }
	        claim Hq1xlt : q1 < x.
	        { exact (RltE_lt q1 x Hq1x). }
	        claim Hxxlt : x < x.
	        { exact (SNoLt_tra x q1 x HxS Hq1S HxS Hxq1lt Hq1xlt). }
	        exact ((SNoLt_irref x) Hxxlt). }
	      claim HxInI : x :e I.
	      { claim Hconj : ~(Rlt x q1) /\ Rlt x q2.
	        { apply andI.
	          - exact Hnxq1.
	          - exact Hxq2. }
	        exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) x HxR Hconj). }
	      witness I.
	      apply andI.
	      * exact HIinB.
	      * exact HxInI.
		  - (** intersection refinement using rational endpoints **)
		    let b1. assume Hb1.
		    let b2. assume Hb2.
		    let x. assume Hx1 Hx2.
	    prove exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2.
	    (** destruct b1 = halfopen_interval_left q1 q2 with q1,q2 rationals **)
	    claim Hexq1 : exists q1 :e rational_numbers, b1 :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
	    { exact (famunionE rational_numbers (fun q1 : set => {halfopen_interval_left q1 q2|q2 :e rational_numbers}) b1 Hb1). }
	    apply Hexq1.
	    let q1. assume Hq1pair. apply Hq1pair.
	    assume Hq1Q : q1 :e rational_numbers.
	    assume Hb1fam : b1 :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
	    claim Hexq2 : exists q2 :e rational_numbers, b1 = halfopen_interval_left q1 q2.
	    { exact (ReplE rational_numbers (fun q2 : set => halfopen_interval_left q1 q2) b1 Hb1fam). }
	    apply Hexq2.
	    let q2. assume Hq2pair. apply Hq2pair.
	    assume Hq2Q : q2 :e rational_numbers.
	    assume Hb1eq : b1 = halfopen_interval_left q1 q2.
	    (** destruct b2 = halfopen_interval_left r1 r2 with r1,r2 rationals **)
	    claim Hexr1 : exists r1 :e rational_numbers, b2 :e {halfopen_interval_left r1 r2|r2 :e rational_numbers}.
	    { exact (famunionE rational_numbers (fun r1 : set => {halfopen_interval_left r1 r2|r2 :e rational_numbers}) b2 Hb2). }
	    apply Hexr1.
	    let r1. assume Hr1pair. apply Hr1pair.
	    assume Hr1Q : r1 :e rational_numbers.
	    assume Hb2fam : b2 :e {halfopen_interval_left r1 r2|r2 :e rational_numbers}.
	    claim Hexr2 : exists r2 :e rational_numbers, b2 = halfopen_interval_left r1 r2.
	    { exact (ReplE rational_numbers (fun r2 : set => halfopen_interval_left r1 r2) b2 Hb2fam). }
	    apply Hexr2.
	    let r2. assume Hr2pair. apply Hr2pair.
	    assume Hr2Q : r2 :e rational_numbers.
	    assume Hb2eq : b2 = halfopen_interval_left r1 r2.
	    (** x in the two half-open intervals **)
	    claim HxIn1 : x :e halfopen_interval_left q1 q2.
	    { rewrite <- Hb1eq. exact Hx1. }
	    claim HxIn2 : x :e halfopen_interval_left r1 r2.
	    { rewrite <- Hb2eq. exact Hx2. }
	    claim HxR : x :e R.
	    { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) x HxIn1). }
	    claim HxProp1 : ~(Rlt x q1) /\ Rlt x q2.
	    { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) x HxIn1). }
	    claim HxProp2 : ~(Rlt x r1) /\ Rlt x r2.
	    { exact (SepE2 R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) x HxIn2). }
	    claim Hnxq1 : ~(Rlt x q1).
	    { exact (andEL (~(Rlt x q1)) (Rlt x q2) HxProp1). }
	    claim Hxq2 : Rlt x q2.
	    { exact (andER (~(Rlt x q1)) (Rlt x q2) HxProp1). }
	    claim Hnxr1 : ~(Rlt x r1).
	    { exact (andEL (~(Rlt x r1)) (Rlt x r2) HxProp2). }
	    claim Hxr2 : Rlt x r2.
	    { exact (andER (~(Rlt x r1)) (Rlt x r2) HxProp2). }
	    (** endpoint types **)
	    claim Hq1R : q1 :e R.
	    { exact (rational_numbers_in_R q1 Hq1Q). }
	    claim Hq2R : q2 :e R.
	    { exact (rational_numbers_in_R q2 Hq2Q). }
	    claim Hr1R : r1 :e R.
	    { exact (rational_numbers_in_R r1 Hr1Q). }
	    claim Hr2R : r2 :e R.
	    { exact (rational_numbers_in_R r2 Hr2Q). }
	    claim Hq1S : SNo q1.
	    { exact (real_SNo q1 Hq1R). }
	    claim Hq2S : SNo q2.
	    { exact (real_SNo q2 Hq2R). }
	    claim Hr1S : SNo r1.
	    { exact (real_SNo r1 Hr1R). }
	    claim Hr2S : SNo r2.
	    { exact (real_SNo r2 Hr2R). }
	    claim HxS : SNo x.
	    { exact (real_SNo x HxR). }
	    claim Hxq2lt : x < q2.
	    { exact (RltE_lt x q2 Hxq2). }
	    claim Hxr2lt : x < r2.
	    { exact (RltE_lt x r2 Hxr2). }
	    (** choose max left endpoint and min right endpoint by trichotomy **)
	    apply (SNoLt_trichotomy_or_impred q1 r1 Hq1S Hr1S
	             (exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	    - assume Hq1lt : q1 < r1.
	      (** left endpoint r1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        (** right endpoint q2 **)
	        set I3 := halfopen_interval_left r1 q2.
	        witness I3.
	        apply andI.
	        * (** I3 in basis **)
	          claim HI3fam : I3 :e {halfopen_interval_left r1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left r1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { (** x in I3 **)
	            claim Hconj : ~(Rlt x r1) /\ Rlt x q2.
	            { apply andI.
	              - exact Hnxr1.
	              - exact Hxq2. }
	            exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) x HxR Hconj). }
	          { (** I3 subset b1 ∩ b2 **)
	            let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) y HyI3). }
	            claim HyProp : ~(Rlt y r1) /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) y HyI3). }
	            claim Hnyr1 : ~(Rlt y r1).
	            { exact (andEL (~(Rlt y r1)) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (~(Rlt y r1)) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            (** y in b2: y < r2 since y<q2 and q2<r2 **)
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyR
	                         (andI (~(Rlt y r1)) (Rlt y r2) Hnyr1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            (** y in b1: need ~(Rlt y q1) and Rlt y q2 (already) **)
	            claim Hnyq1 : ~(Rlt y q1).
	            { assume Hyq1 : Rlt y q1.
	              claim Hyq1lt : y < q1.
	              { exact (RltE_lt y q1 Hyq1). }
	              claim Hyr1lt : y < r1.
	              { exact (SNoLt_tra y q1 r1 HyS Hq1S Hr1S Hyq1lt Hq1lt). }
	              claim Hyr1 : Rlt y r1.
	              { exact (RltI y r1 HyR Hr1R Hyr1lt). }
	              exact (Hnyr1 Hyr1). }
	            claim HyIn1 : y :e halfopen_interval_left q1 q2.
	            { exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyR
	                         (andI (~(Rlt y q1)) (Rlt y q2) Hnyq1 Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := halfopen_interval_left r1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left r1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left r1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) x HxR
	                         (andI (~(Rlt x r1)) (Rlt x q2) Hnxr1 Hxq2)). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) y HyI3). }
	            claim HyProp : ~(Rlt y r1) /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z r1) /\ Rlt z q2) y HyI3). }
	            claim Hnyr1 : ~(Rlt y r1).
	            { exact (andEL (~(Rlt y r1)) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (~(Rlt y r1)) (Rlt y q2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { rewrite <- Hq2eq. exact Hyq2. }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyR
	                         (andI (~(Rlt y r1)) (Rlt y r2) Hnyr1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            claim Hnyq1 : ~(Rlt y q1).
	            { assume Hyq1 : Rlt y q1.
	              claim HyS : SNo y.
	              { exact (real_SNo y HyR). }
	              claim Hyq1lt : y < q1.
	              { exact (RltE_lt y q1 Hyq1). }
	              claim Hyr1lt : y < r1.
	              { exact (SNoLt_tra y q1 r1 HyS Hq1S Hr1S Hyq1lt Hq1lt). }
	              claim Hyr1 : Rlt y r1.
	              { exact (RltI y r1 HyR Hr1R Hyr1lt). }
	              exact (Hnyr1 Hyr1). }
	            claim HyIn1 : y :e halfopen_interval_left q1 q2.
	            { exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyR
	                         (andI (~(Rlt y q1)) (Rlt y q2) Hnyq1 Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        (** right endpoint r2 **)
	        set I3 := halfopen_interval_left r1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left r1 rr|rr :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun rr : set => halfopen_interval_left r1 rr) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   r1
	                   I3
	                   Hr1Q
	                   HI3fam).
	        * apply andI.
	          { (** x in I3 **)
	            claim Hconj : ~(Rlt x r1) /\ Rlt x r2.
	            { apply andI.
	              - exact Hnxr1.
	              - exact Hxr2. }
	            exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) x HxR Hconj). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyI3). }
	            claim HyProp : ~(Rlt y r1) /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyI3). }
	            claim Hnyr1 : ~(Rlt y r1).
	            { exact (andEL (~(Rlt y r1)) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (~(Rlt y r1)) (Rlt y r2) HyProp). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyI3. }
	            (** y in b1: need Rlt y q2 since r2<q2 **)
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { assume Hyq1 : Rlt y q1.
	              claim Hyq1lt : y < q1.
	              { exact (RltE_lt y q1 Hyq1). }
	              claim Hyr1lt : y < r1.
	              { exact (SNoLt_tra y q1 r1 HyS Hq1S Hr1S Hyq1lt Hq1lt). }
	              claim Hyr1 : Rlt y r1.
	              { exact (RltI y r1 HyR Hr1R Hyr1lt). }
	              exact (Hnyr1 Hyr1). }
	            claim HyIn1 : y :e halfopen_interval_left q1 q2.
	            { exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyR
	                         (andI (~(Rlt y q1)) (Rlt y q2) Hnyq1 Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	    - assume Hq1eq : q1 = r1.
	      (** left endpoint q1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        set I3 := halfopen_interval_left q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
		        * apply andI.
		          { exact HxIn1. }
		          { let y. assume HyI3 : y :e I3.
		            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim HyProp : ~(Rlt y q1) /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { exact (andEL (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { rewrite <- Hq1eq at 1.
	              exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyR
	                           (andI (~(Rlt y q1)) (Rlt y r2) Hnyq1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := halfopen_interval_left q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
		        * apply andI.
		          { exact HxIn1. }
		          { let y. assume HyI3 : y :e I3.
		            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. rewrite <- Hq1eq. rewrite <- Hq2eq. exact HyI3. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        set I3 := halfopen_interval_left q1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 rr|rr :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun rr : set => halfopen_interval_left q1 rr) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
		        * apply andI.
		          { claim Hconj : ~(Rlt x q1) /\ Rlt x r2.
		            { apply andI.
		              - exact Hnxq1.
		              - exact Hxr2. }
		            exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) x HxR Hconj). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyI3). }
	            claim HyProp : ~(Rlt y q1) /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyI3). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { exact (andEL (~(Rlt y q1)) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (~(Rlt y q1)) (Rlt y r2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim HyIn1 : y :e halfopen_interval_left q1 q2.
	            { exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyR
	                         (andI (~(Rlt y q1)) (Rlt y q2) Hnyq1 Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { rewrite <- Hq1eq at 1.
	              exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyR
	                           (andI (~(Rlt y q1)) (Rlt y r2) Hnyq1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	    - assume Hr1lt : r1 < q1.
	      (** left endpoint q1 **)
	      apply (SNoLt_trichotomy_or_impred q2 r2 Hq2S Hr2S
	               (exists b3 :e rational_halfopen_intervals_basis, x :e b3 /\ b3 c= b1 :/\: b2)).
	      + assume Hq2lt : q2 < r2.
	        set I3 := halfopen_interval_left q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact HxIn1. }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim HyProp : ~(Rlt y q1) /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { exact (andEL (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyq2lt : y < q2.
	            { exact (RltE_lt y q2 Hyq2). }
	            claim Hyr2lt : y < r2.
	            { exact (SNoLt_tra y q2 r2 HyS Hq2S Hr2S Hyq2lt Hq2lt). }
	            claim Hyr2 : Rlt y r2.
	            { exact (RltI y r2 HyR Hr2R Hyr2lt). }
	            claim Hnyr1 : ~(Rlt y r1).
	            { assume Hyr1 : Rlt y r1.
	              claim Hyr1lt : y < r1.
	              { exact (RltE_lt y r1 Hyr1). }
	              claim Hyq1lt : y < q1.
	              { exact (SNoLt_tra y r1 q1 HyS Hr1S Hq1S Hyr1lt Hr1lt). }
	              claim Hyq1 : Rlt y q1.
	              { exact (RltI y q1 HyR Hq1R Hyq1lt). }
	              exact (Hnyq1 Hyq1). }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyR
	                         (andI (~(Rlt y r1)) (Rlt y r2) Hnyr1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hq2eq : q2 = r2.
	        set I3 := halfopen_interval_left q1 q2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun qq : set => halfopen_interval_left q1 qq) q2 Hq2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { exact HxIn1. }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyI3. }
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim HyProp : ~(Rlt y q1) /\ Rlt y q2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyI3). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { exact (andEL (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim Hyq2 : Rlt y q2.
	            { exact (andER (~(Rlt y q1)) (Rlt y q2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { rewrite <- Hq2eq. exact Hyq2. }
	            claim Hnyr1 : ~(Rlt y r1).
	            { assume Hyr1 : Rlt y r1.
	              claim HyS : SNo y.
	              { exact (real_SNo y HyR). }
	              claim Hyr1lt : y < r1.
	              { exact (RltE_lt y r1 Hyr1). }
	              claim Hyq1lt : y < q1.
	              { exact (SNoLt_tra y r1 q1 HyS Hr1S Hq1S Hyr1lt Hr1lt). }
	              claim Hyq1 : Rlt y q1.
	              { exact (RltI y q1 HyR Hq1R Hyq1lt). }
	              exact (Hnyq1 Hyq1). }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyR
	                         (andI (~(Rlt y r1)) (Rlt y r2) Hnyr1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	      + assume Hr2lt : r2 < q2.
	        set I3 := halfopen_interval_left q1 r2.
	        witness I3.
	        apply andI.
	        * claim HI3fam : I3 :e {halfopen_interval_left q1 rr|rr :e rational_numbers}.
	          { exact (ReplI rational_numbers (fun rr : set => halfopen_interval_left q1 rr) r2 Hr2Q). }
	          exact (famunionI rational_numbers
	                   (fun aa : set => {halfopen_interval_left aa bb|bb :e rational_numbers})
	                   q1
	                   I3
	                   Hq1Q
	                   HI3fam).
	        * apply andI.
	          { claim Hconj : ~(Rlt x q1) /\ Rlt x r2.
	            { apply andI.
	              - exact Hnxq1.
	              - exact Hxr2. }
	            exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) x HxR Hconj). }
	          { let y. assume HyI3 : y :e I3.
	            prove y :e b1 :/\: b2.
	            claim HyR : y :e R.
	            { exact (SepE1 R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyI3). }
	            claim HyProp : ~(Rlt y q1) /\ Rlt y r2.
	            { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z r2) y HyI3). }
	            claim Hnyq1 : ~(Rlt y q1).
	            { exact (andEL (~(Rlt y q1)) (Rlt y r2) HyProp). }
	            claim Hyr2 : Rlt y r2.
	            { exact (andER (~(Rlt y q1)) (Rlt y r2) HyProp). }
	            claim HyS : SNo y.
	            { exact (real_SNo y HyR). }
	            claim Hyr2lt : y < r2.
	            { exact (RltE_lt y r2 Hyr2). }
	            claim Hyq2lt : y < q2.
	            { exact (SNoLt_tra y r2 q2 HyS Hr2S Hq2S Hyr2lt Hr2lt). }
	            claim Hyq2 : Rlt y q2.
	            { exact (RltI y q2 HyR Hq2R Hyq2lt). }
	            claim HyIn1 : y :e halfopen_interval_left q1 q2.
	            { exact (SepI R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) y HyR
	                         (andI (~(Rlt y q1)) (Rlt y q2) Hnyq1 Hyq2)). }
	            claim Hyb1 : y :e b1.
	            { rewrite Hb1eq. exact HyIn1. }
	            claim Hnyr1 : ~(Rlt y r1).
	            { assume Hyr1 : Rlt y r1.
	              claim Hyr1lt : y < r1.
	              { exact (RltE_lt y r1 Hyr1). }
	              claim Hyq1lt : y < q1.
	              { exact (SNoLt_tra y r1 q1 HyS Hr1S Hq1S Hyr1lt Hr1lt). }
	              claim Hyq1 : Rlt y q1.
	              { exact (RltI y q1 HyR Hq1R Hyq1lt). }
	              exact (Hnyq1 Hyq1). }
	            claim HyIn2 : y :e halfopen_interval_left r1 r2.
	            { exact (SepI R (fun z : set => ~(Rlt z r1) /\ Rlt z r2) y HyR
	                         (andI (~(Rlt y r1)) (Rlt y r2) Hnyr1 Hyr2)). }
	            claim Hyb2 : y :e b2.
	            { rewrite Hb2eq. exact HyIn2. }
	            exact (binintersectI b1 b2 y Hyb1 Hyb2). }
	- (** generated topology differs from R_lower_limit_topology **)
	  assume Heq: generated_topology R rational_halfopen_intervals_basis = R_lower_limit_topology.
	  set a := sqrt_SNo_nonneg 2.
	  set U := {x :e R | ~(Rlt x a)}.
	  claim HaDiff: a :e R :\: rational_numbers.
	  { exact sqrt_2_irrational. }
	  claim HaR: a :e R.
	  { exact (setminusE1 R rational_numbers a HaDiff). }
	  claim HaNotQ: a /:e rational_numbers.
	  { exact (setminusE2 R rational_numbers a HaDiff). }
	  (** U is open in the lower limit topology **)
	  claim HUinLower: U :e R_lower_limit_topology.
	  { prove U :e R_lower_limit_topology.
	    prove U :e generated_topology R R_lower_limit_basis.
	    prove U :e {U0 :e Power R | forall x0 :e U0, exists b0 :e R_lower_limit_basis, x0 :e b0 /\ b0 c= U0}.
	    claim HUsub: U c= R.
	    { let y. assume HyU.
	      exact (SepE1 R (fun z : set => ~(Rlt z a)) y HyU). }
	    claim HUpow: U :e Power R.
	    { exact (PowerI R U HUsub). }
	    claim HUprop: forall x0 :e U, exists b0 :e R_lower_limit_basis, x0 :e b0 /\ b0 c= U.
	    { let x0. assume Hx0U.
	      claim Hx0R: x0 :e R.
	      { exact (SepE1 R (fun z : set => ~(Rlt z a)) x0 Hx0U). }
	      claim Hnx0a: ~(Rlt x0 a).
	      { exact (SepE2 R (fun z : set => ~(Rlt z a)) x0 Hx0U). }
	      set b0 := add_SNo x0 1.
	      claim Hb0R: b0 :e R.
	      { exact (real_add_SNo x0 Hx0R 1 real_1). }
	      set I0 := halfopen_interval_left a b0.
	      claim HI0fam: I0 :e {halfopen_interval_left a bb|bb :e R}.
	      { exact (ReplI R (fun bb : set => halfopen_interval_left a bb) b0 Hb0R). }
	      claim HI0inB: I0 :e R_lower_limit_basis.
	      { exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R}) a I0 HaR HI0fam). }
	      claim Hx0InStd: x0 :e open_interval (add_SNo x0 (minus_SNo 1)) b0.
	      { exact (real_in_open_interval_minus1_plus1 x0 Hx0R). }
	      claim Hx0StdProp: Rlt (add_SNo x0 (minus_SNo 1)) x0 /\ Rlt x0 b0.
	      { exact (SepE2 R (fun z : set => Rlt (add_SNo x0 (minus_SNo 1)) z /\ Rlt z b0) x0 Hx0InStd). }
	      claim Hx0b0: Rlt x0 b0.
	      { exact (andER (Rlt (add_SNo x0 (minus_SNo 1)) x0) (Rlt x0 b0) Hx0StdProp). }
	      claim Hx0InI0: x0 :e I0.
	      { claim Hconj: ~(Rlt x0 a) /\ Rlt x0 b0.
	        { apply andI.
	          - exact Hnx0a.
	          - exact Hx0b0. }
	        exact (SepI R (fun z : set => ~(Rlt z a) /\ Rlt z b0) x0 Hx0R Hconj). }
	      claim HI0subU: I0 c= U.
	      { let y. assume HyI0.
	        claim HyR: y :e R.
	        { exact (SepE1 R (fun z : set => ~(Rlt z a) /\ Rlt z b0) y HyI0). }
	        claim HyProp: ~(Rlt y a) /\ Rlt y b0.
	        { exact (SepE2 R (fun z : set => ~(Rlt z a) /\ Rlt z b0) y HyI0). }
	        claim Hnya: ~(Rlt y a).
	        { exact (andEL (~(Rlt y a)) (Rlt y b0) HyProp). }
	        exact (SepI R (fun z : set => ~(Rlt z a)) y HyR Hnya). }
	      witness I0.
	      apply andI.
	      - exact HI0inB.
	      - apply andI.
	        { exact Hx0InI0. }
	        { exact HI0subU. } }
	    exact (SepI (Power R)
	              (fun U0 : set => forall x0 :e U0, exists b0 :e R_lower_limit_basis, x0 :e b0 /\ b0 c= U0)
	              U
	              HUpow
	              HUprop). }
	  (** Using the assumed equality, U would be open in the rational half-open topology **)
	  claim HUinRat: U :e generated_topology R rational_halfopen_intervals_basis.
	  { rewrite Heq. exact HUinLower. }
	  claim HUpropRat: forall x0 :e U, exists b0 :e rational_halfopen_intervals_basis, x0 :e b0 /\ b0 c= U.
	  { exact (SepE2 (Power R)
	            (fun U0 : set => forall x0 :e U0, exists b0 :e rational_halfopen_intervals_basis, x0 :e b0 /\ b0 c= U0)
	            U
	            HUinRat). }
	  (** But a has no neighborhood inside U using rational left endpoints **)
	  claim HaU: a :e U.
	  { exact (SepI R (fun z : set => ~(Rlt z a)) a HaR (not_Rlt_refl a HaR)). }
	  apply (HUpropRat a HaU).
	  let b. assume Hbpair. apply Hbpair.
	  assume HbInB: b :e rational_halfopen_intervals_basis.
	  assume Hbrest: a :e b /\ b c= U.
	  claim Hab: a :e b.
	  { exact (andEL (a :e b) (b c= U) Hbrest). }
	  claim HbsubU: b c= U.
	  { exact (andER (a :e b) (b c= U) Hbrest). }
	  (** destruct b as [q1,q2) with rationals q1,q2 **)
	  claim Hexq1: exists q1 :e rational_numbers, b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
	  { exact (famunionE rational_numbers (fun q1 : set => {halfopen_interval_left q1 q2|q2 :e rational_numbers}) b HbInB). }
	  apply Hexq1.
	  let q1. assume Hq1pair. apply Hq1pair.
	  assume Hq1Q: q1 :e rational_numbers.
	  assume HbFam: b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
	  claim Hexq2: exists q2 :e rational_numbers, b = halfopen_interval_left q1 q2.
	  { exact (ReplE rational_numbers (fun q2 : set => halfopen_interval_left q1 q2) b HbFam). }
	  apply Hexq2.
	  let q2. assume Hq2pair. apply Hq2pair.
	  assume Hq2Q: q2 :e rational_numbers.
	  assume HbEq: b = halfopen_interval_left q1 q2.
	  claim Hq1R: q1 :e R.
	  { exact (rational_numbers_in_R q1 Hq1Q). }
	  claim Hq2R: q2 :e R.
	  { exact (rational_numbers_in_R q2 Hq2Q). }
	  claim Hq1S: SNo q1.
	  { exact (real_SNo q1 Hq1R). }
	  claim Hq2S: SNo q2.
	  { exact (real_SNo q2 Hq2R). }
	  claim HaS: SNo a.
	  { exact (real_SNo a HaR). }
		  claim HaInInt: a :e halfopen_interval_left q1 q2.
		  { rewrite <- HbEq. exact Hab. }
	  claim HaIntProp: ~(Rlt a q1) /\ Rlt a q2.
	  { exact (SepE2 R (fun z : set => ~(Rlt z q1) /\ Rlt z q2) a HaInInt). }
	  claim HnaRq1: ~(Rlt a q1).
	  { exact (andEL (~(Rlt a q1)) (Rlt a q2) HaIntProp). }
	  claim Haq2: Rlt a q2.
	  { exact (andER (~(Rlt a q1)) (Rlt a q2) HaIntProp). }
	  claim HnaLt: ~(a < q1).
	  { assume Haq1lt: a < q1.
	    claim Haq1: Rlt a q1.
	    { exact (RltI a q1 HaR Hq1R Haq1lt). }
	    exact (HnaRq1 Haq1). }
	  claim Hq1lta: q1 < a.
	  { apply (SNoLt_trichotomy_or_impred a q1 HaS Hq1S (q1 < a)).
	    - assume Haq1lt: a < q1.
	      apply FalseE.
	      exact (HnaLt Haq1lt).
		    - assume Haq1eq: a = q1.
		      claim HaQ: a :e rational_numbers.
		      { rewrite Haq1eq. exact Hq1Q. }
		      apply FalseE.
		      exact (HaNotQ HaQ).
	    - assume Hq1alt: q1 < a.
	      exact Hq1alt. }
	  claim Hq1a: Rlt q1 a.
	  { exact (RltI q1 a Hq1R HaR Hq1lta). }
	  claim Haq2lt: a < q2.
	  { exact (RltE_lt a q2 Haq2). }
	  claim Hq1q2lt: q1 < q2.
	  { exact (SNoLt_tra q1 a q2 Hq1S HaS Hq2S Hq1lta Haq2lt). }
	  claim Hq1q2: Rlt q1 q2.
	  { exact (RltI q1 q2 Hq1R Hq2R Hq1q2lt). }
	  claim Hq1Inb: q1 :e b.
	  { rewrite HbEq.
	    exact (halfopen_interval_left_leftmem q1 q2 Hq1q2). }
	  claim Hq1U: q1 :e U.
	  { exact (HbsubU q1 Hq1Inb). }
	  claim Hnq1a: ~(Rlt q1 a).
	  { exact (SepE2 R (fun z : set => ~(Rlt z a)) q1 Hq1U). }
	  exact (Hnq1a Hq1a).
	Qed.

(** from §14 Definition: basis for the order topology **) 
(** LATEX VERSION: For a simply ordered set X, the order-topology basis consists of all open intervals/rays; here represented abstractly. **)
(** FIXED: For dictionary order on R², a and b are ordered pairs (a1,a2) and (b1,b2), not cartesian products setprod a1 a2 and setprod b1 b2. **)
(** SUSPICIOUS DEFINITION: `order_rel` is implemented as a case split over a small list of carrier sets used later; this is not a general interface for simply ordered sets and may force later axioms. **)
Definition order_rel : set -> set -> set -> prop := fun X a b =>
  (X = R /\ Rlt a b)
  \/
  (X = rational_numbers /\ Rlt a b)
  \/
  (X = omega /\ a :e b)
  \/
  (X = omega :\: {0} /\ a :e b)
  \/
  (X = setprod 2 omega /\
   exists i m j n:set,
     (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
  \/
  (X = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b).

(** from §14: simply ordered sets (scope of order topology) **)
(** LATEX VERSION: A simply ordered set is a set X equipped with a strict order relation < satisfying the order axioms. **)
(** NOTE: In this development, the order relation is hard-wired as `order_rel X` on a fixed list of carrier sets. **)
Definition simply_ordered_set : set -> prop := fun X =>
  X = R
  \/ X = rational_numbers
  \/ X = omega
  \/ X = omega :\: {0}
  \/ X = setprod 2 omega
  \/ X = setprod R R
  \/ ordinal X.

(** helper: in the dictionary order on {0,1}×ω we have (0,0) < (1,0) **)
Theorem order_rel_setprod_2_omega_00_10 :
  order_rel (setprod 2 omega) (0,0) (1,0).
prove order_rel (setprod 2 omega) (0,0) (1,0).
(** Unfold `order_rel` at X = setprod 2 omega and select the 5th disjunct. **)
prove (setprod 2 omega = R /\ Rlt (0,0) (1,0))
  \/
  (setprod 2 omega = rational_numbers /\ Rlt (0,0) (1,0))
  \/
  (setprod 2 omega = omega /\ (0,0) :e (1,0))
  \/
  (setprod 2 omega = omega :\: {0} /\ (0,0) :e (1,0))
  \/
  (setprod 2 omega = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     (0,0) = (i, m) /\ (1,0) = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (setprod 2 omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     (0,0) = (a1, a2) /\ (1,0) = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\ setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ (0,0) :e (1,0)).
apply orIL.
apply orIL.
apply orIR.
prove setprod 2 omega = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     (0,0) = (i, m) /\ (1,0) = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)).
apply andI.
- reflexivity.
- witness 0.
  witness 0.
  witness 1.
  witness 0.
  claim Hm0: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Heq00: (0,0) = (0,0).
  { reflexivity. }
  claim Heq10: (1,0) = (1,0).
  { reflexivity. }
  claim H12: 0 :e 2 /\ 0 :e omega.
  { exact (andI (0 :e 2) (0 :e omega) In_0_2 Hm0). }
  claim H123: (0 :e 2 /\ 0 :e omega) /\ 1 :e 2.
  { exact (andI (0 :e 2 /\ 0 :e omega) (1 :e 2) H12 In_1_2). }
  claim H1234: ((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ 0 :e omega.
  { exact (andI ((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) (0 :e omega) H123 Hm0). }
  claim H12345: (((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ 0 :e omega) /\ (0,0) = (0,0).
  { exact (andI (((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ 0 :e omega) ((0,0) = (0,0)) H1234 Heq00). }
  claim H123456: ((((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ 0 :e omega) /\ (0,0) = (0,0)) /\ (1,0) = (1,0).
  { exact (andI ((((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ 0 :e omega) /\ (0,0) = (0,0)) ((1,0) = (1,0)) H12345 Heq10). }
  claim Hlex: 0 :e 1 \/ (0 = 1 /\ 0 :e 0).
  { exact (orIL (0 :e 1) (0 = 1 /\ 0 :e 0) In_0_1). }
  apply andI.
  - exact H123456.
  - exact Hlex.
Qed.

(** helper: in the dictionary order on {0,1}×ω we have (0,0) < (1,n) for any n∈ω **)
Theorem order_rel_setprod_2_omega_00_1n : forall n:set,
  n :e omega -> order_rel (setprod 2 omega) (0,0) (1,n).
let n. assume HnOmega.
prove order_rel (setprod 2 omega) (0,0) (1,n).
(** Unfold `order_rel` at X = setprod 2 omega and select the 5th disjunct. **)
prove (setprod 2 omega = R /\ Rlt (0,0) (1,n))
  \/
  (setprod 2 omega = rational_numbers /\ Rlt (0,0) (1,n))
  \/
  (setprod 2 omega = omega /\ (0,0) :e (1,n))
  \/
  (setprod 2 omega = omega :\: {0} /\ (0,0) :e (1,n))
  \/
  (setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,0) = (i, m) /\ (1,n) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)))
  \/
  (setprod 2 omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     (0,0) = (a1, a2) /\ (1,n) = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\ setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ (0,0) :e (1,n)).
apply orIL.
apply orIL.
apply orIR.
prove setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,0) = (i, m) /\ (1,n) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)).
apply andI.
- reflexivity.
- witness 0.
  witness 0.
  witness 1.
  witness n.
  claim Hm0: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Heq00: (0,0) = (0,0).
  { reflexivity. }
  claim Heq1n: (1,n) = (1,n).
  { reflexivity. }
  claim H12: 0 :e 2 /\ 0 :e omega.
  { exact (andI (0 :e 2) (0 :e omega) In_0_2 Hm0). }
  claim H123: (0 :e 2 /\ 0 :e omega) /\ 1 :e 2.
  { exact (andI (0 :e 2 /\ 0 :e omega) (1 :e 2) H12 In_1_2). }
  claim H1234: ((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ n :e omega.
  { exact (andI ((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) (n :e omega) H123 HnOmega). }
  claim H12345: (((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,0) = (0,0).
  { exact (andI (((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ n :e omega) ((0,0) = (0,0)) H1234 Heq00). }
  claim H123456: ((((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,0) = (0,0)) /\ (1,n) = (1,n).
  { exact (andI ((((0 :e 2 /\ 0 :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,0) = (0,0)) ((1,n) = (1,n)) H12345 Heq1n). }
  claim Hlex: 0 :e 1 \/ (0 = 1 /\ 0 :e n).
  { exact (orIL (0 :e 1) (0 = 1 /\ 0 :e n) In_0_1). }
  apply andI.
  - exact H123456.
  - exact Hlex.
Qed.

(** helper: in the dictionary order on {0,1}×ω we have (0,k) < (1,n) for any k,n∈ω **)
Theorem order_rel_setprod_2_omega_0k_1n : forall k n:set,
  k :e omega -> n :e omega -> order_rel (setprod 2 omega) (0,k) (1,n).
let k n. assume HkOmega. assume HnOmega.
prove order_rel (setprod 2 omega) (0,k) (1,n).
(** Unfold `order_rel` at X = setprod 2 omega and select the 5th disjunct. **)
prove (setprod 2 omega = R /\ Rlt (0,k) (1,n))
  \/
  (setprod 2 omega = rational_numbers /\ Rlt (0,k) (1,n))
  \/
  (setprod 2 omega = omega /\ (0,k) :e (1,n))
  \/
  (setprod 2 omega = omega :\: {0} /\ (0,k) :e (1,n))
  \/
  (setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,k) = (i, m) /\ (1,n) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)))
  \/
  (setprod 2 omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     (0,k) = (a1, a2) /\ (1,n) = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\ setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ (0,k) :e (1,n)).
apply orIL.
apply orIL.
apply orIR.
prove setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,k) = (i, m) /\ (1,n) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)).
apply andI.
- reflexivity.
- witness 0.
  witness k.
  witness 1.
  witness n.
  claim Heq0k: (0,k) = (0,k).
  { reflexivity. }
  claim Heq1n: (1,n) = (1,n).
  { reflexivity. }
  claim H12: 0 :e 2 /\ k :e omega.
  { exact (andI (0 :e 2) (k :e omega) In_0_2 HkOmega). }
  claim H123: (0 :e 2 /\ k :e omega) /\ 1 :e 2.
  { exact (andI (0 :e 2 /\ k :e omega) (1 :e 2) H12 In_1_2). }
  claim H1234: ((0 :e 2 /\ k :e omega) /\ 1 :e 2) /\ n :e omega.
  { exact (andI ((0 :e 2 /\ k :e omega) /\ 1 :e 2) (n :e omega) H123 HnOmega). }
  claim H12345: (((0 :e 2 /\ k :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,k) = (0,k).
  { exact (andI (((0 :e 2 /\ k :e omega) /\ 1 :e 2) /\ n :e omega) ((0,k) = (0,k)) H1234 Heq0k). }
  claim H123456: ((((0 :e 2 /\ k :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,k) = (0,k)) /\ (1,n) = (1,n).
  { exact (andI ((((0 :e 2 /\ k :e omega) /\ 1 :e 2) /\ n :e omega) /\ (0,k) = (0,k)) ((1,n) = (1,n)) H12345 Heq1n). }
  claim Hlex: 0 :e 1 \/ (0 = 1 /\ k :e n).
  { exact (orIL (0 :e 1) (0 = 1 /\ k :e n) In_0_1). }
  apply andI.
  - exact H123456.
  - exact Hlex.
Qed.

(** helper: in the dictionary order on {0,1}×ω we have (0,k) < (0,ordsucc k) for any k∈ω **)
Theorem order_rel_setprod_2_omega_0k_0succk : forall k:set,
  k :e omega -> order_rel (setprod 2 omega) (0,k) (0, ordsucc k).
let k. assume HkOmega.
claim HsuccOmega: ordsucc k :e omega.
{ exact (omega_ordsucc k HkOmega). }
prove order_rel (setprod 2 omega) (0,k) (0, ordsucc k).
(** Unfold `order_rel` at X = setprod 2 omega and select the 5th disjunct. **)
prove (setprod 2 omega = R /\ Rlt (0,k) (0, ordsucc k))
  \/
  (setprod 2 omega = rational_numbers /\ Rlt (0,k) (0, ordsucc k))
  \/
  (setprod 2 omega = omega /\ (0,k) :e (0, ordsucc k))
  \/
  (setprod 2 omega = omega :\: {0} /\ (0,k) :e (0, ordsucc k))
  \/
  (setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,k) = (i, m) /\ (0, ordsucc k) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)))
  \/
  (setprod 2 omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     (0,k) = (a1, a2) /\ (0, ordsucc k) = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\ setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ (0,k) :e (0, ordsucc k)).
apply orIL.
apply orIL.
apply orIR.
prove setprod 2 omega = setprod 2 omega /\
   exists i m j n0:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
     (0,k) = (i, m) /\ (0, ordsucc k) = (j, n0) /\
     (i :e j \/ (i = j /\ m :e n0)).
apply andI.
- reflexivity.
- witness 0.
  witness k.
  witness 0.
  witness (ordsucc k).
  claim Heq0k: (0,k) = (0,k).
  { reflexivity. }
  claim Heq0sk: (0, ordsucc k) = (0, ordsucc k).
  { reflexivity. }
  claim H12: 0 :e 2 /\ k :e omega.
  { exact (andI (0 :e 2) (k :e omega) In_0_2 HkOmega). }
  claim H123: (0 :e 2 /\ k :e omega) /\ 0 :e 2.
  { exact (andI (0 :e 2 /\ k :e omega) (0 :e 2) H12 In_0_2). }
  claim H1234: ((0 :e 2 /\ k :e omega) /\ 0 :e 2) /\ ordsucc k :e omega.
  { exact (andI ((0 :e 2 /\ k :e omega) /\ 0 :e 2) (ordsucc k :e omega) H123 HsuccOmega). }
  claim H12345: (((0 :e 2 /\ k :e omega) /\ 0 :e 2) /\ ordsucc k :e omega) /\ (0,k) = (0,k).
  { exact (andI (((0 :e 2 /\ k :e omega) /\ 0 :e 2) /\ ordsucc k :e omega) ((0,k) = (0,k)) H1234 Heq0k). }
  claim H123456: ((((0 :e 2 /\ k :e omega) /\ 0 :e 2) /\ ordsucc k :e omega) /\ (0,k) = (0,k)) /\ (0, ordsucc k) = (0, ordsucc k).
  { exact (andI ((((0 :e 2 /\ k :e omega) /\ 0 :e 2) /\ ordsucc k :e omega) /\ (0,k) = (0,k)) ((0, ordsucc k) = (0, ordsucc k)) H12345 Heq0sk). }
  claim H00: 0 = 0.
  { reflexivity. }
  claim HkInSucc: k :e ordsucc k.
  { exact (ordsuccI2 k). }
  claim Hlex: 0 :e 0 \/ (0 = 0 /\ k :e ordsucc k).
  { exact (orIR (0 :e 0) (0 = 0 /\ k :e ordsucc k) (andI (0 = 0) (k :e ordsucc k) H00 HkInSucc)). }
  apply andI.
  - exact H123456.
  - exact Hlex.
Qed.

(** helper: eps_ 1 is not an element of the ordinal 2 **)
(** LATEX VERSION: 1/2 is neither 0 nor 1. **)
Theorem eps_1_not_in_2 : eps_ 1 /:e 2.
assume Heps2: eps_ 1 :e 2.
prove False.
claim Hsub: 2 c= {0,1}.
{ exact Subq_2_UPair01. }
claim Heps01: eps_ 1 :e {0,1}.
{ exact (Hsub (eps_ 1) Heps2). }
apply (UPairE (eps_ 1) 0 1 Heps01 False).
- assume Heq0: eps_ 1 = 0.
  claim H1omega: 1 :e omega.
  { exact (nat_p_omega 1 nat_1). }
  claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega 1 H1omega). }
  claim HepsR: eps_ 1 :e R.
  { exact (SNoS_omega_real (eps_ 1) Heps1SNoS). }
  claim H0ltEps: Rlt 0 (eps_ 1).
  { exact (RltI 0 (eps_ 1) real_0 HepsR (SNo_eps_pos 1 H1omega)). }
  claim Hbad: Rlt 0 0.
  { rewrite <- Heq0 at 2. exact H0ltEps. }
  exact ((not_Rlt_refl 0 real_0) Hbad).
- assume Heq1: eps_ 1 = 1.
  claim H1omega: 1 :e omega.
  { exact (nat_p_omega 1 nat_1). }
  claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega 1 H1omega). }
  claim HepsR: eps_ 1 :e R.
  { exact (SNoS_omega_real (eps_ 1) Heps1SNoS). }
  claim H0Ord: ordinal 0.
  { exact (nat_p_ordinal 0 nat_0). }
  claim H0in1: 0 :e 1.
  { exact (ordinal_0_In_ordsucc 0 H0Ord). }
  claim HepsLt1S: (eps_ 1) < 1.
  { claim HepsLtE0: eps_ 1 < eps_ 0.
    { exact (SNo_eps_decr 1 H1omega 0 H0in1). }
    rewrite <- (eps_0_1) at 2.
    exact HepsLtE0. }
  claim HepsLt1: Rlt (eps_ 1) 1.
  { exact (RltI (eps_ 1) 1 HepsR real_1 HepsLt1S). }
  claim Hbad: Rlt 1 1.
  { rewrite <- Heq1 at 1. exact HepsLt1. }
  exact ((not_Rlt_refl 1 real_1) Hbad).
Qed.

(** helper: setprod R R is not setprod 2 omega **)
Theorem setprod_R_R_neq_setprod_2_omega : setprod R R <> setprod 2 omega.
assume Heq: setprod R R = setprod 2 omega.
prove False.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
{ exact (SNo_eps_SNoS_omega 1 H1omega). }
claim HepsR: eps_ 1 :e R.
{ exact (SNoS_omega_real (eps_ 1) Heps1SNoS). }
claim HpRR: (eps_ 1, 0) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) 0 HepsR real_0). }
claim Hp2o: (eps_ 1, 0) :e setprod 2 omega.
{ rewrite <- Heq. exact HpRR. }
claim Heps2: ((eps_ 1, 0) 0) :e 2.
{ exact (ap0_Sigma 2 (fun _ : set => omega) (eps_ 1, 0) Hp2o). }
claim Heps2': eps_ 1 :e 2.
{ rewrite <- (tuple_2_0_eq (eps_ 1) 0).
  exact Heps2. }
exact (eps_1_not_in_2 Heps2').
Qed.

(** helper: tagging notation y' **)
(** LATEX VERSION: Notation helper: we sometimes tag points by adjoining a marker; this is used in constructed examples and does not correspond to a named TeX definition. **)
(** helper: reintroduce tagging notation y' as SetAdjoin y {1} in the topology section **)
Definition tag_topology : set -> set := fun y => SetAdjoin y {1}.
Postfix ' 100 := tag_topology.

(** helper: singleton {1} is not a surreal number **)
Theorem Sing1_not_SNo : ~SNo {1}.
assume HSNo: SNo {1}.
prove False.
set alpha := SNoLev {1}.
claim Hlev: ordinal alpha /\ SNo_ alpha {1}.
{ exact (SNoLev_prop {1} HSNo). }
claim Hord: ordinal alpha.
{ exact (andEL (ordinal alpha) (SNo_ alpha {1}) Hlev). }
claim HSNoa: SNo_ alpha {1}.
{ exact (andER (ordinal alpha) (SNo_ alpha {1}) Hlev). }

claim Hsub: {1} c= SNoElts_ alpha.
{ exact (andEL ({1} c= SNoElts_ alpha)
               (forall beta :e alpha, exactly1of2 (beta ' :e {1}) (beta :e {1}))
               HSNoa). }
claim Hprop: forall beta :e alpha, exactly1of2 (beta ' :e {1}) (beta :e {1}).
{ exact (andER ({1} c= SNoElts_ alpha)
               (forall beta :e alpha, exactly1of2 (beta ' :e {1}) (beta :e {1}))
               HSNoa). }

claim H1inElts: 1 :e SNoElts_ alpha.
{ exact (Hsub 1 (SingI 1)). }

claim H1inalpha: 1 :e alpha.
{ apply (binunionE' alpha {beta '|beta :e alpha} 1 (1 :e alpha)).
  - assume H1a: 1 :e alpha.
    exact H1a.
	  - assume H1tag: 1 :e {beta '|beta :e alpha}.
	    apply (ReplE alpha (fun beta : set => beta ') 1 H1tag).
	    let beta. assume Hbp.
	    apply Hbp.
	    assume Hbetaalpha: beta :e alpha.
	    assume HtagEq: 1 = beta '.
	    prove 1 :e alpha.
	    apply FalseE.
	    claim Hord1: ordinal 1.
	    { exact (nat_p_ordinal 1 nat_1). }
	    claim HnotOrdTag: ~ordinal (beta ').
	    { exact (tagged_not_ordinal beta). }
	    claim HnotOrd1: ~ordinal 1.
	    { rewrite HtagEq at 1.
	      exact HnotOrdTag. }
	    exact (HnotOrd1 Hord1).
	  - exact H1inElts. }

claim Htr: TransSet alpha.
{ exact (ordinal_TransSet alpha Hord). }
claim H1sub: 1 c= alpha.
{ exact (Htr 1 H1inalpha). }
claim H0inalpha: 0 :e alpha.
{ exact (H1sub 0 In_0_1). }

claim Hex01: exactly1of2 (0 ' :e {1}) (0 :e {1}).
{ exact (Hprop 0 H0inalpha). }

apply (exactly1of2_E (0 ' :e {1}) (0 :e {1}) Hex01 False).
- assume Htag: 0 ' :e {1}.
  assume _: ~(0 :e {1}).
  prove False.
  claim HtagEq: 0 ' = 1.
  { exact (SingE 1 (0 ') Htag). }
	  claim Hord1: ordinal 1.
	  { exact (nat_p_ordinal 1 nat_1). }
	  claim HnotOrdTag: ~ordinal (0 ').
	  { exact (tagged_not_ordinal 0). }
	  claim HnotOrd1: ~ordinal 1.
	  { rewrite <- HtagEq at 1.
	    exact HnotOrdTag. }
	  exact (HnotOrd1 Hord1).
- assume _: ~(0 ' :e {1}).
  assume H0: 0 :e {1}.
  prove False.
  claim H0eq: 0 = 1.
  { exact (SingE 1 0 H0). }
  exact (neq_0_1 H0eq).
Qed.

(** Helper: Inj1 0 equals 1 **)
Theorem Inj1_0_eq_1 : Inj1 0 = 1.
apply set_ext.
- let y. assume Hy: y :e Inj1 0.
  prove y :e 1.
  claim Hcase: y = 0 \/ exists x :e 0, y = Inj1 x.
  { exact (Inj1E 0 y Hy). }
  apply (Hcase (y :e 1)).
  - assume Hy0: y = 0.
    rewrite Hy0.
    exact In_0_1.
  - assume Hex: exists x :e 0, y = Inj1 x.
    apply Hex.
    let x. assume Hxp.
    apply Hxp.
    assume Hx0 HyEq.
    apply FalseE.
    exact (EmptyE x Hx0).
- let y. assume Hy: y :e 1.
  prove y :e Inj1 0.
  claim HySing: y :e {0}.
  { prove y :e {0}.
    rewrite <- eq_1_Sing0.
    exact Hy. }
  claim Hy0: y = 0.
  { exact (SingE 0 y HySing). }
  rewrite Hy0.
  exact (Inj1I1 0).
Qed.

(** Helper: tuple (0,1) equals {1} **)
Theorem tuple_0_1_eq_Sing1 : (0,1) = {1}.
prove (0,1) = {1}.
apply set_ext.
- let z. assume Hz: z :e (0,1).
  prove z :e {1}.
  claim Hzsum: z :e 0 :+: 1.
  { prove z :e 0 :+: 1.
    rewrite (tuple_pair 0 1).
    exact Hz. }
  claim Hcases: (exists x :e 0, z = Inj0 x) \/ (exists y :e 1, z = Inj1 y).
  { exact (setsum_Inj_inv 0 1 z Hzsum). }
  apply (Hcases (z :e {1})).
  - assume Hex: exists x :e 0, z = Inj0 x.
    apply Hex.
    let x. assume Hxp.
    apply Hxp.
    assume Hx0 HzEq.
    apply FalseE.
    exact (EmptyE x Hx0).
  - assume Hex: exists y :e 1, z = Inj1 y.
    apply Hex.
    let y. assume Hyp.
    apply Hyp.
    assume Hy1 HzEq.
    claim HySing: y :e {0}.
    { prove y :e {0}.
      rewrite <- eq_1_Sing0.
      exact Hy1. }
    claim Hy0: y = 0.
    { exact (SingE 0 y HySing). }
    claim HzInj10: z = Inj1 0.
    { prove z = Inj1 0.
      rewrite <- Hy0.
      exact HzEq. }
    claim Hz1: z = 1.
    { rewrite HzInj10.
      rewrite Inj1_0_eq_1.
      reflexivity. }
    rewrite Hz1.
    exact (SingI 1).
- let z. assume Hz: z :e {1}.
  prove z :e (0,1).
  rewrite <- (tuple_pair 0 1).
  claim Hz1: z = 1.
  { exact (SingE 1 z Hz). }
  rewrite Hz1.
  rewrite <- Inj1_0_eq_1 at 1.
  exact (Inj1_setsum 0 1 0 In_0_1).
Qed.

(** helper: setprod R R is not R **)
Theorem setprod_R_R_neq_R : setprod R R <> R.
assume Heq: setprod R R = R.
prove False.

claim HpRR: (0,1) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
claim HpR: (0,1) :e R.
{ rewrite <- Heq. exact HpRR. }
claim HSing1R: {1} :e R.
{ rewrite <- tuple_0_1_eq_Sing1 at 1.
  exact HpR. }
claim HdefR: R = real.
{ reflexivity. }
claim HSing1real: {1} :e real.
{ rewrite <- HdefR at 1.
  exact HSing1R. }
claim HSNo: SNo {1}.
{ exact (real_SNo {1} HSing1real). }
exact (Sing1_not_SNo HSNo).
Qed.

(** helper: setprod R R is not rational_numbers **)
Theorem setprod_R_R_neq_rational_numbers : setprod R R <> rational_numbers.
assume Heq: setprod R R = rational_numbers.
prove False.

(** rationals are countable: equip omega rational_numbers gives atleastp rational_numbers omega **)
claim Hequip: equip omega rational_numbers.
{ claim HdefQ: rational_numbers = rational.
  { reflexivity. }
  rewrite HdefQ.
  exact form100_3. }
claim Hequip_sym: equip rational_numbers omega.
{ exact (equip_sym omega rational_numbers Hequip). }
claim Hcount_Q: atleastp rational_numbers omega.
{ exact (equip_atleastp rational_numbers omega Hequip_sym). }
claim Hcount_prod: atleastp (setprod R R) omega.
{ rewrite Heq.
  exact Hcount_Q. }

(** inject R into R×R via x ↦ (x,0) **)
claim Hinj_R_prod: atleastp R (setprod R R).
{ prove exists f : set -> set, inj R (setprod R R) f.
  witness (fun x:set => (x,0)).
  apply (injI R (setprod R R) (fun x:set => (x,0))).
  - let x. assume Hx: x :e R.
    prove (x,0) :e setprod R R.
    exact (tuple_2_setprod_by_pair_Sigma R R x 0 Hx real_0).
  - let x.
    assume Hx: x :e R.
    let z.
    assume Hz: z :e R.
    assume Hxz: (x,0) = (z,0).
    prove x = z.
    claim Hcoords: x = z /\ 0 = 0.
    { exact (tuple_eq_coords x 0 z 0 Hxz). }
    exact (andEL (x = z) (0 = 0) Hcoords). }

(** compose injections to get R countable, contradict real uncountability **)
claim Hcount_R: atleastp R omega.
{ exact (atleastp_tra R (setprod R R) omega Hinj_R_prod Hcount_prod). }
claim HdefR: R = real.
{ reflexivity. }
claim Hcount_real: atleastp real omega.
{ rewrite <- HdefR.
  exact Hcount_R. }
exact (form100_22_real_uncountable_atleastp Hcount_real).
Qed.

(** helper: R is not countable, hence R is not omega, omega\\{0}, or Q **)
(** LATEX VERSION: Uses uncountability of reals to separate R from ω and ℚ. **)
Theorem R_neq_omega : R <> omega.
assume Heq: R = omega.
prove False.
claim HdefR: R = real.
{ reflexivity. }
claim Heq': real = omega.
{ rewrite <- HdefR. exact Heq. }
claim Homega_countable: atleastp omega omega.
{ exact (Subq_atleastp omega omega (Subq_ref omega)). }
claim Hreal_countable: atleastp real omega.
{ rewrite Heq' at 1.
  exact Homega_countable. }
exact (form100_22_real_uncountable_atleastp Hreal_countable).
Qed.

Theorem R_neq_omega_nonzero : R <> (omega :\: {0}).
assume Heq: R = omega :\: {0}.
prove False.
claim HdefR: R = real.
{ reflexivity. }
claim Heq': real = omega :\: {0}.
{ rewrite <- HdefR. exact Heq. }
claim Hsub: (omega :\: {0}) c= omega.
{ exact (setminus_Subq omega {0}). }
claim Hcount_nonzero: atleastp (omega :\: {0}) omega.
{ exact (Subq_atleastp (omega :\: {0}) omega Hsub). }
claim Hreal_countable: atleastp real omega.
{ rewrite Heq' at 1.
  exact Hcount_nonzero. }
exact (form100_22_real_uncountable_atleastp Hreal_countable).
Qed.

Theorem R_neq_rational_numbers : R <> rational_numbers.
assume Heq: R = rational_numbers.
prove False.
claim HdefR: R = real.
{ reflexivity. }
claim Heq': real = rational_numbers.
{ rewrite <- HdefR. exact Heq. }
(** rationals are countable by form100_3 and rational_numbers = rational **)
claim Hequip: equip omega rational_numbers.
{ claim HdefQ: rational_numbers = rational.
  { reflexivity. }
  rewrite HdefQ.
  exact form100_3. }
claim Hequip_sym: equip rational_numbers omega.
{ exact (equip_sym omega rational_numbers Hequip). }
claim Hcount_Q: atleastp rational_numbers omega.
{ exact (equip_atleastp rational_numbers omega Hequip_sym). }
claim Hreal_countable: atleastp real omega.
{ rewrite Heq' at 1.
  exact Hcount_Q. }
exact (form100_22_real_uncountable_atleastp Hreal_countable).
Qed.

(** helper: R is not setprod 2 omega **)
(** LATEX VERSION: ℝ is uncountable, but 2×ω is countable. **)
Theorem R_neq_setprod_2_omega : R <> setprod 2 omega.
assume Heq: R = setprod 2 omega.
prove False.

(** Countability of omega by the identity injection. **)
claim Homega_countable: countable omega.
{ exact (Subq_atleastp omega omega (Subq_ref omega)). }

(** Countability of 2 via 2 c= {0,1} c= omega. **)
claim H01subomega: {0,1} c= omega.
{ let x. assume Hx: x :e {0,1}.
  prove x :e omega.
  apply (UPairE x 0 1 Hx (x :e omega)).
  - assume Hx0: x = 0.
    rewrite Hx0.
    exact (nat_p_omega 0 nat_0).
  - assume Hx1: x = 1.
    rewrite Hx1.
    exact (nat_p_omega 1 nat_1). }
claim H2subomega: 2 c= omega.
{ exact (Subq_tra 2 {0,1} omega Subq_2_UPair01 H01subomega). }
claim H2countable: countable 2.
{ exact (Subq_atleastp 2 omega H2subomega). }

(** Therefore setprod 2 omega is countable. **)
claim Hprod_countable: countable (setprod 2 omega).
{ exact (setprod_countable 2 omega H2countable Homega_countable). }

(** Transfer countability to R by rewriting, contradicting real uncountability. **)
claim HRcountable: countable R.
{ rewrite Heq. exact Hprod_countable. }
claim HdefR: R = real.
{ reflexivity. }
claim Hreal_countable: atleastp real omega.
{ rewrite <- HdefR at 1.
  exact HRcountable. }
exact (form100_22_real_uncountable_atleastp Hreal_countable).
Qed.

(** Helper: strict order on ℝ implies order_rel on ℝ **)
(** LATEX VERSION: If a<b in ℝ then order_rel(ℝ,a,b) holds (first disjunct in the definition). **)
Theorem Rlt_implies_order_rel_R : forall a b:set, Rlt a b -> order_rel R a b.
let a b. assume Hab.
prove order_rel R a b.
(** Unfold `order_rel` at X = R. **)
prove (R = R /\ Rlt a b)
  \/
  (R = rational_numbers /\ Rlt a b)
  \/
  (R = omega /\ a :e b)
  \/
  (R = omega :\: {0} /\ a :e b)
  \/
  (R = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     a = (i, m) /\ b = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (R = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal R /\ R <> R /\ R <> rational_numbers /\ R <> setprod 2 omega /\ R <> setprod R R /\ a :e b).
(** `\/` is left-associative; inject into the leftmost disjunct repeatedly. **)
apply orIL.
apply orIL.
apply orIL.
apply orIL.
apply orIL.
apply orIL.
prove R = R /\ Rlt a b.
apply andI.
- reflexivity.
- exact Hab.
Qed.

(** Helper: order_rel on ℝ implies strict order on ℝ **)
(** LATEX VERSION: If order_rel(ℝ,a,b) then a<b in ℝ (all other disjuncts contradict known inequalities of carrier sets). **)
Theorem order_rel_R_implies_Rlt : forall a b:set, order_rel R a b -> Rlt a b.
let a b. assume Hrel: order_rel R a b.
prove Rlt a b.
apply (Hrel (Rlt a b)).
- assume Hleft6.
  apply (Hleft6 (Rlt a b)).
  - assume Hleft.
    apply (Hleft (Rlt a b)).
    - assume Hleft2.
      apply (Hleft2 (Rlt a b)).
      + assume Hleft3.
        apply (Hleft3 (Rlt a b)).
        * assume Hleft4.
          apply (Hleft4 (Rlt a b)).
          - assume HA: R = R /\ Rlt a b.
            exact (andER (R = R) (Rlt a b) HA).
          - assume HB: R = rational_numbers /\ Rlt a b.
            apply FalseE.
            claim Heq: R = rational_numbers.
            { exact (andEL (R = rational_numbers) (Rlt a b) HB). }
            exact (R_neq_rational_numbers Heq).
        * assume HC: R = omega /\ a :e b.
          apply FalseE.
          claim Heq: R = omega.
          { exact (andEL (R = omega) (a :e b) HC). }
          exact (R_neq_omega Heq).
      + assume HD: R = omega :\: {0} /\ a :e b.
        apply FalseE.
        claim Heq: R = omega :\: {0}.
        { exact (andEL (R = omega :\: {0}) (a :e b) HD). }
        exact (R_neq_omega_nonzero Heq).
    - assume HE: R = setprod 2 omega /\
        exists i m j n:set,
          i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
          a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
      apply FalseE.
      claim Heq: R = setprod 2 omega.
      { exact (andEL (R = setprod 2 omega)
                    (exists i m j n:set,
                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                    HE). }
      exact (R_neq_setprod_2_omega Heq).
  - assume HF: R = setprod R R /\
      exists a1 a2 b1 b2:set,
        a = (a1, a2) /\ b = (b1, b2) /\
        (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
    apply FalseE.
    claim Heq: R = setprod R R.
    { exact (andEL (R = setprod R R)
                   (exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                   HF). }
    apply setprod_R_R_neq_R.
    rewrite <- Heq.
    reflexivity.
- assume Hord: ordinal R /\ R <> R /\ R <> rational_numbers /\ R <> setprod 2 omega /\ R <> setprod R R /\ a :e b.
  apply FalseE.
  apply Hord. assume Hcore Haeb.
  apply Hcore. assume Hcore2 HneqRRset.
  apply Hcore2. assume Hcore3 Hneq2omega.
  apply Hcore3. assume Hcore4 HneqRat.
  apply Hcore4. assume HordR HneqRR.
  claim Hrefl: R = R.
  { reflexivity. }
  exact (HneqRR Hrefl).
Qed.

(** Helper: strict order on ℚ implies order_rel on ℚ **)
(** LATEX VERSION: If a<b in ℝ then order_rel(ℚ,a,b) holds (second disjunct in the definition). **)
Theorem Rlt_implies_order_rel_Q : forall a b:set, Rlt a b -> order_rel rational_numbers a b.
let a b. assume Hab.
prove order_rel rational_numbers a b.
(** Unfold `order_rel` at X = rational_numbers. **)
prove (rational_numbers = R /\ Rlt a b)
  \/
  (rational_numbers = rational_numbers /\ Rlt a b)
  \/
  (rational_numbers = omega /\ a :e b)
  \/
  (rational_numbers = omega :\: {0} /\ a :e b)
  \/
  (rational_numbers = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     a = (i, m) /\ b = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (rational_numbers = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal rational_numbers /\ rational_numbers <> R /\ rational_numbers <> rational_numbers /\
   rational_numbers <> setprod 2 omega /\ rational_numbers <> setprod R R /\ a :e b).
(** Reach the inner disjunction (A \/ B), then choose B. **)
apply orIL.
apply orIL.
apply orIL.
apply orIL.
apply orIL.
apply orIR.
prove rational_numbers = rational_numbers /\ Rlt a b.
apply andI.
- reflexivity.
- exact Hab.
Qed.

(** Helper: membership order on ω implies order_rel on ω **)
(** LATEX VERSION: For ω, the strict order is membership: if a∈b then order_rel(ω,a,b). **)
Theorem mem_implies_order_rel_omega : forall a b:set, a :e b -> order_rel omega a b.
let a b. assume Hab.
prove order_rel omega a b.
(** Unfold `order_rel` at X = omega and inject into the 3rd disjunct. **)
prove (omega = R /\ Rlt a b)
  \/
  (omega = rational_numbers /\ Rlt a b)
  \/
  (omega = omega /\ a :e b)
  \/
  (omega = omega :\: {0} /\ a :e b)
  \/
  (omega = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     a = (i, m) /\ b = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal omega /\ omega <> R /\ omega <> rational_numbers /\ omega <> setprod 2 omega /\ omega <> setprod R R /\ a :e b).
apply orIL.
apply orIL.
apply orIL.
apply orIL.
apply orIR.
prove omega = omega /\ a :e b.
apply andI.
- reflexivity.
- exact Hab.
Qed.

(** Helper: for ω, order_rel implies membership **)
(** LATEX VERSION: On ω (as a von Neumann ordinal), the strict order is membership: a<b iff a∈b. **)
Theorem order_rel_omega_implies_mem : forall a b:set,
  order_rel omega a b -> a :e b.
let a b.
assume Hab: order_rel omega a b.
prove a :e b.
(** local helper: {1} is not transitive **)
claim HnotTrSing1: ~ TransSet {1}.
{ assume Htr: TransSet {1}.
  prove False.
  claim H1in: 1 :e {1}.
  { exact (SingI 1). }
  claim Hsub: 1 c= {1}.
  { exact (Htr 1 H1in). }
  claim H0in1: 0 :e 1.
  { exact In_0_1. }
  claim H0inSing1: 0 :e {1}.
  { exact (Hsub 0 H0in1). }
  claim Heq: 0 = 1.
  { exact (SingE 1 0 H0inSing1). }
  exact (neq_0_1 Heq). }
(** local helper: {1} is not in ω **)
claim HnotSing1omega: {1} /:e omega.
{ assume H: {1} :e omega.
  prove False.
  claim Hnat: nat_p {1}.
  { exact (omega_nat_p {1} H). }
  claim Hord: ordinal {1}.
  { exact (nat_p_ordinal {1} Hnat). }
  claim Htr: TransSet {1}.
  { exact (ordinal_TransSet {1} Hord). }
  exact (HnotTrSing1 Htr). }
(** Unfold `order_rel` at X = omega and eliminate the disjunction cases. **)
apply Hab.
- assume Hleft.
  apply Hleft.
  + assume Hleft2.
    apply Hleft2.
    - assume Hleft3.
      apply Hleft3.
      + assume Hleft4.
        apply Hleft4.
        * assume H12.
          apply H12.
          { assume H1: omega = R /\ Rlt a b.
            apply FalseE.
            claim Heq: omega = R.
            { exact (andEL (omega = R) (Rlt a b) H1). }
            claim HeqR: R = omega.
            { symmetry. exact Heq. }
            exact (R_neq_omega HeqR). }
	          { assume H2: omega = rational_numbers /\ Rlt a b.
	            apply FalseE.
	            claim Heq: omega = rational_numbers.
	            { exact (andEL (omega = rational_numbers) (Rlt a b) H2). }
	            claim Hm1Q: minus_SNo 1 :e rational_numbers.
	            { claim HdefQ: rational_numbers = rational.
	              { reflexivity. }
	              claim H1rat: 1 :e rational.
	              { claim H1real: 1 :e real.
	                { exact real_1. }
	                claim H1omega: 1 :e omega.
	                { exact (nat_p_omega 1 nat_1). }
	                claim H1int: 1 :e int.
	                { exact (Subq_omega_int 1 H1omega). }
	                claim H1not0: 1 /:e {0}.
	                { assume H1: 1 :e {0}.
	                  prove False.
	                  claim Heq10: 1 = 0.
	                  { exact (SingE 0 1 H1). }
	                  exact (neq_1_0 Heq10). }
	                claim H1nonzero: 1 :e omega :\: {0}.
	                { exact (setminusI omega {0} 1 H1omega H1not0). }
	                claim Hrecip1: recip_SNo 1 = 1.
	                { claim H1neq0: 1 <> 0.
	                  { exact neq_1_0. }
	                  claim Hinv: mul_SNo 1 (recip_SNo 1) = 1.
	                  { exact (recip_SNo_invR 1 SNo_1 H1neq0). }
	                  rewrite <- (mul_SNo_oneL (recip_SNo 1) (SNo_recip_SNo 1 SNo_1)) at 1.
	                  exact Hinv. }
	                claim Heq1: 1 = div_SNo 1 1.
	                { claim Hdivdef: div_SNo 1 1 = mul_SNo 1 (recip_SNo 1).
	                  { reflexivity. }
	                  rewrite Hdivdef.
	                  rewrite Hrecip1.
	                  rewrite (mul_SNo_oneR 1 SNo_1).
	                  reflexivity. }
	                claim Hex: exists m :e int, exists n :e omega :\: {0}, 1 = div_SNo m n.
	                { witness 1.
	                  apply andI.
	                  - exact H1int.
	                  - witness 1.
	                    apply andI.
	                    + exact H1nonzero.
	                    + exact Heq1. }
	                exact (SepI real
	                            (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n)
	                            1
	                            H1real
	                            Hex). }
	              claim Hm1rat: minus_SNo 1 :e rational.
	              { exact (rational_minus_SNo 1 H1rat). }
	              rewrite HdefQ.
	              exact Hm1rat. }
	            claim Hm1omega: minus_SNo 1 :e omega.
	            { rewrite Heq.
	              exact Hm1Q. }
	            claim Hle0: 0 <= minus_SNo 1.
	            { exact (omega_nonneg (minus_SNo 1) Hm1omega). }
	            claim Hm1S: SNo (minus_SNo 1).
	            { exact (SNo_minus_SNo 1 SNo_1). }
	            apply (SNoLeE 0 (minus_SNo 1) SNo_0 Hm1S Hle0 False).
	            - assume H0ltm1: 0 < minus_SNo 1.
	              claim Hm1lt0: minus_SNo 1 < 0.
	              { exact minus_1_lt_0. }
	              claim H00: 0 < 0.
	              { exact (SNoLt_tra 0 (minus_SNo 1) 0 SNo_0 Hm1S SNo_0 H0ltm1 Hm1lt0). }
	              exact ((SNoLt_irref 0) H00).
	            - assume H0eqm1: 0 = minus_SNo 1.
	              claim Hm1lt0: minus_SNo 1 < 0.
	              { exact minus_1_lt_0. }
	              claim H00: 0 < 0.
	              { rewrite H0eqm1 at 1.
	                exact Hm1lt0. }
	              exact ((SNoLt_irref 0) H00). }
	        * assume H3: omega = omega /\ a :e b.
	          exact (andER (omega = omega) (a :e b) H3).
      + assume H4: omega = omega :\: {0} /\ a :e b.
        exact (andER (omega = omega :\: {0}) (a :e b) H4).
    - assume H5: omega = setprod 2 omega /\
        exists i m j n:set,
          i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
          a = (i, m) /\ b = (j, n) /\
          (i :e j \/ (i = j /\ m :e n)).
      apply FalseE.
	      claim Heq: omega = setprod 2 omega.
	      { exact (andEL (omega = setprod 2 omega)
	               (exists i m j n:set,
	                 i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                 a = (i, m) /\ b = (j, n) /\
	                 (i :e j \/ (i = j /\ m :e n)))
	               H5). }
	      claim H1omega: 1 :e omega.
	      { exact (nat_p_omega 1 nat_1). }
	      claim Hp: (0,1) :e setprod 2 omega.
	      { exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
	      claim HpOmega: (0,1) :e omega.
	      { rewrite Heq. exact Hp. }
	      claim HSingOmega: {1} :e omega.
	      { rewrite <- tuple_0_1_eq_Sing1.
	        exact HpOmega. }
	      exact (HnotSing1omega HSingOmega).
	  + assume H6: omega = setprod R R /\
	      exists a1 a2 b1 b2:set,
	        a = (a1, a2) /\ b = (b1, b2) /\
	        (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	    apply FalseE.
	    claim Heq: omega = setprod R R.
	    { exact (andEL (omega = setprod R R)
	             (exists a1 a2 b1 b2:set,
	               a = (a1, a2) /\ b = (b1, b2) /\
	               (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	             H6). }
	    claim HpRR: (0,1) :e setprod R R.
	    { exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
	    claim HpOmega: (0,1) :e omega.
	    { rewrite Heq. exact HpRR. }
	    claim HSingOmega: {1} :e omega.
	    { rewrite <- tuple_0_1_eq_Sing1.
	      exact HpOmega. }
	    exact (HnotSing1omega HSingOmega).
- assume H7: ordinal omega /\ omega <> R /\ omega <> rational_numbers /\ omega <> setprod 2 omega /\ omega <> setprod R R /\ a :e b.
  set T :=
    ((((ordinal omega /\ omega <> R) /\ omega <> rational_numbers) /\ omega <> setprod 2 omega) /\ omega <> setprod R R).
  exact (andER T (a :e b) H7).
Qed.

(** helper: for ω\\{0}, order_rel implies membership **)
Theorem order_rel_omega_nonzero_implies_mem : forall a b:set,
  order_rel (omega :\: {0}) a b -> a :e b.
let a b.
assume Hab: order_rel (omega :\: {0}) a b.
prove a :e b.
apply (Hab (a :e b)).
- assume Hleft6.
  apply (Hleft6 (a :e b)).
  - assume Hleft.
    apply (Hleft (a :e b)).
    - assume Hleft2.
      apply (Hleft2 (a :e b)).
      + assume Hleft3.
        apply (Hleft3 (a :e b)).
        * assume Hleft4.
          apply (Hleft4 (a :e b)).
          - assume Hc1: omega :\: {0} = R /\ Rlt a b.
            apply FalseE.
            claim Heq: omega :\: {0} = R.
            { exact (andEL (omega :\: {0} = R) (Rlt a b) Hc1). }
            claim HeqR: R = omega :\: {0}.
            { symmetry.
              exact Heq. }
            exact (R_neq_omega_nonzero HeqR).
          - assume Hc2: omega :\: {0} = rational_numbers /\ Rlt a b.
            apply FalseE.
            claim Heq: omega :\: {0} = rational_numbers.
            { exact (andEL (omega :\: {0} = rational_numbers) (Rlt a b) Hc2). }
            claim HeqQ: rational_numbers = omega :\: {0}.
            { symmetry.
              exact Heq. }
            claim H0Q: 0 :e rational_numbers.
            { prove 0 :e rational.
              claim H0real: 0 :e real.
              { exact real_0. }
              claim H0omega: 0 :e omega.
              { exact (nat_p_omega 0 nat_0). }
              claim H0int: 0 :e int.
              { exact (Subq_omega_int 0 H0omega). }
              claim H1omega: 1 :e omega.
              { exact (nat_p_omega 1 nat_1). }
              claim H1not0: 1 /:e {0}.
              { assume H1: 1 :e {0}.
                prove False.
                claim Heq10: 1 = 0.
                { exact (SingE 0 1 H1). }
                exact (neq_1_0 Heq10). }
              claim H1nonzero: 1 :e omega :\: {0}.
              { exact (setminusI omega {0} 1 H1omega H1not0). }
              claim Heq0: 0 = div_SNo 0 1.
              { claim Hdiv: div_SNo 0 1 = 0.
                { exact (div_SNo_0_num 1 SNo_1). }
                rewrite <- Hdiv at 1.
                reflexivity. }
              claim Hex: exists m :e int, exists n :e omega :\: {0}, 0 = div_SNo m n.
              { witness 0.
                apply andI.
                - exact H0int.
                - witness 1.
                  apply andI.
                  + exact H1nonzero.
                  + exact Heq0. }
              exact (SepI real
                          (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n)
                          0
                          H0real
                          Hex). }
            claim H0NZ: 0 :e omega :\: {0}.
            { rewrite <- HeqQ at 1.
              exact H0Q. }
            claim H0not0: 0 /:e {0}.
            { exact (setminusE2 omega {0} 0 H0NZ). }
            exact (H0not0 (SingI 0)).
        * assume Hc3: omega :\: {0} = omega /\ a :e b.
          apply FalseE.
          claim Heq: omega :\: {0} = omega.
          { exact (andEL (omega :\: {0} = omega) (a :e b) Hc3). }
          claim H0omega: 0 :e omega.
          { exact (nat_p_omega 0 nat_0). }
          claim H0NZ: 0 :e omega :\: {0}.
          { rewrite Heq at 1.
            exact H0omega. }
          claim H0not0: 0 /:e {0}.
          { exact (setminusE2 omega {0} 0 H0NZ). }
          exact (H0not0 (SingI 0)).
      + assume Hc4: omega :\: {0} = omega :\: {0} /\ a :e b.
        exact (andER (omega :\: {0} = omega :\: {0}) (a :e b) Hc4).
    - assume Hc5: omega :\: {0} = setprod 2 omega /\
        exists i m j n:set,
          i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
          a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
      apply FalseE.
      claim Heq: omega :\: {0} = setprod 2 omega.
      { exact (andEL (omega :\: {0} = setprod 2 omega)
                    (exists i m j n:set,
                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                    Hc5). }
      claim Heq2: setprod 2 omega = omega :\: {0}.
      { symmetry.
        exact Heq. }
      claim H1omega: 1 :e omega.
      { exact (nat_p_omega 1 nat_1). }
      claim Hp: (0,1) :e setprod 2 omega.
      { exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
      claim HpNZ: (0,1) :e omega :\: {0}.
      { rewrite <- Heq2 at 1.
        exact Hp. }
      claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
      { exact (setminusE omega {0} (0,1) HpNZ). }
      claim HpOmega: (0,1) :e omega.
      { exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
      claim HSingOmega: {1} :e omega.
      { rewrite <- tuple_0_1_eq_Sing1.
        exact HpOmega. }
      claim HnotTr: ~ TransSet {1}.
      { assume Htr: TransSet {1}.
        prove False.
        claim H1inSing1: 1 :e {1}.
        { exact (SingI 1). }
        claim Hsub: 1 c= {1}.
        { exact (Htr 1 H1inSing1). }
        claim H0in1: 0 :e 1.
        { rewrite eq_1_Sing0 at 1.
          exact (SingI 0). }
        claim H0inSing1: 0 :e {1}.
        { exact (Hsub 0 H0in1). }
        claim Heq01: 0 = 1.
        { exact (SingE 1 0 H0inSing1). }
        exact (neq_0_1 Heq01). }
      claim HnotInOmega: {1} /:e omega.
      { assume HSing: {1} :e omega.
        prove False.
        claim Hnat: nat_p {1}.
        { exact (omega_nat_p {1} HSing). }
        claim Hord: ordinal {1}.
        { exact (nat_p_ordinal {1} Hnat). }
        claim Htr: TransSet {1}.
        { exact (ordinal_TransSet {1} Hord). }
        exact (HnotTr Htr). }
      exact (HnotInOmega HSingOmega).
  - assume Hc6: omega :\: {0} = setprod R R /\
      exists a1 a2 b1 b2:set,
        a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
    apply FalseE.
    claim Heq: omega :\: {0} = setprod R R.
    { exact (andEL (omega :\: {0} = setprod R R)
                   (exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                   Hc6). }
    claim HeqRR: setprod R R = omega :\: {0}.
    { symmetry.
      exact Heq. }
    claim HpRR: (0,1) :e setprod R R.
    { exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
    claim HpNZ: (0,1) :e omega :\: {0}.
    { rewrite <- HeqRR at 1.
      exact HpRR. }
    claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
    { exact (setminusE omega {0} (0,1) HpNZ). }
    claim HpOmega: (0,1) :e omega.
    { exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
    claim HSingOmega: {1} :e omega.
    { rewrite <- tuple_0_1_eq_Sing1.
      exact HpOmega. }
    claim HnotTr: ~ TransSet {1}.
    { assume Htr: TransSet {1}.
      prove False.
      claim H1inSing1: 1 :e {1}.
      { exact (SingI 1). }
      claim Hsub: 1 c= {1}.
      { exact (Htr 1 H1inSing1). }
      claim H0in1: 0 :e 1.
      { rewrite eq_1_Sing0 at 1.
        exact (SingI 0). }
      claim H0inSing1: 0 :e {1}.
      { exact (Hsub 0 H0in1). }
      claim Heq01: 0 = 1.
      { exact (SingE 1 0 H0inSing1). }
      exact (neq_0_1 Heq01). }
    claim HnotInOmega: {1} /:e omega.
    { assume HSing: {1} :e omega.
      prove False.
      claim Hnat: nat_p {1}.
      { exact (omega_nat_p {1} HSing). }
      claim Hord: ordinal {1}.
      { exact (nat_p_ordinal {1} Hnat). }
      claim Htr: TransSet {1}.
      { exact (ordinal_TransSet {1} Hord). }
      exact (HnotTr Htr). }
    exact (HnotInOmega HSingOmega).
- assume Hord:
    ordinal (omega :\: {0}) /\ (omega :\: {0}) <> R /\ (omega :\: {0}) <> rational_numbers /\
    (omega :\: {0}) <> setprod 2 omega /\ (omega :\: {0}) <> setprod R R /\ a :e b.
  set T := ((((ordinal (omega :\: {0}) /\ (omega :\: {0}) <> R) /\ (omega :\: {0}) <> rational_numbers)
            /\ (omega :\: {0}) <> setprod 2 omega) /\ (omega :\: {0}) <> setprod R R).
  exact (andER T (a :e b) Hord).
Qed.

(** Helper: membership order on ω\\{0} implies order_rel on ω\\{0} **)
(** LATEX VERSION: For ω\\{0}, we still use membership as the strict order. **)
Theorem mem_implies_order_rel_omega_nonzero : forall a b:set, a :e b -> order_rel (omega :\: {0}) a b.
let a b. assume Hab.
prove order_rel (omega :\: {0}) a b.
(** Unfold and inject into the 4th disjunct. **)
prove (omega :\: {0} = R /\ Rlt a b)
  \/
  (omega :\: {0} = rational_numbers /\ Rlt a b)
  \/
  (omega :\: {0} = omega /\ a :e b)
  \/
  (omega :\: {0} = omega :\: {0} /\ a :e b)
  \/
  (omega :\: {0} = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     a = (i, m) /\ b = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (omega :\: {0} = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (omega :\: {0}) /\ (omega :\: {0}) <> R /\ (omega :\: {0}) <> rational_numbers /\
   (omega :\: {0}) <> setprod 2 omega /\ (omega :\: {0}) <> setprod R R /\ a :e b).
apply orIL.
apply orIL.
apply orIL.
apply orIR.
prove omega :\: {0} = omega :\: {0} /\ a :e b.
apply andI.
- reflexivity.
- exact Hab.
Qed.

(** helper: omega without 0 differs from omega **)
Theorem omega_nonzero_neq_omega : (omega :\: {0}) <> omega.
assume Heq: omega :\: {0} = omega.
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim H0nonz: 0 :e (omega :\: {0}).
{ rewrite Heq.
  exact H0omega. }
claim Hnot0: 0 /:e {0}.
{ exact (setminusE2 omega {0} 0 H0nonz). }
exact (Hnot0 (SingI 0)).
Qed.

(** helper: introduce dictionary order on {0,1}xomega **)
Theorem order_rel_setprod_2_omega_intro : forall i m j n:set,
  i :e 2 ->
  m :e omega ->
  j :e 2 ->
  n :e omega ->
  (i :e j \/ (i = j /\ m :e n)) ->
  order_rel (setprod 2 omega) (i,m) (j,n).
let i m j n.
assume Hi2 HmO Hj2 HnO Hcmp.
prove order_rel (setprod 2 omega) (i,m) (j,n).
prove (setprod 2 omega = R /\ Rlt (i,m) (j,n))
  \/
  (setprod 2 omega = rational_numbers /\ Rlt (i,m) (j,n))
  \/
  (setprod 2 omega = omega /\ (i,m) :e (j,n))
  \/
  (setprod 2 omega = omega :\: {0} /\ (i,m) :e (j,n))
  \/
  (setprod 2 omega = setprod 2 omega /\
   exists i0 m0 j0 n0:set,
     i0 :e 2 /\ m0 :e omega /\ j0 :e 2 /\ n0 :e omega /\
     (i,m) = (i0, m0) /\ (j,n) = (j0, n0) /\
     (i0 :e j0 \/ (i0 = j0 /\ m0 :e n0)))
  \/
  (setprod 2 omega = setprod R R /\
   exists a1 a2 b1 b2:set,
     (i,m) = (a1, a2) /\ (j,n) = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\
   setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ (i,m) :e (j,n)).
apply orIL.
apply orIL.
apply orIR.
prove setprod 2 omega = setprod 2 omega /\
  exists i0 m0 j0 n0:set,
    i0 :e 2 /\ m0 :e omega /\ j0 :e 2 /\ n0 :e omega /\
    (i,m) = (i0, m0) /\ (j,n) = (j0, n0) /\
    (i0 :e j0 \/ (i0 = j0 /\ m0 :e n0)).
apply andI.
- reflexivity.
- witness i.
  witness m.
  witness j.
  witness n.
  apply and7I.
  - exact Hi2.
  - exact HmO.
  - exact Hj2.
  - exact HnO.
  - reflexivity.
  - reflexivity.
  - exact Hcmp.
Qed.

(** helper: trichotomy for order_rel on simply ordered sets **)
Theorem order_rel_trichotomy_or_impred : forall X a b:set,
  simply_ordered_set X ->
  a :e X ->
  b :e X ->
  forall p:prop,
    (order_rel X a b -> p) ->
    (a = b -> p) ->
    (order_rel X b a -> p) ->
    p.
let X a b.
assume Hso HaX HbX.
let p.
assume Habp Heqp Hbap.
apply (xm (X = R)).
- assume HX: X = R.
  claim HaR: a :e R.
  { rewrite <- HX.
    exact HaX. }
  claim HbR: b :e R.
  { rewrite <- HX.
    exact HbX. }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  apply (SNoLt_trichotomy_or_impred a b HaS HbS p).
  - assume Hablt: a < b.
    claim HabRlt: Rlt a b.
    { exact (RltI a b HaR HbR Hablt). }
    claim Hrel: order_rel X a b.
    { rewrite HX.
      exact (Rlt_implies_order_rel_R a b HabRlt). }
    exact (Habp Hrel).
  - assume Heq: a = b.
    exact (Heqp Heq).
  - assume Hbalt: b < a.
    claim HbaRlt: Rlt b a.
    { exact (RltI b a HbR HaR Hbalt). }
    claim Hrel: order_rel X b a.
    { rewrite HX.
      exact (Rlt_implies_order_rel_R b a HbaRlt). }
    exact (Hbap Hrel).
- assume HneqR: ~(X = R).
  apply (xm (X = rational_numbers)).
  - assume HXQ: X = rational_numbers.
    claim HaQ: a :e rational_numbers.
    { rewrite <- HXQ.
      exact HaX. }
    claim HbQ: b :e rational_numbers.
    { rewrite <- HXQ.
      exact HbX. }
    claim HaR: a :e R.
    { exact (rational_numbers_in_R a HaQ). }
    claim HbR: b :e R.
    { exact (rational_numbers_in_R b HbQ). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    apply (SNoLt_trichotomy_or_impred a b HaS HbS p).
    - assume Hablt: a < b.
      claim HabRlt: Rlt a b.
      { exact (RltI a b HaR HbR Hablt). }
      claim Hrel: order_rel X a b.
      { rewrite HXQ.
        exact (Rlt_implies_order_rel_Q a b HabRlt). }
      exact (Habp Hrel).
    - assume Heq: a = b.
      exact (Heqp Heq).
    - assume Hbalt: b < a.
      claim HbaRlt: Rlt b a.
      { exact (RltI b a HbR HaR Hbalt). }
      claim Hrel: order_rel X b a.
      { rewrite HXQ.
        exact (Rlt_implies_order_rel_Q b a HbaRlt). }
      exact (Hbap Hrel).
  - assume HneqQ: ~(X = rational_numbers).
    apply (xm (X = omega)).
    - assume HXo: X = omega.
      claim HaO: a :e omega.
      { rewrite <- HXo.
        exact HaX. }
      claim HbO: b :e omega.
      { rewrite <- HXo.
        exact HbX. }
      claim HaOrd: ordinal a.
      { exact (nat_p_ordinal a (omega_nat_p a HaO)). }
      claim HbOrd: ordinal b.
      { exact (nat_p_ordinal b (omega_nat_p b HbO)). }
      apply (ordinal_trichotomy_or_impred a b HaOrd HbOrd p).
      - assume Habmem: a :e b.
        claim Hrel: order_rel X a b.
        { rewrite HXo.
          exact (mem_implies_order_rel_omega a b Habmem). }
        exact (Habp Hrel).
      - assume Heq: a = b.
        exact (Heqp Heq).
      - assume Hbmem: b :e a.
        claim Hrel: order_rel X b a.
        { rewrite HXo.
          exact (mem_implies_order_rel_omega b a Hbmem). }
        exact (Hbap Hrel).
    - assume HneqO: ~(X = omega).
      apply (xm (X = omega :\: {0})).
      - assume HXnz: X = omega :\: {0}.
        claim HaNz: a :e omega :\: {0}.
        { rewrite <- HXnz.
          exact HaX. }
        claim HbNz: b :e omega :\: {0}.
        { rewrite <- HXnz.
          exact HbX. }
        claim HaO: a :e omega.
        { exact (setminusE1 omega {0} a HaNz). }
        claim HbO: b :e omega.
        { exact (setminusE1 omega {0} b HbNz). }
        claim HaOrd: ordinal a.
        { exact (nat_p_ordinal a (omega_nat_p a HaO)). }
        claim HbOrd: ordinal b.
        { exact (nat_p_ordinal b (omega_nat_p b HbO)). }
        apply (ordinal_trichotomy_or_impred a b HaOrd HbOrd p).
        - assume Habmem: a :e b.
          claim Hrel: order_rel X a b.
          { rewrite HXnz.
            exact (mem_implies_order_rel_omega_nonzero a b Habmem). }
          exact (Habp Hrel).
        - assume Heq: a = b.
          exact (Heqp Heq).
        - assume Hbmem: b :e a.
          claim Hrel: order_rel X b a.
          { rewrite HXnz.
            exact (mem_implies_order_rel_omega_nonzero b a Hbmem). }
          exact (Hbap Hrel).
      - assume HneqNz: ~(X = omega :\: {0}).
        apply (xm (X = setprod 2 omega)).
        - assume HX2: X = setprod 2 omega.
          claim HaP: a :e setprod 2 omega.
          { rewrite <- HX2.
            exact HaX. }
          claim HbP: b :e setprod 2 omega.
          { rewrite <- HX2.
            exact HbX. }
          apply (Sigma_E 2 (fun _ : set => omega) a HaP).
          let i.
          assume Ha1.
          apply Ha1.
          assume Hi2 Ha2.
          apply Ha2.
          let m.
          assume Ha3.
          apply Ha3.
          assume HmO HaEqPair.
          apply (Sigma_E 2 (fun _ : set => omega) b HbP).
          let j.
          assume Hb1.
          apply Hb1.
          assume Hj2 Hb2.
          apply Hb2.
          let n.
          assume Hb3.
          apply Hb3.
          assume HnO HbEqPair.
          claim HaEq: a = (i,m).
          { rewrite HaEqPair.
            exact (tuple_pair i m). }
          claim HbEq: b = (j,n).
          { rewrite HbEqPair.
            exact (tuple_pair j n). }
          claim H2ord: ordinal 2.
          { exact (nat_p_ordinal 2 nat_2). }
          claim HiOrd: ordinal i.
          { exact (ordinal_Hered 2 H2ord i Hi2). }
          claim HjOrd: ordinal j.
          { exact (ordinal_Hered 2 H2ord j Hj2). }
          claim HmOrd: ordinal m.
          { exact (nat_p_ordinal m (omega_nat_p m HmO)). }
          claim HnOrd: ordinal n.
          { exact (nat_p_ordinal n (omega_nat_p n HnO)). }
          apply (ordinal_trichotomy_or_impred i j HiOrd HjOrd p).
          - assume Hijmem: i :e j.
            claim Hrel: order_rel X a b.
            { rewrite HX2.
              rewrite HaEq.
              rewrite HbEq.
              exact (order_rel_setprod_2_omega_intro i m j n Hi2 HmO Hj2 HnO (orIL (i :e j) (i = j /\ m :e n) Hijmem)). }
            exact (Habp Hrel).
          - assume Hijeq: i = j.
            apply (ordinal_trichotomy_or_impred m n HmOrd HnOrd p).
            + assume Hmnmem: m :e n.
              claim Hrel: order_rel X a b.
              { rewrite HX2.
                rewrite HaEq.
                rewrite HbEq.
                exact (order_rel_setprod_2_omega_intro i m j n Hi2 HmO Hj2 HnO (orIR (i :e j) (i = j /\ m :e n) (andI (i = j) (m :e n) Hijeq Hmnmem))). }
              exact (Habp Hrel).
            + assume Hmneq: m = n.
              claim HabEq: a = b.
              { rewrite HaEq.
                rewrite HbEq.
                exact (coords_eq_tuple i m j n Hijeq Hmneq). }
              exact (Heqp HabEq).
            + assume Hnmemb: n :e m.
              claim Hji: j = i.
              { symmetry.
                exact Hijeq. }
              claim Hrel: order_rel X b a.
              { rewrite HX2.
                rewrite HbEq.
                rewrite HaEq.
                exact (order_rel_setprod_2_omega_intro j n i m Hj2 HnO Hi2 HmO
                        (orIR (j :e i) (j = i /\ n :e m) (andI (j = i) (n :e m) Hji Hnmemb))). }
              exact (Hbap Hrel).
          - assume Hjimmem: j :e i.
            claim Hrel: order_rel X b a.
            { rewrite HX2.
              rewrite HbEq.
              rewrite HaEq.
              exact (order_rel_setprod_2_omega_intro j n i m Hj2 HnO Hi2 HmO (orIL (j :e i) (j = i /\ n :e m) Hjimmem)). }
            exact (Hbap Hrel).
        - assume Hneq2: ~(X = setprod 2 omega).
          apply (xm (X = setprod R R)).
          - assume HXR2: X = setprod R R.
            claim HaP: a :e setprod R R.
            { rewrite <- HXR2.
              exact HaX. }
            claim HbP: b :e setprod R R.
            { rewrite <- HXR2.
              exact HbX. }
            apply (Sigma_E R (fun _ : set => R) a HaP).
            let a1.
            assume Ha1.
            apply Ha1.
            assume Ha1R Ha2.
            apply Ha2.
            let a2.
            assume Ha3.
            apply Ha3.
            assume Ha2R HaEqPair.
            apply (Sigma_E R (fun _ : set => R) b HbP).
            let b1.
            assume Hb1.
            apply Hb1.
            assume Hb1R Hb2.
            apply Hb2.
            let b2.
            assume Hb3.
            apply Hb3.
            assume Hb2R HbEqPair.
            claim HaEq: a = (a1,a2).
            { rewrite HaEqPair.
              exact (tuple_pair a1 a2). }
            claim HbEq: b = (b1,b2).
            { rewrite HbEqPair.
              exact (tuple_pair b1 b2). }
            claim Ha1S: SNo a1.
            { exact (real_SNo a1 Ha1R). }
            claim Hb1S: SNo b1.
            { exact (real_SNo b1 Hb1R). }
            claim Ha2S: SNo a2.
            { exact (real_SNo a2 Ha2R). }
            claim Hb2S: SNo b2.
            { exact (real_SNo b2 Hb2R). }
            apply (SNoLt_trichotomy_or_impred a1 b1 Ha1S Hb1S p).
            - assume Hab1: a1 < b1.
              claim HabRlt: Rlt a1 b1.
              { exact (RltI a1 b1 Ha1R Hb1R Hab1). }
              claim Hrel: order_rel X a b.
              { rewrite HXR2.
                rewrite HaEq.
                rewrite HbEq.
                prove order_rel (setprod R R) (a1,a2) (b1,b2).
                prove (setprod R R = R /\ Rlt (a1,a2) (b1,b2))
                  \/
                  (setprod R R = rational_numbers /\ Rlt (a1,a2) (b1,b2))
                  \/
                  (setprod R R = omega /\ (a1,a2) :e (b1,b2))
                  \/
                  (setprod R R = omega :\: {0} /\ (a1,a2) :e (b1,b2))
                  \/
                  (setprod R R = setprod 2 omega /\
                   exists i m j n:set,
                     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                     (a1,a2) = (i, m) /\ (b1,b2) = (j, n) /\
                     (i :e j \/ (i = j /\ m :e n)))
                  \/
                  (setprod R R = setprod R R /\
                   exists c1 c2 d1 d2:set,
                     (a1,a2) = (c1, c2) /\ (b1,b2) = (d1, d2) /\
                     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)))
                  \/
                  (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
                   setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (a1,a2) :e (b1,b2)).
                apply orIL.
                apply orIR.
                prove setprod R R = setprod R R /\
                  exists c1 c2 d1 d2:set,
                    (a1,a2) = (c1, c2) /\ (b1,b2) = (d1, d2) /\
                    (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
                apply andI.
                - reflexivity.
                - witness a1.
                  witness a2.
                  witness b1.
                  witness b2.
                  apply and3I.
                  + reflexivity.
                  + reflexivity.
                  + exact (orIL (Rlt a1 b1) (a1 = b1 /\ Rlt a2 b2) HabRlt). }
              exact (Habp Hrel).
            - assume H1eq: a1 = b1.
              apply (SNoLt_trichotomy_or_impred a2 b2 Ha2S Hb2S p).
              + assume Hab2: a2 < b2.
                claim HabRlt: Rlt a2 b2.
                { exact (RltI a2 b2 Ha2R Hb2R Hab2). }
                claim Hrel: order_rel X a b.
                { rewrite HXR2.
                  rewrite HaEq.
                  rewrite HbEq.
                  prove order_rel (setprod R R) (a1,a2) (b1,b2).
                  prove (setprod R R = R /\ Rlt (a1,a2) (b1,b2))
                    \/
                    (setprod R R = rational_numbers /\ Rlt (a1,a2) (b1,b2))
                    \/
                    (setprod R R = omega /\ (a1,a2) :e (b1,b2))
                    \/
                    (setprod R R = omega :\: {0} /\ (a1,a2) :e (b1,b2))
                    \/
                    (setprod R R = setprod 2 omega /\
                     exists i m j n:set,
                       i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                       (a1,a2) = (i, m) /\ (b1,b2) = (j, n) /\
                       (i :e j \/ (i = j /\ m :e n)))
                    \/
                    (setprod R R = setprod R R /\
                     exists c1 c2 d1 d2:set,
                       (a1,a2) = (c1, c2) /\ (b1,b2) = (d1, d2) /\
                       (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)))
                    \/
                    (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
                     setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (a1,a2) :e (b1,b2)).
                  apply orIL.
                  apply orIR.
                  prove setprod R R = setprod R R /\
                    exists c1 c2 d1 d2:set,
                      (a1,a2) = (c1, c2) /\ (b1,b2) = (d1, d2) /\
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
                  apply andI.
                  - reflexivity.
                  - witness a1.
                    witness a2.
                    witness b1.
                    witness b2.
                    apply and3I.
                    + reflexivity.
                    + reflexivity.
                    + exact (orIR (Rlt a1 b1) (a1 = b1 /\ Rlt a2 b2) (andI (a1 = b1) (Rlt a2 b2) H1eq HabRlt)). }
                exact (Habp Hrel).
              + assume HabEq: a2 = b2.
                claim HabEq2: a = b.
                { rewrite HaEq.
                  rewrite HbEq.
                  exact (coords_eq_tuple a1 a2 b1 b2 H1eq HabEq). }
                exact (Heqp HabEq2).
              + assume Hba2: b2 < a2.
                claim HbaRlt: Rlt b2 a2.
                { exact (RltI b2 a2 Hb2R Ha2R Hba2). }
                claim Hb1eq: b1 = a1.
                { symmetry.
                  exact H1eq. }
                claim Hrel: order_rel X b a.
                { rewrite HXR2.
                  rewrite HbEq.
                  rewrite HaEq.
                  prove order_rel (setprod R R) (b1,b2) (a1,a2).
                  prove (setprod R R = R /\ Rlt (b1,b2) (a1,a2))
                    \/
                    (setprod R R = rational_numbers /\ Rlt (b1,b2) (a1,a2))
                    \/
                    (setprod R R = omega /\ (b1,b2) :e (a1,a2))
                    \/
                    (setprod R R = omega :\: {0} /\ (b1,b2) :e (a1,a2))
                    \/
                    (setprod R R = setprod 2 omega /\
                     exists i m j n:set,
                       i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                       (b1,b2) = (i, m) /\ (a1,a2) = (j, n) /\
                       (i :e j \/ (i = j /\ m :e n)))
                    \/
                    (setprod R R = setprod R R /\
                     exists c1 c2 d1 d2:set,
                       (b1,b2) = (c1, c2) /\ (a1,a2) = (d1, d2) /\
                       (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)))
                    \/
                    (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
                     setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (b1,b2) :e (a1,a2)).
                  apply orIL.
                  apply orIR.
                  prove setprod R R = setprod R R /\
                    exists c1 c2 d1 d2:set,
                      (b1,b2) = (c1, c2) /\ (a1,a2) = (d1, d2) /\
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
                  apply andI.
                  - reflexivity.
                  - witness b1.
                    witness b2.
                    witness a1.
                    witness a2.
                    apply and3I.
                    + reflexivity.
                    + reflexivity.
                    + exact (orIR (Rlt b1 a1) (b1 = a1 /\ Rlt b2 a2) (andI (b1 = a1) (Rlt b2 a2) Hb1eq HbaRlt)). }
                exact (Hbap Hrel).
            - assume Hba1: b1 < a1.
              claim HbaRlt: Rlt b1 a1.
              { exact (RltI b1 a1 Hb1R Ha1R Hba1). }
              claim Hrel: order_rel X b a.
              { rewrite HXR2.
                rewrite HbEq.
                rewrite HaEq.
                prove order_rel (setprod R R) (b1,b2) (a1,a2).
                prove (setprod R R = R /\ Rlt (b1,b2) (a1,a2))
                  \/
                  (setprod R R = rational_numbers /\ Rlt (b1,b2) (a1,a2))
                  \/
                  (setprod R R = omega /\ (b1,b2) :e (a1,a2))
                  \/
                  (setprod R R = omega :\: {0} /\ (b1,b2) :e (a1,a2))
                  \/
                  (setprod R R = setprod 2 omega /\
                   exists i m j n:set,
                     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                     (b1,b2) = (i, m) /\ (a1,a2) = (j, n) /\
                     (i :e j \/ (i = j /\ m :e n)))
                  \/
                  (setprod R R = setprod R R /\
                   exists c1 c2 d1 d2:set,
                     (b1,b2) = (c1, c2) /\ (a1,a2) = (d1, d2) /\
                     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)))
                  \/
                  (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
                   setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (b1,b2) :e (a1,a2)).
                apply orIL.
                apply orIR.
                prove setprod R R = setprod R R /\
                  exists c1 c2 d1 d2:set,
                    (b1,b2) = (c1, c2) /\ (a1,a2) = (d1, d2) /\
                    (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
                apply andI.
                - reflexivity.
                - witness b1.
                  witness b2.
                  witness a1.
                  witness a2.
                  apply and3I.
                  + reflexivity.
                  + reflexivity.
                  + exact (orIL (Rlt b1 a1) (b1 = a1 /\ Rlt b2 a2) HbaRlt). }
              exact (Hbap Hrel).
          - assume HneqRR: ~(X = setprod R R).
            claim HordX: ordinal X.
            { apply Hso.
              - assume Hleft6.
                apply Hleft6.
                - assume Hleft5.
                  apply Hleft5.
                  + assume Hleft4.
                    apply Hleft4.
                    * assume Hleft3.
                      apply Hleft3.
                      - assume Hleft2.
                        apply Hleft2.
                        - assume HXeq: X = R.
                           apply FalseE.
                           exact (HneqR HXeq).
                        - assume HXeq: X = rational_numbers.
                           apply FalseE.
                           exact (HneqQ HXeq).
                      - assume HXeq: X = omega.
                        apply FalseE.
                        exact (HneqO HXeq).
                    * assume HXeq: X = omega :\: {0}.
                      apply FalseE.
                      exact (HneqNz HXeq).
                  + assume HXeq: X = setprod 2 omega.
                    apply FalseE.
                    exact (Hneq2 HXeq).
                - assume HXeq: X = setprod R R.
                  apply FalseE.
                  exact (HneqRR HXeq).
              - assume Hord.
                exact Hord. }
            claim HaOrd: ordinal a.
            { exact (ordinal_Hered X HordX a HaX). }
            claim HbOrd: ordinal b.
            { exact (ordinal_Hered X HordX b HbX). }
            apply (ordinal_trichotomy_or_impred a b HaOrd HbOrd p).
            - assume Habmem: a :e b.
              claim Hrel: order_rel X a b.
              { prove (X = R /\ Rlt a b)
                  \/
                  (X = rational_numbers /\ Rlt a b)
                  \/
                  (X = omega /\ a :e b)
                  \/
                  (X = omega :\: {0} /\ a :e b)
                  \/
                  (X = setprod 2 omega /\
                   exists i m j n:set,
                     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                     a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                  \/
                  (X = setprod R R /\
                   exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                  \/
                  (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b).
                apply orIR.
                apply and6I.
                - exact HordX.
                - exact HneqR.
                - exact HneqQ.
                - exact Hneq2.
                - exact HneqRR.
                - exact Habmem. }
              exact (Habp Hrel).
            - assume Heq: a = b.
              exact (Heqp Heq).
            - assume Hbmem: b :e a.
              claim Hrel: order_rel X b a.
              { prove (X = R /\ Rlt b a)
                  \/
                  (X = rational_numbers /\ Rlt b a)
                  \/
                  (X = omega /\ b :e a)
                  \/
                  (X = omega :\: {0} /\ b :e a)
                  \/
                  (X = setprod 2 omega /\
                   exists i m j n:set,
                     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                     b = (i, m) /\ a = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                  \/
                  (X = setprod R R /\
                   exists a1 a2 b1 b2:set,
                     b = (a1, a2) /\ a = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                  \/
                  (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ b :e a).
                apply orIR.
                apply and6I.
                - exact HordX.
                - exact HneqR.
                - exact HneqQ.
                - exact Hneq2.
                - exact HneqRR.
                - exact Hbmem. }
              exact (Hbap Hrel).
Qed.

(** helper: transitivity for order_rel on simply ordered sets **)
Theorem order_rel_trans : forall X a b c:set,
  simply_ordered_set X ->
  a :e X ->
  b :e X ->
  c :e X ->
  order_rel X a b ->
  order_rel X b c ->
  order_rel X a c.
let X a b c.
assume Hso HaX HbX HcX Hab Hbc.
apply (xm (X = R)).
- assume HXR: X = R.
  rewrite HXR.
  claim HabR: order_rel R a b.
  { prove order_rel R a b.
    rewrite <- HXR at 1.
    exact Hab. }
  claim HbcR: order_rel R b c.
  { prove order_rel R b c.
    rewrite <- HXR at 1.
    exact Hbc. }
  claim Hablt: Rlt a b.
  { exact (order_rel_R_implies_Rlt a b HabR). }
  claim Hbclt: Rlt b c.
  { exact (order_rel_R_implies_Rlt b c HbcR). }
  claim Haclt: Rlt a c.
  { exact (Rlt_tra a b c Hablt Hbclt). }
  exact (Rlt_implies_order_rel_R a c Haclt).
- assume HneqR: ~(X = R).
  apply (xm (X = rational_numbers)).
  - assume HXQ: X = rational_numbers.
    rewrite HXQ.
    claim HabQ: order_rel rational_numbers a b.
    { prove order_rel rational_numbers a b.
      rewrite <- HXQ at 1.
      exact Hab. }
	    claim HbcQ: order_rel rational_numbers b c.
	    { prove order_rel rational_numbers b c.
	      rewrite <- HXQ at 1.
	      exact Hbc. }
	    claim Hm1Q: minus_SNo 1 :e rational_numbers.
	    { prove minus_SNo 1 :e rational.
	      claim HdefQ: rational_numbers = rational.
	      { reflexivity. }
	      claim H1rat: 1 :e rational.
	      { claim H1real: 1 :e real.
	        { exact real_1. }
	        claim H1omega: 1 :e omega.
	        { exact (nat_p_omega 1 nat_1). }
	        claim H1int: 1 :e int.
	        { exact (Subq_omega_int 1 H1omega). }
	        claim H1not0: 1 /:e {0}.
	        { assume H1: 1 :e {0}.
	          prove False.
	          claim Heq10: 1 = 0.
	          { exact (SingE 0 1 H1). }
	          exact (neq_1_0 Heq10). }
	        claim H1nonzero: 1 :e omega :\: {0}.
	        { exact (setminusI omega {0} 1 H1omega H1not0). }
	        claim Hrecip1: recip_SNo 1 = 1.
	        { claim H1neq0: 1 <> 0.
	          { exact neq_1_0. }
	          claim Hinv: mul_SNo 1 (recip_SNo 1) = 1.
	          { exact (recip_SNo_invR 1 SNo_1 H1neq0). }
	          rewrite <- (mul_SNo_oneL (recip_SNo 1) (SNo_recip_SNo 1 SNo_1)) at 1.
	          exact Hinv. }
	        claim Heq1: 1 = div_SNo 1 1.
	        { claim Hdivdef: div_SNo 1 1 = mul_SNo 1 (recip_SNo 1).
	          { reflexivity. }
	          rewrite Hdivdef.
	          rewrite Hrecip1.
	          rewrite (mul_SNo_oneR 1 SNo_1).
	          reflexivity. }
	        claim Hex: exists m :e int, exists n :e omega :\: {0}, 1 = div_SNo m n.
	        { witness 1.
	          apply andI.
	          - exact H1int.
	          - witness 1.
	            apply andI.
	            + exact H1nonzero.
	            + exact Heq1. }
	        exact (SepI real
	                    (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n)
	                    1
	                    H1real
	                    Hex). }
	      claim Hm1rat: minus_SNo 1 :e rational.
	      { exact (rational_minus_SNo 1 H1rat). }
	      rewrite <- HdefQ at 1.
	      exact Hm1rat. }
	    claim Hm1notomega: minus_SNo 1 /:e omega.
	    { assume Hm1: minus_SNo 1 :e omega.
	      prove False.
	      claim Hle0: 0 <= minus_SNo 1.
	      { exact (omega_nonneg (minus_SNo 1) Hm1). }
	      claim Hm1S: SNo (minus_SNo 1).
	      { exact (SNo_minus_SNo 1 SNo_1). }
	      apply (SNoLeE 0 (minus_SNo 1) SNo_0 Hm1S Hle0 False).
	      - assume H0ltm1: 0 < minus_SNo 1.
	        claim Hm1lt0: minus_SNo 1 < 0.
	        { exact minus_1_lt_0. }
	        claim H00: 0 < 0.
	        { exact (SNoLt_tra 0 (minus_SNo 1) 0 SNo_0 Hm1S SNo_0 H0ltm1 Hm1lt0). }
	        exact ((SNoLt_irref 0) H00).
	      - assume H0eqm1: 0 = minus_SNo 1.
	        claim Hm1lt0: minus_SNo 1 < 0.
	        { exact minus_1_lt_0. }
	        claim H00: 0 < 0.
	        { rewrite H0eqm1 at 1.
	          exact Hm1lt0. }
	        exact ((SNoLt_irref 0) H00). }
	    claim Hablt: Rlt a b.
	    { apply (HabQ (Rlt a b)).
	      - assume Hleft6.
	        apply (Hleft6 (Rlt a b)).
	        - assume Hleft.
	          apply (Hleft (Rlt a b)).
	          - assume Hleft2.
	            apply (Hleft2 (Rlt a b)).
	            + assume Hleft3.
	              apply (Hleft3 (Rlt a b)).
	              * assume Hleft4.
	                apply (Hleft4 (Rlt a b)).
	                - assume HA: rational_numbers = R /\ Rlt a b.
	                  exact (andER (rational_numbers = R) (Rlt a b) HA).
	                - assume HB: rational_numbers = rational_numbers /\ Rlt a b.
	                  exact (andER (rational_numbers = rational_numbers) (Rlt a b) HB).
	              * assume HC: rational_numbers = omega /\ a :e b.
	                apply FalseE.
	                claim Heq: rational_numbers = omega.
	                { exact (andEL (rational_numbers = omega) (a :e b) HC). }
	                claim Hm1omega: minus_SNo 1 :e omega.
	                { rewrite <- Heq at 1.
	                  exact Hm1Q. }
	                exact (Hm1notomega Hm1omega).
	            + assume HD: rational_numbers = omega :\: {0} /\ a :e b.
	              apply FalseE.
	              claim Heq: rational_numbers = omega :\: {0}.
	              { exact (andEL (rational_numbers = omega :\: {0}) (a :e b) HD). }
	              claim Hm1NZ: minus_SNo 1 :e omega :\: {0}.
	              { rewrite <- Heq at 1.
	                exact Hm1Q. }
	              claim Hm1omega: minus_SNo 1 :e omega.
	              { exact (setminusE1 omega {0} (minus_SNo 1) Hm1NZ). }
	              exact (Hm1notomega Hm1omega).
	          - assume HE: rational_numbers = setprod 2 omega /\
	              exists i m j n:set,
	                i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
	            apply FalseE.
	            claim Heq: rational_numbers = setprod 2 omega.
	            { exact (andEL (rational_numbers = setprod 2 omega)
	                          (exists i m j n:set,
	                            i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                            a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
	                          HE). }
	            claim H1omega: 1 :e omega.
	            { exact (nat_p_omega 1 nat_1). }
	            claim Hp: (0,1) :e setprod 2 omega.
	            { exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
	            claim HpQ: (0,1) :e rational_numbers.
	            { rewrite Heq. exact Hp. }
	            claim HSingQ: {1} :e rational_numbers.
	            { rewrite <- tuple_0_1_eq_Sing1.
	              exact HpQ. }
	            claim HSingR: {1} :e R.
	            { exact (rational_numbers_in_R {1} HSingQ). }
	            claim HSingS: SNo {1}.
	            { exact (real_SNo {1} HSingR). }
	            exact (Sing1_not_SNo HSingS).
	        - assume HF: rational_numbers = setprod R R /\
	            exists a1 a2 b1 b2:set,
	              a = (a1, a2) /\ b = (b1, b2) /\
	              (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	          apply FalseE.
	          claim Heq: rational_numbers = setprod R R.
	          { exact (andEL (rational_numbers = setprod R R)
	                         (exists a1 a2 b1 b2:set,
	                           a = (a1, a2) /\ b = (b1, b2) /\
	                           (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	                         HF). }
	          claim Heq': setprod R R = rational_numbers.
	          { symmetry. exact Heq. }
	          exact (setprod_R_R_neq_rational_numbers Heq'). 
	      - assume Hord:
	          ordinal rational_numbers /\ rational_numbers <> R /\ rational_numbers <> rational_numbers /\
	          rational_numbers <> setprod 2 omega /\ rational_numbers <> setprod R R /\ a :e b.
	        apply FalseE.
	        apply Hord. assume Hcore Haeb.
	        apply Hcore. assume Hcore2 HneqRR.
	        apply Hcore2. assume Hcore3 Hneq2omega.
	        apply Hcore3. assume HordQ HneqQQ.
	        claim Hrefl: rational_numbers = rational_numbers.
	        { reflexivity. }
	        exact (HneqQQ Hrefl). }
	    claim Hbclt: Rlt b c.
	    { apply (HbcQ (Rlt b c)).
	      - assume Hleft6.
	        apply (Hleft6 (Rlt b c)).
	        - assume Hleft.
	          apply (Hleft (Rlt b c)).
	          - assume Hleft2.
	            apply (Hleft2 (Rlt b c)).
	            + assume Hleft3.
	              apply (Hleft3 (Rlt b c)).
	              * assume Hleft4.
	                apply (Hleft4 (Rlt b c)).
	                - assume HA: rational_numbers = R /\ Rlt b c.
	                  exact (andER (rational_numbers = R) (Rlt b c) HA).
	                - assume HB: rational_numbers = rational_numbers /\ Rlt b c.
	                  exact (andER (rational_numbers = rational_numbers) (Rlt b c) HB).
	              * assume HC: rational_numbers = omega /\ b :e c.
	                apply FalseE.
	                claim Heq: rational_numbers = omega.
	                { exact (andEL (rational_numbers = omega) (b :e c) HC). }
	                claim Hm1omega: minus_SNo 1 :e omega.
	                { rewrite <- Heq at 1.
	                  exact Hm1Q. }
	                exact (Hm1notomega Hm1omega).
	            + assume HD: rational_numbers = omega :\: {0} /\ b :e c.
	              apply FalseE.
	              claim Heq: rational_numbers = omega :\: {0}.
	              { exact (andEL (rational_numbers = omega :\: {0}) (b :e c) HD). }
	              claim Hm1NZ: minus_SNo 1 :e omega :\: {0}.
	              { rewrite <- Heq at 1.
	                exact Hm1Q. }
	              claim Hm1omega: minus_SNo 1 :e omega.
	              { exact (setminusE1 omega {0} (minus_SNo 1) Hm1NZ). }
	              exact (Hm1notomega Hm1omega).
	          - assume HE: rational_numbers = setprod 2 omega /\
	              exists i m j n:set,
	                i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
	            apply FalseE.
	            claim Heq: rational_numbers = setprod 2 omega.
	            { exact (andEL (rational_numbers = setprod 2 omega)
	                          (exists i m j n:set,
	                            i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                            b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
	                          HE). }
	            claim H1omega: 1 :e omega.
	            { exact (nat_p_omega 1 nat_1). }
	            claim Hp: (0,1) :e setprod 2 omega.
	            { exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
	            claim HpQ: (0,1) :e rational_numbers.
	            { rewrite Heq. exact Hp. }
	            claim HSingQ: {1} :e rational_numbers.
	            { rewrite <- tuple_0_1_eq_Sing1.
	              exact HpQ. }
	            claim HSingR: {1} :e R.
	            { exact (rational_numbers_in_R {1} HSingQ). }
	            claim HSingS: SNo {1}.
	            { exact (real_SNo {1} HSingR). }
	            exact (Sing1_not_SNo HSingS).
	        - assume HF: rational_numbers = setprod R R /\
	            exists a1 a2 b1 b2:set,
	              b = (a1, a2) /\ c = (b1, b2) /\
	              (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	          apply FalseE.
	          claim Heq: rational_numbers = setprod R R.
	          { exact (andEL (rational_numbers = setprod R R)
	                         (exists a1 a2 b1 b2:set,
	                           b = (a1, a2) /\ c = (b1, b2) /\
	                           (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	                         HF). }
	          claim Heq': setprod R R = rational_numbers.
	          { symmetry. exact Heq. }
	          exact (setprod_R_R_neq_rational_numbers Heq').
	      - assume Hord:
	          ordinal rational_numbers /\ rational_numbers <> R /\ rational_numbers <> rational_numbers /\
	          rational_numbers <> setprod 2 omega /\ rational_numbers <> setprod R R /\ b :e c.
	        apply FalseE.
	        apply Hord. assume Hcore Haeb.
	        apply Hcore. assume Hcore2 HneqRR.
	        apply Hcore2. assume Hcore3 Hneq2omega.
	        apply Hcore3. assume HordQ HneqQQ.
	        claim Hrefl: rational_numbers = rational_numbers.
	        { reflexivity. }
	        exact (HneqQQ Hrefl). }
		    claim Haclt: Rlt a c.
		    { exact (Rlt_tra a b c Hablt Hbclt). }
		    exact (Rlt_implies_order_rel_Q a c Haclt).
	  - assume HneqQ: ~(X = rational_numbers).
	    apply (xm (X = omega)).
    - assume HXo: X = omega.
      rewrite HXo.
      claim HabO: order_rel omega a b.
      { prove order_rel omega a b.
        rewrite <- HXo at 1.
        exact Hab. }
      claim HbcO: order_rel omega b c.
      { prove order_rel omega b c.
        rewrite <- HXo at 1.
        exact Hbc. }
	      claim Habmem: a :e b.
	      { exact (order_rel_omega_implies_mem a b HabO). }
	      claim Hbcmem: b :e c.
	      { exact (order_rel_omega_implies_mem b c HbcO). }
	      claim HcOmega: c :e omega.
	      { rewrite <- HXo at 1.
	        exact HcX. }
	      claim HcNat: nat_p c.
	      { exact (omega_nat_p c HcOmega). }
	      claim HcOrd: ordinal c.
	      { exact (nat_p_ordinal c HcNat). }
      claim HcTr: TransSet c.
      { exact (ordinal_TransSet c HcOrd). }
      claim HbSubc: b c= c.
      { exact (HcTr b Hbcmem). }
      claim Hacmem: a :e c.
      { exact (HbSubc a Habmem). }
      exact (mem_implies_order_rel_omega a c Hacmem).
    - assume HneqO: ~(X = omega).
      apply (xm (X = omega :\: {0})).
      - assume HXnz: X = omega :\: {0}.
        rewrite HXnz.
        claim HabNz: order_rel (omega :\: {0}) a b.
        { prove order_rel (omega :\: {0}) a b.
          rewrite <- HXnz at 1.
          exact Hab. }
        claim HbcNz: order_rel (omega :\: {0}) b c.
        { prove order_rel (omega :\: {0}) b c.
          rewrite <- HXnz at 1.
          exact Hbc. }
        claim Habmem: a :e b.
        { exact (order_rel_omega_nonzero_implies_mem a b HabNz). }
	        claim Hbcmem: b :e c.
	        { exact (order_rel_omega_nonzero_implies_mem b c HbcNz). }
	        claim HcNZ: c :e omega :\: {0}.
	        { rewrite <- HXnz at 1.
	          exact HcX. }
	        claim HcOmega: c :e omega.
	        { exact (setminusE1 omega {0} c HcNZ). }
	        claim HcNat: nat_p c.
	        { exact (omega_nat_p c HcOmega). }
        claim HcOrd: ordinal c.
        { exact (nat_p_ordinal c HcNat). }
        claim HcTr: TransSet c.
        { exact (ordinal_TransSet c HcOrd). }
        claim HbSubc: b c= c.
        { exact (HcTr b Hbcmem). }
        claim Hacmem: a :e c.
        { exact (HbSubc a Habmem). }
        exact (mem_implies_order_rel_omega_nonzero a c Hacmem).
      - assume HneqNz: ~(X = omega :\: {0}).
        apply (xm (X = setprod 2 omega)).
        - assume HX2: X = setprod 2 omega.
          rewrite HX2.
          claim Hab2: order_rel (setprod 2 omega) a b.
          { prove order_rel (setprod 2 omega) a b.
            rewrite <- HX2 at 1.
            exact Hab. }
          claim Hbc2: order_rel (setprod 2 omega) b c.
          { prove order_rel (setprod 2 omega) b c.
            rewrite <- HX2 at 1.
            exact Hbc. }
	          claim Hexab: exists i m j n:set,
	            i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	            a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
	          { apply (Hab2 (exists i m j n:set,
	                           (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                            a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	            - assume Hleft6.
	              apply (Hleft6 (exists i m j n:set,
	                              (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                               a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	              - assume Hleft.
	                apply (Hleft (exists i m j n:set,
	                               (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	                - assume Hmid.
	                  apply (Hmid (exists i m j n:set,
	                                 (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                  a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	                  + assume Hm2.
	                    apply (Hm2 (exists i m j n:set,
	                                  (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                   a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	                    - assume Hm3.
	                      apply (Hm3 (exists i m j n:set,
	                                    (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                     a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
	                      - assume Hc1: setprod 2 omega = R /\ Rlt a b.
	                        apply FalseE.
	                        claim Heq: setprod 2 omega = R.
	                        { exact (andEL (setprod 2 omega = R) (Rlt a b) Hc1). }
	                        claim HXR: X = R.
	                        { rewrite HX2 at 1.
	                          exact Heq. }
	                        exact (HneqR HXR).
	                      - assume Hc2: setprod 2 omega = rational_numbers /\ Rlt a b.
	                        apply FalseE.
	                        claim Heq: setprod 2 omega = rational_numbers.
	                        { exact (andEL (setprod 2 omega = rational_numbers) (Rlt a b) Hc2). }
	                        claim HXQ2: X = rational_numbers.
	                        { rewrite HX2 at 1.
	                          exact Heq. }
	                        exact (HneqQ HXQ2).
	                    - assume Hc3: setprod 2 omega = omega /\ a :e b.
	                      apply FalseE.
	                      claim Heq: setprod 2 omega = omega.
	                      { exact (andEL (setprod 2 omega = omega) (a :e b) Hc3). }
	                      claim HXo2: X = omega.
	                      { rewrite HX2 at 1.
	                        exact Heq. }
	                      exact (HneqO HXo2).
	                  + assume Hc4: setprod 2 omega = omega :\: {0} /\ a :e b.
	                    apply FalseE.
	                    claim Heq: setprod 2 omega = omega :\: {0}.
	                    { exact (andEL (setprod 2 omega = omega :\: {0}) (a :e b) Hc4). }
	                    claim HXnz2: X = omega :\: {0}.
	                    { rewrite HX2 at 1.
	                      exact Heq. }
	                    exact (HneqNz HXnz2).
	                - assume Hc5: setprod 2 omega = setprod 2 omega /\
	                    exists i m j n:set,
	                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
	                  exact (andER (setprod 2 omega = setprod 2 omega)
	                               (exists i m j n:set,
	                                 i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                 a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
	                               Hc5).
	              - assume Hc6: setprod 2 omega = setprod R R /\
	                  exists a1 a2 b1 b2:set,
	                    a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	                apply FalseE.
	                claim Heq: setprod 2 omega = setprod R R.
	                { exact (andEL (setprod 2 omega = setprod R R)
	                              (exists a1 a2 b1 b2:set,
	                                a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	                              Hc6). }
	                claim Heq2: setprod R R = setprod 2 omega.
	                { symmetry.
	                  exact Heq. }
	                exact (setprod_R_R_neq_setprod_2_omega Heq2).
	            - assume Hord:
	                ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\
	                setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ a :e b.
	              apply FalseE.
	              apply Hord. assume Hcore Haeb.
	              apply Hcore. assume Hcore2 HneqRR.
	              apply Hcore2. assume Hcore3 HneqXX.
	              claim Hrefl: setprod 2 omega = setprod 2 omega.
	              { reflexivity. }
	              exact (HneqXX Hrefl). }
	          claim Hexbc: exists j2 n2 k p:set,
	            j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	            b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p)).
	          { apply (Hbc2 (exists j2 n2 k p:set,
	                           (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                            b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	            - assume Hleft6.
	              apply (Hleft6 (exists j2 n2 k p:set,
	                              (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                               b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	              - assume Hleft.
	                apply (Hleft (exists j2 n2 k p:set,
	                               (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                                b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	                - assume Hmid.
	                  apply (Hmid (exists j2 n2 k p:set,
	                                 (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                                  b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	                  + assume Hm2.
	                    apply (Hm2 (exists j2 n2 k p:set,
	                                  (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                                   b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	                    - assume Hm3.
	                      apply (Hm3 (exists j2 n2 k p:set,
	                                    (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                                     b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p))))).
	                      - assume Hc1: setprod 2 omega = R /\ Rlt b c.
	                        apply FalseE.
	                        claim Heq: setprod 2 omega = R.
	                        { exact (andEL (setprod 2 omega = R) (Rlt b c) Hc1). }
	                        claim HXR: X = R.
	                        { rewrite HX2 at 1.
	                          exact Heq. }
	                        exact (HneqR HXR).
	                      - assume Hc2: setprod 2 omega = rational_numbers /\ Rlt b c.
	                        apply FalseE.
	                        claim Heq: setprod 2 omega = rational_numbers.
	                        { exact (andEL (setprod 2 omega = rational_numbers) (Rlt b c) Hc2). }
	                        claim HXQ2: X = rational_numbers.
	                        { rewrite HX2 at 1.
	                          exact Heq. }
	                        exact (HneqQ HXQ2).
	                    - assume Hc3: setprod 2 omega = omega /\ b :e c.
	                      apply FalseE.
	                      claim Heq: setprod 2 omega = omega.
	                      { exact (andEL (setprod 2 omega = omega) (b :e c) Hc3). }
	                      claim HXo2: X = omega.
	                      { rewrite HX2 at 1.
	                        exact Heq. }
	                      exact (HneqO HXo2).
	                  + assume Hc4: setprod 2 omega = omega :\: {0} /\ b :e c.
	                    apply FalseE.
	                    claim Heq: setprod 2 omega = omega :\: {0}.
	                    { exact (andEL (setprod 2 omega = omega :\: {0}) (b :e c) Hc4). }
	                    claim HXnz2: X = omega :\: {0}.
	                    { rewrite HX2 at 1.
	                      exact Heq. }
	                    exact (HneqNz HXnz2).
	                - assume Hc5: setprod 2 omega = setprod 2 omega /\
	                    exists j2 n2 k p:set,
	                      j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                      b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p)).
	                  exact (andER (setprod 2 omega = setprod 2 omega)
	                               (exists j2 n2 k p:set,
	                                 j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\
	                                 b = (j2, n2) /\ c = (k, p) /\ (j2 :e k \/ (j2 = k /\ n2 :e p)))
	                               Hc5).
	              - assume Hc6: setprod 2 omega = setprod R R /\
	                  exists a1 a2 b1 b2:set,
	                    b = (a1, a2) /\ c = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	                apply FalseE.
	                claim Heq: setprod 2 omega = setprod R R.
	                { exact (andEL (setprod 2 omega = setprod R R)
	                              (exists a1 a2 b1 b2:set,
	                                b = (a1, a2) /\ c = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	                              Hc6). }
	                claim Heq2: setprod R R = setprod 2 omega.
	                { symmetry.
	                  exact Heq. }
	                exact (setprod_R_R_neq_setprod_2_omega Heq2).
	            - assume Hord:
	                ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\
	                setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ b :e c.
	              apply FalseE.
	              apply Hord. assume Hcore Haeb.
	              apply Hcore. assume Hcore2 HneqRR.
	              apply Hcore2. assume Hcore3 HneqXX.
	              claim Hrefl: setprod 2 omega = setprod 2 omega.
	              { reflexivity. }
	              exact (HneqXX Hrefl). }
          apply Hexab.
          let i. assume HiPair. apply HiPair.
          let m. assume HmPair. apply HmPair.
          let j. assume HjPair. apply HjPair.
          let n. assume HabCore.
          apply Hexbc.
          let j2. assume Hj2Pair. apply Hj2Pair.
          let n2. assume Hn2Pair. apply Hn2Pair.
          let k. assume HkPair. apply HkPair.
          let p. assume HbcCore.
          claim HabCoords: (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m) /\ b = (j, n)).
          { apply HabCore. assume Hc0 Hlex0. exact Hc0. }
          claim HabLex: i :e j \/ (i = j /\ m :e n).
          { apply HabCore. assume Hc0 Hlex0. exact Hlex0. }
          claim HbcCoords: (j2 :e 2 /\ n2 :e omega /\ k :e 2 /\ p :e omega /\ b = (j2, n2) /\ c = (k, p)).
          { apply HbcCore. assume Hc0 Hlex0. exact Hc0. }
          claim HbcLex: j2 :e k \/ (j2 = k /\ n2 :e p).
          { apply HbcCore. assume Hc0 Hlex0. exact Hlex0. }
          claim Hbeq1: b = (j, n).
          { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m))
                         (b = (j, n))
                         HabCoords). }
	          claim HbEq2: b = (j2, n2).
	          { set T0 := ((((j2 :e 2 /\ n2 :e omega) /\ k :e 2) /\ p :e omega) /\ b = (j2, n2)).
	            set T1 := (((j2 :e 2 /\ n2 :e omega) /\ k :e 2) /\ p :e omega).
	            claim Hbc0: T0.
	            { exact (andEL T0 (c = (k, p)) HbcCoords). }
	            exact (andER T1 (b = (j2, n2)) Hbc0). }
	          claim HbEqTuples: (j, n) = (j2, n2).
	          { rewrite <- Hbeq1 at 1.
	            exact HbEq2. }
          claim Hjjn: j = j2 /\ n = n2.
          { exact (tuple_eq_coords j n j2 n2 HbEqTuples). }
          claim Hjj: j = j2.
          { exact (andEL (j = j2) (n = n2) Hjjn). }
	          claim Hnn: n = n2.
	          { exact (andER (j = j2) (n = n2) Hjjn). }
	          set HabT0 := (i :e 2 /\ m :e omega).
	          set HabT1 := (HabT0 /\ j :e 2).
	          set HabT2 := (HabT1 /\ n :e omega).
	          set HabT3 := (HabT2 /\ a = (i, m)).
	          set HabT4 := (HabT3 /\ b = (j, n)).
	          set HbcT0 := (j2 :e 2 /\ n2 :e omega).
	          set HbcT1 := (HbcT0 /\ k :e 2).
	          set HbcT2 := (HbcT1 /\ p :e omega).
	          set HbcT3 := (HbcT2 /\ b = (j2, n2)).
	          set HbcT4 := (HbcT3 /\ c = (k, p)).
	          claim Hab3: HabT3.
	          { exact (andEL HabT3 (b = (j, n)) HabCoords). }
	          claim Hab2: HabT2.
	          { exact (andEL HabT2 (a = (i, m)) Hab3). }
	          claim Hab1: HabT1.
	          { exact (andEL HabT1 (n :e omega) Hab2). }
	          claim Hab0: HabT0.
	          { exact (andEL HabT0 (j :e 2) Hab1). }
	          claim Hi2: i :e 2.
	          { exact (andEL (i :e 2) (m :e omega) Hab0). }
	          claim HmO: m :e omega.
	          { exact (andER (i :e 2) (m :e omega) Hab0). }
	          claim Hbc3: HbcT3.
	          { exact (andEL HbcT3 (c = (k, p)) HbcCoords). }
	          claim Hbc2: HbcT2.
	          { exact (andEL HbcT2 (b = (j2, n2)) Hbc3). }
	          claim Hbc1: HbcT1.
	          { exact (andEL HbcT1 (p :e omega) Hbc2). }
	          claim Hbc0: HbcT0.
	          { exact (andEL HbcT0 (k :e 2) Hbc1). }
	          claim Hj2in: j2 :e 2.
	          { exact (andEL (j2 :e 2) (n2 :e omega) Hbc0). }
	          claim Hk2: k :e 2.
	          { exact (andER HbcT0 (k :e 2) Hbc1). }
	          claim HpO: p :e omega.
	          { exact (andER HbcT1 (p :e omega) Hbc2). }
	          claim HaEq: a = (i, m).
	          { exact (andER HabT2 (a = (i, m)) Hab3). }
	          claim HcEq: c = (k, p).
	          { exact (andER HbcT3 (c = (k, p)) HbcCoords). }
	          claim Hj2kLex: j :e k \/ (j = k /\ n :e p).
	          { rewrite Hjj.
	            rewrite Hnn.
	            exact HbcLex. }
          claim Hcmp: i :e k \/ (i = k /\ m :e p).
          { apply (HabLex (i :e k \/ (i = k /\ m :e p))).
            - assume Hij: i :e j.
              apply (Hj2kLex (i :e k \/ (i = k /\ m :e p))).
              + assume Hjk: j :e k.
                apply orIL.
                claim H2ord: ordinal 2.
                { exact ordinal_2. }
                claim HkOrd: ordinal k.
                { exact (ordinal_Hered 2 H2ord k Hk2). }
                claim HkTr: TransSet k.
                { exact (ordinal_TransSet k HkOrd). }
                claim HjSubk: j c= k.
                { exact (HkTr j Hjk). }
                exact (HjSubk i Hij).
              + assume Hjkeq: j = k /\ n :e p.
                apply orIL.
                claim Hjk: j = k.
                { exact (andEL (j = k) (n :e p) Hjkeq). }
                rewrite <- Hjk.
                exact Hij.
            - assume Hijeq: i = j /\ m :e n.
              claim HijEq: i = j.
              { exact (andEL (i = j) (m :e n) Hijeq). }
              claim Hmn: m :e n.
              { exact (andER (i = j) (m :e n) Hijeq). }
              apply (Hj2kLex (i :e k \/ (i = k /\ m :e p))).
              + assume Hjk: j :e k.
                apply orIL.
                rewrite HijEq.
                exact Hjk.
              + assume Hjkeq: j = k /\ n :e p.
                claim HjkEq: j = k.
                { exact (andEL (j = k) (n :e p) Hjkeq). }
                claim Hnp: n :e p.
                { exact (andER (j = k) (n :e p) Hjkeq). }
                apply orIR.
                apply andI.
                * rewrite HijEq.
                  exact HjkEq.
                * claim HpNat: nat_p p.
                  { exact (omega_nat_p p HpO). }
                  claim HpOrd: ordinal p.
                  { exact (nat_p_ordinal p HpNat). }
                  claim HpTr: TransSet p.
                  { exact (ordinal_TransSet p HpOrd). }
                  claim HnSubp: n c= p.
                  { exact (HpTr n Hnp). }
                  exact (HnSubp m Hmn). }
          rewrite HaEq.
          rewrite HcEq.
          exact (order_rel_setprod_2_omega_intro i m k p Hi2 HmO Hk2 HpO Hcmp).
        - assume Hneq2: ~(X = setprod 2 omega).
          apply (xm (X = setprod R R)).
          - assume HXRR: X = setprod R R.
            rewrite HXRR.
            claim HabRR: order_rel (setprod R R) a b.
            { prove order_rel (setprod R R) a b.
              rewrite <- HXRR at 1.
              exact Hab. }
            claim HbcRR: order_rel (setprod R R) b c.
            { prove order_rel (setprod R R) b c.
              rewrite <- HXRR at 1.
              exact Hbc. }
	            claim Hexab: exists a1 a2 b1 b2:set,
	              a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	            { apply (HabRR (exists a1 a2 b1 b2:set,
	                             (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	              - assume Hleft6.
	                apply (Hleft6 (exists a1 a2 b1 b2:set,
	                                (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	                - assume Hleft.
	                  apply (Hleft (exists a1 a2 b1 b2:set,
	                                 (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	                  - assume Hleft2.
	                    apply (Hleft2 (exists a1 a2 b1 b2:set,
	                                    (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	                    + assume Hleft3.
	                      apply (Hleft3 (exists a1 a2 b1 b2:set,
	                                      (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	                      * assume Hleft4.
	                        apply (Hleft4 (exists a1 a2 b1 b2:set,
	                                        (a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))))).
	                        - assume Hc1: setprod R R = R /\ Rlt a b.
	                          apply FalseE.
	                          claim Heq: setprod R R = R.
	                          { exact (andEL (setprod R R = R) (Rlt a b) Hc1). }
	                          claim HXR: X = R.
	                          { rewrite HXRR at 1.
	                            exact Heq. }
	                          exact (HneqR HXR).
	                        - assume Hc2: setprod R R = rational_numbers /\ Rlt a b.
	                          apply FalseE.
	                          claim Heq: setprod R R = rational_numbers.
	                          { exact (andEL (setprod R R = rational_numbers) (Rlt a b) Hc2). }
	                          claim HXQ2: X = rational_numbers.
	                          { rewrite HXRR at 1.
	                            exact Heq. }
	                          exact (HneqQ HXQ2).
	                      * assume Hc3: setprod R R = omega /\ a :e b.
	                        apply FalseE.
	                        claim Heq: setprod R R = omega.
	                        { exact (andEL (setprod R R = omega) (a :e b) Hc3). }
	                        claim HXo2: X = omega.
	                        { rewrite HXRR at 1.
	                          exact Heq. }
	                        exact (HneqO HXo2).
	                    + assume Hc4: setprod R R = omega :\: {0} /\ a :e b.
	                      apply FalseE.
	                      claim Heq: setprod R R = omega :\: {0}.
	                      { exact (andEL (setprod R R = omega :\: {0}) (a :e b) Hc4). }
	                      claim HXnz2: X = omega :\: {0}.
	                      { rewrite HXRR at 1.
	                        exact Heq. }
	                      exact (HneqNz HXnz2).
	                  - assume Hc5: setprod R R = setprod 2 omega /\
	                      exists i m j n:set,
	                        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                         a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))).
	                    apply FalseE.
	                    claim Heq: setprod R R = setprod 2 omega.
	                    { exact (andEL (setprod R R = setprod 2 omega)
	                                  (exists i m j n:set,
	                                    (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                     a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
	                                  Hc5). }
	                    exact (setprod_R_R_neq_setprod_2_omega Heq).
	                - assume Hc6: setprod R R = setprod R R /\
	                    exists a1 a2 b1 b2:set,
	                      a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	                  exact (andER (setprod R R = setprod R R)
	                               (exists a1 a2 b1 b2:set,
	                                 a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	                               Hc6).
	              - assume Hord:
	                  ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
	                  setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ a :e b.
	                apply FalseE.
	                apply Hord. assume Hcore Haeb.
	                apply Hcore. assume Hcore2 HneqRR.
	                claim Hrefl: setprod R R = setprod R R.
	                { reflexivity. }
	                exact (HneqRR Hrefl). }
	            claim Hexbc: exists b1 b2 c1 c2:set,
	              b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2)).
	            { apply (HbcRR (exists b1 b2 c1 c2:set,
	                             (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	              - assume Hleft6.
	                apply (Hleft6 (exists b1 b2 c1 c2:set,
	                                (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	                - assume Hleft.
	                  apply (Hleft (exists b1 b2 c1 c2:set,
	                                 (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	                  - assume Hleft2.
	                    apply (Hleft2 (exists b1 b2 c1 c2:set,
	                                    (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	                    + assume Hleft3.
	                      apply (Hleft3 (exists b1 b2 c1 c2:set,
	                                      (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	                      * assume Hleft4.
	                        apply (Hleft4 (exists b1 b2 c1 c2:set,
	                                        (b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))))).
	                        - assume Hc1: setprod R R = R /\ Rlt b c.
	                          apply FalseE.
	                          claim Heq: setprod R R = R.
	                          { exact (andEL (setprod R R = R) (Rlt b c) Hc1). }
	                          claim HXR: X = R.
	                          { rewrite HXRR at 1.
	                            exact Heq. }
	                          exact (HneqR HXR).
	                        - assume Hc2: setprod R R = rational_numbers /\ Rlt b c.
	                          apply FalseE.
	                          claim Heq: setprod R R = rational_numbers.
	                          { exact (andEL (setprod R R = rational_numbers) (Rlt b c) Hc2). }
	                          claim HXQ2: X = rational_numbers.
	                          { rewrite HXRR at 1.
	                            exact Heq. }
	                          exact (HneqQ HXQ2).
	                      * assume Hc3: setprod R R = omega /\ b :e c.
	                        apply FalseE.
	                        claim Heq: setprod R R = omega.
	                        { exact (andEL (setprod R R = omega) (b :e c) Hc3). }
	                        claim HXo2: X = omega.
	                        { rewrite HXRR at 1.
	                          exact Heq. }
	                        exact (HneqO HXo2).
	                    + assume Hc4: setprod R R = omega :\: {0} /\ b :e c.
	                      apply FalseE.
	                      claim Heq: setprod R R = omega :\: {0}.
	                      { exact (andEL (setprod R R = omega :\: {0}) (b :e c) Hc4). }
	                      claim HXnz2: X = omega :\: {0}.
	                      { rewrite HXRR at 1.
	                        exact Heq. }
	                      exact (HneqNz HXnz2).
	                  - assume Hc5: setprod R R = setprod 2 omega /\
	                      exists i m j n:set,
	                        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                         b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n))).
	                    apply FalseE.
	                    claim Heq: setprod R R = setprod 2 omega.
	                    { exact (andEL (setprod R R = setprod 2 omega)
	                                  (exists i m j n:set,
	                                    (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                                     b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
	                                  Hc5). }
	                    exact (setprod_R_R_neq_setprod_2_omega Heq).
	                - assume Hc6: setprod R R = setprod R R /\
	                    exists b1 b2 c1 c2:set,
	                      b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2)).
	                  exact (andER (setprod R R = setprod R R)
	                               (exists b1 b2 c1 c2:set,
	                                 b = (b1, b2) /\ c = (c1, c2) /\ (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2)))
	                               Hc6).
	              - assume Hord:
	                  ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
	                  setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ b :e c.
	                apply FalseE.
	                apply Hord. assume Hcore Haeb.
	                apply Hcore. assume Hcore2 HneqRR.
	                claim Hrefl: setprod R R = setprod R R.
	                { reflexivity. }
	                exact (HneqRR Hrefl). }
            apply Hexab.
            let a1. assume Ha1Pair. apply Ha1Pair.
            let a2. assume Ha2Pair. apply Ha2Pair.
            let b1. assume Hb1Pair. apply Hb1Pair.
            let b2. assume HabCore.
            apply Hexbc.
            let b1x. assume Hb1xPair. apply Hb1xPair.
            let b2x. assume Hb2xPair. apply Hb2xPair.
            let c1. assume Hc1Pair. apply Hc1Pair.
            let c2. assume HbcCore.
            claim HabCoords: a = (a1, a2) /\ b = (b1, b2).
            { exact (andEL (a = (a1, a2) /\ b = (b1, b2))
                           (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
                           HabCore). }
            claim HabCmp: Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2).
            { exact (andER (a = (a1, a2) /\ b = (b1, b2))
                           (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
                           HabCore). }
            claim HbcCoords: b = (b1x, b2x) /\ c = (c1, c2).
            { exact (andEL (b = (b1x, b2x) /\ c = (c1, c2))
                           (Rlt b1x c1 \/ (b1x = c1 /\ Rlt b2x c2))
                           HbcCore). }
            claim HbcCmp: Rlt b1x c1 \/ (b1x = c1 /\ Rlt b2x c2).
            { exact (andER (b = (b1x, b2x) /\ c = (c1, c2))
                           (Rlt b1x c1 \/ (b1x = c1 /\ Rlt b2x c2))
                           HbcCore). }
            claim HbEqTuples: (b1, b2) = (b1x, b2x).
            { claim HbEq1: b = (b1, b2).
              { exact (andER (a = (a1, a2)) (b = (b1, b2)) HabCoords). }
              claim HbEq2: b = (b1x, b2x).
              { exact (andEL (b = (b1x, b2x)) (c = (c1, c2)) HbcCoords). }
              rewrite <- HbEq1 at 1.
              exact HbEq2. }
            claim Hbcoords: b1 = b1x /\ b2 = b2x.
            { exact (tuple_eq_coords b1 b2 b1x b2x HbEqTuples). }
            claim Hb1eq: b1 = b1x.
            { exact (andEL (b1 = b1x) (b2 = b2x) Hbcoords). }
            claim Hb2eq: b2 = b2x.
            { exact (andER (b1 = b1x) (b2 = b2x) Hbcoords). }
            claim HbcCmp2: Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2).
            { apply (HbcCmp (Rlt b1 c1 \/ (b1 = c1 /\ Rlt b2 c2))).
              - assume Hb1xc1: Rlt b1x c1.
                apply orIL.
                rewrite Hb1eq at 1.
                exact Hb1xc1.
              - assume Hb1xeq: b1x = c1 /\ Rlt b2x c2.
                claim Hb1xeq2: b1x = c1.
                { exact (andEL (b1x = c1) (Rlt b2x c2) Hb1xeq). }
                claim Hb2xlt: Rlt b2x c2.
                { exact (andER (b1x = c1) (Rlt b2x c2) Hb1xeq). }
                apply orIR.
                apply andI.
                + rewrite Hb1eq at 1.
                  exact Hb1xeq2.
                + rewrite Hb2eq at 1.
                  exact Hb2xlt. }
            claim HacCmp: Rlt a1 c1 \/ (a1 = c1 /\ Rlt a2 c2).
            { apply (HabCmp (Rlt a1 c1 \/ (a1 = c1 /\ Rlt a2 c2))).
              - assume Ha1b1: Rlt a1 b1.
                apply (HbcCmp2 (Rlt a1 c1 \/ (a1 = c1 /\ Rlt a2 c2))).
                + assume Hb1c1: Rlt b1 c1.
                  apply orIL.
                  exact (Rlt_tra a1 b1 c1 Ha1b1 Hb1c1).
                + assume Hb1eqc1: b1 = c1 /\ Rlt b2 c2.
                  apply orIL.
                  claim Hb1eq2: b1 = c1.
                  { exact (andEL (b1 = c1) (Rlt b2 c2) Hb1eqc1). }
                  rewrite <- Hb1eq2.
                  exact Ha1b1.
              - assume Ha1eqb1: a1 = b1 /\ Rlt a2 b2.
                claim Ha1eq: a1 = b1.
                { exact (andEL (a1 = b1) (Rlt a2 b2) Ha1eqb1). }
                claim Ha2lt: Rlt a2 b2.
                { exact (andER (a1 = b1) (Rlt a2 b2) Ha1eqb1). }
                apply (HbcCmp2 (Rlt a1 c1 \/ (a1 = c1 /\ Rlt a2 c2))).
                + assume Hb1c1: Rlt b1 c1.
                  apply orIL.
                  rewrite Ha1eq.
                  exact Hb1c1.
                + assume Hb1eqc1: b1 = c1 /\ Rlt b2 c2.
                  claim Hb1eq2: b1 = c1.
                  { exact (andEL (b1 = c1) (Rlt b2 c2) Hb1eqc1). }
                  claim Hb2lt: Rlt b2 c2.
                  { exact (andER (b1 = c1) (Rlt b2 c2) Hb1eqc1). }
                  apply orIR.
                  apply andI.
                  * rewrite Ha1eq.
                    exact Hb1eq2.
                  * exact (Rlt_tra a2 b2 c2 Ha2lt Hb2lt). }
            claim HaEq: a = (a1, a2).
            { exact (andEL (a = (a1, a2)) (b = (b1, b2)) HabCoords). }
            claim HcEq: c = (c1, c2).
            { exact (andER (b = (b1x, b2x)) (c = (c1, c2)) HbcCoords). }
            rewrite HaEq.
            rewrite HcEq.
            prove order_rel (setprod R R) (a1,a2) (c1,c2).
            prove (setprod R R = R /\ Rlt (a1,a2) (c1,c2))
              \/
              (setprod R R = rational_numbers /\ Rlt (a1,a2) (c1,c2))
              \/
              (setprod R R = omega /\ (a1,a2) :e (c1,c2))
              \/
              (setprod R R = omega :\: {0} /\ (a1,a2) :e (c1,c2))
              \/
              (setprod R R = setprod 2 omega /\
               exists i m j n:set,
                 (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                  (a1,a2) = (i, m) /\ (c1,c2) = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
              \/
              (setprod R R = setprod R R /\
               exists x1 x2 y1 y2:set,
                 (a1,a2) = (x1, x2) /\ (c1,c2) = (y1, y2) /\
                 (Rlt x1 y1 \/ (x1 = y1 /\ Rlt x2 y2)))
              \/
              (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
               setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (a1,a2) :e (c1,c2)).
            apply orIL.
            apply orIR.
            prove setprod R R = setprod R R /\
              exists x1 x2 y1 y2:set,
                (a1,a2) = (x1, x2) /\ (c1,c2) = (y1, y2) /\
                (Rlt x1 y1 \/ (x1 = y1 /\ Rlt x2 y2)).
            apply andI.
            - reflexivity.
            - witness a1.
              witness a2.
              witness c1.
              witness c2.
              apply andI.
              + apply andI.
                * reflexivity.
                * reflexivity.
              + exact HacCmp.
          - assume HneqRR: ~(X = setprod R R).
            (** ordinal case for all other carriers **)
            claim HordX: ordinal X.
            { apply Hso.
              - assume Hleft6.
                apply Hleft6.
                - assume Hleft5.
                  apply Hleft5.
                  + assume Hleft4.
                    apply Hleft4.
                    * assume Hleft3.
                      apply Hleft3.
                      - assume Hleft2.
                        apply Hleft2.
                        - assume HXeq: X = R.
                          apply FalseE.
                          exact (HneqR HXeq).
                        - assume HXeq: X = rational_numbers.
                          apply FalseE.
                          exact (HneqQ HXeq).
                      - assume HXeq: X = omega.
                        apply FalseE.
                        exact (HneqO HXeq).
                    * assume HXeq: X = omega :\: {0}.
                      apply FalseE.
                      exact (HneqNz HXeq).
                  + assume HXeq: X = setprod 2 omega.
                    apply FalseE.
                    exact (Hneq2 HXeq).
                - assume HXeq: X = setprod R R.
                  apply FalseE.
                  exact (HneqRR HXeq).
              - assume Hord.
                exact Hord. }
            claim Habmem: a :e b.
            { apply (Hab (a :e b)).
              - assume Hleft6.
                apply (Hleft6 (a :e b)).
                - assume Hleft5.
                  apply (Hleft5 (a :e b)).
                  + assume Hleft4.
                    apply (Hleft4 (a :e b)).
                    * assume Hleft3.
                      apply (Hleft3 (a :e b)).
                      - assume Hleft2.
                        apply (Hleft2 (a :e b)).
                        - assume Hc1: X = R /\ Rlt a b.
                          apply FalseE.
                          claim Heq: X = R.
                          { exact (andEL (X = R) (Rlt a b) Hc1). }
                          exact (HneqR Heq).
                        - assume Hc2: X = rational_numbers /\ Rlt a b.
                          apply FalseE.
                          claim Heq: X = rational_numbers.
                          { exact (andEL (X = rational_numbers) (Rlt a b) Hc2). }
                          exact (HneqQ Heq).
                      - assume Hc3: X = omega /\ a :e b.
                        apply FalseE.
                        claim Heq: X = omega.
                        { exact (andEL (X = omega) (a :e b) Hc3). }
                        exact (HneqO Heq).
                    * assume Hc4: X = omega :\: {0} /\ a :e b.
                      apply FalseE.
                      claim Heq: X = omega :\: {0}.
                      { exact (andEL (X = omega :\: {0}) (a :e b) Hc4). }
                      exact (HneqNz Heq).
                  + assume Hc5: X = setprod 2 omega /\
                      exists i m j n:set,
                        i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                        a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
                    apply FalseE.
                    claim Heq: X = setprod 2 omega.
                    { exact (andEL (X = setprod 2 omega)
                                  (exists i m j n:set,
                                    i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                                    a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                                  Hc5). }
                    exact (Hneq2 Heq).
                - assume Hc6: X = setprod R R /\
                    exists a1 a2 b1 b2:set,
                      a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
                  apply FalseE.
                  claim Heq: X = setprod R R.
                  { exact (andEL (X = setprod R R)
                                 (exists a1 a2 b1 b2:set,
                                   a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                                 Hc6). }
                  exact (HneqRR Heq).
              - assume Hord:
                  ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b.
                set T := ((((ordinal X /\ X <> R) /\ X <> rational_numbers) /\ X <> setprod 2 omega) /\ X <> setprod R R).
                exact (andER T (a :e b) Hord). }
            claim Hbcmem: b :e c.
            { apply (Hbc (b :e c)).
              - assume Hleft6.
                apply (Hleft6 (b :e c)).
                - assume Hleft5.
                  apply (Hleft5 (b :e c)).
                  + assume Hleft4.
                    apply (Hleft4 (b :e c)).
                    * assume Hleft3.
                      apply (Hleft3 (b :e c)).
                      - assume Hleft2.
                        apply (Hleft2 (b :e c)).
                        - assume Hc1: X = R /\ Rlt b c.
                          apply FalseE.
                          claim Heq: X = R.
                          { exact (andEL (X = R) (Rlt b c) Hc1). }
                          exact (HneqR Heq).
                        - assume Hc2: X = rational_numbers /\ Rlt b c.
                          apply FalseE.
                          claim Heq: X = rational_numbers.
                          { exact (andEL (X = rational_numbers) (Rlt b c) Hc2). }
                          exact (HneqQ Heq).
                      - assume Hc3: X = omega /\ b :e c.
                        apply FalseE.
                        claim Heq: X = omega.
                        { exact (andEL (X = omega) (b :e c) Hc3). }
                        exact (HneqO Heq).
                    * assume Hc4: X = omega :\: {0} /\ b :e c.
                      apply FalseE.
                      claim Heq: X = omega :\: {0}.
                      { exact (andEL (X = omega :\: {0}) (b :e c) Hc4). }
                      exact (HneqNz Heq).
                  + assume Hc5: X = setprod 2 omega /\
                      exists i m j n:set,
                        i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                        b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
                    apply FalseE.
                    claim Heq: X = setprod 2 omega.
                    { exact (andEL (X = setprod 2 omega)
                                  (exists i m j n:set,
                                    i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                                    b = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                                  Hc5). }
                    exact (Hneq2 Heq).
                - assume Hc6: X = setprod R R /\
                    exists a1 a2 b1 b2:set,
                      b = (a1, a2) /\ c = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
                  apply FalseE.
                  claim Heq: X = setprod R R.
                  { exact (andEL (X = setprod R R)
                                 (exists a1 a2 b1 b2:set,
                                   b = (a1, a2) /\ c = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                                 Hc6). }
                  exact (HneqRR Heq).
              - assume Hord:
                  ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ b :e c.
                set T := ((((ordinal X /\ X <> R) /\ X <> rational_numbers) /\ X <> setprod 2 omega) /\ X <> setprod R R).
                exact (andER T (b :e c) Hord). }
            claim HcOrd: ordinal c.
            { exact (ordinal_Hered X HordX c HcX). }
            claim HcTr: TransSet c.
            { exact (ordinal_TransSet c HcOrd). }
            claim HbSubc: b c= c.
            { exact (HcTr b Hbcmem). }
            claim Hacmem: a :e c.
            { exact (HbSubc a Habmem). }
            prove (X = R /\ Rlt a c)
              \/
              (X = rational_numbers /\ Rlt a c)
              \/
              (X = omega /\ a :e c)
              \/
              (X = omega :\: {0} /\ a :e c)
              \/
              (X = setprod 2 omega /\
               exists i m j n:set,
                 i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                 a = (i, m) /\ c = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
              \/
              (X = setprod R R /\
               exists a1 a2 b1 b2:set,
                 a = (a1, a2) /\ c = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
              \/
              (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e c).
            apply orIR.
            apply and6I.
            - exact HordX.
            - exact HneqR.
            - exact HneqQ.
            - exact Hneq2.
            - exact HneqRR.
            - exact Hacmem.
Qed.

(** helper: order_rel is irreflexive (by case analysis on its definition) **)
Theorem order_rel_irref : forall X x:set, ~(order_rel X x x).
let X x.
assume Hxx: order_rel X x x.
apply (Hxx False).
- assume H6.
  apply (H6 False).
  - assume H5.
    apply (H5 False).
    + assume H4.
      apply (H4 False).
      * assume H3.
        apply (H3 False).
        - assume H2.
          apply (H2 False).
          + assume HXR.
            claim Hlt: Rlt x x.
            { exact (andER (X = R) (Rlt x x) HXR). }
            claim HxR: x :e R.
            { exact (RltE_left x x Hlt). }
            exact ((not_Rlt_refl x HxR) Hlt).
          + assume HXQ.
            claim Hlt: Rlt x x.
            { exact (andER (X = rational_numbers) (Rlt x x) HXQ). }
            claim HxR: x :e R.
            { exact (RltE_left x x Hlt). }
            exact ((not_Rlt_refl x HxR) Hlt).
        - assume HXo.
          claim Hmem: x :e x.
          { exact (andER (X = omega) (x :e x) HXo). }
          exact (In_irref x Hmem).
      * assume HXo0.
        claim Hmem: x :e x.
        { exact (andER (X = omega :\: {0}) (x :e x) HXo0). }
        exact (In_irref x Hmem).
    + assume HX2o.
      claim Hex: exists i m j n:set,
        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
         x = (i, m) /\ x = (j, n) /\ (i :e j \/ (i = j /\ m :e n))).
      { exact (andER (X = setprod 2 omega)
                     (exists i m j n:set,
                       (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                        x = (i, m) /\ x = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
                     HX2o). }
      apply Hex.
      let i. assume Hmjn.
      apply Hmjn.
      let m. assume Hjnn.
      apply Hjnn.
      let j. assume Hnn.
      apply Hnn.
      let n. assume Hpack.
      claim Hcoords5:
        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
         x = (i, m) /\ x = (j, n)).
      { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ x = (i, m) /\ x = (j, n))
                     (i :e j \/ (i = j /\ m :e n))
                     Hpack). }
      claim Hcmp: i :e j \/ (i = j /\ m :e n).
      { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ x = (i, m) /\ x = (j, n))
                     (i :e j \/ (i = j /\ m :e n))
                     Hpack). }
      claim Hcoords4:
        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ x = (i, m)).
      { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ x = (i, m))
                     (x = (j, n))
                     Hcoords5). }
      claim Hxjn: x = (j, n).
      { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ x = (i, m))
                     (x = (j, n))
                     Hcoords5). }
      claim Hxim: x = (i, m).
      { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega)
                     (x = (i, m))
                     Hcoords4). }
      claim HeqPair: (i,m) = (j,n).
      { rewrite <- Hxim at 1.
        exact Hxjn. }
      claim Hij: i = j.
      { rewrite <- (tuple_2_0_eq i m).
        rewrite <- (tuple_2_0_eq j n).
        rewrite <- HeqPair.
        reflexivity. }
      claim Hmn: m = n.
      { rewrite <- (tuple_2_1_eq i m).
        rewrite <- (tuple_2_1_eq j n).
        rewrite <- HeqPair.
        reflexivity. }
      apply (Hcmp False).
      * assume Hilj: i :e j.
        claim Hii: i :e i.
        { prove i :e i.
          rewrite Hij at 2.
          exact Hilj. }
        exact (In_irref i Hii).
      * assume Hind: i = j /\ m :e n.
        claim Hmnin: m :e n.
        { exact (andER (i = j) (m :e n) Hind). }
        claim Hmm: m :e m.
        { prove m :e m.
          rewrite Hmn at 2.
          exact Hmnin. }
        exact (In_irref m Hmm).
  - assume HXRR.
    claim Hex: exists a1 a2 b1 b2:set,
      x = (a1, a2) /\ x = (b1, b2) /\
      (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
    { exact (andER (X = setprod R R)
                   (exists a1 a2 b1 b2:set,
                     x = (a1, a2) /\ x = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                   HXRR). }
    apply Hex.
    let a1. assume Ha2b1b2.
    apply Ha2b1b2.
    let a2. assume Hb1b2.
    apply Hb1b2.
    let b1. assume Hb2.
	    apply Hb2.
	    let b2. assume Hpack.
	    claim Hxyxz: x = (a1,a2) /\ x = (b1,b2).
	    { exact (andEL (x = (a1, a2) /\ x = (b1, b2))
	                   (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
	                   Hpack). }
	    claim Hcmp: Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2).
	    { exact (andER (x = (a1, a2) /\ x = (b1, b2))
	                   (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
	                   Hpack). }
	    claim Hxy: x = (a1,a2).
	    { exact (andEL (x = (a1, a2))
	                   (x = (b1, b2))
	                   Hxyxz). }
	    claim Hxz: x = (b1,b2).
	    { exact (andER (x = (a1, a2))
	                   (x = (b1, b2))
	                   Hxyxz). }
	    claim HeqPair: (a1,a2) = (b1,b2).
	    { prove (a1,a2) = (b1,b2).
	      rewrite <- Hxy at 1.
	      exact Hxz. }
	    claim Hab1: a1 = b1.
	    { rewrite <- (tuple_2_0_eq a1 a2).
	      rewrite <- (tuple_2_0_eq b1 b2).
	      rewrite <- HeqPair.
	      reflexivity. }
	    claim Hab2: a2 = b2.
	    { rewrite <- (tuple_2_1_eq a1 a2).
	      rewrite <- (tuple_2_1_eq b1 b2).
	      rewrite <- HeqPair.
	      reflexivity. }
	    apply (Hcmp False).
	    + assume Hlt: Rlt a1 b1.
	      claim Hltself: Rlt a1 a1.
	      { prove Rlt a1 a1.
	        rewrite Hab1 at 2.
	        exact Hlt. }
	      exact ((not_Rlt_refl a1 (RltE_left a1 a1 Hltself)) Hltself).
	    + assume Hlt2: a1 = b1 /\ Rlt a2 b2.
	      claim Hlt: Rlt a2 b2.
	      { exact (andER (a1 = b1) (Rlt a2 b2) Hlt2). }
	      claim Hltself: Rlt a2 a2.
	      { prove Rlt a2 a2.
	        rewrite Hab2 at 2.
	        exact Hlt. }
	      exact ((not_Rlt_refl a2 (RltE_left a2 a2 Hltself)) Hltself).
- assume Hord.
  claim Hmem: x :e x.
  { exact (andER ((((ordinal X /\ X <> R) /\ X <> rational_numbers) /\ X <> setprod 2 omega) /\ X <> setprod R R)
                 (x :e x)
                 Hord). }
  exact (In_irref x Hmem).
Qed.

(** from §16 Definition: order topology basis **)
(** LATEX VERSION: The order topology is generated by basic open intervals (a,b) together with open rays (a0,b) and (a,b0) at endpoints. **)
Definition order_topology_basis : set -> set := fun X =>
  (({I :e Power X | exists a :e X, exists b :e X,
          I = {x :e X | order_rel X a x /\ order_rel X x b}}
    :\/:
    {I :e Power X | exists b :e X, I = {x :e X | order_rel X x b}}
    :\/:
    {I :e Power X | exists a :e X, I = {x :e X | order_rel X a x}})
   :\/:
   {X}).
(** NOTE: This `order_topology_basis` includes both open intervals and open rays for all X; the TeX-definition basis is given separately as `order_topology_basis_tex`. **)

(** helper: intersection of two open intervals refines to an open interval basis element **)
Theorem order_topology_interval_refine : forall X a1 b1x a2 b2x b1 b2 x:set,
  simply_ordered_set X ->
  a1 :e X ->
  b1x :e X ->
  a2 :e X ->
  b2x :e X ->
  b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x} ->
  b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x} ->
  x :e b1 ->
  x :e b2 ->
  exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2.
let X a1 b1x a2 b2x b1 b2 x.
assume Hso Ha1X Hb1xX Ha2X Hb2xX Hb1def Hb2def Hxb1 Hxb2.
set I1 := {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
set I2 := {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
claim HxI1: x :e I1.
{ rewrite <- Hb1def.
  exact Hxb1. }
claim HxI2: x :e I2.
{ rewrite <- Hb2def.
  exact Hxb2. }
claim HxX: x :e X.
{ exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxI1). }
claim HxI1prop: order_rel X a1 x /\ order_rel X x b1x.
{ exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxI1). }
claim Ha1x: order_rel X a1 x.
{ exact (andEL (order_rel X a1 x) (order_rel X x b1x) HxI1prop). }
claim Hxb1x: order_rel X x b1x.
{ exact (andER (order_rel X a1 x) (order_rel X x b1x) HxI1prop). }
claim HxI2prop: order_rel X a2 x /\ order_rel X x b2x.
{ exact (SepE2 X (fun x0:set => order_rel X a2 x0 /\ order_rel X x0 b2x) x HxI2). }
claim Ha2x: order_rel X a2 x.
{ exact (andEL (order_rel X a2 x) (order_rel X x b2x) HxI2prop). }
claim Hxb2x: order_rel X x b2x.
{ exact (andER (order_rel X a2 x) (order_rel X x b2x) HxI2prop). }

(** choose a left endpoint among a1,a2 that is below x **)
claim Hexa: exists a3 :e X,
  (a3 = a1 \/ a3 = a2) /\
  (order_rel X a3 x /\
   ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3))).
{ apply (order_rel_trichotomy_or_impred X a1 a2 Hso Ha1X Ha2X
        (exists a3 :e X,
           (a3 = a1 \/ a3 = a2) /\
           (order_rel X a3 x /\
            ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3))))).
  - assume Ha12: order_rel X a1 a2.
    witness a2.
    apply andI.
    + exact Ha2X.
    + apply andI.
      * prove a2 = a1 \/ a2 = a2.
        apply orIR.
        reflexivity.
      * apply andI.
        - exact Ha2x.
        - apply andI.
          + prove a1 = a2 \/ order_rel X a1 a2.
            apply orIR.
            exact Ha12.
          + prove a2 = a2 \/ order_rel X a2 a2.
            apply orIL.
            reflexivity.
  - assume Haeq: a1 = a2.
    witness a1.
    apply andI.
    + exact Ha1X.
    + apply andI.
      * prove a1 = a1 \/ a1 = a2.
        apply orIL.
        reflexivity.
      * apply andI.
        - exact Ha1x.
        - apply andI.
          + prove a1 = a1 \/ order_rel X a1 a1.
            apply orIL.
            reflexivity.
          + prove a2 = a1 \/ order_rel X a2 a1.
            apply orIL.
            rewrite <- Haeq.
            reflexivity.
  - assume Ha21: order_rel X a2 a1.
    witness a1.
    apply andI.
    + exact Ha1X.
    + apply andI.
      * prove a1 = a1 \/ a1 = a2.
        apply orIL.
        reflexivity.
      * apply andI.
        - exact Ha1x.
        - apply andI.
          + prove a1 = a1 \/ order_rel X a1 a1.
            apply orIL.
            reflexivity.
          + prove a2 = a1 \/ order_rel X a2 a1.
            apply orIR.
            exact Ha21. }
apply Hexa.
let a3.
assume Ha3pack.
apply Ha3pack.
assume Ha3X Ha3core.
claim Ha3x_and_max: order_rel X a3 x /\
  ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3)).
{ exact (andER (a3 = a1 \/ a3 = a2)
               (order_rel X a3 x /\
                ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3)))
               Ha3core). }
claim Ha3x: order_rel X a3 x.
{ exact (andEL (order_rel X a3 x)
               ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3))
               Ha3x_and_max). }
claim Ha_max: (a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3).
{ exact (andER (order_rel X a3 x)
               ((a1 = a3 \/ order_rel X a1 a3) /\ (a2 = a3 \/ order_rel X a2 a3))
               Ha3x_and_max). }
claim Ha1le: a1 = a3 \/ order_rel X a1 a3.
{ exact (andEL (a1 = a3 \/ order_rel X a1 a3)
               (a2 = a3 \/ order_rel X a2 a3)
               Ha_max). }
claim Ha2le: a2 = a3 \/ order_rel X a2 a3.
{ exact (andER (a1 = a3 \/ order_rel X a1 a3)
               (a2 = a3 \/ order_rel X a2 a3)
               Ha_max). }

(** choose a right endpoint among b1x,b2x that is above x **)
claim Hexb: exists b3x :e X,
  (b3x = b1x \/ b3x = b2x) /\
  (order_rel X x b3x /\
   ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x))).
{ apply (order_rel_trichotomy_or_impred X b1x b2x Hso Hb1xX Hb2xX
        (exists b3x :e X,
           (b3x = b1x \/ b3x = b2x) /\
           (order_rel X x b3x /\
            ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x))))).
  - assume Hb12: order_rel X b1x b2x.
    witness b1x.
    apply andI.
    + exact Hb1xX.
    + apply andI.
      * prove b1x = b1x \/ b1x = b2x.
        apply orIL.
        reflexivity.
      * apply andI.
        - exact Hxb1x.
        - apply andI.
          + prove b1x = b1x \/ order_rel X b1x b1x.
            apply orIL.
            reflexivity.
          + prove b1x = b2x \/ order_rel X b1x b2x.
            apply orIR.
            exact Hb12.
  - assume Hbeq: b1x = b2x.
    witness b1x.
    apply andI.
    + exact Hb1xX.
    + apply andI.
      * prove b1x = b1x \/ b1x = b2x.
        apply orIL.
        reflexivity.
      * apply andI.
        - exact Hxb1x.
        - apply andI.
          + prove b1x = b1x \/ order_rel X b1x b1x.
            apply orIL.
            reflexivity.
          + prove b1x = b2x \/ order_rel X b1x b2x.
            apply orIL.
            exact Hbeq.
  - assume Hb21: order_rel X b2x b1x.
    witness b2x.
    apply andI.
    + exact Hb2xX.
    + apply andI.
      * prove b2x = b1x \/ b2x = b2x.
        apply orIR.
        reflexivity.
      * apply andI.
        - exact Hxb2x.
        - apply andI.
          + prove b2x = b1x \/ order_rel X b2x b1x.
            apply orIR.
            exact Hb21.
          + prove b2x = b2x \/ order_rel X b2x b2x.
            apply orIL.
            reflexivity. }
apply Hexb.
let b3x.
assume Hb3pack.
apply Hb3pack.
assume Hb3xX Hb3core.
claim Hxb3x_and_min: order_rel X x b3x /\
  ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x)).
{ exact (andER (b3x = b1x \/ b3x = b2x)
               (order_rel X x b3x /\
                ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x)))
               Hb3core). }
claim Hxb3x: order_rel X x b3x.
{ exact (andEL (order_rel X x b3x)
               ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x))
               Hxb3x_and_min). }
claim Hb_min: (b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x).
{ exact (andER (order_rel X x b3x)
               ((b3x = b1x \/ order_rel X b3x b1x) /\ (b3x = b2x \/ order_rel X b3x b2x))
               Hxb3x_and_min). }
claim Hb1ge: b3x = b1x \/ order_rel X b3x b1x.
{ exact (andEL (b3x = b1x \/ order_rel X b3x b1x)
               (b3x = b2x \/ order_rel X b3x b2x)
               Hb_min). }
claim Hb2ge: b3x = b2x \/ order_rel X b3x b2x.
{ exact (andER (b3x = b1x \/ order_rel X b3x b1x)
               (b3x = b2x \/ order_rel X b3x b2x)
               Hb_min). }

set b3 := {x0 :e X | order_rel X a3 x0 /\ order_rel X x0 b3x}.
claim Hb3basis: b3 :e order_topology_basis X.
{ (** expand `order_topology_basis` and enter the interval-family branch **)
  prove b3 :e
    (({I :e Power X | exists a :e X, exists b :e X, I = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}}
      :\/:
      {I :e Power X | exists b :e X, I = {x0 :e X | order_rel X x0 b}}
      :\/:
      {I :e Power X | exists a :e X, I = {x0 :e X | order_rel X a x0}})
     :\/:
     {X}).
  apply binunionI1.
  apply binunionI1.
  apply binunionI1.
  prove b3 :e {I :e Power X | exists a :e X, exists b :e X, I = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}}.
  apply (SepI (Power X)
              (fun I:set => exists a :e X, exists b :e X, I = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
              b3).
  - prove b3 :e Power X.
    apply (PowerI X b3).
    let y.
    assume Hy: y :e b3.
    exact (SepE1 X (fun x0:set => order_rel X a3 x0 /\ order_rel X x0 b3x) y Hy).
  - witness a3.
    apply andI.
    + exact Ha3X.
    + witness b3x.
      apply andI.
      * exact Hb3xX.
      * reflexivity. }
claim HxInb3: x :e b3.
{ apply (SepI X (fun x0:set => order_rel X a3 x0 /\ order_rel X x0 b3x) x HxX).
  apply andI.
  - exact Ha3x.
  - exact Hxb3x. }

witness b3.
apply andI.
- exact Hb3basis.
- apply andI.
  + exact HxInb3.
  + (** remaining: b3 subset b1 intersection b2; requires max and min endpoint reasoning and order_rel transitivity **)
    prove b3 c= b1 :/\: b2.
    let y.
    assume Hy: y :e b3.
    claim HyX: y :e X.
    { exact (SepE1 X (fun x0:set => order_rel X a3 x0 /\ order_rel X x0 b3x) y Hy). }
    claim Hyprop: order_rel X a3 y /\ order_rel X y b3x.
    { exact (SepE2 X (fun x0:set => order_rel X a3 x0 /\ order_rel X x0 b3x) y Hy). }
    claim Ha3y: order_rel X a3 y.
    { exact (andEL (order_rel X a3 y) (order_rel X y b3x) Hyprop). }
    claim Hyb3x: order_rel X y b3x.
    { exact (andER (order_rel X a3 y) (order_rel X y b3x) Hyprop). }
    claim Ha1y: order_rel X a1 y.
    { apply (Ha1le (order_rel X a1 y)).
      - assume Ha1eq: a1 = a3.
        rewrite Ha1eq.
        exact Ha3y.
      - assume Ha1a3: order_rel X a1 a3.
        exact (order_rel_trans X a1 a3 y Hso Ha1X Ha3X HyX Ha1a3 Ha3y). }
    claim Ha2y: order_rel X a2 y.
    { apply (Ha2le (order_rel X a2 y)).
      - assume Ha2eq: a2 = a3.
        rewrite Ha2eq.
        exact Ha3y.
      - assume Ha2a3: order_rel X a2 a3.
        exact (order_rel_trans X a2 a3 y Hso Ha2X Ha3X HyX Ha2a3 Ha3y). }
    claim Hyb1x: order_rel X y b1x.
    { apply (Hb1ge (order_rel X y b1x)).
      - assume Hb3eqb1: b3x = b1x.
        rewrite <- Hb3eqb1.
        exact Hyb3x.
      - assume Hb3ltb1: order_rel X b3x b1x.
        exact (order_rel_trans X y b3x b1x Hso HyX Hb3xX Hb1xX Hyb3x Hb3ltb1). }
    claim Hyb2x: order_rel X y b2x.
    { apply (Hb2ge (order_rel X y b2x)).
      - assume Hb3eqb2: b3x = b2x.
        rewrite <- Hb3eqb2.
        exact Hyb3x.
      - assume Hb3ltb2: order_rel X b3x b2x.
        exact (order_rel_trans X y b3x b2x Hso HyX Hb3xX Hb2xX Hyb3x Hb3ltb2). }
    claim Hyb1: y :e b1.
    { rewrite Hb1def.
      apply (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y HyX).
      apply andI.
      - exact Ha1y.
      - exact Hyb1x. }
    claim Hyb2: y :e b2.
    { rewrite Hb2def.
      apply (SepI X (fun x0:set => order_rel X a2 x0 /\ order_rel X x0 b2x) y HyX).
      apply andI.
      - exact Ha2y.
      - exact Hyb2x. }
    exact (binintersectI b1 b2 y Hyb1 Hyb2).
Qed.

(** from §14 The Order Topology: least and largest elements **)
(** LATEX VERSION: a0 is the smallest element of X if every x∈X satisfies not(x<a0); b0 is the largest if not(b0<x) for all x∈X. **)
Definition is_least_element : set -> set -> prop := fun X a0 =>
  a0 :e X /\ forall x:set, x :e X -> ~(order_rel X x a0).

Definition is_largest_element : set -> set -> prop := fun X b0 =>
  b0 :e X /\ forall x:set, x :e X -> ~(order_rel X b0 x).

(** from §14 Definition: order topology basis (TeX version) **)
(** LATEX VERSION: Assuming X has more than one element, a basis consists of (1) open intervals (a,b); (2) [a0,b) if a0 is the smallest element; (3) (a,b0] if b0 is the largest element. **)
Definition order_topology_basis_tex : set -> set := fun X =>
  ({I :e Power X | exists a :e X, exists b :e X, order_rel X a b /\ I = {x :e X | order_rel X a x /\ order_rel X x b}}
   :\/:
   {I :e Power X | exists a0 b:set, is_least_element X a0 /\ b :e X /\ order_rel X a0 b /\
     I = {x :e X | (x = a0 \/ order_rel X a0 x) /\ order_rel X x b}}
   :\/:
   {I :e Power X | exists b0 a:set, is_largest_element X b0 /\ a :e X /\ order_rel X a b0 /\
     I = {x :e X | order_rel X a x /\ (x = b0 \/ order_rel X x b0)}}).

(** from §14 Definition: order topology on a simply ordered set **)
(** LATEX VERSION: The order topology on X is the topology generated by the order-topology basis on X. **)
Definition order_topology : set -> set := fun X => generated_topology X (order_topology_basis X).

(** Helper: order topology basis satisfies basis axioms **)
Theorem order_topology_basis_is_basis : forall X:set,
  simply_ordered_set X ->
  basis_on X (order_topology_basis X).
let X.
assume Hso: simply_ordered_set X.
prove basis_on X (order_topology_basis X).
set A := order_topology_basis X c= Power X.
set Bcov := (forall x :e X, exists b :e (order_topology_basis X), x :e b).
set Bref := (forall b1 :e (order_topology_basis X),
               forall b2 :e (order_topology_basis X),
               forall x:set,
                 x :e b1 -> x :e b2 ->
                 exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2).
claim Hab: A /\ Bcov.
{ apply andI.
  - (** basis elements are subsets of X **)
	    prove order_topology_basis X c= Power X.
	    let I.
	    assume HI: I :e order_topology_basis X.
	    prove I :e Power X.
	    set Bold :=
	      ({I0 :e Power X | exists a :e X, exists b :e X,
	            I0 = {x :e X | order_rel X a x /\ order_rel X x b}}
	       :\/:
	       {I0 :e Power X | exists b :e X, I0 = {x :e X | order_rel X x b}}
	       :\/:
	       {I0 :e Power X | exists a :e X, I0 = {x :e X | order_rel X a x}}).
	    apply (binunionE Bold {X} I HI).
	    * assume HI0: I :e Bold.
	      apply (binunionE ({I0 :e Power X | exists a :e X, exists b :e X,
	              I0 = {x :e X | order_rel X a x /\ order_rel X x b}}
	         :\/:
	         {I0 :e Power X | exists b :e X, I0 = {x :e X | order_rel X x b}})
	         ({I0 :e Power X | exists a :e X, I0 = {x :e X | order_rel X a x}})
	         I HI0).
	      * assume HI12: I :e
	        ({I0 :e Power X | exists a :e X, exists b :e X,
	              I0 = {x :e X | order_rel X a x /\ order_rel X x b}}
	         :\/:
	         {I0 :e Power X | exists b :e X, I0 = {x :e X | order_rel X x b}}).
      apply (binunionE
        ({I0 :e Power X | exists a :e X, exists b :e X,
              I0 = {x :e X | order_rel X a x /\ order_rel X x b}})
        ({I0 :e Power X | exists b :e X, I0 = {x :e X | order_rel X x b}})
        I
        HI12).
      - assume HI1: I :e {I0 :e Power X | exists a :e X, exists b :e X,
            I0 = {x :e X | order_rel X a x /\ order_rel X x b}}.
         exact (SepE1 (Power X)
           (fun I0:set => exists a :e X, exists b :e X,
             I0 = {x :e X | order_rel X a x /\ order_rel X x b})
           I HI1).
      - assume HI2: I :e {I0 :e Power X | exists b :e X, I0 = {x :e X | order_rel X x b}}.
         exact (SepE1 (Power X)
           (fun I0:set => exists b :e X, I0 = {x :e X | order_rel X x b})
           I HI2).
	      * assume HI3: I :e {I0 :e Power X | exists a :e X, I0 = {x :e X | order_rel X a x}}.
	        exact (SepE1 (Power X)
	          (fun I0:set => exists a :e X, I0 = {x :e X | order_rel X a x})
	          I HI3).
	    * assume HIX: I :e {X}.
	      claim HIEq: I = X.
	      { exact (SingE X I HIX). }
	      rewrite HIEq.
	      exact (Self_In_Power X).
	  - (** cover property: every x∈X lies in the basis element X **)
	    prove forall x :e X, exists b :e (order_topology_basis X), x :e b.
	    let x.
	    assume HxX: x :e X.
	    witness X.
	    apply andI.
	    + set Bold :=
	        ({I0 :e Power X | exists a :e X, exists b :e X,
	              I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}}
	         :\/:
	         {I0 :e Power X | exists b :e X, I0 = {x0 :e X | order_rel X x0 b}}
	         :\/:
	         {I0 :e Power X | exists a :e X, I0 = {x0 :e X | order_rel X a x0}}).
	      exact (binunionI2 Bold {X} X (SingI X)).
	    + exact HxX. }
claim Href: Bref.
{ (** refinement property: handle the `{X}` basis element, admit the nontrivial interval/ray cases **)
  let b1. assume Hb1: b1 :e order_topology_basis X.
  let b2. assume Hb2: b2 :e order_topology_basis X.
  let x.
  assume Hx1: x :e b1.
  assume Hx2: x :e b2.
  prove exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2.
  set Bold :=
    ({I0 :e Power X | exists a :e X, exists b :e X,
          I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}}
     :\/:
     {I0 :e Power X | exists b :e X, I0 = {x0 :e X | order_rel X x0 b}}
     :\/:
     {I0 :e Power X | exists a :e X, I0 = {x0 :e X | order_rel X a x0}}).
  claim HsubPow: order_topology_basis X c= Power X.
  { exact (andEL A Bcov Hab). }
  apply (binunionE Bold {X} b1 Hb1).
	- assume Hb1old: b1 :e Bold.
	  apply (binunionE Bold {X} b2 Hb2).
	  + assume Hb2old: b2 :e Bold.
	      (** partial refinement inside the original 3-family basis **)
	      set Aint := {I0 :e Power X | exists a :e X, exists b :e X,
	            I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}}.
	      set Blow := {I0 :e Power X | exists b :e X, I0 = {x0 :e X | order_rel X x0 b}}.
	      set Cup := {I0 :e Power X | exists a :e X, I0 = {x0 :e X | order_rel X a x0}}.
	      claim HBdef: Bold = (Aint :\/: Blow :\/: Cup).
	      { reflexivity. }
	      claim Hb1tri: b1 :e (Aint :\/: Blow :\/: Cup).
	      { rewrite <- HBdef.
	        exact Hb1old. }
	      claim Hb2tri: b2 :e (Aint :\/: Blow :\/: Cup).
	      { rewrite <- HBdef.
	        exact Hb2old. }
	      apply (binunionE (Aint :\/: Blow) Cup b1 Hb1tri).
		      - assume Hb1AB: b1 :e (Aint :\/: Blow).
			        apply (binunionE Aint Blow b1 Hb1AB).
			        * assume Hb1A: b1 :e Aint.
			          claim Hexab1: exists a1 :e X, exists b1x :e X,
			            b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			          { exact (SepE2 (Power X)
			                    (fun I0:set => exists a1 :e X, exists b1x :e X,
			                      I0 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x})
			                    b1
			                    Hb1A). }
			          apply Hexab1.
			          let a1.
			          assume Ha1core: a1 :e X /\ exists b1x :e X,
			            b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			          apply Ha1core.
			          assume Ha1X: a1 :e X.
			          assume Hexb1x: exists b1x :e X,
			            b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			          apply Hexb1x.
			          let b1x.
			          assume Hb1xcore: b1x :e X /\ b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			          apply Hb1xcore.
			          assume Hb1xX: b1x :e X.
			          assume Hb1eq: b1 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			          apply (binunionE (Aint :\/: Blow) Cup b2 Hb2tri).
				          - assume Hb2AB: b2 :e (Aint :\/: Blow).
				            apply (binunionE Aint Blow b2 Hb2AB).
				            + assume Hb2A: b2 :e Aint.
				              claim Hexab2: exists a2 :e X, exists b2x :e X,
				                b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
				              { exact (SepE2 (Power X)
				                        (fun I0:set => exists a2 :e X, exists b2x :e X,
				                          I0 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x})
				                        b2
				                        Hb2A). }
				              apply Hexab2.
				              let a2.
				              assume Ha2core: a2 :e X /\ exists b2x :e X,
				                b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
				              apply Ha2core.
				              assume Ha2X: a2 :e X.
				              assume Hexb2x: exists b2x :e X,
				                b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
				              apply Hexb2x.
				              let b2x.
				              assume Hb2xcore: b2x :e X /\ b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
				              apply Hb2xcore.
				              assume Hb2xX: b2x :e X.
				              assume Hb2eq: b2 = {x0 :e X | order_rel X a2 x0 /\ order_rel X x0 b2x}.
				              exact (order_topology_interval_refine X a1 b1x a2 b2x b1 b2 x
				                       Hso Ha1X Hb1xX Ha2X Hb2xX Hb1eq Hb2eq Hx1 Hx2).
				            + assume Hb2B: b2 :e Blow.
				              claim Hexb0: exists b0 :e X, b2 = {x0 :e X | order_rel X x0 b0}.
				              { exact (SepE2 (Power X)
				                        (fun I0:set => exists b0 :e X, I0 = {x0 :e X | order_rel X x0 b0})
			                        b2
			                        Hb2B). }
			              apply Hexb0.
			              let b0.
			              assume Hb0core: b0 :e X /\ b2 = {x0 :e X | order_rel X x0 b0}.
			              apply Hb0core.
			              assume Hb0X: b0 :e X.
			              assume Hb2eq: b2 = {x0 :e X | order_rel X x0 b0}.
			              apply (order_rel_trichotomy_or_impred X b1x b0 Hso Hb1xX Hb0X
			                (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
			              - assume Hb1xlt: order_rel X b1x b0.
			                witness b1.
			                apply andI.
			                + exact (binunionI1 Bold {X} b1 Hb1old).
			                + apply andI.
			                  * exact Hx1.
			                  * prove b1 c= b1 :/\: b2.
			                    let y. assume Hy: y :e b1.
			                    prove y :e b1 :/\: b2.
			                    claim Hyin: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                    { rewrite <- Hb1eq.
			                      exact Hy. }
			                    claim HyX: y :e X.
			                    { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                    claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                    { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                    claim Hyub1: order_rel X y b1x.
			                    { exact (andER (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                    claim Hyub0: order_rel X y b0.
			                    { exact (order_rel_trans X y b1x b0 Hso HyX Hb1xX Hb0X Hyub1 Hb1xlt). }
			                    claim Hyb2: y :e b2.
			                    { rewrite Hb2eq.
			                      exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                    exact (binintersectI b1 b2 y Hy Hyb2).
			              - assume Hbeq: b1x = b0.
			                witness b1.
			                apply andI.
			                + exact (binunionI1 Bold {X} b1 Hb1old).
			                + apply andI.
			                  * exact Hx1.
			                  * prove b1 c= b1 :/\: b2.
			                    let y. assume Hy: y :e b1.
			                    prove y :e b1 :/\: b2.
			                    claim Hyin: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                    { rewrite <- Hb1eq.
			                      exact Hy. }
			                    claim HyX: y :e X.
			                    { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                    claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                    { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                    claim Hyub1: order_rel X y b1x.
			                    { exact (andER (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                    claim Hyub0: order_rel X y b0.
			                    { rewrite <- Hbeq.
			                      exact Hyub1. }
			                    claim Hyb2: y :e b2.
			                    { rewrite Hb2eq.
			                      exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                    exact (binintersectI b1 b2 y Hy Hyb2).
			              - assume Hb0lt: order_rel X b0 b1x.
			                set b3 := {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b0}.
			                witness b3.
			                apply andI.
			                + (** b3 in basis **)
			                  claim Hb3Pow: b3 :e Power X.
			                  { apply PowerI.
			                    let y. assume Hy: y :e b3.
			                    exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy). }
			                  claim Hexa: exists a :e X, exists b :e X,
			                    b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
			                  { witness a1.
			                    apply andI.
			                    - exact Ha1X.
			                    - witness b0.
			                      apply andI.
			                      + exact Hb0X.
			                      + reflexivity. }
			                  claim Hb3A: b3 :e Aint.
			                  { exact (SepI (Power X)
			                            (fun I0:set => exists a :e X, exists b :e X,
			                              I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
			                            b3
			                            Hb3Pow
			                            Hexa). }
			                  claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
			                  { exact (binunionI1 (Aint :\/: Blow) Cup b3
			                           (binunionI1 Aint Blow b3 Hb3A)). }
			                  claim Hb3Bold: b3 :e Bold.
			                  { rewrite HBdef.
			                    exact Hb3tri. }
			                  exact (binunionI1 Bold {X} b3 Hb3Bold).
			                + apply andI.
			                  * (** x in b3 **)
			                    claim HxIn1: x :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                    { rewrite <- Hb1eq.
			                      exact Hx1. }
			                    claim HxIn2: x :e {x0 :e X | order_rel X x0 b0}.
			                    { rewrite <- Hb2eq.
			                      exact Hx2. }
			                    claim HxX: x :e X.
			                    { exact (SepE1 X (fun x0:set => order_rel X x0 b0) x HxIn2). }
			                    claim Hxrel2: order_rel X x b0.
			                    { exact (SepE2 X (fun x0:set => order_rel X x0 b0) x HxIn2). }
			                    claim Hxrel1: order_rel X a1 x /\ order_rel X x b1x.
			                    { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxIn1). }
			                    claim Hxa1: order_rel X a1 x.
			                    { exact (andEL (order_rel X a1 x) (order_rel X x b1x) Hxrel1). }
			                    exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) x HxX
			                          (andI (order_rel X a1 x) (order_rel X x b0) Hxa1 Hxrel2)).
			                  * (** b3 subset b1 ∩ b2 **)
			                    prove b3 c= b1 :/\: b2.
			                    let y. assume Hy3: y :e b3.
			                    claim HyX: y :e X.
			                    { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy3). }
			                    claim Hyrel: order_rel X a1 y /\ order_rel X y b0.
			                    { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy3). }
			                    claim Hyla1: order_rel X a1 y.
			                    { exact (andEL (order_rel X a1 y) (order_rel X y b0) Hyrel). }
			                    claim Hyub0: order_rel X y b0.
			                    { exact (andER (order_rel X a1 y) (order_rel X y b0) Hyrel). }
			                    claim Hyub1x: order_rel X y b1x.
			                    { exact (order_rel_trans X y b0 b1x Hso HyX Hb0X Hb1xX Hyub0 Hb0lt). }
			                    claim Hyb1: y :e b1.
			                    { rewrite Hb1eq.
			                      exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y HyX
			                            (andI (order_rel X a1 y) (order_rel X y b1x) Hyla1 Hyub1x)). }
			                    claim Hyb2: y :e b2.
			                    { rewrite Hb2eq.
			                      exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                    exact (binintersectI b1 b2 y Hyb1 Hyb2).
			          - assume Hb2C: b2 :e Cup.
			            claim Hexa0: exists a0 :e X, b2 = {x0 :e X | order_rel X a0 x0}.
			            { exact (SepE2 (Power X)
			                      (fun I0:set => exists a0 :e X, I0 = {x0 :e X | order_rel X a0 x0})
			                      b2
			                      Hb2C). }
			            apply Hexa0.
			            let a0.
			            assume Ha0core: a0 :e X /\ b2 = {x0 :e X | order_rel X a0 x0}.
			            apply Ha0core.
			            assume Ha0X: a0 :e X.
			            assume Hb2eq: b2 = {x0 :e X | order_rel X a0 x0}.
			            apply (order_rel_trichotomy_or_impred X a0 a1 Hso Ha0X Ha1X
			              (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
			            - assume Ha0lt: order_rel X a0 a1.
			              witness b1.
			              apply andI.
			              + exact (binunionI1 Bold {X} b1 Hb1old).
			              + apply andI.
			                * exact Hx1.
			                * prove b1 c= b1 :/\: b2.
			                  let y. assume Hy: y :e b1.
			                  prove y :e b1 :/\: b2.
			                  claim Hyin: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                  { rewrite <- Hb1eq.
			                    exact Hy. }
			                  claim HyX: y :e X.
			                  { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                  claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                  { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                  claim Hyla1: order_rel X a1 y.
			                  { exact (andEL (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                  claim Hyla0: order_rel X a0 y.
			                  { exact (order_rel_trans X a0 a1 y Hso Ha0X Ha1X HyX Ha0lt Hyla1). }
			                  claim Hyb2: y :e b2.
			                  { rewrite Hb2eq.
			                    exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyla0). }
			                  exact (binintersectI b1 b2 y Hy Hyb2).
			            - assume Haeq: a0 = a1.
			              witness b1.
			              apply andI.
			              + exact (binunionI1 Bold {X} b1 Hb1old).
			              + apply andI.
			                * exact Hx1.
			                * prove b1 c= b1 :/\: b2.
			                  let y. assume Hy: y :e b1.
			                  prove y :e b1 :/\: b2.
			                  claim Hyin: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                  { rewrite <- Hb1eq.
			                    exact Hy. }
			                  claim HyX: y :e X.
			                  { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                  claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                  { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyin). }
			                  claim Hyla1: order_rel X a1 y.
			                  { exact (andEL (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                  claim Hyla0: order_rel X a0 y.
			                  { rewrite Haeq.
			                    exact Hyla1. }
			                  claim Hyb2: y :e b2.
			                  { rewrite Hb2eq.
			                    exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyla0). }
			                  exact (binintersectI b1 b2 y Hy Hyb2).
			            - assume Ha1lt: order_rel X a1 a0.
			              set b3 := {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1x}.
			              witness b3.
			              apply andI.
			              + (** b3 in basis **)
			                claim Hb3Pow: b3 :e Power X.
			                { apply PowerI.
			                  let y. assume Hy: y :e b3.
			                  exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy). }
			                claim Hexa: exists a :e X, exists b :e X,
			                  b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
			                { witness a0.
			                  apply andI.
			                  - exact Ha0X.
			                  - witness b1x.
			                    apply andI.
			                    + exact Hb1xX.
			                    + reflexivity. }
			                claim Hb3A: b3 :e Aint.
			                { exact (SepI (Power X)
			                          (fun I0:set => exists a :e X, exists b :e X,
			                            I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
			                          b3
			                          Hb3Pow
			                          Hexa). }
			                claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
			                { exact (binunionI1 (Aint :\/: Blow) Cup b3
			                         (binunionI1 Aint Blow b3 Hb3A)). }
			                claim Hb3Bold: b3 :e Bold.
			                { rewrite HBdef.
			                  exact Hb3tri. }
			                exact (binunionI1 Bold {X} b3 Hb3Bold).
			              + apply andI.
			                * (** x in b3 **)
			                  claim HxIn1: x :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                  { rewrite <- Hb1eq.
			                    exact Hx1. }
			                  claim HxIn2: x :e {x0 :e X | order_rel X a0 x0}.
			                  { rewrite <- Hb2eq.
			                    exact Hx2. }
			                  claim HxX: x :e X.
			                  { exact (SepE1 X (fun x0:set => order_rel X a0 x0) x HxIn2). }
			                  claim Hxa0: order_rel X a0 x.
			                  { exact (SepE2 X (fun x0:set => order_rel X a0 x0) x HxIn2). }
			                  claim Hxrel1: order_rel X a1 x /\ order_rel X x b1x.
			                  { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxIn1). }
			                  claim Hxb1x: order_rel X x b1x.
			                  { exact (andER (order_rel X a1 x) (order_rel X x b1x) Hxrel1). }
			                  exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) x HxX
			                        (andI (order_rel X a0 x) (order_rel X x b1x) Hxa0 Hxb1x)).
			                * (** b3 subset b1 ∩ b2 **)
			                  prove b3 c= b1 :/\: b2.
			                  let y. assume Hy3: y :e b3.
			                  claim HyX: y :e X.
			                  { exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy3). }
			                  claim Hyrel: order_rel X a0 y /\ order_rel X y b1x.
			                  { exact (SepE2 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy3). }
			                  claim Hyla0: order_rel X a0 y.
			                  { exact (andEL (order_rel X a0 y) (order_rel X y b1x) Hyrel). }
			                  claim Hyub1x: order_rel X y b1x.
			                  { exact (andER (order_rel X a0 y) (order_rel X y b1x) Hyrel). }
			                  claim Hyla1: order_rel X a1 y.
			                  { exact (order_rel_trans X a1 a0 y Hso Ha1X Ha0X HyX Ha1lt Hyla0). }
			                  claim Hyb1: y :e b1.
			                  { rewrite Hb1eq.
			                    exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y HyX
			                          (andI (order_rel X a1 y) (order_rel X y b1x) Hyla1 Hyub1x)). }
			                  claim Hyb2: y :e b2.
			                  { rewrite Hb2eq.
			                    exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyla0). }
			                  exact (binintersectI b1 b2 y Hyb1 Hyb2).
		        * assume Hb1B: b1 :e Blow.
		          apply (binunionE (Aint :\/: Blow) Cup b2 Hb2tri).
		          - assume Hb2AB: b2 :e (Aint :\/: Blow).
			             apply (binunionE Aint Blow b2 Hb2AB).
			             + assume Hb2A: b2 :e Aint.
			                (** b1 is a lower ray and b2 is an open interval; refine by an interval with min right endpoint **)
			                claim Hexb0: exists b0 :e X, b1 = {x0 :e X | order_rel X x0 b0}.
			                { exact (SepE2 (Power X)
			                          (fun I0:set => exists b0 :e X, I0 = {x0 :e X | order_rel X x0 b0})
			                          b1
			                          Hb1B). }
			                claim Hexab: exists a1 :e X, exists b1x :e X,
			                  b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                { exact (SepE2 (Power X)
			                          (fun I0:set => exists a :e X, exists b :e X,
			                            I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
			                          b2
			                          Hb2A). }
			                apply Hexb0.
			                let b0.
			                assume Hb0core: b0 :e X /\ b1 = {x0 :e X | order_rel X x0 b0}.
			                apply Hb0core.
			                assume Hb0X: b0 :e X.
			                assume Hb1eq: b1 = {x0 :e X | order_rel X x0 b0}.
			                apply Hexab.
			                let a1.
			                assume Ha1core: a1 :e X /\ exists b1x :e X,
			                  b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                apply Ha1core.
			                assume Ha1X: a1 :e X.
			                assume Hexb1x.
			                apply Hexb1x.
			                let b1x.
			                assume Hb1xcore: b1x :e X /\ b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                apply Hb1xcore.
			                assume Hb1xX: b1x :e X.
			                assume Hb2eq: b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                apply (order_rel_trichotomy_or_impred X b0 b1x Hso Hb0X Hb1xX
			                  (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
			                - assume Hb0b1x: order_rel X b0 b1x.
			                  set b3 := {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b0}.
			                  witness b3.
			                  apply andI.
			                  + (** b3 is a basis element **)
			                    claim Hb3Pow: b3 :e Power X.
			                    { apply PowerI.
			                      let y. assume Hy: y :e b3.
			                      exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy). }
			                    claim Hexab3: exists a :e X, exists b :e X,
			                      b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
			                    { witness a1.
			                      apply andI.
			                      - exact Ha1X.
			                      - witness b0.
			                        apply andI.
			                        + exact Hb0X.
			                        + reflexivity. }
			                    claim Hb3A: b3 :e Aint.
			                    { exact (SepI (Power X)
			                                  (fun I0:set => exists a :e X, exists b :e X,
			                                    I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
			                                  b3
			                                  Hb3Pow
			                                  Hexab3). }
			                    claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
			                    { exact (binunionI1 (Aint :\/: Blow) Cup b3
			                             (binunionI1 Aint Blow b3 Hb3A)). }
			                    claim Hb3Bold: b3 :e Bold.
			                    { rewrite HBdef.
			                      exact Hb3tri. }
			                    exact (binunionI1 Bold {X} b3 Hb3Bold).
			                  + apply andI.
			                    * (** x :e b3 **)
			                      claim HxB1: x :e {x0 :e X | order_rel X x0 b0}.
			                      { rewrite <- Hb1eq.
			                        exact Hx1. }
			                      claim HxB2: x :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                      { rewrite <- Hb2eq.
			                        exact Hx2. }
				                      claim HxX: x :e X.
				                      { exact (SepE1 X (fun x0:set => order_rel X x0 b0) x HxB1). }
				                      claim Hxrel2: order_rel X a1 x /\ order_rel X x b1x.
				                      { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxB2). }
				                      claim Hxa1: order_rel X a1 x.
				                      { exact (andEL (order_rel X a1 x) (order_rel X x b1x) Hxrel2). }
			                      claim Hxub0: order_rel X x b0.
			                      { exact (SepE2 X (fun x0:set => order_rel X x0 b0) x HxB1). }
			                      exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) x HxX
			                        (andI (order_rel X a1 x) (order_rel X x b0) Hxa1 Hxub0)).
			                    * (** b3 c= b1 :/\: b2 **)
			                      prove b3 c= b1 :/\: b2.
			                      let y. assume Hy3: y :e b3.
			                      claim HyX: y :e X.
			                      { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy3). }
			                      claim Hyrel: order_rel X a1 y /\ order_rel X y b0.
			                      { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b0) y Hy3). }
			                      claim Hyla1: order_rel X a1 y.
			                      { exact (andEL (order_rel X a1 y) (order_rel X y b0) Hyrel). }
			                      claim Hyub0: order_rel X y b0.
			                      { exact (andER (order_rel X a1 y) (order_rel X y b0) Hyrel). }
			                      claim Hyub1x: order_rel X y b1x.
			                      { exact (order_rel_trans X y b0 b1x Hso HyX Hb0X Hb1xX Hyub0 Hb0b1x). }
			                      claim Hyb1: y :e b1.
			                      { rewrite Hb1eq.
			                        exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                      claim Hyb2: y :e b2.
			                      { rewrite Hb2eq.
			                        exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y HyX
			                          (andI (order_rel X a1 y) (order_rel X y b1x) Hyla1 Hyub1x)). }
			                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
			                - assume Hb_eq: b0 = b1x.
			                  witness b2.
			                  apply andI.
			                  + exact (binunionI1 Bold {X} b2 Hb2old).
			                  + apply andI.
			                    * exact Hx2.
			                    * prove b2 c= b1 :/\: b2.
			                      let y. assume Hyb2: y :e b2.
			                      claim Hyb2Sep: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                      { rewrite <- Hb2eq.
			                        exact Hyb2. }
			                      claim HyX: y :e X.
			                      { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
			                      claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                      { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
			                      claim Hyub1x: order_rel X y b1x.
			                      { exact (andER (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                      claim Hyub0: order_rel X y b0.
			                      { rewrite Hb_eq.
			                        exact Hyub1x. }
			                      claim Hyb1: y :e b1.
			                      { rewrite Hb1eq.
			                        exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
			                - assume Hb1xb0: order_rel X b1x b0.
			                  witness b2.
			                  apply andI.
			                  + exact (binunionI1 Bold {X} b2 Hb2old).
			                  + apply andI.
			                    * exact Hx2.
			                    * prove b2 c= b1 :/\: b2.
			                      let y. assume Hyb2: y :e b2.
			                      claim Hyb2Sep: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
			                      { rewrite <- Hb2eq.
			                        exact Hyb2. }
			                      claim HyX: y :e X.
			                      { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
			                      claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
			                      { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
			                      claim Hyub1x: order_rel X y b1x.
			                      { exact (andER (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
			                      claim Hyub0: order_rel X y b0.
			                      { exact (order_rel_trans X y b1x b0 Hso HyX Hb1xX Hb0X Hyub1x Hb1xb0). }
			                      claim Hyb1: y :e b1.
			                      { rewrite Hb1eq.
			                        exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyub0). }
			                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
		             + assume Hb2B: b2 :e Blow.
		                claim Hexb0: exists b0 :e X, b1 = {x0 :e X | order_rel X x0 b0}.
		                { exact (SepE2 (Power X)
		                          (fun I0:set => exists b0 :e X, I0 = {x0 :e X | order_rel X x0 b0})
		                          b1
		                          Hb1B). }
		                claim Hexd0: exists d0 :e X, b2 = {x0 :e X | order_rel X x0 d0}.
		                { exact (SepE2 (Power X)
		                          (fun I0:set => exists d0 :e X, I0 = {x0 :e X | order_rel X x0 d0})
		                          b2
		                          Hb2B). }
		                apply Hexb0.
		                let b0.
		                assume Hb0core: b0 :e X /\ b1 = {x0 :e X | order_rel X x0 b0}.
		                apply Hb0core.
		                assume Hb0X: b0 :e X.
		                assume Hb1eq: b1 = {x0 :e X | order_rel X x0 b0}.
		                apply Hexd0.
		                let d0.
		                assume Hd0core: d0 :e X /\ b2 = {x0 :e X | order_rel X x0 d0}.
		                apply Hd0core.
		                assume Hd0X: d0 :e X.
		                assume Hb2eq: b2 = {x0 :e X | order_rel X x0 d0}.
		                apply (order_rel_trichotomy_or_impred X b0 d0 Hso Hb0X Hd0X
		                  (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
		                - assume Hbd: order_rel X b0 d0.
		                  witness b1.
		                  apply andI.
		                  + exact (binunionI1 Bold {X} b1 Hb1old).
		                  + apply andI.
		                    * exact Hx1.
		                    * prove b1 c= b1 :/\: b2.
		                      let y. assume Hy: y :e b1.
		                      prove y :e b1 :/\: b2.
		                      claim Hyb1: y :e b1.
		                      { exact Hy. }
		                      claim Hyin: y :e {x0 :e X | order_rel X x0 b0}.
		                      { rewrite <- Hb1eq.
		                        exact Hy. }
		                      claim HyX: y :e X.
		                      { exact (SepE1 X (fun x0:set => order_rel X x0 b0) y Hyin). }
		                      claim Hyrel: order_rel X y b0.
		                      { exact (SepE2 X (fun x0:set => order_rel X x0 b0) y Hyin). }
		                      claim Hyrel2: order_rel X y d0.
		                      { exact (order_rel_trans X y b0 d0 Hso HyX Hb0X Hd0X Hyrel Hbd). }
		                      claim Hyb2: y :e b2.
		                      { rewrite Hb2eq.
		                        exact (SepI X (fun x0:set => order_rel X x0 d0) y HyX Hyrel2). }
		                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
		                - assume Hbeq: b0 = d0.
		                  witness b1.
		                  apply andI.
		                  + exact (binunionI1 Bold {X} b1 Hb1old).
		                  + apply andI.
		                    * exact Hx1.
		                    * prove b1 c= b1 :/\: b2.
		                      let y. assume Hy: y :e b1.
		                      prove y :e b1 :/\: b2.
		                      claim Hyb1: y :e b1.
		                      { exact Hy. }
		                      claim Hyin: y :e {x0 :e X | order_rel X x0 b0}.
		                      { rewrite <- Hb1eq.
		                        exact Hy. }
		                      claim HyX: y :e X.
		                      { exact (SepE1 X (fun x0:set => order_rel X x0 b0) y Hyin). }
		                      claim Hyrel: order_rel X y b0.
		                      { exact (SepE2 X (fun x0:set => order_rel X x0 b0) y Hyin). }
                      claim Hyrel2: order_rel X y d0.
                      { rewrite <- Hbeq.
                        exact Hyrel. }
		                      claim Hyb2: y :e b2.
		                      { rewrite Hb2eq.
		                        exact (SepI X (fun x0:set => order_rel X x0 d0) y HyX Hyrel2). }
		                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
		                - assume Hdb: order_rel X d0 b0.
		                  witness b2.
		                  apply andI.
		                  + exact (binunionI1 Bold {X} b2 Hb2old).
		                  + apply andI.
		                    * exact Hx2.
		                    * prove b2 c= b1 :/\: b2.
		                      let y. assume Hy: y :e b2.
		                      prove y :e b1 :/\: b2.
		                      claim Hyb2: y :e b2.
		                      { exact Hy. }
		                      claim Hyin: y :e {x0 :e X | order_rel X x0 d0}.
		                      { rewrite <- Hb2eq.
		                        exact Hy. }
		                      claim HyX: y :e X.
		                      { exact (SepE1 X (fun x0:set => order_rel X x0 d0) y Hyin). }
		                      claim Hyrel: order_rel X y d0.
		                      { exact (SepE2 X (fun x0:set => order_rel X x0 d0) y Hyin). }
		                      claim Hyrel1: order_rel X y b0.
		                      { exact (order_rel_trans X y d0 b0 Hso HyX Hd0X Hb0X Hyrel Hdb). }
		                      claim Hyb1: y :e b1.
		                      { rewrite Hb1eq.
		                        exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyrel1). }
		                      exact (binintersectI b1 b2 y Hyb1 Hyb2).
		          - assume Hb2C: b2 :e Cup.
		             (** b1 is a lower ray and b2 is an upper ray; their intersection is an open interval **)
		             claim Hexb0: exists b0 :e X, b1 = {x0 :e X | order_rel X x0 b0}.
		             { exact (SepE2 (Power X)
	                           (fun I0:set => exists b0 :e X, I0 = {x0 :e X | order_rel X x0 b0})
	                           b1
	                           Hb1B). }
	             claim Hexa0: exists a0 :e X, b2 = {x0 :e X | order_rel X a0 x0}.
	             { exact (SepE2 (Power X)
	                           (fun I0:set => exists a0 :e X, I0 = {x0 :e X | order_rel X a0 x0})
	                           b2
	                           Hb2C). }
	             apply Hexb0.
	             let b0.
	             assume Hb0core: b0 :e X /\ b1 = {x0 :e X | order_rel X x0 b0}.
	             apply Hb0core.
	             assume Hb0X: b0 :e X.
	             assume Hb1eq: b1 = {x0 :e X | order_rel X x0 b0}.
	             apply Hexa0.
	             let a0.
	             assume Ha0core: a0 :e X /\ b2 = {x0 :e X | order_rel X a0 x0}.
	             apply Ha0core.
	             assume Ha0X: a0 :e X.
	             assume Hb2eq: b2 = {x0 :e X | order_rel X a0 x0}.
		             set b3 := {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0}.
		             witness b3.
		             apply andI.
		             + (** b3 is a basis element **)
		                claim Hb3Pow: b3 :e Power X.
		                { apply PowerI.
		                  let y. assume Hy: y :e b3.
		                  exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy). }
	                claim Hexab: exists a :e X, exists b :e X,
	                  b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
	                { witness a0.
	                  apply andI.
	                  - exact Ha0X.
	                  - witness b0.
	                    apply andI.
	                    + exact Hb0X.
	                    + reflexivity. }
	                claim Hb3A: b3 :e Aint.
	                { exact (SepI (Power X)
	                              (fun I0:set => exists a :e X, exists b :e X,
	                                I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
	                              b3
	                              Hb3Pow
	                              Hexab). }
	                claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
	                { exact (binunionI1 (Aint :\/: Blow) Cup b3
	                         (binunionI1 Aint Blow b3 Hb3A)). }
		                claim Hb3Bold: b3 :e Bold.
		                { rewrite HBdef.
		                  exact Hb3tri. }
		                exact (binunionI1 Bold {X} b3 Hb3Bold).
		             + apply andI.
		                - (** x :e b3 **)
		                   claim HxB1: x :e {x0 :e X | order_rel X x0 b0}.
		                   { rewrite <- Hb1eq.
		                     exact Hx1. }
		                   claim HxB2: x :e {x0 :e X | order_rel X a0 x0}.
	                   { rewrite <- Hb2eq.
	                     exact Hx2. }
	                   claim Hrelxb0: order_rel X x b0.
	                   { exact (SepE2 X (fun x0:set => order_rel X x0 b0) x HxB1). }
	                   claim Hrela0x: order_rel X a0 x.
	                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0) x HxB2). }
		                   claim HxX: x :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0) x HxB2). }
		                   exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) x HxX
		                         (andI (order_rel X a0 x) (order_rel X x b0) Hrela0x Hrelxb0)).
		                - (** b3 c= b1 :/\: b2 **)
		                   prove b3 c= b1 :/\: b2.
		                   let y. assume Hy3: y :e b3.
		                   claim HyX: y :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy3). }
	                   claim Hyrel: order_rel X a0 y /\ order_rel X y b0.
	                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy3). }
	                   claim Hyrela: order_rel X a0 y.
	                   { exact (andEL (order_rel X a0 y) (order_rel X y b0) Hyrel). }
	                   claim Hyrelb: order_rel X y b0.
	                   { exact (andER (order_rel X a0 y) (order_rel X y b0) Hyrel). }
	                   claim Hyb1: y :e b1.
	                   { rewrite Hb1eq.
	                     exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyrelb). }
	                   claim Hyb2: y :e b2.
	                   { rewrite Hb2eq.
	                     exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyrela). }
	                   exact (binintersectI b1 b2 y Hyb1 Hyb2).
	      - assume Hb1C: b1 :e Cup.
	        apply (binunionE (Aint :\/: Blow) Cup b2 Hb2tri).
	        * assume Hb2AB: b2 :e (Aint :\/: Blow).
		          apply (binunionE Aint Blow b2 Hb2AB).
		          - assume Hb2A: b2 :e Aint.
		             (** b1 is an upper ray and b2 is an open interval; refine by an interval with max left endpoint **)
		             claim Hexa0: exists a0 :e X, b1 = {x0 :e X | order_rel X a0 x0}.
		             { exact (SepE2 (Power X)
		                           (fun I0:set => exists a0 :e X, I0 = {x0 :e X | order_rel X a0 x0})
		                           b1
		                           Hb1C). }
		             claim Hexab: exists a1 :e X, exists b1x :e X,
		               b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		             { exact (SepE2 (Power X)
		                           (fun I0:set => exists a :e X, exists b :e X,
		                             I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
		                           b2
		                           Hb2A). }
		             apply Hexa0.
		             let a0.
		             assume Ha0core: a0 :e X /\ b1 = {x0 :e X | order_rel X a0 x0}.
		             apply Ha0core.
		             assume Ha0X: a0 :e X.
		             assume Hb1eq: b1 = {x0 :e X | order_rel X a0 x0}.
		             apply Hexab.
		             let a1.
		             assume Ha1core: a1 :e X /\ exists b1x :e X,
		               b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		             apply Ha1core.
		             assume Ha1X: a1 :e X.
		             assume Hexb1x.
		             apply Hexb1x.
		             let b1x.
		             assume Hb1xcore: b1x :e X /\ b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		             apply Hb1xcore.
		             assume Hb1xX: b1x :e X.
		             assume Hb2eq: b2 = {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		             apply (order_rel_trichotomy_or_impred X a0 a1 Hso Ha0X Ha1X
		               (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
		             - assume Ha0a1: order_rel X a0 a1.
		               witness b2.
		               apply andI.
		               + exact (binunionI1 Bold {X} b2 Hb2old).
		               + apply andI.
		                 * exact Hx2.
		                 * prove b2 c= b1 :/\: b2.
		                   let y. assume Hyb2: y :e b2.
		                   claim Hyb2Sep: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		                   { rewrite <- Hb2eq.
		                     exact Hyb2. }
		                   claim HyX: y :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
		                   claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
		                   { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
		                   claim Hyla1: order_rel X a1 y.
		                   { exact (andEL (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
		                   claim Hya0: order_rel X a0 y.
		                   { exact (order_rel_trans X a0 a1 y Hso Ha0X Ha1X HyX Ha0a1 Hyla1). }
		                   claim Hyb1: y :e b1.
		                   { rewrite Hb1eq.
		                     exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hya0). }
		                   exact (binintersectI b1 b2 y Hyb1 Hyb2).
		             - assume Ha01eq: a0 = a1.
		               witness b2.
		               apply andI.
		               + exact (binunionI1 Bold {X} b2 Hb2old).
		               + apply andI.
		                 * exact Hx2.
		                 * prove b2 c= b1 :/\: b2.
		                   let y. assume Hyb2: y :e b2.
		                   claim Hyb2Sep: y :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		                   { rewrite <- Hb2eq.
		                     exact Hyb2. }
		                   claim HyX: y :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
		                   claim Hyrel: order_rel X a1 y /\ order_rel X y b1x.
		                   { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y Hyb2Sep). }
		                   claim Hyla1: order_rel X a1 y.
		                   { exact (andEL (order_rel X a1 y) (order_rel X y b1x) Hyrel). }
		                   claim Hyb1: y :e b1.
		                   { rewrite Hb1eq.
		                     rewrite Ha01eq.
		                     exact (SepI X (fun x0:set => order_rel X a1 x0) y HyX Hyla1). }
		                   exact (binintersectI b1 b2 y Hyb1 Hyb2).
		             - assume Ha1a0: order_rel X a1 a0.
		               set b3 := {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1x}.
		               witness b3.
		               apply andI.
		               + (** b3 is a basis element **)
		                 claim Hb3Pow: b3 :e Power X.
		                 { apply PowerI.
		                   let y. assume Hy: y :e b3.
		                   exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy). }
		                 claim Hexab3: exists a :e X, exists b :e X,
		                   b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
		                 { witness a0.
		                   apply andI.
		                   - exact Ha0X.
		                   - witness b1x.
		                     apply andI.
		                     + exact Hb1xX.
		                     + reflexivity. }
		                 claim Hb3A: b3 :e Aint.
		                 { exact (SepI (Power X)
		                               (fun I0:set => exists a :e X, exists b :e X,
		                                 I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
		                               b3
		                               Hb3Pow
		                               Hexab3). }
		                 claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
		                 { exact (binunionI1 (Aint :\/: Blow) Cup b3
		                          (binunionI1 Aint Blow b3 Hb3A)). }
		                 claim Hb3Bold: b3 :e Bold.
		                 { rewrite HBdef.
		                   exact Hb3tri. }
		                 exact (binunionI1 Bold {X} b3 Hb3Bold).
		               + apply andI.
		                 * (** x :e b3 **)
		                   claim HxB1: x :e {x0 :e X | order_rel X a0 x0}.
		                   { rewrite <- Hb1eq.
		                     exact Hx1. }
		                   claim HxB2: x :e {x0 :e X | order_rel X a1 x0 /\ order_rel X x0 b1x}.
		                   { rewrite <- Hb2eq.
		                     exact Hx2. }
		                   claim HxX: x :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0) x HxB1). }
		                   claim Hxa0: order_rel X a0 x.
		                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0) x HxB1). }
		                   claim Hxrel2: order_rel X a1 x /\ order_rel X x b1x.
		                   { exact (SepE2 X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) x HxB2). }
		                   claim Hxb1x: order_rel X x b1x.
		                   { exact (andER (order_rel X a1 x) (order_rel X x b1x) Hxrel2). }
		                   exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) x HxX
		                     (andI (order_rel X a0 x) (order_rel X x b1x) Hxa0 Hxb1x)).
		                 * (** b3 c= b1 :/\: b2 **)
		                   prove b3 c= b1 :/\: b2.
		                   let y. assume Hy3: y :e b3.
		                   claim HyX: y :e X.
		                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy3). }
		                   claim Hyrel: order_rel X a0 y /\ order_rel X y b1x.
		                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1x) y Hy3). }
		                   claim Hyla0: order_rel X a0 y.
		                   { exact (andEL (order_rel X a0 y) (order_rel X y b1x) Hyrel). }
		                   claim Hyub1x: order_rel X y b1x.
		                   { exact (andER (order_rel X a0 y) (order_rel X y b1x) Hyrel). }
		                   claim Hyla1: order_rel X a1 y.
		                   { exact (order_rel_trans X a1 a0 y Hso Ha1X Ha0X HyX Ha1a0 Hyla0). }
		                   claim Hyb1: y :e b1.
		                   { rewrite Hb1eq.
		                     exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyla0). }
		                   claim Hyb2: y :e b2.
		                   { rewrite Hb2eq.
		                     exact (SepI X (fun x0:set => order_rel X a1 x0 /\ order_rel X x0 b1x) y HyX
		                       (andI (order_rel X a1 y) (order_rel X y b1x) Hyla1 Hyub1x)). }
		                   exact (binintersectI b1 b2 y Hyb1 Hyb2).
	          - assume Hb2B: b2 :e Blow.
	             (** b1 is an upper ray and b2 is a lower ray; their intersection is an open interval **)
	             claim Hexa0: exists a0 :e X, b1 = {x0 :e X | order_rel X a0 x0}.
	             { exact (SepE2 (Power X)
	                           (fun I0:set => exists a0 :e X, I0 = {x0 :e X | order_rel X a0 x0})
	                           b1
	                           Hb1C). }
	             claim Hexb0: exists b0 :e X, b2 = {x0 :e X | order_rel X x0 b0}.
	             { exact (SepE2 (Power X)
	                           (fun I0:set => exists b0 :e X, I0 = {x0 :e X | order_rel X x0 b0})
	                           b2
	                           Hb2B). }
	             apply Hexa0.
	             let a0.
	             assume Ha0core: a0 :e X /\ b1 = {x0 :e X | order_rel X a0 x0}.
	             apply Ha0core.
	             assume Ha0X: a0 :e X.
	             assume Hb1eq: b1 = {x0 :e X | order_rel X a0 x0}.
	             apply Hexb0.
	             let b0.
	             assume Hb0core: b0 :e X /\ b2 = {x0 :e X | order_rel X x0 b0}.
	             apply Hb0core.
	             assume Hb0X: b0 :e X.
	             assume Hb2eq: b2 = {x0 :e X | order_rel X x0 b0}.
	             set b3 := {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0}.
	             witness b3.
	             apply andI.
	             + (** b3 is a basis element **)
	                claim Hb3Pow: b3 :e Power X.
	                { apply PowerI.
	                  let y. assume Hy: y :e b3.
	                  exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy). }
	                claim Hexab: exists a :e X, exists b :e X,
	                  b3 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
	                { witness a0.
	                  apply andI.
	                  - exact Ha0X.
	                  - witness b0.
	                    apply andI.
	                    + exact Hb0X.
	                    + reflexivity. }
	                claim Hb3A: b3 :e Aint.
	                { exact (SepI (Power X)
	                              (fun I0:set => exists a :e X, exists b :e X,
	                                I0 = {x0 :e X | order_rel X a x0 /\ order_rel X x0 b})
	                              b3
	                              Hb3Pow
	                              Hexab). }
	                claim Hb3tri: b3 :e (Aint :\/: Blow :\/: Cup).
	                { exact (binunionI1 (Aint :\/: Blow) Cup b3
	                         (binunionI1 Aint Blow b3 Hb3A)). }
	                claim Hb3Bold: b3 :e Bold.
	                { rewrite HBdef.
	                  exact Hb3tri. }
	                exact (binunionI1 Bold {X} b3 Hb3Bold).
	             + apply andI.
	                - (** x :e b3 **)
	                   claim HxB1: x :e {x0 :e X | order_rel X a0 x0}.
	                   { rewrite <- Hb1eq.
	                     exact Hx1. }
	                   claim HxB2: x :e {x0 :e X | order_rel X x0 b0}.
	                   { rewrite <- Hb2eq.
	                     exact Hx2. }
	                   claim Hrela0x: order_rel X a0 x.
	                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0) x HxB1). }
	                   claim Hrelxb0: order_rel X x b0.
	                   { exact (SepE2 X (fun x0:set => order_rel X x0 b0) x HxB2). }
	                   claim HxX: x :e X.
	                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0) x HxB1). }
	                   exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) x HxX
	                         (andI (order_rel X a0 x) (order_rel X x b0) Hrela0x Hrelxb0)).
	                - (** b3 c= b1 :/\: b2 **)
	                   prove b3 c= b1 :/\: b2.
	                   let y. assume Hy3: y :e b3.
	                   claim HyX: y :e X.
	                   { exact (SepE1 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy3). }
	                   claim Hyrel: order_rel X a0 y /\ order_rel X y b0.
	                   { exact (SepE2 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b0) y Hy3). }
	                   claim Hyrela: order_rel X a0 y.
	                   { exact (andEL (order_rel X a0 y) (order_rel X y b0) Hyrel). }
	                   claim Hyrelb: order_rel X y b0.
	                   { exact (andER (order_rel X a0 y) (order_rel X y b0) Hyrel). }
	                   claim Hyb1: y :e b1.
	                   { rewrite Hb1eq.
	                     exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hyrela). }
	                   claim Hyb2: y :e b2.
	                   { rewrite Hb2eq.
	                     exact (SepI X (fun x0:set => order_rel X x0 b0) y HyX Hyrelb). }
		                   exact (binintersectI b1 b2 y Hyb1 Hyb2).
		        * assume Hb2C: b2 :e Cup.
		          claim Hexa0: exists a0 :e X, b1 = {x0 :e X | order_rel X a0 x0}.
		          { exact (SepE2 (Power X)
		                        (fun I0:set => exists a0 :e X, I0 = {x0 :e X | order_rel X a0 x0})
		                        b1
		                        Hb1C). }
		          claim Hexc0: exists c0 :e X, b2 = {x0 :e X | order_rel X c0 x0}.
		          { exact (SepE2 (Power X)
		                        (fun I0:set => exists c0 :e X, I0 = {x0 :e X | order_rel X c0 x0})
		                        b2
		                        Hb2C). }
		          apply Hexa0.
		          let a0.
		          assume Ha0core: a0 :e X /\ b1 = {x0 :e X | order_rel X a0 x0}.
		          apply Ha0core.
		          assume Ha0X: a0 :e X.
		          assume Hb1eq: b1 = {x0 :e X | order_rel X a0 x0}.
		          apply Hexc0.
		          let c0.
		          assume Hc0core: c0 :e X /\ b2 = {x0 :e X | order_rel X c0 x0}.
		          apply Hc0core.
		          assume Hc0X: c0 :e X.
		          assume Hb2eq: b2 = {x0 :e X | order_rel X c0 x0}.
		          apply (order_rel_trichotomy_or_impred X a0 c0 Hso Ha0X Hc0X
		            (exists b3 :e (order_topology_basis X), x :e b3 /\ b3 c= b1 :/\: b2)).
		          - assume Hac: order_rel X a0 c0.
		            witness b2.
		            apply andI.
		            + (** b2 is a basis element **)
		              claim Hb2tri: b2 :e (Aint :\/: Blow :\/: Cup).
		              { exact (binunionI2 (Aint :\/: Blow) Cup b2 Hb2C). }
		              claim Hb2Bold: b2 :e Bold.
		              { rewrite HBdef.
		                exact Hb2tri. }
		              exact (binunionI1 Bold {X} b2 Hb2Bold).
		            + apply andI.
		              * exact Hx2.
		              * (** b2 c= b1 :/\: b2 **)
		                prove b2 c= b1 :/\: b2.
		                let y.
		                assume Hyb2: y :e b2.
		                claim Hyb2Sep: y :e {x0 :e X | order_rel X c0 x0}.
		                { rewrite <- Hb2eq.
		                  exact Hyb2. }
		                claim Hyc0: order_rel X c0 y.
		                { exact (SepE2 X (fun x0:set => order_rel X c0 x0) y Hyb2Sep). }
		                claim HyX: y :e X.
		                { exact (SepE1 X (fun x0:set => order_rel X c0 x0) y Hyb2Sep). }
		                claim Hya0: order_rel X a0 y.
		                { exact (order_rel_trans X a0 c0 y Hso Ha0X Hc0X HyX Hac Hyc0). }
		                claim Hyb1: y :e b1.
		                { rewrite Hb1eq.
		                  exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Hya0). }
		                exact (binintersectI b1 b2 y Hyb1 Hyb2).
		          - assume H_eq: a0 = c0.
		            witness b1.
		            apply andI.
		            + exact (binunionI1 Bold {X} b1 Hb1old).
		            + apply andI.
		              * exact Hx1.
		              * prove b1 c= b1 :/\: b2.
		                let y.
		                assume Hyb1: y :e b1.
		                claim HyX: y :e X.
		                { claim Hyb1Sep: y :e {x0 :e X | order_rel X a0 x0}.
		                  { rewrite <- Hb1eq.
		                    exact Hyb1. }
		                  exact (SepE1 X (fun x0:set => order_rel X a0 x0) y Hyb1Sep). }
		                claim Hya0: order_rel X a0 y.
		                { claim Hyb1Sep: y :e {x0 :e X | order_rel X a0 x0}.
		                  { rewrite <- Hb1eq.
		                    exact Hyb1. }
		                  exact (SepE2 X (fun x0:set => order_rel X a0 x0) y Hyb1Sep). }
		                claim Hyc0: order_rel X c0 y.
		                { rewrite <- H_eq.
		                  exact Hya0. }
		                claim Hyb2: y :e b2.
		                { rewrite Hb2eq.
		                  exact (SepI X (fun x0:set => order_rel X c0 x0) y HyX Hyc0). }
		                exact (binintersectI b1 b2 y Hyb1 Hyb2).
		          - assume Hca: order_rel X c0 a0.
		            witness b1.
		            apply andI.
		            + exact (binunionI1 Bold {X} b1 Hb1old).
		            + apply andI.
		              * exact Hx1.
		              * (** b1 c= b1 :/\: b2 **)
		                prove b1 c= b1 :/\: b2.
		                let y.
		                assume Hyb1: y :e b1.
		                claim Hya0: order_rel X a0 y.
		                { claim Hyb1Sep: y :e {x0 :e X | order_rel X a0 x0}.
		                  { rewrite <- Hb1eq.
		                    exact Hyb1. }
		                  exact (SepE2 X (fun x0:set => order_rel X a0 x0) y Hyb1Sep). }
		                claim HyX: y :e X.
		                { claim Hyb1Sep: y :e {x0 :e X | order_rel X a0 x0}.
		                  { rewrite <- Hb1eq.
		                    exact Hyb1. }
		                  exact (SepE1 X (fun x0:set => order_rel X a0 x0) y Hyb1Sep). }
		                claim Hyc0: order_rel X c0 y.
		                { exact (order_rel_trans X c0 a0 y Hso Hc0X Ha0X HyX Hca Hya0). }
		                claim Hyb2: y :e b2.
		                { rewrite Hb2eq.
		                  exact (SepI X (fun x0:set => order_rel X c0 x0) y HyX Hyc0). }
		                exact (binintersectI b1 b2 y Hyb1 Hyb2).
	  + assume Hb2X: b2 :e {X}.
	    claim Hb2eq: b2 = X.
	    { exact (SingE X b2 Hb2X). }
	    rewrite Hb2eq.
      witness b1.
      apply andI.
      * exact (binunionI1 Bold {X} b1 Hb1old).
      * apply andI.
        - exact Hx1.
        - prove b1 c= b1 :/\: X.
           claim Hb1Pow: b1 :e Power X.
           { exact (HsubPow b1 (binunionI1 Bold {X} b1 Hb1old)). }
           claim Hb1sub: b1 c= X.
           { exact (PowerE X b1 Hb1Pow). }
           let y. assume Hy: y :e b1.
           exact (binintersectI b1 X y Hy (Hb1sub y Hy)).
  - assume Hb1X: b1 :e {X}.
    claim Hb1eq: b1 = X.
    { exact (SingE X b1 Hb1X). }
    rewrite Hb1eq.
    witness b2.
    apply andI.
    + exact Hb2.
    + apply andI.
      * exact Hx2.
      * prove b2 c= X :/\: b2.
        claim Hb2Pow: b2 :e Power X.
        { exact (HsubPow b2 Hb2). }
        claim Hb2sub: b2 c= X.
        { exact (PowerE X b2 Hb2Pow). }
        let y. assume Hy: y :e b2.
        exact (binintersectI X b2 y (Hb2sub y Hy) Hy). }
exact (andI (A /\ Bcov) Bref Hab Href).
Qed.

(** from §14: order topology is a topology **) 
(** LATEX VERSION: The order topology satisfies the topology axioms. **)
Theorem order_topology_is_topology : forall X:set,
  simply_ordered_set X ->
  topology_on X (order_topology X).
let X.
assume Hso: simply_ordered_set X.
prove topology_on X (order_topology X).
(** order_topology X = generated_topology X (order_topology_basis X) **)
(** Apply axiom that order_topology_basis X is a basis, then use lemma_topology_from_basis **)
exact (lemma_topology_from_basis X (order_topology_basis X) (order_topology_basis_is_basis X Hso)).
Qed.

(** from §16: open rays as building blocks in the order topology **) 
(** LATEX VERSION: The sets (a,∞) and (-∞,a) are open rays used to build the order topology; they form part of a subbasis. **)
Definition open_ray_upper : set -> set -> set := fun X a => {x :e X | order_rel X a x}.

(** from §16: open rays as building blocks in the order topology **) 
(** LATEX VERSION: The sets (a,∞) and (-∞,a) are open rays used to build the order topology; they form part of a subbasis. **)
Definition open_ray_lower : set -> set -> set := fun X a => {x :e X | order_rel X x a}.

(** from §16: open rays form a subbasis for the order topology **) 
(** LATEX VERSION: The order topology is generated by the subbasis of all open rays, together with X itself. **)
Definition open_rays_subbasis : set -> set := fun X =>
  (({I :e Power X | exists a :e X, I = open_ray_upper X a}
    :\/:
    {I :e Power X | exists b :e X, I = open_ray_lower X b})
   :\/:
   {X}).

(** Helper: open rays subbasis is a subset of Power X **)
Theorem open_rays_subbasis_sub_Power : forall X:set,
  open_rays_subbasis X c= Power X.
let X.
prove open_rays_subbasis X c= Power X.
let I. assume HI: I :e open_rays_subbasis X.
prove I :e Power X.
apply (binunionE' ({I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                   :\/:
                   {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b})
                  {X}
                  I
                  (I :e Power X)).
- assume HI0: I :e ({I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                    :\/:
                    {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}).
  apply (binunionE' {I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                    {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}
                    I
                    (I :e Power X)).
  + assume HI1: I :e {I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}.
    exact (SepE1 (Power X) (fun I0 : set => exists a :e X, I0 = open_ray_upper X a) I HI1).
  + assume HI2: I :e {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}.
    exact (SepE1 (Power X) (fun I0 : set => exists b :e X, I0 = open_ray_lower X b) I HI2).
  + exact HI0.
- assume HIX: I :e {X}.
  claim HIEq: I = X.
  { exact (SingE X I HIX). }
  rewrite HIEq.
  exact (Self_In_Power X).
- exact HI.
Qed.

(** Helper: open rays subbasis covers X and lies in Power X **)
Theorem open_rays_subbasis_is_subbasis : forall X:set,
  subbasis_on X (open_rays_subbasis X).
let X.
prove subbasis_on X (open_rays_subbasis X).
prove (open_rays_subbasis X c= Power X) /\ Union (open_rays_subbasis X) = X.
apply andI.
- exact (open_rays_subbasis_sub_Power X).
- apply set_ext.
  + let x. assume HxU: x :e Union (open_rays_subbasis X).
    prove x :e X.
    apply (UnionE_impred (open_rays_subbasis X) x HxU).
    let U.
    assume HxUin: x :e U.
    assume HU: U :e open_rays_subbasis X.
    claim HUpow: U :e Power X.
    { exact (open_rays_subbasis_sub_Power X U HU). }
    claim HUsub: U c= X.
    { exact (PowerE X U HUpow). }
    exact (HUsub x HxUin).
  + let x. assume HxX: x :e X.
    prove x :e Union (open_rays_subbasis X).
    claim HXInS: X :e open_rays_subbasis X.
    { exact (binunionI2 ({I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                         :\/:
                         {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b})
                        {X}
                        X
                        (SingI X)). }
    exact (UnionI (open_rays_subbasis X) x X HxX HXInS).
Qed.

(** Helper: an upper ray is a basis element for the order topology **)
Theorem open_ray_upper_in_order_topology_basis : forall X a:set,
  a :e X -> open_ray_upper X a :e order_topology_basis X.
let X a. assume HaX.
prove open_ray_upper X a :e order_topology_basis X.
set U := open_ray_upper X a.
set Bold := ({I :e Power X | exists a0 :e X, exists b0 :e X,
                I = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
             :\/:
             {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}}
             :\/:
             {I :e Power X | exists a0 :e X, I = {x :e X | order_rel X a0 x}}).
claim HUpow: U :e Power X.
{ apply PowerI.
  let x. assume HxU: x :e U.
  exact (SepE1 X (fun x0 : set => order_rel X a x0) x HxU). }
claim HUex: exists a0 :e X, U = {x :e X | order_rel X a0 x}.
{ witness a.
  prove a :e X /\ U = {x :e X | order_rel X a x}.
  apply andI.
  - exact HaX.
  - reflexivity.
}
claim HUfam: U :e {I :e Power X | exists a0 :e X, I = {x :e X | order_rel X a0 x}}.
{ exact (SepI (Power X)
              (fun I0 : set => exists a0 :e X, I0 = {x :e X | order_rel X a0 x})
              U
              HUpow
              HUex). }
claim HUold: U :e Bold.
{ exact (binunionI2 ({I :e Power X | exists a0 :e X, exists b0 :e X,
                        I = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                     :\/:
                     {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}})
                    {I :e Power X | exists a0 :e X, I = {x :e X | order_rel X a0 x}}
                    U
                    HUfam). }
exact (binunionI1 Bold {X} U HUold).
Qed.

(** Helper: a lower ray is a basis element for the order topology **)
Theorem open_ray_lower_in_order_topology_basis : forall X b:set,
  b :e X -> open_ray_lower X b :e order_topology_basis X.
let X b. assume HbX.
prove open_ray_lower X b :e order_topology_basis X.
set U := open_ray_lower X b.
set Bold := ({I :e Power X | exists a0 :e X, exists b0 :e X,
                I = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
             :\/:
             {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}}
             :\/:
             {I :e Power X | exists a0 :e X, I = {x :e X | order_rel X a0 x}}).
claim HUpow: U :e Power X.
{ apply PowerI.
  let x. assume HxU: x :e U.
  exact (SepE1 X (fun x0 : set => order_rel X x0 b) x HxU). }
claim HUex: exists b0 :e X, U = {x :e X | order_rel X x b0}.
{ witness b.
  prove b :e X /\ U = {x :e X | order_rel X x b}.
  apply andI.
  - exact HbX.
  - reflexivity.
}
claim HUfam: U :e {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}}.
{ exact (SepI (Power X)
              (fun I0 : set => exists b0 :e X, I0 = {x :e X | order_rel X x b0})
              U
              HUpow
              HUex). }
claim HUold: U :e Bold.
{ exact (binunionI1 ({I :e Power X | exists a0 :e X, exists b0 :e X,
                        I = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                     :\/:
                     {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}})
                    {I :e Power X | exists a0 :e X, I = {x :e X | order_rel X a0 x}}
                    U
                    (binunionI2 {I :e Power X | exists a0 :e X, exists b0 :e X,
                                  I = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                                {I :e Power X | exists b0 :e X, I = {x :e X | order_rel X x b0}}
                                U
                                HUfam)). }
exact (binunionI1 Bold {X} U HUold).
Qed.

(** helper: order_topology_basis covers ω via successor lower rays **)
(** LATEX VERSION: For ω, every point lies in some basic open ray of the order topology. **)
Theorem order_topology_basis_covers_omega : forall x:set,
  x :e omega -> exists b :e (order_topology_basis omega), x :e b.
let x.
assume Hx: x :e omega.
set b := open_ray_lower omega (ordsucc x).
witness b.
apply andI.
- (** b is a basis element **)
  claim Hb: ordsucc x :e omega.
  { exact (omega_ordsucc x Hx). }
  exact (open_ray_lower_in_order_topology_basis omega (ordsucc x) Hb).
- (** x is in the lower ray below ordsucc x **)
  claim Hdef: open_ray_lower omega (ordsucc x) = {y :e omega | order_rel omega y (ordsucc x)}.
  { reflexivity. }
  rewrite Hdef.
  apply (SepI omega (fun y:set => order_rel omega y (ordsucc x)) x Hx).
  claim Hmem: x :e ordsucc x.
  { exact (ordsuccI2 x). }
  exact (mem_implies_order_rel_omega x (ordsucc x) Hmem).
Qed.

(** helper: the lower ray below 1 in ω is exactly {0} **)
(** LATEX VERSION: In ω, the initial segment below 1 is the singleton {0}. **)
Theorem open_ray_lower_omega_1_eq_Sing0 :
  open_ray_lower omega 1 = {0}.
prove open_ray_lower omega 1 = {0}.
apply set_ext.
- let y. assume Hy: y :e open_ray_lower omega 1.
  prove y :e {0}.
  claim Hyrel: order_rel omega y 1.
  { exact (SepE2 omega (fun y0:set => order_rel omega y0 1) y Hy). }
  claim Hymem: y :e 1.
  { exact (order_rel_omega_implies_mem y 1 Hyrel). }
  apply (ordsuccE 0 y Hymem).
  + assume Hy0: y :e 0.
    apply FalseE.
    exact (EmptyE y Hy0).
  + assume Heq: y = 0.
    rewrite Heq.
    exact (SingI 0).
- let y. assume Hy: y :e {0}.
  prove y :e open_ray_lower omega 1.
  claim Heq: y = 0.
  { exact (SingE 0 y Hy). }
  rewrite Heq.
  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Hdef: open_ray_lower omega 1 = {y0 :e omega | order_rel omega y0 1}.
  { reflexivity. }
  rewrite Hdef.
  apply (SepI omega (fun y0:set => order_rel omega y0 1) 0 H0omega).
  exact (mem_implies_order_rel_omega 0 1 In_0_1).
Qed.

(** helper: every singleton {x} with x∈ω is a basis element of the ω order topology basis **)
(** LATEX VERSION: In the order topology on ω, each point is isolated: {x} is a basic open set. **)
Theorem singleton_in_order_topology_basis_omega : forall x:set,
  x :e omega -> {x} :e order_topology_basis omega.
let x.
assume Hxomega: x :e omega.
claim Hxnat: nat_p x.
{ exact (omega_nat_p x Hxomega). }
claim Hinv: x = 0 \/ exists m:set, nat_p m /\ x = ordsucc m.
{ exact (nat_inv x Hxnat). }
apply Hinv.
- assume Hx0: x = 0.
  rewrite Hx0.
  rewrite <- open_ray_lower_omega_1_eq_Sing0.
  claim H1omega: 1 :e omega.
  { exact (nat_p_omega 1 nat_1). }
  exact (open_ray_lower_in_order_topology_basis omega 1 H1omega).
- assume Hex: exists m:set, nat_p m /\ x = ordsucc m.
  apply Hex.
  let m.
  assume Hmcore: nat_p m /\ x = ordsucc m.
  claim Hmnat: nat_p m.
  { exact (andEL (nat_p m) (x = ordsucc m) Hmcore). }
  claim Hxeq: x = ordsucc m.
  { exact (andER (nat_p m) (x = ordsucc m) Hmcore). }
  claim Hx1omega: ordsucc m :e omega.
  { rewrite <- Hxeq. exact Hxomega. }
  rewrite Hxeq.
  set x1 := ordsucc m.
  set b := ordsucc x1.
  claim Hmomega: m :e omega.
  { exact (nat_p_omega m Hmnat). }
  claim Hbomega: b :e omega.
  { exact (omega_ordsucc x1 Hx1omega). }
  set I := {y :e omega | order_rel omega m y /\ order_rel omega y b}.
  claim HIeq: I = {x1}.
  { apply set_ext.
    - let y. assume HyI: y :e I.
      prove y :e {x1}.
      claim Hycore: order_rel omega m y /\ order_rel omega y b.
      { exact (SepE2 omega (fun y0:set => order_rel omega m y0 /\ order_rel omega y0 b) y HyI). }
      claim Hmy: order_rel omega m y.
      { exact (andEL (order_rel omega m y) (order_rel omega y b) Hycore). }
      claim Hyb: order_rel omega y b.
      { exact (andER (order_rel omega m y) (order_rel omega y b) Hycore). }
      claim Hm_in_y: m :e y.
      { exact (order_rel_omega_implies_mem m y Hmy). }
      claim Hy_in_b: y :e b.
      { exact (order_rel_omega_implies_mem y b Hyb). }
      apply (ordsuccE x1 y Hy_in_b).
      + assume Hyin: y :e x1.
        apply (ordsuccE m y Hyin).
        * assume Hyinm: y :e m.
          apply FalseE.
          exact (In_no2cycle m y Hm_in_y Hyinm).
	        * assume Heq0: y = m.
	          apply FalseE.
	          claim Hmm: m :e m.
		          { rewrite <- Heq0 at 2.
		            exact Hm_in_y. }
	          exact ((In_irref m) Hmm).
      + assume Heq1: y = x1.
        rewrite Heq1.
        exact (SingI x1).
    - let y. assume HyS: y :e {x1}.
      prove y :e I.
      claim Heq: y = x1.
      { exact (SingE x1 y HyS). }
      rewrite Heq.
      apply (SepI omega (fun y0:set => order_rel omega m y0 /\ order_rel omega y0 b) x1 Hx1omega).
      apply andI.
      + claim Hmemb: m :e x1.
        { exact (ordsuccI2 m). }
        exact (mem_implies_order_rel_omega m x1 Hmemb).
      + claim Hx1b: x1 :e b.
        { exact (ordsuccI2 x1). }
        exact (mem_implies_order_rel_omega x1 b Hx1b). }
  claim HIpow: I :e Power omega.
  { apply PowerI.
    let y. assume HyI: y :e I.
    exact (SepE1 omega (fun y0:set => order_rel omega m y0 /\ order_rel omega y0 b) y HyI). }
  claim Hexab: exists a :e omega, exists b0 :e omega, I = {y :e omega | order_rel omega a y /\ order_rel omega y b0}.
  { witness m.
    apply andI.
    - exact Hmomega.
    - witness b.
      apply andI.
      + exact Hbomega.
      + reflexivity. }
  claim HIinFam: I :e {I0 :e Power omega | exists a :e omega, exists b0 :e omega,
        I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0}}.
  { exact (SepI (Power omega)
            (fun I0:set => exists a :e omega, exists b0 :e omega,
              I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0})
            I
            HIpow
            Hexab). }
  rewrite <- HIeq.
  set Bold := (({I0 :e Power omega | exists a0 :e omega, exists b0 :e omega,
                   I0 = {y :e omega | order_rel omega a0 y /\ order_rel omega y b0}}
                :\/:
                {I0 :e Power omega | exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0}})
               :\/:
               {I0 :e Power omega | exists a0 :e omega, I0 = {y :e omega | order_rel omega a0 y}}).
  exact (binunionI1 Bold {omega} I
    (binunionI1
      ({I0 :e Power omega | exists a0 :e omega, exists b0 :e omega,
            I0 = {y :e omega | order_rel omega a0 y /\ order_rel omega y b0}}
       :\/:
       {I0 :e Power omega | exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0}})
      {I0 :e Power omega | exists a0 :e omega, I0 = {y :e omega | order_rel omega a0 y}}
      I
      (binunionI1
        {I0 :e Power omega | exists a0 :e omega, exists b0 :e omega,
              I0 = {y :e omega | order_rel omega a0 y /\ order_rel omega y b0}}
        {I0 :e Power omega | exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0}}
        I
        HIinFam))).
Qed.

(** helper: the order-topology basis on ω satisfies the basis axioms **)
(** LATEX VERSION: For ω with the usual order, the order-topology basis is a basis. **)
Theorem order_topology_basis_omega_is_basis :
  basis_on omega (order_topology_basis omega).
prove basis_on omega (order_topology_basis omega).
prove ((order_topology_basis omega c= Power omega)
  /\ (forall x :e omega, exists b :e (order_topology_basis omega), x :e b))
  /\ (forall b1 :e (order_topology_basis omega),
        forall b2 :e (order_topology_basis omega),
        forall x:set,
          x :e b1 -> x :e b2 ->
          exists b3 :e (order_topology_basis omega), x :e b3 /\ b3 c= b1 :/\: b2).
apply andI.
- prove (order_topology_basis omega c= Power omega) /\
    (forall x :e omega, exists b :e (order_topology_basis omega), x :e b).
  apply andI.
  + prove order_topology_basis omega c= Power omega.
    let I. assume HI: I :e order_topology_basis omega.
    prove I :e Power omega.
    set A := {I0 :e Power omega | exists a :e omega, exists b0 :e omega,
              I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0}}.
    set B := {I0 :e Power omega | exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0}}.
    set C := {I0 :e Power omega | exists a :e omega, I0 = {y :e omega | order_rel omega a y}}.
    set Bold := (A :\/: B :\/: C).
    apply (binunionE Bold {omega} I HI).
    * assume HI': I :e Bold.
      apply (binunionE (A :\/: B) C I HI').
      - assume HIAB: I :e (A :\/: B).
        apply (binunionE A B I HIAB).
        + assume HIA: I :e A.
          exact (SepE1 (Power omega)
            (fun I0:set => exists a :e omega, exists b0 :e omega,
              I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0})
            I HIA).
        + assume HIB: I :e B.
          exact (SepE1 (Power omega)
            (fun I0:set => exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0})
            I HIB).
      - assume HIC: I :e C.
        exact (SepE1 (Power omega)
          (fun I0:set => exists a :e omega, I0 = {y :e omega | order_rel omega a y})
          I HIC).
    * assume HIomega: I :e {omega}.
      claim HeqI: I = omega.
      { exact (SingE omega I HIomega). }
      rewrite HeqI.
      exact (Self_In_Power omega).
  + let x. assume Hx: x :e omega.
    witness {x}.
    apply andI.
    - exact (singleton_in_order_topology_basis_omega x Hx).
    - exact (SingI x).
- let b1. assume Hb1: b1 :e order_topology_basis omega.
  let b2. assume Hb2: b2 :e order_topology_basis omega.
  let x. assume Hx1: x :e b1.
  assume Hx2: x :e b2.
  prove exists b3 :e order_topology_basis omega, x :e b3 /\ b3 c= b1 :/\: b2.
  claim Hb1pow: b1 :e Power omega.
  { set A := {I0 :e Power omega | exists a :e omega, exists b0 :e omega,
                I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0}}.
    set B := {I0 :e Power omega | exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0}}.
    set C := {I0 :e Power omega | exists a :e omega, I0 = {y :e omega | order_rel omega a y}}.
    set Bold := (A :\/: B :\/: C).
    apply (binunionE Bold {omega} b1 Hb1).
    - assume Hb1U: b1 :e Bold.
      apply (binunionE (A :\/: B) C b1 Hb1U).
      + assume Hb1AB: b1 :e (A :\/: B).
        apply (binunionE A B b1 Hb1AB).
        * assume Hb1A: b1 :e A.
          exact (SepE1 (Power omega)
            (fun I0:set => exists a :e omega, exists b0 :e omega,
              I0 = {y :e omega | order_rel omega a y /\ order_rel omega y b0})
            b1 Hb1A).
        * assume Hb1B: b1 :e B.
          exact (SepE1 (Power omega)
            (fun I0:set => exists b0 :e omega, I0 = {y :e omega | order_rel omega y b0})
            b1 Hb1B).
      + assume Hb1C: b1 :e C.
        exact (SepE1 (Power omega)
          (fun I0:set => exists a :e omega, I0 = {y :e omega | order_rel omega a y})
          b1 Hb1C).
    - assume Hb1omega: b1 :e {omega}.
      claim Hb1eq: b1 = omega.
      { exact (SingE omega b1 Hb1omega). }
      rewrite Hb1eq.
      exact (Self_In_Power omega). }
  claim Hb1sub: b1 c= omega.
  { exact (PowerE omega b1 Hb1pow). }
  claim Hxomega: x :e omega.
  { exact (Hb1sub x Hx1). }
  witness {x}.
  apply andI.
  + exact (singleton_in_order_topology_basis_omega x Hxomega).
  + apply andI.
    * exact (SingI x).
    * prove {x} c= b1 :/\: b2.
      let y. assume Hy: y :e {x}.
      claim Heq: y = x.
      { exact (SingE x y Hy). }
      rewrite Heq.
      exact (binintersectI b1 b2 x Hx1 Hx2).
Qed.

(** helper: the order topology on ω is a topology **)
(** LATEX VERSION: The order topology generated by the order basis is a topology. **)
Theorem order_topology_omega_is_topology :
  topology_on omega (order_topology omega).
prove topology_on omega (order_topology omega).
exact (lemma_topology_from_basis omega (order_topology_basis omega) order_topology_basis_omega_is_basis).
Qed.

(** Helper: open rays subbasis elements are open in the order topology **)
Theorem open_rays_subbasis_sub_order_topology : forall X:set,
  simply_ordered_set X ->
  open_rays_subbasis X c= order_topology X.
let X.
assume Hso: simply_ordered_set X.
prove open_rays_subbasis X c= order_topology X.
let U. assume HU: U :e open_rays_subbasis X.
prove U :e order_topology X.
apply (binunionE' ({I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                   :\/:
                   {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b})
                  {X}
                  U
                  (U :e order_topology X)).
- assume HU0: U :e ({I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                    :\/:
                    {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}).
  apply (binunionE' {I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}
                    {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}
                    U
                    (U :e order_topology X)).
  + assume HU1: U :e {I0 :e Power X | exists a :e X, I0 = open_ray_upper X a}.
    claim Hex: exists a :e X, U = open_ray_upper X a.
    { exact (SepE2 (Power X) (fun I0 : set => exists a :e X, I0 = open_ray_upper X a) U HU1). }
    apply Hex.
    let a.
    assume Hcore: a :e X /\ U = open_ray_upper X a.
    apply Hcore.
    assume HaX: a :e X.
    assume HUeq: U = open_ray_upper X a.
    rewrite HUeq.
    claim HUinB: open_ray_upper X a :e order_topology_basis X.
    { exact (open_ray_upper_in_order_topology_basis X a HaX). }
    claim HUpow: open_ray_upper X a :e Power X.
    { apply PowerI.
      let x. assume HxU: x :e open_ray_upper X a.
      exact (SepE1 X (fun x0 : set => order_rel X a x0) x HxU). }
    exact (generated_topology_contains_elem X (order_topology_basis X) (open_ray_upper X a) HUpow HUinB).
  + assume HU2: U :e {I0 :e Power X | exists b :e X, I0 = open_ray_lower X b}.
    claim Hex: exists b :e X, U = open_ray_lower X b.
    { exact (SepE2 (Power X) (fun I0 : set => exists b :e X, I0 = open_ray_lower X b) U HU2). }
    apply Hex.
    let b.
    assume Hcore: b :e X /\ U = open_ray_lower X b.
    apply Hcore.
    assume HbX: b :e X.
    assume HUeq: U = open_ray_lower X b.
    rewrite HUeq.
    claim HUinB: open_ray_lower X b :e order_topology_basis X.
    { exact (open_ray_lower_in_order_topology_basis X b HbX). }
    claim HUpow: open_ray_lower X b :e Power X.
    { apply PowerI.
      let x. assume HxU: x :e open_ray_lower X b.
      exact (SepE1 X (fun x0 : set => order_rel X x0 b) x HxU). }
    exact (generated_topology_contains_elem X (order_topology_basis X) (open_ray_lower X b) HUpow HUinB).
  + exact HU0.
- assume HUX: U :e {X}.
  claim HUeq: U = X.
  { exact (SingE X U HUX). }
  rewrite HUeq.
  exact (topology_has_X X (order_topology X) (order_topology_is_topology X Hso)).
- exact HU.
Qed.

(** Helper: any subbasis element is open in the generated topology from the subbasis **)
Theorem subbasis_elem_open_in_generated_from_subbasis : forall X S s:set,
  subbasis_on X S ->
  s :e S ->
  s :e generated_topology_from_subbasis X S.
let X S s.
assume HS HsS.
apply (xm (s = Empty)).
- assume HsEmpty.
  rewrite HsEmpty.
  claim HT: topology_on X (generated_topology_from_subbasis X S).
  { exact (topology_from_subbasis_is_topology X S HS). }
  exact (topology_has_empty X (generated_topology_from_subbasis X S) HT).
- assume HsNe.
  claim HBasis: basis_on X (basis_of_subbasis X S).
  { exact (finite_intersections_basis_of_subbasis X S HS). }
  claim HsBasis: s :e basis_of_subbasis X S.
  { exact (subbasis_elem_in_basis X S s HS HsS HsNe). }
  exact (generated_topology_contains_basis X (basis_of_subbasis X S) HBasis s HsBasis).
Qed.

(** Helper: upper ray belongs to open_rays_subbasis **)
Theorem open_ray_upper_in_open_rays_subbasis : forall X a:set,
  a :e X ->
  open_ray_upper X a :e open_rays_subbasis X.
let X a. assume HaX.
set U := open_ray_upper X a.
claim HUpow: U :e Power X.
{ apply PowerI.
  let x. assume HxU: x :e U.
  exact (SepE1 X (fun x0 : set => order_rel X a x0) x HxU). }
claim HUex: exists a0 :e X, U = open_ray_upper X a0.
{ witness a.
  prove a :e X /\ U = open_ray_upper X a.
  apply andI.
  - exact HaX.
  - reflexivity.
}
claim HUfam: U :e {I0 :e Power X | exists a0 :e X, I0 = open_ray_upper X a0}.
{ exact (SepI (Power X)
              (fun I0 : set => exists a0 :e X, I0 = open_ray_upper X a0)
              U
              HUpow
              HUex). }
exact (binunionI1 ({I0 :e Power X | exists a0 :e X, I0 = open_ray_upper X a0}
                   :\/:
                   {I0 :e Power X | exists b0 :e X, I0 = open_ray_lower X b0})
                  {X}
                  U
                  (binunionI1 {I0 :e Power X | exists a0 :e X, I0 = open_ray_upper X a0}
                              {I0 :e Power X | exists b0 :e X, I0 = open_ray_lower X b0}
                              U
                              HUfam)).
Qed.

(** Helper: lower ray belongs to open_rays_subbasis **)
Theorem open_ray_lower_in_open_rays_subbasis : forall X b:set,
  b :e X ->
  open_ray_lower X b :e open_rays_subbasis X.
let X b. assume HbX.
set U := open_ray_lower X b.
claim HUpow: U :e Power X.
{ apply PowerI.
  let x. assume HxU: x :e U.
  exact (SepE1 X (fun x0 : set => order_rel X x0 b) x HxU). }
claim HUex: exists b0 :e X, U = open_ray_lower X b0.
{ witness b.
  prove b :e X /\ U = open_ray_lower X b.
  apply andI.
  - exact HbX.
  - reflexivity.
}
claim HUfam: U :e {I0 :e Power X | exists b0 :e X, I0 = open_ray_lower X b0}.
{ exact (SepI (Power X)
              (fun I0 : set => exists b0 :e X, I0 = open_ray_lower X b0)
              U
              HUpow
              HUex). }
exact (binunionI1 ({I0 :e Power X | exists a0 :e X, I0 = open_ray_upper X a0}
                   :\/:
                   {I0 :e Power X | exists b0 :e X, I0 = open_ray_lower X b0})
                  {X}
                  U
                  (binunionI2 {I0 :e Power X | exists a0 :e X, I0 = open_ray_upper X a0}
                              {I0 :e Power X | exists b0 :e X, I0 = open_ray_lower X b0}
                              U
                              HUfam)).
Qed.

(** Helper: open interval equals intersection of open rays **)
Theorem open_interval_eq_rays_intersection : forall X a b:set,
  {x :e X | order_rel X a x /\ order_rel X x b}
  =
  (open_ray_upper X a) :/\: (open_ray_lower X b).
let X a b.
apply set_ext.
- let x. assume Hx: x :e {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
  prove x :e (open_ray_upper X a) :/\: (open_ray_lower X b).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0 : set => order_rel X a x0 /\ order_rel X x0 b) x Hx). }
  claim HxRel: order_rel X a x /\ order_rel X x b.
  { exact (SepE2 X (fun x0 : set => order_rel X a x0 /\ order_rel X x0 b) x Hx). }
  claim HxUp: x :e open_ray_upper X a.
  { exact (SepI X (fun x0 : set => order_rel X a x0) x HxX
                 (andEL (order_rel X a x) (order_rel X x b) HxRel)). }
  claim HxLo: x :e open_ray_lower X b.
  { exact (SepI X (fun x0 : set => order_rel X x0 b) x HxX
                 (andER (order_rel X a x) (order_rel X x b) HxRel)). }
  exact (binintersectI (open_ray_upper X a) (open_ray_lower X b) x HxUp HxLo).
- let x. assume Hx: x :e (open_ray_upper X a) :/\: (open_ray_lower X b).
  prove x :e {x0 :e X | order_rel X a x0 /\ order_rel X x0 b}.
  claim HxUp: x :e open_ray_upper X a.
  { exact (binintersectE1 (open_ray_upper X a) (open_ray_lower X b) x Hx). }
  claim HxLo: x :e open_ray_lower X b.
  { exact (binintersectE2 (open_ray_upper X a) (open_ray_lower X b) x Hx). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0 : set => order_rel X a x0) x HxUp). }
  claim HxRelUp: order_rel X a x.
  { exact (SepE2 X (fun x0 : set => order_rel X a x0) x HxUp). }
  claim HxRelLo: order_rel X x b.
  { exact (SepE2 X (fun x0 : set => order_rel X x0 b) x HxLo). }
  exact (SepI X (fun x0 : set => order_rel X a x0 /\ order_rel X x0 b) x HxX
              (andI (order_rel X a x) (order_rel X x b) HxRelUp HxRelLo)).
Qed.

(** Helper: order topology basis elements are open in the topology generated by open rays **)
Theorem order_topology_basis_sub_generated_from_open_rays : forall X:set,
  order_topology_basis X c= generated_topology_from_subbasis X (open_rays_subbasis X).
let X.
set Tsub := generated_topology_from_subbasis X (open_rays_subbasis X).
claim HSsub: subbasis_on X (open_rays_subbasis X).
{ exact (open_rays_subbasis_is_subbasis X). }
claim HTsub: topology_on X Tsub.
{ exact (topology_from_subbasis_is_topology X (open_rays_subbasis X) HSsub). }
prove order_topology_basis X c= Tsub.
let I. assume HI: I :e order_topology_basis X.
prove I :e Tsub.
set Bold := (({I0 :e Power X | exists a0 :e X, exists b0 :e X,
                 I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
              :\/:
              {I0 :e Power X | exists b0 :e X, I0 = {x :e X | order_rel X x b0}})
             :\/:
             {I0 :e Power X | exists a0 :e X, I0 = {x :e X | order_rel X a0 x}}).
apply (binunionE' Bold {X} I (I :e Tsub)).
- assume HIold: I :e Bold.
  apply (binunionE' ({I0 :e Power X | exists a0 :e X, exists b0 :e X,
                        I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                     :\/:
                     {I0 :e Power X | exists b0 :e X, I0 = {x :e X | order_rel X x b0}})
                    {I0 :e Power X | exists a0 :e X, I0 = {x :e X | order_rel X a0 x}}
                    I
                    (I :e Tsub)).
  - assume HI0: I :e ({I0 :e Power X | exists a0 :e X, exists b0 :e X,
                        I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                       :\/:
                       {I0 :e Power X | exists b0 :e X, I0 = {x :e X | order_rel X x b0}}).
    apply (binunionE' {I0 :e Power X | exists a0 :e X, exists b0 :e X,
                         I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0}}
                      {I0 :e Power X | exists b0 :e X, I0 = {x :e X | order_rel X x b0}}
                      I
                      (I :e Tsub)).
  + assume HIint: I :e {I0 :e Power X | exists a0 :e X, exists b0 :e X,
                          I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0}}.
    claim Hex: exists a0 :e X, exists b0 :e X, I = {x :e X | order_rel X a0 x /\ order_rel X x b0}.
    { exact (SepE2 (Power X)
                   (fun I0 : set => exists a0 :e X, exists b0 :e X, I0 = {x :e X | order_rel X a0 x /\ order_rel X x b0})
                   I
                   HIint). }
    apply Hex.
    let a0.
    assume Hcore: a0 :e X /\ exists b0 :e X, I = {x :e X | order_rel X a0 x /\ order_rel X x b0}.
    apply Hcore.
    assume HaX: a0 :e X.
    assume Hexb: exists b0 :e X, I = {x :e X | order_rel X a0 x /\ order_rel X x b0}.
    apply Hexb.
    let b0.
    assume Hcore2: b0 :e X /\ I = {x :e X | order_rel X a0 x /\ order_rel X x b0}.
    apply Hcore2.
    assume HbX: b0 :e X.
    assume HIeq: I = {x :e X | order_rel X a0 x /\ order_rel X x b0}.
    rewrite HIeq.
    set U1 := open_ray_upper X a0.
    set U2 := open_ray_lower X b0.
    claim HU1S: U1 :e open_rays_subbasis X.
    { exact (open_ray_upper_in_open_rays_subbasis X a0 HaX). }
    claim HU2S: U2 :e open_rays_subbasis X.
    { exact (open_ray_lower_in_open_rays_subbasis X b0 HbX). }
    claim HU1open: U1 :e Tsub.
    { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U1 HSsub HU1S). }
    claim HU2open: U2 :e Tsub.
    { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U2 HSsub HU2S). }
    claim Heq: {x :e X | order_rel X a0 x /\ order_rel X x b0} = U1 :/\: U2.
    { exact (open_interval_eq_rays_intersection X a0 b0). }
    rewrite Heq.
    exact (topology_binintersect_closed X Tsub U1 U2 HTsub HU1open HU2open).
  + assume HIlow: I :e {I0 :e Power X | exists b0 :e X, I0 = {x :e X | order_rel X x b0}}.
    claim Hex: exists b0 :e X, I = {x :e X | order_rel X x b0}.
    { exact (SepE2 (Power X)
                   (fun I0 : set => exists b0 :e X, I0 = {x :e X | order_rel X x b0})
                   I
                   HIlow). }
    apply Hex.
    let b0.
    assume Hcore: b0 :e X /\ I = {x :e X | order_rel X x b0}.
    apply Hcore.
    assume HbX: b0 :e X.
    assume HIeq: I = {x :e X | order_rel X x b0}.
    rewrite HIeq.
    claim Hdef: open_ray_lower X b0 = {x :e X | order_rel X x b0}.
    { reflexivity. }
    rewrite <- Hdef.
    set U := open_ray_lower X b0.
    claim HUS: U :e open_rays_subbasis X.
    { exact (open_ray_lower_in_open_rays_subbasis X b0 HbX). }
    exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U HSsub HUS).
  + exact HI0.
- assume HIup: I :e {I0 :e Power X | exists a0 :e X, I0 = {x :e X | order_rel X a0 x}}.
  claim Hex: exists a0 :e X, I = {x :e X | order_rel X a0 x}.
  { exact (SepE2 (Power X)
                 (fun I0 : set => exists a0 :e X, I0 = {x :e X | order_rel X a0 x})
                 I
                 HIup). }
  apply Hex.
  let a0.
  assume Hcore: a0 :e X /\ I = {x :e X | order_rel X a0 x}.
  apply Hcore.
  assume HaX: a0 :e X.
  assume HIeq: I = {x :e X | order_rel X a0 x}.
  rewrite HIeq.
  claim Hdef: open_ray_upper X a0 = {x :e X | order_rel X a0 x}.
  { reflexivity. }
  rewrite <- Hdef.
  set U := open_ray_upper X a0.
  claim HUS: U :e open_rays_subbasis X.
  { exact (open_ray_upper_in_open_rays_subbasis X a0 HaX). }
  exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U HSsub HUS).
  - exact HIold.
- assume HIX: I :e {X}.
  claim HIeq: I = X.
  { exact (SingE X I HIX). }
  rewrite HIeq.
  exact (topology_has_X X Tsub HTsub).
- exact HI.
Qed.

Theorem open_rays_subbasis_for_order_topology : forall X:set,
  simply_ordered_set X ->
  generated_topology_from_subbasis X (open_rays_subbasis X) = order_topology X.
let X.
assume Hso: simply_ordered_set X.
prove generated_topology_from_subbasis X (open_rays_subbasis X) = order_topology X.
apply set_ext.
- let U. assume HU : U :e generated_topology_from_subbasis X (open_rays_subbasis X).
  prove U :e order_topology X.
  claim HS: subbasis_on X (open_rays_subbasis X).
  { exact (open_rays_subbasis_is_subbasis X). }
  claim HT: topology_on X (order_topology X).
  { exact (order_topology_is_topology X Hso). }
  claim HSsub: open_rays_subbasis X c= order_topology X.
  { exact (open_rays_subbasis_sub_order_topology X Hso). }
  claim Hmin: finer_than (order_topology X) (generated_topology_from_subbasis X (open_rays_subbasis X)).
  { exact (topology_generated_by_basis_is_minimal X (open_rays_subbasis X) (order_topology X) HS HT HSsub). }
  exact (Hmin U HU).
- let U. assume HU : U :e order_topology X.
  prove U :e generated_topology_from_subbasis X (open_rays_subbasis X).
  set Tsub := generated_topology_from_subbasis X (open_rays_subbasis X).
  claim HS: subbasis_on X (open_rays_subbasis X).
  { exact (open_rays_subbasis_is_subbasis X). }
  claim HTsub: topology_on X Tsub.
  { exact (topology_from_subbasis_is_topology X (open_rays_subbasis X) HS). }
  claim HBsub: forall b :e order_topology_basis X, b :e Tsub.
  { let b. assume Hb.
    exact (order_topology_basis_sub_generated_from_open_rays X b Hb). }
  claim Hfiner: finer_than Tsub (generated_topology X (order_topology_basis X)).
  { exact (generated_topology_finer_weak X (order_topology_basis X) Tsub HTsub HBsub). }
  exact (Hfiner U HU).
Qed.

(** from §14 Example 1: standard basis is a basis on ℝ **)
(** LATEX VERSION: The standard open-interval basis on ℝ satisfies the basis axioms. **)
Theorem R_standard_basis_is_basis : basis_on R R_standard_basis.
prove basis_on R R_standard_basis.
(** Reuse the earlier proof to avoid duplicate work. **)
exact R_standard_basis_is_basis_local.
Qed.

(** from §14 Example 1: standard topology is a topology **)
(** LATEX VERSION: The standard topology on ℝ satisfies the topology axioms. **)
Theorem R_standard_topology_is_topology : topology_on R R_standard_topology.
prove topology_on R R_standard_topology.
exact (lemma_topology_from_basis R R_standard_basis (R_standard_basis_is_basis)).
Qed.

(** from §14 Example 1: standard topology on ℝ is the order topology **)
(** LATEX VERSION: Example 1: The standard topology on ℝ equals its order topology. **)
(** NOTE: The earlier axiom equating bases was too strong; we only need equality of the generated topologies. **)
(** Helper: any standard open interval is an order-topology basis element on ℝ. **)
Theorem open_interval_in_order_topology_basis_R : forall a b:set,
  a :e R -> b :e R -> open_interval a b :e order_topology_basis R.
let a b. assume HaR HbR.
set A := {I :e Power R | exists a1 :e R, exists b1 :e R,
            I = {x :e R | order_rel R a1 x /\ order_rel R x b1}}.
set B := {I :e Power R | exists b1 :e R, I = {x :e R | order_rel R x b1}}.
set C := {I :e Power R | exists a1 :e R, I = {x :e R | order_rel R a1 x}}.
claim HPow: open_interval a b :e Power R.
{ exact (PowerI R (open_interval a b) (open_interval_Subq_R a b)). }
claim HintEq: {x :e R | order_rel R a x /\ order_rel R x b} = open_interval a b.
{ apply set_ext.
  - let x. assume HxI: x :e {x0 :e R | order_rel R a x0 /\ order_rel R x0 b}.
    prove x :e open_interval a b.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0 : set => order_rel R a x0 /\ order_rel R x0 b) x HxI). }
    claim Hconj: order_rel R a x /\ order_rel R x b.
    { exact (SepE2 R (fun x0 : set => order_rel R a x0 /\ order_rel R x0 b) x HxI). }
    claim Hax: order_rel R a x.
    { exact (andEL (order_rel R a x) (order_rel R x b) Hconj). }
    claim Hxb: order_rel R x b.
    { exact (andER (order_rel R a x) (order_rel R x b) Hconj). }
    claim Haxlt: Rlt a x.
    { exact (order_rel_R_implies_Rlt a x Hax). }
    claim Hxblt: Rlt x b.
    { exact (order_rel_R_implies_Rlt x b Hxb). }
    exact (SepI R (fun x0 : set => Rlt a x0 /\ Rlt x0 b)
                x HxR (andI (Rlt a x) (Rlt x b) Haxlt Hxblt)).
  - let x. assume HxI: x :e open_interval a b.
    prove x :e {x0 :e R | order_rel R a x0 /\ order_rel R x0 b}.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0 : set => Rlt a x0 /\ Rlt x0 b) x HxI). }
    claim Hconj: Rlt a x /\ Rlt x b.
    { exact (SepE2 R (fun x0 : set => Rlt a x0 /\ Rlt x0 b) x HxI). }
    claim Hax: Rlt a x.
    { exact (andEL (Rlt a x) (Rlt x b) Hconj). }
    claim Hxb: Rlt x b.
    { exact (andER (Rlt a x) (Rlt x b) Hconj). }
    claim Haxrel: order_rel R a x.
    { exact (Rlt_implies_order_rel_R a x Hax). }
    claim Hxbrel: order_rel R x b.
    { exact (Rlt_implies_order_rel_R x b Hxb). }
    exact (SepI R (fun x0 : set => order_rel R a x0 /\ order_rel R x0 b)
                x HxR (andI (order_rel R a x) (order_rel R x b) Haxrel Hxbrel)). }
claim Hpred: exists a0 :e R, exists b0 :e R,
  open_interval a b = {x :e R | order_rel R a0 x /\ order_rel R x b0}.
{ witness a.
  apply andI.
  - exact HaR.
  - witness b.
    apply andI.
    + exact HbR.
    + rewrite HintEq.
      reflexivity. }
claim HInA: open_interval a b :e A.
{ exact (SepI (Power R)
              (fun I0 : set => exists a0 :e R, exists b0 :e R,
                              I0 = {x :e R | order_rel R a0 x /\ order_rel R x b0})
              (open_interval a b)
              HPow
              Hpred). }
claim HInAB: open_interval a b :e (A :\/: B).
{ exact (binunionI1 A B (open_interval a b) HInA). }
set Bold := (A :\/: B :\/: C).
exact (binunionI1 Bold {R} (open_interval a b)
  (binunionI1 (A :\/: B) C (open_interval a b) HInAB)).
Qed.

(** Helper: refine order-topology basis elements by standard open intervals on ℝ. **)
Theorem order_topology_basis_R_refines_standard_basis :
  forall b :e order_topology_basis R, forall x:set,
    x :e b ->
    exists I :e R_standard_basis, x :e I /\ I c= b.
let b. assume Hb.
let x. assume Hxb.
set A := {I :e Power R | exists a1 :e R, exists b1 :e R,
            I = {y :e R | order_rel R a1 y /\ order_rel R y b1}}.
set B := {I :e Power R | exists b1 :e R, I = {y :e R | order_rel R y b1}}.
set C := {I :e Power R | exists a1 :e R, I = {y :e R | order_rel R a1 y}}.
set Bold := (A :\/: B :\/: C).
apply (binunionE' Bold {R} b (exists I :e R_standard_basis, x :e I /\ I c= b)).
- assume HbU: b :e Bold.
  apply (binunionE' (A :\/: B) C b (exists I :e R_standard_basis, x :e I /\ I c= b)).
  - assume HbAB: b :e (A :\/: B).
    apply (binunionE' A B b (exists I :e R_standard_basis, x :e I /\ I c= b)).
    + assume HbA: b :e A.
    claim Hex: exists a0 :e R, exists b0 :e R, b = {y :e R | order_rel R a0 y /\ order_rel R y b0}.
    { exact (SepE2 (Power R)
                   (fun I0 : set => exists a0 :e R, exists b0 :e R,
                                  I0 = {y :e R | order_rel R a0 y /\ order_rel R y b0})
                   b
                   HbA). }
    apply Hex.
    let a0. assume Ha0core.
    apply Ha0core.
    assume Ha0R: a0 :e R.
    assume Hexb0: exists b0 :e R, b = {y :e R | order_rel R a0 y /\ order_rel R y b0}.
    apply Hexb0.
    let b0. assume Hb0core.
    apply Hb0core.
    assume Hb0R: b0 :e R.
    assume Hbeq: b = {y :e R | order_rel R a0 y /\ order_rel R y b0}.
    set I := open_interval a0 b0.
    claim HIinStdBasis: I :e R_standard_basis.
    { claim HIa: I :e {open_interval a0 bb|bb :e R}.
      { exact (ReplI R (fun bb : set => open_interval a0 bb) b0 Hb0R). }
      exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a0 I Ha0R HIa). }
    claim HxInSet: x :e {y :e R | order_rel R a0 y /\ order_rel R y b0}.
    { rewrite <- Hbeq.
      exact Hxb. }
    claim HxR: x :e R.
    { exact (SepE1 R (fun y : set => order_rel R a0 y /\ order_rel R y b0) x HxInSet). }
    claim Hxconj: order_rel R a0 x /\ order_rel R x b0.
    { exact (SepE2 R (fun y : set => order_rel R a0 y /\ order_rel R y b0) x HxInSet). }
    claim Hax: order_rel R a0 x.
    { exact (andEL (order_rel R a0 x) (order_rel R x b0) Hxconj). }
    claim Hxb0: order_rel R x b0.
    { exact (andER (order_rel R a0 x) (order_rel R x b0) Hxconj). }
    claim Haxlt: Rlt a0 x.
    { exact (order_rel_R_implies_Rlt a0 x Hax). }
    claim Hxblt: Rlt x b0.
    { exact (order_rel_R_implies_Rlt x b0 Hxb0). }
    claim HxI: x :e I.
    { exact (SepI R (fun y : set => Rlt a0 y /\ Rlt y b0)
                x HxR (andI (Rlt a0 x) (Rlt x b0) Haxlt Hxblt)). }
    claim HIsubB: I c= b.
    { let y. assume HyI: y :e I.
      prove y :e b.
      claim HyR: y :e R.
      { exact (SepE1 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 b0) y HyI). }
      claim Hyconj: Rlt a0 y /\ Rlt y b0.
      { exact (SepE2 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 b0) y HyI). }
      claim Hay: Rlt a0 y.
      { exact (andEL (Rlt a0 y) (Rlt y b0) Hyconj). }
      claim Hyb: Rlt y b0.
      { exact (andER (Rlt a0 y) (Rlt y b0) Hyconj). }
      claim Hayrel: order_rel R a0 y.
      { exact (Rlt_implies_order_rel_R a0 y Hay). }
      claim Hybrel: order_rel R y b0.
      { exact (Rlt_implies_order_rel_R y b0 Hyb). }
      claim HySet: y :e {z :e R | order_rel R a0 z /\ order_rel R z b0}.
      { exact (SepI R (fun z : set => order_rel R a0 z /\ order_rel R z b0)
                  y HyR (andI (order_rel R a0 y) (order_rel R y b0) Hayrel Hybrel)). }
      rewrite Hbeq.
      exact HySet. }
    witness I.
    apply andI.
    - exact HIinStdBasis.
    - apply andI.
      + exact HxI.
      + exact HIsubB.
    + assume HbB: b :e B.
    claim Hex: exists b0 :e R, b = {y :e R | order_rel R y b0}.
    { exact (SepE2 (Power R)
                   (fun I0 : set => exists b0 :e R, I0 = {y :e R | order_rel R y b0})
                   b
                   HbB). }
    apply Hex.
    let b0. assume Hb0core.
    apply Hb0core.
    assume Hb0R: b0 :e R.
    assume Hbeq: b = {y :e R | order_rel R y b0}.
    claim HxInSet: x :e {y :e R | order_rel R y b0}.
    { rewrite <- Hbeq.
      exact Hxb. }
    claim HxR: x :e R.
    { exact (SepE1 R (fun y : set => order_rel R y b0) x HxInSet). }
    claim Hrel: order_rel R x b0.
    { exact (SepE2 R (fun y : set => order_rel R y b0) x HxInSet). }
    claim Hxltb0: Rlt x b0.
    { exact (order_rel_R_implies_Rlt x b0 Hrel). }
    claim Hxpm: x :e open_interval (add_SNo x (minus_SNo 1)) (add_SNo x 1).
    { exact (real_in_open_interval_minus1_plus1 x HxR). }
    set a1 := add_SNo x (minus_SNo 1).
    set c1 := add_SNo x 1.
    claim Ha1R: a1 :e R.
    { exact (open_interval_left_in_R a1 c1 x Hxpm). }
    claim Hleft: Rlt a1 x.
    { claim Hconj: Rlt a1 x /\ Rlt x c1.
      { exact (SepE2 R (fun y : set => Rlt a1 y /\ Rlt y c1) x Hxpm). }
      exact (andEL (Rlt a1 x) (Rlt x c1) Hconj). }
    set I := open_interval a1 b0.
    claim HIinStdBasis: I :e R_standard_basis.
    { claim HIa: I :e {open_interval a1 bb|bb :e R}.
      { exact (ReplI R (fun bb : set => open_interval a1 bb) b0 Hb0R). }
      exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a1 I Ha1R HIa). }
    claim HxI: x :e I.
    { exact (SepI R (fun y : set => Rlt a1 y /\ Rlt y b0) x HxR
                (andI (Rlt a1 x) (Rlt x b0) Hleft Hxltb0)). }
    claim HIsubB: I c= b.
    { let y. assume HyI: y :e I.
      prove y :e b.
      claim HyR: y :e R.
      { exact (SepE1 R (fun y0 : set => Rlt a1 y0 /\ Rlt y0 b0) y HyI). }
      claim Hyconj: Rlt a1 y /\ Rlt y b0.
      { exact (SepE2 R (fun y0 : set => Rlt a1 y0 /\ Rlt y0 b0) y HyI). }
      claim Hyb: Rlt y b0.
      { exact (andER (Rlt a1 y) (Rlt y b0) Hyconj). }
      claim Hyrel: order_rel R y b0.
      { exact (Rlt_implies_order_rel_R y b0 Hyb). }
      claim HySet: y :e {z :e R | order_rel R z b0}.
      { exact (SepI R (fun z : set => order_rel R z b0) y HyR Hyrel). }
      rewrite Hbeq.
      exact HySet. }
    witness I.
    apply andI.
    - exact HIinStdBasis.
    - apply andI.
      + exact HxI.
      + exact HIsubB.
  + exact HbAB.
  - assume HbC: b :e C.
  claim Hex: exists a0 :e R, b = {y :e R | order_rel R a0 y}.
  { exact (SepE2 (Power R)
                 (fun I0 : set => exists a0 :e R, I0 = {y :e R | order_rel R a0 y})
                 b
                 HbC). }
  apply Hex.
  let a0. assume Ha0core.
  apply Ha0core.
  assume Ha0R: a0 :e R.
  assume Hbeq: b = {y :e R | order_rel R a0 y}.
  claim HxInSet: x :e {y :e R | order_rel R a0 y}.
  { rewrite <- Hbeq.
    exact Hxb. }
  claim HxR: x :e R.
  { exact (SepE1 R (fun y : set => order_rel R a0 y) x HxInSet). }
  claim Hrel: order_rel R a0 x.
  { exact (SepE2 R (fun y : set => order_rel R a0 y) x HxInSet). }
  claim Ha0ltx: Rlt a0 x.
  { exact (order_rel_R_implies_Rlt a0 x Hrel). }
  claim Hxpm: x :e open_interval (add_SNo x (minus_SNo 1)) (add_SNo x 1).
  { exact (real_in_open_interval_minus1_plus1 x HxR). }
  set a1 := add_SNo x (minus_SNo 1).
  set c1 := add_SNo x 1.
  claim Hright: Rlt x c1.
  { claim Hconj: Rlt a1 x /\ Rlt x c1.
    { exact (SepE2 R (fun y : set => Rlt a1 y /\ Rlt y c1) x Hxpm). }
    exact (andER (Rlt a1 x) (Rlt x c1) Hconj). }
  claim Hc1R: c1 :e R.
  { exact (open_interval_right_in_R a1 c1 x Hxpm). }
  set I := open_interval a0 c1.
  claim HIinStdBasis: I :e R_standard_basis.
  { claim HIa: I :e {open_interval a0 bb|bb :e R}.
    { exact (ReplI R (fun bb : set => open_interval a0 bb) c1 Hc1R). }
    exact (famunionI R (fun aa : set => {open_interval aa bb|bb :e R}) a0 I Ha0R HIa). }
  claim HxI: x :e I.
  { exact (SepI R (fun y : set => Rlt a0 y /\ Rlt y c1) x HxR
              (andI (Rlt a0 x) (Rlt x c1) Ha0ltx Hright)). }
  claim HIsubB: I c= b.
  { let y. assume HyI: y :e I.
    prove y :e b.
    claim HyR: y :e R.
    { exact (SepE1 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 c1) y HyI). }
    claim Hyconj: Rlt a0 y /\ Rlt y c1.
    { exact (SepE2 R (fun y0 : set => Rlt a0 y0 /\ Rlt y0 c1) y HyI). }
    claim Hay: Rlt a0 y.
    { exact (andEL (Rlt a0 y) (Rlt y c1) Hyconj). }
    claim Hayrel: order_rel R a0 y.
    { exact (Rlt_implies_order_rel_R a0 y Hay). }
    claim HySet: y :e {z :e R | order_rel R a0 z}.
    { exact (SepI R (fun z : set => order_rel R a0 z) y HyR Hayrel). }
    rewrite Hbeq.
    exact HySet. }
  witness I.
  apply andI.
  - exact HIinStdBasis.
  - apply andI.
    + exact HxI.
    + exact HIsubB.
- exact HbU.
- assume HbR: b :e {R}.
  claim HbEq: b = R.
  { exact (SingE R b HbR). }
  claim HxR: x :e R.
  { rewrite <- HbEq.
    exact Hxb. }
  claim HexI: exists I :e R_standard_basis, x :e I.
  { exact (basis_on_cover R R_standard_basis (R_standard_basis_is_basis) x HxR). }
  apply HexI.
  let I.
  assume Hcore: I :e R_standard_basis /\ x :e I.
  apply Hcore.
  assume HIbasis: I :e R_standard_basis.
  assume HxI: x :e I.
  witness I.
  apply andI.
  - exact HIbasis.
  - apply andI.
    + exact HxI.
    + prove I c= b.
      rewrite HbEq.
      claim HIPow: I :e Power R.
      { exact ((basis_on_sub_Power R R_standard_basis (R_standard_basis_is_basis)) I HIbasis). }
      exact (PowerE R I HIPow).
- exact Hb.
Qed.
Theorem standard_topology_is_order_topology : order_topology R = R_standard_topology.
prove order_topology R = R_standard_topology.
apply set_ext.
- let U. assume HU: U :e order_topology R.
  prove U :e R_standard_topology.
  claim HdefOrd: order_topology R = generated_topology R (order_topology_basis R).
  { reflexivity. }
  claim HdefStd: R_standard_topology = generated_topology R R_standard_basis.
  { exact R_standard_topology_def_eq. }
  claim HUgen: U :e generated_topology R (order_topology_basis R).
  { rewrite <- HdefOrd.
    exact HU. }
  claim HUpow: U :e Power R.
  { exact (SepE1 (Power R)
                 (fun U0 : set => forall x :e U0, exists b :e order_topology_basis R, x :e b /\ b c= U0)
                 U
                 HUgen). }
  claim HUloc: forall x :e U, exists b :e order_topology_basis R, x :e b /\ b c= U.
  { exact (SepE2 (Power R)
                 (fun U0 : set => forall x :e U0, exists b :e order_topology_basis R, x :e b /\ b c= U0)
                 U
                 HUgen). }
  claim HUlocStd: forall x :e U, exists I :e R_standard_basis, x :e I /\ I c= U.
  { let x0. assume Hx0U: x0 :e U.
    apply (HUloc x0 Hx0U).
    let b0. assume Hb0core.
    claim Hb0B: b0 :e order_topology_basis R.
    { exact (andEL (b0 :e order_topology_basis R) (x0 :e b0 /\ b0 c= U) Hb0core). }
    claim Hrest: x0 :e b0 /\ b0 c= U.
    { exact (andER (b0 :e order_topology_basis R) (x0 :e b0 /\ b0 c= U) Hb0core). }
    claim Hx0b0: x0 :e b0.
    { exact (andEL (x0 :e b0) (b0 c= U) Hrest). }
    claim Hb0subU: b0 c= U.
    { exact (andER (x0 :e b0) (b0 c= U) Hrest). }
    claim HexI: exists I :e R_standard_basis, x0 :e I /\ I c= b0.
    { exact (order_topology_basis_R_refines_standard_basis b0 Hb0B x0 Hx0b0). }
    apply HexI.
    let I. assume HIcore.
    apply HIcore.
    assume HIbasis: I :e R_standard_basis.
    assume HIrest: x0 :e I /\ I c= b0.
    claim Hx0I: x0 :e I.
    { exact (andEL (x0 :e I) (I c= b0) HIrest). }
    claim HIsubb0: I c= b0.
    { exact (andER (x0 :e I) (I c= b0) HIrest). }
    witness I.
    apply andI.
    - exact HIbasis.
    - apply andI.
      + exact Hx0I.
      + exact (Subq_tra I b0 U HIsubb0 Hb0subU). }
  rewrite HdefStd.
  exact (SepI (Power R)
              (fun U0 : set => forall x :e U0, exists I :e R_standard_basis, x :e I /\ I c= U0)
              U
              HUpow
              HUlocStd).
- let U. assume HU: U :e R_standard_topology.
  prove U :e order_topology R.
  claim HdefStd: R_standard_topology = generated_topology R R_standard_basis.
  { exact R_standard_topology_def_eq. }
  claim HdefOrd: order_topology R = generated_topology R (order_topology_basis R).
  { reflexivity. }
  claim HUgen: U :e generated_topology R R_standard_basis.
  { rewrite <- HdefStd.
    exact HU. }
  claim HUpow: U :e Power R.
  { exact (SepE1 (Power R)
                 (fun U0 : set => forall x :e U0, exists I :e R_standard_basis, x :e I /\ I c= U0)
                 U
                 HUgen). }
  claim HUloc: forall x :e U, exists I :e R_standard_basis, x :e I /\ I c= U.
  { exact (SepE2 (Power R)
                 (fun U0 : set => forall x :e U0, exists I :e R_standard_basis, x :e I /\ I c= U0)
                 U
                 HUgen). }
  claim HUlocOrd: forall x :e U, exists b :e order_topology_basis R, x :e b /\ b c= U.
  { let x0. assume Hx0U: x0 :e U.
    apply (HUloc x0 Hx0U).
    let I. assume HIcore.
    apply HIcore.
    assume HIbasis: I :e R_standard_basis.
    assume HIrest: x0 :e I /\ I c= U.
    claim Hx0I: x0 :e I.
    { exact (andEL (x0 :e I) (I c= U) HIrest). }
    claim HIsubU: I c= U.
    { exact (andER (x0 :e I) (I c= U) HIrest). }
    claim Hexa : exists a0 :e R, I :e {open_interval a0 bb|bb :e R}.
    { exact (famunionE R (fun a0 : set => {open_interval a0 bb|bb :e R}) I HIbasis). }
    apply Hexa.
    let a0. assume Ha0core.
    apply Ha0core.
    assume Ha0R: a0 :e R.
    assume HIaFam: I :e {open_interval a0 bb|bb :e R}.
    claim Hexb : exists b0 :e R, I = open_interval a0 b0.
    { exact (ReplE R (fun bb0 : set => open_interval a0 bb0) I HIaFam). }
    apply Hexb.
    let b0. assume Hb0core.
    apply Hb0core.
    assume Hb0R: b0 :e R.
    assume HIeq: I = open_interval a0 b0.
    set b := open_interval a0 b0.
    claim HbBasis: b :e order_topology_basis R.
    { exact (open_interval_in_order_topology_basis_R a0 b0 Ha0R Hb0R). }
    claim Hx0b: x0 :e b.
    { rewrite <- HIeq.
      exact Hx0I. }
    claim HbsubU: b c= U.
    { rewrite <- HIeq.
      exact HIsubU. }
    witness b.
    apply andI.
    - exact HbBasis.
    - apply andI.
      + exact Hx0b.
      + exact HbsubU. }
  rewrite HdefOrd.
  exact (SepI (Power R)
              (fun U0 : set => forall x :e U0, exists b :e order_topology_basis R, x :e b /\ b c= U0)
              U
              HUpow
              HUlocOrd).
Qed.

(** Helper: order topology on ℝ is a topology, via equality with the standard topology. **)
Theorem order_topology_R_is_topology : topology_on R (order_topology R).
prove topology_on R (order_topology R).
rewrite standard_topology_is_order_topology.
exact R_standard_topology_is_topology.
Qed.

(** Helper: the order-topology basis on ℝ satisfies the basis axioms. **)
(** LATEX VERSION: The order topology on ℝ is generated by open intervals and open rays, and these form a basis. **)
Theorem order_topology_basis_R_is_basis : basis_on R (order_topology_basis R).
prove basis_on R (order_topology_basis R).
set T := order_topology R.
claim HT: topology_on R T.
{ exact order_topology_R_is_topology. }
claim HCsub: forall c :e order_topology_basis R, c :e T.
  { let c. assume HcB: c :e order_topology_basis R.
	  prove c :e T.
	  set A := {I :e Power R | exists a1 :e R, exists b1 :e R,
	              I = {x :e R | order_rel R a1 x /\ order_rel R x b1}}.
	  set B := {I :e Power R | exists b1 :e R, I = {x :e R | order_rel R x b1}}.
	  set C := {I :e Power R | exists a1 :e R, I = {x :e R | order_rel R a1 x}}.
	  claim HcPow: c :e Power R.
	  { set Bold := (A :\/: B :\/: C).
	    apply (binunionE' Bold {R} c (c :e Power R)).
	    - assume HcU: c :e Bold.
	      apply (binunionE' (A :\/: B) C c (c :e Power R)).
	      + assume HcAB: c :e (A :\/: B).
	        apply (binunionE' A B c (c :e Power R)).
	        * assume HcA: c :e A.
	          exact (SepE1 (Power R)
	                       (fun I0 : set => exists a0 :e R, exists b0 :e R,
	                                        I0 = {x :e R | order_rel R a0 x /\ order_rel R x b0})
	                       c
	                       HcA).
	        * assume HcB0: c :e B.
	          exact (SepE1 (Power R)
	                       (fun I0 : set => exists b0 :e R, I0 = {x :e R | order_rel R x b0})
	                       c
	                       HcB0).
	        * exact HcAB.
	      + assume HcC: c :e C.
	        exact (SepE1 (Power R)
	                     (fun I0 : set => exists a0 :e R, I0 = {x :e R | order_rel R a0 x})
	                     c
	                     HcC).
	      + exact HcU.
	    - assume HcR: c :e {R}.
	      claim HcEq: c = R.
	      { exact (SingE R c HcR). }
	      rewrite HcEq.
	      exact (Self_In_Power R).
	    - exact HcB. }
	  exact (generated_topology_contains_elem R (order_topology_basis R) c HcPow HcB). }
claim Href: forall U :e T, forall x :e U, exists c :e order_topology_basis R, x :e c /\ c c= U.
{ let U. assume HU: U :e T.
  let x. assume HxU: x :e U.
  prove exists c :e order_topology_basis R, x :e c /\ c c= U.
  claim HTdef: T = generated_topology R (order_topology_basis R).
  { reflexivity. }
  claim HUgen: U :e generated_topology R (order_topology_basis R).
  { rewrite <- HTdef.
    exact HU. }
  exact (SepE2 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b :e order_topology_basis R, x0 :e b /\ b c= U0)
               U
               HUgen
               x
               HxU). }
exact (andEL (basis_on R (order_topology_basis R))
             (generated_topology R (order_topology_basis R) = T)
             (lemma13_2_basis_from_open_subcollection R T (order_topology_basis R) HT HCsub Href)).
Qed.

(** Helper: open rays subbasis elements are open in the order topology on ℝ. **)
Theorem open_rays_subbasis_sub_order_topology_R : open_rays_subbasis R c= order_topology R.
let U. assume HU: U :e open_rays_subbasis R.
prove U :e order_topology R.
apply (binunionE' ({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
                   :\/:
                   {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b})
                  {R}
                  U
                  (U :e order_topology R)).
- assume HU0: U :e ({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
                    :\/:
                    {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}).
  apply (binunionE' {I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
                    {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}
                    U
                    (U :e order_topology R)).
  + assume HUup: U :e {I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}.
    claim Hex: exists a :e R, U = open_ray_upper R a.
    { exact (SepE2 (Power R) (fun I0 : set => exists a :e R, I0 = open_ray_upper R a) U HUup). }
    apply Hex.
    let a. assume Hacore.
    apply Hacore.
    assume HaR: a :e R.
    assume HUeq: U = open_ray_upper R a.
    rewrite HUeq.
    claim HUbasis: open_ray_upper R a :e order_topology_basis R.
    { exact (open_ray_upper_in_order_topology_basis R a HaR). }
    claim HUpow: open_ray_upper R a :e Power R.
    { apply PowerI.
      let x. assume HxU: x :e open_ray_upper R a.
      exact (SepE1 R (fun x0 : set => order_rel R a x0) x HxU). }
    exact (generated_topology_contains_elem R (order_topology_basis R) (open_ray_upper R a) HUpow HUbasis).
  + assume HUlow: U :e {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}.
    claim Hex: exists b :e R, U = open_ray_lower R b.
    { exact (SepE2 (Power R) (fun I0 : set => exists b :e R, I0 = open_ray_lower R b) U HUlow). }
    apply Hex.
    let b. assume Hbcore.
    apply Hbcore.
    assume HbR: b :e R.
    assume HUeq: U = open_ray_lower R b.
    rewrite HUeq.
    claim HUbasis: open_ray_lower R b :e order_topology_basis R.
    { exact (open_ray_lower_in_order_topology_basis R b HbR). }
    claim HUpow: open_ray_lower R b :e Power R.
    { apply PowerI.
      let x. assume HxU: x :e open_ray_lower R b.
      exact (SepE1 R (fun x0 : set => order_rel R x0 b) x HxU). }
    exact (generated_topology_contains_elem R (order_topology_basis R) (open_ray_lower R b) HUpow HUbasis).
  + exact HU0.
- assume HUR: U :e {R}.
  claim HUeq: U = R.
  { exact (SingE R U HUR). }
  rewrite HUeq.
  exact (topology_has_X R (order_topology R) order_topology_R_is_topology).
- exact HU.
Qed.

(** Helper: on ℝ, the order topology is generated by the open rays subbasis. **)
Theorem open_rays_subbasis_for_order_topology_R :
  generated_topology_from_subbasis R (open_rays_subbasis R) = order_topology R.
prove generated_topology_from_subbasis R (open_rays_subbasis R) = order_topology R.
apply set_ext.
- let U. assume HU : U :e generated_topology_from_subbasis R (open_rays_subbasis R).
  prove U :e order_topology R.
  claim HS: subbasis_on R (open_rays_subbasis R).
  { exact (open_rays_subbasis_is_subbasis R). }
  claim HT: topology_on R (order_topology R).
  { exact order_topology_R_is_topology. }
  claim HSsub: open_rays_subbasis R c= order_topology R.
  { exact open_rays_subbasis_sub_order_topology_R. }
  claim Hmin: finer_than (order_topology R) (generated_topology_from_subbasis R (open_rays_subbasis R)).
  { exact (topology_generated_by_basis_is_minimal R (open_rays_subbasis R) (order_topology R) HS HT HSsub). }
  exact (Hmin U HU).
- let U. assume HU : U :e order_topology R.
  prove U :e generated_topology_from_subbasis R (open_rays_subbasis R).
  set Tsub := generated_topology_from_subbasis R (open_rays_subbasis R).
  claim HS: subbasis_on R (open_rays_subbasis R).
  { exact (open_rays_subbasis_is_subbasis R). }
  claim HTsub: topology_on R Tsub.
  { exact (topology_from_subbasis_is_topology R (open_rays_subbasis R) HS). }
  claim HBsub: forall b :e order_topology_basis R, b :e Tsub.
  { let b. assume Hb.
    exact (order_topology_basis_sub_generated_from_open_rays R b Hb). }
  claim Hfiner: finer_than Tsub (generated_topology R (order_topology_basis R)).
  { exact (generated_topology_finer_weak R (order_topology_basis R) Tsub HTsub HBsub). }
  exact (Hfiner U HU).
Qed.

(** from §14 Example 2: dictionary order topology on ℝ×ℝ **) 
(** LATEX VERSION: Example 2 defines the dictionary order topology on ℝ×ℝ via the order topology construction. **)
(** NOTE: We define the dictionary order topology via the open-rays subbasis. This is equivalent to the order-topology construction for the lexicographic order, but avoids dependence on the currently-admitted global order-topology basis axiom. **)
Definition R2_dictionary_order_topology : set :=
  generated_topology_from_subbasis (setprod R R) (open_rays_subbasis (setprod R R)).

Theorem dictionary_order_topology_is_topology :
  topology_on (setprod R R) R2_dictionary_order_topology.
prove topology_on (setprod R R) R2_dictionary_order_topology.
exact (topology_from_subbasis_is_topology (setprod R R)
        (open_rays_subbasis (setprod R R))
        (open_rays_subbasis_is_subbasis (setprod R R))).
Qed.

(** from §14 Example 2: rectangle subbasis yields product-style topology **) 
(** LATEX VERSION: Rectangle-type sets give a basis generating the dictionary order topology on ℝ×ℝ. **)
(** NOTE: Current witness uses the canonical basis from the open-rays subbasis via `basis_of_subbasis`; rectangle characterization is not yet formalized. **)
Theorem rectangles_basis_for_R2 :
  exists B:set, basis_on (setprod R R) B /\ generated_topology (setprod R R) B = R2_dictionary_order_topology.
prove exists B:set, basis_on (setprod R R) B /\ generated_topology (setprod R R) B = R2_dictionary_order_topology.
witness (basis_of_subbasis (setprod R R) (open_rays_subbasis (setprod R R))).
apply andI.
- exact (finite_intersections_basis_of_subbasis (setprod R R)
          (open_rays_subbasis (setprod R R))
          (open_rays_subbasis_is_subbasis (setprod R R))).
- reflexivity.
Qed.

(** from §14 Example 3: order topology on ℤ₊ is discrete **)
(** LATEX VERSION: Example 3: The order topology on the positive integers is the discrete topology. **)
Definition Zplus : set := omega :\: {0}.

(** Helper: 0 is not in Zplus **)
(** Uses the definition Zplus = omega :\: {0}. **)
Theorem zero_not_in_Zplus : 0 /:e Zplus.
prove ~(0 :e Zplus).
assume H0: 0 :e Zplus.
prove False.
claim H0m: 0 :e omega :\: {0}.
{ exact H0. }
claim Hcore: 0 :e omega /\ 0 /:e {0}.
{ exact (setminusE omega {0} 0 H0m). }
claim H0not: 0 /:e {0}.
{ exact (andER (0 :e omega) (0 /:e {0}) Hcore). }
exact (H0not (SingI 0)).
Qed.

(** Helper: 1 is in Zplus **)
(** Uses the definition Zplus = omega :\: {0}. **)
Theorem one_in_Zplus : 1 :e Zplus.
prove 1 :e omega :\: {0}.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H1not0: 1 /:e {0}.
{ assume H1: 1 :e {0}.
  prove False.
  claim Heq: 1 = 0.
  { exact (SingE 0 1 H1). }
  exact (neq_1_0 Heq). }
exact (setminusI omega {0} 1 H1omega H1not0).
Qed.

(** Helper: 2 is in Zplus **)
(** Uses the definition Zplus = omega :\: {0}. **)
Theorem two_in_Zplus : 2 :e Zplus.
prove 2 :e omega :\: {0}.
claim H2omega: 2 :e omega.
{ exact (nat_p_omega 2 nat_2). }
claim H2not0: 2 /:e {0}.
{ assume H2: 2 :e {0}.
  prove False.
  claim Heq: 2 = 0.
  { exact (SingE 0 2 H2). }
  exact (neq_2_0 Heq). }
exact (setminusI omega {0} 2 H2omega H2not0).
Qed.

(** Helper: 0 is in rational_numbers **)
(** Uses the definition rational = {x :e real | exists m :e int, exists n :e omega :\: {0}, x = m :/: n}. **)
Theorem zero_in_rational_numbers : 0 :e rational_numbers.
prove 0 :e rational.
claim H0real: 0 :e real.
{ exact real_0. }
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim H0int: 0 :e int.
{ exact (Subq_omega_int 0 H0omega). }
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H1not0: 1 /:e {0}.
{ assume H1: 1 :e {0}.
  prove False.
  claim Heq: 1 = 0.
  { exact (SingE 0 1 H1). }
  exact (neq_1_0 Heq). }
claim H1nonzero: 1 :e omega :\: {0}.
{ exact (setminusI omega {0} 1 H1omega H1not0). }
claim Heq0: 0 = div_SNo 0 1.
{ claim Hdiv: div_SNo 0 1 = 0.
  { exact (div_SNo_0_num 1 SNo_1). }
  rewrite <- Hdiv at 1.
  reflexivity. }
claim Hex: exists m :e int, exists n :e omega :\: {0}, 0 = div_SNo m n.
{ witness 0.
  apply andI.
  - exact H0int.
  - witness 1.
    apply andI.
    + exact H1nonzero.
    + exact Heq0. }
exact (SepI real
            (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n)
            0
            H0real
            Hex).
Qed.

(** Helper: 1 is in rational_numbers **)
(** Uses the definition rational = {x :e real | exists m :e int, exists n :e omega :\: {0}, x = m :/: n}. **)
Theorem one_in_rational_numbers : 1 :e rational_numbers.
prove 1 :e rational.
claim H1real: 1 :e real.
{ exact real_1. }
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H1int: 1 :e int.
{ exact (Subq_omega_int 1 H1omega). }
claim H1not0: 1 /:e {0}.
{ assume H1: 1 :e {0}.
  prove False.
  claim Heq: 1 = 0.
  { exact (SingE 0 1 H1). }
  exact (neq_1_0 Heq). }
claim H1nonzero: 1 :e omega :\: {0}.
{ exact (setminusI omega {0} 1 H1omega H1not0). }
claim Hrecip1: recip_SNo 1 = 1.
{ claim H1neq0: 1 <> 0.
  { exact neq_1_0. }
  claim Hinv: mul_SNo 1 (recip_SNo 1) = 1.
  { exact (recip_SNo_invR 1 SNo_1 H1neq0). }
  rewrite <- (mul_SNo_oneL (recip_SNo 1) (SNo_recip_SNo 1 SNo_1)) at 1.
  exact Hinv. }
claim Heq1: 1 = div_SNo 1 1.
{ claim Hdivdef: div_SNo 1 1 = mul_SNo 1 (recip_SNo 1).
  { reflexivity. }
  rewrite Hdivdef.
  rewrite Hrecip1.
  rewrite (mul_SNo_oneR 1 SNo_1).
  reflexivity. }
claim Hex: exists m :e int, exists n :e omega :\: {0}, 1 = div_SNo m n.
{ witness 1.
  apply andI.
  - exact H1int.
  - witness 1.
    apply andI.
    + exact H1nonzero.
    + exact Heq1. }
exact (SepI real
            (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n)
            1
            H1real
            Hex).
Qed.

(** Helper: minus one is in rational_numbers **)
Theorem minus_one_in_rational_numbers : minus_SNo 1 :e rational_numbers.
prove minus_SNo 1 :e rational.
claim HdefQ: rational_numbers = rational.
{ reflexivity. }
claim H1rat: 1 :e rational.
{ rewrite <- HdefQ at 1.
  exact one_in_rational_numbers. }
claim Hm1rat: minus_SNo 1 :e rational.
{ exact (rational_minus_SNo 1 H1rat). }
rewrite <- HdefQ at 1.
exact Hm1rat.
Qed.

(** Helper: minus one is not in omega **)
Theorem minus_one_not_in_omega : minus_SNo 1 /:e omega.
assume Hm1: minus_SNo 1 :e omega.
prove False.
claim Hle0: 0 <= minus_SNo 1.
{ exact (omega_nonneg (minus_SNo 1) Hm1). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
apply (SNoLeE 0 (minus_SNo 1) SNo_0 Hm1S Hle0 False).
- assume H0ltm1: 0 < minus_SNo 1.
  claim Hm1lt0: minus_SNo 1 < 0.
  { exact minus_1_lt_0. }
  claim H00: 0 < 0.
  { exact (SNoLt_tra 0 (minus_SNo 1) 0 SNo_0 Hm1S SNo_0 H0ltm1 Hm1lt0). }
  exact ((SNoLt_irref 0) H00).
- assume H0eqm1: 0 = minus_SNo 1.
  claim Hm1lt0: minus_SNo 1 < 0.
  { exact minus_1_lt_0. }
  claim H00: 0 < 0.
  { rewrite H0eqm1 at 1.
    exact Hm1lt0. }
  exact ((SNoLt_irref 0) H00).
Qed.

(** Helper: rational_numbers is not omega **)
Theorem rational_numbers_neq_omega : rational_numbers <> omega.
assume Heq: rational_numbers = omega.
prove False.
claim Hm1Q: minus_SNo 1 :e rational_numbers.
{ exact minus_one_in_rational_numbers. }
claim Hm1omega: minus_SNo 1 :e omega.
{ rewrite <- Heq.
  exact Hm1Q. }
exact (minus_one_not_in_omega Hm1omega).
Qed.

(** Helper: rational_numbers is not omega minus {0} **)
Theorem rational_numbers_neq_omega_nonzero : rational_numbers <> (omega :\: {0}).
assume Heq: rational_numbers = omega :\: {0}.
prove False.
claim Hm1Q: minus_SNo 1 :e rational_numbers.
{ exact minus_one_in_rational_numbers. }
claim Hm1NZ: minus_SNo 1 :e omega :\: {0}.
{ rewrite <- Heq.
  exact Hm1Q. }
claim Hm1omega: minus_SNo 1 :e omega.
{ exact (setminusE1 omega {0} (minus_SNo 1) Hm1NZ). }
exact (minus_one_not_in_omega Hm1omega).
Qed.

(** Helper: Zplus is not omega **)
Theorem Zplus_neq_omega : Zplus <> omega.
assume Heq: Zplus = omega.
prove False.
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim H0Z: 0 :e Zplus.
{ rewrite Heq. exact H0omega. }
exact (zero_not_in_Zplus H0Z).
Qed.

(** Helper: Zplus is not R **)
Theorem Zplus_neq_R : Zplus <> R.
assume Heq: Zplus = R.
prove False.
claim H0R: 0 :e R.
{ exact real_0. }
claim H0Z: 0 :e Zplus.
{ rewrite Heq. exact H0R. }
  exact (zero_not_in_Zplus H0Z).
Qed.

(** Helper: Zplus is not rational_numbers **)
Theorem Zplus_neq_rational_numbers : Zplus <> rational_numbers.
assume Heq: Zplus = rational_numbers.
prove False.
claim H0Q: 0 :e rational_numbers.
{ exact zero_in_rational_numbers. }
	claim H0Z: 0 :e Zplus.
	{ rewrite Heq. exact H0Q. }
	exact (zero_not_in_Zplus H0Z).
Qed.

(** Helper: {1} is not transitive **)
Theorem not_TransSet_singleton_1 : ~ TransSet {1}.
assume H: TransSet {1}.
prove False.
claim H1in: 1 :e {1}.
{ exact (SingI 1). }
claim Hsub: 1 c= {1}.
{ exact (H 1 H1in). }
claim H0in1: 0 :e 1.
{ exact In_0_1. }
claim H0inSing1: 0 :e {1}.
{ exact (Hsub 0 H0in1). }
claim Heq: 0 = 1.
{ exact (SingE 1 0 H0inSing1). }
exact (neq_0_1 Heq).
Qed.

(** Helper: {1} is not in omega **)
Theorem Sing1_not_in_omega : {1} /:e omega.
assume H: {1} :e omega.
prove False.
claim Hnat: nat_p {1}.
{ exact (omega_nat_p {1} H). }
claim Hord: ordinal {1}.
{ exact (nat_p_ordinal {1} Hnat). }
claim Htr: TransSet {1}.
{ exact (ordinal_TransSet {1} Hord). }
exact (not_TransSet_singleton_1 Htr).
Qed.

(** helper: setprod R R is not omega **)
Theorem setprod_R_R_neq_omega : setprod R R <> omega.
assume Heq: setprod R R = omega.
prove False.
claim HpRR: (0,1) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
claim HpOmega: (0,1) :e omega.
{ rewrite <- Heq. exact HpRR. }
claim HSingOmega: {1} :e omega.
{ rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** helper: setprod R R is not omega nonzero **)
Theorem setprod_R_R_neq_omega_nonzero : setprod R R <> (omega :\: {0}).
assume Heq: setprod R R = (omega :\: {0}).
prove False.
claim HpRR: (0,1) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
claim HpNZ: (0,1) :e (omega :\: {0}).
{ rewrite <- Heq. exact HpRR. }
claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
{ exact (setminusE omega {0} (0,1) HpNZ). }
claim HpOmega: (0,1) :e omega.
{ exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
claim HSingOmega: {1} :e omega.
{ rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** helper: setprod 2 omega is not omega **)
Theorem setprod_2_omega_neq_omega : setprod 2 omega <> omega.
assume Heq: setprod 2 omega = omega.
prove False.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Hp: (0,1) :e setprod 2 omega.
{ exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
claim HpOmega: (0,1) :e omega.
{ rewrite <- Heq. exact Hp. }
claim HSingOmega: {1} :e omega.
{ rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** helper: setprod 2 omega is not omega nonzero **)
Theorem setprod_2_omega_neq_omega_nonzero : setprod 2 omega <> (omega :\: {0}).
assume Heq: setprod 2 omega = (omega :\: {0}).
prove False.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Hp: (0,1) :e setprod 2 omega.
{ exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
claim HpNZ: (0,1) :e (omega :\: {0}).
{ rewrite <- Heq. exact Hp. }
claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
{ exact (setminusE omega {0} (0,1) HpNZ). }
claim HpOmega: (0,1) :e omega.
{ exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
claim HSingOmega: {1} :e omega.
{ rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** helper: setprod 2 omega is not setprod R R **)
Theorem setprod_2_omega_neq_setprod_R_R : setprod 2 omega <> setprod R R.
assume Heq: setprod 2 omega = setprod R R.
prove False.
apply setprod_R_R_neq_setprod_2_omega.
rewrite <- Heq.
reflexivity.
Qed.

(** helper: setprod 2 omega is not R **)
Theorem setprod_2_omega_neq_R : setprod 2 omega <> R.
assume Heq: setprod 2 omega = R.
prove False.

(** Countability of omega by the identity injection. **)
claim Homega_countable: countable omega.
{ prove atleastp omega omega.
  claim Homega_sub: omega c= omega.
  { let x. assume Hx: x :e omega.
    exact Hx. }
  exact (Subq_atleastp omega omega Homega_sub). }

(** Countability of 2 via 2 c= {0,1} c= omega. **)
claim H01subomega: {0,1} c= omega.
{ let x. assume Hx: x :e {0,1}.
  prove x :e omega.
  apply (UPairE x 0 1 Hx (x :e omega)).
  - assume Hx0: x = 0.
    rewrite Hx0.
    exact (nat_p_omega 0 nat_0).
  - assume Hx1: x = 1.
    rewrite Hx1.
    exact (nat_p_omega 1 nat_1). }
claim H2subomega: 2 c= omega.
{ exact (Subq_tra 2 {0,1} omega Subq_2_UPair01 H01subomega). }
claim H2countable: countable 2.
{ exact (Subq_atleastp 2 omega H2subomega). }

(** Therefore setprod 2 omega is countable. **)
claim Hprod_countable: countable (setprod 2 omega).
{ exact (setprod_countable 2 omega H2countable Homega_countable). }

(** Transfer countability to R by rewriting, contradicting real uncountability. **)
claim HRcountable: countable R.
{ rewrite <- Heq. exact Hprod_countable. }
claim HdefR: R = real.
{ reflexivity. }
claim Hreal_countable: atleastp real omega.
{ rewrite <- HdefR at 1.
  exact HRcountable. }
exact (form100_22_real_uncountable_atleastp Hreal_countable).
Qed.

(** helper: setprod 2 omega is not rational_numbers **)
Theorem setprod_2_omega_neq_rational_numbers : setprod 2 omega <> rational_numbers.
assume Heq: setprod 2 omega = rational_numbers.
prove False.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Hp: (0,1) :e setprod 2 omega.
{ exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
claim HpQ: (0,1) :e rational_numbers.
{ rewrite <- Heq.
  exact Hp. }
claim HSingQ: {1} :e rational_numbers.
{ rewrite <- tuple_0_1_eq_Sing1.
  exact HpQ. }
claim HSingR: {1} :e R.
{ exact (rational_numbers_in_R {1} HSingQ). }
claim HSingS: SNo {1}.
{ exact (real_SNo {1} HSingR). }
exact (Sing1_not_SNo HSingS).
Qed.

(** helper: rational_numbers is not setprod 2 omega **)
Theorem rational_numbers_neq_setprod_2_omega : rational_numbers <> setprod 2 omega.
assume Heq: rational_numbers = setprod 2 omega.
prove False.
apply setprod_2_omega_neq_rational_numbers.
rewrite <- Heq.
reflexivity.
Qed.

(** helper: rational_numbers is not setprod R R **)
Theorem rational_numbers_neq_setprod_R_R : rational_numbers <> setprod R R.
assume Heq: rational_numbers = setprod R R.
prove False.
apply setprod_R_R_neq_rational_numbers.
rewrite <- Heq.
reflexivity.
Qed.

(** helper: rational_numbers is not R **)
Theorem rational_numbers_neq_R : rational_numbers <> R.
assume Heq: rational_numbers = R.
prove False.
apply R_neq_rational_numbers.
rewrite <- Heq.
reflexivity.
Qed.

(** Helper: order_rel on rational_numbers implies strict order in R **)
(** LATEX VERSION: If order_rel(ℚ,a,b) then a<b in ℝ (all other disjuncts contradict known inequalities of carrier sets). **)
Theorem order_rel_Q_implies_Rlt : forall a b:set, order_rel rational_numbers a b -> Rlt a b.
let a b. assume Hrel: order_rel rational_numbers a b.
prove Rlt a b.
apply (Hrel (Rlt a b)).
- assume Hleft6.
  apply (Hleft6 (Rlt a b)).
  - assume Hleft.
    apply (Hleft (Rlt a b)).
    - assume Hleft2.
      apply (Hleft2 (Rlt a b)).
      + assume Hleft3.
        apply (Hleft3 (Rlt a b)).
        * assume Hleft4.
          apply (Hleft4 (Rlt a b)).
          - assume HA: rational_numbers = R /\ Rlt a b.
            apply FalseE.
            claim Heq: rational_numbers = R.
            { exact (andEL (rational_numbers = R) (Rlt a b) HA). }
            exact (rational_numbers_neq_R Heq).
          - assume HB: rational_numbers = rational_numbers /\ Rlt a b.
            exact (andER (rational_numbers = rational_numbers) (Rlt a b) HB).
        * assume HC: rational_numbers = omega /\ a :e b.
          apply FalseE.
          claim Heq: rational_numbers = omega.
          { exact (andEL (rational_numbers = omega) (a :e b) HC). }
          exact (rational_numbers_neq_omega Heq).
      + assume HD: rational_numbers = omega :\: {0} /\ a :e b.
        apply FalseE.
        claim Heq: rational_numbers = omega :\: {0}.
        { exact (andEL (rational_numbers = omega :\: {0}) (a :e b) HD). }
        exact (rational_numbers_neq_omega_nonzero Heq).
    - assume HE: rational_numbers = setprod 2 omega /\
        exists i m j n:set,
          i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
          a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
      apply FalseE.
      claim Heq: rational_numbers = setprod 2 omega.
      { exact (andEL (rational_numbers = setprod 2 omega)
                    (exists i m j n:set,
                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                    HE). }
      exact (rational_numbers_neq_setprod_2_omega Heq).
  - assume HF: rational_numbers = setprod R R /\
      exists a1 a2 b1 b2:set,
        a = (a1, a2) /\ b = (b1, b2) /\
        (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
    apply FalseE.
    claim Heq: rational_numbers = setprod R R.
    { exact (andEL (rational_numbers = setprod R R)
                   (exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                   HF). }
    exact (rational_numbers_neq_setprod_R_R Heq).
- assume Hord:
    ordinal rational_numbers /\ rational_numbers <> R /\ rational_numbers <> rational_numbers /\
    rational_numbers <> setprod 2 omega /\ rational_numbers <> setprod R R /\ a :e b.
  apply FalseE.
  apply Hord. assume Hcore Haeb.
  apply Hcore. assume Hcore2 HneqRR.
  apply Hcore2. assume Hcore3 Hneq2omega.
  apply Hcore3. assume HordQ HneqQQ.
  claim Hrefl: rational_numbers = rational_numbers.
  { reflexivity. }
  exact (HneqQQ Hrefl).
Qed.

(** helper: unfold order_rel on setprod 2 omega to the dictionary-order case **)
Theorem order_rel_setprod_2_omega_unfold : forall a b:set,
  order_rel (setprod 2 omega) a b ->
  exists i m j n:set,
    (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))).
let a b. assume Hrel: order_rel (setprod 2 omega) a b.
apply (Hrel (exists i m j n:set,
               (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
- assume Hleft6.
  apply (Hleft6 (exists i m j n:set,
                  (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                   a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
  - assume Hleft.
    apply (Hleft (exists i m j n:set,
                   (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                    a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
    - assume Hmid.
      apply (Hmid (exists i m j n:set,
                     (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
      + assume Hm2.
        apply (Hm2 (exists i m j n:set,
                      (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                       a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
        - assume Hm3.
          apply (Hm3 (exists i m j n:set,
                        (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                         a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))).
          - assume Hc1.
            apply FalseE.
            claim Heq: setprod 2 omega = R.
            { exact (andEL (setprod 2 omega = R) (Rlt a b) Hc1). }
            exact (setprod_2_omega_neq_R Heq).
          - assume Hc2.
            apply FalseE.
            claim Heq: setprod 2 omega = rational_numbers.
            { exact (andEL (setprod 2 omega = rational_numbers) (Rlt a b) Hc2). }
            exact (setprod_2_omega_neq_rational_numbers Heq).
        - assume Hc3.
          apply FalseE.
          claim Heq: setprod 2 omega = omega.
          { exact (andEL (setprod 2 omega = omega) (a :e b) Hc3). }
          exact (setprod_2_omega_neq_omega Heq).
      + assume Hc4.
        apply FalseE.
        claim Heq: setprod 2 omega = omega :\: {0}.
        { exact (andEL (setprod 2 omega = omega :\: {0}) (a :e b) Hc4). }
        exact (setprod_2_omega_neq_omega_nonzero Heq).
    - assume Hc5.
      exact (andER (setprod 2 omega = setprod 2 omega)
                   (exists i m j n:set,
                     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                     a = (i, m) /\ b = (j, n) /\
                     (i :e j \/ (i = j /\ m :e n)))
                   Hc5).
  - assume Hc6.
    apply FalseE.
    claim Heq: setprod 2 omega = setprod R R.
    { exact (andEL (setprod 2 omega = setprod R R)
                  (exists a1 a2 b1 b2:set,
                    a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                  Hc6). }
    exact (setprod_2_omega_neq_setprod_R_R Heq).
- assume Hord:
    ordinal (setprod 2 omega) /\ setprod 2 omega <> R /\ setprod 2 omega <> rational_numbers /\
    setprod 2 omega <> setprod 2 omega /\ setprod 2 omega <> setprod R R /\ a :e b.
  apply FalseE.
  apply Hord. assume Hcore Haeb.
  apply Hcore. assume Hcore2 HneqRR.
  apply Hcore2. assume Hcore3 HneqXX.
  apply Hcore3. assume Hcore4 HneqRat.
  apply Hcore4. assume HordX HneqR.
  claim Hrefl: setprod 2 omega = setprod 2 omega.
  { reflexivity. }
  exact (HneqXX Hrefl).
Qed.

(** helper: unfold order_rel on setprod R R to the dictionary-order case **)
Theorem order_rel_setprod_R_R_unfold : forall a b:set,
  order_rel (setprod R R) a b ->
  exists a1 a2 b1 b2:set,
    a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
let a b. assume Hrel: order_rel (setprod R R) a b.
apply (Hrel (exists a1 a2 b1 b2:set,
               a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
- assume Hleft6.
  apply (Hleft6 (exists a1 a2 b1 b2:set,
                  a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
  - assume Hleft.
    apply (Hleft (exists a1 a2 b1 b2:set,
                   a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
    - assume Hmid.
      apply (Hmid (exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
      + assume Hm2.
        apply (Hm2 (exists a1 a2 b1 b2:set,
                      a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
        - assume Hm3.
          apply (Hm3 (exists a1 a2 b1 b2:set,
                        a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))).
          - assume Hc1.
            apply FalseE.
            claim Heq: setprod R R = R.
            { exact (andEL (setprod R R = R) (Rlt a b) Hc1). }
            exact (setprod_R_R_neq_R Heq).
          - assume Hc2.
            apply FalseE.
            claim Heq: setprod R R = rational_numbers.
            { exact (andEL (setprod R R = rational_numbers) (Rlt a b) Hc2). }
            exact (setprod_R_R_neq_rational_numbers Heq).
        - assume Hc3.
          apply FalseE.
          claim Heq: setprod R R = omega.
          { exact (andEL (setprod R R = omega) (a :e b) Hc3). }
          exact (setprod_R_R_neq_omega Heq).
      + assume Hc4.
        apply FalseE.
        claim Heq: setprod R R = omega :\: {0}.
        { exact (andEL (setprod R R = omega :\: {0}) (a :e b) Hc4). }
        exact (setprod_R_R_neq_omega_nonzero Heq).
    - assume Hc5.
      apply FalseE.
      claim Heq: setprod R R = setprod 2 omega.
      { exact (andEL (setprod R R = setprod 2 omega)
                    (exists i m j n:set,
                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\
                      (i :e j \/ (i = j /\ m :e n)))
                    Hc5). }
      exact (setprod_R_R_neq_setprod_2_omega Heq).
  - assume Hc6.
    exact (andER (setprod R R = setprod R R)
                 (exists a1 a2 b1 b2:set,
                   a = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                 Hc6).
- assume Hord:
    ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
    setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ a :e b.
  apply FalseE.
  apply Hord. assume Hcore Haeb.
  apply Hcore. assume Hcore2 HneqRR.
  claim Hrefl: setprod R R = setprod R R.
  { reflexivity. }
  exact (HneqRR Hrefl).
Qed.

(** helper: introduce order_rel on R×R from the dictionary comparison disjunction **)
Theorem order_rel_setprod_R_R_intro : forall a1 a2 b1 b2:set,
  (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)) ->
  order_rel (setprod R R) (a1, a2) (b1, b2).
let a1 a2 b1 b2.
assume Hdisj.
prove order_rel (setprod R R) (a1, a2) (b1, b2).
prove (setprod R R = R /\ Rlt (a1, a2) (b1, b2))
  \/
  (setprod R R = rational_numbers /\ Rlt (a1, a2) (b1, b2))
  \/
  (setprod R R = omega /\ (a1, a2) :e (b1, b2))
  \/
  (setprod R R = omega :\: {0} /\ (a1, a2) :e (b1, b2))
  \/
  (setprod R R = setprod 2 omega /\
   exists i m j n:set,
     i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
     (a1, a2) = (i, m) /\ (b1, b2) = (j, n) /\
     (i :e j \/ (i = j /\ m :e n)))
  \/
  (setprod R R = setprod R R /\
   exists c1 c2 d1 d2:set,
     (a1, a2) = (c1, c2) /\ (b1, b2) = (d1, d2) /\
     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)))
  \/
  (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
   setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ (a1, a2) :e (b1, b2)).
apply orIL.
apply orIR.
prove setprod R R = setprod R R /\
   exists c1 c2 d1 d2:set,
     (a1, a2) = (c1, c2) /\ (b1, b2) = (d1, d2) /\
     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
apply andI.
- reflexivity.
- witness a1.
  witness a2.
  witness b1.
  witness b2.
  prove (a1, a2) = (a1, a2) /\ (b1, b2) = (b1, b2) /\
        (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
  apply andI.
  + apply andI.
    - reflexivity.
    - reflexivity.
  + exact Hdisj.
Qed.

(** Helper: Zplus is not setprod 2 omega **)
Theorem Zplus_neq_setprod_2_omega : Zplus <> setprod 2 omega.
assume Heq: Zplus = setprod 2 omega.
prove False.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Hp: (0,1) :e setprod 2 omega.
{ exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 1 In_0_2 H1omega). }
claim HpZ: (0,1) :e Zplus.
{ rewrite Heq. exact Hp. }
claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
{ exact (setminusE omega {0} (0,1) HpZ). }
claim HpOmega: (0,1) :e omega.
{ exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
claim HSingOmega: {1} :e omega.
{ prove {1} :e omega.
  rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** Helper: Zplus is not setprod R R **)
Theorem Zplus_neq_setprod_R_R : Zplus <> setprod R R.
assume Heq: Zplus = setprod R R.
prove False.
claim Hp: (0,1) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R 0 1 real_0 real_1). }
claim HpZ: (0,1) :e Zplus.
{ rewrite Heq. exact Hp. }
claim Hcore: (0,1) :e omega /\ (0,1) /:e {0}.
{ exact (setminusE omega {0} (0,1) HpZ). }
claim HpOmega: (0,1) :e omega.
{ exact (andEL ((0,1) :e omega) ((0,1) /:e {0}) Hcore). }
claim HSingOmega: {1} :e omega.
{ prove {1} :e omega.
  rewrite <- tuple_0_1_eq_Sing1.
  exact HpOmega. }
exact (Sing1_not_in_omega HSingOmega).
Qed.

(** Helper: on Zplus, order_rel is membership order **)
Theorem order_rel_Zplus_iff_mem : forall a b:set,
  a :e Zplus -> b :e Zplus -> (order_rel Zplus a b <-> a :e b).
let a b. assume HaZ HbZ.
apply iffI.
- assume Hrel: order_rel Zplus a b.
  prove a :e b.
  (** eliminate disjunctions in order_rel using Zplus inequalities **)
  apply (Hrel (a :e b)).
  - assume Hleft6.
    apply (Hleft6 (a :e b)).
    - assume Hleft.
      apply (Hleft (a :e b)).
      - assume Hmid.
        apply (Hmid (a :e b)).
        + assume Hm2.
          apply (Hm2 (a :e b)).
          - assume Hm3.
            apply (Hm3 (a :e b)).
            - assume Hc1.
              apply FalseE.
              claim Heq: Zplus = R.
              { exact (andEL (Zplus = R) (Rlt a b) Hc1). }
              exact (Zplus_neq_R Heq).
            - assume Hc2.
              apply FalseE.
              claim Heq: Zplus = rational_numbers.
              { exact (andEL (Zplus = rational_numbers) (Rlt a b) Hc2). }
              exact (Zplus_neq_rational_numbers Heq).
          - assume Hc3.
            apply FalseE.
            claim Heq: Zplus = omega.
            { exact (andEL (Zplus = omega) (a :e b) Hc3). }
            exact (Zplus_neq_omega Heq).
        + assume Hc4.
          exact (andER (Zplus = omega :\: {0}) (a :e b) Hc4).
      - assume Hc5.
        apply FalseE.
        claim Heq: Zplus = setprod 2 omega.
        { exact (andEL (Zplus = setprod 2 omega)
                      (exists i m j n:set,
                        i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                        a = (i, m) /\ b = (j, n) /\
                        (i :e j \/ (i = j /\ m :e n)))
                      Hc5). }
        exact (Zplus_neq_setprod_2_omega Heq).
    - assume Hc6.
      apply FalseE.
      claim Heq: Zplus = setprod R R.
      { exact (andEL (Zplus = setprod R R)
                    (exists a1 a2 b1 b2:set,
                      a = (a1, a2) /\ b = (b1, b2) /\
                      (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                    Hc6). }
      exact (Zplus_neq_setprod_R_R Heq).
  - assume Hord:
      ordinal Zplus /\ Zplus <> R /\ Zplus <> rational_numbers /\ Zplus <> setprod 2 omega /\ Zplus <> setprod R R /\ a :e b.
    apply Hord. assume Hcore Hab2.
    exact Hab2.
- assume Hab: a :e b.
  prove order_rel Zplus a b.
  claim Heq: Zplus = omega :\: {0}.
  { reflexivity. }
  rewrite Heq.
  exact (mem_implies_order_rel_omega_nonzero a b Hab).
Qed.

(** Helper: membership in Zplus implies membership in omega **)
Theorem Zplus_mem_omega : forall n:set, n :e Zplus -> n :e omega.
let n. assume Hn: n :e Zplus.
claim Hcore: n :e omega /\ n /:e {0}.
{ exact (setminusE omega {0} n Hn). }
exact (andEL (n :e omega) (n /:e {0}) Hcore).
Qed.

(** Helper: membership in Zplus implies n<>0 **)
Theorem Zplus_mem_nonzero : forall n:set, n :e Zplus -> n <> 0.
let n. assume Hn: n :e Zplus.
assume Heq: n = 0.
prove False.
claim Hcore: n :e omega /\ n /:e {0}.
{ exact (setminusE omega {0} n Hn). }
claim Hnnot0: n /:e {0}.
{ exact (andER (n :e omega) (n /:e {0}) Hcore). }
claim HnIn: n :e {0}.
{ rewrite Heq.
  exact (SingI 0). }
exact (Hnnot0 HnIn).
Qed.

(** Helper: Zplus is a subset of omega **)
Theorem Zplus_Subq_omega : Zplus c= omega.
let n. assume Hn: n :e Zplus.
exact (Zplus_mem_omega n Hn).
Qed.

(** Helper: successor of a Zplus element is again in Zplus **)
Theorem Zplus_ordsucc_closed : forall n:set, n :e Zplus -> ordsucc n :e Zplus.
let n. assume Hn: n :e Zplus.
claim HnOmega: n :e omega.
{ exact (Zplus_mem_omega n Hn). }
claim HsuccOmega: ordsucc n :e omega.
{ exact (omega_ordsucc n HnOmega). }
claim HsuccNot0: ordsucc n /:e {0}.
{ assume H0: ordsucc n :e {0}.
  prove False.
  claim Heq0: ordsucc n = 0.
  { exact (SingE 0 (ordsucc n) H0). }
  exact (neq_ordsucc_0 n Heq0). }
exact (setminusI omega {0} (ordsucc n) HsuccOmega HsuccNot0).
Qed.

(** Helper: singleton sets are basic opens in the order topology basis on Zplus **)
Theorem nat_nonzero_in_Zplus : forall n:set, nat_p n -> n <> 0 -> n :e Zplus.
let n. assume HnNat HnNeq.
prove n :e omega :\: {0}.
claim HnOmega: n :e omega.
{ exact (nat_p_omega n HnNat). }
claim Hnnot0: n /:e {0}.
{ assume Hn0: n :e {0}.
  prove False.
  claim Heq: n = 0.
  { exact (SingE 0 n Hn0). }
  exact (HnNeq Heq). }
exact (setminusI omega {0} n HnOmega Hnnot0).
Qed.

(** Helper: singleton {1} is in the order topology basis on Zplus **)
Theorem singleton_ordsucc0_in_order_topology_basis_Zplus :
  {ordsucc 0} :e order_topology_basis Zplus.
prove {ordsucc 0} :e order_topology_basis Zplus.
(** expand order_topology_basis **)
claim Hdef: order_topology_basis Zplus =
  (({I :e Power Zplus | exists a :e Zplus, exists b :e Zplus,
         I = {x :e Zplus | order_rel Zplus a x /\ order_rel Zplus x b}}
    :\/:
    {I :e Power Zplus | exists b :e Zplus, I = {x :e Zplus | order_rel Zplus x b}}
    :\/:
    {I :e Power Zplus | exists a :e Zplus, I = {x :e Zplus | order_rel Zplus a x}})
   :\/:
   {Zplus}).
{ reflexivity. }
rewrite Hdef.
(** order_topology_basis Zplus is a union of three families; use lower ray family **)
apply binunionI1.
apply binunionI1.
apply binunionI2.
apply (SepI (Power Zplus)
            (fun I : set => exists b0 :e Zplus, I = {x :e Zplus | order_rel Zplus x b0})
            {ordsucc 0}).
- apply PowerI.
  let x. assume Hx: x :e {ordsucc 0}.
  prove x :e Zplus.
  claim HxEq: x = ordsucc 0.
  { exact (SingE (ordsucc 0) x Hx). }
  rewrite HxEq.
  exact one_in_Zplus.
- witness (ordsucc (ordsucc 0)).
  apply andI.
  - exact two_in_Zplus.
  - prove {ordsucc 0} = {x :e Zplus | order_rel Zplus x (ordsucc (ordsucc 0))}.
    apply set_ext.
    - let x. assume Hx: x :e {ordsucc 0}.
       prove x :e {x :e Zplus | order_rel Zplus x (ordsucc (ordsucc 0))}.
       claim HxEq: x = ordsucc 0.
       { exact (SingE (ordsucc 0) x Hx). }
       apply (SepI Zplus
                   (fun t : set => order_rel Zplus t (ordsucc (ordsucc 0)))
                   x).
       - rewrite HxEq.
         exact one_in_Zplus.
       - rewrite HxEq.
         claim Hmem: ordsucc 0 :e ordsucc (ordsucc 0).
         { exact (ordsuccI2 (ordsucc 0)). }
         exact (iffER (order_rel Zplus (ordsucc 0) (ordsucc (ordsucc 0)))
                      (ordsucc 0 :e ordsucc (ordsucc 0))
                      (order_rel_Zplus_iff_mem (ordsucc 0) (ordsucc (ordsucc 0)) one_in_Zplus two_in_Zplus)
                      Hmem).
    - let x. assume Hx: x :e {x :e Zplus | order_rel Zplus x (ordsucc (ordsucc 0))}.
       prove x :e {ordsucc 0}.
       claim HxZ: x :e Zplus.
       { exact (SepE1 Zplus (fun t : set => order_rel Zplus t (ordsucc (ordsucc 0))) x Hx). }
       claim Hrel: order_rel Zplus x (ordsucc (ordsucc 0)).
       { exact (SepE2 Zplus (fun t : set => order_rel Zplus t (ordsucc (ordsucc 0))) x Hx). }
       claim Hmem: x :e ordsucc (ordsucc 0).
       { exact (iffEL (order_rel Zplus x (ordsucc (ordsucc 0)))
                      (x :e ordsucc (ordsucc 0))
                      (order_rel_Zplus_iff_mem x (ordsucc (ordsucc 0)) HxZ two_in_Zplus)
                      Hrel). }
       claim HxNe0: x <> 0.
       { exact (Zplus_mem_nonzero x HxZ). }
       claim Hcase: x :e ordsucc 0 \/ x = ordsucc 0.
       { exact (ordsuccE (ordsucc 0) x Hmem). }
       claim HxEq1: x = ordsucc 0.
       { apply (Hcase (x = ordsucc 0)).
         - assume HxIn1: x :e ordsucc 0.
           apply FalseE.
           claim Hcase0: x :e 0 \/ x = 0.
           { exact (ordsuccE 0 x HxIn1). }
           claim Hx0: x = 0.
           { apply (Hcase0 (x = 0)).
             + assume HxIn0: x :e 0.
               apply FalseE.
               exact (EmptyE x HxIn0).
             + assume Hx0. exact Hx0. }
           exact (HxNe0 Hx0).
         - assume HxEq. exact HxEq. }
       rewrite HxEq1.
       exact (SingI (ordsucc 0)).
Qed.

(** Helper: singleton of a successor is in the order topology basis on Zplus **)
Theorem singleton_ordsucc_in_order_topology_basis_Zplus : forall m:set,
  m :e Zplus -> {ordsucc m} :e order_topology_basis Zplus.
let m. assume Hm.
prove {ordsucc m} :e order_topology_basis Zplus.
(** expand order_topology_basis **)
claim Hdef: order_topology_basis Zplus =
  (({I :e Power Zplus | exists a :e Zplus, exists b :e Zplus,
         I = {x :e Zplus | order_rel Zplus a x /\ order_rel Zplus x b}}
    :\/:
    {I :e Power Zplus | exists b :e Zplus, I = {x :e Zplus | order_rel Zplus x b}}
    :\/:
    {I :e Power Zplus | exists a :e Zplus, I = {x :e Zplus | order_rel Zplus a x}})
   :\/:
   {Zplus}).
{ reflexivity. }
rewrite Hdef.
(** use open interval (m, ordsucc (ordsucc m)) in the interval family **)
apply binunionI1.
apply binunionI1.
apply binunionI1.
apply (SepI (Power Zplus)
            (fun I : set =>
               exists a :e Zplus, exists b :e Zplus,
                 I = {x :e Zplus | order_rel Zplus a x /\ order_rel Zplus x b})
            {ordsucc m}).
- apply PowerI.
  let x. assume Hx: x :e {ordsucc m}.
  prove x :e Zplus.
  claim HxEq: x = ordsucc m.
  { exact (SingE (ordsucc m) x Hx). }
  rewrite HxEq.
  exact (Zplus_ordsucc_closed m Hm).
- witness m.
  apply andI.
  - exact Hm.
  - witness (ordsucc (ordsucc m)).
    apply andI.
    - exact (Zplus_ordsucc_closed (ordsucc m) (Zplus_ordsucc_closed m Hm)).
    - prove {ordsucc m} =
        {x :e Zplus | order_rel Zplus m x /\ order_rel Zplus x (ordsucc (ordsucc m))}.
       apply set_ext.
       - let x. assume Hx: x :e {ordsucc m}.
          prove x :e {x :e Zplus | order_rel Zplus m x /\ order_rel Zplus x (ordsucc (ordsucc m))}.
          claim HxEq: x = ordsucc m.
          { exact (SingE (ordsucc m) x Hx). }
          apply (SepI Zplus
                      (fun t : set => order_rel Zplus m t /\ order_rel Zplus t (ordsucc (ordsucc m)))
                      x).
          - rewrite HxEq.
            exact (Zplus_ordsucc_closed m Hm).
          - rewrite HxEq.
            apply andI.
            * claim Hmem1: m :e ordsucc m.
              { exact (ordsuccI2 m). }
              exact (iffER (order_rel Zplus m (ordsucc m))
                           (m :e ordsucc m)
                           (order_rel_Zplus_iff_mem m (ordsucc m) Hm (Zplus_ordsucc_closed m Hm))
                           Hmem1).
            * claim Hmem2: ordsucc m :e ordsucc (ordsucc m).
              { exact (ordsuccI2 (ordsucc m)). }
              exact (iffER (order_rel Zplus (ordsucc m) (ordsucc (ordsucc m)))
                           (ordsucc m :e ordsucc (ordsucc m))
                           (order_rel_Zplus_iff_mem (ordsucc m) (ordsucc (ordsucc m))
                                                    (Zplus_ordsucc_closed m Hm)
                                                    (Zplus_ordsucc_closed (ordsucc m) (Zplus_ordsucc_closed m Hm)))
                           Hmem2).
       - let x. assume Hx: x :e {x :e Zplus | order_rel Zplus m x /\ order_rel Zplus x (ordsucc (ordsucc m))}.
          prove x :e {ordsucc m}.
          claim HxZ: x :e Zplus.
          { exact (SepE1 Zplus
                        (fun t : set => order_rel Zplus m t /\ order_rel Zplus t (ordsucc (ordsucc m)))
                        x
                        Hx). }
          claim Hconj: order_rel Zplus m x /\ order_rel Zplus x (ordsucc (ordsucc m)).
          { exact (SepE2 Zplus
                        (fun t : set => order_rel Zplus m t /\ order_rel Zplus t (ordsucc (ordsucc m)))
                        x
                        Hx). }
          claim Hrel1: order_rel Zplus m x.
          { exact (andEL (order_rel Zplus m x)
                         (order_rel Zplus x (ordsucc (ordsucc m)))
                         Hconj). }
          claim Hrel2: order_rel Zplus x (ordsucc (ordsucc m)).
          { exact (andER (order_rel Zplus m x)
                         (order_rel Zplus x (ordsucc (ordsucc m)))
                         Hconj). }
          claim Hmemb: m :e x.
          { exact (iffEL (order_rel Zplus m x)
                         (m :e x)
                         (order_rel_Zplus_iff_mem m x Hm HxZ)
                         Hrel1). }
          claim HbZ: ordsucc (ordsucc m) :e Zplus.
          { exact (Zplus_ordsucc_closed (ordsucc m) (Zplus_ordsucc_closed m Hm)). }
          claim HxInb: x :e ordsucc (ordsucc m).
          { exact (iffEL (order_rel Zplus x (ordsucc (ordsucc m)))
                         (x :e ordsucc (ordsucc m))
                         (order_rel_Zplus_iff_mem x (ordsucc (ordsucc m)) HxZ HbZ)
                         Hrel2). }
          claim Hcase: x :e ordsucc m \/ x = ordsucc m.
          { exact (ordsuccE (ordsucc m) x HxInb). }
          claim HxEq: x = ordsucc m.
          { apply (Hcase (x = ordsucc m)).
            - assume HxIn1: x :e ordsucc m.
              apply FalseE.
              claim Hcase2: x :e m \/ x = m.
              { exact (ordsuccE m x HxIn1). }
              claim HxInm: x :e m.
              { apply (Hcase2 (x :e m)).
                + assume Hxm. exact Hxm.
                + assume Hxeq.
                  apply FalseE.
                  claim Hmm: m :e m.
                  { prove m :e m.
                    rewrite <- Hxeq at 2.
                    exact Hmemb. }
                  exact (In_irref m Hmm). }
              exact (In_no2cycle m x Hmemb HxInm).
            - assume Hxeq. exact Hxeq. }
          rewrite HxEq.
          exact (SingI (ordsucc m)).
Qed.

Theorem singleton_in_order_topology_basis_Zplus : forall n:set,
  n :e Zplus -> {n} :e order_topology_basis Zplus.
let n. assume HnZ.
claim HnOmega: n :e omega.
{ exact (Zplus_mem_omega n HnZ). }
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnOmega). }
claim HnNeq0: n <> 0.
{ exact (Zplus_mem_nonzero n HnZ). }
claim Hcase: n = 0 \/ exists m:set, nat_p m /\ n = ordsucc m.
{ exact (nat_inv n HnNat). }
apply (Hcase ({n} :e order_topology_basis Zplus)).
- assume Hn0: n = 0.
  prove {n} :e order_topology_basis Zplus.
  apply FalseE.
  exact (HnNeq0 Hn0).
- assume Hex: exists m:set, nat_p m /\ n = ordsucc m.
  apply Hex.
  let m. assume Hmpair.
  apply Hmpair.
  assume HmNat HnEq.
  apply (xm (m = 0)).
  + assume Hm0: m = 0.
    prove {n} :e order_topology_basis Zplus.
    rewrite HnEq.
    rewrite Hm0.
    exact singleton_ordsucc0_in_order_topology_basis_Zplus.
  + assume HmNe0: m <> 0.
    prove {n} :e order_topology_basis Zplus.
    claim HmZ: m :e Zplus.
    { exact (nat_nonzero_in_Zplus m HmNat HmNe0). }
    rewrite HnEq.
    exact (singleton_ordsucc_in_order_topology_basis_Zplus m HmZ).
Qed.

(** Helper: order topology on Zplus is discrete **)
Theorem Zplus_order_topology_is_discrete :
  generated_topology Zplus (order_topology_basis Zplus) = Power Zplus.
prove generated_topology Zplus (order_topology_basis Zplus) = Power Zplus.
apply set_ext.
- let U. assume HU: U :e generated_topology Zplus (order_topology_basis Zplus).
  prove U :e Power Zplus.
  exact (SepE1 (Power Zplus)
               (fun U0 : set => forall x :e U0, exists b :e order_topology_basis Zplus, x :e b /\ b c= U0)
               U HU).
- let U. assume HU: U :e Power Zplus.
  prove U :e generated_topology Zplus (order_topology_basis Zplus).
  prove U :e {U0 :e Power Zplus | forall x :e U0, exists b :e order_topology_basis Zplus, x :e b /\ b c= U0}.
  apply (SepI (Power Zplus)
              (fun U0 : set => forall x :e U0, exists b :e order_topology_basis Zplus, x :e b /\ b c= U0)
              U
              HU).
  claim HUsub: U c= Zplus.
  { exact (PowerE Zplus U HU). }
  let x. assume Hx: x :e U.
  witness {x}.
  apply andI.
  + exact (singleton_in_order_topology_basis_Zplus x (HUsub x Hx)).
  + apply andI.
    * exact (SingI x).
    * let y. assume Hy: y :e {x}.
      prove y :e U.
      claim HyEq: y = x.
      { exact (SingE x y Hy). }
      rewrite HyEq.
      exact Hx.
Qed.

Theorem order_topology_on_Zplus_discrete :
  order_topology Zplus = discrete_topology Zplus.
prove order_topology Zplus = discrete_topology Zplus.
(** Zplus = omega :\: {0} by definition **)
(** order_topology Zplus = generated_topology Zplus (order_topology_basis Zplus) **)
(** discrete_topology Zplus = Power Zplus **)
exact Zplus_order_topology_is_discrete.
Qed.

(** Helper: conjunction reassociation (/\ is left-associative) **)
Theorem and_assoc : forall A B C:prop, (A /\ B) /\ C -> A /\ (B /\ C).
let A B C.
assume H.
apply (H (A /\ (B /\ C))).
assume Hab Hc.
apply (Hab (A /\ (B /\ C))).
assume Ha Hb.
apply andI.
- exact Ha.
- apply andI.
  * exact Hb.
  * exact Hc.
Qed.

Theorem and_assoc_rev : forall A B C:prop, A /\ (B /\ C) -> (A /\ B) /\ C.
let A B C.
assume H.
apply (H ((A /\ B) /\ C)).
assume Ha Hbc.
apply (Hbc ((A /\ B) /\ C)).
assume Hb Hc.
apply andI.
- apply andI.
  * exact Ha.
  * exact Hb.
- exact Hc.
Qed.

(** Helper: eliminate a 7-way conjunction A /\ B /\ C /\ D /\ E /\ F /\ G **)
Theorem and7E : forall A B C D E F G:prop,
  A /\ B /\ C /\ D /\ E /\ F /\ G ->
  forall p:prop, (A -> B -> C -> D -> E -> F -> G -> p) -> p.
let A B C D E F G.
assume H.
let p. assume Hp.
apply (H p).
assume H1 Hg.
apply (H1 p).
assume H2 Hf.
apply (H2 p).
assume H3 He.
apply (H3 p).
assume H4 Hd.
apply (H4 p).
assume H5 Hc.
apply (H5 p).
assume Ha Hb.
exact (Hp Ha Hb Hc Hd He Hf Hg).
Qed.

(** Helper: eliminate a 4-way conjunction A /\ B /\ C /\ D **)
Theorem and4E : forall A B C D:prop,
  A /\ B /\ C /\ D ->
  forall p:prop, (A -> B -> C -> D -> p) -> p.
let A B C D.
assume H.
let p. assume Hp.
apply (H p).
assume H1 Hd.
apply (H1 p).
assume H2 Hc.
apply (H2 p).
assume Ha Hb.
exact (Hp Ha Hb Hc Hd).
Qed.

(** Helper: eliminate a 5-way conjunction A /\ B /\ C /\ D /\ E **)
Theorem and5E : forall A B C D E:prop,
  A /\ B /\ C /\ D /\ E ->
  forall p:prop, (A -> B -> C -> D -> E -> p) -> p.
let A B C D E.
assume H.
let p. assume Hp.
apply (H p).
assume H1 He.
apply (H1 p).
assume H2 Hd.
apply (H2 p).
assume H3 Hc.
apply (H3 p).
assume Ha Hb.
exact (Hp Ha Hb Hc Hd He).
Qed.

(** Helper: eliminate a 6-way conjunction A /\ B /\ C /\ D /\ E /\ F **)
Theorem and6E : forall A B C D E F:prop,
  A /\ B /\ C /\ D /\ E /\ F ->
  forall p:prop, (A -> B -> C -> D -> E -> F -> p) -> p.
let A B C D E F.
assume H.
let p. assume Hp.
apply (H p).
assume H1 Hf.
apply (H1 p).
assume H2 He.
apply (H2 p).
assume H3 Hd.
apply (H3 p).
assume H4 Hc.
apply (H4 p).
assume Ha Hb.
exact (Hp Ha Hb Hc Hd He Hf).
Qed.

(** Helper: if a 7-way conjunction ends with a specific disjunctive clause, extract it by one split **)
Theorem conj7_last_disjE : forall i m j n a b:set,
  i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
  a = (i, m) /\ b = (j, n) /\
  (i :e j \/ (i = j /\ m :e n)) ->
  (i :e j \/ (i = j /\ m :e n)).
let i m j n a b.
assume Hcore.
apply Hcore.
assume Hcoords Hlex.
exact Hlex.
Qed.

(** from §14 Example 4: two-row dictionary order space is not discrete **) 
(** LATEX VERSION: Example 4: The dictionary order topology on {1,2}×ℕ is not discrete. **)
Definition two_by_nat : set := setprod 2 omega.
Definition two_by_nat_order_topology : set := order_topology two_by_nat.

(** helper: singleton {(1,0)} is not a basis element in the order topology basis on two_by_nat **)
Theorem two_by_nat_singleton_not_in_basis :
  {(1,0)} /:e order_topology_basis two_by_nat.
set X := two_by_nat.
set U := {(1,0)}.
assume HU: U :e order_topology_basis X.
prove False.

set A := {I :e Power X | exists a :e X, exists b :e X,
            I = {x :e X | order_rel X a x /\ order_rel X x b}}.
set B := {I :e Power X | exists b :e X,
            I = {x :e X | order_rel X x b}}.
set C := {I :e Power X | exists a :e X,
            I = {x :e X | order_rel X a x}}.
set Bold := (A :\/: B :\/: C).
claim HUold: U :e Bold.
{ claim HUin: U :e (Bold :\/: {X}).
  { claim Hdef: order_topology_basis X = (Bold :\/: {X}).
    { reflexivity. }
    rewrite <- Hdef.
    exact HU. }
  apply (binunionE Bold {X} U HUin).
  - assume HUbold: U :e Bold.
    exact HUbold.
  - assume HUX: U :e {X}.
    apply FalseE.
    claim HUeqX: U = X.
    { exact (SingE X U HUX). }
    claim H0omega: 0 :e omega.
    { exact (nat_p_omega 0 nat_0). }
    claim H00X: (0,0) :e X.
    { claim HXeq: X = setprod 2 omega.
      { reflexivity. }
      rewrite HXeq.
      exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 0 In_0_2 H0omega). }
    claim H00U: (0,0) :e U.
    { rewrite HUeqX.
      exact H00X. }
    claim H00Eq10: (0,0) = (1,0).
    { exact (SingE (1,0) (0,0) H00U). }
    claim H0Eq1: 0 = 1.
    { prove 0 = 1.
      rewrite <- (tuple_2_0_eq 0 0) at 1.
      rewrite <- (tuple_2_0_eq 1 0) at 2.
      claim Hproj0: (0,0) 0 = (1,0) 0.
      { rewrite H00Eq10. reflexivity. }
      exact Hproj0. }
    exact (neq_0_1 H0Eq1). }

apply (binunionE' ({I :e Power X | exists a :e X, exists b :e X,
                      I = {x :e X | order_rel X a x /\ order_rel X x b}}
                   :\/:
                   {I :e Power X | exists b :e X,
                      I = {x :e X | order_rel X x b}})
                  {I :e Power X | exists a :e X,
                      I = {x :e X | order_rel X a x}}
                  U
                  False).
- assume HU12: U :e ({I :e Power X | exists a :e X, exists b :e X,
                        I = {x :e X | order_rel X a x /\ order_rel X x b}}
                     :\/:
                     {I :e Power X | exists b :e X,
                        I = {x :e X | order_rel X x b}}).
  apply (binunionE' {I :e Power X | exists a :e X, exists b :e X,
                       I = {x :e X | order_rel X a x /\ order_rel X x b}}
                    {I :e Power X | exists b :e X,
                       I = {x :e X | order_rel X x b}}
                    U
                    False).
		  + assume HU1: U :e {I :e Power X | exists a :e X, exists b :e X,
		                        I = {x :e X | order_rel X a x /\ order_rel X x b}}.
		    claim Hexab: exists a :e X, exists b :e X,
		      U = {x :e X | order_rel X a x /\ order_rel X x b}.
		    { exact (SepE2 (Power X)
		                   (fun I0 : set => exists a :e X, exists b :e X,
		                     I0 = {x :e X | order_rel X a x /\ order_rel X x b})
		                   U
		                   HU1). }
		    apply Hexab.
		    let a. assume HaPair. apply HaPair.
		    assume HaX: a :e X.
		    assume Hexb.
		    apply Hexb.
		    let b. assume HbPair. apply HbPair.
		    assume HbX: b :e X.
		    assume HUeq: U = {x :e X | order_rel X a x /\ order_rel X x b}.

		    claim H10inU: (1,0) :e U.
		    { exact (SingI (1,0)). }
		    claim H10inDef: (1,0) :e {x :e X | order_rel X a x /\ order_rel X x b}.
		    { rewrite <- HUeq.
		      exact H10inU. }
		    claim Hrelconj: order_rel X a (1,0) /\ order_rel X (1,0) b.
		    { exact (SepE2 X (fun x0 : set => order_rel X a x0 /\ order_rel X x0 b) (1,0) H10inDef). }
		    claim HrelL: order_rel X a (1,0).
		    { exact (andEL (order_rel X a (1,0)) (order_rel X (1,0) b) Hrelconj). }
		    claim HrelR: order_rel X (1,0) b.
		    { exact (andER (order_rel X a (1,0)) (order_rel X (1,0) b) Hrelconj). }

		    claim HXeq: X = setprod 2 omega.
		    { reflexivity. }
		    claim HrelL2: order_rel (setprod 2 omega) a (1,0).
		    { prove order_rel (setprod 2 omega) a (1,0).
		      rewrite <- HXeq at 1.
		      exact HrelL. }
		    claim HrelR2: order_rel (setprod 2 omega) (1,0) b.
		    { prove order_rel (setprod 2 omega) (1,0) b.
		      rewrite <- HXeq at 1.
		      exact HrelR. }

		    (** Analyze `a < (1,0)` to get `a = (0,m)` for some m∈ω. **)
		    claim HexL: exists i m j n0:set,
		      i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\
		      a = (i, m) /\ (1,0) = (j, n0) /\ (i :e j \/ (i = j /\ m :e n0)).
		    { exact (order_rel_setprod_2_omega_unfold a (1,0) HrelL2). }
		    apply HexL.
		    let i. assume HiPair. apply HiPair.
		    let m. assume HmPair. apply HmPair.
		    let j. assume HjPair. apply HjPair.
		    let n0. assume Hcore.

		    claim Hcoords: i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\ a = (i, m) /\ (1,0) = (j, n0).
		    { apply Hcore.
		      assume Hcoords0 Hlex0.
		      exact Hcoords0. }
		    claim Hlex: i :e j \/ (i = j /\ m :e n0).
		    { apply Hcore.
		      assume Hcoords0 Hlex0.
		      exact Hlex0. }

		    claim HjnEq: (1,0) = (j, n0).
		    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\ a = (i, m))
		                   ((1,0) = (j, n0))
		                   Hcoords). }
		    claim Hcoords5: i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\ a = (i, m).
		    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega /\ a = (i, m))
		                   ((1,0) = (j, n0))
		                   Hcoords). }

		    claim HaEq2: a = (i, m).
		    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega)
		                   (a = (i, m))
		                   Hcoords5). }
		    claim Hcoords4: i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega.
		    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n0 :e omega)
		                   (a = (i, m))
		                   Hcoords5). }

		    claim Hn0Omega: n0 :e omega.
		    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2)
		                   (n0 :e omega)
		                   Hcoords4). }
		    claim Hcoords3: i :e 2 /\ m :e omega /\ j :e 2.
		    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2)
		                   (n0 :e omega)
		                   Hcoords4). }

		    claim Hj2: j :e 2.
		    { exact (andER (i :e 2 /\ m :e omega)
		                   (j :e 2)
		                   Hcoords3). }
		    claim Hcoords2: i :e 2 /\ m :e omega.
		    { exact (andEL (i :e 2 /\ m :e omega)
		                   (j :e 2)
		                   Hcoords3). }

		    claim Hi2: i :e 2.
		    { exact (andEL (i :e 2) (m :e omega) Hcoords2). }
		    claim HmOmega: m :e omega.
		    { exact (andER (i :e 2) (m :e omega) Hcoords2). }

		    claim HjEq1: j = 1.
		    { prove j = 1.
		      rewrite <- (tuple_2_0_eq j n0) at 1.
		      rewrite <- (tuple_2_0_eq 1 0) at 2.
		      claim Hproj0: (j,n0) 0 = (1,0) 0.
		      { rewrite <- HjnEq. reflexivity. }
		      exact Hproj0. }

		    claim Hn0Eq0: n0 = 0.
		    { prove n0 = 0.
		      rewrite <- (tuple_2_1_eq j n0) at 1.
		      rewrite <- HjnEq at 1.
		      exact (tuple_2_1_eq 1 0). }

		    claim HiEq0: i = 0.
		    { apply (Hlex (i = 0)).
		      - assume Hilj: i :e j.
		        prove i = 0.
		        claim HiIn1: i :e 1.
		        { rewrite <- HjEq1.
		          exact Hilj. }
		        claim HiInSing0: i :e {0}.
		        { rewrite <- eq_1_Sing0.
		          exact HiIn1. }
		        exact (SingE 0 i HiInSing0).
		      - assume Hind: i = j /\ m :e n0.
		        apply FalseE.
		        claim Hmn: m :e n0.
		        { exact (andER (i = j) (m :e n0) Hind). }
		        claim HmIn0: m :e 0.
		        { rewrite <- Hn0Eq0.
		          exact Hmn. }
		        exact (EmptyE m HmIn0). }

		    claim HaEq: a = (0, m).
		    { prove a = (0, m).
		      rewrite HaEq2.
		      rewrite HiEq0.
		      reflexivity. }

		    (** Analyze `(1,0) < b` to get `b = (1,n)` for some n∈ω. **)
		    claim HexR: exists i2 m2 j2 n:set,
		      i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega /\
		      (1,0) = (i2, m2) /\ b = (j2, n) /\ (i2 :e j2 \/ (i2 = j2 /\ m2 :e n)).
		    { exact (order_rel_setprod_2_omega_unfold (1,0) b HrelR2). }
		    apply HexR.
		    let i2. assume Hi2Pair. apply Hi2Pair.
		    let m2. assume Hm2Pair. apply Hm2Pair.
		    let j2. assume Hj2Pair. apply Hj2Pair.
		    let n. assume Hcore2.

		    claim HcoordsR: i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega /\ (1,0) = (i2, m2) /\ b = (j2, n).
		    { apply Hcore2.
		      assume Hcoords0 Hlex0.
		      exact Hcoords0. }
		    claim HlexR: i2 :e j2 \/ (i2 = j2 /\ m2 :e n).
		    { apply Hcore2.
		      assume Hcoords0 Hlex0.
		      exact Hlex0. }

		    claim HbEq2: b = (j2, n).
		    { exact (andER (i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega /\ (1,0) = (i2, m2))
		                   (b = (j2, n))
		                   HcoordsR). }
		    claim HcoordsR5: i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega /\ (1,0) = (i2, m2).
		    { exact (andEL (i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega /\ (1,0) = (i2, m2))
		                   (b = (j2, n))
		                   HcoordsR). }

		    claim H10EqR: (1,0) = (i2, m2).
		    { exact (andER (i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega)
		                   ((1,0) = (i2, m2))
		                   HcoordsR5). }
		    claim HcoordsR4: i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega.
		    { exact (andEL (i2 :e 2 /\ m2 :e omega /\ j2 :e 2 /\ n :e omega)
		                   ((1,0) = (i2, m2))
		                   HcoordsR5). }

		    claim HnOmega: n :e omega.
		    { exact (andER (i2 :e 2 /\ m2 :e omega /\ j2 :e 2)
		                   (n :e omega)
		                   HcoordsR4). }
		    claim HcoordsR3: i2 :e 2 /\ m2 :e omega /\ j2 :e 2.
		    { exact (andEL (i2 :e 2 /\ m2 :e omega /\ j2 :e 2)
		                   (n :e omega)
		                   HcoordsR4). }

		    claim Hj2_2: j2 :e 2.
		    { exact (andER (i2 :e 2 /\ m2 :e omega)
		                   (j2 :e 2)
		                   HcoordsR3). }
		    claim HcoordsR2: i2 :e 2 /\ m2 :e omega.
		    { exact (andEL (i2 :e 2 /\ m2 :e omega)
		                   (j2 :e 2)
		                   HcoordsR3). }

		    claim Hi2Eq1: i2 = 1.
		    { prove i2 = 1.
		      rewrite <- (tuple_2_0_eq i2 m2) at 1.
		      rewrite <- (tuple_2_0_eq 1 0) at 2.
		      claim Hproj0: (i2,m2) 0 = (1,0) 0.
		      { rewrite <- H10EqR. reflexivity. }
		      exact Hproj0. }

		    claim Hj2Eq1: j2 = 1.
		    { apply (HlexR (j2 = 1)).
		      - assume Hilj: i2 :e j2.
		        apply FalseE.
		        claim H1j: 1 :e j2.
		        { rewrite <- Hi2Eq1.
		          exact Hilj. }
		        claim Hsub2: 2 c= {0,1}.
		        { exact Subq_2_UPair01. }
		        claim Hj01: j2 :e {0,1}.
		        { exact (Hsub2 j2 Hj2_2). }
		        apply (UPairE j2 0 1 Hj01 False).
			        + assume Hj0: j2 = 0.
			          claim H1in0: 1 :e 0.
			          { rewrite <- Hj0 at 2.
			            exact H1j. }
			          exact (EmptyE 1 H1in0).
			        + assume Hj1: j2 = 1.
			          claim H1in1: 1 :e 1.
			          { rewrite <- Hj1 at 2.
			            exact H1j. }
			          exact (In_irref 1 H1in1).
		      - assume Hind: i2 = j2 /\ m2 :e n.
		        prove j2 = 1.
		        claim Hij: i2 = j2.
		        { exact (andEL (i2 = j2) (m2 :e n) Hind). }
		        rewrite <- Hij.
		        exact Hi2Eq1. }

			    claim HbEq: b = (1, n).
			    { prove b = (1, n).
			      rewrite HbEq2.
			      rewrite Hj2Eq1.
			      reflexivity. }

		    (** Define a second point in the interval and derive contradiction. **)
		    claim HsuccOmega: ordsucc m :e omega.
		    { exact (omega_ordsucc m HmOmega). }
			    claim H0sX: (0, ordsucc m) :e X.
			    { rewrite HXeq.
			      exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 (ordsucc m) In_0_2 HsuccOmega). }

		    claim H0sL: order_rel X a (0, ordsucc m).
		    { prove order_rel X a (0, ordsucc m).
		      rewrite HXeq at 1.
		      rewrite HaEq.
		      exact (order_rel_setprod_2_omega_0k_0succk m HmOmega). }
		    claim H0sR: order_rel X (0, ordsucc m) b.
		    { prove order_rel X (0, ordsucc m) b.
		      rewrite HXeq at 1.
		      rewrite HbEq.
		      exact (order_rel_setprod_2_omega_0k_1n (ordsucc m) n HsuccOmega HnOmega). }

		    claim H0score: order_rel X a (0, ordsucc m) /\ order_rel X (0, ordsucc m) b.
		    { apply andI.
		      - exact H0sL.
		      - exact H0sR. }
		    claim H0sinDef: (0, ordsucc m) :e {x :e X | order_rel X a x /\ order_rel X x b}.
		    { exact (SepI X (fun x0 : set => order_rel X a x0 /\ order_rel X x0 b) (0, ordsucc m) H0sX H0score). }
		    claim H0sinU: (0, ordsucc m) :e U.
		    { rewrite HUeq.
		      exact H0sinDef. }

		    claim H0sEq10: (0, ordsucc m) = (1,0).
		    { exact (SingE (1,0) (0, ordsucc m) H0sinU). }
		    claim H0Eq1: 0 = 1.
		    { prove 0 = 1.
		      rewrite <- (tuple_2_0_eq 0 (ordsucc m)) at 1.
		      rewrite <- (tuple_2_0_eq 1 0) at 2.
		      claim Hproj0: (0, ordsucc m) 0 = (1,0) 0.
		      { rewrite H0sEq10. reflexivity. }
		      exact Hproj0. }
		    exact (neq_0_1 H0Eq1).
		  + assume HU2: U :e {I :e Power X | exists b :e X,
		                        I = {x :e X | order_rel X x b}}.
		    claim Hexb: exists b :e X, U = {x :e X | order_rel X x b}.
		    { exact (SepE2 (Power X)
		                   (fun I0 : set => exists b :e X, I0 = {x :e X | order_rel X x b})
		                   U
		                   HU2). }
		    apply Hexb.
		    let b. assume HbPair. apply HbPair.
		    assume HbX: b :e X.
		    assume HUeq: U = {x :e X | order_rel X x b}.

		    claim H10inU: (1,0) :e U.
		    { exact (SingI (1,0)). }
		    claim H10inDef: (1,0) :e {x :e X | order_rel X x b}.
		    { rewrite <- HUeq.
		      exact H10inU. }
		    claim Hrel: order_rel X (1,0) b.
		    { exact (SepE2 X (fun x0 : set => order_rel X x0 b) (1,0) H10inDef). }

		    claim HXeq: X = setprod 2 omega.
		    { reflexivity. }
		    claim Hrel2: order_rel (setprod 2 omega) (1,0) b.
		    { prove order_rel (setprod 2 omega) (1,0) b.
		      rewrite <- HXeq at 1.
		      exact Hrel. }

		    claim Hex: exists i m j n:set,
		      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
		      (1,0) = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
		    { exact (order_rel_setprod_2_omega_unfold (1,0) b Hrel2). }
		    apply Hex.
		    let i. assume HiPair. apply HiPair.
		    let m. assume HmPair. apply HmPair.
		    let j. assume HjPair. apply HjPair.
		    let n. assume Hcore.

			    claim Hcoords: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ (1,0) = (i, m) /\ b = (j, n).
			    { apply Hcore.
			      assume Hcoords0 Hlex0.
			      exact Hcoords0. }
			    claim Hlex: i :e j \/ (i = j /\ m :e n).
			    { apply Hcore.
			      assume Hcoords0 Hlex0.
			      exact Hlex0. }
			
			    claim HbEq2: b = (j, n).
			    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ (1,0) = (i, m))
			                   (b = (j, n))
			                   Hcoords). }
			    claim Hcoords5: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ (1,0) = (i, m).
			    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ (1,0) = (i, m))
			                   (b = (j, n))
			                   Hcoords). }
			
			    claim H10Eq2: (1,0) = (i, m).
			    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega)
			                   ((1,0) = (i, m))
			                   Hcoords5). }
			    claim Hcoords4: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega.
			    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega)
			                   ((1,0) = (i, m))
			                   Hcoords5). }

		    claim HnOmega: n :e omega.
		    { exact (andER (i :e 2 /\ m :e omega /\ j :e 2)
		                   (n :e omega)
		                   Hcoords4). }
		    claim Hcoords3: i :e 2 /\ m :e omega /\ j :e 2.
		    { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2)
		                   (n :e omega)
		                   Hcoords4). }

		    claim Hj2: j :e 2.
		    { exact (andER (i :e 2 /\ m :e omega)
		                   (j :e 2)
		                   Hcoords3). }
		    claim Hcoords2: i :e 2 /\ m :e omega.
		    { exact (andEL (i :e 2 /\ m :e omega)
		                   (j :e 2)
		                   Hcoords3). }

		    claim Hi2: i :e 2.
		    { exact (andEL (i :e 2) (m :e omega) Hcoords2). }
		    claim HmOmega: m :e omega.
		    { exact (andER (i :e 2) (m :e omega) Hcoords2). }

			    claim HiEq: i = 1.
			    { prove i = 1.
			      rewrite <- (tuple_2_0_eq i m) at 1.
			      rewrite <- (tuple_2_0_eq 1 0) at 2.
			      claim Hproj0: (i,m) 0 = (1,0) 0.
			      { rewrite <- H10Eq2. reflexivity. }
			      exact Hproj0. }
	
			    claim Hj1: j = 1.
			    { apply (Hlex (j = 1)).
		      - assume Hilj: i :e j.
		        apply FalseE.
		        claim H1j: 1 :e j.
		        { rewrite <- HiEq at 1.
		          exact Hilj. }
		        claim Hsub2: 2 c= {0,1}.
		        { exact Subq_2_UPair01. }
		        claim Hj01: j :e {0,1}.
		        { exact (Hsub2 j Hj2). }
		        apply (UPairE j 0 1 Hj01 False).
		        + assume Hj0: j = 0.
		          claim H1in0: 1 :e 0.
		          { rewrite <- Hj0 at 2.
		            exact H1j. }
		          exact (EmptyE 1 H1in0).
		        + assume Hj1': j = 1.
		          claim H1in1: 1 :e 1.
		          { rewrite <- Hj1' at 2.
		            exact H1j. }
		          exact (In_irref 1 H1in1).
		      - assume Hind: i = j /\ m :e n.
		        prove j = 1.
		        claim Hij: i = j.
		        { exact (andEL (i = j) (m :e n) Hind). }
	        rewrite <- Hij at 1.
	        exact HiEq. }

		    claim HbEq: b = (1, n).
		    { prove b = (1, n).
		      rewrite <- Hj1 at 2.
		      exact HbEq2. }

		    claim H0omega: 0 :e omega.
		    { exact (nat_p_omega 0 nat_0). }
    claim H00X: (0,0) :e X.
    { rewrite HXeq.
      exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 0 In_0_2 H0omega). }
		    claim H00rel: order_rel X (0,0) b.
		    { prove order_rel X (0,0) b.
		      rewrite HXeq at 1.
		      rewrite HbEq.
		      exact (order_rel_setprod_2_omega_00_1n n HnOmega). }

		    claim H00inDef: (0,0) :e {x :e X | order_rel X x b}.
		    { exact (SepI X (fun x0 : set => order_rel X x0 b) (0,0) H00X H00rel). }
		    claim H00inU: (0,0) :e U.
		    { rewrite HUeq.
		      exact H00inDef. }

		    claim H00Eq10: (0,0) = (1,0).
		    { exact (SingE (1,0) (0,0) H00inU). }
		    claim H0Eq1: 0 = 1.
		    { prove 0 = 1.
		      rewrite <- (tuple_2_0_eq 0 0) at 1.
		      rewrite <- (tuple_2_0_eq 1 0) at 2.
		      claim Hproj0: (0,0) 0 = (1,0) 0.
		      { rewrite H00Eq10. reflexivity. }
		      exact Hproj0. }
		    exact (neq_0_1 H0Eq1).
	  + exact HU12.
	- assume HU3: U :e {I :e Power X | exists a :e X,
	                      I = {x :e X | order_rel X a x}}.
	  claim Hexa: exists a :e X, U = {x :e X | order_rel X a x}.
	  { exact (SepE2 (Power X)
	                 (fun I0 : set => exists a :e X, I0 = {x :e X | order_rel X a x})
	                 U
	                 HU3). }
	  apply Hexa.
	  let a. assume HaPair. apply HaPair.
	  assume HaX: a :e X.
	  assume HUeq: U = {x :e X | order_rel X a x}.

	  claim H10inU: (1,0) :e U.
	  { exact (SingI (1,0)). }
	  claim H10inDef: (1,0) :e {x :e X | order_rel X a x}.
	  { rewrite <- HUeq.
	    exact H10inU. }
	  claim Hrel: order_rel X a (1,0).
	  { exact (SepE2 X (fun x0 : set => order_rel X a x0) (1,0) H10inDef). }

	  claim HXeq: X = setprod 2 omega.
	  { reflexivity. }
	  claim Hrel2: order_rel (setprod 2 omega) a (1,0).
	  { prove order_rel (setprod 2 omega) a (1,0).
	    rewrite <- HXeq at 1.
	    exact Hrel. }

	  claim Hex: exists i m j n:set,
	    i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	    a = (i, m) /\ (1,0) = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
	  { exact (order_rel_setprod_2_omega_unfold a (1,0) Hrel2). }
	  apply Hex.
	  let i. assume HiPair. apply HiPair.
	  let m. assume HmPair. apply HmPair.
	  let j. assume HjPair. apply HjPair.
	  let n. assume Hcore.

	  claim Hcoords: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m) /\ (1,0) = (j, n).
	  { apply Hcore.
	    assume Hcoords0 Hlex0.
	    exact Hcoords0. }
	  claim Hlex: i :e j \/ (i = j /\ m :e n).
	  { apply Hcore.
	    assume Hcoords0 Hlex0.
	    exact Hlex0. }

	  claim HjnEq: (1,0) = (j, n).
	  { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m))
	                 ((1,0) = (j, n))
	                 Hcoords). }
	  claim Hcoords5: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m).
	  { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\ a = (i, m))
	                 ((1,0) = (j, n))
	                 Hcoords). }

	  claim HaEq2: a = (i, m).
	  { exact (andER (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega)
	                 (a = (i, m))
	                 Hcoords5). }
	  claim Hcoords4: i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega.
	  { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega)
	                 (a = (i, m))
	                 Hcoords5). }

	  claim HnOmega: n :e omega.
	  { exact (andER (i :e 2 /\ m :e omega /\ j :e 2)
	                 (n :e omega)
	                 Hcoords4). }
	  claim Hcoords3: i :e 2 /\ m :e omega /\ j :e 2.
	  { exact (andEL (i :e 2 /\ m :e omega /\ j :e 2)
	                 (n :e omega)
	                 Hcoords4). }

	  claim Hj2: j :e 2.
	  { exact (andER (i :e 2 /\ m :e omega)
	                 (j :e 2)
	                 Hcoords3). }
	  claim Hcoords2: i :e 2 /\ m :e omega.
	  { exact (andEL (i :e 2 /\ m :e omega)
	                 (j :e 2)
	                 Hcoords3). }

	  claim Hi2: i :e 2.
	  { exact (andEL (i :e 2) (m :e omega) Hcoords2). }
	  claim HmOmega: m :e omega.
	  { exact (andER (i :e 2) (m :e omega) Hcoords2). }

	  claim HjEq1: j = 1.
	  { prove j = 1.
	    rewrite <- (tuple_2_0_eq j n) at 1.
	    rewrite <- (tuple_2_0_eq 1 0) at 2.
	    claim Hproj0: (j,n) 0 = (1,0) 0.
	    { rewrite <- HjnEq. reflexivity. }
	    exact Hproj0. }

		  claim HnEq0: n = 0.
		  { prove n = 0.
		    rewrite <- (tuple_2_1_eq j n) at 1.
		    rewrite <- HjnEq at 1.
		    exact (tuple_2_1_eq 1 0). }

	  claim HiEq0: i = 0.
	  { apply (Hlex (i = 0)).
	    - assume Hilj: i :e j.
		      prove i = 0.
		      claim HiIn1: i :e 1.
		      { rewrite <- HjEq1.
		        exact Hilj. }
		      claim HiInSing0: i :e {0}.
		      { rewrite <- eq_1_Sing0.
		        exact HiIn1. }
		      exact (SingE 0 i HiInSing0).
	    - assume Hind: i = j /\ m :e n.
	      apply FalseE.
	      claim Hmn: m :e n.
	      { exact (andER (i = j) (m :e n) Hind). }
		      claim HmIn0: m :e 0.
		      { rewrite <- HnEq0.
		        exact Hmn. }
	      exact (EmptyE m HmIn0). }

		  claim HaEq: a = (0, m).
		  { prove a = (0, m).
		    rewrite HaEq2.
		    rewrite HiEq0.
		    reflexivity. }

		  claim HsuccOmega: ordsucc m :e omega.
		  { exact (omega_ordsucc m HmOmega). }
			  claim H0sX: (0, ordsucc m) :e X.
			  { rewrite HXeq.
			    exact (tuple_2_setprod_by_pair_Sigma 2 omega 0 (ordsucc m) In_0_2 HsuccOmega). }

		  claim H0srel: order_rel X a (0, ordsucc m).
		  { prove order_rel X a (0, ordsucc m).
		    rewrite HXeq at 1.
		    rewrite HaEq.
		    exact (order_rel_setprod_2_omega_0k_0succk m HmOmega). }

		  claim H0sinDef: (0, ordsucc m) :e {x :e X | order_rel X a x}.
		  { exact (SepI X (fun x0 : set => order_rel X a x0) (0, ordsucc m) H0sX H0srel). }
		  claim H0sinU: (0, ordsucc m) :e U.
		  { rewrite HUeq.
		    exact H0sinDef. }

		  claim H0sEq10: (0, ordsucc m) = (1,0).
		  { exact (SingE (1,0) (0, ordsucc m) H0sinU). }

			  claim H0Eq1: 0 = 1.
			  { prove 0 = 1.
			    rewrite <- (tuple_2_0_eq 0 (ordsucc m)) at 1.
			    rewrite <- (tuple_2_0_eq 1 0) at 2.
			    claim Hproj0: (0, ordsucc m) 0 = (1,0) 0.
			    { rewrite H0sEq10. reflexivity. }
			    exact Hproj0. }
			  exact (neq_0_1 H0Eq1).
		- exact HUold.
Qed.

(** Helper: singleton {(1,0)} is not open in two_by_nat order topology **)
Theorem two_by_nat_singleton_not_open :
  ~ ({(1,0)} :e two_by_nat_order_topology).
assume Hopen: {(1,0)} :e two_by_nat_order_topology.
prove False.
set X := two_by_nat.
set B := order_topology_basis X.
set U := {(1,0)}.

(** Unpack generated_topology membership: x in U implies existence of basis neighborhood inside U **)
claim Hneigh: forall x :e U, exists b :e B, x :e b /\ b c= U.
{ exact (SepE2 (Power X)
               (fun U0 : set => forall x :e U0, exists b :e B, x :e b /\ b c= U0)
               U
               Hopen). }

claim HxU: (1,0) :e U.
{ exact (SingI (1,0)). }

claim Hexb: exists b :e B, (1,0) :e b /\ b c= U.
{ exact (Hneigh (1,0) HxU). }
apply Hexb.
let b. assume Hbpair. apply Hbpair.
assume HbB: b :e B.
assume Hbcore: (1,0) :e b /\ b c= U.
claim HbcU: b c= U.
{ exact (andER ((1,0) :e b) (b c= U) Hbcore). }
claim HUcb: U c= b.
{ let y. assume Hy: y :e U.
  prove y :e b.
  claim HyEq: y = (1,0).
  { exact (SingE (1,0) y Hy). }
  rewrite HyEq.
  exact (andEL ((1,0) :e b) (b c= U) Hbcore). }
claim HbeqU: b = U.
{ apply set_ext.
  - let y. assume Hy: y :e b.
    exact (HbcU y Hy).
  - let y. assume Hy: y :e U.
    exact (HUcb y Hy). }

claim HUnotB: U /:e B.
{ exact two_by_nat_singleton_not_in_basis. }

claim HUinB: U :e B.
{ rewrite <- HbeqU. exact HbB. }
exact (HUnotB HUinB).
Qed.

(** LATEX VERSION: The two-by-ℕ dictionary order space fails to be discrete. **)
Theorem two_by_nat_not_discrete :
  ~ (two_by_nat_order_topology = discrete_topology two_by_nat).
prove ~ (two_by_nat_order_topology = discrete_topology two_by_nat).
(** Proof by contradiction: assume they're equal **)
assume Heq: two_by_nat_order_topology = discrete_topology two_by_nat.
(** In discrete topology, all singletons are open **)
set singleton_1_0 := {(1,0)}.
claim Hsingleton_in_discrete: singleton_1_0 :e discrete_topology two_by_nat.
{ (** discrete_topology two_by_nat = Power two_by_nat, so any subset is open **)
  (** Need to show singleton_1_0 :e Power two_by_nat **)
  (** This requires singleton_1_0 c= two_by_nat **)
  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Helem: (1,0) :e two_by_nat.
  { exact (tuple_2_setprod_by_pair_Sigma 2 omega 1 0 In_1_2 H0omega). }
  claim Hsub: singleton_1_0 c= two_by_nat.
  { let y. assume Hy: y :e singleton_1_0.
    prove y :e two_by_nat.
    claim HyEq: y = (1,0).
    { exact (SingE (1,0) y Hy). }
    rewrite HyEq.
    exact Helem. }

  exact (PowerI two_by_nat singleton_1_0 Hsub).
}
claim Hsingleton_in_order: singleton_1_0 :e two_by_nat_order_topology.
{ rewrite Heq. exact Hsingleton_in_discrete. }
(** But this contradicts the axiom **)
exact (two_by_nat_singleton_not_open Hsingleton_in_order).
Qed.

(** from §15 Definition: product topology on X×Y **) 
(** LATEX VERSION: The product topology on X×Y is generated by the basis of rectangles U×V with U open in X and V open in Y. **)
Definition rectangle_set : set -> set -> set := fun U V => setprod U V.

(** Helper: definitional expansion for rectangle_set **)
Theorem rectangle_set_def : forall U V:set, rectangle_set U V = setprod U V.
let U V.
reflexivity.
Qed.

(** Helper: pairing belongs to rectangle_set **)
Theorem tuple_2_rectangle_set : forall U V:set, forall x y:set,
  x :e U -> y :e V -> (x,y) :e rectangle_set U V.
let U V x y.
assume Hx: x :e U.
assume Hy: y :e V.
prove (x,y) :e rectangle_set U V.
rewrite rectangle_set_def.
rewrite <- (tuple_pair x y) at 1.
exact (pair_Sigma U (fun _ : set => V) x Hx y Hy).
Qed.

(** Helper: surjective pairing for setprod **)
Theorem setprod_eta : forall X Y p:set,
  p :e setprod X Y -> p = (p 0, p 1).
let X Y p.
assume Hp: p :e setprod X Y.
prove p = (p 0, p 1).
apply (Sigma_E X (fun _ : set => Y) p Hp).
let x.
assume Hx_pair.
apply Hx_pair.
assume HxX Hexy.
apply Hexy.
let y.
assume Hy_pair.
apply Hy_pair.
assume HyY Hpeq.
claim HeqT: p = (x,y).
{ prove p = (x,y).
  rewrite <- (tuple_pair x y).
  exact Hpeq. }
claim Hp0: p 0 = x.
{ rewrite HeqT. exact (tuple_2_0_eq x y). }
claim Hp1: p 1 = y.
{ rewrite HeqT. exact (tuple_2_1_eq x y). }
rewrite Hp0.
rewrite Hp1.
exact HeqT.
Qed.

(** Helper: cartesian products preserve subset relation **)
Theorem setprod_Subq : forall U V X Y:set,
  U c= X -> V c= Y -> setprod U V c= setprod X Y.
let U V X Y.
assume HU: U c= X.
assume HV: V c= Y.
prove setprod U V c= setprod X Y.
let p.
assume Hp: p :e setprod U V.
prove p :e setprod X Y.
claim Hp0: p 0 :e U.
{ exact (ap0_Sigma U (fun u => V) p Hp). }
claim Hp1: p 1 :e V.
{ exact (ap1_Sigma U (fun u => V) p Hp). }
claim Hp0X: p 0 :e X.
{ exact (HU (p 0) Hp0). }
claim Hp1Y: p 1 :e Y.
{ exact (HV (p 1) Hp1). }
claim Heta: p = (p 0, p 1).
{ exact (setprod_eta U V p Hp). }
rewrite Heta.
prove (p 0, p 1) :e setprod X Y.
exact (tuple_2_setprod_by_pair_Sigma X Y (p 0) (p 1) Hp0X Hp1Y).
Qed.

(** Helper: elements of cartesian products have coordinates **)
Theorem setprod_elem_decompose : forall X Y p:set,
  p :e setprod X Y ->
  exists x :e X, exists y :e Y, p :e setprod {x} {y}.
let X Y p.
assume Hp: p :e setprod X Y.
claim Hp0X: p 0 :e X.
{ exact (ap0_Sigma X (fun _ : set => Y) p Hp). }
claim Hp1Y: p 1 :e Y.
{ exact (ap1_Sigma X (fun _ : set => Y) p Hp). }
witness (p 0).
apply andI.
- exact Hp0X.
- witness (p 1).
  apply andI.
  * exact Hp1Y.
  * claim Heta: p = (p 0, p 1).
    { exact (setprod_eta X Y p Hp). }
    rewrite Heta at 1.
    exact (tuple_2_setprod_by_pair_Sigma {p 0} {p 1} (p 0) (p 1) (SingI (p 0)) (SingI (p 1))).
Qed.

(** Helper: singleton subset property **)
Theorem singleton_subset : forall x U:set, x :e U -> {x} c= U.
let x U. assume HxU.
prove {x} c= U.
let y. assume Hy: y :e {x}.
prove y :e U.
claim HyEq: y = x.
{ exact (SingE x y Hy). }
rewrite HyEq.
exact HxU.
Qed.

(** Helper: singleton element equality **)
Theorem singleton_elem : forall x y:set, x :e {y} -> x = y.
let x y. assume H.
exact (SingE y x H).
Qed.

(** Helper: coordinates of product elements **)
Theorem setprod_coords_in : forall x y U V p:set,
  p :e setprod {x} {y} -> p :e setprod U V -> x :e U /\ y :e V.
let x y U V p.
assume Hpxy: p :e setprod {x} {y}.
assume HpUV: p :e setprod U V.
prove x :e U /\ y :e V.
claim Hp0x: p 0 :e {x}.
{ exact (ap0_Sigma {x} (fun u => {y}) p Hpxy). }
claim Hp1y: p 1 :e {y}.
{ exact (ap1_Sigma {x} (fun u => {y}) p Hpxy). }
claim Hp0_eq_x: p 0 = x.
{ exact (singleton_elem (p 0) x Hp0x). }
claim Hp1_eq_y: p 1 = y.
{ exact (singleton_elem (p 1) y Hp1y). }
claim Hp0U: p 0 :e U.
{ exact (ap0_Sigma U (fun u => V) p HpUV). }
claim Hp1V: p 1 :e V.
{ exact (ap1_Sigma U (fun u => V) p HpUV). }
apply andI.
- prove x :e U.
  rewrite <- Hp0_eq_x.
  exact Hp0U.
- prove y :e V.
  rewrite <- Hp1_eq_y.
  exact Hp1V.
Qed.

(** Helper: intersection of cartesian products **)
Theorem setprod_intersection : forall U1 V1 U2 V2:set,
  setprod U1 V1 :/\: setprod U2 V2 = setprod (U1 :/\: U2) (V1 :/\: V2).
let U1 V1 U2 V2.
prove setprod U1 V1 :/\: setprod U2 V2 = setprod (U1 :/\: U2) (V1 :/\: V2).
apply set_ext.
- let p. assume Hp: p :e setprod U1 V1 :/\: setprod U2 V2.
  prove p :e setprod (U1 :/\: U2) (V1 :/\: V2).
  claim HpU1V1: p :e setprod U1 V1.
  { exact (binintersectE1 (setprod U1 V1) (setprod U2 V2) p Hp). }
  claim HpU2V2: p :e setprod U2 V2.
  { exact (binintersectE2 (setprod U1 V1) (setprod U2 V2) p Hp). }
  claim Hp0U1: p 0 :e U1.
  { exact (ap0_Sigma U1 (fun u => V1) p HpU1V1). }
  claim Hp1V1: p 1 :e V1.
  { exact (ap1_Sigma U1 (fun u => V1) p HpU1V1). }
  claim Hp0U2: p 0 :e U2.
  { exact (ap0_Sigma U2 (fun u => V2) p HpU2V2). }
  claim Hp1V2: p 1 :e V2.
  { exact (ap1_Sigma U2 (fun u => V2) p HpU2V2). }
  claim Hp0: p 0 :e U1 :/\: U2.
  { exact (binintersectI U1 U2 (p 0) Hp0U1 Hp0U2). }
  claim Hp1: p 1 :e V1 :/\: V2.
  { exact (binintersectI V1 V2 (p 1) Hp1V1 Hp1V2). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta U1 V1 p HpU1V1). }
  rewrite Heta.
  exact (tuple_2_setprod_by_pair_Sigma (U1 :/\: U2) (V1 :/\: V2) (p 0) (p 1) Hp0 Hp1).
- let p. assume Hp: p :e setprod (U1 :/\: U2) (V1 :/\: V2).
  prove p :e setprod U1 V1 :/\: setprod U2 V2.
  claim Hp0: p 0 :e U1 :/\: U2.
  { exact (ap0_Sigma (U1 :/\: U2) (fun u => V1 :/\: V2) p Hp). }
  claim Hp1: p 1 :e V1 :/\: V2.
  { exact (ap1_Sigma (U1 :/\: U2) (fun u => V1 :/\: V2) p Hp). }
  claim Hp0U1: p 0 :e U1.
  { exact (binintersectE1 U1 U2 (p 0) Hp0). }
  claim Hp0U2: p 0 :e U2.
  { exact (binintersectE2 U1 U2 (p 0) Hp0). }
  claim Hp1V1: p 1 :e V1.
  { exact (binintersectE1 V1 V2 (p 1) Hp1). }
  claim Hp1V2: p 1 :e V2.
  { exact (binintersectE2 V1 V2 (p 1) Hp1). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta (U1 :/\: U2) (V1 :/\: V2) p Hp). }
  rewrite Heta.
  apply binintersectI.
  + exact (tuple_2_setprod_by_pair_Sigma U1 V1 (p 0) (p 1) Hp0U1 Hp1V1).
  + exact (tuple_2_setprod_by_pair_Sigma U2 V2 (p 0) (p 1) Hp0U2 Hp1V2).
Qed.

(** from §15 Definition: product topology on X×Y (basis rectangles) **)
(** LATEX VERSION: The product topology on X×Y has as a basis all sets U×V where U is open in X and V is open in Y. **)
(** NOTE: Despite the name, `product_subbasis` here is a rectangle basis family indexed by opens in X and Y. **)
Definition product_subbasis : set -> set -> set -> set -> set :=
  fun X Tx Y Ty =>
    \/_ U :e Tx, {rectangle_set U V|V :e Ty}.

(** from §15 Definition: product topology generated from rectangles **)
(** LATEX VERSION: The product topology is the topology generated by the rectangle basis. **)
Definition product_topology : set -> set -> set -> set -> set :=
  fun X Tx Y Ty => generated_topology (setprod X Y) (product_subbasis X Tx Y Ty).

(** Helper: product subbasis satisfies basis axioms **)
Theorem product_subbasis_is_basis : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
prove product_subbasis X Tx Y Ty c= Power (setprod X Y)
  /\ (forall p :e setprod X Y, exists b :e product_subbasis X Tx Y Ty, p :e b)
  /\ (forall b1 :e product_subbasis X Tx Y Ty,
        forall b2 :e product_subbasis X Tx Y Ty,
          forall p:set, p :e b1 -> p :e b2 ->
            exists b3 :e product_subbasis X Tx Y Ty, p :e b3 /\ b3 c= b1 :/\: b2).
apply andI.
- apply andI.
  + (** subset axiom: every rectangle is a subset of X×Y **)
    let b. assume Hb: b :e product_subbasis X Tx Y Ty.
    prove b :e Power (setprod X Y).
    claim HTxSub: Tx c= Power X.
    { exact (topology_subset_axiom X Tx HTx). }
    claim HTySub: Ty c= Power Y.
    { exact (topology_subset_axiom Y Ty HTy). }
    claim HexU: exists U :e Tx, b :e {rectangle_set U V|V :e Ty}.
    { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b Hb). }
    apply HexU.
    let U. assume HUconj: U :e Tx /\ b :e {rectangle_set U V|V :e Ty}.
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim HbRepl: b :e {rectangle_set U V|V :e Ty}.
    { exact (andER (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim HexV: exists V :e Ty, b = rectangle_set U V.
    { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b HbRepl). }
    apply HexV.
    let V. assume HVconj: V :e Ty /\ b = rectangle_set U V.
    claim HV: V :e Ty.
    { exact (andEL (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim Hbeq: b = rectangle_set U V.
    { exact (andER (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim HUpow: U :e Power X.
    { exact (HTxSub U HU). }
    claim HVpow: V :e Power Y.
    { exact (HTySub V HV). }
    claim HUsubX: U c= X.
    { exact (PowerE X U HUpow). }
    claim HVsubY: V c= Y.
    { exact (PowerE Y V HVpow). }
    claim HrectSub: rectangle_set U V c= setprod X Y.
    { exact (setprod_Subq U V X Y HUsubX HVsubY). }
    rewrite Hbeq.
    exact (PowerI (setprod X Y) (rectangle_set U V) HrectSub).
  + (** cover axiom: every p in X×Y lies in some rectangle in the subbasis **)
    let p. assume Hp: p :e setprod X Y.
    witness (rectangle_set X Y).
    apply andI.
    * prove rectangle_set X Y :e product_subbasis X Tx Y Ty.
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HYTy: Y :e Ty.
      { exact (topology_has_X Y Ty HTy). }
      claim HRfam: rectangle_set X Y :e {rectangle_set X V|V :e Ty}.
      { exact (ReplI Ty (fun V0:set => rectangle_set X V0) Y HYTy). }
      exact (famunionI Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) X (rectangle_set X Y) HXTx HRfam).
    * (** p is in X×Y **)
      exact Hp.
- (** refinement axiom: intersection of two rectangles refines to a rectangle **)
  let b1. assume Hb1: b1 :e product_subbasis X Tx Y Ty.
  let b2. assume Hb2: b2 :e product_subbasis X Tx Y Ty.
  let p. assume Hp1: p :e b1.
  assume Hp2: p :e b2.
  claim HexU1: exists U1 :e Tx, b1 :e {rectangle_set U1 V|V :e Ty}.
  { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b1 Hb1). }
  apply HexU1.
  let U1. assume HU1conj: U1 :e Tx /\ b1 :e {rectangle_set U1 V|V :e Ty}.
  claim HU1: U1 :e Tx.
  { exact (andEL (U1 :e Tx) (b1 :e {rectangle_set U1 V|V :e Ty}) HU1conj). }
  claim Hb1Repl: b1 :e {rectangle_set U1 V|V :e Ty}.
  { exact (andER (U1 :e Tx) (b1 :e {rectangle_set U1 V|V :e Ty}) HU1conj). }
  claim HexV1: exists V1 :e Ty, b1 = rectangle_set U1 V1.
  { exact (ReplE Ty (fun V0:set => rectangle_set U1 V0) b1 Hb1Repl). }
  apply HexV1.
  let V1. assume HV1conj: V1 :e Ty /\ b1 = rectangle_set U1 V1.
  claim HV1: V1 :e Ty.
  { exact (andEL (V1 :e Ty) (b1 = rectangle_set U1 V1) HV1conj). }
  claim Hb1eq: b1 = rectangle_set U1 V1.
  { exact (andER (V1 :e Ty) (b1 = rectangle_set U1 V1) HV1conj). }

  claim HexU2: exists U2 :e Tx, b2 :e {rectangle_set U2 V|V :e Ty}.
  { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b2 Hb2). }
  apply HexU2.
  let U2. assume HU2conj: U2 :e Tx /\ b2 :e {rectangle_set U2 V|V :e Ty}.
  claim HU2: U2 :e Tx.
  { exact (andEL (U2 :e Tx) (b2 :e {rectangle_set U2 V|V :e Ty}) HU2conj). }
  claim Hb2Repl: b2 :e {rectangle_set U2 V|V :e Ty}.
  { exact (andER (U2 :e Tx) (b2 :e {rectangle_set U2 V|V :e Ty}) HU2conj). }
  claim HexV2: exists V2 :e Ty, b2 = rectangle_set U2 V2.
  { exact (ReplE Ty (fun V0:set => rectangle_set U2 V0) b2 Hb2Repl). }
  apply HexV2.
  let V2. assume HV2conj: V2 :e Ty /\ b2 = rectangle_set U2 V2.
  claim HV2: V2 :e Ty.
  { exact (andEL (V2 :e Ty) (b2 = rectangle_set U2 V2) HV2conj). }
  claim Hb2eq: b2 = rectangle_set U2 V2.
  { exact (andER (V2 :e Ty) (b2 = rectangle_set U2 V2) HV2conj). }

  set b3 := rectangle_set (U1 :/\: U2) (V1 :/\: V2).
  witness b3.
  apply andI.
  + (** b3 in the product subbasis **)
    claim HU12: (U1 :/\: U2) :e Tx.
    { exact (topology_binintersect_closed X Tx U1 U2 HTx HU1 HU2). }
    claim HV12: (V1 :/\: V2) :e Ty.
    { exact (topology_binintersect_closed Y Ty V1 V2 HTy HV1 HV2). }
    claim Hb3fam: rectangle_set (U1 :/\: U2) (V1 :/\: V2) :e {rectangle_set (U1 :/\: U2) V|V :e Ty}.
    { exact (ReplI Ty (fun V0:set => rectangle_set (U1 :/\: U2) V0) (V1 :/\: V2) HV12). }
    exact (famunionI Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) (U1 :/\: U2) b3 HU12 Hb3fam).
  + (** p in b3 and b3 subset of b1∩b2 **)
    apply andI.
    * (** membership **)
      claim HpU1V1: p :e rectangle_set U1 V1.
      { rewrite <- Hb1eq.
        exact Hp1. }
      claim HpU2V2: p :e rectangle_set U2 V2.
      { rewrite <- Hb2eq.
        exact Hp2. }
      claim HpInt: p :e (rectangle_set U1 V1) :/\: (rectangle_set U2 V2).
      { exact (binintersectI (rectangle_set U1 V1) (rectangle_set U2 V2) p HpU1V1 HpU2V2). }
      rewrite <- (setprod_intersection U1 V1 U2 V2).
      exact HpInt.
    * (** subset **)
      claim HintEq: b1 :/\: b2 = b3.
      { prove b1 :/\: b2 = b3.
        rewrite Hb1eq.
        rewrite Hb2eq.
        exact (setprod_intersection U1 V1 U2 V2). }
      rewrite HintEq.
      exact (Subq_ref b3).
Qed.

(** from §15: product topology is a topology **)
(** LATEX VERSION: The product topology determined by Tx and Ty satisfies the topology axioms on X×Y. **)
Theorem product_topology_is_topology : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  topology_on (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove topology_on (setprod X Y) (product_topology X Tx Y Ty).
(** product_topology X Tx Y Ty = generated_topology (setprod X Y) (product_subbasis X Tx Y Ty) **)
(** Use axiom that product_subbasis forms a basis, then apply lemma_topology_from_basis **)
exact (lemma_topology_from_basis (setprod X Y) (product_subbasis X Tx Y Ty)
         (product_subbasis_is_basis X Tx Y Ty HTx HTy)).
Qed.

(** from §15: basis for a product from bases in the factors **)
(** LATEX VERSION: If B and C are bases for X and Y, then {B×C} is a basis for X×Y in the product topology. **)
(** Definition: product basis from two bases **)
Definition product_basis_from : set -> set -> set :=
  fun Bx By => \/_ U :e Bx, {setprod U V | V :e By}.

(** Helper: product basis generates product topology **)
Theorem product_basis_generates_product_topology : forall X Y Bx By Tx Ty:set,
  basis_on X Bx -> generated_topology X Bx = Tx ->
  basis_on Y By -> generated_topology Y By = Ty ->
  generated_topology (setprod X Y) (product_basis_from Bx By) = product_topology X Tx Y Ty.
let X Y Bx By Tx Ty.
assume HBx_basis: basis_on X Bx.
assume HTx_eq: generated_topology X Bx = Tx.
assume HBy_basis: basis_on Y By.
assume HTy_eq: generated_topology Y By = Ty.
claim HTx: topology_on X Tx.
{ rewrite <- HTx_eq.
  exact (lemma_topology_from_basis X Bx HBx_basis). }
claim HTy: topology_on Y Ty.
{ rewrite <- HTy_eq.
  exact (lemma_topology_from_basis Y By HBy_basis). }
claim HTprod: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
claim HCsub: forall c :e product_basis_from Bx By, c :e product_topology X Tx Y Ty.
{ let c. assume HcC.
  claim HBprod: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HexU: exists U :e Bx, c :e {setprod U V | V :e By}.
  { exact (famunionE Bx (fun U0:set => {setprod U0 V0 | V0 :e By}) c HcC). }
  apply HexU.
  let U. assume HUconj: U :e Bx /\ c :e {setprod U V | V :e By}.
  claim HU: U :e Bx.
  { exact (andEL (U :e Bx) (c :e {setprod U V | V :e By}) HUconj). }
  claim HcRepl: c :e {setprod U V | V :e By}.
  { exact (andER (U :e Bx) (c :e {setprod U V | V :e By}) HUconj). }
  claim HexV: exists V :e By, c = setprod U V.
  { exact (ReplE By (fun V0:set => setprod U V0) c HcRepl). }
  apply HexV.
  let V. assume HVconj: V :e By /\ c = setprod U V.
  claim HV: V :e By.
  { exact (andEL (V :e By) (c = setprod U V) HVconj). }
  claim Hceq: c = setprod U V.
  { exact (andER (V :e By) (c = setprod U V) HVconj). }
  claim HUTx: U :e Tx.
  { rewrite <- HTx_eq.
    exact (generated_topology_contains_basis X Bx HBx_basis U HU). }
  claim HVTy: V :e Ty.
  { rewrite <- HTy_eq.
    exact (generated_topology_contains_basis Y By HBy_basis V HV). }
  claim HcSub: c :e product_subbasis X Tx Y Ty.
  { rewrite Hceq.
    claim Hrepl: rectangle_set U V :e {rectangle_set U W | W :e Ty}.
    { exact (ReplI Ty (fun W:set => rectangle_set U W) V HVTy). }
    exact (famunionI Tx (fun U0:set => {rectangle_set U0 W | W :e Ty}) U (rectangle_set U V) HUTx Hrepl). }
  exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBprod c HcSub). }
claim Href: forall U :e product_topology X Tx Y Ty, forall p :e U,
  exists Cx :e product_basis_from Bx By, p :e Cx /\ Cx c= U.
{ let U. assume HU: U :e product_topology X Tx Y Ty.
  let p. assume Hp: p :e U.
  claim HUprop: forall q :e U, exists b :e product_subbasis X Tx Y Ty, q :e b /\ b c= U.
  { exact (SepE2 (Power (setprod X Y))
                 (fun U0:set => forall q0 :e U0, exists b0 :e product_subbasis X Tx Y Ty, q0 :e b0 /\ b0 c= U0)
                 U HU). }
  claim Hexb: exists b :e product_subbasis X Tx Y Ty, p :e b /\ b c= U.
  { exact (HUprop p Hp). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbSub: b :e product_subbasis X Tx Y Ty.
  { exact (andEL (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair). }
  claim Hbprop: p :e b /\ b c= U.
  { exact (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= U) Hbprop). }
  claim HbsubU: b c= U.
  { exact (andER (p :e b) (b c= U) Hbprop). }
  claim HexU0: exists U0 :e Tx, b :e {rectangle_set U0 V0 | V0 :e Ty}.
  { exact (famunionE Tx (fun U1:set => {rectangle_set U1 V1 | V1 :e Ty}) b HbSub). }
  apply HexU0.
  let U0. assume HU0conj: U0 :e Tx /\ b :e {rectangle_set U0 V0 | V0 :e Ty}.
  claim HU0: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V0 | V0 :e Ty}) HU0conj). }
  claim HbRepl: b :e {rectangle_set U0 V0 | V0 :e Ty}.
  { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V0 | V0 :e Ty}) HU0conj). }
  claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
  { exact (ReplE Ty (fun V1:set => rectangle_set U0 V1) b HbRepl). }
  apply HexV0.
  let V0. assume HV0conj: V0 :e Ty /\ b = rectangle_set U0 V0.
  claim HV0: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
  claim Hbeq: b = rectangle_set U0 V0.
  { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
  claim Hpb0: p :e rectangle_set U0 V0.
  { prove p :e rectangle_set U0 V0.
    rewrite <- Hbeq.
    exact Hpb. }
  claim Hp0U0: p 0 :e U0.
  { exact (ap0_Sigma U0 (fun _ : set => V0) p Hpb0). }
  claim Hp1V0: p 1 :e V0.
  { exact (ap1_Sigma U0 (fun _ : set => V0) p Hpb0). }
  claim HU0gen: U0 :e generated_topology X Bx.
  { rewrite HTx_eq. exact HU0. }
  claim HV0gen: V0 :e generated_topology Y By.
  { rewrite HTy_eq. exact HV0. }
  claim HU0loc: forall x :e U0, exists bx :e Bx, x :e bx /\ bx c= U0.
  { exact (SepE2 (Power X)
                 (fun U1:set => forall x1 :e U1, exists b1 :e Bx, x1 :e b1 /\ b1 c= U1)
                 U0 HU0gen). }
  claim HV0loc: forall y :e V0, exists by :e By, y :e by /\ by c= V0.
  { exact (SepE2 (Power Y)
                 (fun V1:set => forall y1 :e V1, exists b1 :e By, y1 :e b1 /\ b1 c= V1)
                 V0 HV0gen). }
  claim Hexbx: exists bx :e Bx, p 0 :e bx /\ bx c= U0.
  { exact (HU0loc (p 0) Hp0U0). }
  apply Hexbx.
  let bx. assume Hbxpair.
  claim Hbx: bx :e Bx.
  { exact (andEL (bx :e Bx) (p 0 :e bx /\ bx c= U0) Hbxpair). }
  claim Hbxprop: p 0 :e bx /\ bx c= U0.
  { exact (andER (bx :e Bx) (p 0 :e bx /\ bx c= U0) Hbxpair). }
  claim Hp0bx: p 0 :e bx.
  { exact (andEL (p 0 :e bx) (bx c= U0) Hbxprop). }
  claim Hbxsub: bx c= U0.
  { exact (andER (p 0 :e bx) (bx c= U0) Hbxprop). }
  claim Hexby: exists by :e By, p 1 :e by /\ by c= V0.
  { exact (HV0loc (p 1) Hp1V0). }
  apply Hexby.
  let by. assume Hbypair.
  claim Hby: by :e By.
  { exact (andEL (by :e By) (p 1 :e by /\ by c= V0) Hbypair). }
  claim Hbyprop: p 1 :e by /\ by c= V0.
  { exact (andER (by :e By) (p 1 :e by /\ by c= V0) Hbypair). }
  claim Hp1by: p 1 :e by.
  { exact (andEL (p 1 :e by) (by c= V0) Hbyprop). }
  claim Hbysub: by c= V0.
  { exact (andER (p 1 :e by) (by c= V0) Hbyprop). }
  witness (setprod bx by).
  apply andI.
  - (** membership in product_basis_from **)
    claim Hrepl: setprod bx by :e {setprod bx w | w :e By}.
    { exact (ReplI By (fun w:set => setprod bx w) by Hby). }
    exact (famunionI Bx (fun u:set => {setprod u w | w :e By}) bx (setprod bx by) Hbx Hrepl).
  - apply andI.
    + (** p in setprod bx by **)
      claim Heta: p = (p 0, p 1).
      { exact (setprod_eta U0 V0 p Hpb0). }
      rewrite Heta.
      exact (tuple_2_setprod_by_pair_Sigma bx by (p 0) (p 1) Hp0bx Hp1by).
    + (** subset **)
      claim Hsubbb: setprod bx by c= setprod U0 V0.
      { exact (setprod_Subq bx by U0 V0 Hbxsub Hbysub). }
      claim HsubbU: setprod U0 V0 c= U.
      { rewrite <- Hbeq. exact HbsubU. }
      exact (Subq_tra (setprod bx by) (setprod U0 V0) U Hsubbb HsubbU). }
apply (andER (basis_on (setprod X Y) (product_basis_from Bx By))
             (generated_topology (setprod X Y) (product_basis_from Bx By) = product_topology X Tx Y Ty)
             (basis_refines_topology (setprod X Y) (product_topology X Tx Y Ty) (product_basis_from Bx By) HTprod HCsub Href)).
Qed.

(** Helper: product_basis_from is a basis on the product **)
Theorem product_basis_from_is_basis_on : forall X Y Bx By Tx Ty:set,
  basis_on X Bx -> generated_topology X Bx = Tx ->
  basis_on Y By -> generated_topology Y By = Ty ->
  basis_on (setprod X Y) (product_basis_from Bx By).
let X Y Bx By Tx Ty.
assume HBx_basis: basis_on X Bx.
assume HTx_eq: generated_topology X Bx = Tx.
assume HBy_basis: basis_on Y By.
assume HTy_eq: generated_topology Y By = Ty.
claim HTx: topology_on X Tx.
{ rewrite <- HTx_eq.
  exact (lemma_topology_from_basis X Bx HBx_basis). }
claim HTy: topology_on Y Ty.
{ rewrite <- HTy_eq.
  exact (lemma_topology_from_basis Y By HBy_basis). }
claim HTprod: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
claim HCsub: forall c :e product_basis_from Bx By, c :e product_topology X Tx Y Ty.
{ let c. assume HcC.
  claim HBprod: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HexU: exists U :e Bx, c :e {setprod U V | V :e By}.
  { exact (famunionE Bx (fun U0:set => {setprod U0 V0 | V0 :e By}) c HcC). }
  apply HexU.
  let U. assume HUconj: U :e Bx /\ c :e {setprod U V | V :e By}.
  claim HU: U :e Bx.
  { exact (andEL (U :e Bx) (c :e {setprod U V | V :e By}) HUconj). }
  claim HcRepl: c :e {setprod U V | V :e By}.
  { exact (andER (U :e Bx) (c :e {setprod U V | V :e By}) HUconj). }
  claim HexV: exists V :e By, c = setprod U V.
  { exact (ReplE By (fun V0:set => setprod U V0) c HcRepl). }
  apply HexV.
  let V. assume HVconj: V :e By /\ c = setprod U V.
  claim HV: V :e By.
  { exact (andEL (V :e By) (c = setprod U V) HVconj). }
  claim Hceq: c = setprod U V.
  { exact (andER (V :e By) (c = setprod U V) HVconj). }
  claim HUTx: U :e Tx.
  { rewrite <- HTx_eq.
    exact (generated_topology_contains_basis X Bx HBx_basis U HU). }
  claim HVTy: V :e Ty.
  { rewrite <- HTy_eq.
    exact (generated_topology_contains_basis Y By HBy_basis V HV). }
  claim HcSub: c :e product_subbasis X Tx Y Ty.
  { rewrite Hceq.
    claim Hrepl: rectangle_set U V :e {rectangle_set U W | W :e Ty}.
    { exact (ReplI Ty (fun W:set => rectangle_set U W) V HVTy). }
    exact (famunionI Tx (fun U0:set => {rectangle_set U0 W | W :e Ty}) U (rectangle_set U V) HUTx Hrepl). }
  exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBprod c HcSub). }
claim Href: forall U :e product_topology X Tx Y Ty, forall p :e U,
  exists Cx :e product_basis_from Bx By, p :e Cx /\ Cx c= U.
{ let U. assume HU: U :e product_topology X Tx Y Ty.
  let p. assume Hp: p :e U.
  claim HUprop: forall q :e U, exists b :e product_subbasis X Tx Y Ty, q :e b /\ b c= U.
  { exact (SepE2 (Power (setprod X Y))
                 (fun U0:set => forall q0 :e U0, exists b0 :e product_subbasis X Tx Y Ty, q0 :e b0 /\ b0 c= U0)
                 U HU). }
  claim Hexb: exists b :e product_subbasis X Tx Y Ty, p :e b /\ b c= U.
  { exact (HUprop p Hp). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbSub: b :e product_subbasis X Tx Y Ty.
  { exact (andEL (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair). }
  claim Hbprop: p :e b /\ b c= U.
  { exact (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= U) Hbprop). }
  claim HbsubU: b c= U.
  { exact (andER (p :e b) (b c= U) Hbprop). }
  claim HexU0: exists U0 :e Tx, b :e {rectangle_set U0 V0 | V0 :e Ty}.
  { exact (famunionE Tx (fun U1:set => {rectangle_set U1 V1 | V1 :e Ty}) b HbSub). }
  apply HexU0.
  let U0. assume HU0conj: U0 :e Tx /\ b :e {rectangle_set U0 V0 | V0 :e Ty}.
  claim HU0: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V0 | V0 :e Ty}) HU0conj). }
  claim HbRepl: b :e {rectangle_set U0 V0 | V0 :e Ty}.
  { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V0 | V0 :e Ty}) HU0conj). }
  claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
  { exact (ReplE Ty (fun V1:set => rectangle_set U0 V1) b HbRepl). }
  apply HexV0.
  let V0. assume HV0conj: V0 :e Ty /\ b = rectangle_set U0 V0.
  claim HV0: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
  claim Hbeq: b = rectangle_set U0 V0.
  { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
  claim Hpb0: p :e rectangle_set U0 V0.
  { prove p :e rectangle_set U0 V0.
    rewrite <- Hbeq.
    exact Hpb. }
  claim Hp0U0: p 0 :e U0.
  { exact (ap0_Sigma U0 (fun _ : set => V0) p Hpb0). }
  claim Hp1V0: p 1 :e V0.
  { exact (ap1_Sigma U0 (fun _ : set => V0) p Hpb0). }
  claim HU0gen: U0 :e generated_topology X Bx.
  { rewrite HTx_eq. exact HU0. }
  claim HV0gen: V0 :e generated_topology Y By.
  { rewrite HTy_eq. exact HV0. }
  claim HU0loc: forall x :e U0, exists bx :e Bx, x :e bx /\ bx c= U0.
  { exact (SepE2 (Power X)
                 (fun U1:set => forall x1 :e U1, exists b1 :e Bx, x1 :e b1 /\ b1 c= U1)
                 U0 HU0gen). }
  claim HV0loc: forall y :e V0, exists by :e By, y :e by /\ by c= V0.
  { exact (SepE2 (Power Y)
                 (fun V1:set => forall y1 :e V1, exists b1 :e By, y1 :e b1 /\ b1 c= V1)
                 V0 HV0gen). }
  claim Hexbx: exists bx :e Bx, p 0 :e bx /\ bx c= U0.
  { exact (HU0loc (p 0) Hp0U0). }
  apply Hexbx.
  let bx. assume Hbxpair.
  claim Hbx: bx :e Bx.
  { exact (andEL (bx :e Bx) (p 0 :e bx /\ bx c= U0) Hbxpair). }
  claim Hbxprop: p 0 :e bx /\ bx c= U0.
  { exact (andER (bx :e Bx) (p 0 :e bx /\ bx c= U0) Hbxpair). }
  claim Hp0bx: p 0 :e bx.
  { exact (andEL (p 0 :e bx) (bx c= U0) Hbxprop). }
  claim Hbxsub: bx c= U0.
  { exact (andER (p 0 :e bx) (bx c= U0) Hbxprop). }
  claim Hexby: exists by :e By, p 1 :e by /\ by c= V0.
  { exact (HV0loc (p 1) Hp1V0). }
  apply Hexby.
  let by. assume Hbypair.
  claim Hby: by :e By.
  { exact (andEL (by :e By) (p 1 :e by /\ by c= V0) Hbypair). }
  claim Hbyprop: p 1 :e by /\ by c= V0.
  { exact (andER (by :e By) (p 1 :e by /\ by c= V0) Hbypair). }
  claim Hp1by: p 1 :e by.
  { exact (andEL (p 1 :e by) (by c= V0) Hbyprop). }
  claim Hbysub: by c= V0.
  { exact (andER (p 1 :e by) (by c= V0) Hbyprop). }
  witness (setprod bx by).
  apply andI.
  - claim Hrepl: setprod bx by :e {setprod bx w | w :e By}.
    { exact (ReplI By (fun w:set => setprod bx w) by Hby). }
    exact (famunionI Bx (fun u:set => {setprod u w | w :e By}) bx (setprod bx by) Hbx Hrepl).
  - apply andI.
    + claim Heta: p = (p 0, p 1).
      { exact (setprod_eta U0 V0 p Hpb0). }
      rewrite Heta.
      exact (tuple_2_setprod_by_pair_Sigma bx by (p 0) (p 1) Hp0bx Hp1by).
    + claim Hsubbb: setprod bx by c= setprod U0 V0.
      { exact (setprod_Subq bx by U0 V0 Hbxsub Hbysub). }
      claim HsubbU: setprod U0 V0 c= U.
      { rewrite <- Hbeq. exact HbsubU. }
      exact (Subq_tra (setprod bx by) (setprod U0 V0) U Hsubbb HsubbU). }
exact (andEL (basis_on (setprod X Y) (product_basis_from Bx By))
             (generated_topology (setprod X Y) (product_basis_from Bx By) = product_topology X Tx Y Ty)
             (basis_refines_topology (setprod X Y) (product_topology X Tx Y Ty) (product_basis_from Bx By) HTprod HCsub Href)).
Qed.

(** from §15 Theorem: basis of products of basis elements **)
(** LATEX VERSION: If Bx, By are bases for Tx, Ty, then the collection {U×V|U∈Bx, V∈By} is a basis generating the product topology. **)
Theorem product_basis_generates :
  forall X Tx Y Ty Bx By:set,
    basis_on X Bx /\ generated_topology X Bx = Tx ->
    basis_on Y By /\ generated_topology Y By = Ty ->
    exists B:set,
      basis_on (setprod X Y) B /\
      (forall U :e Bx, forall V :e By, setprod U V :e B) /\
  generated_topology (setprod X Y) B = product_topology X Tx Y Ty.
let X Tx Y Ty Bx By.
assume HBx: basis_on X Bx /\ generated_topology X Bx = Tx.
assume HBy: basis_on Y By /\ generated_topology Y By = Ty.
prove exists B:set,
      basis_on (setprod X Y) B /\
      (forall U :e Bx, forall V :e By, setprod U V :e B) /\
  generated_topology (setprod X Y) B = product_topology X Tx Y Ty.
(** Witness B = product_basis_from Bx By = {U×V | U∈Bx, V∈By} **)
witness (product_basis_from Bx By).
prove basis_on (setprod X Y) (product_basis_from Bx By) /\
      (forall U :e Bx, forall V :e By, setprod U V :e product_basis_from Bx By) /\
  generated_topology (setprod X Y) (product_basis_from Bx By) = product_topology X Tx Y Ty.
apply andI.
- (** Part 1 & 2: product_basis_from Bx By is a basis and contains all U×V **)
  apply andI.
  + (** Prove basis_on (setprod X Y) (product_basis_from Bx By) **)
    (** Extract properties from assumptions **)
    claim HBx_basis: basis_on X Bx.
    { exact (andEL (basis_on X Bx) (generated_topology X Bx = Tx) HBx). }
    claim HBy_basis: basis_on Y By.
    { exact (andEL (basis_on Y By) (generated_topology Y By = Ty) HBy). }
    (** Verify three basis axioms for product_basis_from Bx By **)
    prove product_basis_from Bx By c= Power (setprod X Y)
      /\ (forall p :e setprod X Y, exists b :e product_basis_from Bx By, p :e b)
      /\ (forall b1 :e product_basis_from Bx By, forall b2 :e product_basis_from Bx By, forall p:set,
            p :e b1 -> p :e b2 -> exists b3 :e product_basis_from Bx By, p :e b3 /\ b3 c= b1 :/\: b2).
    (** Left-associative structure: (Axiom1 /\ Axiom2) /\ Axiom3 **)
    apply andI.
    * (** Prove Axiom1 /\ Axiom2 **)
      apply andI.
      - (** Axiom 1: product_basis_from Bx By c= Power (setprod X Y) **)
        let b. assume Hb: b :e product_basis_from Bx By.
        prove b :e Power (setprod X Y).
        (** b is in the family union, so b = setprod U V for some U :e Bx, V :e By **)
        claim Hexists: exists U :e Bx, b :e {setprod U V' | V' :e By}.
        { exact (famunionE Bx (fun U' => {setprod U' V' | V' :e By}) b Hb). }
        apply Hexists.
        let U. assume HU_conj: U :e Bx /\ b :e {setprod U V' | V' :e By}.
        claim HU: U :e Bx.
        { exact (andEL (U :e Bx) (b :e {setprod U V' | V' :e By}) HU_conj). }
        claim HbRepl: b :e {setprod U V' | V' :e By}.
        { exact (andER (U :e Bx) (b :e {setprod U V' | V' :e By}) HU_conj). }
        (** b :e {setprod U V' | V' :e By}, so b = setprod U V for some V :e By **)
        claim Hexists2: exists V :e By, b = setprod U V.
        { exact (ReplE By (fun V' => setprod U V') b HbRepl). }
        apply Hexists2.
        let V. assume HV_conj: V :e By /\ b = setprod U V.
        claim HV: V :e By.
        { exact (andEL (V :e By) (b = setprod U V) HV_conj). }
        claim Hbeq: b = setprod U V.
        { exact (andER (V :e By) (b = setprod U V) HV_conj). }
        (** Now show setprod U V :e Power (setprod X Y) **)
        (** Need U c= X and V c= Y **)
        claim HBx_sub: Bx c= Power X.
        { exact (andEL (Bx c= Power X) (forall x :e X, exists b :e Bx, x :e b) (andEL (Bx c= Power X /\ (forall x :e X, exists b :e Bx, x :e b)) (forall b1 :e Bx, forall b2 :e Bx, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e Bx, x :e b3 /\ b3 c= b1 :/\: b2) HBx_basis)). }
        claim HBy_sub: By c= Power Y.
        { exact (andEL (By c= Power Y) (forall y :e Y, exists b :e By, y :e b) (andEL (By c= Power Y /\ (forall y :e Y, exists b :e By, y :e b)) (forall b1 :e By, forall b2 :e By, forall y:set, y :e b1 -> y :e b2 -> exists b3 :e By, y :e b3 /\ b3 c= b1 :/\: b2) HBy_basis)). }
        claim HUsubX: U c= X.
        { exact (PowerE X U (HBx_sub U HU)). }
        claim HVsubY: V c= Y.
        { exact (PowerE Y V (HBy_sub V HV)). }
        claim HUVsub: setprod U V c= setprod X Y.
        { exact (setprod_Subq U V X Y HUsubX HVsubY). }
        (** Since b = setprod U V, we have b c= setprod X Y **)
        claim Hbsub: b c= setprod X Y.
        { rewrite Hbeq. exact HUVsub. }
        exact (PowerI (setprod X Y) b Hbsub).
      - (** Axiom 2: covering - every (x,y) is in some U×V **)
        let p. assume Hp: p :e setprod X Y.
        prove exists b :e product_basis_from Bx By, p :e b.
        (** Use setprod_elem_decompose to extract coordinates **)
        claim Hcoords: exists x :e X, exists y :e Y, p :e setprod {x} {y}.
        { exact (setprod_elem_decompose X Y p Hp). }
        apply Hcoords.
        let x. assume Hx_conj: x :e X /\ exists y :e Y, p :e setprod {x} {y}.
        claim Hx: x :e X.
        { exact (andEL (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hx_conj). }
        claim Hy_exists: exists y :e Y, p :e setprod {x} {y}.
        { exact (andER (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hx_conj). }
        apply Hy_exists.
        let y. assume Hy_conj: y :e Y /\ p :e setprod {x} {y}.
        claim Hy: y :e Y.
        { exact (andEL (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
        claim Hp_sing: p :e setprod {x} {y}.
        { exact (andER (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
        (** Use covering property of Bx to find U containing x **)
        claim HBx_cover: forall x' :e X, exists U :e Bx, x' :e U.
        { exact (andER (Bx c= Power X) (forall x' :e X, exists U :e Bx, x' :e U)
                       (andEL (Bx c= Power X /\ (forall x' :e X, exists U :e Bx, x' :e U))
                              (forall b1 :e Bx, forall b2 :e Bx, forall x':set, x' :e b1 -> x' :e b2 -> exists b3 :e Bx, x' :e b3 /\ b3 c= b1 :/\: b2)
                              HBx_basis)). }
        claim HU_exists: exists U :e Bx, x :e U.
        { exact (HBx_cover x Hx). }
        apply HU_exists.
        let U. assume HU_conj: U :e Bx /\ x :e U.
        claim HU: U :e Bx.
        { exact (andEL (U :e Bx) (x :e U) HU_conj). }
        claim Hx_in_U: x :e U.
        { exact (andER (U :e Bx) (x :e U) HU_conj). }
        (** Use covering property of By to find V containing y **)
        claim HBy_cover: forall y' :e Y, exists V :e By, y' :e V.
        { exact (andER (By c= Power Y) (forall y' :e Y, exists V :e By, y' :e V)
                       (andEL (By c= Power Y /\ (forall y' :e Y, exists V :e By, y' :e V))
                              (forall b1 :e By, forall b2 :e By, forall y':set, y' :e b1 -> y' :e b2 -> exists b3 :e By, y' :e b3 /\ b3 c= b1 :/\: b2)
                              HBy_basis)). }
        claim HV_exists: exists V :e By, y :e V.
        { exact (HBy_cover y Hy). }
        apply HV_exists.
        let V. assume HV_conj: V :e By /\ y :e V.
        claim HV: V :e By.
        { exact (andEL (V :e By) (y :e V) HV_conj). }
        claim Hy_in_V: y :e V.
        { exact (andER (V :e By) (y :e V) HV_conj). }
        (** Now show p :e setprod U V using singleton subsets **)
        claim Hx_sing_sub: {x} c= U.
        { exact (singleton_subset x U Hx_in_U). }
        claim Hy_sing_sub: {y} c= V.
        { exact (singleton_subset y V Hy_in_V). }
        claim HUV_sub: setprod {x} {y} c= setprod U V.
        { exact (setprod_Subq {x} {y} U V Hx_sing_sub Hy_sing_sub). }
        claim Hp_in_UV: p :e setprod U V.
        { exact (HUV_sub p Hp_sing). }
        (** Finally, witness setprod U V :e product_basis_from Bx By **)
        witness (setprod U V).
        prove setprod U V :e product_basis_from Bx By /\ p :e setprod U V.
        apply andI.
        + (** Show setprod U V :e product_basis_from Bx By **)
          claim HUVinRepl: setprod U V :e {setprod U V' | V' :e By}.
          { exact (ReplI By (fun V' => setprod U V') V HV). }
          exact (famunionI Bx (fun U' => {setprod U' V' | V' :e By}) U (setprod U V) HU HUVinRepl).
        + exact Hp_in_UV.

    * (** Axiom 3: intersection property **)
      let b1. assume Hb1: b1 :e product_basis_from Bx By.
      let b2. assume Hb2: b2 :e product_basis_from Bx By.
      let p. assume Hpb1: p :e b1. assume Hpb2: p :e b2.
      prove exists b3 :e product_basis_from Bx By, p :e b3 /\ b3 c= b1 :/\: b2.
      (** Extract U1, V1 from b1 **)
      claim Hexists1: exists U1 :e Bx, b1 :e {setprod U1 V' | V' :e By}.
      { exact (famunionE Bx (fun U' => {setprod U' V' | V' :e By}) b1 Hb1). }
      apply Hexists1.
      let U1. assume HU1_conj: U1 :e Bx /\ b1 :e {setprod U1 V' | V' :e By}.
      claim HU1: U1 :e Bx.
      { exact (andEL (U1 :e Bx) (b1 :e {setprod U1 V' | V' :e By}) HU1_conj). }
      claim Hb1Repl: b1 :e {setprod U1 V' | V' :e By}.
      { exact (andER (U1 :e Bx) (b1 :e {setprod U1 V' | V' :e By}) HU1_conj). }
      claim Hexists1b: exists V1 :e By, b1 = setprod U1 V1.
      { exact (ReplE By (fun V' => setprod U1 V') b1 Hb1Repl). }
      apply Hexists1b.
      let V1. assume HV1_conj: V1 :e By /\ b1 = setprod U1 V1.
      claim HV1: V1 :e By.
      { exact (andEL (V1 :e By) (b1 = setprod U1 V1) HV1_conj). }
      claim Hb1eq: b1 = setprod U1 V1.
      { exact (andER (V1 :e By) (b1 = setprod U1 V1) HV1_conj). }
      (** Extract U2, V2 from b2 **)
      claim Hexists2: exists U2 :e Bx, b2 :e {setprod U2 V' | V' :e By}.
      { exact (famunionE Bx (fun U' => {setprod U' V' | V' :e By}) b2 Hb2). }
      apply Hexists2.
      let U2. assume HU2_conj: U2 :e Bx /\ b2 :e {setprod U2 V' | V' :e By}.
      claim HU2: U2 :e Bx.
      { exact (andEL (U2 :e Bx) (b2 :e {setprod U2 V' | V' :e By}) HU2_conj). }
      claim Hb2Repl: b2 :e {setprod U2 V' | V' :e By}.
      { exact (andER (U2 :e Bx) (b2 :e {setprod U2 V' | V' :e By}) HU2_conj). }
      claim Hexists2b: exists V2 :e By, b2 = setprod U2 V2.
      { exact (ReplE By (fun V' => setprod U2 V') b2 Hb2Repl). }
      apply Hexists2b.
      let V2. assume HV2_conj: V2 :e By /\ b2 = setprod U2 V2.
      claim HV2: V2 :e By.
      { exact (andEL (V2 :e By) (b2 = setprod U2 V2) HV2_conj). }
      claim Hb2eq: b2 = setprod U2 V2.
      { exact (andER (V2 :e By) (b2 = setprod U2 V2) HV2_conj). }
      (** Show p :e setprod X Y **)
      claim Hb1sub: b1 c= setprod X Y.
      { claim Hb1Power: b1 :e Power (setprod X Y).
        { (** Use same logic as Axiom 1 **)
          claim HBx_sub: Bx c= Power X.
          { exact (andEL (Bx c= Power X) (forall x :e X, exists b :e Bx, x :e b) (andEL (Bx c= Power X /\ (forall x :e X, exists b :e Bx, x :e b)) (forall b1 :e Bx, forall b2 :e Bx, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e Bx, x :e b3 /\ b3 c= b1 :/\: b2) HBx_basis)). }
          claim HBy_sub: By c= Power Y.
          { exact (andEL (By c= Power Y) (forall y :e Y, exists b :e By, y :e b) (andEL (By c= Power Y /\ (forall y :e Y, exists b :e By, y :e b)) (forall b1 :e By, forall b2 :e By, forall y:set, y :e b1 -> y :e b2 -> exists b3 :e By, y :e b3 /\ b3 c= b1 :/\: b2) HBy_basis)). }
          claim HU1subX: U1 c= X.
          { exact (PowerE X U1 (HBx_sub U1 HU1)). }
          claim HV1subY: V1 c= Y.
          { exact (PowerE Y V1 (HBy_sub V1 HV1)). }
          claim HU1V1sub: setprod U1 V1 c= setprod X Y.
          { exact (setprod_Subq U1 V1 X Y HU1subX HV1subY). }
          claim Hb1sub_inner: b1 c= setprod X Y.
          { rewrite Hb1eq. exact HU1V1sub. }
          exact (PowerI (setprod X Y) b1 Hb1sub_inner). }
        exact (PowerE (setprod X Y) b1 Hb1Power). }
      claim Hp_XY: p :e setprod X Y.
      { exact (Hb1sub p Hpb1). }
      (** Extract coordinates x, y from p **)
      claim Hcoords: exists x :e X, exists y :e Y, p :e setprod {x} {y}.
      { exact (setprod_elem_decompose X Y p Hp_XY). }
      apply Hcoords.
      let x. assume Hx_conj: x :e X /\ exists y :e Y, p :e setprod {x} {y}.
      claim Hx: x :e X.
      { exact (andEL (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hx_conj). }
      claim Hy_exists: exists y :e Y, p :e setprod {x} {y}.
      { exact (andER (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hx_conj). }
      apply Hy_exists.
      let y. assume Hy_conj: y :e Y /\ p :e setprod {x} {y}.
      claim Hy: y :e Y.
      { exact (andEL (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
      claim Hp_sing: p :e setprod {x} {y}.
      { exact (andER (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
      (** Show x :e U1 :/\: U2 and y :e V1 :/\: V2 **)
      claim Hp_b1: p :e setprod U1 V1.
      { rewrite <- Hb1eq. exact Hpb1. }
      claim Hp_b2: p :e setprod U2 V2.
      { rewrite <- Hb2eq. exact Hpb2. }
      claim Hxy_U1V1: x :e U1 /\ y :e V1.
      { exact (setprod_coords_in x y U1 V1 p Hp_sing Hp_b1). }
      claim Hxy_U2V2: x :e U2 /\ y :e V2.
      { exact (setprod_coords_in x y U2 V2 p Hp_sing Hp_b2). }
      claim Hx_U1: x :e U1.
      { exact (andEL (x :e U1) (y :e V1) Hxy_U1V1). }
      claim Hy_V1: y :e V1.
      { exact (andER (x :e U1) (y :e V1) Hxy_U1V1). }
      claim Hx_U2: x :e U2.
      { exact (andEL (x :e U2) (y :e V2) Hxy_U2V2). }
      claim Hy_V2: y :e V2.
      { exact (andER (x :e U2) (y :e V2) Hxy_U2V2). }
      (** Use basis intersection property for Bx **)
      claim HBx_intersect: forall b1' :e Bx, forall b2' :e Bx, forall x':set,
        x' :e b1' -> x' :e b2' -> exists b3' :e Bx, x' :e b3' /\ b3' c= b1' :/\: b2'.
      { exact (andER (Bx c= Power X /\ (forall x' :e X, exists b :e Bx, x' :e b))
                     (forall b1' :e Bx, forall b2' :e Bx, forall x':set, x' :e b1' -> x' :e b2' -> exists b3' :e Bx, x' :e b3' /\ b3' c= b1' :/\: b2')
                     HBx_basis). }
      claim HU3_exists: exists U3 :e Bx, x :e U3 /\ U3 c= U1 :/\: U2.
      { exact (HBx_intersect U1 HU1 U2 HU2 x Hx_U1 Hx_U2). }
      apply HU3_exists.
      let U3. assume HU3_conj: U3 :e Bx /\ (x :e U3 /\ U3 c= U1 :/\: U2).
      claim HU3: U3 :e Bx.
      { exact (andEL (U3 :e Bx) (x :e U3 /\ U3 c= U1 :/\: U2) HU3_conj). }
      claim Hx_U3_and_sub: x :e U3 /\ U3 c= U1 :/\: U2.
      { exact (andER (U3 :e Bx) (x :e U3 /\ U3 c= U1 :/\: U2) HU3_conj). }
      claim Hx_U3: x :e U3.
      { exact (andEL (x :e U3) (U3 c= U1 :/\: U2) Hx_U3_and_sub). }
      claim HU3_sub: U3 c= U1 :/\: U2.
      { exact (andER (x :e U3) (U3 c= U1 :/\: U2) Hx_U3_and_sub). }
      (** Use basis intersection property for By **)
      claim HBy_intersect: forall b1' :e By, forall b2' :e By, forall y':set,
        y' :e b1' -> y' :e b2' -> exists b3' :e By, y' :e b3' /\ b3' c= b1' :/\: b2'.
      { exact (andER (By c= Power Y /\ (forall y' :e Y, exists b :e By, y' :e b))
                     (forall b1' :e By, forall b2' :e By, forall y':set, y' :e b1' -> y' :e b2' -> exists b3' :e By, y' :e b3' /\ b3' c= b1' :/\: b2')
                     HBy_basis). }
      claim HV3_exists: exists V3 :e By, y :e V3 /\ V3 c= V1 :/\: V2.
      { exact (HBy_intersect V1 HV1 V2 HV2 y Hy_V1 Hy_V2). }
      apply HV3_exists.
      let V3. assume HV3_conj: V3 :e By /\ (y :e V3 /\ V3 c= V1 :/\: V2).
      claim HV3: V3 :e By.
      { exact (andEL (V3 :e By) (y :e V3 /\ V3 c= V1 :/\: V2) HV3_conj). }
      claim Hy_V3_and_sub: y :e V3 /\ V3 c= V1 :/\: V2.
      { exact (andER (V3 :e By) (y :e V3 /\ V3 c= V1 :/\: V2) HV3_conj). }
      claim Hy_V3: y :e V3.
      { exact (andEL (y :e V3) (V3 c= V1 :/\: V2) Hy_V3_and_sub). }
      claim HV3_sub: V3 c= V1 :/\: V2.
      { exact (andER (y :e V3) (V3 c= V1 :/\: V2) Hy_V3_and_sub). }
      (** Show p :e setprod U3 V3 **)
      claim Hx_sing_sub: {x} c= U3.
      { exact (singleton_subset x U3 Hx_U3). }
      claim Hy_sing_sub: {y} c= V3.
      { exact (singleton_subset y V3 Hy_V3). }
      claim HU3V3_super: setprod {x} {y} c= setprod U3 V3.
      { exact (setprod_Subq {x} {y} U3 V3 Hx_sing_sub Hy_sing_sub). }
      claim Hp_U3V3: p :e setprod U3 V3.
      { exact (HU3V3_super p Hp_sing). }
      (** Show setprod U3 V3 c= b1 :/\: b2 **)
      claim Hb1b2_int: b1 :/\: b2 = setprod U1 V1 :/\: setprod U2 V2.
      { rewrite Hb1eq. rewrite Hb2eq. reflexivity. }
      claim Hprod_int: setprod U1 V1 :/\: setprod U2 V2 = setprod (U1 :/\: U2) (V1 :/\: V2).
      { exact (setprod_intersection U1 V1 U2 V2). }
      claim HU3V3_sub: setprod U3 V3 c= setprod (U1 :/\: U2) (V1 :/\: V2).
      { exact (setprod_Subq U3 V3 (U1 :/\: U2) (V1 :/\: V2) HU3_sub HV3_sub). }
      claim HU3V3_sub_b1b2: setprod U3 V3 c= b1 :/\: b2.
      { rewrite Hb1b2_int. rewrite Hprod_int. exact HU3V3_sub. }
      (** Witness setprod U3 V3 **)
      witness (setprod U3 V3).
      prove setprod U3 V3 :e product_basis_from Bx By /\ (p :e setprod U3 V3 /\ setprod U3 V3 c= b1 :/\: b2).
      apply andI.
      + claim HU3V3inRepl: setprod U3 V3 :e {setprod U3 V' | V' :e By}.
        { exact (ReplI By (fun V' => setprod U3 V') V3 HV3). }
        exact (famunionI Bx (fun U' => {setprod U' V' | V' :e By}) U3 (setprod U3 V3) HU3 HU3V3inRepl).
      + apply andI.
        - exact Hp_U3V3.
        - exact HU3V3_sub_b1b2.
  + (** Prove forall U :e Bx, forall V :e By, setprod U V :e product_basis_from Bx By **)
    let U. assume HU: U :e Bx.
    let V. assume HV: V :e By.
    prove setprod U V :e product_basis_from Bx By.
    (** product_basis_from Bx By = \/_ U' :e Bx, {setprod U' V' | V' :e By} **)
    (** Use famunionI with U :e Bx and setprod U V :e {setprod U V' | V' :e By} **)
    claim HUVinRepl: setprod U V :e {setprod U V' | V' :e By}.
    { exact (ReplI By (fun V' => setprod U V') V HV). }
    exact (famunionI Bx (fun U' => {setprod U' V' | V' :e By}) U (setprod U V) HU HUVinRepl).
- (** Part 3: generated_topology (setprod X Y) (product_basis_from Bx By) = product_topology X Tx Y Ty **)
  (** product_topology X Tx Y Ty = generated_topology (setprod X Y) (product_subbasis X Tx Y Ty) **)
  (** product_subbasis X Tx Y Ty uses Tx and Ty, which equal generated_topology X Bx and generated_topology Y By **)
  (** product_basis_from Bx By = {U×V | U :e Bx, V :e By} **)
  (** Use the axiom that product basis generates product topology **)
  claim HBx_basis: basis_on X Bx.
  { exact (andEL (basis_on X Bx) (generated_topology X Bx = Tx) HBx). }
  claim HBy_basis: basis_on Y By.
  { exact (andEL (basis_on Y By) (generated_topology Y By = Ty) HBy). }
  claim HTx_eq: generated_topology X Bx = Tx.
  { exact (andER (basis_on X Bx) (generated_topology X Bx = Tx) HBx). }
  claim HTy_eq: generated_topology Y By = Ty.
  { exact (andER (basis_on Y By) (generated_topology Y By = Ty) HBy). }
  exact (product_basis_generates_product_topology X Y Bx By Tx Ty HBx_basis HTx_eq HBy_basis HTy_eq).
Qed.

(** from §15 Definition: projections on a product **) 
(** LATEX VERSION: Define coordinate projection relations π₁ and π₂ from X×Y. **)
(** FIXED: Projections must use ordered pairs for function graphs: proj₁ maps (x,y)↦x and proj₂ maps (x,y)↦y, with graphs {((x,y),x)} and {((x,y),y)}; UPair and setprod x y were incorrect here. **)
Definition projection1 : set -> set -> set := fun X Y =>
  {(p, p 0) | p :e setprod X Y}.
Definition projection2 : set -> set -> set := fun X Y =>
  {(p, p 1) | p :e setprod X Y}.
 
(** SUSPICIOUS DEFINITION: These projection graphs rely on tuple-as-function encoding, so that for `p :e setprod X Y` we can read `p 0` and `p 1` as coordinates. **)

(** from §15 Theorem 15.2: projection preimages form a subbasis **) 
(** LATEX VERSION: The inverse images of opens under projections give a subbasis for the product topology. **)
Theorem product_subbasis_from_projections : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  exists S:set,
    S = product_subbasis X Tx Y Ty /\
    generated_topology (setprod X Y) S = product_topology X Tx Y Ty.
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove exists S:set,
    S = product_subbasis X Tx Y Ty /\
    generated_topology (setprod X Y) S = product_topology X Tx Y Ty.
(** Witness S = product_subbasis X Tx Y Ty **)
witness (product_subbasis X Tx Y Ty).
prove product_subbasis X Tx Y Ty = product_subbasis X Tx Y Ty /\
      generated_topology (setprod X Y) (product_subbasis X Tx Y Ty) = product_topology X Tx Y Ty.
apply andI.
- (** S = product_subbasis X Tx Y Ty **)
  reflexivity.
- (** generated_topology (setprod X Y) S = product_topology X Tx Y Ty **)
  (** By definition: product_topology X Tx Y Ty = generated_topology (setprod X Y) (product_subbasis X Tx Y Ty) **)
  reflexivity.
Qed.

(** from §18 Continuous Functions: functions as maps between sets **)
(** LATEX VERSION: A function f:X→Y assigns to each x∈X a point f(x)∈Y; continuity is defined using inverse images of open sets. **)
(** FIXED: Function-related definitions use ordered pairs, not UPair; functions are sets of ordered pairs (x,y), apply_fun looks up y with (x,y) ∈ f, identity is {(y,y)|y∈X}. **)
(** SUSPICIOUS DEFINITION: `apply_fun` is based on `Eps_i`, so `function_on` only constrains the chosen values, not that `f` is a genuine functional graph; later results about unions and preimages may require extra axioms. Use `total_function_on` when totality is required. **)
Definition apply_fun : set -> set -> set := fun f x => Eps_i (fun y => (x,y) :e f).
Definition function_on : set -> set -> set -> prop := fun f X Y => forall x:set, x :e X -> apply_fun f x :e Y.
Definition function_space : set -> set -> set := fun X Y => {f :e Power (setprod X Y)|function_on f X Y}.

(** helper: function_on restriction to smaller domain **)
Theorem function_on_restrict_dom : forall f X X' Y:set,
  function_on f X Y ->
  X' c= X ->
  function_on f X' Y.
let f X X' Y.
assume Hfun: function_on f X Y.
assume Hsub: X' c= X.
let x. assume HxX': x :e X'.
exact (Hfun x (Hsub x HxX')).
Qed.

(** helper: extract function_on from function_space membership **)
Theorem function_on_of_function_space : forall f X Y:set,
  f :e function_space X Y -> function_on f X Y.
let f X Y.
assume Hf: f :e function_space X Y.
exact (SepE2 (Power (setprod X Y)) (fun g:set => function_on g X Y) f Hf).
Qed.

(** from §18 Continuous Functions: set-theoretic encoding of functions **)
(** LATEX VERSION: A function is single-valued: if f(x)=y1 and f(x)=y2 then y1=y2. **)
(** Helper: a functional graph is single valued **)
Definition functional_graph : set -> prop :=
  fun f => forall x y1 y2:set, (x,y1) :e f -> (x,y2) :e f -> y1 = y2.

(** from §18 Continuous Functions: domain and codomain restrictions for graphs **)
(** LATEX VERSION: A function f:X→Y has domain contained in X and range contained in Y. **)
(** Helper: graph domain restriction **)
Definition graph_domain_subset : set -> set -> prop :=
  fun f X => forall x y:set, (x,y) :e f -> x :e X.

(** from §18 Continuous Functions: domain and codomain restrictions for graphs **)
(** LATEX VERSION: A function f:X→Y has domain contained in X and range contained in Y. **)
(** Helper: graph range restriction **)
Definition graph_range_subset : set -> set -> prop :=
  fun f Y => forall x y:set, (x,y) :e f -> y :e Y.

(** Helper: a graph comprehension has domain subset of its index set **)
Theorem graph_domain_subset_graph : forall A:set, forall g:set->set,
  graph_domain_subset {(a, g a)|a :e A} A.
let A g.
let x y.
assume Hxy: (x,y) :e {(a, g a)|a :e A}.
prove x :e A.
apply (ReplE_impred A (fun a0:set => (a0, g a0)) (x,y) Hxy (x :e A)).
let a. assume Ha: a :e A.
assume Heq: (x,y) = (a, g a).
claim Hxa: x = a.
{ rewrite <- (tuple_2_0_eq x y).
  rewrite <- (tuple_2_0_eq a (g a)).
  rewrite Heq.
  reflexivity. }
rewrite Hxa.
exact Ha.
Qed.

(** Helper: a constant graph comprehension has domain subset of its index set **)
Theorem graph_domain_subset_const_fun : forall A c:set,
  graph_domain_subset {(a,c)|a :e A} A.
let A c.
let x y.
assume Hxy: (x,y) :e {(a,c)|a :e A}.
prove x :e A.
apply (ReplE_impred A (fun a0:set => (a0,c)) (x,y) Hxy (x :e A)).
let a. assume Ha: a :e A.
assume Heq: (x,y) = (a,c).
claim Hxa: x = a.
{ rewrite <- (tuple_2_0_eq x y).
  rewrite <- (tuple_2_0_eq a c).
  rewrite Heq.
  reflexivity. }
rewrite Hxa.
exact Ha.
Qed.

(** Helper: a graph comprehension has range subset under a pointwise condition **)
Theorem graph_range_subset_graph : forall A Y:set, forall g:set->set,
  (forall a:set, a :e A -> g a :e Y) ->
  graph_range_subset {(a, g a)|a :e A} Y.
let A Y g.
assume HgY: forall a:set, a :e A -> g a :e Y.
let x y.
assume Hxy: (x,y) :e {(a, g a)|a :e A}.
prove y :e Y.
apply (ReplE_impred A (fun a0:set => (a0, g a0)) (x,y) Hxy (y :e Y)).
let a. assume Ha: a :e A.
assume Heq: (x,y) = (a, g a).
claim Hyg: y = g a.
{ rewrite <- (tuple_2_1_eq x y).
  rewrite <- (tuple_2_1_eq a (g a)).
  rewrite Heq.
  reflexivity. }
rewrite Hyg.
exact (HgY a Ha).
Qed.

(** Helper: a constant graph comprehension has range subset **)
Theorem graph_range_subset_const_fun : forall A Y c:set,
  c :e Y ->
  graph_range_subset {(a,c)|a :e A} Y.
let A Y c.
assume HcY: c :e Y.
let x y.
assume Hxy: (x,y) :e {(a,c)|a :e A}.
prove y :e Y.
apply (ReplE_impred A (fun a0:set => (a0,c)) (x,y) Hxy (y :e Y)).
let a. assume Ha: a :e A.
assume Heq: (x,y) = (a,c).
claim Hyc: y = c.
{ rewrite <- (tuple_2_1_eq x y).
  rewrite <- (tuple_2_1_eq a c).
  rewrite Heq.
  reflexivity. }
rewrite Hyc.
exact HcY.
Qed.

(** Helper: a graph comprehension is functional **)
Theorem functional_graph_graph : forall A:set, forall g:set->set,
  functional_graph {(a, g a)|a :e A}.
let A g.
let x y1 y2.
assume H1: (x,y1) :e {(a, g a)|a :e A}.
assume H2: (x,y2) :e {(a, g a)|a :e A}.
apply (ReplE_impred A (fun a0:set => (a0, g a0)) (x,y1) H1 (y1 = y2)).
let a1. assume Ha1: a1 :e A.
assume Heq1: (x,y1) = (a1, g a1).
apply (ReplE_impred A (fun a0:set => (a0, g a0)) (x,y2) H2 (y1 = y2)).
let a2. assume Ha2: a2 :e A.
assume Heq2: (x,y2) = (a2, g a2).
claim Hx1: x = a1.
{ rewrite <- (tuple_2_0_eq x y1).
  rewrite <- (tuple_2_0_eq a1 (g a1)).
  rewrite Heq1.
  reflexivity. }
claim Hx2: x = a2.
{ rewrite <- (tuple_2_0_eq x y2).
  rewrite <- (tuple_2_0_eq a2 (g a2)).
  rewrite Heq2.
  reflexivity. }
claim Ha12: a1 = a2.
{ rewrite <- Hx1.
  rewrite Hx2.
  reflexivity. }
claim Hy1: y1 = g a1.
{ rewrite <- (tuple_2_1_eq x y1).
  rewrite <- (tuple_2_1_eq a1 (g a1)).
  rewrite Heq1.
  reflexivity. }
claim Hy2: y2 = g a2.
{ rewrite <- (tuple_2_1_eq x y2).
  rewrite <- (tuple_2_1_eq a2 (g a2)).
  rewrite Heq2.
  reflexivity. }
rewrite Hy1.
rewrite Hy2.
rewrite <- Ha12.
reflexivity.
Qed.

(** Helper: a constant graph comprehension is functional **)
Theorem functional_graph_const_fun : forall A c:set,
  functional_graph {(a,c)|a :e A}.
let A c.
let x y1 y2.
assume H1: (x,y1) :e {(a,c)|a :e A}.
assume H2: (x,y2) :e {(a,c)|a :e A}.
apply (ReplE_impred A (fun a0:set => (a0,c)) (x,y1) H1 (y1 = y2)).
let a1. assume Ha1: a1 :e A.
assume Heq1: (x,y1) = (a1,c).
apply (ReplE_impred A (fun a0:set => (a0,c)) (x,y2) H2 (y1 = y2)).
let a2. assume Ha2: a2 :e A.
assume Heq2: (x,y2) = (a2,c).
claim Hy1: y1 = c.
{ rewrite <- (tuple_2_1_eq x y1).
  rewrite <- (tuple_2_1_eq a1 c).
  rewrite Heq1.
  reflexivity. }
claim Hy2: y2 = c.
{ rewrite <- (tuple_2_1_eq x y2).
  rewrite <- (tuple_2_1_eq a2 c).
  rewrite Heq2.
  reflexivity. }
rewrite Hy1.
rewrite Hy2.
reflexivity.
Qed.

(** Helper: if a value exists in the graph, apply_fun yields a value in the graph **)
Theorem apply_fun_in_graph_of_ex : forall f x:set,
  (exists y:set, (x,y) :e f) ->
  (x, apply_fun f x) :e f.
let f x.
assume Hex: exists y:set, (x,y) :e f.
prove (x, apply_fun f x) :e f.
exact (Eps_i_ex (fun y:set => (x,y) :e f) Hex).
Qed.

(** Helper: for a functional graph, apply_fun equals any value in the graph **)
Theorem functional_graph_apply_fun_eq : forall f x y:set,
  functional_graph f ->
  (x,y) :e f ->
  apply_fun f x = y.
let f x y.
assume Hfun: functional_graph f.
assume Hxy: (x,y) :e f.
claim Happ: (x, apply_fun f x) :e f.
{ exact (Eps_i_ax (fun y0:set => (x,y0) :e f) y Hxy). }
exact (Hfun x (apply_fun f x) y Happ Hxy).
Qed.

(** Helper: domain subset preserved under binary union **)
Theorem graph_domain_subset_binunion : forall A B f g:set,
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  graph_domain_subset (f :\/: g) (A :\/: B).
let A B f g.
assume Hdf: graph_domain_subset f A.
assume Hdg: graph_domain_subset g B.
let x y.
assume Hxy: (x,y) :e (f :\/: g).
prove x :e (A :\/: B).
apply (binunionE f g (x,y) Hxy).
- assume Hxyf: (x,y) :e f.
  claim HxA: x :e A.
  { exact (Hdf x y Hxyf). }
  exact (binunionI1 A B x HxA).
- assume Hxyg: (x,y) :e g.
  claim HxB: x :e B.
  { exact (Hdg x y Hxyg). }
  exact (binunionI2 A B x HxB).
Qed.

(** Helper: range subset preserved under binary union **)
Theorem graph_range_subset_binunion : forall f g Y:set,
  graph_range_subset f Y ->
  graph_range_subset g Y ->
  graph_range_subset (f :\/: g) Y.
let f g Y.
assume Hrf: graph_range_subset f Y.
assume Hrg: graph_range_subset g Y.
let x y.
assume Hxy: (x,y) :e (f :\/: g).
apply (binunionE f g (x,y) Hxy).
- assume Hxyf: (x,y) :e f.
  exact (Hrf x y Hxyf).
- assume Hxyg: (x,y) :e g.
  exact (Hrg x y Hxyg).
Qed.

(** Helper: build function_on from pointwise totality and range subset **)
Theorem function_on_from_totality_and_range : forall X Y f:set,
  (forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f) ->
  graph_range_subset f Y ->
  function_on f X Y.
let X Y f.
assume Htot: forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f.
assume Hrange: graph_range_subset f Y.
let x. assume HxX: x :e X.
prove apply_fun f x :e Y.
claim Hex: exists y:set, (x,y) :e f.
{ apply (Htot x HxX).
  let y. assume Hy: y :e Y /\ (x,y) :e f.
  witness y.
  exact (andER (y :e Y) ((x,y) :e f) Hy). }
claim Hpair: (x, apply_fun f x) :e f.
{ exact (apply_fun_in_graph_of_ex f x Hex). }
exact (Hrange x (apply_fun f x) Hpair).
Qed.

(** from §18 Continuous Functions: set theoretic graphs of functions **)
(** LATEX VERSION: A function may be identified with its graph, the set of ordered pairs (x,f(x)). **)
(** Helper: graph of a meta level function as a set of ordered pairs **)
Definition graph : set -> (set -> set) -> set := fun A g => {(a, g a) | a :e A}.

(** Helper: evaluating apply_fun on a graph built by Repl **)
Theorem apply_fun_graph : forall A:set, forall g:set->set, forall a:set,
  a :e A -> apply_fun (graph A g) a = g a.
let A g a.
assume Ha: a :e A.
prove apply_fun (graph A g) a = g a.
prove Eps_i (fun y => (a,y) :e graph A g) = g a.
claim H1: (a, g a) :e graph A g.
{ exact (ReplI A (fun a0:set => (a0, g a0)) a Ha). }
claim H2: (a, Eps_i (fun y => (a,y) :e graph A g)) :e graph A g.
{ exact (Eps_i_ax (fun y => (a,y) :e graph A g) (g a) H1). }
apply (ReplE_impred A (fun a0:set => (a0, g a0))
        (a, Eps_i (fun y => (a,y) :e graph A g)) H2
        (Eps_i (fun y => (a,y) :e graph A g) = g a)).
let a0. assume Ha0: a0 :e A.
assume Heq: (a, Eps_i (fun y => (a,y) :e graph A g)) = (a0, g a0).
claim Ha_eq: a = a0.
{ rewrite <- (tuple_2_0_eq a (Eps_i (fun y => (a,y) :e graph A g))).
  rewrite <- (tuple_2_0_eq a0 (g a0)).
  rewrite Heq.
  reflexivity. }
claim Hy_eq: Eps_i (fun y => (a,y) :e graph A g) = g a0.
{ rewrite <- (tuple_2_1_eq a (Eps_i (fun y => (a,y) :e graph A g))).
  rewrite <- (tuple_2_1_eq a0 (g a0)).
  rewrite Heq.
  reflexivity. }
rewrite Hy_eq.
rewrite <- Ha_eq.
reflexivity.
Qed.

(** from §18 Continuous Functions: functions defined on all points **)
(** LATEX VERSION: A function f:X->Y assigns a value f(x) in Y for each x in X. **)
(** Helper: total function graph on X into Y (in addition to function_on) **)
Definition total_function_on : set -> set -> set -> prop := fun f X Y =>
  function_on f X Y /\ forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f.

(** Helper: total_function_on implies function_on **)
Theorem total_function_on_function_on : forall f X Y:set,
  total_function_on f X Y -> function_on f X Y.
let f X Y.
assume H: total_function_on f X Y.
exact (andEL (function_on f X Y)
             (forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f)
             H).
Qed.

(** Helper: total_function_on gives a graph witness for each x **)
Theorem total_function_on_totality : forall f X Y:set,
  total_function_on f X Y ->
  forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f.
let f X Y.
assume H: total_function_on f X Y.
exact (andER (function_on f X Y)
             (forall x:set, x :e X -> exists y:set, y :e Y /\ (x,y) :e f)
             H).
Qed.

(** Helper: total_function_on gives membership of the chosen value in the graph **)
Theorem total_function_on_apply_fun_in_graph : forall f X Y x:set,
  total_function_on f X Y ->
  x :e X ->
  (x, apply_fun f x) :e f.
let f X Y x.
assume Htot: total_function_on f X Y.
assume HxX: x :e X.
prove (x, apply_fun f x) :e f.
claim Hex: exists y:set, y :e Y /\ (x,y) :e f.
{ exact (total_function_on_totality f X Y Htot x HxX). }
set y0 := Eps_i (fun y:set => y :e Y /\ (x,y) :e f).
claim Hy0: y0 :e Y /\ (x,y0) :e f.
{ exact (Eps_i_ex (fun y:set => y :e Y /\ (x,y) :e f) Hex). }
claim Hxy0: (x,y0) :e f.
{ exact (andER (y0 :e Y) ((x,y0) :e f) Hy0). }
exact (Eps_i_ax (fun y:set => (x,y) :e f) y0 Hxy0).
Qed.

(** Helper: total_function_on implies apply_fun lands in Y **)
Theorem total_function_on_apply_fun_in_Y : forall f X Y x:set,
  total_function_on f X Y ->
  x :e X ->
  apply_fun f x :e Y.
let f X Y x.
assume Htot: total_function_on f X Y.
assume HxX: x :e X.
claim Hfun: function_on f X Y.
{ exact (total_function_on_function_on f X Y Htot). }
exact (Hfun x HxX).
Qed.

(** Helper: range subset from totality and functionality **)
Theorem graph_range_subset_from_total_functional : forall A Y f:set,
  graph_domain_subset f A ->
  total_function_on f A Y ->
  functional_graph f ->
  graph_range_subset f Y.
let A Y f.
assume Hdom: graph_domain_subset f A.
assume Htot: total_function_on f A Y.
assume Hfun: functional_graph f.
let x y.
assume Hxy: (x,y) :e f.
prove y :e Y.
claim HxA: x :e A.
{ exact (Hdom x y Hxy). }
claim HappY: apply_fun f x :e Y.
{ exact (total_function_on_apply_fun_in_Y f A Y x Htot HxA). }
claim HappEq: apply_fun f x = y.
{ exact (functional_graph_apply_fun_eq f x y Hfun Hxy). }
rewrite <- HappEq.
exact HappY.
Qed.

(** from §18 Continuous Functions: constant functions **)
(** LATEX VERSION: A constant function on A takes every a in A to the same value x. **)
(** Helper: constant function as a graph **)
Definition const_fun : set -> set -> set := fun A x => {(a,x) | a :e A}.

(** Helper: apply_fun for const_fun **)
Theorem const_fun_apply : forall A x a:set,
  a :e A ->
  apply_fun (const_fun A x) a = x.
let A x a.
assume Ha: a :e A.
prove apply_fun (const_fun A x) a = x.
prove Eps_i (fun y => (a,y) :e const_fun A x) = x.
claim H1: (a,x) :e const_fun A x.
{ exact (ReplI A (fun a0:set => (a0,x)) a Ha). }
claim H2: (a, Eps_i (fun y => (a,y) :e const_fun A x)) :e const_fun A x.
{ exact (Eps_i_ax (fun y => (a,y) :e const_fun A x) x H1). }
apply (ReplE_impred A (fun a0:set => (a0,x)) (a, Eps_i (fun y => (a,y) :e const_fun A x)) H2).
let a0.
assume Ha0: a0 :e A.
assume Heq: (a, Eps_i (fun y => (a,y) :e const_fun A x)) = (a0,x).
	rewrite <- (tuple_2_1_eq a (Eps_i (fun y => (a,y) :e const_fun A x))) at 1.
	rewrite <- (tuple_2_1_eq a0 x) at 2.
	rewrite Heq.
	reflexivity.
	Qed.

(** Helper: const_fun is total_function_on **)
Theorem const_fun_total_function_on : forall A Y x:set,
  x :e Y -> total_function_on (const_fun A x) A Y.
let A Y x.
assume HxY: x :e Y.
prove function_on (const_fun A x) A Y /\
  forall a:set, a :e A -> exists y:set, y :e Y /\ (a,y) :e const_fun A x.
apply andI.
- (** function_on **)
  let a. assume HaA: a :e A.
  prove apply_fun (const_fun A x) a :e Y.
  claim Happ: apply_fun (const_fun A x) a = x.
  { exact (const_fun_apply A x a HaA). }
  rewrite Happ.
  exact HxY.
- (** totality **)
  let a. assume HaA: a :e A.
  prove exists y:set, y :e Y /\ (a,y) :e const_fun A x.
  witness x.
  apply andI.
  + exact HxY.
  + exact (ReplI A (fun a0:set => (a0,x)) a HaA).
Qed.

		(** Helper: identity function application **)
Theorem identity_function_apply : forall X x:set,
  x :e X -> apply_fun {(y,y) | y :e X} x = x.
let X x. assume Hx: x :e X.
prove apply_fun {(y,y) | y :e X} x = x.
prove Eps_i (fun z => (x,z) :e {(y,y) | y :e X}) = x.
claim H1: (x,x) :e {(y,y) | y :e X}.
{ exact (ReplI X (fun y => (y,y)) x Hx). }
claim H2: (x, Eps_i (fun z => (x,z) :e {(y,y) | y :e X})) :e {(y,y) | y :e X}.
{ exact (Eps_i_ax (fun z => (x,z) :e {(y,y) | y :e X}) x H1). }
apply (ReplE_impred X (fun y => (y,y)) (x, Eps_i (fun z => (x,z) :e {(y,y) | y :e X})) H2).
let y.
assume Hy: y :e X.
assume Heq: (x, Eps_i (fun z => (x,z) :e {(y,y) | y :e X})) = (y,y).
claim Hx_eq: x = y.
{ rewrite <- (tuple_2_0_eq x (Eps_i (fun z => (x,z) :e {(y,y) | y :e X}))).
  rewrite <- (tuple_2_0_eq y y).
  rewrite Heq.
  reflexivity. }
claim Hz_eq: Eps_i (fun z => (x,z) :e {(y,y) | y :e X}) = y.
{ rewrite <- (tuple_2_1_eq x (Eps_i (fun z => (x,z) :e {(y,y) | y :e X}))).
  rewrite <- (tuple_2_1_eq y y).
  rewrite Heq.
  reflexivity. }
rewrite Hz_eq.
rewrite <- Hx_eq.
reflexivity.
Qed.

(** Helper: identity graph is total_function_on **)
Theorem identity_total_function_on : forall X:set,
  total_function_on {(y,y) | y :e X} X X.
let X.
prove function_on {(y,y) | y :e X} X X /\
  forall x:set, x :e X -> exists y:set, y :e X /\ (x,y) :e {(y,y) | y :e X}.
apply andI.
- let x. assume HxX: x :e X.
  prove apply_fun {(y,y) | y :e X} x :e X.
  rewrite (identity_function_apply X x HxX).
  exact HxX.
- let x. assume HxX: x :e X.
  prove exists y:set, y :e X /\ (x,y) :e {(y,y) | y :e X}.
  witness x.
  apply andI.
  + exact HxX.
  + exact (ReplI X (fun y0:set => (y0,y0)) x HxX).
Qed.

(** from §19 The Product Topology: constant families in products **)
(** LATEX VERSION: In cartesian products, one often considers the constant family taking each index i to the same space X. **)
Definition const_family : set -> set -> set := fun I X => {(i,X)|i :e I}.

(** Helper: apply_fun for const_family **)
Theorem const_family_apply : forall I X i:set,
  i :e I -> apply_fun (const_family I X) i = X.
let I X i.
assume Hi: i :e I.
prove apply_fun (const_family I X) i = X.
exact (const_fun_apply I X i Hi).
Qed.

(** from §19 The Product Topology: extracting components of a family of spaces **)
(** LATEX VERSION: A product consists of a family of spaces X_i with topologies; we refer to the i-th factor and its topology. **)
Definition product_component : set -> set -> set := fun Xi i => (apply_fun Xi i) 0.

(** from §19 The Product Topology: extracting components of a family of spaces **)
(** LATEX VERSION: A product consists of a family of spaces X_i with topologies; we refer to the i-th factor and its topology. **)
Definition product_component_topology : set -> set -> set := fun Xi i => (apply_fun Xi i) 1.

(** Helper: unfold product_component and product_component_topology **)
Theorem product_component_def : forall Xi i:set,
  product_component Xi i = (apply_fun Xi i) 0.
let Xi i.
prove product_component Xi i = (apply_fun Xi i) 0.
reflexivity.
Qed.

Theorem product_component_topology_def : forall Xi i:set,
  product_component_topology Xi i = (apply_fun Xi i) 1.
let Xi i.
prove product_component_topology Xi i = (apply_fun Xi i) 1.
reflexivity.
Qed.

(** from §19 The Product Topology: a family of topological spaces indexed by I **)
(** LATEX VERSION: Consider a cartesian product of a family of spaces; we package each space X_i with its topology. **)
(** family of spaces as a family of pairs (X_i, T_i) **)
Definition const_space_family : set -> set -> set -> set := fun I X Tx =>
  {(i,(X,Tx))|i :e I}.

(** Helper: apply_fun for const_space_family **)
Theorem const_space_family_apply : forall I X Tx i:set,
  i :e I -> apply_fun (const_space_family I X Tx) i = (X,Tx).
let I X Tx i.
assume Hi: i :e I.
prove apply_fun (const_space_family I X Tx) i = (X,Tx).
exact (const_fun_apply I (X,Tx) i Hi).
Qed.

(** from §19 The Product Topology: component space and component topology **)
(** LATEX VERSION: For a family Xi, each index i determines a space X_i and a topology T_i. **)
Definition space_family_set : set -> set -> set := fun Xi i => (apply_fun Xi i) 0.

(** from §19 The Product Topology: component space and component topology **)
(** LATEX VERSION: For a family Xi, each index i determines a space X_i and a topology T_i. **)
Definition space_family_topology : set -> set -> set := fun Xi i => (apply_fun Xi i) 1.

(** helper: constant space family component carrier **)
Theorem space_family_set_const_space_family : forall I X Tx i:set,
  i :e I ->
  space_family_set (const_space_family I X Tx) i = X.
let I X Tx i.
assume Hi: i :e I.
prove space_family_set (const_space_family I X Tx) i = X.
claim Hsf: space_family_set (const_space_family I X Tx) i = (apply_fun (const_space_family I X Tx) i) 0.
{ reflexivity. }
rewrite Hsf.
rewrite (const_space_family_apply I X Tx i Hi).
exact (tuple_2_0_eq X Tx).
Qed.

(** helper: constant space family component topology **)
Theorem space_family_topology_const_space_family : forall I X Tx i:set,
  i :e I ->
  space_family_topology (const_space_family I X Tx) i = Tx.
let I X Tx i.
assume Hi: i :e I.
prove space_family_topology (const_space_family I X Tx) i = Tx.
claim Hsf: space_family_topology (const_space_family I X Tx) i = (apply_fun (const_space_family I X Tx) i) 1.
{ reflexivity. }
rewrite Hsf.
rewrite (const_space_family_apply I X Tx i Hi).
exact (tuple_2_1_eq X Tx).
Qed.

(** from §19 The Product Topology: union of component carriers **)
(** LATEX VERSION: We take the union of all component spaces X_i as an ambient codomain for product functions. **)
Definition space_family_union : set -> set -> set := fun I Xi =>
  Union {space_family_set Xi i|i :e I}.

(** from §19 The Product Topology: union of component topology families **)
(** LATEX VERSION: We take the union of all component topologies T_i as an ambient codomain for cylinder parameters. **)
Definition topology_family_union : set -> set -> set := fun I Xi =>
  Union {space_family_topology Xi i|i :e I}.

(** from §19 The Product Topology: cartesian product as a set of choice functions **)
(** LATEX VERSION: The cartesian product consists of all functions f with f(i) in X_i for each index i. **)
Definition product_space : set -> set -> set := fun I Xi =>
  {f :e Power (setprod I (space_family_union I Xi))|
     total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
     forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i}.
(** FIXED: product_space elements are total functional graphs I -> space_family_union, matching the intended set-theoretic product and avoiding Eps-choice pathologies. **)
(** from §19 The Product Topology: subbasis elements via projections **)
(** LATEX VERSION: Subbasis elements have the form pi_i^{-1}(U_i), restricting only the i-th coordinate to lie in an open set U_i. **)
Definition product_cylinder : set -> set -> set -> set -> set :=
  fun I Xi i U =>
    {f :e product_space I Xi | i :e I /\ U :e space_family_topology Xi i /\ apply_fun f i :e U}.

(** from §19 The Product Topology: product topology subbasis **)
(** LATEX VERSION: The product topology is generated by the subbasis of all inverse images of opens under coordinate projections. **)
Definition product_subbasis_full : set -> set -> set :=
  fun I Xi => \/_ i :e I, {product_cylinder I Xi i U|U :e space_family_topology Xi i}.

(** from §19 The Product Topology: product topology on an indexed product **)
(** LATEX VERSION: The product topology is the topology generated by the projection subbasis. **)
Definition product_topology_full : set -> set -> set := fun I Xi =>
  generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
(** FIXED: Was using Power set which generates discrete topology, not box topology; now box_topology is generated from the box_basis (products of opens in each component). **)
(** from §19 The Product Topology: box topology on an indexed product **)
(** LATEX VERSION: The box topology has as basis all products of open sets in each coordinate, with no finiteness restriction. **)
Definition box_basis : set -> set -> set := fun I Xi =>
  {B :e Power (product_space I Xi) |
    exists U:set, total_function_on U I (topology_family_union I Xi) /\ functional_graph U /\
      (forall i:set, i :e I -> apply_fun U i :e space_family_topology Xi i) /\
      B = {f :e product_space I Xi | forall i:set, i :e I -> apply_fun f i :e apply_fun U i}}.
(** FIXED: box_basis witnesses are total functional graphs U:I->(union of component topologies), ensuring `apply_fun U i` is backed by an actual graph element. **)
(** from §19 The Product Topology: box topology generated by box_basis **)
(** LATEX VERSION: The box topology is the topology generated by the box basis. **)
Definition box_topology : set -> set -> set := fun I Xi =>
  generated_topology (product_space I Xi) (box_basis I Xi).

(** from §19 The Product Topology: notation for countable products **)
(** LATEX VERSION: For countable index sets, we use the same product space and product topology constructions. **)
Definition countable_product_space : set -> set -> set := fun I Xi =>
  product_space I Xi.

(** from §19 The Product Topology: notation for countable products **)
(** LATEX VERSION: For countable index sets, we use the product topology on the product space. **)
Definition countable_product_topology : set -> set -> set := fun I Xi =>
  product_topology_full I Xi.

(** from §19 Example 1: Euclidean n space as a finite product of R **)
(** LATEX VERSION: Euclidean n space R^n is a finite cartesian product of copies of R with the product topology. **)
Definition euclidean_space : set -> set := fun n => product_space n (const_space_family n R R_standard_topology).

(** from §19 Example 1: Euclidean n space as a finite product of R **)
(** LATEX VERSION: Euclidean n space has the product topology, which agrees with the box topology in the finite case. **)
Definition euclidean_topology : set -> set := fun n => product_topology_full n (const_space_family n R R_standard_topology).

(** from §15 Example: standard topology on ℝ² as product topology **) 
(** LATEX VERSION: The standard topology on ℝ² coincides with the product of the standard topologies on ℝ. **)
Definition R2_standard_topology : set := product_topology R R_standard_topology R R_standard_topology.

Theorem R2_standard_equals_product :
  R2_standard_topology = product_topology R R_standard_topology R R_standard_topology.
prove R2_standard_topology = product_topology R R_standard_topology R R_standard_topology.
(** R2_standard_topology is defined as product_topology R R_standard_topology R R_standard_topology **)
reflexivity.
Qed.

(** helper: the usual open rectangle set equals the cartesian product of open intervals **)
(** LATEX VERSION: {(x,y) | a<x<b and c<y<d} = (a,b)×(c,d). **)
Theorem open_rectangle_set_eq_rectangle_set_intervals : forall a b c d:set,
  {p :e EuclidPlane|
     exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
    = rectangle_set (open_interval a b) (open_interval c d).
let a b c d.
apply set_ext.
- let p. assume Hp:
    p :e {p0 :e EuclidPlane|
           exists x y:set, p0 = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
  prove p :e rectangle_set (open_interval a b) (open_interval c d).
  claim Hex:
    exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d.
  { exact (SepE2 EuclidPlane
          (fun p0:set => exists x y:set, p0 = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d)
          p Hp). }
  apply Hex.
  let x. assume Hexy: exists y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d.
  apply Hexy.
  let y. assume Hcore: p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d.
  claim Hleft4: p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y.
  { exact (andEL (p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y) (Rlt y d) Hcore). }
  claim Hyd: Rlt y d.
  { exact (andER (p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y) (Rlt y d) Hcore). }
  claim Hleft3: p = (x,y) /\ Rlt a x /\ Rlt x b.
  { exact (andEL (p = (x,y) /\ Rlt a x /\ Rlt x b) (Rlt c y) Hleft4). }
  claim Hcy: Rlt c y.
  { exact (andER (p = (x,y) /\ Rlt a x /\ Rlt x b) (Rlt c y) Hleft4). }
  claim Hleft2: p = (x,y) /\ Rlt a x.
  { exact (andEL (p = (x,y) /\ Rlt a x) (Rlt x b) Hleft3). }
  claim Hxb: Rlt x b.
  { exact (andER (p = (x,y) /\ Rlt a x) (Rlt x b) Hleft3). }
  claim Hpeq: p = (x,y).
  { exact (andEL (p = (x,y)) (Rlt a x) Hleft2). }
  claim Hax: Rlt a x.
  { exact (andER (p = (x,y)) (Rlt a x) Hleft2). }
  claim HxR: x :e R.
  { exact (RltE_right a x Hax). }
  claim HyR: y :e R.
  { exact (RltE_right c y Hcy). }
  claim HxIn: x :e open_interval a b.
  { exact (SepI R (fun z:set => Rlt a z /\ Rlt z b) x HxR (andI (Rlt a x) (Rlt x b) Hax Hxb)). }
  claim HyIn: y :e open_interval c d.
  { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) y HyR (andI (Rlt c y) (Rlt y d) Hcy Hyd)). }
  rewrite Hpeq.
  exact (tuple_2_rectangle_set (open_interval a b) (open_interval c d) x y HxIn HyIn).
- let p. assume Hp: p :e rectangle_set (open_interval a b) (open_interval c d).
  prove p :e {p0 :e EuclidPlane|
               exists x y:set, p0 = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
  claim HpUV: p :e setprod (open_interval a b) (open_interval c d).
  { rewrite rectangle_set_def. exact Hp. }
  claim Hp0U: p 0 :e open_interval a b.
  { exact (ap0_Sigma (open_interval a b) (fun _ : set => open_interval c d) p HpUV). }
  claim Hp1V: p 1 :e open_interval c d.
  { exact (ap1_Sigma (open_interval a b) (fun _ : set => open_interval c d) p HpUV). }
  claim Hp0R: p 0 :e R.
  { exact (SepE1 R (fun z:set => Rlt a z /\ Rlt z b) (p 0) Hp0U). }
  claim Hp1R: p 1 :e R.
  { exact (SepE1 R (fun z:set => Rlt c z /\ Rlt z d) (p 1) Hp1V). }
  claim HpEta: p = (p 0, p 1).
  { exact (setprod_eta (open_interval a b) (open_interval c d) p HpUV). }
  claim HpE: p :e EuclidPlane.
  { rewrite HpEta.
    exact (tuple_2_setprod_by_pair_Sigma R R (p 0) (p 1) Hp0R Hp1R). }
  claim Hp0ineq: Rlt a (p 0) /\ Rlt (p 0) b.
  { exact (SepE2 R (fun z:set => Rlt a z /\ Rlt z b) (p 0) Hp0U). }
  claim Hp1ineq: Rlt c (p 1) /\ Rlt (p 1) d.
  { exact (SepE2 R (fun z:set => Rlt c z /\ Rlt z d) (p 1) Hp1V). }
  claim Hap0: Rlt a (p 0).
  { exact (andEL (Rlt a (p 0)) (Rlt (p 0) b) Hp0ineq). }
  claim Hp0b: Rlt (p 0) b.
  { exact (andER (Rlt a (p 0)) (Rlt (p 0) b) Hp0ineq). }
  claim Hcp1: Rlt c (p 1).
  { exact (andEL (Rlt c (p 1)) (Rlt (p 1) d) Hp1ineq). }
  claim Hp1d: Rlt (p 1) d.
  { exact (andER (Rlt c (p 1)) (Rlt (p 1) d) Hp1ineq). }
  claim Hpred: exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d.
  { witness (p 0).
    witness (p 1).
    apply and5I.
    - exact HpEta.
    - exact Hap0.
    - exact Hp0b.
    - exact Hcp1.
    - exact Hp1d. }
  exact (SepI EuclidPlane
            (fun p0:set =>
              exists x y:set, p0 = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d)
            p
            HpE
            Hpred).
Qed.

(** helper: an open rectangle is open in the standard topology on R^2 **)
(** LATEX VERSION: If a<b and c<d, then (a,b)×(c,d) is open in the product topology on ℝ². **)
Theorem open_rectangle_in_R2_standard_topology : forall a b c d:set,
  Rlt a b -> Rlt c d ->
  {p :e EuclidPlane|
     exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}
    :e R2_standard_topology.
let a b c d.
assume Hab: Rlt a b.
assume Hcd: Rlt c d.
rewrite (open_rectangle_set_eq_rectangle_set_intervals a b c d).
claim HU: open_interval a b :e R_standard_topology.
{ exact (open_interval_in_R_standard_topology a b Hab). }
claim HV: open_interval c d :e R_standard_topology.
{ exact (open_interval_in_R_standard_topology c d Hcd). }
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HrectInFam: rectangle_set (open_interval a b) (open_interval c d)
  :e {rectangle_set (open_interval a b) V|V :e R_standard_topology}.
{ exact (ReplI R_standard_topology (fun V0:set => rectangle_set (open_interval a b) V0)
         (open_interval c d) HV). }
claim HrectInSub: rectangle_set (open_interval a b) (open_interval c d)
  :e product_subbasis R R_standard_topology R R_standard_topology.
{ exact (famunionI R_standard_topology
         (fun U0:set => {rectangle_set U0 V|V :e R_standard_topology})
         (open_interval a b)
         (rectangle_set (open_interval a b) (open_interval c d))
         HU
         HrectInFam). }
claim HrectPow: rectangle_set (open_interval a b) (open_interval c d) :e Power (setprod R R).
{ apply PowerI.
  let p. assume Hp: p :e rectangle_set (open_interval a b) (open_interval c d).
  prove p :e setprod R R.
  claim HpUV: p :e setprod (open_interval a b) (open_interval c d).
  { rewrite rectangle_set_def. exact Hp. }
  claim Hp0U: p 0 :e open_interval a b.
  { exact (ap0_Sigma (open_interval a b) (fun _ : set => open_interval c d) p HpUV). }
  claim Hp1V: p 1 :e open_interval c d.
  { exact (ap1_Sigma (open_interval a b) (fun _ : set => open_interval c d) p HpUV). }
  claim Hp0R: p 0 :e R.
  { exact (SepE1 R (fun z:set => Rlt a z /\ Rlt z b) (p 0) Hp0U). }
  claim Hp1R: p 1 :e R.
  { exact (SepE1 R (fun z:set => Rlt c z /\ Rlt z d) (p 1) Hp1V). }
  claim HpEta: p = (p 0, p 1).
  { exact (setprod_eta (open_interval a b) (open_interval c d) p HpUV). }
  rewrite HpEta.
  exact (tuple_2_setprod_by_pair_Sigma R R (p 0) (p 1) Hp0R Hp1R).
}
exact (generated_topology_contains_elem (setprod R R)
        (product_subbasis R R_standard_topology R R_standard_topology)
        (rectangle_set (open_interval a b) (open_interval c d))
        HrectPow
        HrectInSub).
Qed.

(** helper: every rectangular region is open in the standard topology on R^2 **)
(** LATEX VERSION: Every axis-parallel open rectangle (a,b)×(c,d) is open in the standard topology on ℝ². **)
Theorem rectangular_regions_subset_R2_standard_topology : forall U:set,
  U :e rectangular_regions -> U :e R2_standard_topology.
let U.
assume HU: U :e rectangular_regions.
prove U :e R2_standard_topology.
claim Hdesc:
  exists a b c d:set,
    a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
      U = {p :e EuclidPlane|
             exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
{ exact (SepE2 (Power EuclidPlane)
        (fun U0:set =>
          exists a0 b0 c0 d0:set,
            a0 :e R /\ b0 :e R /\ c0 :e R /\ d0 :e R /\ Rlt a0 b0 /\ Rlt c0 d0 /\
              U0 = {p :e EuclidPlane|
                     exists x y:set, p = (x,y) /\ Rlt a0 x /\ Rlt x b0 /\ Rlt c0 y /\ Rlt y d0})
        U HU). }
apply Hdesc.
let a. assume Hbex: exists b c d:set,
  a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
    U = {p :e EuclidPlane|
           exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
apply Hbex.
let b. assume Hcex: exists c d:set,
  a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
    U = {p :e EuclidPlane|
           exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
apply Hcex.
let c. assume Hdex: exists d:set,
  a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
    U = {p :e EuclidPlane|
           exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
apply Hdex.
let d. assume Hcore:
  a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d /\
    U = {p :e EuclidPlane|
           exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
claim Hleft6: a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d.
{ exact (andEL (a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d)
               (U = {p :e EuclidPlane|
                      exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d})
               Hcore). }
claim HUeq:
  U = {p :e EuclidPlane|
         exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d}.
{ exact (andER (a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b /\ Rlt c d)
               (U = {p :e EuclidPlane|
                      exists x y:set, p = (x,y) /\ Rlt a x /\ Rlt x b /\ Rlt c y /\ Rlt y d})
               Hcore). }
claim Hleft5: a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b.
{ exact (andEL (a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b) (Rlt c d) Hleft6). }
claim Hcd: Rlt c d.
{ exact (andER (a :e R /\ b :e R /\ c :e R /\ d :e R /\ Rlt a b) (Rlt c d) Hleft6). }
claim Hab: Rlt a b.
{ exact (andER (a :e R /\ b :e R /\ c :e R /\ d :e R) (Rlt a b) Hleft5). }
rewrite HUeq.
exact (open_rectangle_in_R2_standard_topology a b c d Hab Hcd).
Qed.

(** helper: topology generated by rectangular regions is contained in the standard topology on R^2 **)
(** LATEX VERSION: The topology generated by rectangular regions is no finer than the standard topology on ℝ². **)
Theorem generated_topology_rectangular_regions_sub_R2_standard_topology :
  generated_topology EuclidPlane rectangular_regions c= R2_standard_topology.
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HtopPlane: topology_on EuclidPlane R2_standard_topology.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology HtopR HtopR). }
claim Hall: forall U :e rectangular_regions, U :e R2_standard_topology.
{ let U. assume HU: U :e rectangular_regions.
  exact (rectangular_regions_subset_R2_standard_topology U HU). }
exact (generated_topology_finer_weak EuclidPlane rectangular_regions R2_standard_topology HtopPlane Hall).
Qed.

(** helper: rectangular regions generate the standard topology on R^2 **)
(** LATEX VERSION: The family of all rectangular regions (a,b)×(c,d) forms a basis that generates the standard topology on ℝ². **)
Theorem generated_topology_rectangular_regions_eq_R2_standard_topology :
  generated_topology EuclidPlane rectangular_regions = R2_standard_topology.
prove generated_topology EuclidPlane rectangular_regions = R2_standard_topology.
(** Use Lemma 13.2 / basis_refines_topology with the refinement property coming from the definition of product_topology as a generated topology. **)
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HtopPlane: topology_on EuclidPlane R2_standard_topology.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology HtopR HtopR). }
claim HCsub: forall Cx :e rectangular_regions, Cx :e R2_standard_topology.
{ let Cx. assume HCx: Cx :e rectangular_regions.
  exact (rectangular_regions_subset_R2_standard_topology Cx HCx). }

(** Main refinement: for any U open in R2_standard_topology and p∈U, find a rectangular region inside U containing p. **)
claim Href:
  forall U :e R2_standard_topology, forall p :e U,
    exists Cx :e rectangular_regions, p :e Cx /\ Cx c= U.
{ let U. assume HU: U :e R2_standard_topology.
  let p. assume HpU: p :e U.
  (** Unfold membership in the generated topology defining the product topology. **)
  claim HeqPlane: EuclidPlane = setprod R R.
  { reflexivity. }
  set B := product_subbasis R R_standard_topology R R_standard_topology.
  claim HUgenRR: U :e generated_topology (setprod R R) B.
  { (** R2_standard_topology = product_topology R R_standard_topology R R_standard_topology by definition **)
    claim Hdef: R2_standard_topology = generated_topology (setprod R R) B.
    { reflexivity. }
    rewrite Hdef.
    rewrite <- HeqPlane.
    exact HU. }
  claim HUgen: U :e generated_topology EuclidPlane B.
  { rewrite HeqPlane. exact HUgenRR. }
  claim HUsub: U c= EuclidPlane.
  { exact (generated_topology_subset EuclidPlane B U HUgen). }
  claim HpE: p :e EuclidPlane.
  { exact (HUsub p HpU). }
  claim HUprop:
    forall x :e U, exists b :e B, x :e b /\ b c= U.
  { exact (SepE2 (Power EuclidPlane)
          (fun U0:set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
          U HUgen). }
  claim Hexb: exists b :e B, p :e b /\ b c= U.
  { exact (HUprop p HpU). }
  apply Hexb.
  let b. assume Hbpair: b :e B /\ (p :e b /\ b c= U).
  claim HbB: b :e B.
  { exact (andEL (b :e B) (p :e b /\ b c= U) Hbpair). }
  claim Hbprop: p :e b /\ b c= U.
  { exact (andER (b :e B) (p :e b /\ b c= U) Hbpair). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= U) Hbprop). }
  claim HbsubU: b c= U.
  { exact (andER (p :e b) (b c= U) Hbprop). }

  (** Destruct b ∈ product_subbasis: b = U0×V0 with U0,V0 open in R. **)
  apply (famunionE_impred R_standard_topology
         (fun U0:set => {rectangle_set U0 V|V :e R_standard_topology})
         b HbB
         (exists Cx :e rectangular_regions, p :e Cx /\ Cx c= U)).
  let U0. assume HU0: U0 :e R_standard_topology.
  assume HbIn: b :e {rectangle_set U0 V|V :e R_standard_topology}.
  apply (ReplE_impred R_standard_topology (fun V0:set => rectangle_set U0 V0) b HbIn
         (exists Cx :e rectangular_regions, p :e Cx /\ Cx c= U)).
  let V0. assume HV0: V0 :e R_standard_topology.
  assume Hbeq: b = rectangle_set U0 V0.

  claim HpbUV: p :e rectangle_set U0 V0.
  { rewrite <- Hbeq. exact Hpb. }
  claim HpUV: p :e setprod U0 V0.
  { rewrite <- rectangle_set_def. exact HpbUV. }
  claim Hp0U0: p 0 :e U0.
  { exact (ap0_Sigma U0 (fun _ : set => V0) p HpUV). }
  claim Hp1V0: p 1 :e V0.
  { exact (ap1_Sigma U0 (fun _ : set => V0) p HpUV). }
  claim HpEta: p = (p 0, p 1).
  { exact (setprod_eta U0 V0 p HpUV). }

  (** Refine U0 around p0 using the standard basis on R. **)
  claim HU0gen: U0 :e generated_topology R R_standard_basis.
  { rewrite <- R_standard_topology_def_eq. exact HU0. }
  claim HU0prop: forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0.
  { exact (SepE2 (Power R)
          (fun U1:set => forall x0 :e U1, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U1)
          U0 HU0gen). }
  claim HexI1: exists I1 :e R_standard_basis, (p 0) :e I1 /\ I1 c= U0.
  { exact (HU0prop (p 0) Hp0U0). }
  apply HexI1.
  let I1. assume HI1pair: I1 :e R_standard_basis /\ ((p 0) :e I1 /\ I1 c= U0).
  claim HI1: I1 :e R_standard_basis.
  { exact (andEL (I1 :e R_standard_basis) ((p 0) :e I1 /\ I1 c= U0) HI1pair). }
  claim HI1prop: (p 0) :e I1 /\ I1 c= U0.
  { exact (andER (I1 :e R_standard_basis) ((p 0) :e I1 /\ I1 c= U0) HI1pair). }
  claim Hp0I1: (p 0) :e I1.
  { exact (andEL ((p 0) :e I1) (I1 c= U0) HI1prop). }
  claim HI1sub: I1 c= U0.
  { exact (andER ((p 0) :e I1) (I1 c= U0) HI1prop). }

  (** Extract I1 = open_interval a b1 with a,b1 ∈ R. **)
  claim Hexa: exists a :e R, I1 :e {open_interval a b|b :e R}.
  { exact (famunionE R (fun a0:set => {open_interval a0 b|b :e R}) I1 HI1). }
  apply Hexa.
  let a. assume Hapair: a :e R /\ I1 :e {open_interval a b|b :e R}.
  claim HaR: a :e R.
  { exact (andEL (a :e R) (I1 :e {open_interval a b|b :e R}) Hapair). }
  claim HI1fam: I1 :e {open_interval a b|b :e R}.
  { exact (andER (a :e R) (I1 :e {open_interval a b|b :e R}) Hapair). }
  claim Hexb1: exists b1 :e R, I1 = open_interval a b1.
  { exact (ReplE R (fun b0:set => open_interval a b0) I1 HI1fam). }
  apply Hexb1.
  let b1. assume Hb1pair: b1 :e R /\ I1 = open_interval a b1.
  claim Hb1R: b1 :e R.
  { exact (andEL (b1 :e R) (I1 = open_interval a b1) Hb1pair). }
  claim HI1eq: I1 = open_interval a b1.
  { exact (andER (b1 :e R) (I1 = open_interval a b1) Hb1pair). }
  claim Hp0InInt: (p 0) :e open_interval a b1.
  { rewrite <- HI1eq. exact Hp0I1. }
  claim Hp0ineq: Rlt a (p 0) /\ Rlt (p 0) b1.
  { exact (SepE2 R (fun z:set => Rlt a z /\ Rlt z b1) (p 0) Hp0InInt). }
  claim Hap0: Rlt a (p 0).
  { exact (andEL (Rlt a (p 0)) (Rlt (p 0) b1) Hp0ineq). }
  claim Hp0b1: Rlt (p 0) b1.
  { exact (andER (Rlt a (p 0)) (Rlt (p 0) b1) Hp0ineq). }
  claim Hab: Rlt a b1.
  { exact (Rlt_tra a (p 0) b1 Hap0 Hp0b1). }

  (** Refine V0 around p1 using the standard basis on R. **)
  claim HV0gen: V0 :e generated_topology R R_standard_basis.
  { rewrite <- R_standard_topology_def_eq. exact HV0. }
  claim HV0prop: forall y0 :e V0, exists J1 :e R_standard_basis, y0 :e J1 /\ J1 c= V0.
  { exact (SepE2 (Power R)
          (fun U1:set => forall x0 :e U1, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U1)
          V0 HV0gen). }
  claim HexI2: exists I2 :e R_standard_basis, (p 1) :e I2 /\ I2 c= V0.
  { exact (HV0prop (p 1) Hp1V0). }
  apply HexI2.
  let I2. assume HI2pair: I2 :e R_standard_basis /\ ((p 1) :e I2 /\ I2 c= V0).
  claim HI2: I2 :e R_standard_basis.
  { exact (andEL (I2 :e R_standard_basis) ((p 1) :e I2 /\ I2 c= V0) HI2pair). }
  claim HI2prop: (p 1) :e I2 /\ I2 c= V0.
  { exact (andER (I2 :e R_standard_basis) ((p 1) :e I2 /\ I2 c= V0) HI2pair). }
  claim Hp1I2: (p 1) :e I2.
  { exact (andEL ((p 1) :e I2) (I2 c= V0) HI2prop). }
  claim HI2sub: I2 c= V0.
  { exact (andER ((p 1) :e I2) (I2 c= V0) HI2prop). }

  claim Hexc: exists c :e R, I2 :e {open_interval c d|d :e R}.
  { exact (famunionE R (fun c0:set => {open_interval c0 d|d :e R}) I2 HI2). }
  apply Hexc.
  let c. assume Hcpair: c :e R /\ I2 :e {open_interval c d|d :e R}.
  claim HcR: c :e R.
  { exact (andEL (c :e R) (I2 :e {open_interval c d|d :e R}) Hcpair). }
  claim HI2fam: I2 :e {open_interval c d|d :e R}.
  { exact (andER (c :e R) (I2 :e {open_interval c d|d :e R}) Hcpair). }
  claim Hexd1: exists d1 :e R, I2 = open_interval c d1.
  { exact (ReplE R (fun d0:set => open_interval c d0) I2 HI2fam). }
  apply Hexd1.
  let d1. assume Hd1pair: d1 :e R /\ I2 = open_interval c d1.
  claim Hd1R: d1 :e R.
  { exact (andEL (d1 :e R) (I2 = open_interval c d1) Hd1pair). }
  claim HI2eq: I2 = open_interval c d1.
  { exact (andER (d1 :e R) (I2 = open_interval c d1) Hd1pair). }
  claim Hp1InInt: (p 1) :e open_interval c d1.
  { rewrite <- HI2eq. exact Hp1I2. }
  claim Hp1ineq: Rlt c (p 1) /\ Rlt (p 1) d1.
  { exact (SepE2 R (fun z:set => Rlt c z /\ Rlt z d1) (p 1) Hp1InInt). }
  claim Hcp1: Rlt c (p 1).
  { exact (andEL (Rlt c (p 1)) (Rlt (p 1) d1) Hp1ineq). }
  claim Hp1d1: Rlt (p 1) d1.
  { exact (andER (Rlt c (p 1)) (Rlt (p 1) d1) Hp1ineq). }
  claim Hcd: Rlt c d1.
  { exact (Rlt_tra c (p 1) d1 Hcp1 Hp1d1). }

  (** Define the refined rectangular region and show it lies inside U. **)
  set Rg := {q :e EuclidPlane|
               exists x y:set, q = (x,y) /\ Rlt a x /\ Rlt x b1 /\ Rlt c y /\ Rlt y d1}.
  claim HRgRect: Rg :e rectangular_regions.
  { exact (rectangular_regionI a b1 c d1 HaR Hb1R HcR Hd1R Hab Hcd). }
  claim HpRg: p :e Rg.
  { rewrite HpEta.
    claim Hp0R: (p 0) :e R.
    { exact (SepE1 R (fun z:set => Rlt a z /\ Rlt z b1) (p 0) Hp0InInt). }
    claim Hp1R: (p 1) :e R.
    { exact (SepE1 R (fun z:set => Rlt c z /\ Rlt z d1) (p 1) Hp1InInt). }
    claim HpE2: (p 0, p 1) :e EuclidPlane.
    { claim HeqPlane2: EuclidPlane = setprod R R.
      { reflexivity. }
      rewrite HeqPlane2.
      exact (tuple_2_setprod_by_pair_Sigma R R (p 0) (p 1) Hp0R Hp1R). }
    claim Hpred:
      exists x y:set, (p 0, p 1) = (x,y) /\ Rlt a x /\ Rlt x b1 /\ Rlt c y /\ Rlt y d1.
    { witness (p 0).
      witness (p 1).
      apply and5I.
      - reflexivity.
      - exact Hap0.
      - exact Hp0b1.
      - exact Hcp1.
      - exact Hp1d1. }
    exact (SepI EuclidPlane
            (fun q0:set => exists x y:set, q0 = (x,y) /\ Rlt a x /\ Rlt x b1 /\ Rlt c y /\ Rlt y d1)
            (p 0, p 1)
            HpE2
            Hpred). }

  claim HRgSubb: Rg c= b.
  { (** Rg = open rectangle = rectangle_set(open_interval a b1)(open_interval c d1) and subsets preserve product. **)
    claim HI1subU0: open_interval a b1 c= U0.
    { rewrite <- HI1eq. exact HI1sub. }
    claim HI2subV0: open_interval c d1 c= V0.
    { rewrite <- HI2eq. exact HI2sub. }
    claim HsetprodSub: setprod (open_interval a b1) (open_interval c d1) c= setprod U0 V0.
    { exact (setprod_Subq (open_interval a b1) (open_interval c d1) U0 V0 HI1subU0 HI2subV0). }
    claim HrectSub: rectangle_set (open_interval a b1) (open_interval c d1) c= rectangle_set U0 V0.
    { rewrite rectangle_set_def.
      rewrite rectangle_set_def.
      exact HsetprodSub. }
    let q. assume HqRg: q :e Rg.
    prove q :e b.
    claim HqRect: q :e rectangle_set (open_interval a b1) (open_interval c d1).
    { rewrite <- (open_rectangle_set_eq_rectangle_set_intervals a b1 c d1).
      exact HqRg. }
    claim HqInUV: q :e rectangle_set U0 V0.
    { exact (HrectSub q HqRect). }
    rewrite Hbeq.
    exact HqInUV. }
  claim HRgSubU: Rg c= U.
  { exact (Subq_tra Rg b U HRgSubb HbsubU). }
  witness Rg.
  apply andI.
  - exact HRgRect.
  - apply andI.
    + exact HpRg.
    + exact HRgSubU. }

(** Apply basis_refines_topology and extract equality **)
claim HBgener: basis_on EuclidPlane rectangular_regions /\ generated_topology EuclidPlane rectangular_regions = R2_standard_topology.
{ exact (basis_refines_topology EuclidPlane R2_standard_topology rectangular_regions
         HtopPlane HCsub Href). }
exact (andER (basis_on EuclidPlane rectangular_regions)
             (generated_topology EuclidPlane rectangular_regions = R2_standard_topology)
             HBgener).
Qed.

(** from §13 Example 4: circular regions generate the standard topology on R^2 **)
(** LATEX VERSION: Since circular and rectangular regions generate the same topology, and rectangles generate the standard topology, circular regions also generate the standard topology on ℝ². **)
Theorem generated_topology_circular_regions_eq_R2_standard_topology :
  generated_topology EuclidPlane circular_regions = R2_standard_topology.
prove generated_topology EuclidPlane circular_regions = R2_standard_topology.
rewrite circular_rectangular_same_topology_plane.
exact generated_topology_rectangular_regions_eq_R2_standard_topology.
Qed.

(** from §13 Example 4: rectangular regions form a basis generating the standard topology on R^2 **)
(** LATEX VERSION: The rectangular regions form a basis for the standard topology on ℝ². **)
Theorem rectangular_regions_generate_R2_standard_topology :
  basis_generates EuclidPlane rectangular_regions R2_standard_topology.
prove basis_generates EuclidPlane rectangular_regions R2_standard_topology.
prove basis_on EuclidPlane rectangular_regions /\ generated_topology EuclidPlane rectangular_regions = R2_standard_topology.
apply andI.
- exact rectangular_regions_basis_plane.
- exact generated_topology_rectangular_regions_eq_R2_standard_topology.
Qed.

(** from §13 Example 4: circular regions form a basis generating the standard topology on R^2 **)
(** LATEX VERSION: The circular regions form a basis for the standard topology on ℝ². **)
Theorem circular_regions_generate_R2_standard_topology :
  basis_generates EuclidPlane circular_regions R2_standard_topology.
prove basis_generates EuclidPlane circular_regions R2_standard_topology.
prove basis_on EuclidPlane circular_regions /\ generated_topology EuclidPlane circular_regions = R2_standard_topology.
apply andI.
- exact circular_regions_basis_plane.
- exact generated_topology_circular_regions_eq_R2_standard_topology.
Qed.

(** helper: reverse equalities for rewriting **)
Theorem R2_standard_topology_eq_generated_rectangular_regions :
  R2_standard_topology = generated_topology EuclidPlane rectangular_regions.
prove R2_standard_topology = generated_topology EuclidPlane rectangular_regions.
symmetry.
exact generated_topology_rectangular_regions_eq_R2_standard_topology.
Qed.

(** helper: reverse equalities for rewriting **)
Theorem R2_standard_topology_eq_generated_circular_regions :
  R2_standard_topology = generated_topology EuclidPlane circular_regions.
prove R2_standard_topology = generated_topology EuclidPlane circular_regions.
symmetry.
exact generated_topology_circular_regions_eq_R2_standard_topology.
Qed.

(** from §16 Definition: subspace topology **) 
(** LATEX VERSION: The subspace topology on Y⊂X with topology Tx consists of intersections V∩Y with V open in X. **)
(** SUSPICIOUS DEFINITION: This is phrased as a family of subsets of `Y` (via `Power Y`) with witnesses `V :e Tx`; proofs often need to extract both the witness and the subset fact. **)
Definition subspace_topology : set -> set -> set -> set :=
  fun X Tx Y => {U :e Power Y | exists V :e Tx, U = V :/\: Y}.

(** helper: elimination for subspace_topology membership **)
Theorem subspace_topologyE : forall X Tx Y U:set,
  U :e subspace_topology X Tx Y -> exists V :e Tx, U = V :/\: Y.
let X Tx Y U.
assume HU: U :e subspace_topology X Tx Y.
exact (SepE2 (Power Y) (fun U0:set => exists V :e Tx, U0 = V :/\: Y) U HU).
Qed.

(** helper: basic open sets of subspace_topology are intersections **)
Theorem subspace_topologyI : forall X Tx Y V:set,
  V :e Tx -> (V :/\: Y) :e subspace_topology X Tx Y.
let X Tx Y V.
assume HV: V :e Tx.
claim HVsub: V :/\: Y c= Y.
{ exact (binintersect_Subq_2 V Y). }
claim HVpow: V :/\: Y :e Power Y.
{ exact (PowerI Y (V :/\: Y) HVsub). }
claim Hex: exists V0 :e Tx, (V :/\: Y) = V0 :/\: Y.
{ witness V.
  apply andI.
  - exact HV.
  - reflexivity. }
exact (SepI (Power Y) (fun U0:set => exists V0 :e Tx, U0 = V0 :/\: Y) (V :/\: Y) HVpow Hex).
Qed.

(** helper: elements of the subspace topology are subsets of Y **)
Theorem subspace_topology_subset : forall X Tx Y U:set,
  U :e subspace_topology X Tx Y -> U c= Y.
let X Tx Y U.
assume HU: U :e subspace_topology X Tx Y.
claim Hex: exists V :e Tx, U = V :/\: Y.
{ exact (subspace_topologyE X Tx Y U HU). }
apply Hex.
let V. assume HVpair.
claim HUeq: U = V :/\: Y.
{ exact (andER (V :e Tx) (U = V :/\: Y) HVpair). }
rewrite HUeq.
exact (binintersect_Subq_2 V Y).
Qed.

(** helper: elements of the subspace topology are members of Power Y **)
Theorem subspace_topology_in_Power : forall X Tx Y U:set,
  U :e subspace_topology X Tx Y -> U :e Power Y.
let X Tx Y U.
assume HU: U :e subspace_topology X Tx Y.
apply PowerI.
exact (subspace_topology_subset X Tx Y U HU).
Qed.

(** helper: intersection of two subspace-open sets is subspace-open, with an explicit witness **)
Theorem subspace_topology_binintersect_witness : forall X Tx Y U V VU VV:set,
  U = VU :/\: Y ->
  V = VV :/\: Y ->
  U :/\: V = (VU :/\: VV) :/\: Y.
let X Tx Y U V VU VV.
assume HU: U = VU :/\: Y.
assume HV: V = VV :/\: Y.
prove U :/\: V = (VU :/\: VV) :/\: Y.
apply set_ext.
- let x. assume Hx: x :e U :/\: V.
  claim HxUV: x :e U /\ x :e V.
  { exact (binintersectE U V x Hx). }
  claim HxU: x :e U.
  { exact (andEL (x :e U) (x :e V) HxUV). }
  claim HxV: x :e V.
  { exact (andER (x :e U) (x :e V) HxUV). }
  claim HxUY: x :e VU :/\: Y.
  { rewrite <- HU. exact HxU. }
  claim HxVY: x :e VV :/\: Y.
  { rewrite <- HV. exact HxV. }
  claim HxVU: x :e VU.
  { exact (binintersectE1 VU Y x HxUY). }
  claim HxVV: x :e VV.
  { exact (binintersectE1 VV Y x HxVY). }
  claim HxY: x :e Y.
  { exact (binintersectE2 VU Y x HxUY). }
  claim HxVUVV: x :e VU :/\: VV.
  { exact (binintersectI VU VV x HxVU HxVV). }
  exact (binintersectI (VU :/\: VV) Y x HxVUVV HxY).
- let x. assume Hx: x :e (VU :/\: VV) :/\: Y.
  claim HxVUVV: x :e VU :/\: VV.
  { exact (binintersectE1 (VU :/\: VV) Y x Hx). }
  claim HxY: x :e Y.
  { exact (binintersectE2 (VU :/\: VV) Y x Hx). }
  claim HxVU: x :e VU.
  { exact (binintersectE1 VU VV x HxVUVV). }
  claim HxVV: x :e VV.
  { exact (binintersectE2 VU VV x HxVUVV). }
  claim HxU: x :e U.
  { rewrite HU.
    exact (binintersectI VU Y x HxVU HxY). }
  claim HxV: x :e V.
  { rewrite HV.
    exact (binintersectI VV Y x HxVV HxY). }
  exact (binintersectI U V x HxU HxV).
Qed.

(** helper: intersection closure for the subspace topology **)
Theorem subspace_topology_binintersect : forall X Tx Y U V:set,
  topology_on X Tx -> Y c= X ->
  U :e subspace_topology X Tx Y ->
  V :e subspace_topology X Tx Y ->
  U :/\: V :e subspace_topology X Tx Y.
let X Tx Y U V.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
assume HU: U :e subspace_topology X Tx Y.
assume HV: V :e subspace_topology X Tx Y.
claim HexU: exists VU :e Tx, U = VU :/\: Y.
{ exact (subspace_topologyE X Tx Y U HU). }
claim HexV: exists VV :e Tx, V = VV :/\: Y.
{ exact (subspace_topologyE X Tx Y V HV). }
apply HexU.
let VU. assume HVUpair.
claim HVU: VU :e Tx.
{ exact (andEL (VU :e Tx) (U = VU :/\: Y) HVUpair). }
claim HUeq: U = VU :/\: Y.
{ exact (andER (VU :e Tx) (U = VU :/\: Y) HVUpair). }
apply HexV.
let VV. assume HVVpair.
claim HVV: VV :e Tx.
{ exact (andEL (VV :e Tx) (V = VV :/\: Y) HVVpair). }
claim HVeq: V = VV :/\: Y.
{ exact (andER (VV :e Tx) (V = VV :/\: Y) HVVpair). }
claim HUV: VU :/\: VV :e Tx.
{ exact (topology_binintersect_closed X Tx VU VV HTx HVU HVV). }
rewrite (subspace_topology_binintersect_witness X Tx Y U V VU VV HUeq HVeq).
exact (subspace_topologyI X Tx Y (VU :/\: VV) HUV).
Qed.

(** helper: monotonicity of the subspace topology in the ambient topology **)
Theorem subspace_topology_mono : forall X Tx1 Tx2 Y U:set,
  Tx1 c= Tx2 ->
  U :e subspace_topology X Tx1 Y ->
  U :e subspace_topology X Tx2 Y.
let X Tx1 Tx2 Y U.
assume Hsub: Tx1 c= Tx2.
assume HU: U :e subspace_topology X Tx1 Y.
claim Hex: exists V :e Tx1, U = V :/\: Y.
{ exact (subspace_topologyE X Tx1 Y U HU). }
apply Hex.
let V. assume HVpair.
claim HV1: V :e Tx1.
{ exact (andEL (V :e Tx1) (U = V :/\: Y) HVpair). }
claim HUeq: U = V :/\: Y.
{ exact (andER (V :e Tx1) (U = V :/\: Y) HVpair). }
claim HV2: V :e Tx2.
{ exact (Hsub V HV1). }
rewrite HUeq.
exact (subspace_topologyI X Tx2 Y V HV2).
Qed.

(** helper: union closure for the subspace topology **)
Theorem subspace_topology_union_closed : forall X Tx Y UFam:set,
  topology_on X Tx -> Y c= X ->
  UFam c= subspace_topology X Tx Y ->
  Union UFam :e subspace_topology X Tx Y.
let X Tx Y UFam.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
assume HUFam: UFam c= subspace_topology X Tx Y.
prove Union UFam :e subspace_topology X Tx Y.
set VFam := {V :e Tx | exists U :e UFam, U = V :/\: Y}.
claim HVFamTx: VFam c= Tx.
{ let V. assume HV: V :e VFam.
  exact (SepE1 Tx (fun V0 => exists U :e UFam, U = V0 :/\: Y) V HV). }
claim HUnionVFam: Union VFam :e Tx.
{ exact (topology_union_closed X Tx VFam HTx HVFamTx). }
claim HUnionEq: Union UFam = (Union VFam) :/\: Y.
{ apply set_ext.
  - let x. assume Hx: x :e Union UFam.
    apply UnionE_impred UFam x Hx.
    let U. assume HxU: x :e U. assume HUinFam: U :e UFam.
    claim HUinSub: U :e subspace_topology X Tx Y.
    { exact (HUFam U HUinFam). }
    claim HUexists: exists V :e Tx, U = V :/\: Y.
    { exact (subspace_topologyE X Tx Y U HUinSub). }
    apply HUexists.
    let V. assume HVpair.
    claim HVTx: V :e Tx.
    { exact (andEL (V :e Tx) (U = V :/\: Y) HVpair). }
    claim HUeq: U = V :/\: Y.
    { exact (andER (V :e Tx) (U = V :/\: Y) HVpair). }
    apply binintersectI.
    + prove x :e Union VFam.
      claim HxV: x :e V.
      { claim HxVY: x :e V :/\: Y.
        { rewrite <- HUeq. exact HxU. }
        exact (binintersectE1 V Y x HxVY). }
      claim HVinVFam: V :e VFam.
      { apply (SepI Tx (fun V0 => exists U0 :e UFam, U0 = V0 :/\: Y) V HVTx).
        witness U.
        apply andI.
        - exact HUinFam.
        - exact HUeq. }
      exact (UnionI VFam x V HxV HVinVFam).
    + prove x :e Y.
      claim HxVY: x :e V :/\: Y.
      { rewrite <- HUeq. exact HxU. }
      exact (binintersectE2 V Y x HxVY).
  - let x. assume Hx: x :e (Union VFam) :/\: Y.
    claim HxUnionV: x :e Union VFam.
    { exact (binintersectE1 (Union VFam) Y x Hx). }
    claim HxY: x :e Y.
    { exact (binintersectE2 (Union VFam) Y x Hx). }
    apply UnionE_impred VFam x HxUnionV.
    let V. assume HxV: x :e V. assume HVin: V :e VFam.
    claim HVexists: exists U :e UFam, U = V :/\: Y.
    { exact (SepE2 Tx (fun V0 => exists U0 :e UFam, U0 = V0 :/\: Y) V HVin). }
    apply HVexists.
    let U. assume HUpair.
    claim HUinFam: U :e UFam.
    { exact (andEL (U :e UFam) (U = V :/\: Y) HUpair). }
    claim HUeq: U = V :/\: Y.
    { exact (andER (U :e UFam) (U = V :/\: Y) HUpair). }
    claim HxU: x :e U.
    { rewrite HUeq.
      exact (binintersectI V Y x HxV HxY). }
    exact (UnionI UFam x U HxU HUinFam).
}
rewrite HUnionEq.
exact (subspace_topologyI X Tx Y (Union VFam) HUnionVFam).
Qed.

(** helper: subspace topology on whole space equals original topology **)
Theorem subspace_topology_whole : forall X Tx:set,
  topology_on X Tx ->
  subspace_topology X Tx X = Tx.
let X Tx.
assume HTx: topology_on X Tx.
prove subspace_topology X Tx X = Tx.
apply set_ext.
- let U. assume HU: U :e subspace_topology X Tx X.
  prove U :e Tx.
  claim Hex: exists V :e Tx, U = V :/\: X.
  { exact (subspace_topologyE X Tx X U HU). }
  apply Hex.
  let V. assume HVpair.
  claim HV: V :e Tx.
  { exact (andEL (V :e Tx) (U = V :/\: X) HVpair). }
  claim HUeq: U = V :/\: X.
  { exact (andER (V :e Tx) (U = V :/\: X) HVpair). }
  claim HVsub: V c= X.
  { exact (topology_elem_subset X Tx V HTx HV). }
  claim HVeql: V :/\: X = V.
  { exact (binintersect_Subq_eq_1 V X HVsub). }
  claim HUeqV: U = V.
  { rewrite HUeq. exact HVeql. }
  rewrite HUeqV.
  exact HV.
- let U. assume HU: U :e Tx.
  prove U :e subspace_topology X Tx X.
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U HTx HU). }
  claim HUpow: U :e Power X.
  { exact (PowerI X U HUsub). }
  claim Hex: exists V :e Tx, U = V :/\: X.
  { witness U.
    apply andI.
    - exact HU.
    - prove U = U :/\: X.
      rewrite (binintersect_Subq_eq_1 U X HUsub).
      reflexivity. }
  exact (SepI (Power X) (fun U0:set => exists V :e Tx, U0 = V :/\: X) U HUpow Hex).
Qed.

(** from §16: subspace topology is a topology **) 
(** LATEX VERSION: The subspace topology on Y inherits the topology axioms. **)
Theorem subspace_topology_is_topology : forall X Tx Y:set,
  topology_on X Tx -> Y c= X ->
  topology_on Y (subspace_topology X Tx Y).
let X Tx Y.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
prove topology_on Y (subspace_topology X Tx Y).
prove subspace_topology X Tx Y c= Power Y
  /\ Empty :e subspace_topology X Tx Y
  /\ Y :e subspace_topology X Tx Y
  /\ (forall UFam :e Power (subspace_topology X Tx Y), Union UFam :e subspace_topology X Tx Y)
  /\ (forall U :e subspace_topology X Tx Y, forall V :e subspace_topology X Tx Y, U :/\: V :e subspace_topology X Tx Y).
apply andI.
- prove (subspace_topology X Tx Y c= Power Y /\ Empty :e subspace_topology X Tx Y) /\ Y :e subspace_topology X Tx Y /\ (forall UFam :e Power (subspace_topology X Tx Y), Union UFam :e subspace_topology X Tx Y).
  apply andI.
  + prove subspace_topology X Tx Y c= Power Y /\ Empty :e subspace_topology X Tx Y /\ Y :e subspace_topology X Tx Y.
    apply andI.
    * prove subspace_topology X Tx Y c= Power Y /\ Empty :e subspace_topology X Tx Y.
	      apply andI.
	      { prove subspace_topology X Tx Y c= Power Y.
	        let U. assume HU: U :e subspace_topology X Tx Y.
	        exact (subspace_topology_in_Power X Tx Y U HU).
	      }
      { prove Empty :e subspace_topology X Tx Y.
        claim HEmptyTx: Empty :e Tx.
        { exact (topology_has_empty X Tx HTx). }
        claim HPred: exists V :e Tx, Empty = V :/\: Y.
        { witness Empty.
          apply andI.
          - exact HEmptyTx.
          - prove Empty = Empty :/\: Y.
            claim H1: Empty :/\: Y = Empty.
            { apply Empty_Subq_eq.
              exact (binintersect_Subq_1 Empty Y). }
            rewrite H1.
            reflexivity.
        }
        exact (SepI (Power Y) (fun U0:set => exists V :e Tx, U0 = V :/\: Y) Empty (Empty_In_Power Y) HPred).
      }
    * prove Y :e subspace_topology X Tx Y.
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HPredY: exists V :e Tx, Y = V :/\: Y.
      { witness X.
        apply andI.
        - exact HXTx.
        - prove Y = X :/\: Y.
          apply set_ext.
          + let y. assume Hy: y :e Y.
            apply binintersectI.
            * exact (HY y Hy).
            * exact Hy.
          + exact (binintersect_Subq_2 X Y).
      }
      exact (SepI (Power Y) (fun U0:set => exists V :e Tx, U0 = V :/\: Y) Y (Self_In_Power Y) HPredY).
	  + prove forall UFam :e Power (subspace_topology X Tx Y), Union UFam :e subspace_topology X Tx Y.
	    let UFam. assume HUFam: UFam :e Power (subspace_topology X Tx Y).
	    prove Union UFam :e subspace_topology X Tx Y.
	    claim HUFamsub: UFam c= subspace_topology X Tx Y.
	    { exact (PowerE (subspace_topology X Tx Y) UFam HUFam). }
	    exact (subspace_topology_union_closed X Tx Y UFam HTx HY HUFamsub).
	- prove forall U :e subspace_topology X Tx Y, forall V :e subspace_topology X Tx Y, U :/\: V :e subspace_topology X Tx Y.
	  let U. assume HU: U :e subspace_topology X Tx Y.
	  let V. assume HV: V :e subspace_topology X Tx Y.
	  prove U :/\: V :e subspace_topology X Tx Y.
	  exact (subspace_topology_binintersect X Tx Y U V HTx HY HU HV).
Qed.

(** from §16: openness in subspace via ambient openness **) 
(** LATEX VERSION: A set U⊂Y is open in the subspace topology iff U = V∩Y for some V open in X. **)
Theorem open_in_subspace_iff : forall X Tx Y U:set,
  topology_on X Tx -> Y c= X -> U c= Y ->
  (open_in Y (subspace_topology X Tx Y) U <->
  exists V :e Tx, U = V :/\: Y).
let X Tx Y U.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
assume HU: U c= Y.
prove open_in Y (subspace_topology X Tx Y) U <-> exists V :e Tx, U = V :/\: Y.
apply iffI.
- assume HopenU: open_in Y (subspace_topology X Tx Y) U.
  prove exists V :e Tx, U = V :/\: Y.
  claim HUinSubspace: U :e subspace_topology X Tx Y.
  { exact (andER (topology_on Y (subspace_topology X Tx Y)) (U :e subspace_topology X Tx Y) HopenU). }
  exact (subspace_topologyE X Tx Y U HUinSubspace).
- assume Hexists: exists V :e Tx, U = V :/\: Y.
  prove open_in Y (subspace_topology X Tx Y) U.
  prove topology_on Y (subspace_topology X Tx Y) /\ U :e subspace_topology X Tx Y.
  apply andI.
  + prove topology_on Y (subspace_topology X Tx Y).
    exact (subspace_topology_is_topology X Tx Y HTx HY).
  + prove U :e subspace_topology X Tx Y.
    apply Hexists.
    let V.
    assume HVpair: V :e Tx /\ U = V :/\: Y.
    claim HV: V :e Tx.
    { exact (andEL (V :e Tx) (U = V :/\: Y) HVpair). }
    claim HUeq: U = V :/\: Y.
    { exact (andER (V :e Tx) (U = V :/\: Y) HVpair). }
    rewrite HUeq.
    exact (subspace_topologyI X Tx Y V HV).
Qed.

(** from §16 Lemma 16.1: basis for the subspace topology **) 
(** LATEX VERSION: Lemma 16.1: If B is a basis for Tx, then {b∩Y | b∈B} is a basis for the subspace topology on Y. **)
Theorem subspace_basis : forall X Tx Y B:set,
  topology_on X Tx ->
  Y c= X ->
  basis_on X B /\ generated_topology X B = Tx ->
  basis_on Y {b :/\: Y | b :e B} /\
  generated_topology Y {b :/\: Y | b :e B} = subspace_topology X Tx Y.
let X Tx Y B.
assume HTx: topology_on X Tx.
assume HYsub: Y c= X.
assume HB: basis_on X B /\ generated_topology X B = Tx.
prove basis_on Y {b :/\: Y | b :e B} /\ generated_topology Y {b :/\: Y | b :e B} = subspace_topology X Tx Y.
(** Use basis_refines_topology with C = {b∩Y | b∈B} on the subspace topology. **)
claim HBasis: basis_on X B.
{ exact (andEL (basis_on X B) (generated_topology X B = Tx) HB). }
claim HgenEq: generated_topology X B = Tx.
{ exact (andER (basis_on X B) (generated_topology X B = Tx) HB). }
claim HtopSub: topology_on Y (subspace_topology X Tx Y).
{ exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
claim HCsub: forall c :e {b :/\: Y | b :e B}, c :e subspace_topology X Tx Y.
{ let c. assume HcC.
  claim Hexb: exists b :e B, c = b :/\: Y.
  { exact (ReplE B (fun b0:set => b0 :/\: Y) c HcC). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (c = b :/\: Y) Hbpair). }
  claim Hceq: c = b :/\: Y.
  { exact (andER (b :e B) (c = b :/\: Y) Hbpair). }
  claim HbGen: b :e generated_topology X B.
  { exact (generated_topology_contains_basis X B HBasis b HbB). }
  claim HbTx: b :e Tx.
  { prove b :e Tx.
    rewrite <- HgenEq.
    exact HbGen. }
  claim HcPowY: c :e Power Y.
  { apply PowerI Y c.
    let y. assume Hyc: y :e c.
    claim HycBY: y :e b :/\: Y.
    { prove y :e b :/\: Y.
      rewrite <- Hceq.
      exact Hyc. }
    exact (binintersectE2 b Y y HycBY). }
  claim HcProp: exists V :e Tx, c = V :/\: Y.
  { witness b.
    apply andI.
    - exact HbTx.
    - exact Hceq. }
  exact (SepI (Power Y) (fun U0:set => exists V :e Tx, U0 = V :/\: Y) c HcPowY HcProp). }
claim Href: forall U :e subspace_topology X Tx Y, forall x :e U,
  exists Cx :e {b :/\: Y | b :e B}, x :e Cx /\ Cx c= U.
{ let U. assume HU: U :e subspace_topology X Tx Y.
  let x. assume HxU: x :e U.
  claim HUprop: exists V :e Tx, U = V :/\: Y.
  { exact (subspace_topologyE X Tx Y U HU). }
  apply HUprop.
  let V. assume HVpair.
  claim HVTx: V :e Tx.
  { exact (andEL (V :e Tx) (U = V :/\: Y) HVpair). }
  claim HUeq: U = V :/\: Y.
  { exact (andER (V :e Tx) (U = V :/\: Y) HVpair). }
  claim HxVY: x :e V :/\: Y.
  { rewrite <- HUeq. exact HxU. }
  claim HxV: x :e V.
  { exact (binintersectE1 V Y x HxVY). }
  claim HxY: x :e Y.
  { exact (binintersectE2 V Y x HxVY). }
  claim HVGen: V :e generated_topology X B.
  { prove V :e generated_topology X B.
    rewrite HgenEq.
    exact HVTx. }
  claim HVref: forall z :e V, exists b :e B, z :e b /\ b c= V.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall z0 :e U0, exists b0 :e B, z0 :e b0 /\ b0 c= U0)
                 V
                 HVGen). }
  claim Hexb: exists b :e B, x :e b /\ b c= V.
  { exact (HVref x HxV). }
  apply Hexb.
  let b. assume Hbpair2.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= V) Hbpair2). }
  claim Hbprop: x :e b /\ b c= V.
  { exact (andER (b :e B) (x :e b /\ b c= V) Hbpair2). }
  claim Hxb: x :e b.
  { exact (andEL (x :e b) (b c= V) Hbprop). }
  claim HbsubV: b c= V.
  { exact (andER (x :e b) (b c= V) Hbprop). }
  set Cx := b :/\: Y.
  witness Cx.
  apply andI.
  - prove Cx :e {b0 :/\: Y | b0 :e B}.
    exact (ReplI B (fun b0:set => b0 :/\: Y) b HbB).
  - apply andI.
    + prove x :e Cx.
      exact (binintersectI b Y x Hxb HxY).
    + prove Cx c= U.
      let y. assume HyCx: y :e Cx.
      claim Hyb: y :e b.
      { exact (binintersectE1 b Y y HyCx). }
      claim HyY: y :e Y.
      { exact (binintersectE2 b Y y HyCx). }
      claim HyV: y :e V.
      { exact (HbsubV y Hyb). }
      claim HyVY: y :e V :/\: Y.
      { exact (binintersectI V Y y HyV HyY). }
      rewrite HUeq.
      exact HyVY. }
exact (basis_refines_topology Y (subspace_topology X Tx Y) {b :/\: Y | b :e B} HtopSub HCsub Href).
Qed.

(** from §16 Lemma 16.2: openness inherited when subspace is open **) 
(** LATEX VERSION: Lemma 16.2: If Y itself is open in X, any set open in the subspace Y is open in X. **)
Theorem open_in_subspace_if_ambient_open : forall X Tx Y U:set,
  topology_on X Tx -> Y :e Tx -> U c= Y ->
  open_in Y (subspace_topology X Tx Y) U ->
  U :e Tx.
let X Tx Y U.
assume HTx: topology_on X Tx.
assume HY: Y :e Tx.
assume HU: U c= Y.
assume HUopen: open_in Y (subspace_topology X Tx Y) U.
prove U :e Tx.
claim HYsub: Y c= X.
{ exact (topology_elem_subset X Tx Y HTx HY). }
claim HUiffExists: open_in Y (subspace_topology X Tx Y) U <-> exists V :e Tx, U = V :/\: Y.
{ exact (open_in_subspace_iff X Tx Y U HTx HYsub HU). }
claim Hexists: exists V :e Tx, U = V :/\: Y.
{ exact (iffEL (open_in Y (subspace_topology X Tx Y) U) (exists V :e Tx, U = V :/\: Y) HUiffExists HUopen). }
apply Hexists.
let V. assume HVandEq. apply HVandEq.
assume HV: V :e Tx. assume HUeq: U = V :/\: Y.
claim HVY: V :/\: Y :e Tx.
{ exact (topology_binintersect_closed X Tx V Y HTx HV HY). }
claim HUinTx: U :e Tx.
{ rewrite HUeq. exact HVY. }
exact HUinTx.
Qed.

(** from §16 Theorem 16.3: product of subspaces equals subspace of product **) 
(** LATEX VERSION: The product topology on A×B (with subspace topologies) equals the subspace topology of A×B inside X×Y. **)
Theorem product_subspace_topology : forall X Tx Y Ty A B:set,
  topology_on X Tx -> topology_on Y Ty ->
  A c= X -> B c= Y ->
  product_topology A (subspace_topology X Tx A) B (subspace_topology Y Ty B) =
  subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
let X Tx Y Ty A B.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HA: A c= X.
assume HB: B c= Y.
prove product_topology A (subspace_topology X Tx A) B (subspace_topology Y Ty B) =
  subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
(** Use the rectangle family (U∩A)×(V∩B) as a common basis for both topologies. **)
set Bx := {U :/\: A | U :e Tx}.
set By := {V :/\: B | V :e Ty}.
set C := product_basis_from Bx By.

(** First, show Tx generates itself, so Bx generates the subspace topology on A, and similarly for By. **)
claim HgenTx: basis_on X Tx /\ generated_topology X Tx = Tx.
{ prove basis_on X Tx /\ generated_topology X Tx = Tx.
  apply (basis_refines_topology X Tx Tx HTx).
  - let c. assume Hc: c :e Tx.
    exact Hc.
  - let U. assume HU: U :e Tx.
    let x. assume Hx: x :e U.
    prove exists Cx :e Tx, x :e Cx /\ Cx c= U.
    witness U.
    apply andI.
    + exact HU.
    + apply andI.
      * exact Hx.
      * exact (Subq_ref U). }
claim HgenTy: basis_on Y Ty /\ generated_topology Y Ty = Ty.
{ prove basis_on Y Ty /\ generated_topology Y Ty = Ty.
  apply (basis_refines_topology Y Ty Ty HTy).
  - let c. assume Hc: c :e Ty.
    exact Hc.
  - let U. assume HU: U :e Ty.
    let x. assume Hx: x :e U.
    prove exists Cx :e Ty, x :e Cx /\ Cx c= U.
    witness U.
    apply andI.
    + exact HU.
    + apply andI.
      * exact Hx.
      * exact (Subq_ref U). }

claim HBx: basis_on A Bx /\ generated_topology A Bx = subspace_topology X Tx A.
{ exact (subspace_basis X Tx A Tx HTx HA HgenTx). }
claim HBy: basis_on B By /\ generated_topology B By = subspace_topology Y Ty B.
{ exact (subspace_basis Y Ty B Ty HTy HB HgenTy). }

claim HBx_basis: basis_on A Bx.
{ exact (andEL (basis_on A Bx) (generated_topology A Bx = subspace_topology X Tx A) HBx). }
claim HBy_basis: basis_on B By.
{ exact (andEL (basis_on B By) (generated_topology B By = subspace_topology Y Ty B) HBy). }
claim HBx_eq: generated_topology A Bx = subspace_topology X Tx A.
{ exact (andER (basis_on A Bx) (generated_topology A Bx = subspace_topology X Tx A) HBx). }
claim HBy_eq: generated_topology B By = subspace_topology Y Ty B.
{ exact (andER (basis_on B By) (generated_topology B By = subspace_topology Y Ty B) HBy). }

(** Product of subspaces is generated by C. **)
claim Hprod_gen:
  generated_topology (setprod A B) C =
  product_topology A (subspace_topology X Tx A) B (subspace_topology Y Ty B).
{ exact (product_basis_generates_product_topology
          A B Bx By
          (subspace_topology X Tx A) (subspace_topology Y Ty B)
          HBx_basis HBx_eq
          HBy_basis HBy_eq). }

(** Now show that the subspace topology of the product is also generated by C, using basis_refines_topology. **)
claim HABsub: setprod A B c= setprod X Y.
{ exact (setprod_Subq A B X Y HA HB). }
claim HtopProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
claim HtopSubProd: topology_on (setprod A B)
  (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B)).
{ exact (subspace_topology_is_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B) HtopProd HABsub). }

claim HCsub: forall c :e C,
  c :e subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
{ let c. assume HcC.
  claim HexU: exists U :e Bx, c :e {setprod U V|V :e By}.
  { exact (famunionE Bx (fun U0:set => {setprod U0 V|V :e By}) c HcC). }
  apply HexU.
  let U. assume HUconj.
  claim HUbx: U :e Bx.
  { exact (andEL (U :e Bx) (c :e {setprod U V|V :e By}) HUconj). }
  claim HcRepl: c :e {setprod U V|V :e By}.
  { exact (andER (U :e Bx) (c :e {setprod U V|V :e By}) HUconj). }
  claim HexV: exists V :e By, c = setprod U V.
  { exact (ReplE By (fun V0:set => setprod U V0) c HcRepl). }
  apply HexV.
  let V. assume HVconj.
  claim HVby: V :e By.
  { exact (andEL (V :e By) (c = setprod U V) HVconj). }
  claim HcEqUV: c = setprod U V.
  { exact (andER (V :e By) (c = setprod U V) HVconj). }

  claim HexUx: exists U0 :e Tx, U = U0 :/\: A.
  { exact (ReplE Tx (fun U0:set => U0 :/\: A) U HUbx). }
  claim HexVy: exists V0 :e Ty, V = V0 :/\: B.
  { exact (ReplE Ty (fun V0:set => V0 :/\: B) V HVby). }
  apply HexUx.
  let U0. assume HU0conj.
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (U = U0 :/\: A) HU0conj). }
  claim HUeq: U = U0 :/\: A.
  { exact (andER (U0 :e Tx) (U = U0 :/\: A) HU0conj). }
  apply HexVy.
  let V0. assume HV0conj.
  claim HV0Ty: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (V = V0 :/\: B) HV0conj). }
  claim HVeq: V = V0 :/\: B.
  { exact (andER (V0 :e Ty) (V = V0 :/\: B) HV0conj). }

  set W := setprod U0 V0.
  claim HWsub: W :e product_subbasis X Tx Y Ty.
  { prove W :e product_subbasis X Tx Y Ty.
    claim HWV: rectangle_set U0 V0 :e {rectangle_set U0 V|V :e Ty}.
    { exact (ReplI Ty (fun V1:set => rectangle_set U0 V1) V0 HV0Ty). }
    exact (famunionI Tx (fun U1:set => {rectangle_set U1 V|V :e Ty}) U0 (rectangle_set U0 V0) HU0Tx HWV). }
  claim HBsubbasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HWopen: W :e product_topology X Tx Y Ty.
  { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty)
            HBsubbasis W HWsub). }

  claim HcPow: c :e Power (setprod A B).
  { apply PowerI (setprod A B) c.
    let p. assume Hp: p :e c.
    prove p :e setprod A B.
    claim HpUV: p :e setprod U V.
    { prove p :e setprod U V.
      rewrite <- HcEqUV.
      exact Hp. }
    claim HsubU: U c= A.
    { prove U c= A.
      rewrite HUeq.
      exact (binintersect_Subq_2 U0 A). }
    claim HsubV: V c= B.
    { prove V c= B.
      rewrite HVeq.
      exact (binintersect_Subq_2 V0 B). }
    claim HsubUV: setprod U V c= setprod A B.
    { exact (setprod_Subq U V A B HsubU HsubV). }
    exact (HsubUV p HpUV). }
  claim HcEqSub: c = W :/\: setprod A B.
  { prove c = W :/\: setprod A B.
    rewrite HcEqUV.
    rewrite HUeq.
    rewrite HVeq.
    rewrite <- (setprod_intersection U0 V0 A B).
    reflexivity. }
  claim HexW: exists V1 :e product_topology X Tx Y Ty, c = V1 :/\: setprod A B.
  { witness W.
    apply andI.
    - exact HWopen.
    - exact HcEqSub. }
  exact (SepI (Power (setprod A B))
              (fun U1:set => exists V1 :e product_topology X Tx Y Ty, U1 = V1 :/\: setprod A B)
              c
              HcPow
              HexW). }

claim Href: forall U1 :e subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B),
  forall p :e U1,
  exists Cx :e C, p :e Cx /\ Cx c= U1.
{ let U1. assume HU1: U1 :e subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
  let p. assume HpU1: p :e U1.
  claim HU1sub: U1 c= setprod A B.
  { exact (PowerE (setprod A B) U1 (SepE1 (Power (setprod A B))
                (fun U0:set => exists V0 :e product_topology X Tx Y Ty, U0 = V0 :/\: setprod A B)
                U1 HU1)). }
  claim HpAB: p :e setprod A B.
  { exact (HU1sub p HpU1). }
  claim HU1prop: exists W :e product_topology X Tx Y Ty, U1 = W :/\: setprod A B.
  { exact (SepE2 (Power (setprod A B))
                 (fun U0:set => exists V0 :e product_topology X Tx Y Ty, U0 = V0 :/\: setprod A B)
                 U1 HU1). }
  apply HU1prop.
  let W. assume HWconj.
  claim HWopen: W :e product_topology X Tx Y Ty.
  { exact (andEL (W :e product_topology X Tx Y Ty) (U1 = W :/\: setprod A B) HWconj). }
  claim HU1eq: U1 = W :/\: setprod A B.
  { exact (andER (W :e product_topology X Tx Y Ty) (U1 = W :/\: setprod A B) HWconj). }
  claim HpWAB: p :e W :/\: setprod A B.
  { rewrite <- HU1eq. exact HpU1. }
  claim HpW: p :e W.
  { exact (binintersectE1 W (setprod A B) p HpWAB). }

  claim HWgen: W :e generated_topology (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact HWopen. }
  claim HWref: forall z :e W, exists b :e product_subbasis X Tx Y Ty, z :e b /\ b c= W.
  { exact (SepE2 (Power (setprod X Y))
                 (fun U0 : set => forall z0 :e U0, exists b0 :e product_subbasis X Tx Y Ty, z0 :e b0 /\ b0 c= U0)
                 W
                 HWgen). }
  claim Hexb: exists b :e product_subbasis X Tx Y Ty, p :e b /\ b c= W.
  { exact (HWref p HpW). }
  apply Hexb.
  let b. assume Hbconj.
  claim HbSub: b :e product_subbasis X Tx Y Ty.
  { exact (andEL (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= W) Hbconj). }
  claim Hbprop: p :e b /\ b c= W.
  { exact (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= W) Hbconj). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= W) Hbprop). }
  claim HbsubW: b c= W.
  { exact (andER (p :e b) (b c= W) Hbprop). }

  claim HexU: exists U0 :e Tx, b :e {rectangle_set U0 V|V :e Ty}.
  { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbSub). }
  apply HexU.
  let U0. assume HU0conj.
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
  claim HbRepl: b :e {rectangle_set U0 V|V :e Ty}.
  { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
  claim HexV: exists V0 :e Ty, b = rectangle_set U0 V0.
  { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbRepl). }
  apply HexV.
  let V0. assume HV0conj.
  claim HV0Ty: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
  claim Hbeq: b = rectangle_set U0 V0.
  { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }

  set Cx := setprod (U0 :/\: A) (V0 :/\: B).
  witness Cx.
  apply andI.
  - prove Cx :e C.
    claim HU0Bx: U0 :/\: A :e Bx.
    { exact (ReplI Tx (fun U1:set => U1 :/\: A) U0 HU0Tx). }
    claim HV0By: V0 :/\: B :e By.
    { exact (ReplI Ty (fun V1:set => V1 :/\: B) V0 HV0Ty). }
    claim HcxRepl: setprod (U0 :/\: A) (V0 :/\: B) :e {setprod (U0 :/\: A) V|V :e By}.
    { exact (ReplI By (fun V1:set => setprod (U0 :/\: A) V1) (V0 :/\: B) HV0By). }
    exact (famunionI Bx (fun U1:set => {setprod U1 V|V :e By}) (U0 :/\: A)
            (setprod (U0 :/\: A) (V0 :/\: B)) HU0Bx HcxRepl).
  - apply andI.
    + prove p :e Cx.
      claim HpInInter: p :e (rectangle_set U0 V0) :/\: setprod A B.
      { prove p :e (rectangle_set U0 V0) :/\: setprod A B.
        apply binintersectI.
        - prove p :e rectangle_set U0 V0.
          rewrite <- Hbeq.
          exact Hpb.
        - exact HpAB. }
      rewrite <- (setprod_intersection U0 V0 A B).
      exact HpInInter.
    + prove Cx c= U1.
      claim HCx_sub_b: Cx c= rectangle_set U0 V0.
      { exact (setprod_Subq (U0 :/\: A) (V0 :/\: B) U0 V0 (binintersect_Subq_1 U0 A) (binintersect_Subq_1 V0 B)). }
      claim HCx_sub_W: Cx c= W.
      { claim HrectSubb: rectangle_set U0 V0 c= b.
        { prove rectangle_set U0 V0 c= b.
          rewrite <- Hbeq.
          exact (Subq_ref b). }
        exact (Subq_tra Cx (rectangle_set U0 V0) W HCx_sub_b
                 (Subq_tra (rectangle_set U0 V0) b W HrectSubb HbsubW)). }
      claim HCx_sub_AB: Cx c= setprod A B.
      { exact (setprod_Subq (U0 :/\: A) (V0 :/\: B) A B (binintersect_Subq_2 U0 A) (binintersect_Subq_2 V0 B)). }
      claim HCx_sub_WAB: Cx c= W :/\: setprod A B.
      { exact (binintersect_Subq_max W (setprod A B) Cx HCx_sub_W HCx_sub_AB). }
      rewrite HU1eq.
      exact HCx_sub_WAB. }

claim HsubEq:
  generated_topology (setprod A B) C =
  subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
{ exact (andER (basis_on (setprod A B) C)
               (generated_topology (setprod A B) C = subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B))
               (basis_refines_topology (setprod A B)
                 (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod A B))
                 C
                 HtopSubProd
                 HCsub
                 Href)). }

(** Conclude by identifying both sides with generated_topology (setprod A B) C. **)
rewrite <- Hprod_gen.
rewrite HsubEq.
reflexivity.
Qed.

(** from §16 Example 3: ordered square versus subspace topology **) 
(** LATEX VERSION: Example 3: The order topology on the ordered square differs from the subspace topology inherited from the dictionary order on ℝ×ℝ. **)
(** FIXED: Unit interval [0,1] = {x ∈ R | 0 ≤ x ≤ 1}, using negated strict inequality: x ≥ 0 means ~(x < 0) and x ≤ 1 means ~(1 < x). **)
Definition unit_interval : set := {x :e R | ~(Rlt x 0) /\ ~(Rlt 1 x)}.

(** helper: unit_interval is a subset of R **)
(** LATEX VERSION: The unit interval [0,1] is a subset of the real line. **)
Theorem unit_interval_sub_R : unit_interval c= R.
let x. assume Hx: x :e unit_interval.
exact (SepE1 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) x Hx).
Qed.

(** helper: eps_1 is a real number **)
Theorem eps_1_in_R : eps_ 1 :e R.
prove eps_ 1 :e R.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
{ exact (SNo_eps_SNoS_omega 1 H1omega). }
exact (SNoS_omega_real (eps_ 1) Heps1SNoS).
Qed.

(** helper: eps_1 is strictly between 0 and 1 in R **)
Theorem eps_1_pos_R : Rlt 0 (eps_ 1).
prove Rlt 0 (eps_ 1).
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
exact (RltI 0 (eps_ 1) real_0 eps_1_in_R (SNo_eps_pos 1 H1omega)).
Qed.

(** helper: eps_1 is less than 1 in R **)
Theorem eps_1_lt1_R : Rlt (eps_ 1) 1.
prove Rlt (eps_ 1) 1.
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H0Ord: ordinal 0.
{ exact (nat_p_ordinal 0 nat_0). }
claim H0in1: 0 :e 1.
{ exact (ordinal_0_In_ordsucc 0 H0Ord). }
claim HepsLtE0: eps_ 1 < eps_ 0.
{ exact (SNo_eps_decr 1 H1omega 0 H0in1). }
claim HepsLt1S: (eps_ 1) < 1.
{ rewrite <- (eps_0_1) at 2.
  exact HepsLtE0. }
exact (RltI (eps_ 1) 1 eps_1_in_R real_1 HepsLt1S).
Qed.

(** helper: 0 is in the unit interval **)
Theorem zero_in_unit_interval : 0 :e unit_interval.
prove 0 :e unit_interval.
claim H0R: 0 :e R.
{ exact real_0. }
claim Hnlt00: ~(Rlt 0 0).
{ exact (not_Rlt_refl 0 H0R). }
claim H0lt1: Rlt 0 1.
{ exact (RltI 0 1 real_0 real_1 SNoLt_0_1). }
claim Hnlt10: ~(Rlt 1 0).
{ exact (not_Rlt_sym 0 1 H0lt1). }
exact (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t))
           0 H0R
           (andI (~(Rlt 0 0)) (~(Rlt 1 0)) Hnlt00 Hnlt10)).
Qed.

(** helper: 1 is in the unit interval **)
Theorem one_in_unit_interval : 1 :e unit_interval.
prove 1 :e unit_interval.
claim H1R: 1 :e R.
{ exact real_1. }
claim H0lt1: Rlt 0 1.
{ exact (RltI 0 1 real_0 real_1 SNoLt_0_1). }
claim Hnlt10: ~(Rlt 1 0).
{ exact (not_Rlt_sym 0 1 H0lt1). }
claim Hnlt11: ~(Rlt 1 1).
{ exact (not_Rlt_refl 1 H1R). }
exact (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t))
           1 H1R
           (andI (~(Rlt 1 0)) (~(Rlt 1 1)) Hnlt10 Hnlt11)).
Qed.

(** helper: eps_1 is in the unit interval **)
Theorem eps_1_in_unit_interval : eps_ 1 :e unit_interval.
prove eps_ 1 :e unit_interval.
claim Hnlt_eps10: ~(Rlt (eps_ 1) 0).
{ exact (not_Rlt_sym 0 (eps_ 1) eps_1_pos_R). }
claim Hnlt_1eps1: ~(Rlt 1 (eps_ 1)).
{ exact (not_Rlt_sym (eps_ 1) 1 eps_1_lt1_R). }
exact (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t))
           (eps_ 1) eps_1_in_R
           (andI (~(Rlt (eps_ 1) 0)) (~(Rlt 1 (eps_ 1))) Hnlt_eps10 Hnlt_1eps1)).
Qed.

(** helper: 2 is not in the unit interval **)
(** LATEX VERSION: 2 is not in [0,1]. **)
Theorem two_not_in_unit_interval : 2 /:e unit_interval.
assume H2I: 2 :e unit_interval.
prove False.
claim H2R: 2 :e R.
{ exact (SepE1 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) 2 H2I). }
claim Hprop: ~(Rlt 1 2).
{ claim Hconj: ~(Rlt 2 0) /\ ~(Rlt 1 2).
  { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) 2 H2I). }
  exact (andER (~(Rlt 2 0)) (~(Rlt 1 2)) Hconj). }
claim H12: Rlt 1 2.
{ exact (RltI 1 2 real_1 H2R SNoLt_1_2). }
exact (Hprop H12).
Qed.

(** helper: 2 is a real number **)
(** LATEX VERSION: 2 is a real number. **)
Theorem two_in_R : 2 :e R.
prove 2 :e R.
claim HsumR: add_SNo 1 1 :e R.
{ exact (real_add_SNo 1 real_1 1 real_1). }
rewrite <- add_SNo_1_1_2.
exact HsumR.
Qed.

(** helper: unit interval is a proper subset of R **)
(** LATEX VERSION: [0,1] is not all of ℝ. **)
Theorem unit_interval_neq_R : unit_interval <> R.
assume Heq: unit_interval = R.
prove False.
claim H2I: 2 :e unit_interval.
{ rewrite Heq.
  exact two_in_R. }
exact (two_not_in_unit_interval H2I).
Qed.

(** helper: standard topology on the unit interval as a subspace of R **)
(** LATEX VERSION: Equip [0,1] with the subspace topology inherited from the standard topology on R. **)
Definition unit_interval_topology : set :=
  subspace_topology R R_standard_topology unit_interval.
Theorem unit_interval_topology_on : topology_on unit_interval unit_interval_topology.
prove topology_on unit_interval unit_interval_topology.
exact (subspace_topology_is_topology R R_standard_topology unit_interval
         R_standard_topology_is_topology
         unit_interval_sub_R).
Qed.

(** helper: flip map on the unit interval **)
(** LATEX VERSION: Notation helper: t |-> 1-t on [0,1], used for reversing parameterizations of paths. **)
Definition flip_unit_interval : set :=
  {(t, add_SNo 1 (minus_SNo t)) | t :e unit_interval}.

(** helper: application of flip_unit_interval **)
Theorem flip_unit_interval_apply : forall t:set,
  t :e unit_interval ->
  apply_fun flip_unit_interval t = add_SNo 1 (minus_SNo t).
let t.
assume Ht: t :e unit_interval.
prove apply_fun flip_unit_interval t = add_SNo 1 (minus_SNo t).
prove Eps_i (fun z => (t,z) :e flip_unit_interval) = add_SNo 1 (minus_SNo t).
claim H1: (t, add_SNo 1 (minus_SNo t)) :e flip_unit_interval.
{ exact (ReplI unit_interval (fun t0:set => (t0, add_SNo 1 (minus_SNo t0))) t Ht). }
claim H2: (t, Eps_i (fun z => (t,z) :e flip_unit_interval)) :e flip_unit_interval.
{ exact (Eps_i_ax (fun z => (t,z) :e flip_unit_interval) (add_SNo 1 (minus_SNo t)) H1). }
apply (ReplE_impred unit_interval (fun t0:set => (t0, add_SNo 1 (minus_SNo t0)))
        (t, Eps_i (fun z => (t,z) :e flip_unit_interval)) H2).
let y.
assume Hy: y :e unit_interval.
assume Heq: (t, Eps_i (fun z => (t,z) :e flip_unit_interval)) = (y, add_SNo 1 (minus_SNo y)).
claim Ht_eq: t = y.
{ rewrite <- (tuple_2_0_eq t (Eps_i (fun z => (t,z) :e flip_unit_interval))).
  rewrite <- (tuple_2_0_eq y (add_SNo 1 (minus_SNo y))).
  rewrite Heq.
  reflexivity. }
claim Hz_eq: Eps_i (fun z => (t,z) :e flip_unit_interval) = add_SNo 1 (minus_SNo y).
{ rewrite <- (tuple_2_1_eq t (Eps_i (fun z => (t,z) :e flip_unit_interval))).
  rewrite <- (tuple_2_1_eq y (add_SNo 1 (minus_SNo y))).
  rewrite Heq.
  reflexivity. }
rewrite Hz_eq.
rewrite <- Ht_eq.
reflexivity.
Qed.

(** helper: flip_unit_interval maps into R **)
Theorem flip_unit_interval_in_R : forall t:set,
  t :e unit_interval ->
  apply_fun flip_unit_interval t :e R.
let t.
assume Ht: t :e unit_interval.
prove apply_fun flip_unit_interval t :e R.
claim HtR: t :e R.
{ exact (unit_interval_sub_R t Ht). }
claim HmR: minus_SNo t :e R.
{ exact (real_minus_SNo t HtR). }
claim HaddR: add_SNo 1 (minus_SNo t) :e R.
{ exact (real_add_SNo 1 real_1 (minus_SNo t) HmR). }
rewrite (flip_unit_interval_apply t Ht).
exact HaddR.
Qed.

(** helper: flip_unit_interval at endpoints **)
Theorem flip_unit_interval_at_0 : apply_fun flip_unit_interval 0 = 1.
prove apply_fun flip_unit_interval 0 = 1.
claim H0I: 0 :e unit_interval.
{ exact zero_in_unit_interval. }
rewrite (flip_unit_interval_apply 0 H0I).
rewrite minus_SNo_0.
exact (add_SNo_0R 1 SNo_1).
Qed.

Theorem flip_unit_interval_at_1 : apply_fun flip_unit_interval 1 = 0.
prove apply_fun flip_unit_interval 1 = 0.
claim H1I: 1 :e unit_interval.
{ exact one_in_unit_interval. }
rewrite (flip_unit_interval_apply 1 H1I).
exact (add_SNo_minus_SNo_rinv 1 SNo_1).
Qed.

(** helper: flip_unit_interval is a self-map of the unit interval (placeholder) **)
Theorem flip_unit_interval_function_on :
  function_on flip_unit_interval unit_interval unit_interval.
let t.
assume HtI: t :e unit_interval.
prove apply_fun flip_unit_interval t :e unit_interval.
claim HtR: t :e R.
{ exact (unit_interval_sub_R t HtI). }
claim Htprop: ~(Rlt t 0) /\ ~(Rlt 1 t).
{ exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) t HtI). }
claim Hnlt_t0: ~(Rlt t 0).
{ exact (andEL (~(Rlt t 0)) (~(Rlt 1 t)) Htprop). }
claim Hnlt_1t: ~(Rlt 1 t).
{ exact (andER (~(Rlt t 0)) (~(Rlt 1 t)) Htprop). }
claim HmR: minus_SNo t :e R.
{ exact (real_minus_SNo t HtR). }
rewrite (flip_unit_interval_apply t HtI).
prove (add_SNo 1 (minus_SNo t)) :e unit_interval.
claim HsumR: add_SNo 1 (minus_SNo t) :e R.
{ exact (real_add_SNo 1 real_1 (minus_SNo t) HmR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (real_SNo (minus_SNo 1) Hm1R). }
claim HmtS: SNo (minus_SNo t).
{ exact (real_SNo (minus_SNo t) HmR). }

(** lower bound: ~( (1 + (-t)) < 0 ), using add_SNo cancellation **)
claim Hnlt_sum0: ~(Rlt (add_SNo 1 (minus_SNo t)) 0).
{ assume Hlt: Rlt (add_SNo 1 (minus_SNo t)) 0.
  prove False.
  claim HltS: (add_SNo 1 (minus_SNo t)) < 0.
  { exact (RltE_lt (add_SNo 1 (minus_SNo t)) 0 Hlt). }
  claim HltS1: (add_SNo 1 (minus_SNo t)) < (add_SNo 1 (minus_SNo 1)).
  { rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
    exact HltS. }
  claim Hmtltm1: (minus_SNo t) < (minus_SNo 1).
  { exact (add_SNo_Lt2_cancel 1 (minus_SNo t) (minus_SNo 1) SNo_1 HmtS Hm1S HltS1). }
  claim H1ltmm: 1 < minus_SNo (minus_SNo t).
  { exact (minus_SNo_Lt_contra2 (minus_SNo t) 1 HmtS SNo_1 Hmtltm1). }
  claim H1ltt: 1 < t.
  { rewrite <- (minus_SNo_invol t HtS).
    exact H1ltmm. }
  claim H1lt: Rlt 1 t.
  { exact (RltI 1 t real_1 HtR H1ltt). }
  exact (Hnlt_1t H1lt). }

(** upper bound: ~( 1 < (1 + (-t)) ), using add_SNo cancellation **)
claim Hnlt_1sum: ~(Rlt 1 (add_SNo 1 (minus_SNo t))).
{ assume Hlt: Rlt 1 (add_SNo 1 (minus_SNo t)).
  prove False.
  claim HltS: 1 < (add_SNo 1 (minus_SNo t)).
  { exact (RltE_lt 1 (add_SNo 1 (minus_SNo t)) Hlt). }
  claim HltS1: (add_SNo 1 0) < (add_SNo 1 (minus_SNo t)).
  { rewrite (add_SNo_0R 1 SNo_1).
    exact HltS. }
  claim H0ltmt: 0 < (minus_SNo t).
  { exact (add_SNo_Lt2_cancel 1 0 (minus_SNo t) SNo_1 SNo_0 HmtS HltS1). }
  claim Htltm0: t < minus_SNo 0.
  { exact (minus_SNo_Lt_contra2 0 t SNo_0 HtS H0ltmt). }
  claim Htlt0S: t < 0.
  { rewrite <- minus_SNo_0.
    exact Htltm0. }
  claim Htlt0: Rlt t 0.
  { exact (RltI t 0 HtR real_0 Htlt0S). }
  exact (Hnlt_t0 Htlt0). }

exact (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0))
           (add_SNo 1 (minus_SNo t)) HsumR
           (andI (~(Rlt (add_SNo 1 (minus_SNo t)) 0))
                 (~(Rlt 1 (add_SNo 1 (minus_SNo t))))
                 Hnlt_sum0 Hnlt_1sum)).
Qed.

(** helper: neighborhoods of eps_ 1 in the unit interval contain other points **)
(** LATEX VERSION: Any open set in the unit interval topology containing 1/2 contains a point different from 1/2. **)
Theorem unit_interval_open_neighborhood_has_other_point : forall U0:set,
  U0 :e unit_interval_topology ->
  eps_ 1 :e U0 ->
  exists x:set, x :e U0 /\ x <> eps_ 1.
let U0.
assume HU0Tx: U0 :e unit_interval_topology.
assume HepsU0: eps_ 1 :e U0.
claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
claim HU0Sub: U0 :e subspace_topology R R_standard_topology unit_interval.
{ rewrite <- Hut. exact HU0Tx. }
claim HU0Pow: U0 :e Power unit_interval.
{ exact (SepE1 (Power unit_interval)
               (fun U:set => exists V :e R_standard_topology, U = V :/\: unit_interval)
               U0 HU0Sub). }
claim HU0subI: U0 c= unit_interval.
{ exact (PowerE unit_interval U0 HU0Pow). }
claim HepsI: eps_ 1 :e unit_interval.
{ exact (HU0subI (eps_ 1) HepsU0). }
claim HepsR: eps_ 1 :e R.
{ exact (unit_interval_sub_R (eps_ 1) HepsI). }
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim HepsS: SNo (eps_ 1).
{ exact (real_SNo (eps_ 1) HepsR). }
claim HepsPosS: 0 < (eps_ 1).
{ exact (SNo_eps_pos 1 H1omega). }
claim H0ltEps: Rlt 0 (eps_ 1).
{ exact (RltI 0 (eps_ 1) real_0 HepsR HepsPosS). }
claim H0Ord: ordinal 0.
{ exact (nat_p_ordinal 0 nat_0). }
claim H0in1: 0 :e 1.
{ exact (ordinal_0_In_ordsucc 0 H0Ord). }
claim HepsLt1S: (eps_ 1) < 1.
{ claim HepsLtE0: eps_ 1 < eps_ 0.
  { exact (SNo_eps_decr 1 H1omega 0 H0in1). }
  rewrite <- (eps_0_1) at 2.
  exact HepsLtE0. }
claim HepsLt1: Rlt (eps_ 1) 1.
{ exact (RltI (eps_ 1) 1 HepsR real_1 HepsLt1S). }
claim HexV: exists V :e R_standard_topology, U0 = V :/\: unit_interval.
{ exact (SepE2 (Power unit_interval)
               (fun U:set => exists V :e R_standard_topology, U = V :/\: unit_interval)
               U0 HU0Sub). }
apply HexV.
let V.
assume HVpair.
claim HV: V :e R_standard_topology.
{ exact (andEL (V :e R_standard_topology) (U0 = V :/\: unit_interval) HVpair). }
claim HU0eq: U0 = V :/\: unit_interval.
{ exact (andER (V :e R_standard_topology) (U0 = V :/\: unit_interval) HVpair). }
claim HepsV: eps_ 1 :e V.
{ claim HepsCap: eps_ 1 :e V :/\: unit_interval.
  { rewrite <- HU0eq. exact HepsU0. }
  apply (binintersectE V unit_interval (eps_ 1) HepsCap).
  assume HepsV0 HepsI0.
  exact HepsV0. }
claim HrTopDef: R_standard_topology = generated_topology R R_standard_basis.
{ reflexivity. }
claim HVgen: V :e generated_topology R R_standard_basis.
{ rewrite <- HrTopDef. exact HV. }
claim HVprop: forall x :e V, exists b :e R_standard_basis, x :e b /\ b c= V.
{ exact (SepE2 (Power R)
               (fun U:set => forall x0 :e U, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U)
               V HVgen). }
claim Hexb: exists b :e R_standard_basis, eps_ 1 :e b /\ b c= V.
{ exact (HVprop (eps_ 1) HepsV). }
apply Hexb.
let b.
assume Hbpair.
claim HbB: b :e R_standard_basis.
{ exact (andEL (b :e R_standard_basis) (eps_ 1 :e b /\ b c= V) Hbpair). }
claim Hbprop: eps_ 1 :e b /\ b c= V.
{ exact (andER (b :e R_standard_basis) (eps_ 1 :e b /\ b c= V) Hbpair). }
claim Hepsb: eps_ 1 :e b.
{ exact (andEL (eps_ 1 :e b) (b c= V) Hbprop). }
claim HbsubV: b c= V.
{ exact (andER (eps_ 1 :e b) (b c= V) Hbprop). }
claim Hexa: exists a :e R, b :e {open_interval a bb|bb :e R}.
{ exact (famunionE R (fun a0:set => {open_interval a0 bb|bb :e R}) b HbB). }
apply Hexa.
let a.
assume Hapair.
claim HaR: a :e R.
{ exact (andEL (a :e R) (b :e {open_interval a bb|bb :e R}) Hapair). }
claim HbFam: b :e {open_interval a bb|bb :e R}.
{ exact (andER (a :e R) (b :e {open_interval a bb|bb :e R}) Hapair). }
claim Hexbb: exists bb :e R, b = open_interval a bb.
{ exact (ReplE R (fun bb0:set => open_interval a bb0) b HbFam). }
apply Hexbb.
let bb.
assume Hbbpair.
claim HbbR: bb :e R.
{ exact (andEL (bb :e R) (b = open_interval a bb) Hbbpair). }
claim Hbeq: b = open_interval a bb.
{ exact (andER (bb :e R) (b = open_interval a bb) Hbbpair). }
claim HepsInInt: eps_ 1 :e open_interval a bb.
{ rewrite <- Hbeq. exact Hepsb. }
claim HepsIntProp: Rlt a (eps_ 1) /\ Rlt (eps_ 1) bb.
{ exact (SepE2 R (fun t:set => Rlt a t /\ Rlt t bb) (eps_ 1) HepsInInt). }
claim HaLtEps: Rlt a (eps_ 1).
{ exact (andEL (Rlt a (eps_ 1)) (Rlt (eps_ 1) bb) HepsIntProp). }
claim HepsLtbb: Rlt (eps_ 1) bb.
{ exact (andER (Rlt a (eps_ 1)) (Rlt (eps_ 1) bb) HepsIntProp). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbbS: SNo bb.
{ exact (real_SNo bb HbbR). }
apply (SNoLt_trichotomy_or_impred bb 1 HbbS SNo_1 (exists x:set, x :e U0 /\ x <> eps_ 1)).
- assume HbbLt1S: bb < 1.
  claim HbbLt1: Rlt bb 1.
  { exact (RltI bb 1 HbbR real_1 HbbLt1S). }
  apply (rational_dense_between_reals (eps_ 1) bb HepsR HbbR HepsLtbb).
  let q.
  assume Hqpair.
  claim HqQ: q :e rational_numbers.
  { exact (andEL (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q bb) Hqpair). }
  claim Hqprop: Rlt (eps_ 1) q /\ Rlt q bb.
  { exact (andER (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q bb) Hqpair). }
  claim HepsLtq: Rlt (eps_ 1) q.
  { exact (andEL (Rlt (eps_ 1) q) (Rlt q bb) Hqprop). }
  claim HqLtbb: Rlt q bb.
  { exact (andER (Rlt (eps_ 1) q) (Rlt q bb) Hqprop). }
  claim HqR: q :e R.
  { exact (rational_numbers_in_R q HqQ). }
  claim HaLtq: Rlt a q.
  { exact (Rlt_tra a (eps_ 1) q HaLtEps HepsLtq). }
  claim HqInb: q :e b.
  { rewrite Hbeq.
    claim Hqconj: Rlt a q /\ Rlt q bb.
    { apply andI.
      - exact HaLtq.
      - exact HqLtbb. }
    exact (SepI R (fun t:set => Rlt a t /\ Rlt t bb) q HqR Hqconj). }
  claim HqInV: q :e V.
  { exact (HbsubV q HqInb). }
  claim H0ltq: Rlt 0 q.
  { exact (Rlt_tra 0 (eps_ 1) q H0ltEps HepsLtq). }
  claim HqLt1: Rlt q 1.
  { exact (Rlt_tra q bb 1 HqLtbb HbbLt1). }
  claim Hnltq0: ~(Rlt q 0).
  { exact (not_Rlt_sym 0 q H0ltq). }
  claim Hnlt1q: ~(Rlt 1 q).
  { exact (not_Rlt_sym q 1 HqLt1). }
  claim HqInI: q :e unit_interval.
  { claim Hqconj: ~(Rlt q 0) /\ ~(Rlt 1 q).
    { apply andI.
      - exact Hnltq0.
      - exact Hnlt1q. }
    exact (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) q HqR Hqconj). }
  claim HqInU0: q :e U0.
  { rewrite HU0eq.
    apply binintersectI.
    - exact HqInV.
    - exact HqInI. }
  witness q.
  apply andI.
  * exact HqInU0.
  * prove q <> eps_ 1.
    assume Heq: q = eps_ 1.
    claim Hbad: Rlt (eps_ 1) (eps_ 1).
    { rewrite <- Heq at 2. exact HepsLtq. }
    exact ((not_Rlt_refl (eps_ 1) HepsR) Hbad).
- assume HbbEq: bb = 1.
  apply (rational_dense_between_reals (eps_ 1) 1 HepsR real_1 HepsLt1).
  let q.
  assume Hqpair.
  claim HqQ: q :e rational_numbers.
  { exact (andEL (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q 1) Hqpair). }
  claim Hqprop: Rlt (eps_ 1) q /\ Rlt q 1.
  { exact (andER (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q 1) Hqpair). }
  claim HepsLtq: Rlt (eps_ 1) q.
  { exact (andEL (Rlt (eps_ 1) q) (Rlt q 1) Hqprop). }
  claim HqLt1: Rlt q 1.
  { exact (andER (Rlt (eps_ 1) q) (Rlt q 1) Hqprop). }
  claim HqR: q :e R.
  { exact (rational_numbers_in_R q HqQ). }
  claim HaLtq: Rlt a q.
  { exact (Rlt_tra a (eps_ 1) q HaLtEps HepsLtq). }
  claim HqLtbb: Rlt q bb.
  { rewrite HbbEq. exact HqLt1. }
  claim HqInb: q :e b.
  { rewrite Hbeq.
    claim Hqconj: Rlt a q /\ Rlt q bb.
    { apply andI.
      - exact HaLtq.
      - exact HqLtbb. }
    exact (SepI R (fun t:set => Rlt a t /\ Rlt t bb) q HqR Hqconj). }
  claim HqInV: q :e V.
  { exact (HbsubV q HqInb). }
  claim H0ltq: Rlt 0 q.
  { exact (Rlt_tra 0 (eps_ 1) q H0ltEps HepsLtq). }
  claim Hnltq0: ~(Rlt q 0).
  { exact (not_Rlt_sym 0 q H0ltq). }
  claim Hnlt1q: ~(Rlt 1 q).
  { exact (not_Rlt_sym q 1 HqLt1). }
  claim HqInI: q :e unit_interval.
  { claim Hqconj: ~(Rlt q 0) /\ ~(Rlt 1 q).
    { apply andI.
      - exact Hnltq0.
      - exact Hnlt1q. }
    exact (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) q HqR Hqconj). }
  claim HqInU0: q :e U0.
  { rewrite HU0eq.
    apply binintersectI.
    - exact HqInV.
    - exact HqInI. }
  witness q.
  apply andI.
  * exact HqInU0.
  * prove q <> eps_ 1.
    assume Heq: q = eps_ 1.
    claim Hbad: Rlt (eps_ 1) (eps_ 1).
    { rewrite <- Heq at 2. exact HepsLtq. }
    exact ((not_Rlt_refl (eps_ 1) HepsR) Hbad).
- assume H1LtbbS: 1 < bb.
  claim H1Ltbb: Rlt 1 bb.
  { exact (RltI 1 bb real_1 HbbR H1LtbbS). }
  apply (rational_dense_between_reals (eps_ 1) 1 HepsR real_1 HepsLt1).
  let q.
  assume Hqpair.
  claim HqQ: q :e rational_numbers.
  { exact (andEL (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q 1) Hqpair). }
  claim Hqprop: Rlt (eps_ 1) q /\ Rlt q 1.
  { exact (andER (q :e rational_numbers) (Rlt (eps_ 1) q /\ Rlt q 1) Hqpair). }
  claim HepsLtq: Rlt (eps_ 1) q.
  { exact (andEL (Rlt (eps_ 1) q) (Rlt q 1) Hqprop). }
  claim HqLt1: Rlt q 1.
  { exact (andER (Rlt (eps_ 1) q) (Rlt q 1) Hqprop). }
  claim HqR: q :e R.
  { exact (rational_numbers_in_R q HqQ). }
  claim HaLtq: Rlt a q.
  { exact (Rlt_tra a (eps_ 1) q HaLtEps HepsLtq). }
  claim HqLtbb: Rlt q bb.
  { exact (Rlt_tra q 1 bb HqLt1 H1Ltbb). }
  claim HqInb: q :e b.
  { rewrite Hbeq.
    claim Hqconj: Rlt a q /\ Rlt q bb.
    { apply andI.
      - exact HaLtq.
      - exact HqLtbb. }
    exact (SepI R (fun t:set => Rlt a t /\ Rlt t bb) q HqR Hqconj). }
  claim HqInV: q :e V.
  { exact (HbsubV q HqInb). }
  claim H0ltq: Rlt 0 q.
  { exact (Rlt_tra 0 (eps_ 1) q H0ltEps HepsLtq). }
  claim Hnltq0: ~(Rlt q 0).
  { exact (not_Rlt_sym 0 q H0ltq). }
  claim Hnlt1q: ~(Rlt 1 q).
  { exact (not_Rlt_sym q 1 HqLt1). }
  claim HqInI: q :e unit_interval.
  { claim Hqconj: ~(Rlt q 0) /\ ~(Rlt 1 q).
    { apply andI.
      - exact Hnltq0.
      - exact Hnlt1q. }
    exact (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) q HqR Hqconj). }
  claim HqInU0: q :e U0.
  { rewrite HU0eq.
    apply binintersectI.
    - exact HqInV.
    - exact HqInI. }
  witness q.
  apply andI.
  * exact HqInU0.
  * prove q <> eps_ 1.
    assume Heq: q = eps_ 1.
    claim Hbad: Rlt (eps_ 1) (eps_ 1).
    { rewrite <- Heq at 2. exact HepsLtq. }
    exact ((not_Rlt_refl (eps_ 1) HepsR) Hbad).
Qed.
(** from §16 Example: the ordered square I_o^2 **)
(** LATEX VERSION: The set I×I in the dictionary order topology is called the ordered square and denoted I_o^2. **)
Definition ordered_square : set := setprod unit_interval unit_interval.

(** from §16 Example: basis for the dictionary order topology on I×I **)
(** LATEX VERSION: The dictionary order topology is the order topology induced by the lexicographic order; basic opens are intervals and rays. **)
(** helper: basis for the dictionary order topology on I×I, using the dictionary comparison on R×R **)
Definition ordered_square_order_basis : set :=
  ({I :e Power ordered_square | exists a :e ordered_square, exists b :e ordered_square,
        I = {x :e ordered_square | order_rel (setprod R R) a x /\ order_rel (setprod R R) x b}}
   :\/:
   {I :e Power ordered_square | exists b :e ordered_square,
        I = {x :e ordered_square | order_rel (setprod R R) x b}}
   :\/:
   {I :e Power ordered_square | exists a :e ordered_square,
        I = {x :e ordered_square | order_rel (setprod R R) a x}}).

(** from §16 Example: the ordered square topology **)
(** LATEX VERSION: The ordered square carries the order topology from the dictionary order. **)
Definition ordered_square_topology : set := generated_topology ordered_square ordered_square_order_basis.
(** LATEX VERSION: The vertical strip {1/2}×(1/2,1] inside I×I. **)
Definition ordered_square_open_strip : set :=
  {p :e ordered_square|exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y)}.

(** from §16 Example 3: order topology vs subspace topology **)
(** LATEX VERSION: The order topology on I×I is not the same as the subspace topology inherited from R×R in the dictionary order topology. **)
Definition ordered_square_subspace_topology : set :=
  subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.

(** helper: ordered square is a proper subset of R×R **)
(** LATEX VERSION: I×I is a proper subset of ℝ×ℝ. **)
Theorem ordered_square_neq_setprod_R_R : ordered_square <> setprod R R.
assume Heq: ordered_square = setprod R R.
prove False.
set p := (2,2).
claim HpRR: p :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R 2 2 two_in_R two_in_R). }
claim HpOS: p :e ordered_square.
{ rewrite Heq.
  exact HpRR. }
claim HpSing: p :e setprod {2} {2}.
{ exact (tuple_2_setprod_by_pair_Sigma {2} {2} 2 2 (SingI 2) (SingI 2)). }
claim Hcoords: 2 :e unit_interval /\ 2 :e unit_interval.
{ exact (setprod_coords_in 2 2 unit_interval unit_interval p HpSing HpOS). }
claim H2I: 2 :e unit_interval.
{ exact (andEL (2 :e unit_interval) (2 :e unit_interval) Hcoords). }
exact (two_not_in_unit_interval H2I).
Qed.

(** helper: ordered square as a standard subspace is the product topology **)
(** LATEX VERSION: The standard subspace topology on I×I agrees with the product topology on I×I. **)
Theorem ordered_square_standard_subspace_equals_product :
  subspace_topology (setprod R R) R2_standard_topology ordered_square =
  product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
prove subspace_topology (setprod R R) R2_standard_topology ordered_square =
  product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
claim Hsq: ordered_square = setprod unit_interval unit_interval.
{ reflexivity. }
claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
rewrite Hsq.
rewrite Hut.
rewrite R2_standard_equals_product.
(** rewrite the product topology as a subspace of the product using `product_subspace_topology` **)
rewrite (product_subspace_topology
          R R_standard_topology
          R R_standard_topology
          unit_interval unit_interval
          R_standard_topology_is_topology R_standard_topology_is_topology
          unit_interval_sub_R unit_interval_sub_R).
reflexivity.
Qed.

Theorem ordered_square_not_subspace_dictionary :
  ordered_square_topology <> subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.
prove ordered_square_topology <> subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.
assume Heq: ordered_square_topology =
  subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.
prove False.
set U := ordered_square_open_strip.

(** U is open in the dictionary order subspace topology **)
claim HUdic: U :e subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.
{ claim HUsub: U c= ordered_square.
  { let p. assume Hp: p :e U.
    exact (SepE1 ordered_square
                 (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                 p Hp). }
  claim HUpow: U :e Power ordered_square.
  { exact (PowerI ordered_square U HUsub). }
  set a := (eps_ 1, eps_ 1).
  set b := (eps_ 1, 2).
	  set V := {p :e setprod R R | order_rel (setprod R R) a p /\ order_rel (setprod R R) p b}.
	
	  claim HVopen: V :e R2_dictionary_order_topology.
	  { set X := setprod R R.
	    claim HS: subbasis_on X (open_rays_subbasis X).
	    { exact (open_rays_subbasis_is_subbasis X). }
	    claim HT: topology_on X R2_dictionary_order_topology.
	    { exact dictionary_order_topology_is_topology. }
	    claim HaX: a :e X.
	    { exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) (eps_ 1) eps_1_in_R eps_1_in_R). }
	    claim HbX: b :e X.
	    { exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) 2 eps_1_in_R two_in_R). }
	    set U1 := open_ray_upper X a.
	    set U2 := open_ray_lower X b.
	    claim HU1S: U1 :e open_rays_subbasis X.
	    { exact (open_ray_upper_in_open_rays_subbasis X a HaX). }
	    claim HU2S: U2 :e open_rays_subbasis X.
	    { exact (open_ray_lower_in_open_rays_subbasis X b HbX). }
	    claim HU1open: U1 :e R2_dictionary_order_topology.
	    { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U1 HS HU1S). }
	    claim HU2open: U2 :e R2_dictionary_order_topology.
	    { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U2 HS HU2S). }
	    claim HVeq: V = U1 :/\: U2.
	    { claim HdefV: V = {p :e X | order_rel X a p /\ order_rel X p b}.
	      { reflexivity. }
	      rewrite HdefV.
	      exact (open_interval_eq_rays_intersection X a b). }
	    rewrite HVeq.
	    exact (topology_binintersect_closed X R2_dictionary_order_topology U1 U2 HT HU1open HU2open).
	  }

  claim HeqU: U = V :/\: ordered_square.
  { apply set_ext.
    - let p. assume HpU: p :e U.
      prove p :e V :/\: ordered_square.
      claim HpSq: p :e ordered_square.
      { exact (HUsub p HpU). }
      claim Hexy: exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
      { exact (SepE2 ordered_square
                   (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                   p HpU). }
      apply Hexy.
      let y. assume Hyprop.
      claim Hpair: (p = (eps_ 1,y) /\ Rlt (eps_ 1) y).
      { exact (andEL (p = (eps_ 1,y) /\ Rlt (eps_ 1) y) (~(Rlt 1 y)) Hyprop). }
      claim Hpy: p = (eps_ 1,y).
      { exact (andEL (p = (eps_ 1,y)) (Rlt (eps_ 1) y) Hpair). }
      claim Hey: Rlt (eps_ 1) y.
      { exact (andER (p = (eps_ 1,y)) (Rlt (eps_ 1) y) Hpair). }
      claim Hnlt1y: ~(Rlt 1 y).
      { exact (andER (p = (eps_ 1,y) /\ Rlt (eps_ 1) y) (~(Rlt 1 y)) Hyprop). }
      claim HyR: y :e R.
      { exact (RltE_right (eps_ 1) y Hey). }
      claim Hylt2: Rlt y 2.
      { (** y <= 1 and 1 < 2 gives y < 2 **)
        claim HyS: SNo y.
        { exact (real_SNo y HyR). }
        claim H1S: SNo 1.
        { exact (real_SNo 1 real_1). }
        claim H2S: SNo 2.
        { exact (real_SNo 2 two_in_R). }
        claim HnltS: ~(1 < y).
        { assume Hlt: 1 < y.
          claim H1y: Rlt 1 y.
          { exact (RltI 1 y real_1 HyR Hlt). }
          exact (Hnlt1y H1y). }
        apply (SNoLt_trichotomy_or_impred y 1 HyS H1S (Rlt y 2)).
        - assume Hylt1S: y < 1.
          claim Hylt2S: y < 2.
          { exact (SNoLt_tra y 1 2 HyS H1S H2S Hylt1S SNoLt_1_2). }
          exact (RltI y 2 HyR two_in_R Hylt2S).
        - assume Hyeq: y = 1.
          rewrite Hyeq.
          exact (RltI 1 2 real_1 two_in_R SNoLt_1_2).
        - assume H1ltyS: 1 < y.
          apply FalseE.
          exact (HnltS H1ltyS). }
      claim HpV: p :e V.
      { rewrite Hpy.
        claim HpRR: (eps_ 1,y) :e setprod R R.
        { exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) y eps_1_in_R HyR). }
        claim Hord1: order_rel (setprod R R) a (eps_ 1,y).
        { apply (order_rel_setprod_R_R_intro (eps_ 1) (eps_ 1) (eps_ 1) y).
          apply orIR.
          apply andI.
          - reflexivity.
          - exact Hey. }
        claim Hord2: order_rel (setprod R R) (eps_ 1,y) b.
        { apply (order_rel_setprod_R_R_intro (eps_ 1) y (eps_ 1) 2).
          apply orIR.
          apply andI.
          - reflexivity.
          - exact Hylt2. }
        claim Hpconj: order_rel (setprod R R) a (eps_ 1,y) /\ order_rel (setprod R R) (eps_ 1,y) b.
        { exact (andI (order_rel (setprod R R) a (eps_ 1,y))
                      (order_rel (setprod R R) (eps_ 1,y) b)
                      Hord1 Hord2). }
        exact (SepI (setprod R R)
                    (fun p0:set => order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b)
                    (eps_ 1,y) HpRR Hpconj). }
      apply binintersectI.
      - exact HpV.
      - exact HpSq.
	    - let p. assume HpCap: p :e V :/\: ordered_square.
	      prove p :e U.
	      claim HpV: p :e V.
	      { exact (binintersectE1 V ordered_square p HpCap). }
	      claim HpSq: p :e ordered_square.
	      { exact (binintersectE2 V ordered_square p HpCap). }
	      claim HpRR: p :e setprod R R.
	      { exact (SepE1 (setprod R R)
	                   (fun p0:set => order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b)
	                   p
	                   HpV). }
	      claim HpEta: p = (p 0, p 1).
	      { exact (setprod_eta R R p HpRR). }
	      claim Hpord: order_rel (setprod R R) a p /\ order_rel (setprod R R) p b.
	      { exact (SepE2 (setprod R R)
	                     (fun p0:set => order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b)
	                     p
	                     HpV). }
	      claim Hord1: order_rel (setprod R R) a p.
	      { exact (andEL (order_rel (setprod R R) a p)
	                     (order_rel (setprod R R) p b)
	                     Hpord). }
	      claim Hord2: order_rel (setprod R R) p b.
	      { exact (andER (order_rel (setprod R R) a p)
	                     (order_rel (setprod R R) p b)
	                     Hpord). }
	      claim Hex_ap: exists a1 a2 b1 b2:set,
	        a = (a1, a2) /\ p = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	      { exact (order_rel_setprod_R_R_unfold a p Hord1). }
	      claim Hex_pb: exists a1 a2 b1 b2:set,
	        p = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
	      { exact (order_rel_setprod_R_R_unfold p b Hord2). }
	      claim Hdisj1p: Rlt (eps_ 1) (p 0) \/ ((eps_ 1) = (p 0) /\ Rlt (eps_ 1) (p 1)).
	      { apply Hex_ap.
	        let a1. assume Hex_a2.
	        apply Hex_a2.
	        let a2. assume Hex_b1.
	        apply Hex_b1.
	        let b1. assume Hex_b2.
	        apply Hex_b2.
	        let b2. assume Hap.
	        claim Hcore1: a = (a1, a2) /\ p = (b1, b2).
	        { exact (andEL (a = (a1, a2) /\ p = (b1, b2))
	                      (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
	                      Hap). }
	        claim HaEq: a = (a1, a2).
	        { exact (andEL (a = (a1, a2)) (p = (b1, b2)) Hcore1). }
	        claim HpEq: p = (b1, b2).
	        { exact (andER (a = (a1, a2)) (p = (b1, b2)) Hcore1). }
	        claim Hdisj1: Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2).
	        { exact (andER (a = (a1, a2) /\ p = (b1, b2))
	                      (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
	                      Hap). }
	        claim HaDef: a = (eps_ 1, eps_ 1).
	        { reflexivity. }
	        claim Haa: (eps_ 1, eps_ 1) = (a1, a2).
	        { rewrite HaDef at 1.
	          exact HaEq. }
	        claim HaCoords: (eps_ 1) = a1 /\ (eps_ 1) = a2.
	        { exact (tuple_eq_coords (eps_ 1) (eps_ 1) a1 a2 Haa). }
	        claim Ha1eq: a1 = eps_ 1.
	        { symmetry.
	          exact (andEL ((eps_ 1) = a1) ((eps_ 1) = a2) HaCoords). }
	        claim Ha2eq: a2 = eps_ 1.
	        { symmetry.
	          exact (andER ((eps_ 1) = a1) ((eps_ 1) = a2) HaCoords). }
	        claim Hbb: (b1, b2) = (p 0, p 1).
	        { rewrite <- HpEq at 1.
	          exact HpEta. }
	        claim HbCoords: b1 = p 0 /\ b2 = p 1.
	        { exact (tuple_eq_coords b1 b2 (p 0) (p 1) Hbb). }
	        claim Hb1eq: b1 = p 0.
	        { exact (andEL (b1 = p 0) (b2 = p 1) HbCoords). }
	        claim Hb2eq: b2 = p 1.
	        { exact (andER (b1 = p 0) (b2 = p 1) HbCoords). }
	        apply (Hdisj1 (Rlt (eps_ 1) (p 0) \/ ((eps_ 1) = (p 0) /\ Rlt (eps_ 1) (p 1)))).
	        - assume Hlt: Rlt a1 b1.
	          apply orIL.
	          prove Rlt (eps_ 1) (p 0).
		          claim Htmp: Rlt (eps_ 1) b1.
		          { rewrite <- Ha1eq at 1.
		            exact Hlt. }
	          rewrite <- Hb1eq at 1.
	          exact Htmp.
	        - assume Hc: a1 = b1 /\ Rlt a2 b2.
	          claim Ha1b1: a1 = b1.
	          { exact (andEL (a1 = b1) (Rlt a2 b2) Hc). }
	          claim Ha2b2: Rlt a2 b2.
	          { exact (andER (a1 = b1) (Rlt a2 b2) Hc). }
	          claim Heq0: (eps_ 1) = (p 0).
	          { prove (eps_ 1) = (p 0).
	            claim Heq1: (eps_ 1) = b1.
	            { rewrite <- Ha1eq at 1.
	              exact Ha1b1. }
		            rewrite <- Hb1eq at 1.
	            exact Heq1. }
	          claim Hlt1: Rlt (eps_ 1) (p 1).
	          { prove Rlt (eps_ 1) (p 1).
		            claim Htmp2: Rlt (eps_ 1) b2.
		            { rewrite <- Ha2eq at 1.
		              exact Ha2b2. }
		            rewrite <- Hb2eq at 1.
	            exact Htmp2. }
	          apply orIR.
	          exact (andI ((eps_ 1) = (p 0)) (Rlt (eps_ 1) (p 1)) Heq0 Hlt1). }
	      claim Hdisj2p: Rlt (p 0) (eps_ 1) \/ ((p 0) = (eps_ 1) /\ Rlt (p 1) 2).
	      { apply Hex_pb.
	        let c1. assume Hex_c2.
	        apply Hex_c2.
	        let c2. assume Hex_d1.
	        apply Hex_d1.
	        let d1. assume Hex_d2.
	        apply Hex_d2.
	        let d2. assume Hpb.
	        claim Hcore2: p = (c1, c2) /\ b = (d1, d2).
	        { exact (andEL (p = (c1, c2) /\ b = (d1, d2))
	                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
	                      Hpb). }
	        claim HpEq2: p = (c1, c2).
	        { exact (andEL (p = (c1, c2)) (b = (d1, d2)) Hcore2). }
	        claim HbEq: b = (d1, d2).
	        { exact (andER (p = (c1, c2)) (b = (d1, d2)) Hcore2). }
	        claim Hdisj2: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
	        { exact (andER (p = (c1, c2) /\ b = (d1, d2))
	                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
	                      Hpb). }
	        claim Hpc: (c1, c2) = (p 0, p 1).
	        { rewrite <- HpEq2 at 1.
	          exact HpEta. }
	        claim HpCoords: c1 = p 0 /\ c2 = p 1.
	        { exact (tuple_eq_coords c1 c2 (p 0) (p 1) Hpc). }
	        claim Hc1eq: c1 = p 0.
	        { exact (andEL (c1 = p 0) (c2 = p 1) HpCoords). }
	        claim Hc2eq: c2 = p 1.
	        { exact (andER (c1 = p 0) (c2 = p 1) HpCoords). }
	        claim HbDef: b = (eps_ 1, 2).
	        { reflexivity. }
	        claim Hbd: (eps_ 1, 2) = (d1, d2).
	        { rewrite HbDef at 1.
	          exact HbEq. }
	        claim HbCoords: (eps_ 1) = d1 /\ 2 = d2.
	        { exact (tuple_eq_coords (eps_ 1) 2 d1 d2 Hbd). }
	        claim Hd1eq: d1 = eps_ 1.
	        { symmetry.
	          exact (andEL ((eps_ 1) = d1) (2 = d2) HbCoords). }
	        claim Hd2eq: d2 = 2.
	        { symmetry.
	          exact (andER ((eps_ 1) = d1) (2 = d2) HbCoords). }
	        apply (Hdisj2 (Rlt (p 0) (eps_ 1) \/ ((p 0) = (eps_ 1) /\ Rlt (p 1) 2))).
	        - assume Hlt: Rlt c1 d1.
	          apply orIL.
	          prove Rlt (p 0) (eps_ 1).
	          claim Htmp: Rlt (p 0) d1.
	          { rewrite <- Hc1eq at 1.
	            exact Hlt. }
		          rewrite <- Hd1eq at 1.
	          exact Htmp.
	        - assume Hc: c1 = d1 /\ Rlt c2 d2.
	          claim Hc1d1: c1 = d1.
	          { exact (andEL (c1 = d1) (Rlt c2 d2) Hc). }
	          claim Hc2d2: Rlt c2 d2.
	          { exact (andER (c1 = d1) (Rlt c2 d2) Hc). }
	          claim Heq0: (p 0) = (eps_ 1).
	          { prove (p 0) = (eps_ 1).
		            claim Heq1: (p 0) = d1.
		            { rewrite <- Hc1eq at 1.
		              exact Hc1d1. }
		            rewrite <- Hd1eq at 1.
	            exact Heq1. }
	          claim Hlt1: Rlt (p 1) 2.
	          { prove Rlt (p 1) 2.
	            claim Htmp2: Rlt (p 1) d2.
	            { rewrite <- Hc2eq at 1.
	              exact Hc2d2. }
		            rewrite <- Hd2eq at 1.
	            exact Htmp2. }
	          apply orIR.
	          exact (andI ((p 0) = (eps_ 1)) (Rlt (p 1) 2) Heq0 Hlt1). }
	      claim Hp0eq: (p 0) = (eps_ 1).
	      { apply (Hdisj2p ((p 0) = (eps_ 1))).
	        - assume Hp0lt: Rlt (p 0) (eps_ 1).
	          apply FalseE.
	          apply (Hdisj1p False).
	          + assume Hepslt: Rlt (eps_ 1) (p 0).
	            exact ((not_Rlt_sym (eps_ 1) (p 0) Hepslt) Hp0lt).
	          + assume Hc: (eps_ 1) = (p 0) /\ Rlt (eps_ 1) (p 1).
	            claim Heq: (p 0) = (eps_ 1).
	            { symmetry.
	              exact (andEL ((eps_ 1) = (p 0)) (Rlt (eps_ 1) (p 1)) Hc). }
		            claim Hbad: Rlt (eps_ 1) (eps_ 1).
		            { rewrite <- Heq at 1.
		              exact Hp0lt. }
	            exact ((not_Rlt_refl (eps_ 1) eps_1_in_R) Hbad).
	        - assume Hc: (p 0) = (eps_ 1) /\ Rlt (p 1) 2.
	          exact (andEL ((p 0) = (eps_ 1)) (Rlt (p 1) 2) Hc). }
	      claim Hey: Rlt (eps_ 1) (p 1).
	      { apply (Hdisj1p (Rlt (eps_ 1) (p 1))).
	        - assume Hepslt: Rlt (eps_ 1) (p 0).
	          apply FalseE.
		          claim Hbad: Rlt (eps_ 1) (eps_ 1).
		          { rewrite <- Hp0eq at 2.
		            exact Hepslt. }
	          exact ((not_Rlt_refl (eps_ 1) eps_1_in_R) Hbad).
	        - assume Hc: (eps_ 1) = (p 0) /\ Rlt (eps_ 1) (p 1).
	          exact (andER ((eps_ 1) = (p 0)) (Rlt (eps_ 1) (p 1)) Hc). }
	      claim HyU: (p 1) :e unit_interval.
	      { exact (ap1_Sigma unit_interval (fun _ : set => unit_interval) p HpSq). }
	      claim Hnlt1y: ~(Rlt 1 (p 1)).
	      { exact (andER (~(Rlt (p 1) 0)) (~(Rlt 1 (p 1)))
	                    (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (p 1) HyU)). }
	      apply (SepI ordered_square
	                  (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
	                  p
	                  HpSq).
	      witness (p 1).
	      prove p = (eps_ 1, p 1) /\ Rlt (eps_ 1) (p 1) /\ ~(Rlt 1 (p 1)).
	      apply andI.
	      - prove p = (eps_ 1, p 1) /\ Rlt (eps_ 1) (p 1).
	        apply andI.
		        + prove p = (eps_ 1, p 1).
		          rewrite HpEta at 1.
		          rewrite Hp0eq.
		          reflexivity.
	        + exact Hey.
	      - exact Hnlt1y. }

  claim Hex: exists W :e R2_dictionary_order_topology, U = W :/\: ordered_square.
  { witness V.
    apply andI.
    - exact HVopen.
    - exact HeqU. }
  exact (SepI (Power ordered_square)
              (fun U0:set => exists W :e R2_dictionary_order_topology, U0 = W :/\: ordered_square)
              U HUpow Hex). }

claim HUord: U :e ordered_square_topology.
{ rewrite Heq.
  exact HUdic. }

claim HUnord: ~(U :e ordered_square_topology).
{ assume HU: U :e ordered_square_topology.
  prove False.
  claim HUgt: U :e generated_topology ordered_square ordered_square_order_basis.
  { claim HdefT: ordered_square_topology = generated_topology ordered_square ordered_square_order_basis.
    { reflexivity. }
    rewrite <- HdefT.
    exact HU. }
  claim HUpoint: forall x :e U, exists I :e ordered_square_order_basis, x :e I /\ I c= U.
  { exact (SepE2 (Power ordered_square)
                 (fun U0:set => forall x :e U0, exists b0 :e ordered_square_order_basis, x :e b0 /\ b0 c= U0)
                 U
                 HUgt). }
  set p0 := (eps_ 1, 1).
  claim Hp0Sq: p0 :e ordered_square.
  { exact (tuple_2_setprod_by_pair_Sigma unit_interval unit_interval (eps_ 1) 1 eps_1_in_unit_interval one_in_unit_interval). }
  claim Hp0U: p0 :e U.
  { apply (SepI ordered_square
                (fun p:set => exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                p0
                Hp0Sq).
    witness 1.
    prove p0 = (eps_ 1,1) /\ Rlt (eps_ 1) 1 /\ ~(Rlt 1 1).
    apply andI.
    - prove p0 = (eps_ 1,1) /\ Rlt (eps_ 1) 1.
      apply andI.
      + reflexivity.
      + exact eps_1_lt1_R.
    - exact (not_Rlt_refl 1 real_1). }
  claim HexI: exists I :e ordered_square_order_basis, p0 :e I /\ I c= U.
  { exact (HUpoint p0 Hp0U). }
  apply HexI.
  let I. assume HIprop.
  apply HIprop.
  assume HIbas HIcore.
  apply HIcore.
  assume Hp0I HIU.
  set Bint := {J :e Power ordered_square | exists a :e ordered_square, exists b :e ordered_square,
        J = {x :e ordered_square | order_rel (setprod R R) a x /\ order_rel (setprod R R) x b}}.
  set Blow := {J :e Power ordered_square | exists b :e ordered_square,
        J = {x :e ordered_square | order_rel (setprod R R) x b}}.
  set Bup := {J :e Power ordered_square | exists a :e ordered_square,
        J = {x :e ordered_square | order_rel (setprod R R) a x}}.
  claim HIcase: I :e ((Bint :\/: Blow) :\/: Bup).
  { claim Hdef: ordered_square_order_basis = ((Bint :\/: Blow) :\/: Bup).
    { reflexivity. }
    rewrite <- Hdef.
    exact HIbas. }
  apply (binunionE (Bint :\/: Blow) Bup I HIcase).
  - assume HIleft: I :e (Bint :\/: Blow).
    apply (binunionE Bint Blow I HIleft).
    + assume HIint: I :e Bint.
      claim HIint_ex: exists a :e ordered_square, exists b :e ordered_square,
        I = {x :e ordered_square | order_rel (setprod R R) a x /\ order_rel (setprod R R) x b}.
      { exact (SepE2 (Power ordered_square)
                     (fun J0:set => exists a :e ordered_square, exists b :e ordered_square,
                       J0 = {x :e ordered_square | order_rel (setprod R R) a x /\ order_rel (setprod R R) x b})
                     I
                     HIint). }
      apply HIint_ex.
      let a. assume Ha_prop.
      apply Ha_prop.
      assume HaSq Hexb.
      apply Hexb.
      let b. assume Hb_prop.
      apply Hb_prop.
      assume HbSq HeqI.
      claim Hp0I': p0 :e {x :e ordered_square | order_rel (setprod R R) a x /\ order_rel (setprod R R) x b}.
      { rewrite <- HeqI.
        exact Hp0I. }
      claim Hp0ord: order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b.
      { exact (SepE2 ordered_square
                     (fun x:set => order_rel (setprod R R) a x /\ order_rel (setprod R R) x b)
                     p0
                     Hp0I'). }
      claim Hord2: order_rel (setprod R R) p0 b.
      { exact (andER (order_rel (setprod R R) a p0)
                     (order_rel (setprod R R) p0 b)
                     Hp0ord). }
      claim HbEta: b = (b 0, b 1).
      { exact (setprod_eta unit_interval unit_interval b HbSq). }
      claim Hb0U: (b 0) :e unit_interval.
      { exact (ap0_Sigma unit_interval (fun _ : set => unit_interval) b HbSq). }
      claim Hb1U: (b 1) :e unit_interval.
      { exact (ap1_Sigma unit_interval (fun _ : set => unit_interval) b HbSq). }
      claim Hb0R: (b 0) :e R.
      { exact (SepE1 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 0) Hb0U). }
      claim Hb0prop: ~(Rlt 1 (b 0)).
      { exact (andER (~(Rlt (b 0) 0)) (~(Rlt 1 (b 0)))
                    (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 0) Hb0U)). }
      claim Hb1prop: ~(Rlt 1 (b 1)).
      { exact (andER (~(Rlt (b 1) 0)) (~(Rlt 1 (b 1)))
                    (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 1) Hb1U)). }
      claim Hepsltb0: Rlt (eps_ 1) (b 0).
      { claim Hex_pb: exists c1 c2 d1 d2:set,
          p0 = (c1, c2) /\ b = (d1, d2) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
        { exact (order_rel_setprod_R_R_unfold p0 b Hord2). }
        apply Hex_pb.
        let c1. assume Hc2.
        apply Hc2.
        let c2. assume Hd1.
        apply Hd1.
        let d1. assume Hd2.
        apply Hd2.
        let d2. assume Hcore.
        claim Hpb: p0 = (c1, c2) /\ b = (d1, d2).
        { exact (andEL (p0 = (c1, c2) /\ b = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim Hp0Eq: p0 = (c1, c2).
        { exact (andEL (p0 = (c1, c2)) (b = (d1, d2)) Hpb). }
        claim HbEq: b = (d1, d2).
        { exact (andER (p0 = (c1, c2)) (b = (d1, d2)) Hpb). }
        claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
        { exact (andER (p0 = (c1, c2) /\ b = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim Hp0def: p0 = (eps_ 1, 1).
        { reflexivity. }
        claim Hp0c: (eps_ 1, 1) = (c1, c2).
        { rewrite Hp0def at 1.
          exact Hp0Eq. }
        claim Hp0coords: (eps_ 1) = c1 /\ 1 = c2.
        { exact (tuple_eq_coords (eps_ 1) 1 c1 c2 Hp0c). }
        claim Hc1eq: c1 = eps_ 1.
        { symmetry.
          exact (andEL ((eps_ 1) = c1) (1 = c2) Hp0coords). }
        claim HbD: (d1, d2) = (b 0, b 1).
        { rewrite <- HbEq at 1.
          exact HbEta. }
        claim Hbcoords: d1 = b 0 /\ d2 = b 1.
        { exact (tuple_eq_coords d1 d2 (b 0) (b 1) HbD). }
        claim Hd1eq: d1 = b 0.
        { exact (andEL (d1 = b 0) (d2 = b 1) Hbcoords). }
        apply (Hdisj (Rlt (eps_ 1) (b 0))).
        - assume Hlt: Rlt c1 d1.
          rewrite <- Hc1eq at 1.
	          rewrite <- Hd1eq at 1.
          exact Hlt.
        - assume Hc: c1 = d1 /\ Rlt c2 d2.
          apply FalseE.
          claim H1lt: Rlt 1 (b 1).
          { claim Heqcd: c1 = d1.
            { exact (andEL (c1 = d1) (Rlt c2 d2) Hc). }
            claim Hlt2: Rlt c2 d2.
            { exact (andER (c1 = d1) (Rlt c2 d2) Hc). }
            claim Hc2eq: c2 = 1.
            { symmetry.
              exact (andER ((eps_ 1) = c1) (1 = c2) Hp0coords). }
            claim Hd2eq: d2 = b 1.
            { exact (andER (d1 = b 0) (d2 = b 1) Hbcoords). }
            claim H1lt_d2: Rlt 1 d2.
            { rewrite <- Hc2eq at 1.
              exact Hlt2. }
            rewrite <- Hd2eq at 1.
            exact H1lt_d2. }
          exact (Hb1prop H1lt). }
      apply (rational_dense_between_reals (eps_ 1) (b 0) eps_1_in_R Hb0R Hepsltb0).
      let q. assume Hq_prop.
      apply Hq_prop.
      assume HqQ HqIneq.
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hepsltq: Rlt (eps_ 1) q.
      { exact (andEL (Rlt (eps_ 1) q) (Rlt q (b 0)) HqIneq). }
      claim Hqltb0: Rlt q (b 0).
      { exact (andER (Rlt (eps_ 1) q) (Rlt q (b 0)) HqIneq). }
      claim HqU: q :e unit_interval.
      { apply (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) q HqR).
        apply andI.
        - prove ~(Rlt q 0).
          assume Hq0: Rlt q 0.
          claim H0q: Rlt 0 q.
          { exact (Rlt_tra 0 (eps_ 1) q eps_1_pos_R Hepsltq). }
          exact ((not_Rlt_sym 0 q H0q) Hq0).
        - prove ~(Rlt 1 q).
          assume H1q: Rlt 1 q.
          claim H1b0: Rlt 1 (b 0).
          { exact (Rlt_tra 1 q (b 0) H1q Hqltb0). }
          exact (Hb0prop H1b0). }
      set z := (q,0).
      claim HzSq: z :e ordered_square.
      { exact (tuple_2_setprod_by_pair_Sigma unit_interval unit_interval q 0 HqU zero_in_unit_interval). }
      claim HaEta: a = (a 0, a 1).
      { exact (setprod_eta unit_interval unit_interval a HaSq). }
      claim Ha0U: (a 0) :e unit_interval.
      { exact (ap0_Sigma unit_interval (fun _ : set => unit_interval) a HaSq). }
      claim Ha0R: (a 0) :e R.
      { exact (SepE1 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (a 0) Ha0U). }
      claim Hord1: order_rel (setprod R R) a p0.
      { exact (andEL (order_rel (setprod R R) a p0)
                     (order_rel (setprod R R) p0 b)
                     Hp0ord). }
      claim Hex_ap: exists c1 c2 d1 d2:set,
        a = (c1, c2) /\ p0 = (d1, d2) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
      { exact (order_rel_setprod_R_R_unfold a p0 Hord1). }
      claim Ha0ltq: Rlt (a 0) q.
      { apply Hex_ap.
        let c1. assume Hc2.
        apply Hc2.
        let c2. assume Hd1.
        apply Hd1.
        let d1. assume Hd2.
        apply Hd2.
        let d2. assume Hcore.
        claim Hap: a = (c1, c2) /\ p0 = (d1, d2).
        { exact (andEL (a = (c1, c2) /\ p0 = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim HaEq: a = (c1, c2).
        { exact (andEL (a = (c1, c2)) (p0 = (d1, d2)) Hap). }
        claim Hp0Eq: p0 = (d1, d2).
        { exact (andER (a = (c1, c2)) (p0 = (d1, d2)) Hap). }
        claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
        { exact (andER (a = (c1, c2) /\ p0 = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim HaC: (c1, c2) = (a 0, a 1).
        { rewrite <- HaEq at 1.
          exact HaEta. }
        claim HaCcoords: c1 = a 0 /\ c2 = a 1.
        { exact (tuple_eq_coords c1 c2 (a 0) (a 1) HaC). }
        claim Hc1eq: c1 = a 0.
        { exact (andEL (c1 = a 0) (c2 = a 1) HaCcoords). }
        claim Hp0def: p0 = (eps_ 1, 1).
        { reflexivity. }
        claim Hp0D: (eps_ 1, 1) = (d1, d2).
        { rewrite Hp0def at 1.
          exact Hp0Eq. }
        claim Hp0Dcoords: (eps_ 1) = d1 /\ 1 = d2.
        { exact (tuple_eq_coords (eps_ 1) 1 d1 d2 Hp0D). }
        claim Hd1eq: d1 = eps_ 1.
        { symmetry.
          exact (andEL ((eps_ 1) = d1) (1 = d2) Hp0Dcoords). }
        apply (Hdisj (Rlt (a 0) q)).
        - assume Hlt: Rlt c1 d1.
          claim Hlt1: Rlt (a 0) (eps_ 1).
          { rewrite <- Hc1eq at 1.
		            rewrite <- Hd1eq at 1.
            exact Hlt. }
          exact (Rlt_tra (a 0) (eps_ 1) q Hlt1 Hepsltq).
        - assume Hc: c1 = d1 /\ Rlt c2 d2.
          claim Heq: c1 = d1.
          { exact (andEL (c1 = d1) (Rlt c2 d2) Hc). }
          claim Ha0eq: (a 0) = (eps_ 1).
          { prove (a 0) = (eps_ 1).
            rewrite <- Hc1eq at 1.
		            rewrite <- Hd1eq at 1.
            exact Heq. }
          rewrite Ha0eq at 1.
          exact Hepsltq. }
      claim HzInI: z :e I.
      { rewrite HeqI.
        apply (SepI ordered_square
                    (fun x:set => order_rel (setprod R R) a x /\ order_rel (setprod R R) x b)
                    z
                    HzSq).
        apply andI.
        - prove order_rel (setprod R R) a z.
          rewrite HaEta.
          apply (order_rel_setprod_R_R_intro (a 0) (a 1) q 0).
          apply orIL.
          exact Ha0ltq.
        - prove order_rel (setprod R R) z b.
          rewrite HbEta.
          apply (order_rel_setprod_R_R_intro q 0 (b 0) (b 1)).
          apply orIL.
          exact Hqltb0. }
      claim HzU: z :e U.
      { exact (HIU z HzInI). }
      claim HzNotU: ~(z :e U).
      { assume HzU'.
        claim Hexy: exists y:set, z = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
        { exact (SepE2 ordered_square
                     (fun p:set => exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                     z
                     HzU'). }
        apply Hexy.
        let y. assume Hyprop.
        claim Hpair: z = (eps_ 1,y) /\ Rlt (eps_ 1) y.
        { exact (andEL (z = (eps_ 1,y) /\ Rlt (eps_ 1) y) (~(Rlt 1 y)) Hyprop). }
        claim HzEq: z = (eps_ 1,y).
        { exact (andEL (z = (eps_ 1,y)) (Rlt (eps_ 1) y) Hpair). }
        claim Hcoords: q = eps_ 1 /\ 0 = y.
        { exact (tuple_eq_coords q 0 (eps_ 1) y HzEq). }
        claim Hqeq: q = eps_ 1.
        { exact (andEL (q = eps_ 1) (0 = y) Hcoords). }
        claim Hbad: Rlt (eps_ 1) (eps_ 1).
        { rewrite <- Hqeq at 2.
          exact Hepsltq. }
        exact ((not_Rlt_refl (eps_ 1) eps_1_in_R) Hbad). }
      exact (HzNotU HzU).
    + assume HIlow: I :e Blow.
      claim HIlow_ex: exists b :e ordered_square,
        I = {x :e ordered_square | order_rel (setprod R R) x b}.
      { exact (SepE2 (Power ordered_square)
                     (fun J0:set => exists b0 :e ordered_square,
                       J0 = {x :e ordered_square | order_rel (setprod R R) x b0})
                     I
                     HIlow). }
      apply HIlow_ex.
      let b. assume Hbprop.
      apply Hbprop.
      assume HbSq HeqI.
      claim Hp0I': p0 :e {x :e ordered_square | order_rel (setprod R R) x b}.
      { rewrite <- HeqI.
        exact Hp0I. }
      claim Hord2: order_rel (setprod R R) p0 b.
      { exact (SepE2 ordered_square (fun x:set => order_rel (setprod R R) x b) p0 Hp0I'). }
      claim HbEta: b = (b 0, b 1).
      { exact (setprod_eta unit_interval unit_interval b HbSq). }
      claim Hb0U: (b 0) :e unit_interval.
      { exact (ap0_Sigma unit_interval (fun _ : set => unit_interval) b HbSq). }
      claim Hb1U: (b 1) :e unit_interval.
      { exact (ap1_Sigma unit_interval (fun _ : set => unit_interval) b HbSq). }
      claim Hb0R: (b 0) :e R.
      { exact (SepE1 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 0) Hb0U). }
      claim Hb0prop: ~(Rlt 1 (b 0)).
      { exact (andER (~(Rlt (b 0) 0)) (~(Rlt 1 (b 0)))
                    (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 0) Hb0U)). }
      claim Hb1prop: ~(Rlt 1 (b 1)).
      { exact (andER (~(Rlt (b 1) 0)) (~(Rlt 1 (b 1)))
                    (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (b 1) Hb1U)). }
      claim Hepsltb0: Rlt (eps_ 1) (b 0).
      { claim Hex_pb: exists c1 c2 d1 d2:set,
          p0 = (c1, c2) /\ b = (d1, d2) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
        { exact (order_rel_setprod_R_R_unfold p0 b Hord2). }
        apply Hex_pb.
        let c1. assume Hc2.
        apply Hc2.
        let c2. assume Hd1.
        apply Hd1.
        let d1. assume Hd2.
        apply Hd2.
        let d2. assume Hcore.
        claim Hpb: p0 = (c1, c2) /\ b = (d1, d2).
        { exact (andEL (p0 = (c1, c2) /\ b = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim Hp0Eq: p0 = (c1, c2).
        { exact (andEL (p0 = (c1, c2)) (b = (d1, d2)) Hpb). }
        claim HbEq: b = (d1, d2).
        { exact (andER (p0 = (c1, c2)) (b = (d1, d2)) Hpb). }
        claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
        { exact (andER (p0 = (c1, c2) /\ b = (d1, d2))
                      (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                      Hcore). }
        claim Hp0def: p0 = (eps_ 1, 1).
        { reflexivity. }
        claim Hp0c: (eps_ 1, 1) = (c1, c2).
        { rewrite Hp0def at 1.
          exact Hp0Eq. }
        claim Hp0coords: (eps_ 1) = c1 /\ 1 = c2.
        { exact (tuple_eq_coords (eps_ 1) 1 c1 c2 Hp0c). }
        claim Hc1eq: c1 = eps_ 1.
        { symmetry.
          exact (andEL ((eps_ 1) = c1) (1 = c2) Hp0coords). }
        claim HbD: (d1, d2) = (b 0, b 1).
        { rewrite <- HbEq at 1.
          exact HbEta. }
        claim Hbcoords: d1 = b 0 /\ d2 = b 1.
        { exact (tuple_eq_coords d1 d2 (b 0) (b 1) HbD). }
        claim Hd1eq: d1 = b 0.
        { exact (andEL (d1 = b 0) (d2 = b 1) Hbcoords). }
        apply (Hdisj (Rlt (eps_ 1) (b 0))).
        - assume Hlt: Rlt c1 d1.
          rewrite <- Hc1eq at 1.
	          rewrite <- Hd1eq at 1.
          exact Hlt.
        - assume Hc: c1 = d1 /\ Rlt c2 d2.
          apply FalseE.
	          claim H1lt: Rlt 1 (b 1).
	          { claim Hlt2: Rlt c2 d2.
	            { exact (andER (c1 = d1) (Rlt c2 d2) Hc). }
	            claim Hc2eq: c2 = 1.
	            { symmetry.
	              exact (andER ((eps_ 1) = c1) (1 = c2) Hp0coords). }
	            claim Hd2eq: d2 = b 1.
	            { exact (andER (d1 = b 0) (d2 = b 1) Hbcoords). }
	            claim H1lt_d2: Rlt 1 d2.
	            { rewrite <- Hc2eq at 1.
	              exact Hlt2. }
	            rewrite <- Hd2eq at 1.
	            exact H1lt_d2. }
	          exact (Hb1prop H1lt). }
      apply (rational_dense_between_reals (eps_ 1) (b 0) eps_1_in_R Hb0R Hepsltb0).
      let q. assume Hq_prop.
      apply Hq_prop.
      assume HqQ HqIneq.
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hepsltq: Rlt (eps_ 1) q.
      { exact (andEL (Rlt (eps_ 1) q) (Rlt q (b 0)) HqIneq). }
      claim Hqltb0: Rlt q (b 0).
      { exact (andER (Rlt (eps_ 1) q) (Rlt q (b 0)) HqIneq). }
      claim HqU: q :e unit_interval.
      { apply (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) q HqR).
        apply andI.
        - prove ~(Rlt q 0).
          assume Hq0: Rlt q 0.
          claim H0q: Rlt 0 q.
          { exact (Rlt_tra 0 (eps_ 1) q eps_1_pos_R Hepsltq). }
          exact ((not_Rlt_sym 0 q H0q) Hq0).
        - prove ~(Rlt 1 q).
          assume H1q: Rlt 1 q.
          claim H1b0: Rlt 1 (b 0).
          { exact (Rlt_tra 1 q (b 0) H1q Hqltb0). }
          exact (Hb0prop H1b0). }
      set z := (q,0).
      claim HzSq: z :e ordered_square.
      { exact (tuple_2_setprod_by_pair_Sigma unit_interval unit_interval q 0 HqU zero_in_unit_interval). }
      claim HzInI: z :e I.
      { rewrite HeqI.
        apply (SepI ordered_square (fun x:set => order_rel (setprod R R) x b) z HzSq).
        rewrite HbEta.
        apply (order_rel_setprod_R_R_intro q 0 (b 0) (b 1)).
        apply orIL.
        exact Hqltb0. }
      claim HzU: z :e U.
      { exact (HIU z HzInI). }
      claim HzNotU: ~(z :e U).
      { assume HzU'.
        claim Hexy: exists y:set, z = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
        { exact (SepE2 ordered_square
                     (fun p:set => exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                     z
                     HzU'). }
        apply Hexy.
        let y. assume Hyprop.
        claim Hpair: z = (eps_ 1,y) /\ Rlt (eps_ 1) y.
        { exact (andEL (z = (eps_ 1,y) /\ Rlt (eps_ 1) y) (~(Rlt 1 y)) Hyprop). }
        claim HzEq: z = (eps_ 1,y).
        { exact (andEL (z = (eps_ 1,y)) (Rlt (eps_ 1) y) Hpair). }
        claim Hcoords: q = eps_ 1 /\ 0 = y.
        { exact (tuple_eq_coords q 0 (eps_ 1) y HzEq). }
        claim Hqeq: q = eps_ 1.
        { exact (andEL (q = eps_ 1) (0 = y) Hcoords). }
        claim Hbad: Rlt (eps_ 1) (eps_ 1).
        { rewrite <- Hqeq at 2.
          exact Hepsltq. }
        exact ((not_Rlt_refl (eps_ 1) eps_1_in_R) Hbad). }
      exact (HzNotU HzU).
  - assume HIup: I :e Bup.
    claim HIup_ex: exists a :e ordered_square,
      I = {x :e ordered_square | order_rel (setprod R R) a x}.
    { exact (SepE2 (Power ordered_square)
                   (fun J0:set => exists a0 :e ordered_square,
                     J0 = {x :e ordered_square | order_rel (setprod R R) a0 x})
                   I
                   HIup). }
    apply HIup_ex.
    let a. assume Haprop.
    apply Haprop.
    assume HaSq HeqI.
    claim Hp0I': p0 :e {x :e ordered_square | order_rel (setprod R R) a x}.
    { rewrite <- HeqI.
      exact Hp0I. }
    claim Hord1: order_rel (setprod R R) a p0.
    { exact (SepE2 ordered_square (fun x:set => order_rel (setprod R R) a x) p0 Hp0I'). }
    claim HaEta: a = (a 0, a 1).
    { exact (setprod_eta unit_interval unit_interval a HaSq). }
    claim Ha0U: (a 0) :e unit_interval.
    { exact (ap0_Sigma unit_interval (fun _ : set => unit_interval) a HaSq). }
    claim Ha0R: (a 0) :e R.
    { exact (SepE1 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) (a 0) Ha0U). }
    claim Ha0lt1: Rlt (a 0) 1.
    { claim Hex_ap: exists c1 c2 d1 d2:set,
        a = (c1, c2) /\ p0 = (d1, d2) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
      { exact (order_rel_setprod_R_R_unfold a p0 Hord1). }
      apply Hex_ap.
      let c1. assume Hc2.
      apply Hc2.
      let c2. assume Hd1.
      apply Hd1.
      let d1. assume Hd2.
      apply Hd2.
      let d2. assume Hcore.
      claim Hap: a = (c1, c2) /\ p0 = (d1, d2).
      { exact (andEL (a = (c1, c2) /\ p0 = (d1, d2))
                    (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                    Hcore). }
      claim HaEq: a = (c1, c2).
      { exact (andEL (a = (c1, c2)) (p0 = (d1, d2)) Hap). }
      claim Hp0Eq: p0 = (d1, d2).
      { exact (andER (a = (c1, c2)) (p0 = (d1, d2)) Hap). }
      claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
      { exact (andER (a = (c1, c2) /\ p0 = (d1, d2))
                    (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                    Hcore). }
      claim HaC: (c1, c2) = (a 0, a 1).
      { rewrite <- HaEq at 1.
        exact HaEta. }
      claim HaCcoords: c1 = a 0 /\ c2 = a 1.
      { exact (tuple_eq_coords c1 c2 (a 0) (a 1) HaC). }
      claim Hc1eq: c1 = a 0.
      { exact (andEL (c1 = a 0) (c2 = a 1) HaCcoords). }
      claim Hp0def: p0 = (eps_ 1, 1).
      { reflexivity. }
      claim Hp0D: (eps_ 1, 1) = (d1, d2).
      { rewrite Hp0def at 1.
        exact Hp0Eq. }
      claim Hp0Dcoords: (eps_ 1) = d1 /\ 1 = d2.
      { exact (tuple_eq_coords (eps_ 1) 1 d1 d2 Hp0D). }
      claim Hd1eq: d1 = eps_ 1.
      { symmetry.
        exact (andEL ((eps_ 1) = d1) (1 = d2) Hp0Dcoords). }
      apply (Hdisj (Rlt (a 0) 1)).
      - assume Hlt: Rlt c1 d1.
        claim Ha0lteps: Rlt (a 0) (eps_ 1).
        { rewrite <- Hc1eq at 1.
	          rewrite <- Hd1eq at 1.
          exact Hlt. }
        exact (Rlt_tra (a 0) (eps_ 1) 1 Ha0lteps eps_1_lt1_R).
      - assume Hc: c1 = d1 /\ Rlt c2 d2.
        claim Heq: c1 = d1.
        { exact (andEL (c1 = d1) (Rlt c2 d2) Hc). }
        claim Ha0eq: (a 0) = (eps_ 1).
        { prove (a 0) = (eps_ 1).
          rewrite <- Hc1eq at 1.
	          rewrite <- Hd1eq at 1.
          exact Heq. }
        rewrite Ha0eq at 1.
        exact eps_1_lt1_R. }
    set z := (1,0).
    claim HzSq: z :e ordered_square.
    { exact (tuple_2_setprod_by_pair_Sigma unit_interval unit_interval 1 0 one_in_unit_interval zero_in_unit_interval). }
    claim HzInI: z :e I.
    { rewrite HeqI.
      apply (SepI ordered_square (fun x:set => order_rel (setprod R R) a x) z HzSq).
      rewrite HaEta.
      apply (order_rel_setprod_R_R_intro (a 0) (a 1) 1 0).
      apply orIL.
      exact Ha0lt1. }
    claim HzU: z :e U.
    { exact (HIU z HzInI). }
    claim HzNotU: ~(z :e U).
    { assume HzU'.
      claim Hexy: exists y:set, z = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
      { exact (SepE2 ordered_square
                   (fun p:set => exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                   z
                   HzU'). }
      apply Hexy.
      let y. assume Hyprop.
      claim Hpair: z = (eps_ 1,y) /\ Rlt (eps_ 1) y.
      { exact (andEL (z = (eps_ 1,y) /\ Rlt (eps_ 1) y) (~(Rlt 1 y)) Hyprop). }
      claim HzEq: z = (eps_ 1,y).
      { exact (andEL (z = (eps_ 1,y)) (Rlt (eps_ 1) y) Hpair). }
      claim Hcoords: 1 = eps_ 1 /\ 0 = y.
      { exact (tuple_eq_coords 1 0 (eps_ 1) y HzEq). }
      claim H1eq: 1 = eps_ 1.
      { exact (andEL (1 = eps_ 1) (0 = y) Hcoords). }
      claim Hbad: Rlt (eps_ 1) (eps_ 1).
      { rewrite <- H1eq at 2.
        exact eps_1_lt1_R. }
      exact ((not_Rlt_refl (eps_ 1) eps_1_in_R) Hbad). }
    exact (HzNotU HzU). }

exact (HUnord HUord).
Qed.

(** from §16 Theorem 16.4: convex subspaces share the order topology **) 
(** LATEX VERSION: Theorem 16.4: A convex subset Y of an ordered set X inherits the order topology as a subspace topology. **)
(** Helper: order interval (a,b) in an ordered set **)
Definition order_interval : set -> set -> set -> set := fun X a b =>
  {x :e X | order_rel X a x /\ order_rel X x b}.

(** helper: in ℝ, order_interval agrees with open_interval **)
(** LATEX VERSION: In the real line with the usual order, (a,b) = {x∈ℝ | a<x<b}. **)
Theorem order_interval_R_eq_open_interval : forall a b:set,
  order_interval R a b = open_interval a b.
let a b.
apply set_ext.
- let x. assume Hx: x :e order_interval R a b.
  prove x :e open_interval a b.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => order_rel R a x0 /\ order_rel R x0 b) x Hx). }
  claim Hconj: order_rel R a x /\ order_rel R x b.
  { exact (SepE2 R (fun x0:set => order_rel R a x0 /\ order_rel R x0 b) x Hx). }
  claim Hax: order_rel R a x.
  { exact (andEL (order_rel R a x) (order_rel R x b) Hconj). }
  claim Hxb: order_rel R x b.
  { exact (andER (order_rel R a x) (order_rel R x b) Hconj). }
  claim Haxlt: Rlt a x.
  { exact (order_rel_R_implies_Rlt a x Hax). }
  claim Hxblt: Rlt x b.
  { exact (order_rel_R_implies_Rlt x b Hxb). }
  exact (SepI R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x HxR
              (andI (Rlt a x) (Rlt x b) Haxlt Hxblt)).
- let x. assume Hx: x :e open_interval a b.
  prove x :e order_interval R a b.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hconj: Rlt a x /\ Rlt x b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hax: Rlt a x.
  { exact (andEL (Rlt a x) (Rlt x b) Hconj). }
  claim Hxb: Rlt x b.
  { exact (andER (Rlt a x) (Rlt x b) Hconj). }
  claim Haxrel: order_rel R a x.
  { exact (Rlt_implies_order_rel_R a x Hax). }
  claim Hxbrel: order_rel R x b.
  { exact (Rlt_implies_order_rel_R x b Hxb). }
  exact (SepI R (fun x0:set => order_rel R a x0 /\ order_rel R x0 b) x HxR
              (andI (order_rel R a x) (order_rel R x b) Haxrel Hxbrel)).
Qed.

(** Helper: order intervals are subsets of the ambient set **)
Theorem order_interval_subset : forall X a b:set,
  order_interval X a b c= X.
let X a b.
let x.
assume Hx: x :e order_interval X a b.
exact (SepE1 X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b) x Hx).
Qed.

(** Helper: eliminator for order_interval membership **)
Theorem order_intervalE : forall X a b x:set,
  x :e order_interval X a b ->
  x :e X /\ (order_rel X a x /\ order_rel X x b).
let X a b x.
assume Hx: x :e order_interval X a b.
apply andI.
- exact (SepE1 X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b) x Hx).
- exact (SepE2 X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b) x Hx).
Qed.

(** Helper: introduction rule for order_interval membership **)
Theorem order_intervalI : forall X a b x:set,
  x :e X ->
  order_rel X a x ->
  order_rel X x b ->
  x :e order_interval X a b.
let X a b x.
assume HxX: x :e X.
assume Hax: order_rel X a x.
assume Hxb: order_rel X x b.
exact (SepI X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b)
            x HxX (andI (order_rel X a x) (order_rel X x b) Hax Hxb)).
Qed.

(** from §16: convex subsets of ordered sets **)
(** LATEX VERSION: A subset Y of an ordered set X is convex in X if for each pair of points a<b of Y, the entire interval between them in X lies in Y. **)
(** Helper: convex subset definition used in Theorem 16.4 **)
Definition convex_in : set -> set -> prop := fun X Y =>
  Y c= X /\
  forall a b:set, a :e Y -> b :e Y -> order_interval X a b c= Y.

(** Helper: extract Y c= X from convex_in **)
Theorem convex_in_subset : forall X Y:set,
  convex_in X Y -> Y c= X.
let X Y.
assume H: convex_in X Y.
exact (andEL (Y c= X)
             (forall a b:set, a :e Y -> b :e Y -> order_interval X a b c= Y)
             H).
Qed.

(** Helper: extract the interval closure property from convex_in **)
Theorem convex_in_interval_property : forall X Y:set,
  convex_in X Y ->
  forall a b:set, a :e Y -> b :e Y -> order_interval X a b c= Y.
let X Y.
assume H: convex_in X Y.
exact (andER (Y c= X)
             (forall a b:set, a :e Y -> b :e Y -> order_interval X a b c= Y)
             H).
Qed.

(** from §16 Theorem 16.4: convex subset order topology equals subspace topology **)
(** LATEX VERSION: If Y is a convex subset of an ordered set X, then the order topology on Y (inherited from X) equals the subspace topology on Y as a subspace of X in the order topology. **)
(** NOTE: Our global `order_topology Y` uses `order_rel Y`, which does not represent the inherited order from X on subsets Y. We therefore define the inherited order-topology on Y explicitly using `order_rel X` restricted to Y. **)
Definition order_topology_basis_inherited : set -> set -> set := fun X Y =>
  (({I :e Power Y | exists a :e Y, exists b :e Y,
          I = {x :e Y | order_rel X a x /\ order_rel X x b}}
    :\/:
    {I :e Power Y | exists b :e Y, I = {x :e Y | order_rel X x b}}
    :\/:
    {I :e Power Y | exists a :e Y, I = {x :e Y | order_rel X a x}})
   :\/:
   {Y}).

Definition order_topology_inherited : set -> set -> set := fun X Y =>
  generated_topology Y (order_topology_basis_inherited X Y).

Theorem convex_subspace_order_topology : forall X Y:set,
  simply_ordered_set X ->
  convex_in X Y ->
  order_topology_inherited X Y = subspace_topology X (order_topology X) Y.
let X Y.
assume Hso: simply_ordered_set X.
assume Hconv: convex_in X Y.
prove order_topology_inherited X Y = subspace_topology X (order_topology X) Y.
(** One direction: any generator in `order_topology_basis_inherited` is open in the subspace topology, so the generated family is contained in the subspace topology. **)
set Binh := order_topology_basis_inherited X Y.
set Tx := order_topology X.
set Tsub := subspace_topology X Tx Y.
claim HTx: topology_on X Tx.
{ exact (order_topology_is_topology X Hso). }
claim HYsub: Y c= X.
{ exact (convex_in_subset X Y Hconv). }
claim HtopSub: topology_on Y Tsub.
{ exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
claim HBsub: forall b :e Binh, b :e Tsub.
{ let b. assume Hb: b :e Binh.
  set A := {I :e Power Y | exists a :e Y, exists b0 :e Y,
            I = {x :e Y | order_rel X a x /\ order_rel X x b0}}.
  set B := {I :e Power Y | exists b0 :e Y, I = {x :e Y | order_rel X x b0}}.
  set C := {I :e Power Y | exists a :e Y, I = {x :e Y | order_rel X a x}}.
  set Bold := (A :\/: B :\/: C).
  claim HbIn: b :e (Bold :\/: {Y}).
  { claim Hdef: Binh = (Bold :\/: {Y}).
    { reflexivity. }
    rewrite <- Hdef.
    exact Hb. }
  apply (binunionE' Bold {Y} b (b :e Tsub)).
  - assume HbBold: b :e Bold.
    apply (binunionE' (A :\/: B) C b (b :e Tsub)).
    + assume HbAB: b :e (A :\/: B).
      apply (binunionE' A B b (b :e Tsub)).
      * assume HbA: b :e A.
        claim Hex: exists a :e Y, exists b0 :e Y,
          b = {x :e Y | order_rel X a x /\ order_rel X x b0}.
        { exact (SepE2 (Power Y)
                       (fun I:set => exists a :e Y, exists b0 :e Y,
                         I = {x :e Y | order_rel X a x /\ order_rel X x b0})
                       b
                       HbA). }
        apply Hex.
        let a. assume HaPair.
        apply HaPair.
        assume HaY: a :e Y.
        assume Hexb0.
        apply Hexb0.
        let b1. assume Hb1Pair.
        apply Hb1Pair.
        assume Hb1Y: b1 :e Y.
        assume Hbeq: b = {x :e Y | order_rel X a x /\ order_rel X x b1}.
        set V := {x :e X | order_rel X a x /\ order_rel X x b1}.
        claim HaX: a :e X.
        { exact (HYsub a HaY). }
        claim Hb1X: b1 :e X.
        { exact (HYsub b1 Hb1Y). }
        (** V is an order-topology basis element in X, hence open in Tx. **)
        claim HVbasis: V :e order_topology_basis X.
        { set A0 := {I :e Power X | exists a0 :e X, exists b0 :e X,
                      I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0}}.
          set B0 := {I :e Power X | exists b0 :e X, I = {x0 :e X | order_rel X x0 b0}}.
          set C0 := {I :e Power X | exists a0 :e X, I = {x0 :e X | order_rel X a0 x0}}.
          set Bold0 := (A0 :\/: B0 :\/: C0).
          claim HVinA0: V :e A0.
          { claim HVpow: V :e Power X.
            { apply PowerI X V.
              let x. assume HxV: x :e V.
              exact (SepE1 X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxV). }
            claim Hex0: exists a0 :e X, exists b0 :e X,
              V = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0}.
            { witness a.
              apply andI.
              - exact HaX.
              - witness b1.
                apply andI.
                + exact Hb1X.
                + reflexivity. }
            exact (SepI (Power X)
                        (fun I:set => exists a0 :e X, exists b0 :e X,
                          I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0})
                        V
                        HVpow
                        Hex0). }
          claim HVinBold0: V :e Bold0.
          { exact (binunionI1 (A0 :\/: B0) C0 V (binunionI1 A0 B0 V HVinA0)). }
          claim HVin: V :e (Bold0 :\/: {X}).
          { exact (binunionI1 Bold0 {X} V HVinBold0). }
          claim Hdef: order_topology_basis X = (Bold0 :\/: {X}).
          { reflexivity. }
          rewrite Hdef.
          exact HVin. }
        claim HBBasis: basis_on X (order_topology_basis X).
        { exact (order_topology_basis_is_basis X Hso). }
        claim HVgen: V :e generated_topology X (order_topology_basis X).
        { exact (generated_topology_contains_basis X (order_topology_basis X) HBBasis V HVbasis). }
        claim HVTx: V :e Tx.
        { claim HdefTx: Tx = generated_topology X (order_topology_basis X).
          { reflexivity. }
          rewrite HdefTx.
          exact HVgen. }
        (** b = V ∩ Y **)
        claim HbVY: b = V :/\: Y.
        { apply set_ext.
          - let x. assume HxB: x :e b.
            claim HxBdef: x :e {x0 :e Y | order_rel X a x0 /\ order_rel X x0 b1}.
            { rewrite <- Hbeq at 1.
              exact HxB. }
            claim HxProp: order_rel X a x /\ order_rel X x b1.
            { exact (SepE2 Y (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxBdef). }
            claim HxY: x :e Y.
            { exact (SepE1 Y (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxBdef). }
            claim HxX: x :e X.
            { exact (HYsub x HxY). }
            claim HxV: x :e V.
            { exact (SepI X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxX HxProp). }
            exact (binintersectI V Y x HxV HxY).
          - let x. assume HxVY: x :e V :/\: Y.
            claim HxV: x :e V.
            { exact (binintersectE1 V Y x HxVY). }
            claim HxY: x :e Y.
            { exact (binintersectE2 V Y x HxVY). }
            claim HxProp: order_rel X a x /\ order_rel X x b1.
            { exact (SepE2 X (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxV). }
            rewrite Hbeq.
            exact (SepI Y (fun x0:set => order_rel X a x0 /\ order_rel X x0 b1) x HxY HxProp). }
        rewrite HbVY.
        exact (subspace_topologyI X Tx Y V HVTx).
      * assume HbB: b :e B.
        claim Hex: exists b0 :e Y, b = {x :e Y | order_rel X x b0}.
        { exact (SepE2 (Power Y)
                       (fun I:set => exists b0 :e Y, I = {x :e Y | order_rel X x b0})
                       b
                       HbB). }
        apply Hex.
        let b0. assume Hb0Pair.
        apply Hb0Pair.
        assume Hb0Y: b0 :e Y.
        assume Hbeq: b = {x :e Y | order_rel X x b0}.
        set V := {x :e X | order_rel X x b0}.
        claim Hb0X: b0 :e X.
        { exact (HYsub b0 Hb0Y). }
        claim HVbasis: V :e order_topology_basis X.
        { set A0 := {I :e Power X | exists a0 :e X, exists b1 :e X,
                      I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1}}.
          set B0 := {I :e Power X | exists b1 :e X, I = {x0 :e X | order_rel X x0 b1}}.
          set C0 := {I :e Power X | exists a0 :e X, I = {x0 :e X | order_rel X a0 x0}}.
          set Bold0 := (A0 :\/: B0 :\/: C0).
          claim HVinB0: V :e B0.
          { claim HVpow: V :e Power X.
            { apply PowerI X V.
              let x. assume HxV: x :e V.
              exact (SepE1 X (fun x0:set => order_rel X x0 b0) x HxV). }
            claim Hex0: exists b1 :e X, V = {x0 :e X | order_rel X x0 b1}.
            { witness b0.
              apply andI.
              - exact Hb0X.
              - reflexivity. }
            exact (SepI (Power X)
                        (fun I:set => exists b1 :e X, I = {x0 :e X | order_rel X x0 b1})
                        V
                        HVpow
                        Hex0). }
          claim HVinBold0: V :e Bold0.
          { exact (binunionI1 (A0 :\/: B0) C0 V (binunionI2 A0 B0 V HVinB0)). }
          claim HVin: V :e (Bold0 :\/: {X}).
          { exact (binunionI1 Bold0 {X} V HVinBold0). }
          claim Hdef: order_topology_basis X = (Bold0 :\/: {X}).
          { reflexivity. }
          rewrite Hdef.
          exact HVin. }
        claim HBBasis: basis_on X (order_topology_basis X).
        { exact (order_topology_basis_is_basis X Hso). }
        claim HVgen: V :e generated_topology X (order_topology_basis X).
        { exact (generated_topology_contains_basis X (order_topology_basis X) HBBasis V HVbasis). }
        claim HVTx: V :e Tx.
        { claim HdefTx: Tx = generated_topology X (order_topology_basis X).
          { reflexivity. }
          rewrite HdefTx.
          exact HVgen. }
        claim HbVY: b = V :/\: Y.
        { apply set_ext.
          - let x. assume HxB: x :e b.
            claim HxY: x :e Y.
            { claim HxBdef: x :e {x0 :e Y | order_rel X x0 b0}.
              { rewrite <- Hbeq at 1.
                exact HxB. }
              exact (SepE1 Y (fun x0:set => order_rel X x0 b0) x HxBdef). }
            claim HxX: x :e X.
            { exact (HYsub x HxY). }
            claim HxProp: order_rel X x b0.
            { claim HxBdef: x :e {x0 :e Y | order_rel X x0 b0}.
              { rewrite <- Hbeq at 1.
                exact HxB. }
              exact (SepE2 Y (fun x0:set => order_rel X x0 b0) x HxBdef). }
            claim HxV: x :e V.
            { exact (SepI X (fun x0:set => order_rel X x0 b0) x HxX HxProp). }
            exact (binintersectI V Y x HxV HxY).
          - let x. assume HxVY: x :e V :/\: Y.
            claim HxV: x :e V.
            { exact (binintersectE1 V Y x HxVY). }
            claim HxY: x :e Y.
            { exact (binintersectE2 V Y x HxVY). }
            claim HxProp: order_rel X x b0.
            { exact (SepE2 X (fun x0:set => order_rel X x0 b0) x HxV). }
            rewrite Hbeq.
            exact (SepI Y (fun x0:set => order_rel X x0 b0) x HxY HxProp). }
        rewrite HbVY.
        exact (subspace_topologyI X Tx Y V HVTx).
      * exact HbAB.
    + assume HbC: b :e C.
      claim Hex: exists a :e Y, b = {x :e Y | order_rel X a x}.
      { exact (SepE2 (Power Y)
                     (fun I:set => exists a :e Y, I = {x :e Y | order_rel X a x})
                     b
                     HbC). }
      apply Hex.
      let a. assume HaPair.
      apply HaPair.
      assume HaY: a :e Y.
      assume Hbeq: b = {x :e Y | order_rel X a x}.
      set V := {x :e X | order_rel X a x}.
      claim HaX: a :e X.
      { exact (HYsub a HaY). }
      claim HVbasis: V :e order_topology_basis X.
      { set A0 := {I :e Power X | exists a0 :e X, exists b0 :e X,
                    I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0}}.
        set B0 := {I :e Power X | exists b0 :e X, I = {x0 :e X | order_rel X x0 b0}}.
        set C0 := {I :e Power X | exists a0 :e X, I = {x0 :e X | order_rel X a0 x0}}.
        set Bold0 := (A0 :\/: B0 :\/: C0).
        claim HVinC0: V :e C0.
        { claim HVpow: V :e Power X.
          { apply PowerI X V.
            let x. assume HxV: x :e V.
            exact (SepE1 X (fun x0:set => order_rel X a x0) x HxV). }
          claim Hex0: exists a0 :e X, V = {x0 :e X | order_rel X a0 x0}.
          { witness a.
            apply andI.
            - exact HaX.
            - reflexivity. }
          exact (SepI (Power X)
                      (fun I:set => exists a0 :e X, I = {x0 :e X | order_rel X a0 x0})
                      V
                      HVpow
                      Hex0). }
        claim HVinBold0: V :e Bold0.
        { exact (binunionI2 (A0 :\/: B0) C0 V HVinC0). }
        claim HVin: V :e (Bold0 :\/: {X}).
        { exact (binunionI1 Bold0 {X} V HVinBold0). }
        claim Hdef: order_topology_basis X = (Bold0 :\/: {X}).
        { reflexivity. }
        rewrite Hdef.
        exact HVin. }
      claim HBBasis: basis_on X (order_topology_basis X).
      { exact (order_topology_basis_is_basis X Hso). }
      claim HVgen: V :e generated_topology X (order_topology_basis X).
      { exact (generated_topology_contains_basis X (order_topology_basis X) HBBasis V HVbasis). }
      claim HVTx: V :e Tx.
      { claim HdefTx: Tx = generated_topology X (order_topology_basis X).
        { reflexivity. }
        rewrite HdefTx.
        exact HVgen. }
      claim HbVY: b = V :/\: Y.
      { apply set_ext.
        - let x. assume HxB: x :e b.
          claim HxY: x :e Y.
          { claim HxBdef: x :e {x0 :e Y | order_rel X a x0}.
            { rewrite <- Hbeq at 1.
              exact HxB. }
            exact (SepE1 Y (fun x0:set => order_rel X a x0) x HxBdef). }
          claim HxX: x :e X.
          { exact (HYsub x HxY). }
          claim HxProp: order_rel X a x.
          { claim HxBdef: x :e {x0 :e Y | order_rel X a x0}.
            { rewrite <- Hbeq at 1.
              exact HxB. }
            exact (SepE2 Y (fun x0:set => order_rel X a x0) x HxBdef). }
          claim HxV: x :e V.
          { exact (SepI X (fun x0:set => order_rel X a x0) x HxX HxProp). }
          exact (binintersectI V Y x HxV HxY).
        - let x. assume HxVY: x :e V :/\: Y.
          claim HxV: x :e V.
          { exact (binintersectE1 V Y x HxVY). }
          claim HxY: x :e Y.
          { exact (binintersectE2 V Y x HxVY). }
          claim HxProp: order_rel X a x.
          { exact (SepE2 X (fun x0:set => order_rel X a x0) x HxV). }
          rewrite Hbeq.
          exact (SepI Y (fun x0:set => order_rel X a x0) x HxY HxProp). }
      rewrite HbVY.
      exact (subspace_topologyI X Tx Y V HVTx).
    + exact HbBold.
  - assume HbY: b :e {Y}.
    claim Hbeq: b = Y.
    { exact (SingE Y b HbY). }
    rewrite Hbeq.
    (** Y = X ∩ Y and X is open in any topology on X **)
    claim HXTx: X :e Tx.
    { exact (topology_has_X X Tx HTx). }
    claim HXYeq: X :/\: Y = Y.
    { apply set_ext.
      - exact (binintersect_Subq_2 X Y).
      - let y. assume Hy: y :e Y.
        exact (binintersectI X Y y (HYsub y Hy) Hy). }
    claim HXYin: (X :/\: Y) :e Tsub.
    { exact (subspace_topologyI X Tx Y X HXTx). }
    rewrite <- HXYeq at 1.
    exact HXYin.
  - exact HbIn. }
claim Hfiner: finer_than Tsub (generated_topology Y Binh).
{ exact (generated_topology_finer_weak Y Binh Tsub HtopSub HBsub). }
apply set_ext.
- let U. assume HU: U :e order_topology_inherited X Y.
  prove U :e Tsub.
  exact (Hfiner U HU).
- let U. assume HU: U :e Tsub.
	  prove U :e order_topology_inherited X Y.
	  (** Remaining direction: show every subspace-open set is generated by inherited basic intervals/rays; this uses convexity. **)
	  prove U :e generated_topology Y Binh.
	  claim HgenDef: generated_topology Y Binh =
	    {U0 :e Power Y | forall x0 :e U0, exists b0 :e Binh, x0 :e b0 /\ b0 c= U0}.
	  { reflexivity. }
	  rewrite HgenDef.
	  claim HUpow: U :e Power Y.
	  { exact (subspace_topology_in_Power X Tx Y U HU). }
  apply (SepI (Power Y)
              (fun U0:set => forall x0 :e U0, exists b0 :e Binh, x0 :e b0 /\ b0 c= U0)
              U).
  - exact HUpow.
  - let x. assume HxU: x :e U.
  (** Unfold U as V∩Y with V open in the ambient order topology. **)
  claim HUrep: exists V :e Tx, U = V :/\: Y.
  { exact (subspace_topologyE X Tx Y U HU). }
  apply HUrep.
  let V. assume HVpair.
  claim HVTx: V :e Tx.
  { exact (andEL (V :e Tx) (U = V :/\: Y) HVpair). }
  claim HUeq: U = V :/\: Y.
  { exact (andER (V :e Tx) (U = V :/\: Y) HVpair). }
  claim HxVY: x :e V :/\: Y.
  { rewrite <- HUeq.
    exact HxU. }
  claim HxV: x :e V.
  { exact (binintersectE1 V Y x HxVY). }
  claim HxY: x :e Y.
  { exact (binintersectE2 V Y x HxVY). }
  (** Use the definition of order topology as generated by the order-topology basis. **)
  claim HdefTx: Tx = generated_topology X (order_topology_basis X).
  { reflexivity. }
  claim HVgen: V :e generated_topology X (order_topology_basis X).
  { rewrite <- HdefTx.
    exact HVTx. }
  claim HVloc: forall x0 :e V,
      exists b0 :e order_topology_basis X, x0 :e b0 /\ b0 c= V.
  { exact (SepE2 (Power X)
                 (fun U0:set =>
                    forall x1 :e U0, exists b1 :e order_topology_basis X, x1 :e b1 /\ b1 c= U0)
                 V
                 HVgen). }
  claim Hexb: exists b0 :e order_topology_basis X, x :e b0 /\ b0 c= V.
  { exact (HVloc x HxV). }
  apply Hexb.
  let b0. assume Hb0pair.
  claim Hb0B: b0 :e order_topology_basis X.
  { exact (andEL (b0 :e order_topology_basis X) (x :e b0 /\ b0 c= V) Hb0pair). }
  claim Hb0prop: x :e b0 /\ b0 c= V.
  { exact (andER (b0 :e order_topology_basis X) (x :e b0 /\ b0 c= V) Hb0pair). }
  claim Hxb0: x :e b0.
  { exact (andEL (x :e b0) (b0 c= V) Hb0prop). }
  claim Hb0subV: b0 c= V.
  { exact (andER (x :e b0) (b0 c= V) Hb0prop). }
  set bY := b0 :/\: Y.
  witness bY.
  apply andI.
  - (** Convexity forces b0∩Y to be a basic inherited interval, ray, or all of Y. **)
    set Ainh := {I :e Power Y | exists a :e Y, exists b1 :e Y,
          I = {z :e Y | order_rel X a z /\ order_rel X z b1}}.
    set Binh_ray := {I :e Power Y | exists b1 :e Y, I = {z :e Y | order_rel X z b1}}.
    set Cinh_ray := {I :e Power Y | exists a :e Y, I = {z :e Y | order_rel X a z}}.
    set Boldinh := (Ainh :\/: Binh_ray :\/: Cinh_ray).
    set A0 := {I :e Power X | exists a :e X, exists b1 :e X,
                I = {z :e X | order_rel X a z /\ order_rel X z b1}}.
    set B0 := {I :e Power X | exists b1 :e X, I = {z :e X | order_rel X z b1}}.
    set C0 := {I :e Power X | exists a :e X, I = {z :e X | order_rel X a z}}.
    set Bold0 := (A0 :\/: B0 :\/: C0).
    apply (binunionE Bold0 {X} b0 Hb0B).
    + assume Hb0Bold: b0 :e Bold0.
      apply (binunionE (A0 :\/: B0) C0 b0 Hb0Bold).
      * assume Hb0AB: b0 :e (A0 :\/: B0).
        apply (binunionE A0 B0 b0 Hb0AB).
        - (** interval case **)
           assume Hb0A0: b0 :e A0.
           claim HexInt: exists a0 :e X, exists b1 :e X,
             b0 = {z :e X | order_rel X a0 z /\ order_rel X z b1}.
           { exact (SepE2 (Power X)
                          (fun I:set => exists a0 :e X, exists b1 :e X,
                            I = {z :e X | order_rel X a0 z /\ order_rel X z b1})
                          b0
                          Hb0A0). }
           apply HexInt.
           let a0. assume Ha0pair.
           apply Ha0pair.
           assume Ha0X: a0 :e X.
           assume Hexb1.
           apply Hexb1.
           let b1. assume Hb1pair.
           apply Hb1pair.
           assume Hb1X: b1 :e X.
           assume Hb0eq: b0 = {z :e X | order_rel X a0 z /\ order_rel X z b1}.
           claim HbYdef: bY = {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
           { apply set_ext.
             - let z. assume Hz: z :e bY.
               claim Hzb0: z :e b0.
               { exact (binintersectE1 b0 Y z Hz). }
               claim HzY: z :e Y.
               { exact (binintersectE2 b0 Y z Hz). }
	               claim HzIn: z :e {z :e X | order_rel X a0 z /\ order_rel X z b1}.
	               { rewrite <- Hb0eq.
	                 exact Hzb0. }
	               claim HzProp: order_rel X a0 z /\ order_rel X z b1.
	               { exact (SepE2 X (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzIn). }
               exact (SepI Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzY HzProp).
             - let z. assume Hz: z :e {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
               claim HzY: z :e Y.
               { exact (SepE1 Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z Hz). }
               claim HzProp: order_rel X a0 z /\ order_rel X z b1.
               { exact (SepE2 Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z Hz). }
               claim HzX: z :e X.
               { exact (HYsub z HzY). }
               claim Hzb0: z :e b0.
               { rewrite Hb0eq.
                 exact (SepI X (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzX HzProp). }
               exact (binintersectI b0 Y z Hzb0 HzY). }
           apply (xm (a0 :e Y)).
           - assume Ha0Y: a0 :e Y.
             apply (xm (b1 :e Y)).
             - assume Hb1Y: b1 :e Y.
                    rewrite HbYdef.
                    claim HbYpow: {z :e Y | order_rel X a0 z /\ order_rel X z b1} :e Power Y.
                    { apply PowerI Y {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
                      let z. assume Hz: z :e {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
                      exact (SepE1 Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z Hz). }
                    claim HbYA: {z :e Y | order_rel X a0 z /\ order_rel X z b1} :e Ainh.
                    { apply (SepI (Power Y)
                                  (fun I:set => exists a :e Y, exists b2 :e Y,
                                       I = {z :e Y | order_rel X a z /\ order_rel X z b2})
                                  {z :e Y | order_rel X a0 z /\ order_rel X z b1}
                                  HbYpow).
                      witness a0.
                      apply andI.
                      - exact Ha0Y.
                      - witness b1.
                        apply andI.
                        + exact Hb1Y.
                        + reflexivity. }
                    exact (binunionI1 Boldinh {Y}
                                      {z :e Y | order_rel X a0 z /\ order_rel X z b1}
                                      (binunionI1 (Ainh :\/: Binh_ray) Cinh_ray
                                                  {z :e Y | order_rel X a0 z /\ order_rel X z b1}
                                                  (binunionI1 Ainh Binh_ray
                                                              {z :e Y | order_rel X a0 z /\ order_rel X z b1}
                                                              HbYA))).
             - assume Hb1notY: ~(b1 :e Y).
                    claim Hb1upper: forall y:set, y :e Y -> order_rel X y b1.
                    { let y. assume HyY: y :e Y.
                      apply (order_rel_trichotomy_or_impred X y b1 Hso (HYsub y HyY) Hb1X (order_rel X y b1)).
                      - assume Hlt: order_rel X y b1.
                        exact Hlt.
	                      - assume Heq: y = b1.
	                        apply FalseE.
	                        prove False.
	                        claim Hb1Y': b1 :e Y.
	                        { rewrite <- Heq.
	                          exact HyY. }
	                        exact (Hb1notY Hb1Y').
                      - assume Hgt: order_rel X b1 y.
                        apply FalseE.
                        prove False.
                        claim HxY': x :e Y.
                        { exact HxY. }
                        claim HyY': y :e Y.
                        { exact HyY. }
                        claim HxX': x :e X.
                        { exact (HYsub x HxY'). }
	                        claim HxInSet: x :e {z :e X | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- Hb0eq.
	                          exact Hxb0. }
	                        claim HxConj: order_rel X a0 x /\ order_rel X x b1.
	                        { exact (SepE2 X (fun w:set => order_rel X a0 w /\ order_rel X w b1) x HxInSet). }
	                        claim HxLessB1: order_rel X x b1.
	                        { exact (andER (order_rel X a0 x) (order_rel X x b1) HxConj). }
	                        claim Hb1InInt: b1 :e order_interval X x y.
	                        { exact (order_intervalI X x y b1 Hb1X HxLessB1 Hgt). }
                        claim HintSub: order_interval X x y c= Y.
                        { exact (convex_in_interval_property X Y Hconv x y HxY' HyY'). }
                        exact (Hb1notY (HintSub b1 Hb1InInt)). }
                    claim HbYeq2: bY = {z :e Y | order_rel X a0 z}.
                    { apply set_ext.
                      - let z. assume Hz: z :e bY.
	                        claim HzIn: z :e {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- HbYdef.
	                          exact Hz. }
	                        claim HzProp: order_rel X a0 z /\ order_rel X z b1.
	                        { exact (SepE2 Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzIn). }
                        exact (SepI Y (fun w:set => order_rel X a0 w) z
                                    (binintersectE2 b0 Y z Hz)
                                    (andEL (order_rel X a0 z) (order_rel X z b1) HzProp)). 
                      - let z. assume Hz: z :e {z :e Y | order_rel X a0 z}.
                        claim HzY: z :e Y.
                        { exact (SepE1 Y (fun w:set => order_rel X a0 w) z Hz). }
                        claim HzProp: order_rel X a0 z.
                        { exact (SepE2 Y (fun w:set => order_rel X a0 w) z Hz). }
                        claim Hzb1: order_rel X z b1.
                        { exact (Hb1upper z HzY). }
                        rewrite HbYdef.
                        exact (SepI Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzY
                                    (andI (order_rel X a0 z) (order_rel X z b1) HzProp Hzb1)). }
                    rewrite HbYeq2.
                    claim HbYpow: {z :e Y | order_rel X a0 z} :e Power Y.
                    { apply PowerI Y {z :e Y | order_rel X a0 z}.
                      let z. assume Hz: z :e {z :e Y | order_rel X a0 z}.
                      exact (SepE1 Y (fun w:set => order_rel X a0 w) z Hz). }
                    claim HbYC: {z :e Y | order_rel X a0 z} :e Cinh_ray.
                    { apply (SepI (Power Y)
                                  (fun I:set => exists a :e Y, I = {z :e Y | order_rel X a z})
                                  {z :e Y | order_rel X a0 z}
                                  HbYpow).
                      witness a0.
                      apply andI.
                      - exact Ha0Y.
                      - reflexivity. }
                    exact (binunionI1 Boldinh {Y}
                                      {z :e Y | order_rel X a0 z}
                                      (binunionI2 (Ainh :\/: Binh_ray) Cinh_ray
                                                  {z :e Y | order_rel X a0 z}
                                                  HbYC)).
           - assume Ha0notY: ~(a0 :e Y).
             apply (xm (b1 :e Y)).
             - assume Hb1Y: b1 :e Y.
                    claim Ha0lower: forall y:set, y :e Y -> order_rel X a0 y.
                    { let y. assume HyY: y :e Y.
                      apply (order_rel_trichotomy_or_impred X a0 y Hso Ha0X (HYsub y HyY) (order_rel X a0 y)).
                      - assume Hlt: order_rel X a0 y.
                        exact Hlt.
	                      - assume Heq: a0 = y.
	                        apply FalseE.
	                        prove False.
	                        claim Ha0Y': a0 :e Y.
	                        { rewrite Heq.
	                          exact HyY. }
	                        exact (Ha0notY Ha0Y').
                      - assume Hgt: order_rel X y a0.
                        apply FalseE.
                        prove False.
                        claim HyY': y :e Y.
                        { exact HyY. }
                        claim HxY': x :e Y.
                        { exact HxY. }
                        claim HxX': x :e X.
                        { exact (HYsub x HxY'). }
	                        claim HxInSet: x :e {z :e X | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- Hb0eq.
	                          exact Hxb0. }
	                        claim HxConj: order_rel X a0 x /\ order_rel X x b1.
	                        { exact (SepE2 X (fun w:set => order_rel X a0 w /\ order_rel X w b1) x HxInSet). }
	                        claim Ha0LessX: order_rel X a0 x.
	                        { exact (andEL (order_rel X a0 x) (order_rel X x b1) HxConj). }
	                        claim Ha0InInt: a0 :e order_interval X y x.
	                        { exact (order_intervalI X y x a0 Ha0X Hgt Ha0LessX). }
                        claim HintSub: order_interval X y x c= Y.
                        { exact (convex_in_interval_property X Y Hconv y x HyY' HxY'). }
                        exact (Ha0notY (HintSub a0 Ha0InInt)). }
                    claim HbYeq2: bY = {z :e Y | order_rel X z b1}.
                    { apply set_ext.
                      - let z. assume Hz: z :e bY.
	                        claim HzIn: z :e {z :e Y | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- HbYdef.
	                          exact Hz. }
	                        claim HzProp: order_rel X a0 z /\ order_rel X z b1.
	                        { exact (SepE2 Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzIn). }
                        exact (SepI Y (fun w:set => order_rel X w b1) z
                                    (binintersectE2 b0 Y z Hz)
                                    (andER (order_rel X a0 z) (order_rel X z b1) HzProp)). 
                      - let z. assume Hz: z :e {z :e Y | order_rel X z b1}.
                        claim HzY: z :e Y.
                        { exact (SepE1 Y (fun w:set => order_rel X w b1) z Hz). }
                        claim HzProp: order_rel X z b1.
                        { exact (SepE2 Y (fun w:set => order_rel X w b1) z Hz). }
                        claim Haza: order_rel X a0 z.
                        { exact (Ha0lower z HzY). }
                        rewrite HbYdef.
                        exact (SepI Y (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzY
                                    (andI (order_rel X a0 z) (order_rel X z b1) Haza HzProp)). }
                    rewrite HbYeq2.
                    claim HbYpow: {z :e Y | order_rel X z b1} :e Power Y.
                    { apply PowerI Y {z :e Y | order_rel X z b1}.
                      let z. assume Hz: z :e {z :e Y | order_rel X z b1}.
                      exact (SepE1 Y (fun w:set => order_rel X w b1) z Hz). }
                    claim HbYB: {z :e Y | order_rel X z b1} :e Binh_ray.
                    { apply (SepI (Power Y)
                                  (fun I:set => exists b2 :e Y, I = {z :e Y | order_rel X z b2})
                                  {z :e Y | order_rel X z b1}
                                  HbYpow).
                      witness b1.
                      apply andI.
                      - exact Hb1Y.
                      - reflexivity. }
                    exact (binunionI1 Boldinh {Y}
                                      {z :e Y | order_rel X z b1}
                                      (binunionI1 (Ainh :\/: Binh_ray) Cinh_ray
                                                  {z :e Y | order_rel X z b1}
                                                  (binunionI2 Ainh Binh_ray
                                                              {z :e Y | order_rel X z b1}
                                                              HbYB))).
             - assume Hb1notY: ~(b1 :e Y).
                    claim Ha0lower: forall y:set, y :e Y -> order_rel X a0 y.
                    { let y. assume HyY: y :e Y.
                      apply (order_rel_trichotomy_or_impred X a0 y Hso Ha0X (HYsub y HyY) (order_rel X a0 y)).
                      - assume Hlt: order_rel X a0 y.
                        exact Hlt.
	                      - assume Heq: a0 = y.
	                        apply FalseE.
	                        prove False.
	                        claim Ha0Y': a0 :e Y.
	                        { rewrite Heq.
	                          exact HyY. }
	                        exact (Ha0notY Ha0Y').
                      - assume Hgt: order_rel X y a0.
                        apply FalseE.
                        prove False.
                        claim HyY': y :e Y.
                        { exact HyY. }
                        claim HxY': x :e Y.
                        { exact HxY. }
                        claim HxX': x :e X.
                        { exact (HYsub x HxY'). }
	                        claim HxInSet: x :e {z :e X | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- Hb0eq.
	                          exact Hxb0. }
	                        claim HxConj: order_rel X a0 x /\ order_rel X x b1.
	                        { exact (SepE2 X (fun w:set => order_rel X a0 w /\ order_rel X w b1) x HxInSet). }
	                        claim Ha0LessX: order_rel X a0 x.
	                        { exact (andEL (order_rel X a0 x) (order_rel X x b1) HxConj). }
	                        claim Ha0InInt: a0 :e order_interval X y x.
	                        { exact (order_intervalI X y x a0 Ha0X Hgt Ha0LessX). }
                        claim HintSub: order_interval X y x c= Y.
                        { exact (convex_in_interval_property X Y Hconv y x HyY' HxY'). }
                        exact (Ha0notY (HintSub a0 Ha0InInt)). }
                    claim Hb1upper: forall y:set, y :e Y -> order_rel X y b1.
                    { let y. assume HyY: y :e Y.
                      apply (order_rel_trichotomy_or_impred X y b1 Hso (HYsub y HyY) Hb1X (order_rel X y b1)).
                      - assume Hlt: order_rel X y b1.
                        exact Hlt.
	                      - assume Heq: y = b1.
	                        apply FalseE.
	                        prove False.
	                        claim Hb1Y': b1 :e Y.
	                        { rewrite <- Heq.
	                          exact HyY. }
	                        exact (Hb1notY Hb1Y').
                      - assume Hgt: order_rel X b1 y.
                        apply FalseE.
                        prove False.
                        claim HxY': x :e Y.
                        { exact HxY. }
                        claim HyY': y :e Y.
                        { exact HyY. }
                        claim HxX': x :e X.
                        { exact (HYsub x HxY'). }
	                        claim HxInSet: x :e {z :e X | order_rel X a0 z /\ order_rel X z b1}.
	                        { rewrite <- Hb0eq.
	                          exact Hxb0. }
	                        claim HxConj: order_rel X a0 x /\ order_rel X x b1.
	                        { exact (SepE2 X (fun w:set => order_rel X a0 w /\ order_rel X w b1) x HxInSet). }
	                        claim HxLessB1: order_rel X x b1.
	                        { exact (andER (order_rel X a0 x) (order_rel X x b1) HxConj). }
	                        claim Hb1InInt: b1 :e order_interval X x y.
	                        { exact (order_intervalI X x y b1 Hb1X HxLessB1 Hgt). }
                        claim HintSub: order_interval X x y c= Y.
                        { exact (convex_in_interval_property X Y Hconv x y HxY' HyY'). }
                        exact (Hb1notY (HintSub b1 Hb1InInt)). }
                    claim HbYeqY: bY = Y.
                    { apply set_ext.
                      - exact (binintersect_Subq_2 b0 Y).
                      - let z. assume HzY: z :e Y.
                        claim HzX: z :e X.
                        { exact (HYsub z HzY). }
                        claim Haza: order_rel X a0 z.
                        { exact (Ha0lower z HzY). }
                        claim Hzb1: order_rel X z b1.
                        { exact (Hb1upper z HzY). }
                        claim Hzb0: z :e b0.
                        { rewrite Hb0eq.
                          exact (SepI X (fun w:set => order_rel X a0 w /\ order_rel X w b1) z HzX
                                      (andI (order_rel X a0 z) (order_rel X z b1) Haza Hzb1)). }
                        exact (binintersectI b0 Y z Hzb0 HzY). }
                    rewrite HbYeqY.
                    exact (binunionI2 Boldinh {Y} Y (SingI Y)).
        - (** left ray case **)
           assume Hb0B0: b0 :e B0.
           claim HexRay: exists b1 :e X, b0 = {z :e X | order_rel X z b1}.
           { exact (SepE2 (Power X)
                          (fun I:set => exists b1 :e X, I = {z :e X | order_rel X z b1})
                          b0
                          Hb0B0). }
           apply HexRay.
           let b1. assume Hb1pair.
           apply Hb1pair.
           assume Hb1X: b1 :e X.
           assume Hb0eq: b0 = {z :e X | order_rel X z b1}.
           claim HbYdef: bY = {z :e Y | order_rel X z b1}.
           { apply set_ext.
             - let z. assume Hz: z :e bY.
               claim Hzb0: z :e b0.
               { exact (binintersectE1 b0 Y z Hz). }
               claim HzY: z :e Y.
               { exact (binintersectE2 b0 Y z Hz). }
	               claim HzIn: z :e {z :e X | order_rel X z b1}.
	               { rewrite <- Hb0eq.
	                 exact Hzb0. }
	               claim HzProp: order_rel X z b1.
	               { exact (SepE2 X (fun w:set => order_rel X w b1) z HzIn). }
               exact (SepI Y (fun w:set => order_rel X w b1) z HzY HzProp).
             - let z. assume Hz: z :e {z :e Y | order_rel X z b1}.
               claim HzY: z :e Y.
               { exact (SepE1 Y (fun w:set => order_rel X w b1) z Hz). }
               claim HzProp: order_rel X z b1.
               { exact (SepE2 Y (fun w:set => order_rel X w b1) z Hz). }
               claim HzX: z :e X.
               { exact (HYsub z HzY). }
               claim Hzb0: z :e b0.
               { rewrite Hb0eq.
                 exact (SepI X (fun w:set => order_rel X w b1) z HzX HzProp). }
               exact (binintersectI b0 Y z Hzb0 HzY). }
           apply (xm (b1 :e Y)).
           - assume Hb1Y: b1 :e Y.
               rewrite HbYdef.
               claim HbYpow: {z :e Y | order_rel X z b1} :e Power Y.
               { apply PowerI Y {z :e Y | order_rel X z b1}.
                 let z. assume Hz: z :e {z :e Y | order_rel X z b1}.
                 exact (SepE1 Y (fun w:set => order_rel X w b1) z Hz). }
               claim HbYB: {z :e Y | order_rel X z b1} :e Binh_ray.
               { apply (SepI (Power Y)
                             (fun I:set => exists b2 :e Y, I = {z :e Y | order_rel X z b2})
                             {z :e Y | order_rel X z b1}
                             HbYpow).
                 witness b1.
                 apply andI.
                 - exact Hb1Y.
                 - reflexivity. }
               exact (binunionI1 Boldinh {Y}
                                 {z :e Y | order_rel X z b1}
                                 (binunionI1 (Ainh :\/: Binh_ray) Cinh_ray
                                             {z :e Y | order_rel X z b1}
                                             (binunionI2 Ainh Binh_ray
                                                         {z :e Y | order_rel X z b1}
                                                         HbYB))).
           - assume Hb1notY: ~(b1 :e Y).
               claim Hb1upper: forall y:set, y :e Y -> order_rel X y b1.
               { let y. assume HyY: y :e Y.
                 apply (order_rel_trichotomy_or_impred X y b1 Hso (HYsub y HyY) Hb1X (order_rel X y b1)).
                 - assume Hlt: order_rel X y b1.
                   exact Hlt.
	                 - assume Heq: y = b1.
	                   apply FalseE.
	                   prove False.
	                   claim Hb1Y': b1 :e Y.
	                   { rewrite <- Heq.
	                     exact HyY. }
	                   exact (Hb1notY Hb1Y').
                 - assume Hgt: order_rel X b1 y.
	                   apply FalseE.
	                   prove False.
	                   claim HxProp: order_rel X x b1.
	                   { claim HxInbY: x :e bY.
	                     { exact (binintersectI b0 Y x Hxb0 HxY). }
	                     claim HxInDef: x :e {z :e Y | order_rel X z b1}.
	                     { rewrite <- HbYdef.
	                       exact HxInbY. }
	                     exact (SepE2 Y (fun w:set => order_rel X w b1) x HxInDef). }
                   claim Hb1InInt: b1 :e order_interval X x y.
                   { exact (order_intervalI X x y b1 Hb1X HxProp Hgt). }
                   claim HintSub: order_interval X x y c= Y.
                   { exact (convex_in_interval_property X Y Hconv x y HxY HyY). }
                   exact (Hb1notY (HintSub b1 Hb1InInt)). }
               claim HbYeqY: bY = Y.
               { apply set_ext.
                 - exact (binintersect_Subq_2 b0 Y).
                 - let z. assume HzY: z :e Y.
                   claim HzX: z :e X.
                   { exact (HYsub z HzY). }
                   claim HzProp: order_rel X z b1.
                   { exact (Hb1upper z HzY). }
                   claim Hzb0: z :e b0.
                   { rewrite Hb0eq.
                     exact (SepI X (fun w:set => order_rel X w b1) z HzX HzProp). }
                   exact (binintersectI b0 Y z Hzb0 HzY). }
               rewrite HbYeqY.
               exact (binunionI2 Boldinh {Y} Y (SingI Y)).
      * (** right ray case **)
        assume Hb0C0: b0 :e C0.
        claim HexRay: exists a0 :e X, b0 = {z :e X | order_rel X a0 z}.
        { exact (SepE2 (Power X)
                       (fun I:set => exists a0 :e X, I = {z :e X | order_rel X a0 z})
                       b0
                       Hb0C0). }
        apply HexRay.
        let a0. assume Ha0pair.
        apply Ha0pair.
        assume Ha0X: a0 :e X.
        assume Hb0eq: b0 = {z :e X | order_rel X a0 z}.
        claim HbYdef: bY = {z :e Y | order_rel X a0 z}.
        { apply set_ext.
          - let z. assume Hz: z :e bY.
            claim Hzb0: z :e b0.
            { exact (binintersectE1 b0 Y z Hz). }
            claim HzY: z :e Y.
            { exact (binintersectE2 b0 Y z Hz). }
	            claim HzIn: z :e {z :e X | order_rel X a0 z}.
	            { rewrite <- Hb0eq.
	              exact Hzb0. }
	            claim HzProp: order_rel X a0 z.
	            { exact (SepE2 X (fun w:set => order_rel X a0 w) z HzIn). }
            exact (SepI Y (fun w:set => order_rel X a0 w) z HzY HzProp).
          - let z. assume Hz: z :e {z :e Y | order_rel X a0 z}.
            claim HzY: z :e Y.
            { exact (SepE1 Y (fun w:set => order_rel X a0 w) z Hz). }
            claim HzProp: order_rel X a0 z.
            { exact (SepE2 Y (fun w:set => order_rel X a0 w) z Hz). }
            claim HzX: z :e X.
            { exact (HYsub z HzY). }
            claim Hzb0: z :e b0.
            { rewrite Hb0eq.
              exact (SepI X (fun w:set => order_rel X a0 w) z HzX HzProp). }
            exact (binintersectI b0 Y z Hzb0 HzY). }
        apply (xm (a0 :e Y)).
        - assume Ha0Y: a0 :e Y.
           rewrite HbYdef.
           claim HbYpow: {z :e Y | order_rel X a0 z} :e Power Y.
           { apply PowerI Y {z :e Y | order_rel X a0 z}.
             let z. assume Hz: z :e {z :e Y | order_rel X a0 z}.
             exact (SepE1 Y (fun w:set => order_rel X a0 w) z Hz). }
           claim HbYC: {z :e Y | order_rel X a0 z} :e Cinh_ray.
           { apply (SepI (Power Y)
                         (fun I:set => exists a :e Y, I = {z :e Y | order_rel X a z})
                         {z :e Y | order_rel X a0 z}
                         HbYpow).
             witness a0.
             apply andI.
             - exact Ha0Y.
             - reflexivity. }
           exact (binunionI1 Boldinh {Y}
                             {z :e Y | order_rel X a0 z}
                             (binunionI2 (Ainh :\/: Binh_ray) Cinh_ray
                                         {z :e Y | order_rel X a0 z}
                                         HbYC)).
        - assume Ha0notY: ~(a0 :e Y).
           claim Ha0lower: forall y:set, y :e Y -> order_rel X a0 y.
           { let y. assume HyY: y :e Y.
             apply (order_rel_trichotomy_or_impred X a0 y Hso Ha0X (HYsub y HyY) (order_rel X a0 y)).
             - assume Hlt: order_rel X a0 y.
               exact Hlt.
	             - assume Heq: a0 = y.
	               apply FalseE.
	               prove False.
	               claim Ha0Y': a0 :e Y.
	               { rewrite Heq.
	                 exact HyY. }
	               exact (Ha0notY Ha0Y').
             - assume Hgt: order_rel X y a0.
	               apply FalseE.
	               prove False.
	               claim HxProp: order_rel X a0 x.
	               { claim HxInbY: x :e bY.
	                 { exact (binintersectI b0 Y x Hxb0 HxY). }
	                 claim HxInDef: x :e {z :e Y | order_rel X a0 z}.
	                 { rewrite <- HbYdef.
	                   exact HxInbY. }
	                 exact (SepE2 Y (fun w:set => order_rel X a0 w) x HxInDef). }
               claim Ha0InInt: a0 :e order_interval X y x.
               { exact (order_intervalI X y x a0 Ha0X Hgt HxProp). }
               claim HintSub: order_interval X y x c= Y.
               { exact (convex_in_interval_property X Y Hconv y x HyY HxY). }
               exact (Ha0notY (HintSub a0 Ha0InInt)). }
           claim HbYeqY: bY = Y.
           { apply set_ext.
             - exact (binintersect_Subq_2 b0 Y).
             - let z. assume HzY: z :e Y.
               claim HzX: z :e X.
               { exact (HYsub z HzY). }
               claim HzProp: order_rel X a0 z.
               { exact (Ha0lower z HzY). }
               claim Hzb0: z :e b0.
               { rewrite Hb0eq.
                 exact (SepI X (fun w:set => order_rel X a0 w) z HzX HzProp). }
               exact (binintersectI b0 Y z Hzb0 HzY). }
           rewrite HbYeqY.
           exact (binunionI2 Boldinh {Y} Y (SingI Y)).
    + (** b0 = X **)
      assume Hb0X: b0 :e {X}.
      claim Hb0eqX: b0 = X.
      { exact (SingE X b0 Hb0X). }
      claim HbYeqY: bY = Y.
      { apply set_ext.
        - exact (binintersect_Subq_2 b0 Y).
        - let z. assume HzY: z :e Y.
          claim HzX: z :e X.
          { exact (HYsub z HzY). }
          claim Hzb0: z :e b0.
          { rewrite Hb0eqX.
            exact HzX. }
          exact (binintersectI b0 Y z Hzb0 HzY). }
      rewrite HbYeqY.
      exact (binunionI2 Boldinh {Y} Y (SingI Y)).
  - apply andI.
    + exact (binintersectI b0 Y x Hxb0 HxY).
    + (** b0∩Y ⊂ V∩Y = U **)
      let z. assume Hz: z :e bY.
      claim Hzb0: z :e b0.
      { exact (binintersectE1 b0 Y z Hz). }
      claim HzY: z :e Y.
      { exact (binintersectE2 b0 Y z Hz). }
      claim HzV: z :e V.
      { exact (Hb0subV z Hzb0). }
      claim HzU: z :e U.
      { rewrite HUeq.
        exact (binintersectI V Y z HzV HzY). }
      exact HzU.
Qed.

(** helper: intersection with a subset can drop the larger set **) 
Theorem binintersect_right_absorb_subset : forall W Y A:set,
  A c= Y -> (W :/\: Y) :/\: A = W :/\: A.
let W Y A.
assume Hsub: A c= Y.
apply set_ext.
- let x. assume Hx: x :e (W :/\: Y) :/\: A.
  claim Hpair : x :e W :/\: Y /\ x :e A.
  { exact (binintersectE (W :/\: Y) A x Hx). }
  claim HWY : x :e W :/\: Y.
  { exact (andEL (x :e W :/\: Y) (x :e A) Hpair). }
  claim HA : x :e A.
  { exact (andER (x :e W :/\: Y) (x :e A) Hpair). }
  claim HWYpair : x :e W /\ x :e Y.
  { exact (binintersectE W Y x HWY). }
  claim HW : x :e W.
  { exact (andEL (x :e W) (x :e Y) HWYpair). }
  apply binintersectI.
  * exact HW.
  * exact HA.
- let x. assume Hx: x :e W :/\: A.
  claim Hpair : x :e W /\ x :e A.
  { exact (binintersectE W A x Hx). }
  claim HW : x :e W.
  { exact (andEL (x :e W) (x :e A) Hpair). }
  claim HA : x :e A.
  { exact (andER (x :e W) (x :e A) Hpair). }
  claim HY : x :e Y.
  { exact (Hsub x HA). }
  claim HWY : x :e W :/\: Y.
  { exact (binintersectI W Y x HW HY). }
  apply binintersectI.
  * exact HWY.
  * exact HA.
Qed.

(** from §16 Exercise 1: subspace of subspace inherits same topology **)
(** LATEX VERSION: Exercise 1: Subspace of a subspace has the same topology as taking the subspace directly. **)
Theorem ex16_1_subspace_transitive : forall X Tx Y A:set,
  topology_on X Tx -> Y c= X -> A c= Y ->
  subspace_topology Y (subspace_topology X Tx Y) A =
  subspace_topology X Tx A.
let X Tx Y A.
assume Htop: topology_on X Tx.
assume HY: Y c= X.
assume HA: A c= Y.
prove subspace_topology Y (subspace_topology X Tx Y) A = subspace_topology X Tx A.
(** Strategy: Prove both sides equal {W ∈ Power A | ∃V∈Tx, W = V∩A} using binintersect_right_absorb_subset: (V∩Y)∩A = V∩A when A⊆Y **)
apply set_ext.
- let W.
  assume HW: W :e subspace_topology Y (subspace_topology X Tx Y) A.
  prove W :e subspace_topology X Tx A.
  (** W ∈ subspace_topology Y (subspace_topology X Tx Y) A means W ∈ Power A and exists U∈(subspace_topology X Tx Y) with W = U ∩ A. **)
  claim HWPowerA: W :e Power A.
  { exact (SepE1 (Power A) (fun U0:set => exists U :e subspace_topology X Tx Y, U0 = U :/\: A) W HW). }
  claim HWexists: exists U :e subspace_topology X Tx Y, W = U :/\: A.
  { exact (subspace_topologyE Y (subspace_topology X Tx Y) A W HW). }
  apply HWexists.
  let U.
  assume HU: U :e subspace_topology X Tx Y /\ W = U :/\: A.
  claim HUinSubY: U :e subspace_topology X Tx Y.
  { exact (andEL (U :e subspace_topology X Tx Y) (W = U :/\: A) HU). }
  claim HWeqUA: W = U :/\: A.
  { exact (andER (U :e subspace_topology X Tx Y) (W = U :/\: A) HU). }
  (** U ∈ subspace_topology X Tx Y means U ∈ Power Y ∧ ∃V∈Tx, U = V ∩ Y **)
  claim HUPowerY: U :e Power Y.
  { exact (subspace_topology_in_Power X Tx Y U HUinSubY). }
  claim HUexists: exists V :e Tx, U = V :/\: Y.
  { exact (subspace_topologyE X Tx Y U HUinSubY). }
  apply HUexists.
  let V.
  assume HV: V :e Tx /\ U = V :/\: Y.
  claim HVinTx: V :e Tx.
  { exact (andEL (V :e Tx) (U = V :/\: Y) HV). }
  claim HUeqVY: U = V :/\: Y.
  { exact (andER (V :e Tx) (U = V :/\: Y) HV). }
  (** Now W = U ∩ A = (V ∩ Y) ∩ A = V ∩ A by binintersect_right_absorb_subset **)
  claim HWeqVA: W = V :/\: A.
  { rewrite HWeqUA.
    rewrite HUeqVY.
    exact (binintersect_right_absorb_subset V Y A HA). }
  (** So W ∈ {W ∈ Power A | ∃V∈Tx, W = V∩A} = subspace_topology X Tx A **)
  claim HWPred: exists V0 :e Tx, W = V0 :/\: A.
  { witness V.
    apply andI.
    - exact HVinTx.
    - exact HWeqVA. }
  exact (SepI (Power A) (fun W0:set => exists V0 :e Tx, W0 = V0 :/\: A) W HWPowerA HWPred).
- let W.
  assume HW: W :e subspace_topology X Tx A.
  prove W :e subspace_topology Y (subspace_topology X Tx Y) A.
  (** W ∈ subspace_topology X Tx A means W ∈ Power A ∧ ∃V∈Tx, W = V ∩ A **)
  claim HWPowerA: W :e Power A.
  { exact (subspace_topology_in_Power X Tx A W HW). }
  claim HWexists: exists V :e Tx, W = V :/\: A.
  { exact (subspace_topologyE X Tx A W HW). }
  apply HWexists.
  let V.
  assume HV: V :e Tx /\ W = V :/\: A.
  claim HVinTx: V :e Tx.
  { exact (andEL (V :e Tx) (W = V :/\: A) HV). }
  claim HWeqVA: W = V :/\: A.
  { exact (andER (V :e Tx) (W = V :/\: A) HV). }
	(** Set U = V ∩ Y. Then U ∈ subspace_topology X Tx Y, and W = U ∩ A **)
	set U := V :/\: Y.
	claim HUinSubY: U :e subspace_topology X Tx Y.
	{ exact (subspace_topologyI X Tx Y V HVinTx). }
  claim HWeqUA: W = U :/\: A.
  { rewrite HWeqVA.
    symmetry.
    exact (binintersect_right_absorb_subset V Y A HA). }
  (** So W ∈ {W ∈ Power A | ∃U∈(subspace_topology X Tx Y), W = U∩A} **)
  claim HWPred: exists U0 :e subspace_topology X Tx Y, W = U0 :/\: A.
  { witness U.
    apply andI.
    - exact HUinSubY.
    - exact HWeqUA. }
  exact (SepI (Power A) (fun W0:set => exists U0 :e subspace_topology X Tx Y, W0 = U0 :/\: A) W HWPowerA HWPred).
Qed.

(** from §16 Exercise 2: fineness relation passes to subspaces **)
(** LATEX VERSION: Exercise 2: If T'⊂T on X, then the induced subspace topology from T' on Y is contained in that from T. **)
Theorem ex16_2_finer_subspaces : forall X T T' Y:set,
  topology_on X T -> topology_on X T' -> T' c= T -> Y c= X ->
  subspace_topology X T' Y c= subspace_topology X T Y.
let X T T' Y.
assume Htop: topology_on X T.
assume Htop': topology_on X T'.
assume Hfiner: T' c= T.
assume HY: Y c= X.
prove subspace_topology X T' Y c= subspace_topology X T Y.
(** Strategy: If W ∈ subspace_topology X T' Y, then W = V' ∩ Y for some V' ∈ T'; since T' ⊆ T, V' ∈ T, so W ∈ subspace_topology X T Y. **)
let W.
assume HW: W :e subspace_topology X T' Y.
prove W :e subspace_topology X T Y.
  (** W ∈ subspace_topology X T' Y means W ∈ Power Y ∧ ∃V'∈T', W = V' ∩ Y **)
  claim HWPowerY: W :e Power Y.
  { exact (subspace_topology_in_Power X T' Y W HW). }
  claim HWexists: exists V :e T', W = V :/\: Y.
  { exact (subspace_topologyE X T' Y W HW). }
  apply HWexists.
let V'.
assume HV': V' :e T' /\ W = V' :/\: Y.
claim HV'inT': V' :e T'.
{ exact (andEL (V' :e T') (W = V' :/\: Y) HV'). }
claim HWeqV'Y: W = V' :/\: Y.
{ exact (andER (V' :e T') (W = V' :/\: Y) HV'). }
(** Since T' ⊆ T, we have V' ∈ T **)
claim HV'inT: V' :e T.
{ exact (Hfiner V' HV'inT'). }
(** So W = V' ∩ Y with V' ∈ T, meaning W ∈ subspace_topology X T Y **)
claim HWPred: exists V :e T, W = V :/\: Y.
{ witness V'.
  apply andI.
  - exact HV'inT.
  - exact HWeqV'Y. }
exact (SepI (Power Y) (fun W0:set => exists V :e T, W0 = V :/\: Y) W HWPowerY HWPred).
Qed.

(** Helper: subspace topology respects equality of ambient topologies **)
Theorem subspace_topology_eq_of_eq : forall X T T' Y:set,
  T = T' ->
  subspace_topology X T Y = subspace_topology X T' Y.
let X T T' Y.
assume Heq: T = T'.
prove subspace_topology X T Y = subspace_topology X T' Y.
rewrite Heq.
reflexivity.
Qed.

(** from §16 Exercise 3: openness of specific sets in subspace [-1,1] **)
(** LATEX VERSION: Exercise 3: Determine openness in subspace [-1,1]; formalized as existence of ambient open V with U=V∩Y. **)
(** LATEX VERSION: A={x|1/2<|x|<1}, B={x|1/2<|x|<=1}, C={x|1/2<=|x|<1}, D={x|1/2<=|x|<=1}, E={x|0<|x|<1 and 1/x not in Zplus}. **)
Definition one_half : set := inv_nat 2.
Definition interval_A : set := {x :e R | one_half < abs_SNo x /\ abs_SNo x < 1}.
Definition interval_B : set := {x :e R | one_half < abs_SNo x /\ ~(1 < abs_SNo x)}.
Definition interval_C : set := {x :e R | ~(abs_SNo x < one_half) /\ abs_SNo x < 1}.
Definition interval_D : set := {x :e R | ~(abs_SNo x < one_half) /\ ~(1 < abs_SNo x)}.
(** from §16 Exercise 3: set E in the subspace [-1,1] **)
(** LATEX VERSION: E = {x ∈ ℝ | 0<|x|<1 and 1/x ∉ ℤ_+}. **)
Definition interval_E : set := {x :e R | 0 < abs_SNo x /\ abs_SNo x < 1 /\ ~ (div_SNo 1 x :e Zplus)}.

Theorem ex16_3_open_sets_subspace : forall X Tx Y:set,
  topology_on X Tx -> Y c= X ->
  forall U:set, open_in Y (subspace_topology X Tx Y) U -> exists V:set, open_in X Tx V /\ U = V :/\: Y.
let X Tx Y.
assume Htop: topology_on X Tx.
assume HY: Y c= X.
let U.
assume HU: open_in Y (subspace_topology X Tx Y) U.
prove exists V:set, open_in X Tx V /\ U = V :/\: Y.
  (** open_in Y (subspace_topology X Tx Y) U means topology_on Y (subspace_topology X Tx Y) and U ∈ subspace_topology X Tx Y. **)
claim HtopY: topology_on Y (subspace_topology X Tx Y).
{ exact (andEL (topology_on Y (subspace_topology X Tx Y)) (U :e subspace_topology X Tx Y) HU). }
claim HUinSub: U :e subspace_topology X Tx Y.
{ exact (andER (topology_on Y (subspace_topology X Tx Y)) (U :e subspace_topology X Tx Y) HU). }
  (** U ∈ subspace_topology X Tx Y means U ∈ Power Y ∧ ∃V∈Tx, U = V ∩ Y **)
  claim HUPowerY: U :e Power Y.
  { exact (subspace_topology_in_Power X Tx Y U HUinSub). }
  claim HUexists: exists V :e Tx, U = V :/\: Y.
  { exact (subspace_topologyE X Tx Y U HUinSub). }
apply HUexists.
let V.
assume HV: V :e Tx /\ U = V :/\: Y.
claim HVinTx: V :e Tx.
{ exact (andEL (V :e Tx) (U = V :/\: Y) HV). }
claim HUeqVY: U = V :/\: Y.
{ exact (andER (V :e Tx) (U = V :/\: Y) HV). }
(** Now open_in X Tx V means topology_on X Tx ∧ V ∈ Tx, both of which we have **)
claim HVopen: open_in X Tx V.
{ exact (andI (topology_on X Tx) (V :e Tx) Htop HVinTx). }
witness V.
apply andI.
- exact HVopen.
- exact HUeqVY.
Qed.

(** from §16 Exercise 4: projections are open maps **)
(** LATEX VERSION: Exercise 4: Projections from a product are open maps. **)
Definition projection_image1 : set -> set -> set -> set :=
  fun X Y U => {x :e X | exists y:set, (x,y) :e U}.
Definition projection_image2 : set -> set -> set -> set :=
  fun X Y U => {y :e Y | exists x:set, (x,y) :e U}.

(** helper: nonempty set has an element **)
Theorem nonempty_has_element : forall V:set, V <> Empty -> exists y:set, y :e V.
let V. assume Hne: V <> Empty.
apply (xm (exists y:set, y :e V)).
- assume Hex. exact Hex.
- assume Hno: ~(exists y:set, y :e V).
  claim HVsub: V c= Empty.
  { let y. assume Hy: y :e V.
    prove y :e Empty.
    apply FalseE.
    claim Hexy: exists z:set, z :e V.
    { witness y. exact Hy. }
    exact (Hno Hexy). }
  claim HVEmpty: V = Empty.
  { exact (Empty_Subq_eq V HVsub). }
  apply FalseE.
  exact (Hne HVEmpty).
Qed.

(** helper: set with an element is nonempty **)
Theorem elem_implies_nonempty : forall V y:set, y :e V -> V <> Empty.
let V y.
assume Hy: y :e V.
prove V <> Empty.
assume HV: V = Empty.
claim HyE: y :e Empty.
{ rewrite <- HV.
  exact Hy. }
exact (EmptyE y HyE).
Qed.

(** helper: projection of a rectangle to the first coordinate **)
Theorem projection_image1_rectangle_nonempty : forall X Y U V:set,
  U c= X ->
  V c= Y ->
  V <> Empty ->
  projection_image1 X Y (setprod U V) = U.
let X Y U V.
assume HUsub: U c= X.
assume HVsub: V c= Y.
assume HVne: V <> Empty.
set y0 := Eps_i (fun y:set => y :e V).
claim Hexy: exists y:set, y :e V.
{ exact (nonempty_has_element V HVne). }
claim Hy0: y0 :e V.
{ exact (Eps_i_ex (fun y:set => y :e V) Hexy). }
apply set_ext.
- let x. assume Hx: x :e projection_image1 X Y (setprod U V).
  prove x :e U.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => exists y:set, (x0,y) :e setprod U V) x Hx). }
  claim Hex: exists y:set, (x,y) :e setprod U V.
  { exact (SepE2 X (fun x0:set => exists y:set, (x0,y) :e setprod U V) x Hx). }
  apply Hex.
  let y. assume Hxy: (x,y) :e setprod U V.
  claim Hx0: ((x,y) 0) :e U.
  { exact (ap0_Sigma U (fun _:set => V) (x,y) Hxy). }
  rewrite <- (tuple_2_0_eq x y).
				        exact Hx0.
- let x. assume HxU: x :e U.
  prove x :e projection_image1 X Y (setprod U V).
  claim HxX: x :e X.
  { exact (HUsub x HxU). }
  claim Hpred: exists y:set, (x,y) :e setprod U V.
  { witness y0.
    exact (lamI2 U (fun _:set => V) x HxU y0 Hy0). }
  exact (SepI X (fun x0:set => exists y:set, (x0,y) :e setprod U V) x HxX Hpred).
Qed.

Theorem projection_image1_rectangle_empty : forall X Y U:set,
  projection_image1 X Y (setprod U Empty) = Empty.
let X Y U.
apply set_ext.
- let x. assume Hx: x :e projection_image1 X Y (setprod U Empty).
  prove x :e Empty.
  claim Hex: exists y:set, (x,y) :e setprod U Empty.
  { exact (SepE2 X (fun x0:set => exists y:set, (x0,y) :e setprod U Empty) x Hx). }
  apply Hex.
  let y. assume Hxy: (x,y) :e setprod U Empty.
  claim HyEmpty: ((x,y) 1) :e Empty.
  { exact (ap1_Sigma U (fun _:set => Empty) (x,y) Hxy). }
  claim HyE: y :e Empty.
  { prove y :e Empty.
    rewrite <- (tuple_2_1_eq x y).
    exact HyEmpty. }
  apply FalseE.
  exact (EmptyE y HyE).
- let x. assume Hx: x :e Empty.
  apply (EmptyE x Hx).
Qed.

(** helper: projection of a rectangle to the second coordinate **)
Theorem projection_image2_rectangle_nonempty : forall X Y U V:set,
  U c= X ->
  V c= Y ->
  U <> Empty ->
  projection_image2 X Y (setprod U V) = V.
let X Y U V.
assume HUsub: U c= X.
assume HVsub: V c= Y.
assume HUne: U <> Empty.
set x0 := Eps_i (fun x:set => x :e U).
claim Hexx: exists x:set, x :e U.
{ exact (nonempty_has_element U HUne). }
claim Hx0: x0 :e U.
{ exact (Eps_i_ex (fun x:set => x :e U) Hexx). }
apply set_ext.
- let y. assume Hy: y :e projection_image2 X Y (setprod U V).
  prove y :e V.
  claim HyY: y :e Y.
  { exact (SepE1 Y (fun y0:set => exists x:set, (x,y0) :e setprod U V) y Hy). }
  claim Hex: exists x:set, (x,y) :e setprod U V.
  { exact (SepE2 Y (fun y0:set => exists x:set, (x,y0) :e setprod U V) y Hy). }
  apply Hex.
  let x. assume Hxy: (x,y) :e setprod U V.
  claim Hy1: ((x,y) 1) :e V.
  { exact (ap1_Sigma U (fun _:set => V) (x,y) Hxy). }
  rewrite <- (tuple_2_1_eq x y).
  exact Hy1.
- let y. assume HyV: y :e V.
  prove y :e projection_image2 X Y (setprod U V).
  claim HyY: y :e Y.
  { exact (HVsub y HyV). }
  claim Hpred: exists x:set, (x,y) :e setprod U V.
  { witness x0.
    exact (lamI2 U (fun _:set => V) x0 Hx0 y HyV). }
  exact (SepI Y (fun y0:set => exists x:set, (x,y0) :e setprod U V) y HyY Hpred).
Qed.

Theorem projection_image2_rectangle_empty : forall X Y V:set,
  projection_image2 X Y (setprod Empty V) = Empty.
let X Y V.
apply set_ext.
- let y. assume Hy: y :e projection_image2 X Y (setprod Empty V).
  prove y :e Empty.
  claim Hex: exists x:set, (x,y) :e setprod Empty V.
  { exact (SepE2 Y (fun y0:set => exists x:set, (x,y0) :e setprod Empty V) y Hy). }
  apply Hex.
  let x. assume Hxy: (x,y) :e setprod Empty V.
  claim HxEmpty: ((x,y) 0) :e Empty.
  { exact (ap0_Sigma Empty (fun _:set => V) (x,y) Hxy). }
  claim HxE: x :e Empty.
  { prove x :e Empty.
    rewrite <- (tuple_2_0_eq x y).
    exact HxEmpty. }
  apply FalseE.
  exact (EmptyE x HxE).
- let y. assume Hy: y :e Empty.
  apply (EmptyE y Hy).
Qed.

Theorem ex16_4_projections_open : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  forall U:set, U :e product_topology X Tx Y Ty ->
    open_in X Tx (projection_image1 X Y U) /\ open_in Y Ty (projection_image2 X Y U).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
let U.
assume HU: U :e product_topology X Tx Y Ty.
prove open_in X Tx (projection_image1 X Y U) /\ open_in Y Ty (projection_image2 X Y U).
apply andI.
- prove open_in X Tx (projection_image1 X Y U).
  prove topology_on X Tx /\ projection_image1 X Y U :e Tx.
  apply andI.
  + exact HTx.
  + (** represent U as a union of product subbasis elements **)
    claim HtopProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
    { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
    claim HUopen: open_in (setprod X Y) (product_topology X Tx Y Ty) U.
    { exact (andI (topology_on (setprod X Y) (product_topology X Tx Y Ty)) (U :e product_topology X Tx Y Ty) HtopProd HU). }
    claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
    { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
    claim HexFam: exists Fam :e Power (product_subbasis X Tx Y Ty), Union Fam = U.
    { exact (open_sets_as_unions_of_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis U HUopen). }
    apply HexFam.
    let Fam. assume HFampair.
    claim HFamPow: Fam :e Power (product_subbasis X Tx Y Ty).
    { exact (andEL (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = U) HFampair). }
    claim HUnionEq: Union Fam = U.
    { exact (andER (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = U) HFampair). }
    set P1Fam := {projection_image1 X Y b|b :e Fam}.
    claim HP1open: open_in X Tx (Union P1Fam).
    { apply (union_open X Tx P1Fam HTx).
      let W. assume HW: W :e P1Fam.
      prove open_in X Tx W.
      claim Hexb: exists b :e Fam, W = projection_image1 X Y b.
      { exact (ReplE Fam (fun b0:set => projection_image1 X Y b0) W HW). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbFam: b :e Fam.
      { exact (andEL (b :e Fam) (W = projection_image1 X Y b) Hbpair). }
      claim HWeq: W = projection_image1 X Y b.
      { exact (andER (b :e Fam) (W = projection_image1 X Y b) Hbpair). }
      claim HbSub: b :e product_subbasis X Tx Y Ty.
      { exact (PowerE (product_subbasis X Tx Y Ty) Fam HFamPow b HbFam). }
      claim HexU0: exists U0 :e Tx, b :e {rectangle_set U0 V|V :e Ty}.
      { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbSub). }
      apply HexU0.
      let U0. assume HU0conj.
      claim HU0Tx: U0 :e Tx.
      { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
      claim HbRepl: b :e {rectangle_set U0 V|V :e Ty}.
      { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
      claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
      { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbRepl). }
      apply HexV0.
      let V0. assume HV0conj.
      claim HV0Ty: V0 :e Ty.
      { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
      claim Hbeq: b = rectangle_set U0 V0.
      { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
      claim HU0subX: U0 c= X.
      { exact (topology_elem_subset X Tx U0 HTx HU0Tx). }
      claim HV0subY: V0 c= Y.
      { exact (topology_elem_subset Y Ty V0 HTy HV0Ty). }
      apply (xm (V0 = Empty)).
      - assume HV0E: V0 = Empty.
        claim HWEmpty: W = Empty.
        { prove W = Empty.
          rewrite HWeq.
          rewrite Hbeq.
          rewrite HV0E.
          exact (projection_image1_rectangle_empty X Y U0). }
        rewrite HWEmpty.
        exact (andI (topology_on X Tx) (Empty :e Tx) HTx (topology_has_empty X Tx HTx)).
      - assume HV0NE: ~(V0 = Empty).
        claim HV0ne: V0 <> Empty.
        { exact HV0NE. }
        claim HWU0: W = U0.
        { prove W = U0.
          rewrite HWeq.
          rewrite Hbeq.
          exact (projection_image1_rectangle_nonempty X Y U0 V0 HU0subX HV0subY HV0ne). }
        rewrite HWU0.
        exact (andI (topology_on X Tx) (U0 :e Tx) HTx HU0Tx). }
    claim HP1inTx: Union P1Fam :e Tx.
    { exact (andER (topology_on X Tx) (Union P1Fam :e Tx) HP1open). }
    claim HUnionP1: Union P1Fam = projection_image1 X Y (Union Fam).
    { apply set_ext.
      - let x. assume Hx: x :e Union P1Fam.
        claim HexW: exists W:set, x :e W /\ W :e P1Fam.
        { exact (UnionE P1Fam x Hx). }
        apply HexW.
        let W. assume HWconj.
        claim HxW: x :e W.
        { exact (andEL (x :e W) (W :e P1Fam) HWconj). }
        claim HWPF: W :e P1Fam.
        { exact (andER (x :e W) (W :e P1Fam) HWconj). }
        claim Hexb: exists b :e Fam, W = projection_image1 X Y b.
        { exact (ReplE Fam (fun b0:set => projection_image1 X Y b0) W HWPF). }
        apply Hexb.
        let b. assume Hbpair.
        claim HbFam: b :e Fam.
        { exact (andEL (b :e Fam) (W = projection_image1 X Y b) Hbpair). }
        claim HWeq: W = projection_image1 X Y b.
        { exact (andER (b :e Fam) (W = projection_image1 X Y b) Hbpair). }
        claim HxP1b: x :e projection_image1 X Y b.
        { rewrite <- HWeq. exact HxW. }
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => exists y:set, (x0,y) :e b) x HxP1b). }
        claim Hexy: exists y:set, (x,y) :e b.
        { exact (SepE2 X (fun x0:set => exists y:set, (x0,y) :e b) x HxP1b). }
        claim Hpred: exists y:set, (x,y) :e Union Fam.
        { apply Hexy.
          let y. assume Hxy: (x,y) :e b.
          claim HbInUnion: (x,y) :e Union Fam.
          { exact (UnionI Fam (x,y) b Hxy HbFam). }
          witness y.
          exact HbInUnion. }
        exact (SepI X (fun x0:set => exists y:set, (x0,y) :e Union Fam) x HxX Hpred).
      - let x. assume Hx: x :e projection_image1 X Y (Union Fam).
        prove x :e Union P1Fam.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => exists y:set, (x0,y) :e Union Fam) x Hx). }
        claim Hexy: exists y:set, (x,y) :e Union Fam.
        { exact (SepE2 X (fun x0:set => exists y:set, (x0,y) :e Union Fam) x Hx). }
        apply Hexy.
        let y. assume HxyUnion: (x,y) :e Union Fam.
        apply UnionE_impred Fam (x,y) HxyUnion.
        let b. assume Hxyb HbFam.
        claim HbPF: projection_image1 X Y b :e P1Fam.
        { exact (ReplI Fam (fun b0:set => projection_image1 X Y b0) b HbFam). }
        claim HxP1b: x :e projection_image1 X Y b.
        { claim Hpred: exists y0:set, (x,y0) :e b.
          { witness y.
            exact Hxyb. }
          exact (SepI X (fun x0:set => exists y0:set, (x0,y0) :e b) x HxX Hpred). }
        exact (UnionI P1Fam x (projection_image1 X Y b) HxP1b HbPF). }
    rewrite <- HUnionEq.
    rewrite <- HUnionP1.
    exact HP1inTx.
- prove open_in Y Ty (projection_image2 X Y U).
  prove topology_on Y Ty /\ projection_image2 X Y U :e Ty.
  apply andI.
  + exact HTy.
  + claim HtopProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
    { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
    claim HUopen: open_in (setprod X Y) (product_topology X Tx Y Ty) U.
    { exact (andI (topology_on (setprod X Y) (product_topology X Tx Y Ty)) (U :e product_topology X Tx Y Ty) HtopProd HU). }
    claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
    { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
    claim HexFam: exists Fam :e Power (product_subbasis X Tx Y Ty), Union Fam = U.
    { exact (open_sets_as_unions_of_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis U HUopen). }
    apply HexFam.
    let Fam. assume HFampair.
    claim HFamPow: Fam :e Power (product_subbasis X Tx Y Ty).
    { exact (andEL (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = U) HFampair). }
    claim HUnionEq: Union Fam = U.
    { exact (andER (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = U) HFampair). }
    set P2Fam := {projection_image2 X Y b|b :e Fam}.
    claim HP2open: open_in Y Ty (Union P2Fam).
    { apply (union_open Y Ty P2Fam HTy).
      let W. assume HW: W :e P2Fam.
      prove open_in Y Ty W.
      claim Hexb: exists b :e Fam, W = projection_image2 X Y b.
      { exact (ReplE Fam (fun b0:set => projection_image2 X Y b0) W HW). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbFam: b :e Fam.
      { exact (andEL (b :e Fam) (W = projection_image2 X Y b) Hbpair). }
      claim HWeq: W = projection_image2 X Y b.
      { exact (andER (b :e Fam) (W = projection_image2 X Y b) Hbpair). }
      claim HbSub: b :e product_subbasis X Tx Y Ty.
      { exact (PowerE (product_subbasis X Tx Y Ty) Fam HFamPow b HbFam). }
      claim HexU0: exists U0 :e Tx, b :e {rectangle_set U0 V|V :e Ty}.
      { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbSub). }
      apply HexU0.
      let U0. assume HU0conj.
      claim HU0Tx: U0 :e Tx.
      { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
      claim HbRepl: b :e {rectangle_set U0 V|V :e Ty}.
      { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
      claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
      { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbRepl). }
      apply HexV0.
      let V0. assume HV0conj.
      claim HV0Ty: V0 :e Ty.
      { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
      claim Hbeq: b = rectangle_set U0 V0.
      { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
      claim HU0subX: U0 c= X.
      { exact (topology_elem_subset X Tx U0 HTx HU0Tx). }
      claim HV0subY: V0 c= Y.
      { exact (topology_elem_subset Y Ty V0 HTy HV0Ty). }
      apply (xm (U0 = Empty)).
      - assume HU0E: U0 = Empty.
        claim HWEmpty: W = Empty.
        { prove W = Empty.
          rewrite HWeq.
          rewrite Hbeq.
          rewrite HU0E.
          exact (projection_image2_rectangle_empty X Y V0). }
        rewrite HWEmpty.
        exact (andI (topology_on Y Ty) (Empty :e Ty) HTy (topology_has_empty Y Ty HTy)).
      - assume HU0NE: ~(U0 = Empty).
        claim HUne: U0 <> Empty.
        { exact HU0NE. }
        claim HWV0: W = V0.
        { prove W = V0.
          rewrite HWeq.
          rewrite Hbeq.
          exact (projection_image2_rectangle_nonempty X Y U0 V0 HU0subX HV0subY HUne). }
        rewrite HWV0.
        exact (andI (topology_on Y Ty) (V0 :e Ty) HTy HV0Ty). }
    claim HP2inTy: Union P2Fam :e Ty.
    { exact (andER (topology_on Y Ty) (Union P2Fam :e Ty) HP2open). }
    claim HUnionP2: Union P2Fam = projection_image2 X Y (Union Fam).
    { apply set_ext.
      - let y. assume Hy: y :e Union P2Fam.
        claim HexW: exists W:set, y :e W /\ W :e P2Fam.
        { exact (UnionE P2Fam y Hy). }
        apply HexW.
        let W. assume HWconj.
        claim HyW: y :e W.
        { exact (andEL (y :e W) (W :e P2Fam) HWconj). }
        claim HWPF: W :e P2Fam.
        { exact (andER (y :e W) (W :e P2Fam) HWconj). }
        claim Hexb: exists b :e Fam, W = projection_image2 X Y b.
        { exact (ReplE Fam (fun b0:set => projection_image2 X Y b0) W HWPF). }
        apply Hexb.
        let b. assume Hbpair.
        claim HbFam: b :e Fam.
        { exact (andEL (b :e Fam) (W = projection_image2 X Y b) Hbpair). }
        claim HWeq: W = projection_image2 X Y b.
        { exact (andER (b :e Fam) (W = projection_image2 X Y b) Hbpair). }
        claim HyP2b: y :e projection_image2 X Y b.
        { rewrite <- HWeq. exact HyW. }
        claim HyY: y :e Y.
        { exact (SepE1 Y (fun y0:set => exists x:set, (x,y0) :e b) y HyP2b). }
        claim Hexx: exists x:set, (x,y) :e b.
        { exact (SepE2 Y (fun y0:set => exists x:set, (x,y0) :e b) y HyP2b). }
        claim Hpred: exists x:set, (x,y) :e Union Fam.
        { apply Hexx.
          let x. assume Hxy: (x,y) :e b.
          claim HbInUnion: (x,y) :e Union Fam.
          { exact (UnionI Fam (x,y) b Hxy HbFam). }
          witness x.
          exact HbInUnion. }
        exact (SepI Y (fun y0:set => exists x:set, (x,y0) :e Union Fam) y HyY Hpred).
      - let y. assume Hy: y :e projection_image2 X Y (Union Fam).
        prove y :e Union P2Fam.
        claim HyY: y :e Y.
        { exact (SepE1 Y (fun y0:set => exists x:set, (x,y0) :e Union Fam) y Hy). }
        claim Hexx: exists x:set, (x,y) :e Union Fam.
        { exact (SepE2 Y (fun y0:set => exists x:set, (x,y0) :e Union Fam) y Hy). }
        apply Hexx.
        let x. assume HxyUnion: (x,y) :e Union Fam.
        apply UnionE_impred Fam (x,y) HxyUnion.
        let b. assume Hxyb HbFam.
        claim HbPF: projection_image2 X Y b :e P2Fam.
        { exact (ReplI Fam (fun b0:set => projection_image2 X Y b0) b HbFam). }
        claim HyP2b: y :e projection_image2 X Y b.
        { claim Hpred: exists x0:set, (x0,y) :e b.
          { witness x.
            exact Hxyb. }
          exact (SepI Y (fun y0:set => exists x0:set, (x0,y0) :e b) y HyY Hpred). }
        exact (UnionI P2Fam y (projection_image2 X Y b) HyP2b HbPF). }
    rewrite <- HUnionEq.
    rewrite <- HUnionP2.
    exact HP2inTy.
Qed.

(** from §16 Exercise 5(a): product topology monotonicity **)
(** LATEX VERSION: Exercise 5(a): If T⊂T' and U⊂U', then the product topology from T,U is contained in that from T',U'. **)
Theorem ex16_5a_product_monotone : forall X T T' Y U U':set,
  X <> Empty -> Y <> Empty ->
  topology_on X T -> topology_on X T' -> topology_on Y U -> topology_on Y U' ->
  T c= T' /\ U c= U' ->
  product_topology X T Y U c= product_topology X T' Y U'.
	let X T T' Y U U'.
	assume HXne: X <> Empty.
	assume HYne: Y <> Empty.
	assume HTx: topology_on X T.
	assume HTx': topology_on X T'.
	assume HTy: topology_on Y U.
	assume HTy': topology_on Y U'.
	assume Hfiner: T c= T' /\ U c= U'.
	prove product_topology X T Y U c= product_topology X T' Y U'.
	claim HTprod': topology_on (setprod X Y) (product_topology X T' Y U').
	{ exact (product_topology_is_topology X T' Y U' HTx' HTy'). }
	apply (generated_topology_finer_weak (setprod X Y) (product_subbasis X T Y U) (product_topology X T' Y U') HTprod').
	let b. assume Hb: b :e product_subbasis X T Y U.
	prove b :e product_topology X T' Y U'.
	claim HexU0: exists U0 :e T, b :e {rectangle_set U0 V|V :e U}.
	{ exact (famunionE T (fun U0:set => {rectangle_set U0 V|V :e U}) b Hb). }
	apply HexU0.
	let U0. assume HU0conj.
	claim HU0T: U0 :e T.
	{ exact (andEL (U0 :e T) (b :e {rectangle_set U0 V|V :e U}) HU0conj). }
	claim HbRepl: b :e {rectangle_set U0 V|V :e U}.
	{ exact (andER (U0 :e T) (b :e {rectangle_set U0 V|V :e U}) HU0conj). }
	claim HexV0: exists V0 :e U, b = rectangle_set U0 V0.
	{ exact (ReplE U (fun V0:set => rectangle_set U0 V0) b HbRepl). }
	apply HexV0.
	let V0. assume HV0conj.
	claim HV0U: V0 :e U.
	{ exact (andEL (V0 :e U) (b = rectangle_set U0 V0) HV0conj). }
	claim Hbeq: b = rectangle_set U0 V0.
	{ exact (andER (V0 :e U) (b = rectangle_set U0 V0) HV0conj). }
	claim HU0sub: U0 :e T'.
	{ claim HTsub: T c= T'.
	  { exact (andEL (T c= T') (U c= U') Hfiner). }
	  exact (HTsub U0 HU0T). }
	claim HV0sub: V0 :e U'.
	{ claim HUsub: U c= U'.
	  { exact (andER (T c= T') (U c= U') Hfiner). }
	  exact (HUsub V0 HV0U). }
	claim HBasis': basis_on (setprod X Y) (product_subbasis X T' Y U').
	{ exact (product_subbasis_is_basis X T' Y U' HTx' HTy'). }
	claim HbSub': b :e product_subbasis X T' Y U'.
	{ prove b :e product_subbasis X T' Y U'.
	  claim HbV: rectangle_set U0 V0 :e {rectangle_set U0 V|V :e U'}.
	  { exact (ReplI U' (fun V1:set => rectangle_set U0 V1) V0 HV0sub). }
	  rewrite Hbeq.
	  exact (famunionI T' (fun U1:set => {rectangle_set U1 V|V :e U'}) U0 (rectangle_set U0 V0) HU0sub HbV). }
	exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X T' Y U') HBasis' b HbSub').
Qed.

(** from §16 Exercise 5(b): converse question about product fineness **)
(** LATEX VERSION: Exercise 5(b): If product topology from T,U is contained in that from T',U', then T⊂T' and U⊂U'. **)
Theorem ex16_5b_product_converse : forall X T T' Y U U':set,
  X <> Empty -> Y <> Empty ->
  topology_on X T -> topology_on X T' -> topology_on Y U -> topology_on Y U' ->
  product_topology X T Y U c= product_topology X T' Y U' ->
  T c= T' /\ U c= U'.
	let X T T' Y U U'.
	assume HXne: X <> Empty.
	assume HYne: Y <> Empty.
	assume HTx: topology_on X T.
	assume HTx': topology_on X T'.
	assume HTy: topology_on Y U.
	assume HTy': topology_on Y U'.
	assume Hprod: product_topology X T Y U c= product_topology X T' Y U'.
	prove T c= T' /\ U c= U'.
	apply andI.
	- (** show T c= T' using openness of projection_image1 **)
	  let V. assume HV: V :e T.
	  prove V :e T'.
	  claim HVsubX: V c= X.
	  { exact (topology_elem_subset X T V HTx HV). }
	  claim HYsubY: Y c= Y.
	  { let y. assume Hy: y :e Y. exact Hy. }
	  claim HYU: Y :e U.
	  { exact (topology_has_X Y U HTy). }
	  claim HbSub: rectangle_set V Y :e product_subbasis X T Y U.
	  { prove rectangle_set V Y :e product_subbasis X T Y U.
	    claim HbV: rectangle_set V Y :e {rectangle_set V W|W :e U}.
	    { exact (ReplI U (fun W1:set => rectangle_set V W1) Y HYU). }
	    exact (famunionI T (fun U0:set => {rectangle_set U0 W|W :e U}) V (rectangle_set V Y) HV HbV). }
	  claim HBasis: basis_on (setprod X Y) (product_subbasis X T Y U).
	  { exact (product_subbasis_is_basis X T Y U HTx HTy). }
	  claim HbOpen: rectangle_set V Y :e product_topology X T Y U.
	  { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X T Y U) HBasis (rectangle_set V Y) HbSub). }
	  claim HbOpen': rectangle_set V Y :e product_topology X T' Y U'.
	  { exact (Hprod (rectangle_set V Y) HbOpen). }
	  claim HprojOpen: open_in X T' (projection_image1 X Y (rectangle_set V Y)).
	  { exact (andEL (open_in X T' (projection_image1 X Y (rectangle_set V Y))) (open_in Y U' (projection_image2 X Y (rectangle_set V Y)))
	                 (ex16_4_projections_open X T' Y U' HTx' HTy' (rectangle_set V Y) HbOpen')). }
	  claim HVeqProj: projection_image1 X Y (rectangle_set V Y) = V.
	  { exact (projection_image1_rectangle_nonempty X Y V Y HVsubX HYsubY HYne). }
	  claim HVinT': projection_image1 X Y (rectangle_set V Y) :e T'.
	  { exact (andER (topology_on X T') (projection_image1 X Y (rectangle_set V Y) :e T') HprojOpen). }
	  rewrite <- HVeqProj.
	  exact HVinT'.
	- (** show U c= U' using openness of projection_image2 **)
	  let W. assume HW: W :e U.
	  prove W :e U'.
	  claim HWsubY: W c= Y.
	  { exact (topology_elem_subset Y U W HTy HW). }
	  claim HXsubX: X c= X.
	  { let x. assume Hx: x :e X. exact Hx. }
	  claim HX_T: X :e T.
	  { exact (topology_has_X X T HTx). }
	  claim HbSub: rectangle_set X W :e product_subbasis X T Y U.
	  { prove rectangle_set X W :e product_subbasis X T Y U.
	    claim HbW: rectangle_set X W :e {rectangle_set X V|V :e U}.
	    { exact (ReplI U (fun V1:set => rectangle_set X V1) W HW). }
	    exact (famunionI T (fun U0:set => {rectangle_set U0 V|V :e U}) X (rectangle_set X W) HX_T HbW). }
	  claim HBasis: basis_on (setprod X Y) (product_subbasis X T Y U).
	  { exact (product_subbasis_is_basis X T Y U HTx HTy). }
	  claim HbOpen: rectangle_set X W :e product_topology X T Y U.
	  { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X T Y U) HBasis (rectangle_set X W) HbSub). }
	  claim HbOpen': rectangle_set X W :e product_topology X T' Y U'.
	  { exact (Hprod (rectangle_set X W) HbOpen). }
	  claim HprojOpen: open_in Y U' (projection_image2 X Y (rectangle_set X W)).
	  { exact (andER (open_in X T' (projection_image1 X Y (rectangle_set X W))) (open_in Y U' (projection_image2 X Y (rectangle_set X W)))
	                 (ex16_4_projections_open X T' Y U' HTx' HTy' (rectangle_set X W) HbOpen')). }
	  claim HWeqProj: projection_image2 X Y (rectangle_set X W) = W.
	  { exact (projection_image2_rectangle_nonempty X Y X W HXsubX HWsubY HXne). }
	  claim HWinU': projection_image2 X Y (rectangle_set X W) :e U'.
	  { exact (andER (topology_on Y U') (projection_image2 X Y (rectangle_set X W) :e U') HprojOpen). }
	  rewrite <- HWeqProj.
	  exact HWinU'.
Qed.

(** from §16 Exercise 6: rational rectangles form a basis for ℝ² **)
(** LATEX VERSION: Exercise 6: Rational rectangles form a basis generating the standard topology on ℝ². **)
Definition rational_rectangle_basis : set :=
  {r :e Power (setprod R R) |
     exists a b c d:set,
       a :e rational_numbers /\ b :e rational_numbers /\
       c :e rational_numbers /\ d :e rational_numbers /\
       r = setprod (open_interval a b) (open_interval c d)}.

(** helper: open intervals are standard-open when endpoints are real **)
(** LATEX VERSION: Since the standard basis contains all open intervals (a,b) with a,b in R, such intervals are open in the standard topology. **)
Theorem open_interval_in_R_standard_topology_endpoints : forall a b:set,
  a :e R -> b :e R -> open_interval a b :e R_standard_topology.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
claim HbFam : open_interval a b :e {open_interval a b0|b0 :e R}.
{ exact (ReplI R (fun b0:set => open_interval a b0) b HbR). }
claim HbStd : open_interval a b :e R_standard_basis.
{ exact (famunionI R (fun a0:set => {open_interval a0 b0|b0 :e R}) a (open_interval a b) HaR HbFam). }
claim HPow: open_interval a b :e Power R.
{ exact (PowerI R (open_interval a b) (open_interval_Subq_R a b)). }
exact (generated_topology_contains_elem R R_standard_basis (open_interval a b) HPow HbStd).
Qed.

(** helper: rational open intervals are in the rational-interval basis **)
Theorem open_interval_in_rational_open_intervals_basis : forall q1 q2:set,
  q1 :e rational_numbers -> q2 :e rational_numbers ->
  open_interval q1 q2 :e rational_open_intervals_basis.
let q1 q2.
assume Hq1Q: q1 :e rational_numbers.
assume Hq2Q: q2 :e rational_numbers.
claim Hq2fam : open_interval q1 q2 :e {open_interval q1 q2'|q2' :e rational_numbers}.
{ exact (ReplI rational_numbers (fun q2' : set => open_interval q1 q2') q2 Hq2Q). }
exact (famunionI rational_numbers
                 (fun q1' : set => {open_interval q1' q2'|q2' :e rational_numbers})
                 q1
                 (open_interval q1 q2)
                 Hq1Q
                 Hq2fam).
Qed.

(** helper: eliminate membership in rational_open_intervals_basis **)
Theorem rational_open_intervals_basisE : forall b:set,
  b :e rational_open_intervals_basis ->
  exists q1, exists q2, (q1 :e rational_numbers /\ q2 :e rational_numbers /\ b = open_interval q1 q2).
let b. assume Hb: b :e rational_open_intervals_basis.
apply (famunionE_impred rational_numbers
         (fun q1 : set => {open_interval q1 q2|q2 :e rational_numbers})
         b
         Hb
         (exists q1, exists q2, (q1 :e rational_numbers /\ q2 :e rational_numbers /\ b = open_interval q1 q2))).
let q1.
assume Hq1Q: q1 :e rational_numbers.
assume Hbq1: b :e {open_interval q1 q2|q2 :e rational_numbers}.
apply (ReplE_impred rational_numbers (fun q2:set => open_interval q1 q2)
         b Hbq1
         (exists q1, exists q2, (q1 :e rational_numbers /\ q2 :e rational_numbers /\ b = open_interval q1 q2))).
let q2.
assume Hq2Q: q2 :e rational_numbers.
assume Heq: b = open_interval q1 q2.
witness q1.
witness q2.
apply andI.
- apply andI.
  + exact Hq1Q.
  + exact Hq2Q.
- exact Heq.
Qed.

(** helper: rational rectangles are exactly products of rational open intervals **)
(** LATEX VERSION: Rational rectangles (q1,q2)×(r1,r2) form the product basis from the rational-interval basis on each coordinate. **)
Theorem rational_rectangle_basis_eq_product_basis_from :
  rational_rectangle_basis =
    product_basis_from rational_open_intervals_basis rational_open_intervals_basis.
apply set_ext.
- let r. assume Hr: r :e rational_rectangle_basis.
  prove r :e product_basis_from rational_open_intervals_basis rational_open_intervals_basis.
  claim Hex: exists a b c d:set,
    a :e rational_numbers /\ b :e rational_numbers /\
    c :e rational_numbers /\ d :e rational_numbers /\
    r = setprod (open_interval a b) (open_interval c d).
  { exact (SepE2 (Power (setprod R R))
                 (fun r0:set => exists a b c d:set,
                   a :e rational_numbers /\ b :e rational_numbers /\
                   c :e rational_numbers /\ d :e rational_numbers /\
                   r0 = setprod (open_interval a b) (open_interval c d))
                 r
                 Hr). }
  apply Hex.
  let a. assume H1.
  apply H1.
  let b. assume H2.
  apply H2.
  let c. assume H3.
  apply H3.
  let d. assume H4.
  claim Hcore:
    a :e rational_numbers /\ b :e rational_numbers /\
    c :e rational_numbers /\ d :e rational_numbers /\
    r = setprod (open_interval a b) (open_interval c d).
  { exact H4. }
  (** conjunction is left-associative: ((((aQ /\ bQ) /\ cQ) /\ dQ) /\ eq) **)
  claim Hleft : (((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers) /\ d :e rational_numbers)
                /\ r = setprod (open_interval a b) (open_interval c d).
  { exact Hcore. }
  claim Hfour : ((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers) /\ d :e rational_numbers.
  { exact (andEL (((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers) /\ d :e rational_numbers)
                 (r = setprod (open_interval a b) (open_interval c d))
                 Hleft). }
  claim Hreq : r = setprod (open_interval a b) (open_interval c d).
  { exact (andER (((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers) /\ d :e rational_numbers)
                 (r = setprod (open_interval a b) (open_interval c d))
                 Hleft). }
  claim Hthree : (a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers.
  { exact (andEL ((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers)
                 (d :e rational_numbers)
                 Hfour). }
  claim HdQ : d :e rational_numbers.
  { exact (andER ((a :e rational_numbers /\ b :e rational_numbers) /\ c :e rational_numbers)
                 (d :e rational_numbers)
                 Hfour). }
  claim Hab : a :e rational_numbers /\ b :e rational_numbers.
  { exact (andEL (a :e rational_numbers /\ b :e rational_numbers)
                 (c :e rational_numbers)
                 Hthree). }
  claim HcQ : c :e rational_numbers.
  { exact (andER (a :e rational_numbers /\ b :e rational_numbers)
                 (c :e rational_numbers)
                 Hthree). }
  claim HaQ : a :e rational_numbers.
  { exact (andEL (a :e rational_numbers) (b :e rational_numbers) Hab). }
  claim HbQ : b :e rational_numbers.
  { exact (andER (a :e rational_numbers) (b :e rational_numbers) Hab). }
  claim HUinBx: open_interval a b :e rational_open_intervals_basis.
  { exact (open_interval_in_rational_open_intervals_basis a b HaQ HbQ). }
  claim HVinBy: open_interval c d :e rational_open_intervals_basis.
  { exact (open_interval_in_rational_open_intervals_basis c d HcQ HdQ). }
  claim HRepl: setprod (open_interval a b) (open_interval c d)
    :e {setprod (open_interval a b) V | V :e rational_open_intervals_basis}.
  { exact (ReplI rational_open_intervals_basis
                 (fun V:set => setprod (open_interval a b) V)
                 (open_interval c d)
                 HVinBy). }
  rewrite Hreq.
  exact (famunionI rational_open_intervals_basis
                   (fun U:set => {setprod U V | V :e rational_open_intervals_basis})
                   (open_interval a b)
                   (setprod (open_interval a b) (open_interval c d))
                   HUinBx
                   HRepl).
- let r. assume Hr: r :e product_basis_from rational_open_intervals_basis rational_open_intervals_basis.
  prove r :e rational_rectangle_basis.
  claim HexU: exists U :e rational_open_intervals_basis,
    r :e {setprod U V | V :e rational_open_intervals_basis}.
  { exact (famunionE rational_open_intervals_basis
           (fun U:set => {setprod U V | V :e rational_open_intervals_basis})
           r
           Hr). }
  apply HexU.
  let U. assume HUcore.
  claim HU: U :e rational_open_intervals_basis.
  { exact (andEL (U :e rational_open_intervals_basis)
                 (r :e {setprod U V | V :e rational_open_intervals_basis})
                 HUcore). }
  claim HrRepl: r :e {setprod U V | V :e rational_open_intervals_basis}.
  { exact (andER (U :e rational_open_intervals_basis)
                 (r :e {setprod U V | V :e rational_open_intervals_basis})
                 HUcore). }
  claim HexV: exists V :e rational_open_intervals_basis, r = setprod U V.
  { exact (ReplE rational_open_intervals_basis (fun V0:set => setprod U V0) r HrRepl). }
  apply HexV.
  let V. assume HVcore.
	  claim HV: V :e rational_open_intervals_basis.
	  { exact (andEL (V :e rational_open_intervals_basis) (r = setprod U V) HVcore). }
	  claim Hreq: r = setprod U V.
	  { exact (andER (V :e rational_open_intervals_basis) (r = setprod U V) HVcore). }
	  claim HexUab: exists a, exists b, (a :e rational_numbers /\ b :e rational_numbers /\ U = open_interval a b).
	  { exact (rational_open_intervals_basisE U HU). }
	  claim HexVcd: exists c, exists d, (c :e rational_numbers /\ d :e rational_numbers /\ V = open_interval c d).
	  { exact (rational_open_intervals_basisE V HV). }
	  apply HexUab.
	  let a. assume Ha2.
	  apply Ha2.
	  let b. assume Hab.
	  apply HexVcd.
	  let c. assume Hc2.
	  apply Hc2.
	  let d. assume Hcd.
	  claim HabLeft: a :e rational_numbers /\ b :e rational_numbers.
	  { exact (andEL (a :e rational_numbers /\ b :e rational_numbers)
	                 (U = open_interval a b)
	                 Hab). }
	  claim HUeq: U = open_interval a b.
	  { exact (andER (a :e rational_numbers /\ b :e rational_numbers)
	                 (U = open_interval a b)
	                 Hab). }
	  claim HaQ: a :e rational_numbers.
	  { exact (andEL (a :e rational_numbers) (b :e rational_numbers) HabLeft). }
	  claim HbQ: b :e rational_numbers.
	  { exact (andER (a :e rational_numbers) (b :e rational_numbers) HabLeft). }
	  claim HcdLeft: c :e rational_numbers /\ d :e rational_numbers.
	  { exact (andEL (c :e rational_numbers /\ d :e rational_numbers)
	                 (V = open_interval c d)
	                 Hcd). }
	  claim HVeql: V = open_interval c d.
	  { exact (andER (c :e rational_numbers /\ d :e rational_numbers)
	                 (V = open_interval c d)
	                 Hcd). }
	  claim HcQ: c :e rational_numbers.
	  { exact (andEL (c :e rational_numbers) (d :e rational_numbers) HcdLeft). }
	  claim HdQ: d :e rational_numbers.
	  { exact (andER (c :e rational_numbers) (d :e rational_numbers) HcdLeft). }
	  claim HUsubR: U c= R.
	  { rewrite HUeq.
	    exact (open_interval_Subq_R a b). }
  claim HVsubR: V c= R.
  { rewrite HVeql.
    exact (open_interval_Subq_R c d). }
  claim HrectSubRR: setprod U V c= setprod R R.
  { exact (setprod_Subq U V R R HUsubR HVsubR). }
  claim HrectPow: setprod U V :e Power (setprod R R).
  { exact (PowerI (setprod R R) (setprod U V) HrectSubRR). }
	  claim HexDef: exists a0 b0 c0 d0:set,
	    a0 :e rational_numbers /\ b0 :e rational_numbers /\
	    c0 :e rational_numbers /\ d0 :e rational_numbers /\
	    setprod U V = setprod (open_interval a0 b0) (open_interval c0 d0).
	  { witness a. witness b. witness c. witness d.
	    apply andI.
	    - apply andI.
	      + apply andI.
	        * apply andI.
	          { exact HaQ. }
	          { exact HbQ. }
	        * exact HcQ.
	      + exact HdQ.
	    - rewrite HUeq. rewrite HVeql. reflexivity. }
	  rewrite Hreq.
	  exact (SepI (Power (setprod R R))
	              (fun r0:set => exists a0 b0 c0 d0:set,
	                a0 :e rational_numbers /\ b0 :e rational_numbers /\
                c0 :e rational_numbers /\ d0 :e rational_numbers /\
                r0 = setprod (open_interval a0 b0) (open_interval c0 d0))
              (setprod U V)
              HrectPow
              HexDef).
Qed.

Theorem ex16_6_rational_rectangles_basis :
  basis_on (setprod R R) rational_rectangle_basis /\
  generated_topology (setprod R R) rational_rectangle_basis = R2_standard_topology.
set B := rational_open_intervals_basis.
claim HBpkg: basis_on R B /\ generated_topology R B = R_standard_topology.
{ exact ex13_8a_rational_intervals_basis_standard. }
claim HBbasis: basis_on R B.
{ exact (andEL (basis_on R B) (generated_topology R B = R_standard_topology) HBpkg). }
claim HBeq: generated_topology R B = R_standard_topology.
{ exact (andER (basis_on R B) (generated_topology R B = R_standard_topology) HBpkg). }
apply andI.
- rewrite rational_rectangle_basis_eq_product_basis_from.
  exact (product_basis_from_is_basis_on R R B B R_standard_topology R_standard_topology
         HBbasis HBeq HBbasis HBeq).
- (** reduce to product-basis theorem using equality of bases **)
  rewrite rational_rectangle_basis_eq_product_basis_from.
  rewrite R2_standard_equals_product.
  exact (product_basis_generates_product_topology R R B B R_standard_topology R_standard_topology
         HBbasis HBeq HBbasis HBeq).
Qed.

(** from §16 Exercise 7: convex subset implies interval or ray? **) 
(** LATEX VERSION: Exercise 7: Let X be an ordered set. If Y is a proper subset of X that is convex in X, does it follow that Y is an interval or a ray in X. **)
Definition closed_interval_in : set -> set -> set -> set := fun X a b =>
  {x :e X | (x = a \/ order_rel X a x) /\ (x = b \/ order_rel X x b)}.

(** from §16 Exercise 7: half-open intervals in an ordered set **) 
(** LATEX VERSION: [a,b) = {x∈X | a≤x<b}. **)
Definition halfopen_interval_left_in : set -> set -> set -> set := fun X a b =>
  {x :e X | (x = a \/ order_rel X a x) /\ order_rel X x b}.

(** from §16 Exercise 7: half-open intervals in an ordered set **) 
(** LATEX VERSION: (a,b] = {x∈X | a<x≤b}. **)
Definition halfopen_interval_right_in : set -> set -> set -> set := fun X a b =>
  {x :e X | order_rel X a x /\ (x = b \/ order_rel X x b)}.

(** from §16 Exercise 7: rays in ordered sets **)
(** LATEX VERSION: A ray in X is one of the sets (a,∞), [a,∞), (-∞,a), (-∞,a]. **)
Definition closed_ray_upper : set -> set -> set := fun X a =>
  {x :e X | x = a \/ order_rel X a x}.

(** from §16 Exercise 7: rays in ordered sets **)
(** LATEX VERSION: A ray in X is one of the sets (a,∞), [a,∞), (-∞,a), (-∞,a]. **)
Definition closed_ray_lower : set -> set -> set := fun X a =>
  {x :e X | x = a \/ order_rel X x a}.

(** Helper: closed intervals are intersections of closed rays **)
(** LATEX VERSION: In an ordered set, the closed interval [a,b] equals [a,∞) ∩ (-∞,b]. **)
Theorem closed_interval_in_eq_ray_intersection : forall X a b:set,
  closed_interval_in X a b = (closed_ray_upper X a) :/\: (closed_ray_lower X b).
let X a b.
apply set_ext.
- let x. assume Hx: x :e closed_interval_in X a b.
  prove x :e (closed_ray_upper X a) :/\: (closed_ray_lower X b).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
  claim Hcond: (x = a \/ order_rel X a x) /\ (x = b \/ order_rel X x b).
  { exact (SepE2 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
  claim Hleft: x = a \/ order_rel X a x.
  { exact (andEL (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
  claim Hright: x = b \/ order_rel X x b.
  { exact (andER (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
  apply binintersectI.
  * (** x :e closed_ray_upper X a **)
    prove x :e closed_ray_upper X a.
    exact (SepI X (fun x0:set => x0 = a \/ order_rel X a x0) x HxX Hleft).
  * (** x :e closed_ray_lower X b **)
    prove x :e closed_ray_lower X b.
    exact (SepI X (fun x0:set => x0 = b \/ order_rel X x0 b) x HxX Hright).
- let x. assume Hx: x :e (closed_ray_upper X a) :/\: (closed_ray_lower X b).
  prove x :e closed_interval_in X a b.
  claim Hpair: x :e closed_ray_upper X a /\ x :e closed_ray_lower X b.
  { exact (binintersectE (closed_ray_upper X a) (closed_ray_lower X b) x Hx). }
  claim HxUp: x :e closed_ray_upper X a.
  { exact (andEL (x :e closed_ray_upper X a) (x :e closed_ray_lower X b) Hpair). }
  claim HxLow: x :e closed_ray_lower X b.
  { exact (andER (x :e closed_ray_upper X a) (x :e closed_ray_lower X b) Hpair). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => x0 = a \/ order_rel X a x0) x HxUp). }
  claim Hleft: x = a \/ order_rel X a x.
  { exact (SepE2 X (fun x0:set => x0 = a \/ order_rel X a x0) x HxUp). }
  claim Hright: x = b \/ order_rel X x b.
  { exact (SepE2 X (fun x0:set => x0 = b \/ order_rel X x0 b) x HxLow). }
  claim Hdef: closed_interval_in X a b =
    {x0 :e X | (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)}.
  { reflexivity. }
  rewrite Hdef.
  exact (SepI X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b))
              x
              HxX
              (andI (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hleft Hright)).
Qed.

(** from §16 Exercise 7: intervals in ordered sets **)
(** LATEX VERSION: An interval in X is one of (a,b), [a,b), (a,b], [a,b]. **)
Definition interval_in : set -> set -> set -> set -> prop := fun X a b Y =>
  Y = order_interval X a b
  \/ Y = halfopen_interval_left_in X a b
  \/ Y = halfopen_interval_right_in X a b
  \/ Y = closed_interval_in X a b.

(** from §16 Exercise 7: rays in ordered sets **)
(** LATEX VERSION: A ray in X is one of the open or closed upper or lower rays determined by a point a. **)
Definition ray_in : set -> set -> set -> prop := fun X a Y =>
  Y = open_ray_upper X a
  \/ Y = closed_ray_upper X a
  \/ Y = open_ray_lower X a
  \/ Y = closed_ray_lower X a.

(** from §16 Exercise 7: intervals or rays criterion **)
(** LATEX VERSION: The question asks whether every proper convex subset must be an interval or a ray. **)
Definition interval_or_ray_in : set -> set -> prop := fun X Y =>
  (exists a b:set, a :e X /\ b :e X /\ interval_in X a b Y)
  \/ (exists a:set, a :e X /\ ray_in X a Y).

(** Counterexample pattern inside Q: points with q^2 < 2 form a convex set with no endpoint in Q. **)
(** LATEX VERSION: Consider the subset of Q consisting of rationals q such that q^2 < 2; it is convex but not an interval or ray in Q. **)
Definition Q_sqrt2_cut : set := {q :e rational_numbers | mul_SNo q q < 2}.

(** helper for §16 Exercise 7: 2 is a rational number **)
(** LATEX VERSION: The number 2 is rational (2 = 2/1). **)
Theorem two_in_rational_numbers : 2 :e rational_numbers.
prove 2 :e rational.
claim H2omega: 2 :e omega.
{ exact (nat_p_omega 2 nat_2). }
claim H2SNoS: 2 :e SNoS_ omega.
{ exact (omega_SNoS_omega 2 H2omega). }
claim H2real: 2 :e real.
{ exact (SNoS_omega_real 2 H2SNoS). }
claim H2int: 2 :e int.
{ exact (Subq_omega_int 2 H2omega). }
claim H1omega: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H1not0: 1 /:e {0}.
{ assume H1: 1 :e {0}.
  prove False.
  claim Heq: 1 = 0.
  { exact (SingE 0 1 H1). }
  exact (neq_1_0 Heq). }
claim H1nonzero: 1 :e omega :\: {0}.
{ exact (setminusI omega {0} 1 H1omega H1not0). }
claim Hrecip1: recip_SNo 1 = 1.
{ claim H1neq0: 1 <> 0.
  { exact neq_1_0. }
  claim Hinv: mul_SNo 1 (recip_SNo 1) = 1.
  { exact (recip_SNo_invR 1 SNo_1 H1neq0). }
  rewrite <- (mul_SNo_oneL (recip_SNo 1) (SNo_recip_SNo 1 SNo_1)) at 1.
  exact Hinv. }
claim Heq2: 2 = div_SNo 2 1.
{ claim Hdivdef: div_SNo 2 1 = mul_SNo 2 (recip_SNo 1).
  { reflexivity. }
  rewrite Hdivdef.
  rewrite Hrecip1.
  rewrite (mul_SNo_oneR 2 SNo_2).
  reflexivity. }
claim Hex: exists m :e int, exists n :e omega :\: {0}, 2 = div_SNo m n.
{ witness 2.
  apply andI.
  - exact H2int.
  - witness 1.
    apply andI.
    + exact H1nonzero.
    + exact Heq2. }
exact (SepI real (fun x:set => exists m :e int, exists n :e omega :\: {0}, x = div_SNo m n) 2 H2real Hex).
Qed.

(** helper for §16 Exercise 7: 2 is not in the sqrt(2)-cut **)
(** LATEX VERSION: Since 2^2 is not < 2, we have 2 ∉ {q∈Q | q^2 < 2}. **)
Theorem two_not_in_Q_sqrt2_cut : 2 /:e Q_sqrt2_cut.
assume H2: 2 :e Q_sqrt2_cut.
prove False.
claim H2Q: 2 :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q:set => mul_SNo q q < 2) 2 H2). }
claim Hlt: mul_SNo 2 2 < 2.
{ exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) 2 H2). }
claim Hpos2: 0 < 2.
{ exact SNoLt_0_2. }
claim H12: 1 < 2.
{ exact SNoLt_1_2. }
claim H1mul: mul_SNo 1 2 < mul_SNo 2 2.
{ exact (pos_mul_SNo_Lt' 1 2 2 SNo_1 SNo_2 SNo_2 Hpos2 H12). }
claim H2lt22: 2 < mul_SNo 2 2.
{ rewrite <- (mul_SNo_oneL 2 SNo_2) at 1.
  exact H1mul. }
claim H2lt2: 2 < 2.
{ exact (SNoLt_tra 2 (mul_SNo 2 2) 2 SNo_2 (SNo_mul_SNo 2 2 SNo_2 SNo_2) SNo_2 H2lt22 Hlt). }
exact ((SNoLt_irref 2) H2lt2).
Qed.

(** helper for §16 Exercise 7: minus two is not in the sqrt(2)-cut **)
(** LATEX VERSION: Since (-2)^2 is not < 2, we have -2 ∉ {q∈Q | q^2 < 2}. **)
Theorem minus_two_not_in_Q_sqrt2_cut : minus_SNo 2 /:e Q_sqrt2_cut.
assume Hm2: minus_SNo 2 :e Q_sqrt2_cut.
prove False.
claim Hm2lt: mul_SNo (minus_SNo 2) (minus_SNo 2) < 2.
{ exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) (minus_SNo 2) Hm2). }
claim H22lt: mul_SNo 2 2 < 2.
{ prove mul_SNo 2 2 < 2.
  rewrite <- (mul_SNo_minus_minus 2 2 SNo_2 SNo_2) at 1.
  exact Hm2lt. }
claim H2Q: 2 :e rational_numbers.
{ exact two_in_rational_numbers. }
claim H2cut: 2 :e Q_sqrt2_cut.
{ exact (SepI rational_numbers (fun q:set => mul_SNo q q < 2) 2 H2Q H22lt). }
exact (two_not_in_Q_sqrt2_cut H2cut).
Qed.

(** helper for §16 Exercise 7: Q_sqrt2_cut is a proper subset of Q **)
(** LATEX VERSION: The sqrt(2)-cut is not all of Q (for instance 2 is not in it). **)
Theorem Q_sqrt2_cut_neq_Q : Q_sqrt2_cut <> rational_numbers.
assume Heq: Q_sqrt2_cut = rational_numbers.
prove False.
claim H2inQ: 2 :e rational_numbers.
{ exact two_in_rational_numbers. }
claim H2inCut: 2 :e Q_sqrt2_cut.
{ rewrite Heq.
  exact H2inQ. }
exact (two_not_in_Q_sqrt2_cut H2inCut).
Qed.

(** helper for §16 Exercise 7: cut subset property **)
(** LATEX VERSION: The set {q∈Q | q^2<2} is a subset of Q. **)
Theorem Q_sqrt2_cut_sub_Q : Q_sqrt2_cut c= rational_numbers.
let q. assume Hq: q :e Q_sqrt2_cut.
prove q :e rational_numbers.
exact (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq).
Qed.

(** helper for §16 Exercise 7: 0 is in the cut **)
(** LATEX VERSION: Since 0^2<2, we have 0 ∈ {q∈Q | q^2<2}. **)
Theorem zero_in_Q_sqrt2_cut : 0 :e Q_sqrt2_cut.
prove 0 :e Q_sqrt2_cut.
claim H0Q: 0 :e rational_numbers.
{ exact zero_in_rational_numbers. }
claim H00: mul_SNo 0 0 = 0.
{ exact (mul_SNo_zeroL 0 SNo_0). }
claim Hlt: mul_SNo 0 0 < 2.
{ rewrite H00.
  exact SNoLt_0_2. }
exact (SepI rational_numbers (fun q:set => mul_SNo q q < 2) 0 H0Q Hlt).
Qed.

(** helper for §16 Exercise 7: convexity of the sqrt(2) cut in Q **)
(** LATEX VERSION: The set {q∈Q | q^2<2} is convex in Q. **)
(** helper: if x lies strictly between two cut points, then x is in the cut **)
Theorem Q_sqrt2_cut_between_square : forall a b x:set,
  a :e Q_sqrt2_cut ->
  b :e Q_sqrt2_cut ->
  x :e rational_numbers ->
  Rlt a x ->
  Rlt x b ->
  mul_SNo x x < 2.
let a b x.
assume Ha: a :e Q_sqrt2_cut.
assume Hb: b :e Q_sqrt2_cut.
assume HxQ: x :e rational_numbers.
assume Hax: Rlt a x.
assume Hxb: Rlt x b.
claim HaQ: a :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q:set => mul_SNo q q < 2) a Ha). }
claim HbQ: b :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q:set => mul_SNo q q < 2) b Hb). }
claim Haa: mul_SNo a a < 2.
{ exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) a Ha). }
claim Hbb: mul_SNo b b < 2.
{ exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) b Hb). }
claim HaR: a :e R.
{ exact (rational_numbers_in_R a HaQ). }
claim HbR: b :e R.
{ exact (rational_numbers_in_R b HbQ). }
claim HxR: x :e R.
{ exact (rational_numbers_in_R x HxQ). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Haxlt: a < x.
{ exact (RltE_lt a x Hax). }
claim Hxblt: x < b.
{ exact (RltE_lt x b Hxb). }
(** split on the position of x relative to 0 using trichotomy **)
apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (mul_SNo x x < 2)).
- assume Hxlt0: x < 0.
  claim Halt0: a < 0.
  { exact (SNoLt_tra a x 0 HaS HxS SNo_0 Haxlt Hxlt0). }
  claim HnegxS: SNo (minus_SNo x).
  { exact (SNo_minus_SNo x HxS). }
  claim HnegaS: SNo (minus_SNo a).
  { exact (SNo_minus_SNo a HaS). }
  claim Hnegxltnega: minus_SNo x < minus_SNo a.
  { exact (minus_SNo_Lt_contra a x HaS HxS Haxlt). }
  claim H0ltnegx: 0 < minus_SNo x.
  { claim Hm0: minus_SNo 0 < minus_SNo x.
    { exact (minus_SNo_Lt_contra x 0 HxS SNo_0 Hxlt0). }
    rewrite <- (minus_SNo_0) at 1.
    exact Hm0. }
  claim H0ltnega: 0 < minus_SNo a.
  { claim Hm0: minus_SNo 0 < minus_SNo a.
    { exact (minus_SNo_Lt_contra a 0 HaS SNo_0 Halt0). }
    rewrite <- (minus_SNo_0) at 1.
    exact Hm0. }
  claim Hsq: mul_SNo (minus_SNo x) (minus_SNo x) < mul_SNo (minus_SNo a) (minus_SNo a).
  { exact (pos_mul_SNo_Lt2 (minus_SNo x) (minus_SNo x) (minus_SNo a) (minus_SNo a)
            HnegxS HnegxS HnegaS HnegaS
            H0ltnegx H0ltnegx Hnegxltnega Hnegxltnega). }
  claim Hxxlt: mul_SNo x x < mul_SNo a a.
  { prove mul_SNo x x < mul_SNo a a.
    rewrite <- (mul_SNo_minus_minus x x HxS HxS) at 1.
    rewrite <- (mul_SNo_minus_minus a a HaS HaS) at 1.
    exact Hsq. }
  claim HxxS: SNo (mul_SNo x x).
  { exact (SNo_mul_SNo x x HxS HxS). }
  claim HaaS: SNo (mul_SNo a a).
  { exact (SNo_mul_SNo a a HaS HaS). }
  exact (SNoLt_tra (mul_SNo x x) (mul_SNo a a) 2 HxxS HaaS SNo_2 Hxxlt Haa).
- assume Hxeq0: x = 0.
  rewrite Hxeq0.
  rewrite (mul_SNo_zeroL 0 SNo_0).
  exact SNoLt_0_2.
- assume H0ltx: 0 < x.
  claim H0ltb: 0 < b.
  { exact (SNoLt_tra 0 x b SNo_0 HxS HbS H0ltx Hxblt). }
  claim Hsq: mul_SNo x x < mul_SNo b b.
  { exact (pos_mul_SNo_Lt2 x x b b HxS HxS HbS HbS H0ltx H0ltx Hxblt Hxblt). }
  claim HxxS: SNo (mul_SNo x x).
  { exact (SNo_mul_SNo x x HxS HxS). }
  claim HbbS: SNo (mul_SNo b b).
  { exact (SNo_mul_SNo b b HbS HbS). }
  exact (SNoLt_tra (mul_SNo x x) (mul_SNo b b) 2 HxxS HbbS SNo_2 Hsq Hbb).
Qed.

Theorem Q_sqrt2_cut_convex : convex_in rational_numbers Q_sqrt2_cut.
prove convex_in rational_numbers Q_sqrt2_cut.
(** convex_in X Y = Y c= X /\ interval-closure property **)
prove Q_sqrt2_cut c= rational_numbers /\
     forall a b:set, a :e Q_sqrt2_cut -> b :e Q_sqrt2_cut ->
       order_interval rational_numbers a b c= Q_sqrt2_cut.
apply andI.
- exact Q_sqrt2_cut_sub_Q.
- let a b.
  assume Ha: a :e Q_sqrt2_cut.
  assume Hb: b :e Q_sqrt2_cut.
  claim HaQ: a :e rational_numbers.
  { exact (SepE1 rational_numbers (fun q:set => mul_SNo q q < 2) a Ha). }
  claim HbQ: b :e rational_numbers.
  { exact (SepE1 rational_numbers (fun q:set => mul_SNo q q < 2) b Hb). }
  claim Haa: mul_SNo a a < 2.
  { exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) a Ha). }
  claim Hbb: mul_SNo b b < 2.
  { exact (SepE2 rational_numbers (fun q:set => mul_SNo q q < 2) b Hb). }
  prove order_interval rational_numbers a b c= Q_sqrt2_cut.
  let x. assume Hx: x :e order_interval rational_numbers a b.
  prove x :e Q_sqrt2_cut.
  claim HxQ: x :e rational_numbers.
  { exact (SepE1 rational_numbers
                 (fun x0:set => order_rel rational_numbers a x0 /\ order_rel rational_numbers x0 b)
                 x
                 Hx). }
  claim HxRel: order_rel rational_numbers a x /\ order_rel rational_numbers x b.
  { exact (SepE2 rational_numbers
                 (fun x0:set => order_rel rational_numbers a x0 /\ order_rel rational_numbers x0 b)
                 x
                 Hx). }
  claim Hax: order_rel rational_numbers a x.
  { exact (andEL (order_rel rational_numbers a x) (order_rel rational_numbers x b) HxRel). }
  claim Hxb: order_rel rational_numbers x b.
  { exact (andER (order_rel rational_numbers a x) (order_rel rational_numbers x b) HxRel). }
  claim Haxlt: Rlt a x.
  { exact (order_rel_Q_implies_Rlt a x Hax). }
  claim Hxblt: Rlt x b.
  { exact (order_rel_Q_implies_Rlt x b Hxb). }
  claim Hxx: mul_SNo x x < 2.
  { exact (Q_sqrt2_cut_between_square a b x Ha Hb HxQ Haxlt Hxblt). }
  exact (SepI rational_numbers (fun q:set => mul_SNo q q < 2) x HxQ Hxx).
Qed.

(** helper for §16 Exercise 7: the sqrt2 cut has no maximum element in Q **)
(** LATEX VERSION: The cut {q∈Q | q^2<2} has no endpoint in Q. **)
Theorem Q_sqrt2_cut_no_max : forall q:set,
  q :e Q_sqrt2_cut -> exists r:set, r :e Q_sqrt2_cut /\ Rlt q r.
let q. assume Hq: q :e Q_sqrt2_cut.
prove exists r:set, r :e Q_sqrt2_cut /\ Rlt q r.
claim HqQ: q :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq). }
claim HqR: q :e R.
{ exact (rational_numbers_in_R q HqQ). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim Hqq: mul_SNo q q < 2.
{ exact (SepE2 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq). }
(** split on q relative to 0 **)
apply (SNoLt_trichotomy_or_impred q 0 HqS SNo_0 (exists r:set, r :e Q_sqrt2_cut /\ Rlt q r)).
- assume Hqlt0: q < 0.
  witness 0.
  apply andI.
  + exact zero_in_Q_sqrt2_cut.
  + exact (RltI q 0 HqR real_0 Hqlt0).
- assume Hqeq0: q = 0.
  witness 1.
  apply andI.
  + (** 1 is in the cut **)
    claim H1Q: 1 :e rational_numbers.
    { exact one_in_rational_numbers. }
    claim H11: mul_SNo 1 1 < 2.
    { prove mul_SNo 1 1 < 2.
      rewrite (mul_SNo_oneL 1 SNo_1).
      exact SNoLt_1_2. }
    exact (SepI rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) 1 H1Q H11).
  + (** q<1 **)
    claim H1R: 1 :e R.
    { exact (rational_numbers_in_R 1 one_in_rational_numbers). }
    rewrite Hqeq0.
    exact (RltI 0 1 real_0 H1R SNoLt_0_1).
- assume H0ltq: 0 < q.
  (** define sqrt(2) and use density of Q in R **)
  set s2 := sqrt_SNo_nonneg 2.
  claim Hs2Def: s2 = sqrt_SNo_nonneg 2.
  { reflexivity. }
  claim H2R: 2 :e R.
  { exact (rational_numbers_in_R 2 two_in_rational_numbers). }
  claim H0le2: 0 <= 2.
  { exact (SNoLtLe 0 2 SNoLt_0_2). }
  claim Hs2R: s2 :e R.
  { exact (sqrt_SNo_nonneg_real 2 H2R H0le2). }
  claim Hs2S: SNo s2.
  { exact (real_SNo s2 Hs2R). }
  claim Hs2nonneg: 0 <= s2.
  { exact (sqrt_SNo_nonneg_nonneg 2 SNo_2 H0le2). }
  claim Hs2sq: mul_SNo s2 s2 = 2.
  { prove mul_SNo s2 s2 = 2.
    rewrite Hs2Def at 1.
    rewrite Hs2Def at 2.
    exact (sqrt_SNo_nonneg_sqr 2 SNo_2 H0le2). }
  (** show q < s2 (otherwise q^2 >= 2 or q = sqrt(2) irrational) **)
  claim Hqlts2: q < s2.
  { apply (SNoLt_trichotomy_or_impred q s2 HqS Hs2S (q < s2)).
    - assume Hlt: q < s2.
      exact Hlt.
    - assume Heq: q = s2.
      apply FalseE.
      claim Hirr: s2 :e real :\: rational.
      { exact sqrt_2_irrational. }
      claim Hnotrat: s2 /:e rational.
      { exact (setminusE2 real rational s2 Hirr). }
      claim Hs2Q: s2 :e rational_numbers.
      { rewrite <- Heq. exact HqQ. }
      claim HdefQ: rational_numbers = rational.
      { reflexivity. }
      claim Hs2rat: s2 :e rational.
      { rewrite <- HdefQ. exact Hs2Q. }
      exact (Hnotrat Hs2rat).
    - assume Hs2ltq: s2 < q.
      apply FalseE.
      (** get 0 < s2 from 0 <= s2 and s2 <> 0 **)
      claim Hs2neq0: s2 <> 0.
      { assume Hs2eq0: s2 = 0.
        apply neq_2_0.
        rewrite <- Hs2sq.
        rewrite Hs2eq0.
        rewrite (mul_SNo_zeroL 0 SNo_0).
        reflexivity. }
      claim H0lts2: 0 < s2.
      { claim Hdisj: 0 < s2 \/ 0 = s2.
        { exact (SNoLeE 0 s2 SNo_0 Hs2S Hs2nonneg). }
        apply Hdisj.
        - assume Hlt0: 0 < s2.
          exact Hlt0.
	        - assume Heq0: 0 = s2.
	          apply FalseE.
	          claim Hs2eq0: s2 = 0.
	          { rewrite <- Heq0.
	            reflexivity. }
	          exact (Hs2neq0 Hs2eq0). }
      claim HqqS: SNo (mul_SNo q q).
      { exact (SNo_mul_SNo q q HqS HqS). }
      claim Hs2s2S: SNo (mul_SNo s2 s2).
      { exact (SNo_mul_SNo s2 s2 Hs2S Hs2S). }
      claim Hs2s2ltqq: mul_SNo s2 s2 < mul_SNo q q.
      { exact (pos_mul_SNo_Lt2 s2 s2 q q Hs2S Hs2S HqS HqS H0lts2 H0lts2 Hs2ltq Hs2ltq). }
      claim H2ltqq: 2 < mul_SNo q q.
      { rewrite <- Hs2sq at 1.
        exact Hs2s2ltqq. }
      claim H2lt2: 2 < 2.
      { exact (SNoLt_tra 2 (mul_SNo q q) 2 SNo_2 HqqS SNo_2 H2ltqq Hqq). }
      exact ((SNoLt_irref 2) H2lt2). }
  claim Hqs2: Rlt q s2.
  { exact (RltI q s2 HqR Hs2R Hqlts2). }
  apply (rational_dense_between_reals q s2 HqR Hs2R Hqs2).
  let r. assume Hrpair.
  apply Hrpair.
  assume HrQ: r :e rational_numbers.
  assume Hrlt: Rlt q r /\ Rlt r s2.
  claim Hqr: Rlt q r.
  { exact (andEL (Rlt q r) (Rlt r s2) Hrlt). }
  claim Hrs2: Rlt r s2.
  { exact (andER (Rlt q r) (Rlt r s2) Hrlt). }
  (** show r is in the cut using r<s2 and s2^2=2 **)
  claim HrR: r :e R.
  { exact (rational_numbers_in_R r HrQ). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim Hqrrlt: q < r.
  { exact (RltE_lt q r Hqr). }
  claim Hrs2lt: r < s2.
  { exact (RltE_lt r s2 Hrs2). }
  claim H0ltr: 0 < r.
  { exact (SNoLt_tra 0 q r SNo_0 HqS HrS H0ltq Hqrrlt). }
  claim Hrrlt2: mul_SNo r r < 2.
  { prove mul_SNo r r < 2.
	    claim Hrrlts2: mul_SNo r r < mul_SNo s2 s2.
	    { exact (pos_mul_SNo_Lt2 r r s2 s2 HrS HrS Hs2S Hs2S H0ltr H0ltr Hrs2lt Hrs2lt). }
	    rewrite <- Hs2sq.
	    exact Hrrlts2. }
  claim HrCut: r :e Q_sqrt2_cut.
  { exact (SepI rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) r HrQ Hrrlt2). }
  witness r.
  exact (andI (r :e Q_sqrt2_cut) (Rlt q r) HrCut Hqr).
Qed.

(** helper for §16 Exercise 7: the sqrt2 cut is closed under negation **)
(** LATEX VERSION: If q^2<2 then (-q)^2<2, so the cut is symmetric. **)
Theorem Q_sqrt2_cut_neg_closed : forall q:set,
  q :e Q_sqrt2_cut -> minus_SNo q :e Q_sqrt2_cut.
let q. assume Hq: q :e Q_sqrt2_cut.
prove minus_SNo q :e Q_sqrt2_cut.
claim HqQ: q :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq). }
claim Hqq: mul_SNo q q < 2.
{ exact (SepE2 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq). }
claim HqR: q :e R.
{ exact (rational_numbers_in_R q HqQ). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim HnegQ: minus_SNo q :e rational_numbers.
{ exact (rational_minus_SNo q HqQ). }
claim HnegR: minus_SNo q :e R.
{ exact (rational_numbers_in_R (minus_SNo q) HnegQ). }
claim HnegS: SNo (minus_SNo q).
{ exact (real_SNo (minus_SNo q) HnegR). }
claim Hnegneg: mul_SNo (minus_SNo q) (minus_SNo q) < 2.
{ prove mul_SNo (minus_SNo q) (minus_SNo q) < 2.
  rewrite (mul_SNo_minus_minus q q HqS HqS).
  exact Hqq. }
exact (SepI rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) (minus_SNo q) HnegQ Hnegneg).
Qed.

(** helper for §16 Exercise 7: the sqrt2 cut has no minimum element in Q **)
(** LATEX VERSION: The cut {q∈Q | q^2<2} has no endpoint in Q. **)
Theorem Q_sqrt2_cut_no_min : forall q:set,
  q :e Q_sqrt2_cut -> exists r:set, r :e Q_sqrt2_cut /\ Rlt r q.
let q. assume Hq: q :e Q_sqrt2_cut.
prove exists r:set, r :e Q_sqrt2_cut /\ Rlt r q.
claim HnegqCut: minus_SNo q :e Q_sqrt2_cut.
{ exact (Q_sqrt2_cut_neg_closed q Hq). }
apply (Q_sqrt2_cut_no_max (minus_SNo q) HnegqCut).
let r. assume Hrconj.
claim HrCut: r :e Q_sqrt2_cut.
{ exact (andEL (r :e Q_sqrt2_cut) (Rlt (minus_SNo q) r) Hrconj). }
claim Hlt: Rlt (minus_SNo q) r.
{ exact (andER (r :e Q_sqrt2_cut) (Rlt (minus_SNo q) r) Hrconj). }
set s := minus_SNo r.
claim HsCut: s :e Q_sqrt2_cut.
{ exact (Q_sqrt2_cut_neg_closed r HrCut). }
claim HrQ: r :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) r HrCut). }
claim HqQ: q :e rational_numbers.
{ exact (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q Hq). }
claim HrR: r :e R.
{ exact (rational_numbers_in_R r HrQ). }
claim HqR: q :e R.
{ exact (rational_numbers_in_R q HqQ). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HnegqR: minus_SNo q :e R.
{ exact (rational_numbers_in_R (minus_SNo q) (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) (minus_SNo q) HnegqCut)). }
claim HnegqS: SNo (minus_SNo q).
{ exact (real_SNo (minus_SNo q) HnegqR). }
claim HltS: minus_SNo q < r.
{ exact (RltE_lt (minus_SNo q) r Hlt). }
claim Hneglt: minus_SNo r < minus_SNo (minus_SNo q).
{ exact (minus_SNo_Lt_contra (minus_SNo q) r HnegqS HrS HltS). }
claim Hslt: s < q.
{ claim Hinv: minus_SNo (minus_SNo q) = q.
  { exact (minus_SNo_invol q (real_SNo q HqR)). }
  rewrite <- Hinv.
  exact Hneglt. }
claim HsR: s :e R.
{ exact (rational_numbers_in_R s (SepE1 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) s HsCut)). }
claim Hsq: Rlt s q.
{ exact (RltI s q HsR HqR Hslt). }
witness s.
exact (andI (s :e Q_sqrt2_cut) (Rlt s q) HsCut Hsq).
Qed.

(** helper for §16 Exercise 7: the sqrt(2) cut in Q is not an interval or ray (endpoints must lie in Q) **)
(** LATEX VERSION: {q∈Q | q^2<2} is not an interval or ray in Q since it has no endpoint in Q. **)
Theorem Q_sqrt2_cut_not_interval_or_ray :
  ~ interval_or_ray_in rational_numbers Q_sqrt2_cut.
assume H: interval_or_ray_in rational_numbers Q_sqrt2_cut.
prove False.
(** interval_or_ray_in X Y = (exists a b, interval_in ...) \/ (exists a, ray_in ...) **)
apply H.
- assume Hinterval: exists a b:set, a :e rational_numbers /\ b :e rational_numbers /\ interval_in rational_numbers a b Q_sqrt2_cut.
  apply Hinterval.
  let a. assume Hexb.
  apply Hexb.
  let b. assume Hab.
  claim HabQ: a :e rational_numbers /\ b :e rational_numbers.
  { exact (andEL (a :e rational_numbers /\ b :e rational_numbers) (interval_in rational_numbers a b Q_sqrt2_cut) Hab). }
  claim HaQ: a :e rational_numbers.
  { exact (andEL (a :e rational_numbers) (b :e rational_numbers) HabQ). }
  claim HbQ: b :e rational_numbers.
  { exact (andER (a :e rational_numbers) (b :e rational_numbers) HabQ). }
  claim Hint: interval_in rational_numbers a b Q_sqrt2_cut.
  { exact (andER (a :e rational_numbers /\ b :e rational_numbers) (interval_in rational_numbers a b Q_sqrt2_cut) Hab). }
  claim H0cut: 0 :e Q_sqrt2_cut.
  { exact zero_in_Q_sqrt2_cut. }
  apply Hint.
  - assume Hleft3: Q_sqrt2_cut = order_interval rational_numbers a b
                \/ Q_sqrt2_cut = halfopen_interval_left_in rational_numbers a b
                \/ Q_sqrt2_cut = halfopen_interval_right_in rational_numbers a b.
    apply Hleft3.
    + assume Hleft2: Q_sqrt2_cut = order_interval rational_numbers a b
                  \/ Q_sqrt2_cut = halfopen_interval_left_in rational_numbers a b.
      apply Hleft2.
      * assume HeqOI: Q_sqrt2_cut = order_interval rational_numbers a b.
        (** use sqrt(2) to refute existence of rational endpoints a<b with {q∈Q|q^2<2} = (a,b) **)
        claim H0in: 0 :e order_interval rational_numbers a b.
        { rewrite <- HeqOI. exact H0cut. }
        claim H0pred: order_rel rational_numbers a 0 /\ order_rel rational_numbers 0 b.
        { exact (SepE2 rational_numbers
                       (fun x0:set => order_rel rational_numbers a x0 /\ order_rel rational_numbers x0 b)
                       0
                       H0in). }
        claim Ha0: order_rel rational_numbers a 0.
        { exact (andEL (order_rel rational_numbers a 0) (order_rel rational_numbers 0 b) H0pred). }
        claim H0b: order_rel rational_numbers 0 b.
        { exact (andER (order_rel rational_numbers a 0) (order_rel rational_numbers 0 b) H0pred). }
        claim HaR: a :e R.
        { exact (rational_numbers_in_R a HaQ). }
        claim HbR: b :e R.
        { exact (rational_numbers_in_R b HbQ). }
        claim HaS: SNo a.
        { exact (real_SNo a HaR). }
        claim HbS: SNo b.
        { exact (real_SNo b HbR). }
        claim Halt0: Rlt a 0.
        { exact (order_rel_Q_implies_Rlt a 0 Ha0). }
        claim H0blt: Rlt 0 b.
        { exact (order_rel_Q_implies_Rlt 0 b H0b). }
        set s2 := sqrt_SNo_nonneg 2.
        claim H2R: 2 :e R.
        { exact (rational_numbers_in_R 2 two_in_rational_numbers). }
        claim H0le2: 0 <= 2.
        { exact (SNoLtLe 0 2 SNoLt_0_2). }
        claim Hs2R: s2 :e R.
        { exact (sqrt_SNo_nonneg_real 2 H2R H0le2). }
        claim Hs2S: SNo s2.
        { exact (real_SNo s2 Hs2R). }
        claim Hs2nonneg: 0 <= s2.
        { exact (sqrt_SNo_nonneg_nonneg 2 SNo_2 H0le2). }
        claim Hs2sq: mul_SNo s2 s2 = 2.
        { exact (sqrt_SNo_nonneg_sqr 2 SNo_2 H0le2). }
        claim Hs2neq0: s2 <> 0.
        { assume Hs2eq0: s2 = 0.
          apply neq_2_0.
          rewrite <- Hs2sq.
          rewrite Hs2eq0.
          rewrite (mul_SNo_zeroL 0 SNo_0).
          reflexivity. }
        claim H0lts2: 0 < s2.
        { claim Hdisj: 0 < s2 \/ 0 = s2.
          { exact (SNoLeE 0 s2 SNo_0 Hs2S Hs2nonneg). }
          apply Hdisj.
          - assume Hlt0: 0 < s2.
            exact Hlt0.
          - assume Heq0: 0 = s2.
            apply FalseE.
            claim Hs2eq0: s2 = 0.
            { rewrite <- Heq0. reflexivity. }
            exact (Hs2neq0 Hs2eq0). }
        (** compare b to sqrt(2) **)
        apply (SNoLt_trichotomy_or_impred b s2 HbS Hs2S False).
        - assume Hblts2: b < s2.
          claim Hbs2: Rlt b s2.
          { exact (RltI b s2 HbR Hs2R Hblts2). }
          (** choose q with b<q<s2, then q is in the interval so should be in the cut, but q<b from interval membership **)
          apply (rational_dense_between_reals b s2 HbR Hs2R Hbs2).
          let q. assume Hqpair. apply Hqpair.
          assume HqQ: q :e rational_numbers.
          assume HqProp: Rlt b q /\ Rlt q s2.
          claim Hbq: Rlt b q.
          { exact (andEL (Rlt b q) (Rlt q s2) HqProp). }
          claim Hqs2: Rlt q s2.
          { exact (andER (Rlt b q) (Rlt q s2) HqProp). }
          claim HqR: q :e R.
          { exact (rational_numbers_in_R q HqQ). }
          claim HqS: SNo q.
          { exact (real_SNo q HqR). }
          claim H0q: Rlt 0 q.
          { exact (Rlt_tra 0 b q H0blt Hbq). }
          claim H0ltq: 0 < q.
          { exact (RltE_lt 0 q H0q). }
          claim Hqlts2: q < s2.
          { exact (RltE_lt q s2 Hqs2). }
          claim Hqqlt2: mul_SNo q q < 2.
          { claim Hqqs2: mul_SNo q q < mul_SNo s2 s2.
            { exact (pos_mul_SNo_Lt2 q q s2 s2 HqS HqS Hs2S Hs2S H0ltq H0ltq Hqlts2 Hqlts2). }
            rewrite <- Hs2sq.
            exact Hqqs2. }
          claim HqCut: q :e Q_sqrt2_cut.
          { exact (SepI rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q HqQ Hqqlt2). }
          claim HqInI: q :e order_interval rational_numbers a b.
          { rewrite <- HeqOI. exact HqCut. }
          claim HqPred: order_rel rational_numbers a q /\ order_rel rational_numbers q b.
          { exact (SepE2 rational_numbers
                         (fun x0:set => order_rel rational_numbers a x0 /\ order_rel rational_numbers x0 b)
                         q
                         HqInI). }
          claim Hqb: order_rel rational_numbers q b.
          { exact (andER (order_rel rational_numbers a q) (order_rel rational_numbers q b) HqPred). }
          claim Hqblt: Rlt q b.
          { exact (order_rel_Q_implies_Rlt q b Hqb). }
          exact ((not_Rlt_sym b q Hbq) Hqblt).
        - assume Hbeq: b = s2.
          (** b is rational, so sqrt(2) would be rational, contradiction **)
          claim Hirr: s2 :e real :\: rational.
          { exact sqrt_2_irrational. }
          claim Hnotrat: s2 /:e rational.
          { exact (setminusE2 real rational s2 Hirr). }
          claim Hs2Q: s2 :e rational_numbers.
          { rewrite <- Hbeq. exact HbQ. }
          claim HdefQ: rational_numbers = rational.
          { reflexivity. }
          claim Hs2rat: s2 :e rational.
          { rewrite <- HdefQ. exact Hs2Q. }
          exact (Hnotrat Hs2rat).
        - assume Hs2ltb: s2 < b.
          claim Hs2b: Rlt s2 b.
          { exact (RltI s2 b Hs2R HbR Hs2ltb). }
          (** choose q with s2<q<b; q is in the interval so must be in the cut, but then q^2<2 contradicts s2<q **)
          apply (rational_dense_between_reals s2 b Hs2R HbR Hs2b).
          let q. assume Hqpair. apply Hqpair.
          assume HqQ: q :e rational_numbers.
          assume HqProp: Rlt s2 q /\ Rlt q b.
          claim Hs2q: Rlt s2 q.
          { exact (andEL (Rlt s2 q) (Rlt q b) HqProp). }
          claim Hqb: Rlt q b.
          { exact (andER (Rlt s2 q) (Rlt q b) HqProp). }
          claim HqR: q :e R.
          { exact (rational_numbers_in_R q HqQ). }
          claim HqS: SNo q.
          { exact (real_SNo q HqR). }
          claim Hs2ltq: s2 < q.
          { exact (RltE_lt s2 q Hs2q). }
          claim H0ltq: 0 < q.
          { exact (SNoLt_tra 0 s2 q SNo_0 Hs2S HqS H0lts2 Hs2ltq). }
          claim Haq: Rlt a q.
          { claim H0q: Rlt 0 q.
            { exact (RltI 0 q real_0 HqR H0ltq). }
            exact (Rlt_tra a 0 q Halt0 H0q). }
          claim Haqrel: order_rel rational_numbers a q.
          { exact (Rlt_implies_order_rel_Q a q Haq). }
          claim Hqbrep: order_rel rational_numbers q b.
          { exact (Rlt_implies_order_rel_Q q b Hqb). }
          claim HqInI: q :e order_interval rational_numbers a b.
          { exact (SepI rational_numbers
                         (fun x0:set => order_rel rational_numbers a x0 /\ order_rel rational_numbers x0 b)
                         q
                         HqQ
                         (andI (order_rel rational_numbers a q) (order_rel rational_numbers q b) Haqrel Hqbrep)). }
          claim HqCut: q :e Q_sqrt2_cut.
          { rewrite HeqOI. exact HqInI. }
          claim Hqqlt2: mul_SNo q q < 2.
          { exact (SepE2 rational_numbers (fun q0:set => mul_SNo q0 q0 < 2) q HqCut). }
          claim Hs2s2ltqq: mul_SNo s2 s2 < mul_SNo q q.
          { exact (pos_mul_SNo_Lt2 s2 s2 q q Hs2S Hs2S HqS HqS H0lts2 H0lts2 Hs2ltq Hs2ltq). }
          claim H2ltqq: 2 < mul_SNo q q.
          { rewrite <- Hs2sq at 1.
            exact Hs2s2ltqq. }
          claim HqqS: SNo (mul_SNo q q).
          { exact (SNo_mul_SNo q q HqS HqS). }
          claim H2lt2: 2 < 2.
          { exact (SNoLt_tra 2 (mul_SNo q q) 2 SNo_2 HqqS SNo_2 H2ltqq Hqqlt2). }
          exact ((SNoLt_irref 2) H2lt2).
      * assume HeqHL: Q_sqrt2_cut = halfopen_interval_left_in rational_numbers a b.
        (** derive order_rel a b from 0 in the interval **)
        claim H0in: 0 :e halfopen_interval_left_in rational_numbers a b.
        { rewrite <- HeqHL. exact H0cut. }
        claim H0pred: (0 = a \/ order_rel rational_numbers a 0) /\ order_rel rational_numbers 0 b.
        { exact (SepE2 rational_numbers (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ order_rel rational_numbers x0 b) 0 H0in). }
        claim H0ab: 0 = a \/ order_rel rational_numbers a 0.
        { exact (andEL (0 = a \/ order_rel rational_numbers a 0) (order_rel rational_numbers 0 b) H0pred). }
        claim H0b: order_rel rational_numbers 0 b.
        { exact (andER (0 = a \/ order_rel rational_numbers a 0) (order_rel rational_numbers 0 b) H0pred). }
        claim Hab: order_rel rational_numbers a b.
        { apply H0ab.
          - assume H0eq: 0 = a.
            rewrite <- H0eq.
            exact H0b.
          - assume Ha0: order_rel rational_numbers a 0.
            claim Halt0: Rlt a 0.
            { exact (order_rel_Q_implies_Rlt a 0 Ha0). }
            claim H0blt: Rlt 0 b.
            { exact (order_rel_Q_implies_Rlt 0 b H0b). }
            claim Hablt: Rlt a b.
            { exact (Rlt_tra a 0 b Halt0 H0blt). }
            exact (Rlt_implies_order_rel_Q a b Hablt). }
        (** show a is in the cut, then contradict no-minimum by pulling r<a back into the interval **)
        claim HainI: a :e halfopen_interval_left_in rational_numbers a b.
        { claim Heqaa: a = a.
          { reflexivity. }
          claim Hleft: a = a \/ order_rel rational_numbers a a.
          { exact (orIL (a = a) (order_rel rational_numbers a a) Heqaa). }
          exact (SepI rational_numbers
                     (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ order_rel rational_numbers x0 b)
                     a
                     HaQ
                     (andI (a = a \/ order_rel rational_numbers a a)
                           (order_rel rational_numbers a b)
                           Hleft
                           Hab)). }
        claim HainCut: a :e Q_sqrt2_cut.
        { rewrite HeqHL. exact HainI. }
        apply (Q_sqrt2_cut_no_min a HainCut).
        let r. assume Hrconj.
        claim HrCut: r :e Q_sqrt2_cut.
        { exact (andEL (r :e Q_sqrt2_cut) (Rlt r a) Hrconj). }
        claim Hrlt: Rlt r a.
        { exact (andER (r :e Q_sqrt2_cut) (Rlt r a) Hrconj). }
        claim HrInI: r :e halfopen_interval_left_in rational_numbers a b.
        { rewrite <- HeqHL. exact HrCut. }
        claim HrPred: (r = a \/ order_rel rational_numbers a r) /\ order_rel rational_numbers r b.
        { exact (SepE2 rational_numbers
                     (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ order_rel rational_numbers x0 b)
                     r
                     HrInI). }
        claim HrLeft: r = a \/ order_rel rational_numbers a r.
        { exact (andEL (r = a \/ order_rel rational_numbers a r) (order_rel rational_numbers r b) HrPred). }
        apply HrLeft.
	        - assume Hreq: r = a.
	          apply (not_Rlt_refl a (rational_numbers_in_R a HaQ)).
	          rewrite <- Hreq at 1.
	          exact Hrlt.
        - assume Hrel: order_rel rational_numbers a r.
          claim Halt: Rlt a r.
          { exact (order_rel_Q_implies_Rlt a r Hrel). }
          exact ((not_Rlt_sym r a Hrlt) Halt).
    + assume HeqHR: Q_sqrt2_cut = halfopen_interval_right_in rational_numbers a b.
      (** derive order_rel a b from 0 in the interval **)
      claim H0in: 0 :e halfopen_interval_right_in rational_numbers a b.
      { rewrite <- HeqHR. exact H0cut. }
      claim H0pred: order_rel rational_numbers a 0 /\ (0 = b \/ order_rel rational_numbers 0 b).
      { exact (SepE2 rational_numbers (fun x0:set => order_rel rational_numbers a x0 /\ (x0 = b \/ order_rel rational_numbers x0 b)) 0 H0in). }
      claim Ha0: order_rel rational_numbers a 0.
      { exact (andEL (order_rel rational_numbers a 0) (0 = b \/ order_rel rational_numbers 0 b) H0pred). }
      claim H0b: 0 = b \/ order_rel rational_numbers 0 b.
      { exact (andER (order_rel rational_numbers a 0) (0 = b \/ order_rel rational_numbers 0 b) H0pred). }
      claim Hab: order_rel rational_numbers a b.
      { apply H0b.
        - assume H0eq: 0 = b.
          rewrite <- H0eq.
          exact Ha0.
        - assume Hrel: order_rel rational_numbers 0 b.
          claim Halt0: Rlt a 0.
          { exact (order_rel_Q_implies_Rlt a 0 Ha0). }
          claim H0blt: Rlt 0 b.
          { exact (order_rel_Q_implies_Rlt 0 b Hrel). }
          claim Hablt: Rlt a b.
          { exact (Rlt_tra a 0 b Halt0 H0blt). }
          exact (Rlt_implies_order_rel_Q a b Hablt). }
      (** show b is in the cut, then contradict no-maximum by pushing r>b back into the interval **)
      claim HbinI: b :e halfopen_interval_right_in rational_numbers a b.
      { claim Heqbb: b = b.
        { reflexivity. }
        claim Hright: b = b \/ order_rel rational_numbers b b.
        { exact (orIL (b = b) (order_rel rational_numbers b b) Heqbb). }
        exact (SepI rational_numbers
                   (fun x0:set => order_rel rational_numbers a x0 /\ (x0 = b \/ order_rel rational_numbers x0 b))
                   b
                   HbQ
                   (andI (order_rel rational_numbers a b)
                         (b = b \/ order_rel rational_numbers b b)
                         Hab
                         Hright)). }
      claim HbinCut: b :e Q_sqrt2_cut.
      { rewrite HeqHR. exact HbinI. }
      apply (Q_sqrt2_cut_no_max b HbinCut).
      let r. assume Hrconj.
      claim HrCut: r :e Q_sqrt2_cut.
      { exact (andEL (r :e Q_sqrt2_cut) (Rlt b r) Hrconj). }
      claim HbR: Rlt b r.
      { exact (andER (r :e Q_sqrt2_cut) (Rlt b r) Hrconj). }
      claim HrInI: r :e halfopen_interval_right_in rational_numbers a b.
      { rewrite <- HeqHR. exact HrCut. }
      claim HrPred: order_rel rational_numbers a r /\ (r = b \/ order_rel rational_numbers r b).
      { exact (SepE2 rational_numbers (fun x0:set => order_rel rational_numbers a x0 /\ (x0 = b \/ order_rel rational_numbers x0 b)) r HrInI). }
      claim HrRight: r = b \/ order_rel rational_numbers r b.
      { exact (andER (order_rel rational_numbers a r) (r = b \/ order_rel rational_numbers r b) HrPred). }
      apply HrRight.
      - assume Hreq: r = b.
        apply (not_Rlt_refl b (rational_numbers_in_R b HbQ)).
        rewrite <- Hreq at 2.
        exact HbR.
      - assume Hrel: order_rel rational_numbers r b.
        claim Hrltb: Rlt r b.
        { exact (order_rel_Q_implies_Rlt r b Hrel). }
        exact ((not_Rlt_sym b r HbR) Hrltb).
	  - assume HeqCI: Q_sqrt2_cut = closed_interval_in rational_numbers a b.
	    (** derive (b=a \/ a<b) from 0 in the interval **)
	    claim H0in: 0 :e closed_interval_in rational_numbers a b.
	    { rewrite <- HeqCI. exact H0cut. }
	    claim H0pred: (0 = a \/ order_rel rational_numbers a 0) /\ (0 = b \/ order_rel rational_numbers 0 b).
	    { exact (SepE2 rational_numbers
	                   (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ (x0 = b \/ order_rel rational_numbers x0 b))
	                   0
	                   H0in). }
	    claim H0a: 0 = a \/ order_rel rational_numbers a 0.
	    { exact (andEL (0 = a \/ order_rel rational_numbers a 0) (0 = b \/ order_rel rational_numbers 0 b) H0pred). }
	    claim H0b: 0 = b \/ order_rel rational_numbers 0 b.
	    { exact (andER (0 = a \/ order_rel rational_numbers a 0) (0 = b \/ order_rel rational_numbers 0 b) H0pred). }
	    claim Habdisj: b = a \/ order_rel rational_numbers a b.
	    { apply H0a.
	      - assume H0eq: 0 = a.
	        apply H0b.
	        + assume H0eqb: 0 = b.
	          claim Hab: b = a.
	          { rewrite <- H0eq.
	            rewrite <- H0eqb.
	            reflexivity. }
	          exact (orIL (b = a) (order_rel rational_numbers a b) Hab).
	        + assume H0rel: order_rel rational_numbers 0 b.
	          claim H0blt: Rlt 0 b.
	          { exact (order_rel_Q_implies_Rlt 0 b H0rel). }
	          claim Hablt: Rlt a b.
	          { rewrite <- H0eq. exact H0blt. }
	          claim Hab: order_rel rational_numbers a b.
	          { exact (Rlt_implies_order_rel_Q a b Hablt). }
	          exact (orIR (b = a) (order_rel rational_numbers a b) Hab).
	      - assume Ha0: order_rel rational_numbers a 0.
	        claim Halt0: Rlt a 0.
	        { exact (order_rel_Q_implies_Rlt a 0 Ha0). }
	        apply H0b.
	        + assume H0eqb: 0 = b.
	          claim Hablt: Rlt a b.
	          { rewrite <- H0eqb. exact Halt0. }
	          claim Hab: order_rel rational_numbers a b.
	          { exact (Rlt_implies_order_rel_Q a b Hablt). }
	          exact (orIR (b = a) (order_rel rational_numbers a b) Hab).
	        + assume H0rel: order_rel rational_numbers 0 b.
	          claim H0blt: Rlt 0 b.
	          { exact (order_rel_Q_implies_Rlt 0 b H0rel). }
	          claim Hablt: Rlt a b.
	          { exact (Rlt_tra a 0 b Halt0 H0blt). }
	          claim Hab: order_rel rational_numbers a b.
	          { exact (Rlt_implies_order_rel_Q a b Hablt). }
	          exact (orIR (b = a) (order_rel rational_numbers a b) Hab). }
	    (** show b is in the cut, then contradict no-maximum by pushing r>b back into the interval **)
	    claim HbinI: b :e closed_interval_in rational_numbers a b.
	    { claim Heqbb: b = b.
	      { reflexivity. }
	      claim Hright: b = b \/ order_rel rational_numbers b b.
	      { exact (orIL (b = b) (order_rel rational_numbers b b) Heqbb). }
	      exact (SepI rational_numbers
	                 (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ (x0 = b \/ order_rel rational_numbers x0 b))
	                 b
	                 HbQ
	                 (andI (b = a \/ order_rel rational_numbers a b)
	                       (b = b \/ order_rel rational_numbers b b)
	                       Habdisj
	                       Hright)). }
	    claim HbinCut: b :e Q_sqrt2_cut.
	    { rewrite HeqCI. exact HbinI. }
	    apply (Q_sqrt2_cut_no_max b HbinCut).
	    let r. assume Hrconj.
	    claim HrCut: r :e Q_sqrt2_cut.
	    { exact (andEL (r :e Q_sqrt2_cut) (Rlt b r) Hrconj). }
	    claim HbR: Rlt b r.
	    { exact (andER (r :e Q_sqrt2_cut) (Rlt b r) Hrconj). }
	    claim HrInI: r :e closed_interval_in rational_numbers a b.
	    { rewrite <- HeqCI. exact HrCut. }
	    claim HrPred: (r = a \/ order_rel rational_numbers a r) /\ (r = b \/ order_rel rational_numbers r b).
	    { exact (SepE2 rational_numbers
	                   (fun x0:set => (x0 = a \/ order_rel rational_numbers a x0) /\ (x0 = b \/ order_rel rational_numbers x0 b))
	                   r
	                   HrInI). }
	    claim HrRight: r = b \/ order_rel rational_numbers r b.
	    { exact (andER (r = a \/ order_rel rational_numbers a r) (r = b \/ order_rel rational_numbers r b) HrPred). }
	    apply HrRight.
	    - assume Hreq: r = b.
	      apply (not_Rlt_refl b (rational_numbers_in_R b HbQ)).
	      rewrite <- Hreq at 2.
	      exact HbR.
	    - assume Hrel: order_rel rational_numbers r b.
	      claim Hrltb: Rlt r b.
	      { exact (order_rel_Q_implies_Rlt r b Hrel). }
	      exact ((not_Rlt_sym b r HbR) Hrltb).
- assume Hray: exists a:set, a :e rational_numbers /\ ray_in rational_numbers a Q_sqrt2_cut.
  apply Hray.
  let a. assume Hpair.
  claim HaQ: a :e rational_numbers.
  { exact (andEL (a :e rational_numbers) (ray_in rational_numbers a Q_sqrt2_cut) Hpair). }
  claim Hrayin: ray_in rational_numbers a Q_sqrt2_cut.
  { exact (andER (a :e rational_numbers) (ray_in rational_numbers a Q_sqrt2_cut) Hpair). }
  claim H0cut: 0 :e Q_sqrt2_cut.
  { exact zero_in_Q_sqrt2_cut. }
  claim H2Q: 2 :e rational_numbers.
  { exact two_in_rational_numbers. }
  claim Hm2Q: minus_SNo 2 :e rational_numbers.
  { exact (rational_minus_SNo 2 H2Q). }
  claim Hm2lt0: minus_SNo 2 < 0.
  { prove minus_SNo 2 < 0.
    rewrite <- (minus_SNo_0) at 2.
    exact (minus_SNo_Lt_contra 0 2 SNo_0 SNo_2 SNoLt_0_2). }
  (** eliminate the four ray forms using 0 in the cut and +-2 outside the cut **)
  apply Hrayin.
  - assume Hleft: Q_sqrt2_cut = open_ray_upper rational_numbers a
                \/ Q_sqrt2_cut = closed_ray_upper rational_numbers a
                \/ Q_sqrt2_cut = open_ray_lower rational_numbers a.
    apply Hleft.
    + assume Hup: Q_sqrt2_cut = open_ray_upper rational_numbers a
                \/ Q_sqrt2_cut = closed_ray_upper rational_numbers a.
      apply Hup.
      * assume HeqU: Q_sqrt2_cut = open_ray_upper rational_numbers a.
        claim H0in: 0 :e open_ray_upper rational_numbers a.
        { rewrite <- HeqU. exact H0cut. }
        claim Hrel: order_rel rational_numbers a 0.
        { exact (SepE2 rational_numbers (fun x0:set => order_rel rational_numbers a x0) 0 H0in). }
        claim Ha0: Rlt a 0.
        { exact (order_rel_Q_implies_Rlt a 0 Hrel). }
        claim H02: Rlt 0 2.
        { exact (RltI 0 2 real_0 (rational_numbers_in_R 2 H2Q) SNoLt_0_2). }
        claim Ha2: Rlt a 2.
        { exact (Rlt_tra a 0 2 Ha0 H02). }
        claim Hrel2: order_rel rational_numbers a 2.
        { exact (Rlt_implies_order_rel_Q a 2 Ha2). }
        claim H2in: 2 :e open_ray_upper rational_numbers a.
        { exact (SepI rational_numbers (fun x0:set => order_rel rational_numbers a x0) 2 H2Q Hrel2). }
        claim H2cut: 2 :e Q_sqrt2_cut.
        { rewrite HeqU. exact H2in. }
        exact (two_not_in_Q_sqrt2_cut H2cut).
      * assume HeqU: Q_sqrt2_cut = closed_ray_upper rational_numbers a.
        claim H0in: 0 :e closed_ray_upper rational_numbers a.
        { rewrite <- HeqU. exact H0cut. }
        claim Hrel0: 0 = a \/ order_rel rational_numbers a 0.
        { exact (SepE2 rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers a x0) 0 H0in). }
        apply Hrel0.
        - assume H0eq: 0 = a.
           claim H02: Rlt 0 2.
           { exact (RltI 0 2 real_0 (rational_numbers_in_R 2 H2Q) SNoLt_0_2). }
           claim Ha2: Rlt a 2.
           { rewrite <- H0eq. exact H02. }
           claim Hrel2: order_rel rational_numbers a 2.
           { exact (Rlt_implies_order_rel_Q a 2 Ha2). }
           claim H2in: 2 :e closed_ray_upper rational_numbers a.
           { exact (SepI rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers a x0) 2 H2Q (orIR (2 = a) (order_rel rational_numbers a 2) Hrel2)). }
           claim H2cut: 2 :e Q_sqrt2_cut.
           { rewrite HeqU. exact H2in. }
           exact (two_not_in_Q_sqrt2_cut H2cut).
        - assume Hrel: order_rel rational_numbers a 0.
           claim Ha0: Rlt a 0.
           { exact (order_rel_Q_implies_Rlt a 0 Hrel). }
           claim H02: Rlt 0 2.
           { exact (RltI 0 2 real_0 (rational_numbers_in_R 2 H2Q) SNoLt_0_2). }
           claim Ha2: Rlt a 2.
           { exact (Rlt_tra a 0 2 Ha0 H02). }
           claim Hrel2: order_rel rational_numbers a 2.
           { exact (Rlt_implies_order_rel_Q a 2 Ha2). }
           claim H2in: 2 :e closed_ray_upper rational_numbers a.
           { exact (SepI rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers a x0) 2 H2Q (orIR (2 = a) (order_rel rational_numbers a 2) Hrel2)). }
           claim H2cut: 2 :e Q_sqrt2_cut.
           { rewrite HeqU. exact H2in. }
           exact (two_not_in_Q_sqrt2_cut H2cut).
    + assume HeqL: Q_sqrt2_cut = open_ray_lower rational_numbers a.
      claim H0in: 0 :e open_ray_lower rational_numbers a.
      { rewrite <- HeqL. exact H0cut. }
      claim Hrel0: order_rel rational_numbers 0 a.
      { exact (SepE2 rational_numbers (fun x0:set => order_rel rational_numbers x0 a) 0 H0in). }
      claim H0a: Rlt 0 a.
      { exact (order_rel_Q_implies_Rlt 0 a Hrel0). }
      claim Hm20: Rlt (minus_SNo 2) 0.
      { exact (RltI (minus_SNo 2) 0 (rational_numbers_in_R (minus_SNo 2) Hm2Q) real_0 Hm2lt0). }
      claim Hm2a: Rlt (minus_SNo 2) a.
      { exact (Rlt_tra (minus_SNo 2) 0 a Hm20 H0a). }
      claim Hrelm2: order_rel rational_numbers (minus_SNo 2) a.
      { exact (Rlt_implies_order_rel_Q (minus_SNo 2) a Hm2a). }
      claim Hm2in: minus_SNo 2 :e open_ray_lower rational_numbers a.
      { exact (SepI rational_numbers (fun x0:set => order_rel rational_numbers x0 a) (minus_SNo 2) Hm2Q Hrelm2). }
      claim Hm2cut: minus_SNo 2 :e Q_sqrt2_cut.
      { rewrite HeqL. exact Hm2in. }
      exact (minus_two_not_in_Q_sqrt2_cut Hm2cut).
  - assume HeqL: Q_sqrt2_cut = closed_ray_lower rational_numbers a.
    claim H0in: 0 :e closed_ray_lower rational_numbers a.
    { rewrite <- HeqL. exact H0cut. }
    claim Hrel0: 0 = a \/ order_rel rational_numbers 0 a.
    { exact (SepE2 rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers x0 a) 0 H0in). }
    apply Hrel0.
    + assume H0eq: 0 = a.
      claim Hm20: Rlt (minus_SNo 2) 0.
      { exact (RltI (minus_SNo 2) 0 (rational_numbers_in_R (minus_SNo 2) Hm2Q) real_0 Hm2lt0). }
      claim Hm2a: Rlt (minus_SNo 2) a.
      { rewrite <- H0eq. exact Hm20. }
      claim Hrelm2: order_rel rational_numbers (minus_SNo 2) a.
      { exact (Rlt_implies_order_rel_Q (minus_SNo 2) a Hm2a). }
      claim Hm2in: minus_SNo 2 :e closed_ray_lower rational_numbers a.
      { exact (SepI rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers x0 a) (minus_SNo 2) Hm2Q
                (orIR ((minus_SNo 2) = a) (order_rel rational_numbers (minus_SNo 2) a) Hrelm2)). }
      claim Hm2cut: minus_SNo 2 :e Q_sqrt2_cut.
      { rewrite HeqL. exact Hm2in. }
      exact (minus_two_not_in_Q_sqrt2_cut Hm2cut).
    + assume Hrel: order_rel rational_numbers 0 a.
      claim H0a: Rlt 0 a.
      { exact (order_rel_Q_implies_Rlt 0 a Hrel). }
      claim Hm20: Rlt (minus_SNo 2) 0.
      { exact (RltI (minus_SNo 2) 0 (rational_numbers_in_R (minus_SNo 2) Hm2Q) real_0 Hm2lt0). }
      claim Hm2a: Rlt (minus_SNo 2) a.
      { exact (Rlt_tra (minus_SNo 2) 0 a Hm20 H0a). }
      claim Hrelm2: order_rel rational_numbers (minus_SNo 2) a.
      { exact (Rlt_implies_order_rel_Q (minus_SNo 2) a Hm2a). }
      claim Hm2in: minus_SNo 2 :e closed_ray_lower rational_numbers a.
      { exact (SepI rational_numbers (fun x0:set => x0 = a \/ order_rel rational_numbers x0 a) (minus_SNo 2) Hm2Q
                (orIR ((minus_SNo 2) = a) (order_rel rational_numbers (minus_SNo 2) a) Hrelm2)). }
      claim Hm2cut: minus_SNo 2 :e Q_sqrt2_cut.
      { rewrite HeqL. exact Hm2in. }
      exact (minus_two_not_in_Q_sqrt2_cut Hm2cut).
Qed.

Theorem ex16_7_convex_interval_or_ray :
  exists X Y:set, convex_in X Y /\ Y <> X /\ ~ interval_or_ray_in X Y.
prove exists X Y:set, convex_in X Y /\ Y <> X /\ ~ interval_or_ray_in X Y.
witness rational_numbers.
witness Q_sqrt2_cut.
prove convex_in rational_numbers Q_sqrt2_cut /\ Q_sqrt2_cut <> rational_numbers /\ ~ interval_or_ray_in rational_numbers Q_sqrt2_cut.
apply andI.
  - apply andI.
    + exact Q_sqrt2_cut_convex.
    + exact Q_sqrt2_cut_neq_Q.
  - exact Q_sqrt2_cut_not_interval_or_ray.
Qed.

(** from §16 Exercise 8: lines as subspaces of lower limit products **)
(** LATEX VERSION: Exercise 8: If L is a straight line in the plane, describe the topology L inherits as a subspace of R_l×R and as a subspace of R_l×R_l. In each case it is a familiar topology. **)
(** NOTE: Formal statement currently deferred to Theorem ex16_8_lines_in_lower_limit_products, placed after Definition homeomorphism. **)

(** Helper: singleton rectangles in the dictionary order topology **)
Theorem singleton_rectangle_in_dictionary : forall a V:set,
  a :e R ->
  V :e R_standard_topology ->
  rectangle_set {a} V :e R2_dictionary_order_topology.
let a V.
assume HaR: a :e R.
assume HV: V :e R_standard_topology.
(** Use that V is a union of rational open intervals. **)
set X0 := setprod R R.
set T := R2_dictionary_order_topology.
claim HT: topology_on X0 T.
{ exact dictionary_order_topology_is_topology. }
set Bq := rational_open_intervals_basis.
claim HBq: basis_on R Bq.
{ exact (andEL (basis_on R Bq) (generated_topology R Bq = R_standard_topology)
               ex13_8a_rational_intervals_basis_standard). }
claim HeqStd: generated_topology R Bq = R_standard_topology.
{ exact (andER (basis_on R Bq) (generated_topology R Bq = R_standard_topology)
               ex13_8a_rational_intervals_basis_standard). }
claim HVgen: V :e generated_topology R Bq.
{ rewrite HeqStd.
  exact HV. }
claim HTgen: topology_on R (generated_topology R Bq).
{ exact (lemma_topology_from_basis R Bq HBq). }
claim HVopen: open_in R (generated_topology R Bq) V.
{ exact (andI (topology_on R (generated_topology R Bq)) (V :e generated_topology R Bq) HTgen HVgen). }
claim HexFam: exists Fam :e Power Bq, Union Fam = V.
{ exact (open_sets_as_unions_of_basis R Bq HBq V HVopen). }
apply HexFam.
let Fam. assume HFcore. apply HFcore.
assume HFamPow: Fam :e Power Bq.
assume HUnionEq: Union Fam = V.
set Fam2 := {rectangle_set {a} I|I :e Fam}.
claim HFam2Sub: Fam2 c= T.
{ let W. assume HW: W :e Fam2.
  apply (ReplE_impred Fam (fun I:set => rectangle_set {a} I) W HW (W :e T)).
  let I. assume HIinFam Heq.
  rewrite Heq.
  claim HFamSubBq: Fam c= Bq.
  { exact (PowerE Bq Fam HFamPow). }
  claim HIbq: I :e Bq.
  { exact (HFamSubBq I HIinFam). }
  (** Reduce to a rational open interval basis element. **)
  apply (famunionE_impred rational_numbers
    (fun q1:set => {open_interval q1 q2|q2 :e rational_numbers})
    I
    HIbq
    (rectangle_set {a} I :e T)).
  let q1. assume Hq1Q HIq1.
  apply (ReplE_impred rational_numbers (fun q2:set => open_interval q1 q2) I HIq1 (rectangle_set {a} I :e T)).
  let q2. assume Hq2Q HIeq.
  rewrite HIeq.
  (** Show {a}×(q1,q2) is an intersection of two subbasis rays in X0. **)
  set pL := (a, q1).
  set pU := (a, q2).
  claim Hq1R: q1 :e R.
  { exact (rational_numbers_in_R q1 Hq1Q). }
  claim Hq2R: q2 :e R.
  { exact (rational_numbers_in_R q2 Hq2Q). }
  claim HpLX0: pL :e X0.
  { exact (tuple_2_setprod_by_pair_Sigma R R a q1 HaR Hq1R). }
  claim HpUX0: pU :e X0.
  { exact (tuple_2_setprod_by_pair_Sigma R R a q2 HaR Hq2R). }
  set U1 := open_ray_upper X0 pL.
  set U2 := open_ray_lower X0 pU.
  claim HS: subbasis_on X0 (open_rays_subbasis X0).
  { exact (open_rays_subbasis_is_subbasis X0). }
  claim HU1S: U1 :e open_rays_subbasis X0.
  { exact (open_ray_upper_in_open_rays_subbasis X0 pL HpLX0). }
  claim HU2S: U2 :e open_rays_subbasis X0.
  { exact (open_ray_lower_in_open_rays_subbasis X0 pU HpUX0). }
  claim HdefT: T = generated_topology_from_subbasis X0 (open_rays_subbasis X0).
  { reflexivity. }
  claim HdefT2: generated_topology_from_subbasis X0 (open_rays_subbasis X0)
    = generated_topology X0 (basis_of_subbasis X0 (open_rays_subbasis X0)).
  { reflexivity. }
  claim HBsub: basis_on X0 (basis_of_subbasis X0 (open_rays_subbasis X0)).
  { exact (finite_intersections_basis_of_subbasis X0 (open_rays_subbasis X0) HS). }
  claim HU1T: U1 :e T.
  { apply (xm (U1 = Empty)).
    - assume HU1Empty.
      rewrite HU1Empty.
      exact (topology_has_empty X0 T HT).
    - assume HU1ne: U1 <> Empty.
      claim HU1B: U1 :e basis_of_subbasis X0 (open_rays_subbasis X0).
      { claim HU1F: U1 :e finite_intersections_of X0 (open_rays_subbasis X0).
        { (** witness {U1} as a finite subcollection **)
          claim HU1subX0: U1 c= X0.
          { let x. assume Hx: x :e U1.
            exact (SepE1 X0 (fun y:set => order_rel X0 pL y) x Hx). }
          claim Hintsing: intersection_of_family X0 {U1} = U1.
          { exact (intersection_of_family_singleton_eq X0 U1 HU1subX0). }
          claim HFsub: {U1} :e finite_subcollections (open_rays_subbasis X0).
          { claim HFpow: {U1} :e Power (open_rays_subbasis X0).
            { apply PowerI.
              let s. assume Hs: s :e {U1}.
              claim Hseq: s = U1.
              { exact (SingE U1 s Hs). }
              rewrite Hseq.
              exact HU1S. }
            claim HFfin: finite {U1}.
            { exact (Sing_finite U1). }
            exact (SepI (Power (open_rays_subbasis X0)) (fun F0:set => finite F0) {U1} HFpow HFfin). }
          claim Hintsing_in: intersection_of_family X0 {U1}
            :e finite_intersections_of X0 (open_rays_subbasis X0).
          { exact (ReplI (finite_subcollections (open_rays_subbasis X0))
                    (fun F0 : set => intersection_of_family X0 F0)
                    {U1}
                    HFsub). }
          rewrite <- Hintsing.
          exact Hintsing_in. }
        exact (SepI (finite_intersections_of X0 (open_rays_subbasis X0))
               (fun b0:set => b0 <> Empty)
               U1
               HU1F
               HU1ne). }
      rewrite HdefT.
      rewrite HdefT2.
      exact (generated_topology_contains_basis X0 (basis_of_subbasis X0 (open_rays_subbasis X0)) HBsub U1 HU1B). }
  claim HU2T: U2 :e T.
  { apply (xm (U2 = Empty)).
    - assume HU2Empty.
      rewrite HU2Empty.
      exact (topology_has_empty X0 T HT).
    - assume HU2ne: U2 <> Empty.
      claim HU2B: U2 :e basis_of_subbasis X0 (open_rays_subbasis X0).
      { claim HU2F: U2 :e finite_intersections_of X0 (open_rays_subbasis X0).
        { claim HU2subX0: U2 c= X0.
          { let x. assume Hx: x :e U2.
            exact (SepE1 X0 (fun y:set => order_rel X0 y pU) x Hx). }
          claim Hintsing: intersection_of_family X0 {U2} = U2.
          { exact (intersection_of_family_singleton_eq X0 U2 HU2subX0). }
          claim HFsub: {U2} :e finite_subcollections (open_rays_subbasis X0).
          { claim HFpow: {U2} :e Power (open_rays_subbasis X0).
            { apply PowerI.
              let s. assume Hs: s :e {U2}.
              claim Hseq: s = U2.
              { exact (SingE U2 s Hs). }
              rewrite Hseq.
              exact HU2S. }
            claim HFfin: finite {U2}.
            { exact (Sing_finite U2). }
            exact (SepI (Power (open_rays_subbasis X0)) (fun F0:set => finite F0) {U2} HFpow HFfin). }
          claim Hintsing_in: intersection_of_family X0 {U2}
            :e finite_intersections_of X0 (open_rays_subbasis X0).
          { exact (ReplI (finite_subcollections (open_rays_subbasis X0))
                    (fun F0 : set => intersection_of_family X0 F0)
                    {U2}
                    HFsub). }
          rewrite <- Hintsing.
          exact Hintsing_in. }
        exact (SepI (finite_intersections_of X0 (open_rays_subbasis X0))
               (fun b0:set => b0 <> Empty)
               U2
               HU2F
               HU2ne). }
      rewrite HdefT.
      rewrite HdefT2.
      exact (generated_topology_contains_basis X0 (basis_of_subbasis X0 (open_rays_subbasis X0)) HBsub U2 HU2B). }
  claim Hinter: U1 :/\: U2 :e T.
  { exact (topology_binintersect_closed X0 T U1 U2 HT HU1T HU2T). }
  claim HeqRect: rectangle_set {a} (open_interval q1 q2) = U1 :/\: U2.
  { apply set_ext.
	    - let p. assume Hp: p :e rectangle_set {a} (open_interval q1 q2).
	      prove p :e U1 :/\: U2.
	      claim HpS: p :e setprod {a} (open_interval q1 q2).
	      { rewrite <- rectangle_set_def. exact Hp. }
	      claim Hp0Sing: p 0 :e {a}.
	      { exact (ap0_Sigma {a} (fun _ : set => open_interval q1 q2) p HpS). }
	      claim Hp0eq: p 0 = a.
	      { exact (SingE a (p 0) Hp0Sing). }
	      claim Hp1Int: p 1 :e open_interval q1 q2.
	      { exact (ap1_Sigma {a} (fun _ : set => open_interval q1 q2) p HpS). }
      claim Hp1R: p 1 :e R.
      { exact (SepE1 R (fun z:set => Rlt q1 z /\ Rlt z q2) (p 1) Hp1Int). }
      claim Hp1ineq: Rlt q1 (p 1) /\ Rlt (p 1) q2.
      { exact (SepE2 R (fun z:set => Rlt q1 z /\ Rlt z q2) (p 1) Hp1Int). }
      claim HltL: Rlt q1 (p 1).
      { exact (andEL (Rlt q1 (p 1)) (Rlt (p 1) q2) Hp1ineq). }
      claim HltU: Rlt (p 1) q2.
      { exact (andER (Rlt q1 (p 1)) (Rlt (p 1) q2) Hp1ineq). }
      claim HsingSub: {a} c= R.
      { exact (singleton_subset a R HaR). }
      claim HintSub: open_interval q1 q2 c= R.
      { let y. assume Hy: y :e open_interval q1 q2.
        exact (SepE1 R (fun z:set => Rlt q1 z /\ Rlt z q2) y Hy). }
      claim HpX0: p :e X0.
      { exact ((setprod_Subq {a} (open_interval q1 q2) R R HsingSub HintSub) p Hp). }
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta R R p HpX0). }
      claim HrelU1: order_rel X0 pL (p 0, p 1).
      { claim Hcore: a = p 0 /\ Rlt q1 (p 1).
        { apply andI.
          - rewrite <- Hp0eq.
            reflexivity.
          - exact HltL. }
        exact (order_rel_setprod_R_R_intro a q1 (p 0) (p 1)
                (orIR (Rlt a (p 0)) (a = (p 0) /\ Rlt q1 (p 1)) Hcore)). }
      claim HrelU2: order_rel X0 (p 0, p 1) pU.
      { claim Hcore: (p 0) = a /\ Rlt (p 1) q2.
        { apply andI.
          - rewrite Hp0eq.
            reflexivity.
          - exact HltU. }
        exact (order_rel_setprod_R_R_intro (p 0) (p 1) a q2
                (orIR (Rlt (p 0) a) ((p 0) = a /\ Rlt (p 1) q2) Hcore)). }
      claim HpX0pair: (p 0, p 1) :e X0.
      { rewrite <- HpEta.
        exact HpX0. }
      apply binintersectI.
      + rewrite HpEta.
        exact (SepI X0 (fun x0:set => order_rel X0 pL x0) (p 0, p 1) HpX0pair HrelU1).
      + rewrite HpEta.
        exact (SepI X0 (fun x0:set => order_rel X0 x0 pU) (p 0, p 1) HpX0pair HrelU2).
    - let p. assume Hp: p :e U1 :/\: U2.
      prove p :e rectangle_set {a} (open_interval q1 q2).
      claim HpU1: p :e U1.
      { exact (binintersectE1 U1 U2 p Hp). }
      claim HpU2: p :e U2.
      { exact (binintersectE2 U1 U2 p Hp). }
      claim HpX0: p :e X0.
      { exact (SepE1 X0 (fun x0:set => order_rel X0 pL x0) p HpU1). }
      set p0 := p 0.
      set p1 := p 1.
      claim HpEta: p = (p0, p1).
      { exact (setprod_eta R R p HpX0). }
      claim Hrel1: order_rel X0 pL p.
      { exact (SepE2 X0 (fun x0:set => order_rel X0 pL x0) p HpU1). }
      claim Hrel2: order_rel X0 p pU.
      { exact (SepE2 X0 (fun x0:set => order_rel X0 x0 pU) p HpU2). }
      claim Hrel1': order_rel X0 pL (p0, p1).
      { rewrite <- HpEta at 1.
        exact Hrel1. }
      claim Hrel2': order_rel X0 (p0, p1) pU.
      { rewrite <- HpEta at 1.
        exact Hrel2. }
      claim Hex1: exists a1 a2 b1 b2:set,
        pL = (a1, a2) /\ (p0, p1) = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
      { exact (order_rel_setprod_R_R_unfold pL (p0, p1) Hrel1'). }
      claim Hex2: exists a1 a2 b1 b2:set,
        (p0, p1) = (a1, a2) /\ pU = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
      { exact (order_rel_setprod_R_R_unfold (p0, p1) pU Hrel2'). }
      apply Hex1.
      let a1. assume Hc1. apply Hc1.
      let a2. assume Hc2. apply Hc2.
      let b1. assume Hd1. apply Hd1.
      let b2. assume Hpack1.
      claim Heq1: pL = (a1, a2) /\ (p0, p1) = (b1, b2).
      { exact (andEL (pL = (a1, a2) /\ (p0, p1) = (b1, b2))
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
                     Hpack1). }
      claim Hdisj1: Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2).
      { exact (andER (pL = (a1, a2) /\ (p0, p1) = (b1, b2))
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
                     Hpack1). }
      claim HpLeq: pL = (a1, a2).
      { exact (andEL (pL = (a1, a2)) ((p0, p1) = (b1, b2)) Heq1). }
      claim HppEq: (p0, p1) = (b1, b2).
      { exact (andER (pL = (a1, a2)) ((p0, p1) = (b1, b2)) Heq1). }
      claim Ha1eq: a1 = a.
      { claim Ha1eq0: a = a1.
        { rewrite <- (tuple_2_0_eq a q1).
          rewrite <- (tuple_2_0_eq a1 a2).
          rewrite <- HpLeq.
          reflexivity. }
        rewrite Ha1eq0.
        reflexivity. }
      claim Ha2eq: a2 = q1.
      { claim Ha2eq0: q1 = a2.
        { rewrite <- (tuple_2_1_eq a q1).
          rewrite <- (tuple_2_1_eq a1 a2).
          rewrite <- HpLeq.
          reflexivity. }
        rewrite Ha2eq0.
        reflexivity. }
      claim Hb1eq: b1 = p0.
      { claim Hb1eq0: p0 = b1.
        { rewrite <- (tuple_2_0_eq p0 p1).
          rewrite <- (tuple_2_0_eq b1 b2).
          rewrite HppEq.
          reflexivity. }
        rewrite Hb1eq0.
        reflexivity. }
      claim Hb2eq: b2 = p1.
      { claim Hb2eq0: p1 = b2.
        { rewrite <- (tuple_2_1_eq p0 p1).
          rewrite <- (tuple_2_1_eq b1 b2).
          rewrite HppEq.
          reflexivity. }
        rewrite Hb2eq0.
        reflexivity. }
      claim Hcases1: Rlt a p0 \/ (a = p0 /\ Rlt q1 p1).
      { apply Hdisj1.
        - assume Hlt.
          apply orIL.
          rewrite <- Ha1eq at 1.
          rewrite <- Hb1eq at 1.
          exact Hlt.
        - assume Hcore.
          apply orIR.
          apply andI.
          + rewrite <- Ha1eq at 1.
            rewrite <- Hb1eq at 1.
            exact (andEL (a1 = b1) (Rlt a2 b2) Hcore).
          + rewrite <- Ha2eq at 1.
            rewrite <- Hb2eq at 1.
            exact (andER (a1 = b1) (Rlt a2 b2) Hcore). }
      (** Now unfold the second inequality and extract p0 = a and p1 < q2. **)
      apply Hex2.
      let c1. assume Hc1'. apply Hc1'.
      let c2. assume Hc2'. apply Hc2'.
      let d1. assume Hd1'. apply Hd1'.
      let d2. assume Hpack2.
      claim Heq2: (p0, p1) = (c1, c2) /\ pU = (d1, d2).
      { exact (andEL ((p0, p1) = (c1, c2) /\ pU = (d1, d2))
                     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                     Hpack2). }
      claim Hdisj2: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
      { exact (andER ((p0, p1) = (c1, c2) /\ pU = (d1, d2))
                     (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                     Hpack2). }
      claim HpcEq: (p0, p1) = (c1, c2).
      { exact (andEL ((p0, p1) = (c1, c2)) (pU = (d1, d2)) Heq2). }
      claim HpUeq: pU = (d1, d2).
      { exact (andER ((p0, p1) = (c1, c2)) (pU = (d1, d2)) Heq2). }
      claim Hc1eq: c1 = p0.
      { claim Hc1eq0: p0 = c1.
        { rewrite <- (tuple_2_0_eq p0 p1).
          rewrite <- (tuple_2_0_eq c1 c2).
          rewrite HpcEq.
          reflexivity. }
        rewrite Hc1eq0.
        reflexivity. }
      claim Hc2eq: c2 = p1.
      { claim Hc2eq0: p1 = c2.
        { rewrite <- (tuple_2_1_eq p0 p1).
          rewrite <- (tuple_2_1_eq c1 c2).
          rewrite HpcEq.
          reflexivity. }
        rewrite Hc2eq0.
        reflexivity. }
      claim Hd1eq: d1 = a.
      { claim Hd1eq0: a = d1.
        { rewrite <- (tuple_2_0_eq a q2).
          rewrite <- (tuple_2_0_eq d1 d2).
          rewrite <- HpUeq.
          reflexivity. }
        rewrite Hd1eq0.
        reflexivity. }
      claim Hd2eq: d2 = q2.
      { claim Hd2eq0: q2 = d2.
        { rewrite <- (tuple_2_1_eq a q2).
          rewrite <- (tuple_2_1_eq d1 d2).
          rewrite <- HpUeq.
          reflexivity. }
        rewrite Hd2eq0.
        reflexivity. }
      claim Hcases2: Rlt p0 a \/ (p0 = a /\ Rlt p1 q2).
      { apply Hdisj2.
        - assume Hlt.
          apply orIL.
          rewrite <- Hc1eq at 1.
          rewrite <- Hd1eq at 1.
          exact Hlt.
        - assume Hcore.
          apply orIR.
          apply andI.
          + rewrite <- Hc1eq at 1.
            rewrite <- Hd1eq at 1.
            exact (andEL (c1 = d1) (Rlt c2 d2) Hcore).
          + rewrite <- Hc2eq at 1.
            rewrite <- Hd2eq at 1.
            exact (andER (c1 = d1) (Rlt c2 d2) Hcore). }
      (** Derive p0 = a and the two inequalities q1 < p1 and p1 < q2. **)
      claim Hp0eq: p0 = a.
      { apply Hcases1.
        - assume Hltap0.
          apply FalseE.
          apply Hcases2.
          + assume Hltp0a.
            exact (not_Rlt_sym a p0 Hltap0 Hltp0a).
          + assume Hcore.
            claim Hp0a: p0 = a.
            { exact (andEL (p0 = a) (Rlt p1 q2) Hcore). }
            claim HltAA: Rlt a a.
            { rewrite <- Hp0a at 2.
              exact Hltap0. }
            exact (not_Rlt_refl a HaR HltAA).
	        - assume Hcore.
	          claim Haeqp0: a = p0.
	          { exact (andEL (a = p0) (Rlt q1 p1) Hcore). }
	          symmetry.
	          exact Haeqp0. }
      claim Hltq1: Rlt q1 p1.
      { apply Hcases1.
        - assume Hltap0.
          apply FalseE.
          apply Hcases2.
          + assume Hltp0a.
            exact (not_Rlt_sym a p0 Hltap0 Hltp0a).
          + assume Hcore.
            claim Hp0a: p0 = a.
            { exact (andEL (p0 = a) (Rlt p1 q2) Hcore). }
            claim HltAA: Rlt a a.
            { rewrite <- Hp0a at 2.
              exact Hltap0. }
            exact (not_Rlt_refl a HaR HltAA).
        - assume Hcore.
          exact (andER (a = p0) (Rlt q1 p1) Hcore). }
      claim Hltq2: Rlt p1 q2.
      { apply Hcases2.
	        - assume Hltp0a.
	          apply FalseE.
	          claim HltAA: Rlt a a.
	          { rewrite <- Hp0eq at 1.
	            exact Hltp0a. }
	          exact (not_Rlt_refl a HaR HltAA).
        - assume Hcore.
          exact (andER (p0 = a) (Rlt p1 q2) Hcore). }
      (** Conclude membership in {a}×(q1,q2). **)
      rewrite rectangle_set_def.
      claim Hp0Sing: p0 :e {a}.
      { rewrite <- Hp0eq.
        exact (SingI p0). }
      claim Hp1Int: p1 :e open_interval q1 q2.
      { claim Hconj: Rlt q1 p1 /\ Rlt p1 q2.
        { apply andI.
          - exact Hltq1.
          - exact Hltq2. }
        exact (SepI R (fun z:set => Rlt q1 z /\ Rlt z q2) p1 (ap1_Sigma R (fun _ : set => R) p HpX0) Hconj). }
      rewrite HpEta.
      exact (tuple_2_setprod_by_pair_Sigma {a} (open_interval q1 q2) p0 p1 Hp0Sing Hp1Int). }
  rewrite HeqRect.
  exact Hinter. }
claim HUnionInT: Union Fam2 :e T.
{ exact (topology_union_closed X0 T Fam2 HT HFam2Sub). }
claim HUnionEq2: Union Fam2 = rectangle_set {a} V.
{ apply set_ext.
  - let p. assume Hp: p :e Union Fam2.
    apply (UnionE_impred Fam2 p Hp (p :e rectangle_set {a} V)).
    let W. assume HpW HW.
	    apply (ReplE_impred Fam (fun I:set => rectangle_set {a} I) W HW (p :e rectangle_set {a} V)).
	    let I. assume HIinFam Heq.
	    claim HpWI: p :e rectangle_set {a} I.
	    { rewrite <- Heq.
	      exact HpW. }
	    claim HpWI_S: p :e setprod {a} I.
	    { rewrite <- rectangle_set_def.
	      exact HpWI. }
	    claim Hp0Sing: p 0 :e {a}.
	    { exact (ap0_Sigma {a} (fun _ : set => I) p HpWI_S). }
	    claim Hp1I: p 1 :e I.
	    { exact (ap1_Sigma {a} (fun _ : set => I) p HpWI_S). }
    claim HFamSubBq: Fam c= Bq.
    { exact (PowerE Bq Fam HFamPow). }
    claim HIbq: I :e Bq.
    { exact (HFamSubBq I HIinFam). }
    claim Ipowsub: I c= R.
    { (** each basis element lies in R by construction **)
      apply (famunionE_impred rational_numbers
        (fun q1:set => {open_interval q1 q2|q2 :e rational_numbers})
        I
        HIbq
        (I c= R)).
      let q1. assume Hq1Q HIq1.
      apply (ReplE_impred rational_numbers (fun q2:set => open_interval q1 q2) I HIq1 (I c= R)).
      let q2. assume Hq2Q HeqI.
      rewrite HeqI.
      let y. assume Hy: y :e open_interval q1 q2.
      exact (SepE1 R (fun z:set => Rlt q1 z /\ Rlt z q2) y Hy). }
    claim Hp1V: p 1 :e V.
    { rewrite <- HUnionEq.
      exact (UnionI Fam (p 1) I Hp1I HIinFam). }
    rewrite rectangle_set_def.
    claim HpVsetprod: p :e setprod {a} V.
    { claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta {a} I p HpWI). }
      rewrite HpEta at 1.
      exact (tuple_2_setprod_by_pair_Sigma {a} V (p 0) (p 1) Hp0Sing Hp1V). }
    exact HpVsetprod.
	  - let p. assume Hp: p :e rectangle_set {a} V.
	    prove p :e Union Fam2.
	    (** choose I with p1 :e I from Union Fam = V, then use UnionI **)
	    claim HpS: p :e setprod {a} V.
	    { rewrite <- rectangle_set_def.
	      exact Hp. }
	    claim Hp0Sing: p 0 :e {a}.
	    { exact (ap0_Sigma {a} (fun _ : set => V) p HpS). }
	    claim Hp1V: p 1 :e V.
	    { exact (ap1_Sigma {a} (fun _ : set => V) p HpS). }
	    claim Hp1Union: p 1 :e Union Fam.
	    { rewrite HUnionEq.
	      exact Hp1V. }
	    apply (UnionE_impred Fam (p 1) Hp1Union (p :e Union Fam2)).
    let I. assume Hp1I HIinFam.
    set W := rectangle_set {a} I.
    claim HW: W :e Fam2.
    { exact (ReplI Fam (fun J:set => rectangle_set {a} J) I HIinFam). }
    claim HpW: p :e W.
    { rewrite rectangle_set_def.
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta {a} V p Hp). }
      rewrite HpEta at 1.
      exact (tuple_2_setprod_by_pair_Sigma {a} I (p 0) (p 1) Hp0Sing Hp1I). }
    exact (UnionI Fam2 p W HpW HW). }
rewrite <- HUnionEq2.
exact HUnionInT.
Qed.

(** Helper: general rectangles are unions of singleton rectangles **)
Theorem rectangle_in_dictionary : forall U V:set,
  U :e discrete_topology R ->
  V :e R_standard_topology ->
  rectangle_set U V :e R2_dictionary_order_topology.
let U V.
assume HU: U :e discrete_topology R.
assume HV: V :e R_standard_topology.
set X0 := setprod R R.
set T := R2_dictionary_order_topology.
claim HT: topology_on X0 T.
{ exact dictionary_order_topology_is_topology. }
claim HUPow: U :e Power R.
{ claim HdefDisc: discrete_topology R = Power R.
  { reflexivity. }
  rewrite HdefDisc.
  exact HU. }
claim HUsub: U c= R.
{ exact (PowerE R U HUPow). }
set Fam := {rectangle_set {a} V|a :e U}.
claim HFamSub: Fam c= T.
{ let W. assume HW: W :e Fam.
  apply (ReplE_impred U (fun a:set => rectangle_set {a} V) W HW (W :e T)).
  let a. assume HaU Heq.
  rewrite Heq.
  claim HaR: a :e R.
  { exact (HUsub a HaU). }
  exact (singleton_rectangle_in_dictionary a V HaR HV). }
claim HUnionInT: Union Fam :e T.
{ exact (topology_union_closed X0 T Fam HT HFamSub). }
claim HUnionEq: Union Fam = rectangle_set U V.
  { apply set_ext.
  - let p. assume Hp: p :e Union Fam.
    apply (UnionE_impred Fam p Hp (p :e rectangle_set U V)).
    let W. assume HpW HW.
    apply (ReplE_impred U (fun a:set => rectangle_set {a} V) W HW (p :e rectangle_set U V)).
    let a. assume HaU Heq.
    claim HpWrect: p :e rectangle_set {a} V.
    { rewrite <- Heq.
      exact HpW. }
    claim HpWsetprod: p :e setprod {a} V.
    { rewrite rectangle_set_def.
      exact HpWrect. }
    claim Hp0: p 0 :e {a}.
    { exact (ap0_Sigma {a} (fun _ : set => V) p HpWsetprod). }
    claim Hpa: p 0 = a.
    { exact (SingE a (p 0) Hp0). }
    prove p :e rectangle_set U V.
    rewrite rectangle_set_def.
    claim Hp1: p 1 :e V.
    { exact (ap1_Sigma {a} (fun _ : set => V) p HpWsetprod). }
    claim Hp0U: p 0 :e U.
    { rewrite Hpa.
      exact HaU. }
    claim HpEta: p = (p 0, p 1).
    { exact (setprod_eta {a} V p HpWsetprod). }
    rewrite HpEta.
    exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1).
		  - let p. assume Hp: p :e rectangle_set U V.
		    prove p :e Union Fam.
		    claim HpUV: p :e setprod U V.
		    { rewrite rectangle_set_def.
		      exact Hp. }
		    set a := p 0.
		    claim Hp0U: p 0 :e U.
		    { exact (ap0_Sigma U (fun _ : set => V) p HpUV). }
		    claim Hp1V: p 1 :e V.
		    { exact (ap1_Sigma U (fun _ : set => V) p HpUV). }
		    claim HpEta0: p = (p 0, p 1).
		    { exact (setprod_eta U V p HpUV). }
		    set W := rectangle_set {a} V.
		    claim HWFam: W :e Fam.
		    { exact (ReplI U (fun x:set => rectangle_set {x} V) a Hp0U). }
		    claim HpW: p :e W.
		    { rewrite rectangle_set_def.
		      rewrite HpEta0 at 1.
		      claim Hp0Sing: p 0 :e {a}.
		      { claim Hadef: a = p 0.
		        { reflexivity. }
		        rewrite Hadef.
		        exact (SingI (p 0)). }
		      exact (tuple_2_setprod_by_pair_Sigma {a} V (p 0) (p 1) Hp0Sing Hp1V). }
		    exact (UnionI Fam p W HpW HWFam). }
rewrite <- HUnionEq.
exact HUnionInT.
Qed.

(** Helper: singleton is not open in the standard topology on R **)
Theorem singleton_not_open_R_standard_topology : forall a:set,
  a :e R ->
  {a} /:e R_standard_topology.
let a. assume HaR.
prove {a} /:e R_standard_topology.
assume Hsing: {a} :e R_standard_topology.
prove False.
set Bq := rational_open_intervals_basis.
claim HBq: basis_on R Bq.
{ exact (andEL (basis_on R Bq) (generated_topology R Bq = R_standard_topology)
               ex13_8a_rational_intervals_basis_standard). }
claim HeqStd: generated_topology R Bq = R_standard_topology.
{ exact (andER (basis_on R Bq) (generated_topology R Bq = R_standard_topology)
               ex13_8a_rational_intervals_basis_standard). }
claim HsingGen: {a} :e generated_topology R Bq.
{ rewrite HeqStd.
  exact Hsing. }
claim HTgen: topology_on R (generated_topology R Bq).
{ exact (lemma_topology_from_basis R Bq HBq). }
claim Hopen: open_in R (generated_topology R Bq) {a}.
{ exact (andI (topology_on R (generated_topology R Bq)) ({a} :e generated_topology R Bq) HTgen HsingGen). }
claim HexFam: exists Fam :e Power Bq, Union Fam = {a}.
{ exact (open_sets_as_unions_of_basis R Bq HBq {a} Hopen). }
apply HexFam.
let Fam. assume HFcore. apply HFcore.
assume HFamPow: Fam :e Power Bq.
assume HUnionEq: Union Fam = {a}.
claim HaUnion: a :e Union Fam.
{ rewrite HUnionEq.
  exact (SingI a). }
apply (UnionE_impred Fam a HaUnion False).
let I. assume HaI HIinFam.
claim HIbq: I :e Bq.
{ exact (PowerE Bq Fam HFamPow I HIinFam). }
apply (famunionE_impred rational_numbers
       (fun q1:set => {open_interval q1 q2|q2 :e rational_numbers})
       I
       HIbq
       False).
let q1. assume Hq1Q HIq1.
apply (ReplE_impred rational_numbers (fun q2:set => open_interval q1 q2) I HIq1 False).
let q2. assume Hq2Q HIeq.
claim HaInt: a :e open_interval q1 q2.
{ rewrite <- HIeq.
  exact HaI. }
claim Hq1a: Rlt q1 a.
{ exact (andEL (Rlt q1 a) (Rlt a q2)
        (SepE2 R (fun z:set => Rlt q1 z /\ Rlt z q2) a HaInt)). }
claim Haq2: Rlt a q2.
{ exact (andER (Rlt q1 a) (Rlt a q2)
        (SepE2 R (fun z:set => Rlt q1 z /\ Rlt z q2) a HaInt)). }
claim Hq1R: q1 :e R.
{ exact (rational_numbers_in_R q1 Hq1Q). }
claim Hq2R: q2 :e R.
{ exact (rational_numbers_in_R q2 Hq2Q). }
claim Hexq: exists q :e rational_numbers, Rlt q1 q /\ Rlt q a.
{ exact (rational_dense_between_reals q1 a Hq1R HaR Hq1a). }
apply Hexq.
let q. assume Hqcore. apply Hqcore.
assume HqQ Hqineq.
claim Hq1q: Rlt q1 q.
{ exact (andEL (Rlt q1 q) (Rlt q a) Hqineq). }
claim Hqqa: Rlt q a.
{ exact (andER (Rlt q1 q) (Rlt q a) Hqineq). }
claim HqR: q :e R.
{ exact (rational_numbers_in_R q HqQ). }
claim Hqq2: Rlt q q2.
{ exact (Rlt_tra q a q2 Hqqa Haq2). }
claim HqInt: q :e open_interval q1 q2.
{ exact (SepI R (fun z:set => Rlt q1 z /\ Rlt z q2) q HqR
         (andI (Rlt q1 q) (Rlt q q2) Hq1q Hqq2)). }
claim HqI: q :e I.
{ rewrite HIeq.
  exact HqInt. }
claim HqUnion: q :e Union Fam.
{ exact (UnionI Fam q I HqI HIinFam). }
claim HqSing: q :e {a}.
{ rewrite <- HUnionEq.
  exact HqUnion. }
claim Hqeq: q = a.
{ exact (SingE a q HqSing). }
claim HltAA: Rlt a a.
{ rewrite <- Hqeq at 1.
  exact Hqqa. }
exact (not_Rlt_refl a HaR HltAA).
Qed.

(** from §16 Exercise 9: dictionary order topology on ℝ×ℝ equals ℝ_d × ℝ **) 
(** LATEX VERSION: Exercise 9: The dictionary order topology on ℝ×ℝ is the same as the product topology ℝ_d×ℝ; compare it with the standard topology. **)
Theorem ex16_9_dictionary_equals_product :
  R2_dictionary_order_topology = product_topology R (discrete_topology R) R R_standard_topology
  /\ R2_dictionary_order_topology <> R2_standard_topology.
prove R2_dictionary_order_topology = product_topology R (discrete_topology R) R R_standard_topology /\ R2_dictionary_order_topology <> R2_standard_topology.
apply andI.
- (** equality of the two topologies (skeleton) **)
  claim Heq: R2_dictionary_order_topology = product_topology R (discrete_topology R) R R_standard_topology.
  { apply set_ext.
    - let U. assume HU: U :e R2_dictionary_order_topology.
      prove U :e product_topology R (discrete_topology R) R R_standard_topology.
      set X0 := setprod R R.
      set S := open_rays_subbasis X0.
      set Tprod := product_topology R (discrete_topology R) R R_standard_topology.
      claim HS: subbasis_on X0 S.
      { exact (open_rays_subbasis_is_subbasis X0). }
      claim HTx: topology_on R (discrete_topology R).
      { exact (discrete_topology_on R). }
      claim HTy: topology_on R R_standard_topology.
      { exact R_standard_topology_is_topology_local. }
      claim HTprod: topology_on X0 Tprod.
      { exact (product_topology_is_topology R (discrete_topology R) R R_standard_topology HTx HTy). }
      claim HSsub: S c= Tprod.
      { let I. assume HI: I :e S.
        prove I :e Tprod.
        apply (binunionE' ({I0 :e Power X0 | exists a :e X0, I0 = open_ray_upper X0 a}
                           :\/:
                           {I0 :e Power X0 | exists b :e X0, I0 = open_ray_lower X0 b})
                          {X0}
                          I
                          (I :e Tprod)).
        - assume HI0: I :e ({I0 :e Power X0 | exists a :e X0, I0 = open_ray_upper X0 a}
                            :\/:
                            {I0 :e Power X0 | exists b :e X0, I0 = open_ray_lower X0 b}).
          apply (binunionE' {I0 :e Power X0 | exists a :e X0, I0 = open_ray_upper X0 a}
                            {I0 :e Power X0 | exists b :e X0, I0 = open_ray_lower X0 b}
                            I
                            (I :e Tprod)).
          + assume HIup: I :e {I0 :e Power X0 | exists a :e X0, I0 = open_ray_upper X0 a}.
            claim Hex: exists a :e X0, I = open_ray_upper X0 a.
            { exact (SepE2 (Power X0) (fun I0 : set => exists a :e X0, I0 = open_ray_upper X0 a) I HIup). }
            apply Hex.
            let a. assume Hacore. apply Hacore.
            assume HaX0: a :e X0.
            assume HIeq: I = open_ray_upper X0 a.
            rewrite HIeq.
            (** express the open upper ray as union of two product-basis rectangles **)
            set a1 := a 0.
            set a2 := a 1.
            claim Ha1R: a1 :e R.
            { exact (ap0_Sigma R (fun _ : set => R) a HaX0). }
            claim Ha2R: a2 :e R.
            { exact (ap1_Sigma R (fun _ : set => R) a HaX0). }
            claim HaEta: a = (a1, a2).
            { exact (setprod_eta R R a HaX0). }
            set U0 := open_ray_upper R a1.
            set V0 := open_ray_upper R a2.
            set Rrect := rectangle_set U0 R.
            set Vrect := rectangle_set {a1} V0.
            claim HU0inTx: U0 :e discrete_topology R.
            { claim HdefDisc: discrete_topology R = Power R.
              { reflexivity. }
              rewrite HdefDisc.
              prove U0 :e Power R.
              apply PowerI.
              let x. assume HxU0: x :e U0.
              exact (SepE1 R (fun x0 : set => order_rel R a1 x0) x HxU0). }
            claim HRinTy: R :e R_standard_topology.
            { exact (topology_has_X R R_standard_topology HTy). }
            claim HV0inTy: V0 :e R_standard_topology.
            { rewrite <- standard_topology_is_order_topology.
              claim HsRay: V0 :e open_rays_subbasis R.
              { exact (open_ray_upper_in_open_rays_subbasis R a2 Ha2R). }
              exact (open_rays_subbasis_sub_order_topology_R V0 HsRay). }
            claim Hsing: {a1} :e discrete_topology R.
            { claim HdefDisc: discrete_topology R = Power R.
              { reflexivity. }
              rewrite HdefDisc.
              apply PowerI.
              exact (singleton_subset a1 R Ha1R). }
            claim Hb1: Rrect :e product_subbasis R (discrete_topology R) R R_standard_topology.
            { claim HdefPS:
                product_subbasis R (discrete_topology R) R R_standard_topology
                = (\/_ U :e (discrete_topology R), {rectangle_set U V|V :e R_standard_topology}).
              { reflexivity. }
              rewrite HdefPS.
              apply (famunionI (discrete_topology R)
                (fun U:set => {rectangle_set U V|V :e R_standard_topology})
                U0 Rrect HU0inTx).
              prove Rrect :e {rectangle_set U0 V|V :e R_standard_topology}.
              exact (ReplI R_standard_topology (fun V:set => rectangle_set U0 V) R HRinTy). }
            claim Hb2: Vrect :e product_subbasis R (discrete_topology R) R R_standard_topology.
            { claim HdefPS:
                product_subbasis R (discrete_topology R) R R_standard_topology
                = (\/_ U :e (discrete_topology R), {rectangle_set U V|V :e R_standard_topology}).
              { reflexivity. }
              rewrite HdefPS.
              apply (famunionI (discrete_topology R)
                (fun U:set => {rectangle_set U V|V :e R_standard_topology})
                {a1} Vrect Hsing).
              prove Vrect :e {rectangle_set {a1} V|V :e R_standard_topology}.
              exact (ReplI R_standard_topology (fun V:set => rectangle_set {a1} V) V0 HV0inTy). }
            claim Hbasis: basis_on X0 (product_subbasis R (discrete_topology R) R R_standard_topology).
            { exact (product_subbasis_is_basis R (discrete_topology R) R R_standard_topology HTx HTy). }
            claim Hb1open: Rrect :e Tprod.
            { exact (generated_topology_contains_basis X0
                (product_subbasis R (discrete_topology R) R R_standard_topology)
                Hbasis Rrect Hb1). }
            claim Hb2open: Vrect :e Tprod.
            { exact (generated_topology_contains_basis X0
                (product_subbasis R (discrete_topology R) R R_standard_topology)
                Hbasis Vrect Hb2). }
            claim Hop: open_ray_upper X0 a = Rrect :\/: Vrect.
            { apply set_ext.
              - let p. assume Hp: p :e open_ray_upper X0 a.
                claim HpX0: p :e X0.
                { exact (SepE1 X0 (fun x0:set => order_rel X0 a x0) p Hp). }
                set p1 := p 0.
                set p2 := p 1.
                claim Hp1R: p1 :e R.
                { exact (ap0_Sigma R (fun _ : set => R) p HpX0). }
                claim Hp2R: p2 :e R.
                { exact (ap1_Sigma R (fun _ : set => R) p HpX0). }
                claim HpEta: p = (p1, p2).
                { exact (setprod_eta R R p HpX0). }
                claim Hrel: order_rel X0 a p.
                { exact (SepE2 X0 (fun x0:set => order_rel X0 a x0) p Hp). }
                claim Hunf: Rlt a1 p1 \/ (a1 = p1 /\ Rlt a2 p2).
                { claim Hrel': order_rel X0 (a1, a2) (p1, p2).
                  { rewrite <- HaEta at 1.
                    rewrite <- HpEta at 1.
                    exact Hrel. }
                  apply (order_rel_setprod_R_R_unfold (a1, a2) (p1, p2) Hrel').
                  let c1. assume Hc1rest. apply Hc1rest.
                  let c2. assume Hc2rest. apply Hc2rest.
                  let d1. assume Hd1rest. apply Hd1rest.
                  let d2. assume Hpack:
                    ((a1, a2) = (c1, c2) /\ (p1, p2) = (d1, d2)) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
                  claim Heqs: (a1, a2) = (c1, c2) /\ (p1, p2) = (d1, d2).
                  { exact (andEL ((a1, a2) = (c1, c2) /\ (p1, p2) = (d1, d2))
                                 (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                                 Hpack). }
                  claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
                  { exact (andER ((a1, a2) = (c1, c2) /\ (p1, p2) = (d1, d2))
                                 (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                                 Hpack). }
                  claim HacEq: (a1, a2) = (c1, c2).
                  { exact (andEL ((a1, a2) = (c1, c2)) ((p1, p2) = (d1, d2)) Heqs). }
                  claim HpdEq: (p1, p2) = (d1, d2).
                  { exact (andER ((a1, a2) = (c1, c2)) ((p1, p2) = (d1, d2)) Heqs). }
                  claim Hc1eq: c1 = a1.
                  { claim Ha1eq: a1 = c1.
                    { rewrite <- (tuple_2_0_eq a1 a2).
                      rewrite <- (tuple_2_0_eq c1 c2).
                      rewrite HacEq.
                      reflexivity. }
                    prove c1 = a1.
                    rewrite Ha1eq.
                    reflexivity. }
                  claim Hc2eq: c2 = a2.
                  { claim Ha2eq: a2 = c2.
                    { rewrite <- (tuple_2_1_eq a1 a2).
                      rewrite <- (tuple_2_1_eq c1 c2).
                      rewrite HacEq.
                      reflexivity. }
                    prove c2 = a2.
                    rewrite Ha2eq.
                    reflexivity. }
                  claim Hd1eq: d1 = p1.
                  { claim Hp1eq: p1 = d1.
                    { rewrite <- (tuple_2_0_eq p1 p2).
                      rewrite <- (tuple_2_0_eq d1 d2).
                      rewrite HpdEq.
                      reflexivity. }
                    prove d1 = p1.
                    rewrite Hp1eq.
                    reflexivity. }
                  claim Hd2eq: d2 = p2.
                  { claim Hp2eq: p2 = d2.
                    { rewrite <- (tuple_2_1_eq p1 p2).
                      rewrite <- (tuple_2_1_eq d1 d2).
                      rewrite HpdEq.
                      reflexivity. }
                    prove d2 = p2.
                    rewrite Hp2eq.
                    reflexivity. }
                  apply Hdisj.
                  - assume Hlt: Rlt c1 d1.
                    apply orIL.
                    prove Rlt a1 p1.
                    rewrite <- Hc1eq at 1.
                    rewrite <- Hd1eq at 1.
                    exact Hlt.
                  - assume Hcore: c1 = d1 /\ Rlt c2 d2.
                    apply orIR.
	                    apply andI.
	                    + prove a1 = p1.
	                      rewrite <- Hc1eq at 1.
	                      rewrite <- Hd1eq at 1.
	                      exact (andEL (c1 = d1) (Rlt c2 d2) Hcore).
	                    + prove Rlt a2 p2.
	                      rewrite <- Hc2eq at 1.
	                      rewrite <- Hd2eq at 1.
                      exact (andER (c1 = d1) (Rlt c2 d2) Hcore). }
	                apply Hunf.
	                - assume Hlt: Rlt a1 p1.
	                  apply binunionI1.
	                  rewrite rectangle_set_def.
	                  rewrite HpEta.
	                  exact (tuple_2_setprod_by_pair_Sigma U0 R p1 p2
	                          (SepI R (fun x0:set => order_rel R a1 x0) p1 Hp1R (Rlt_implies_order_rel_R a1 p1 (RltI a1 p1 Ha1R Hp1R (RltE_lt a1 p1 Hlt))))
	                          Hp2R).
	                - assume Hcore: a1 = p1 /\ Rlt a2 p2.
	                  apply binunionI2.
	                  claim Hpeq: p1 = a1.
	                  { rewrite <- (andEL (a1 = p1) (Rlt a2 p2) Hcore). reflexivity. }
	                  rewrite HpEta.
	                  rewrite Hpeq.
	                  rewrite rectangle_set_def.
	                  exact (tuple_2_setprod_by_pair_Sigma {a1} V0 a1 p2
	                          (SingI a1)
	                          (SepI R (fun x0:set => order_rel R a2 x0) p2 Hp2R (Rlt_implies_order_rel_R a2 p2 (RltI a2 p2 Ha2R Hp2R (RltE_lt a2 p2 (andER (a1 = p1) (Rlt a2 p2) Hcore)))))).
              - let p. assume Hp: p :e Rrect :\/: Vrect.
	                apply (binunionE Rrect Vrect p Hp (p :e open_ray_upper X0 a)).
	                + assume HpR: p :e Rrect.
	                  set p1 := p 0.
	                  set p2 := p 1.
	                  claim HpUV: p :e setprod U0 R.
	                  { rewrite rectangle_set_def. exact HpR. }
	                  claim HU0subR: U0 c= R.
	                  { let x. assume Hx: x :e U0.
	                    exact (SepE1 R (fun x0:set => order_rel R a1 x0) x Hx). }
	                  claim HpX0: p :e X0.
	                  { exact ((setprod_Subq U0 R R R HU0subR (Subq_ref R)) p HpUV). }
	                  claim HpEta: p = (p1, p2).
	                  { exact (setprod_eta R R p HpX0). }
	                  claim HpX0pair: (p1, p2) :e X0.
	                  { rewrite <- HpEta. exact HpX0. }
	                  claim Hp1inU0: p1 :e U0.
	                  { exact (ap0_Sigma U0 (fun _ : set => R) p HpUV). }
	                  claim Hp2R: p2 :e R.
	                  { exact (ap1_Sigma U0 (fun _ : set => R) p HpUV). }
	                  claim Hrel1: order_rel R a1 p1.
	                  { exact (SepE2 R (fun x0:set => order_rel R a1 x0) p1 Hp1inU0). }
	                  claim Hlt: Rlt a1 p1.
	                  { exact (order_rel_R_implies_Rlt a1 p1 Hrel1). }
	                  prove p :e open_ray_upper X0 a.
	                  claim HdefOR: open_ray_upper X0 a = {x :e X0 | order_rel X0 a x}.
	                  { reflexivity. }
	                  rewrite HdefOR.
	                  apply (SepI X0 (fun q:set => order_rel X0 a q) p HpX0).
	                  claim HrelX0: order_rel X0 (a1, a2) (p1, p2).
	                  { exact (order_rel_setprod_R_R_intro a1 a2 p1 p2 (orIL (Rlt a1 p1) (a1 = p1 /\ Rlt a2 p2) Hlt)). }
	                  prove order_rel X0 a p.
	                  rewrite HaEta.
	                  rewrite HpEta.
	                  exact HrelX0.
	                + assume HpV: p :e Vrect.
	                  set p1 := p 0.
	                  set p2 := p 1.
	                  claim HpUV: p :e setprod {a1} V0.
	                  { rewrite rectangle_set_def. exact HpV. }
	                  claim HV0subR: V0 c= R.
	                  { let x. assume Hx: x :e V0.
	                    exact (SepE1 R (fun x0:set => order_rel R a2 x0) x Hx). }
	                  claim HpX0: p :e X0.
	                  { exact ((setprod_Subq {a1} V0 R R (singleton_subset a1 R Ha1R) HV0subR) p HpUV). }
	                  claim HpEta: p = (p1, p2).
	                  { exact (setprod_eta R R p HpX0). }
	                  claim HpX0pair: (p1, p2) :e X0.
	                  { rewrite <- HpEta. exact HpX0. }
	                  claim Hp1eq: p1 = a1.
	                  { exact (SingE a1 p1 (ap0_Sigma {a1} (fun _ : set => V0) p HpUV)). }
	                  claim Hp2inV0: p2 :e V0.
	                  { exact (ap1_Sigma {a1} (fun _ : set => V0) p HpUV). }
	                  claim Hrel2: order_rel R a2 p2.
	                  { exact (SepE2 R (fun x0:set => order_rel R a2 x0) p2 Hp2inV0). }
	                  claim Hlt2: Rlt a2 p2.
	                  { exact (order_rel_R_implies_Rlt a2 p2 Hrel2). }
	                  claim Ha1eqp1: a1 = p1.
	                  { rewrite <- Hp1eq. reflexivity. }
	                  prove p :e open_ray_upper X0 a.
	                  claim HdefOR: open_ray_upper X0 a = {x :e X0 | order_rel X0 a x}.
	                  { reflexivity. }
	                  rewrite HdefOR.
	                  apply (SepI X0 (fun q:set => order_rel X0 a q) p HpX0).
	                  claim HrelX0: order_rel X0 (a1, a2) (p1, p2).
	                  { exact (order_rel_setprod_R_R_intro a1 a2 p1 p2 (orIR (Rlt a1 p1) (a1 = p1 /\ Rlt a2 p2)
	                        (andI (a1 = p1) (Rlt a2 p2) Ha1eqp1 Hlt2))). }
	                  prove order_rel X0 a p.
	                  rewrite HaEta.
	                  rewrite HpEta.
	                  exact HrelX0.
	            }
	            rewrite Hop.
	            exact (topology_binunion_closed X0 Tprod Rrect Vrect HTprod Hb1open Hb2open).
	          + assume HIlow: I :e {I0 :e Power X0 | exists b :e X0, I0 = open_ray_lower X0 b}.
	            claim Hex: exists b :e X0, I = open_ray_lower X0 b.
	            { exact (SepE2 (Power X0) (fun I0 : set => exists b :e X0, I0 = open_ray_lower X0 b) I HIlow). }
	            apply Hex.
	            let b. assume Hbcore. apply Hbcore.
	            assume HbX0: b :e X0.
	            assume HIeq: I = open_ray_lower X0 b.
	            rewrite HIeq.
	            (** express the open lower ray as union of two product-basis rectangles **)
	            set b1 := b 0.
	            set b2 := b 1.
	            claim Hb1R: b1 :e R.
	            { exact (ap0_Sigma R (fun _ : set => R) b HbX0). }
	            claim Hb2R: b2 :e R.
	            { exact (ap1_Sigma R (fun _ : set => R) b HbX0). }
	            claim HbEta: b = (b1, b2).
	            { exact (setprod_eta R R b HbX0). }
	            set U0 := open_ray_lower R b1.
	            set V0 := open_ray_lower R b2.
	            set Rrect := rectangle_set U0 R.
	            set Vrect := rectangle_set {b1} V0.
	            claim HU0inTx: U0 :e discrete_topology R.
	            { claim HdefDisc: discrete_topology R = Power R.
	              { reflexivity. }
	              rewrite HdefDisc.
	              prove U0 :e Power R.
	              apply PowerI.
	              let x. assume HxU0: x :e U0.
	              exact (SepE1 R (fun x0 : set => order_rel R x0 b1) x HxU0). }
	            claim HRinTy: R :e R_standard_topology.
	            { exact (topology_has_X R R_standard_topology HTy). }
	            claim HV0inTy: V0 :e R_standard_topology.
	            { rewrite <- standard_topology_is_order_topology.
	              claim HsRay: V0 :e open_rays_subbasis R.
	              { exact (open_ray_lower_in_open_rays_subbasis R b2 Hb2R). }
	              exact (open_rays_subbasis_sub_order_topology_R V0 HsRay). }
	            claim Hsing: {b1} :e discrete_topology R.
	            { claim HdefDisc: discrete_topology R = Power R.
	              { reflexivity. }
	              rewrite HdefDisc.
	              apply PowerI.
	              exact (singleton_subset b1 R Hb1R). }
	            claim Hb1: Rrect :e product_subbasis R (discrete_topology R) R R_standard_topology.
	            { claim HdefPS:
	                product_subbasis R (discrete_topology R) R R_standard_topology
	                = (\/_ U :e (discrete_topology R), {rectangle_set U V|V :e R_standard_topology}).
	              { reflexivity. }
	              rewrite HdefPS.
	              apply (famunionI (discrete_topology R)
	                (fun U:set => {rectangle_set U V|V :e R_standard_topology})
	                U0 Rrect HU0inTx).
	              prove Rrect :e {rectangle_set U0 V|V :e R_standard_topology}.
	              exact (ReplI R_standard_topology (fun V:set => rectangle_set U0 V) R HRinTy). }
	            claim Hb2: Vrect :e product_subbasis R (discrete_topology R) R R_standard_topology.
	            { claim HdefPS:
	                product_subbasis R (discrete_topology R) R R_standard_topology
	                = (\/_ U :e (discrete_topology R), {rectangle_set U V|V :e R_standard_topology}).
	              { reflexivity. }
	              rewrite HdefPS.
	              apply (famunionI (discrete_topology R)
	                (fun U:set => {rectangle_set U V|V :e R_standard_topology})
	                {b1} Vrect Hsing).
	              prove Vrect :e {rectangle_set {b1} V|V :e R_standard_topology}.
	              exact (ReplI R_standard_topology (fun V:set => rectangle_set {b1} V) V0 HV0inTy). }
	            claim Hbasis: basis_on X0 (product_subbasis R (discrete_topology R) R R_standard_topology).
	            { exact (product_subbasis_is_basis R (discrete_topology R) R R_standard_topology HTx HTy). }
	            claim Hb1open: Rrect :e Tprod.
	            { exact (generated_topology_contains_basis X0
	                (product_subbasis R (discrete_topology R) R R_standard_topology)
	                Hbasis Rrect Hb1). }
	            claim Hb2open: Vrect :e Tprod.
	            { exact (generated_topology_contains_basis X0
	                (product_subbasis R (discrete_topology R) R R_standard_topology)
	                Hbasis Vrect Hb2). }
	            claim Hop: open_ray_lower X0 b = Rrect :\/: Vrect.
	            { apply set_ext.
	              - let p. assume Hp: p :e open_ray_lower X0 b.
	                claim HpX0: p :e X0.
	                { exact (SepE1 X0 (fun x0:set => order_rel X0 x0 b) p Hp). }
	                set p1 := p 0.
	                set p2 := p 1.
	                claim Hp1R: p1 :e R.
	                { exact (ap0_Sigma R (fun _ : set => R) p HpX0). }
	                claim Hp2R: p2 :e R.
	                { exact (ap1_Sigma R (fun _ : set => R) p HpX0). }
	                claim HpEta: p = (p1, p2).
	                { exact (setprod_eta R R p HpX0). }
	                claim Hrel: order_rel X0 p b.
	                { exact (SepE2 X0 (fun x0:set => order_rel X0 x0 b) p Hp). }
	                claim Hunf: Rlt p1 b1 \/ (p1 = b1 /\ Rlt p2 b2).
	                { claim Hrel': order_rel X0 (p1, p2) (b1, b2).
	                  { rewrite <- HpEta at 1.
	                    rewrite <- HbEta at 1.
	                    exact Hrel. }
	                  apply (order_rel_setprod_R_R_unfold (p1, p2) (b1, b2) Hrel').
	                  let c1. assume Hc1rest. apply Hc1rest.
	                  let c2. assume Hc2rest. apply Hc2rest.
	                  let d1. assume Hd1rest. apply Hd1rest.
	                  let d2. assume Hpack:
	                    ((p1, p2) = (c1, c2) /\ (b1, b2) = (d1, d2)) /\ (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2)).
	                  claim Heqs: (p1, p2) = (c1, c2) /\ (b1, b2) = (d1, d2).
	                  { exact (andEL ((p1, p2) = (c1, c2) /\ (b1, b2) = (d1, d2))
	                                 (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
	                                 Hpack). }
	                  claim Hdisj: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
	                  { exact (andER ((p1, p2) = (c1, c2) /\ (b1, b2) = (d1, d2))
	                                 (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
	                                 Hpack). }
	                  claim HpcEq: (p1, p2) = (c1, c2).
	                  { exact (andEL ((p1, p2) = (c1, c2)) ((b1, b2) = (d1, d2)) Heqs). }
	                  claim HbdEq: (b1, b2) = (d1, d2).
	                  { exact (andER ((p1, p2) = (c1, c2)) ((b1, b2) = (d1, d2)) Heqs). }
	                  claim Hc1eq: c1 = p1.
	                  { claim Hp1eq: p1 = c1.
	                    { rewrite <- (tuple_2_0_eq p1 p2).
	                      rewrite <- (tuple_2_0_eq c1 c2).
	                      rewrite HpcEq.
	                      reflexivity. }
	                    prove c1 = p1.
	                    rewrite Hp1eq.
	                    reflexivity. }
	                  claim Hc2eq: c2 = p2.
	                  { claim Hp2eq: p2 = c2.
	                    { rewrite <- (tuple_2_1_eq p1 p2).
	                      rewrite <- (tuple_2_1_eq c1 c2).
	                      rewrite HpcEq.
	                      reflexivity. }
	                    prove c2 = p2.
	                    rewrite Hp2eq.
	                    reflexivity. }
	                  claim Hd1eq: d1 = b1.
	                  { claim Hb1eq: b1 = d1.
	                    { rewrite <- (tuple_2_0_eq b1 b2).
	                      rewrite <- (tuple_2_0_eq d1 d2).
	                      rewrite HbdEq.
	                      reflexivity. }
	                    prove d1 = b1.
	                    rewrite Hb1eq.
	                    reflexivity. }
	                  claim Hd2eq: d2 = b2.
	                  { claim Hb2eq: b2 = d2.
	                    { rewrite <- (tuple_2_1_eq b1 b2).
	                      rewrite <- (tuple_2_1_eq d1 d2).
	                      rewrite HbdEq.
	                      reflexivity. }
	                    prove d2 = b2.
	                    rewrite Hb2eq.
	                    reflexivity. }
	                  apply Hdisj.
	                  - assume Hlt: Rlt c1 d1.
	                    apply orIL.
	                    prove Rlt p1 b1.
	                    rewrite <- Hc1eq at 1.
	                    rewrite <- Hd1eq at 1.
	                    exact Hlt.
	                  - assume Hcore: c1 = d1 /\ Rlt c2 d2.
	                    apply orIR.
	                    apply andI.
	                    + prove p1 = b1.
	                      rewrite <- Hc1eq at 1.
	                      rewrite <- Hd1eq at 1.
	                      exact (andEL (c1 = d1) (Rlt c2 d2) Hcore).
	                    + prove Rlt p2 b2.
	                      rewrite <- Hc2eq at 1.
	                      rewrite <- Hd2eq at 1.
	                      exact (andER (c1 = d1) (Rlt c2 d2) Hcore). }
	                apply Hunf.
	                - assume Hlt: Rlt p1 b1.
	                  apply binunionI1.
	                  rewrite rectangle_set_def.
	                  rewrite HpEta.
	                  exact (tuple_2_setprod_by_pair_Sigma U0 R p1 p2
	                          (SepI R (fun x0:set => order_rel R x0 b1) p1 Hp1R (Rlt_implies_order_rel_R p1 b1 (RltI p1 b1 Hp1R Hb1R (RltE_lt p1 b1 Hlt))))
	                          Hp2R).
	                - assume Hcore: p1 = b1 /\ Rlt p2 b2.
	                  apply binunionI2.
	                  claim Hpeq: p1 = b1.
	                  { exact (andEL (p1 = b1) (Rlt p2 b2) Hcore). }
	                  rewrite HpEta.
	                  rewrite Hpeq.
	                  rewrite rectangle_set_def.
	                  exact (tuple_2_setprod_by_pair_Sigma {b1} V0 b1 p2
	                          (SingI b1)
	                          (SepI R (fun x0:set => order_rel R x0 b2) p2 Hp2R (Rlt_implies_order_rel_R p2 b2 (RltI p2 b2 Hp2R Hb2R (RltE_lt p2 b2 (andER (p1 = b1) (Rlt p2 b2) Hcore)))))).
	              - let p. assume Hp: p :e Rrect :\/: Vrect.
	                apply (binunionE Rrect Vrect p Hp (p :e open_ray_lower X0 b)).
	                + assume HpR: p :e Rrect.
	                  set p1 := p 0.
	                  set p2 := p 1.
	                  claim HpUV: p :e setprod U0 R.
	                  { rewrite rectangle_set_def. exact HpR. }
	                  claim HU0subR: U0 c= R.
	                  { let x. assume Hx: x :e U0.
	                    exact (SepE1 R (fun x0 : set => order_rel R x0 b1) x Hx). }
	                  claim HpX0: p :e X0.
	                  { exact ((setprod_Subq U0 R R R HU0subR (Subq_ref R)) p HpUV). }
	                  claim HpEta: p = (p1, p2).
	                  { exact (setprod_eta R R p HpX0). }
	                  claim Hp1inU0: p1 :e U0.
	                  { exact (ap0_Sigma U0 (fun _ : set => R) p HpUV). }
	                  claim Hrel1: order_rel R p1 b1.
	                  { exact (SepE2 R (fun x0:set => order_rel R x0 b1) p1 Hp1inU0). }
	                  claim Hlt: Rlt p1 b1.
	                  { exact (order_rel_R_implies_Rlt p1 b1 Hrel1). }
	                  prove p :e open_ray_lower X0 b.
	                  claim HdefOL: open_ray_lower X0 b = {x :e X0 | order_rel X0 x b}.
	                  { reflexivity. }
	                  rewrite HdefOL.
	                  apply (SepI X0 (fun q:set => order_rel X0 q b) p HpX0).
	                  claim HrelX0: order_rel X0 (p1, p2) (b1, b2).
	                  { exact (order_rel_setprod_R_R_intro p1 p2 b1 b2 (orIL (Rlt p1 b1) (p1 = b1 /\ Rlt p2 b2) Hlt)). }
	                  prove order_rel X0 p b.
	                  rewrite HpEta.
	                  rewrite HbEta.
	                  exact HrelX0.
	                + assume HpV: p :e Vrect.
	                  set p1 := p 0.
	                  set p2 := p 1.
	                  claim HpUV: p :e setprod {b1} V0.
	                  { rewrite rectangle_set_def. exact HpV. }
	                  claim HV0subR: V0 c= R.
	                  { let x. assume Hx: x :e V0.
	                    exact (SepE1 R (fun x0 : set => order_rel R x0 b2) x Hx). }
	                  claim HpX0: p :e X0.
	                  { exact ((setprod_Subq {b1} V0 R R (singleton_subset b1 R Hb1R) HV0subR) p HpUV). }
	                  claim HpEta: p = (p1, p2).
	                  { exact (setprod_eta R R p HpX0). }
	                  claim Hp1eq: p1 = b1.
	                  { exact (SingE b1 p1 (ap0_Sigma {b1} (fun _ : set => V0) p HpUV)). }
	                  claim Hp2inV0: p2 :e V0.
	                  { exact (ap1_Sigma {b1} (fun _ : set => V0) p HpUV). }
	                  claim Hrel2: order_rel R p2 b2.
	                  { exact (SepE2 R (fun x0:set => order_rel R x0 b2) p2 Hp2inV0). }
	                  claim Hlt2: Rlt p2 b2.
	                  { exact (order_rel_R_implies_Rlt p2 b2 Hrel2). }
	                  claim Hp1eq2: p1 = b1.
	                  { exact Hp1eq. }
	                  prove p :e open_ray_lower X0 b.
	                  claim HdefOL: open_ray_lower X0 b = {x :e X0 | order_rel X0 x b}.
	                  { reflexivity. }
	                  rewrite HdefOL.
	                  apply (SepI X0 (fun q:set => order_rel X0 q b) p HpX0).
	                  claim HrelX0: order_rel X0 (p1, p2) (b1, b2).
	                  { exact (order_rel_setprod_R_R_intro p1 p2 b1 b2 (orIR (Rlt p1 b1) (p1 = b1 /\ Rlt p2 b2)
	                          (andI (p1 = b1) (Rlt p2 b2) Hp1eq2 Hlt2))). }
	                  prove order_rel X0 p b.
	                  rewrite HpEta.
	                  rewrite HbEta.
	                  exact HrelX0.
	            }
	            rewrite Hop.
	            exact (topology_binunion_closed X0 Tprod Rrect Vrect HTprod Hb1open Hb2open).
          + exact HI0.
        - assume HIX: I :e {X0}.
          claim HIeq: I = X0.
          { exact (SingE X0 I HIX). }
          rewrite HIeq.
          exact (topology_has_X X0 Tprod HTprod).
        - exact HI. }
      claim Hmin: finer_than Tprod (generated_topology_from_subbasis X0 S).
      { exact (topology_generated_by_basis_is_minimal X0 S Tprod HS HTprod HSsub). }
      exact (Hmin U HU).
	    - let U. assume HU: U :e product_topology R (discrete_topology R) R R_standard_topology.
	      prove U :e R2_dictionary_order_topology.
	      set X0 := setprod R R.
	      set B := product_subbasis R (discrete_topology R) R R_standard_topology.
	      set Tprod := product_topology R (discrete_topology R) R R_standard_topology.
	      set T := R2_dictionary_order_topology.
	      claim HTx: topology_on R (discrete_topology R).
	      { exact (discrete_topology_on R). }
	      claim HTy: topology_on R R_standard_topology.
	      { exact R_standard_topology_is_topology_local. }
	      claim HBasis: basis_on X0 B.
	      { exact (product_subbasis_is_basis R (discrete_topology R) R R_standard_topology HTx HTy). }
	      claim HTprod: topology_on X0 Tprod.
	      { exact (lemma_topology_from_basis X0 B HBasis). }
	      claim HUopen: open_in X0 Tprod U.
	      { exact (andI (topology_on X0 Tprod) (U :e Tprod) HTprod HU). }
	      claim HexFam: exists Fam :e Power B, Union Fam = U.
	      { exact (open_sets_as_unions_of_basis X0 B HBasis U HUopen). }
	      apply HexFam.
	      let Fam. assume HFcore. apply HFcore.
	      assume HFamPow: Fam :e Power B.
	      assume HUnionEq: Union Fam = U.
	      rewrite <- HUnionEq.
	      claim HT: topology_on X0 T.
	      { exact dictionary_order_topology_is_topology. }
	      apply (topology_union_closed_pow X0 T Fam HT).
	      apply PowerI.
	      let I. assume HI: I :e Fam.
	      claim HIb: I :e B.
	      { exact (PowerE B Fam HFamPow I HI). }
	      (** Each basis rectangle is open in the dictionary order topology; delegated to a helper. **)
	      apply (famunionE_impred (discrete_topology R)
	        (fun U0:set => {rectangle_set U0 V|V :e R_standard_topology})
	        I
	        HIb
	        (I :e T)).
	      let U0. assume HU0Tx HIU0.
	      apply (ReplE_impred R_standard_topology (fun V0:set => rectangle_set U0 V0) I HIU0 (I :e T)).
	      let V0. assume HV0Ty HIeq.
	      rewrite HIeq.
	      exact (rectangle_in_dictionary U0 V0 HU0Tx HV0Ty).
	  }
	  exact Heq.
		- (** strict inequality vs the standard topology (skeleton) **)
		  (** Separate by the vertical open strip {0}×(0,1). **)
		  prove R2_dictionary_order_topology <> R2_standard_topology.
		  assume HeqTop: R2_dictionary_order_topology = R2_standard_topology.
		  apply FalseE.
		  claim H0R: 0 :e R.
		  { exact real_0. }
		  claim H1R: 1 :e R.
		  { exact real_1. }
		  claim H01: Rlt 0 1.
		  { exact (RltI 0 1 H0R H1R SNoLt_0_1). }
		  set V := open_interval 0 1.
		  set U := rectangle_set {0} V.
		  claim HV: V :e R_standard_topology.
		  { exact (open_interval_in_R_standard_topology 0 1 H01). }
		  claim HUdict: U :e R2_dictionary_order_topology.
		  { exact (singleton_rectangle_in_dictionary 0 V H0R HV). }
		  claim HUstd: U :e R2_standard_topology.
		  { rewrite <- HeqTop.
		    exact HUdict. }
		  claim HUnot: U /:e R2_standard_topology.
		  { assume HU: U :e R2_standard_topology.
		    prove False.
		    set X0 := setprod R R.
		    set B := product_subbasis R R_standard_topology R R_standard_topology.
		    claim HTx: topology_on R R_standard_topology.
		    { exact R_standard_topology_is_topology_local. }
		    claim HTy: topology_on R R_standard_topology.
		    { exact R_standard_topology_is_topology_local. }
		    claim HBasis: basis_on X0 B.
		    { exact (product_subbasis_is_basis R R_standard_topology R R_standard_topology HTx HTy). }
		    claim HTstd: topology_on X0 R2_standard_topology.
		    { exact (product_topology_is_topology R R_standard_topology R R_standard_topology HTx HTy). }
		    claim HUopen: open_in X0 R2_standard_topology U.
		    { exact (andI (topology_on X0 R2_standard_topology) (U :e R2_standard_topology) HTstd HU). }
		    claim HexFam: exists Fam :e Power B, Union Fam = U.
		    { exact (open_sets_as_unions_of_basis X0 B HBasis U HUopen). }
		    apply HexFam.
		    let Fam. assume HFcore. apply HFcore.
		    assume HFamPow: Fam :e Power B.
		    assume HUnionEq: Union Fam = U.
		    (** choose a rational q with 0<q<1, so (0,q) :e U **)
		    claim Hexq: exists q :e rational_numbers, Rlt 0 q /\ Rlt q 1.
		    { exact (rational_dense_between_reals 0 1 H0R H1R H01). }
		    apply Hexq.
		    let q. assume Hqcore. apply Hqcore.
		    assume HqQ Hqineq.
		    claim H0q: Rlt 0 q.
		    { exact (andEL (Rlt 0 q) (Rlt q 1) Hqineq). }
		    claim Hq1: Rlt q 1.
		    { exact (andER (Rlt 0 q) (Rlt q 1) Hqineq). }
		    claim HqR: q :e R.
		    { exact (rational_numbers_in_R q HqQ). }
		    claim HqV: q :e V.
		    { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z 1) q HqR
		            (andI (Rlt 0 q) (Rlt q 1) H0q Hq1)). }
		    set p := (0, q).
		    claim HpU: p :e U.
		    { rewrite rectangle_set_def.
		      exact (tuple_2_setprod_by_pair_Sigma {0} V 0 q (SingI 0) HqV). }
		    claim HpUnion: p :e Union Fam.
		    { rewrite HUnionEq.
		      exact HpU. }
		    apply (UnionE_impred Fam p HpUnion False).
		    let I. assume HpI HIinFam.
		    claim HIb: I :e B.
		    { exact (PowerE B Fam HFamPow I HIinFam). }
		    apply (famunionE_impred R_standard_topology
		      (fun U0:set => {rectangle_set U0 V0|V0 :e R_standard_topology})
		      I
		      HIb
		      False).
		    let U0. assume HU0open HIU0.
		    apply (ReplE_impred R_standard_topology (fun V0:set => rectangle_set U0 V0) I HIU0 False).
		    let V0. assume HV0open HIeq.
		    (** extract 0 :e U0 and q :e V0 from p :e I = U0×V0 **)
		    claim HpUV: p :e setprod U0 V0.
		    { rewrite <- rectangle_set_def.
		      rewrite <- HIeq.
		      exact HpI. }
		    claim Hp0U0: p 0 :e U0.
		    { exact (ap0_Sigma U0 (fun _ : set => V0) p HpUV). }
		    claim Hp1V0: p 1 :e V0.
		    { exact (ap1_Sigma U0 (fun _ : set => V0) p HpUV). }
		    claim Hp0eq: p 0 = 0.
		    { exact (tuple_2_0_eq 0 q). }
		    claim Hp1eq: p 1 = q.
		    { exact (tuple_2_1_eq 0 q). }
		    claim H0U0: 0 :e U0.
		    { rewrite <- Hp0eq.
		      exact Hp0U0. }
		    claim HqV0: q :e V0.
		    { rewrite <- Hp1eq.
		      exact Hp1V0. }
		    (** show U0 c= {0} using the point (x,q) and I c= U **)
		    claim HU0sub: U0 c= {0}.
		    { let x. assume Hx: x :e U0.
		      claim HxqUV: (x, q) :e setprod U0 V0.
		      { exact (tuple_2_setprod_by_pair_Sigma U0 V0 x q Hx HqV0). }
		      claim HxqI: (x, q) :e I.
		      { rewrite HIeq.
		        rewrite <- rectangle_set_def.
		        exact HxqUV. }
		      claim HxqUnion: (x, q) :e Union Fam.
		      { exact (UnionI Fam (x, q) I HxqI HIinFam). }
		      claim HxqU: (x, q) :e U.
		      { rewrite <- HUnionEq.
		        exact HxqUnion. }
		      claim HxqUS: (x, q) :e setprod {0} V.
		      { rewrite <- rectangle_set_def.
		        exact HxqU. }
		      claim Hx0: (x, q) 0 :e {0}.
		      { exact (ap0_Sigma {0} (fun _ : set => V) (x, q) HxqUS). }
		      rewrite <- (tuple_2_0_eq x q).
		      exact Hx0. }
		    (** conclude {0} :e R_standard_topology, contradict singleton_not_open_R_standard_topology **)
		    claim HsingSub: {0} c= U0.
		    { let y. assume Hy: y :e {0}.
		      claim Hyeq: y = 0.
		      { exact (SingE 0 y Hy). }
		      rewrite Hyeq.
		      exact H0U0. }
		    claim HU0eq: U0 = {0}.
		    { apply set_ext.
		      - exact HU0sub.
		      - exact HsingSub. }
		    claim HsingOpen: {0} :e R_standard_topology.
		    { rewrite <- HU0eq.
		      exact HU0open. }
		    exact (singleton_not_open_R_standard_topology 0 H0R HsingOpen). }
		  apply HUnot.
		  exact HUstd.
	Qed.

(** from §16 Exercise 10: compare topologies on I×I **) 
(** LATEX VERSION: Exercise 10: Compare ordered square topology, dictionary subspace topology, and product topology on I×I. **)
Theorem ex16_10_compare_topologies_on_square :
  ordered_square_topology <> subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square /\
  subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square <>
    product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
prove ordered_square_topology <> subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square /\ subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square <> product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
apply andI.
- exact ordered_square_not_subspace_dictionary.
- (** show the dictionary-order subspace topology differs from the product topology **)
  set Tdic := subspace_topology (setprod R R) R2_dictionary_order_topology ordered_square.
  set Tprod := product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
  prove Tdic <> Tprod.
  assume Heq: Tdic = Tprod.
  set U := ordered_square_open_strip.
  claim HUdic: U :e Tdic.
  { (** U is open in the dictionary-order subspace topology by Example 3 **)
    prove U :e Tdic.
    (** show U is a subset of ordered_square, hence U is in Power ordered_square **)
    claim HUsub: U c= ordered_square.
    { let p. assume Hp: p :e U.
      exact (SepE1 ordered_square
                   (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                   p
                   Hp). }
    claim HUpow: U :e Power ordered_square.
    { exact (PowerI ordered_square U HUsub). }
    (** define an open interval V in the dictionary order on R×R with V∩ordered_square = U **)
    set a := (eps_ 1, eps_ 1).
    set b := (eps_ 1, 2).
    set V := {p :e setprod R R |
                order_rel (setprod R R) a p /\ order_rel (setprod R R) p b}.
    claim HVTx: V :e R2_dictionary_order_topology.
    { set X := setprod R R.
      claim HS: subbasis_on X (open_rays_subbasis X).
      { exact (open_rays_subbasis_is_subbasis X). }
      claim HT: topology_on X R2_dictionary_order_topology.
      { exact dictionary_order_topology_is_topology. }
      claim HaX: a :e X.
      { exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) (eps_ 1) eps_1_in_R eps_1_in_R). }
      claim HbX: b :e X.
      { exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) 2 eps_1_in_R two_in_R). }
      set U1 := open_ray_upper X a.
      set U2 := open_ray_lower X b.
      claim HU1S: U1 :e open_rays_subbasis X.
      { exact (open_ray_upper_in_open_rays_subbasis X a HaX). }
      claim HU2S: U2 :e open_rays_subbasis X.
      { exact (open_ray_lower_in_open_rays_subbasis X b HbX). }
      claim HU1open: U1 :e R2_dictionary_order_topology.
      { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U1 HS HU1S). }
      claim HU2open: U2 :e R2_dictionary_order_topology.
      { exact (subbasis_elem_open_in_generated_from_subbasis X (open_rays_subbasis X) U2 HS HU2S). }
      claim HVeq: V = U1 :/\: U2.
      { claim HdefV: V = {p :e X | order_rel X a p /\ order_rel X p b}.
        { reflexivity. }
        rewrite HdefV.
        exact (open_interval_eq_rays_intersection X a b). }
      rewrite HVeq.
      exact (topology_binintersect_closed X R2_dictionary_order_topology U1 U2 HT HU1open HU2open).
    }
    claim HeqU: U = V :/\: ordered_square.
    { (** this is the key set identity from Example 3 **)
      apply set_ext.
      - let p. assume HpU: p :e U.
        prove p :e V :/\: ordered_square.
        claim HpSq: p :e ordered_square.
        { exact (SepE1 ordered_square
                     (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                     p
                     HpU). }
        claim Hexy: exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
        { exact (SepE2 ordered_square
                     (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
                     p
                     HpU). }
	        apply Hexy.
	        let y. assume Hyprop.
	        (** conjunction is left-associative: (A /\ B) /\ C **)
	        claim Hpair: (p = (eps_ 1,y) /\ Rlt (eps_ 1) y).
	        { exact (andEL (p = (eps_ 1,y) /\ Rlt (eps_ 1) y)
	                      (~(Rlt 1 y))
	                      Hyprop). }
	        claim Hyle1: ~(Rlt 1 y).
	        { exact (andER (p = (eps_ 1,y) /\ Rlt (eps_ 1) y)
	                      (~(Rlt 1 y))
	                      Hyprop). }
	        claim Hpy: p = (eps_ 1,y).
	        { exact (andEL (p = (eps_ 1,y))
	                      (Rlt (eps_ 1) y)
	                      Hpair). }
	        claim Hey: Rlt (eps_ 1) y.
	        { exact (andER (p = (eps_ 1,y))
	                      (Rlt (eps_ 1) y)
	                      Hpair). }
	        claim Heps1R: eps_ 1 :e R.
	        { exact (RltE_left (eps_ 1) y Hey). }
	        claim HyR: y :e R.
	        { exact (RltE_right (eps_ 1) y Hey). }
        (** build p :e V **)
	        claim HpV: p :e V.
	        { prove p :e V.
	          claim HpRR: p :e setprod R R.
	          { rewrite Hpy.
	            exact (tuple_2_setprod_by_pair_Sigma R R (eps_ 1) y Heps1R HyR). }
	          claim Hord1: order_rel (setprod R R) a p.
	          { (** use the defining disjunction for order_rel and inject to the last case **)
	            prove (setprod R R = R /\ Rlt a p)
	              \/
	              (setprod R R = rational_numbers /\ Rlt a p)
	              \/
	              (setprod R R = omega /\ a :e p)
	              \/
	              (setprod R R = omega :\: {0} /\ a :e p)
	              \/
	              (setprod R R = setprod 2 omega /\
	               exists i m j n:set,
	                 i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                 a = (i, m) /\ p = (j, n) /\
	                 (i :e j \/ (i = j /\ m :e n)))
	              \/
	              (setprod R R = setprod R R /\
	               exists a1 a2 b1 b2:set,
	                 a = (a1, a2) /\ p = (b1, b2) /\
	                 (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	              \/
	              (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
	               setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ a :e p).
	            apply orIL.
	            apply orIR.
	            prove (setprod R R = setprod R R /\
	                   exists a1 a2 b1 b2:set,
	                     a = (a1, a2) /\ p = (b1, b2) /\
	                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))).
	            apply andI.
	            - reflexivity.
	            - witness (eps_ 1).
              witness (eps_ 1).
              witness (eps_ 1).
              witness y.
              prove a = (eps_ 1, eps_ 1) /\ p = (eps_ 1, y) /\
                    (Rlt (eps_ 1) (eps_ 1) \/ ((eps_ 1) = (eps_ 1) /\ Rlt (eps_ 1) y)).
              apply andI.
              + apply andI.
                * reflexivity.
                * exact Hpy.
              + apply orIR.
                apply andI.
                * reflexivity.
                * exact Hey. }
	          claim Hord2: order_rel (setprod R R) p b.
	          { prove (setprod R R = R /\ Rlt p b)
	              \/
	              (setprod R R = rational_numbers /\ Rlt p b)
	              \/
	              (setprod R R = omega /\ p :e b)
	              \/
	              (setprod R R = omega :\: {0} /\ p :e b)
	              \/
	              (setprod R R = setprod 2 omega /\
	               exists i m j n:set,
	                 i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
	                 p = (i, m) /\ b = (j, n) /\
	                 (i :e j \/ (i = j /\ m :e n)))
	              \/
	              (setprod R R = setprod R R /\
	               exists a1 a2 b1 b2:set,
	                 p = (a1, a2) /\ b = (b1, b2) /\
	                 (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
	              \/
	              (ordinal (setprod R R) /\ setprod R R <> R /\ setprod R R <> rational_numbers /\
	               setprod R R <> setprod 2 omega /\ setprod R R <> setprod R R /\ p :e b).
	            apply orIL.
	            apply orIR.
	            prove (setprod R R = setprod R R /\
	                   exists a1 a2 b1 b2:set,
	                     p = (a1, a2) /\ b = (b1, b2) /\
	                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))).
	            apply andI.
	            - reflexivity.
	            - (** derive Rlt y 2 from y <= 1 and 1 < 2 **)
              claim HdefR: R = real.
              { reflexivity. }
              claim H1R: 1 :e R.
              { rewrite HdefR. exact real_1. }
              claim H2R: 2 :e R.
              { claim H2real: 2 :e real.
                { rewrite <- add_SNo_1_1_2.
                  exact (real_add_SNo 1 real_1 1 real_1). }
                rewrite HdefR.
                exact H2real. }
	              claim H12: Rlt 1 2.
	              { exact (RltI 1 2 H1R H2R SNoLt_1_2). }
	              claim Hy2: Rlt y 2.
	              { (** derive y < 2 by trichotomy, using that ~(1 < y) **)
	                claim Hyreal: y :e real.
	                { rewrite <- HdefR.
	                  exact HyR. }
	                claim H2real: 2 :e real.
	                { rewrite <- HdefR.
	                  exact H2R. }
	                claim HyS: SNo y.
	                { exact (real_SNo y Hyreal). }
	                claim H2S: SNo 2.
	                { exact (real_SNo 2 H2real). }
	                apply (SNoLt_trichotomy_or_impred y 2 HyS H2S (Rlt y 2)).
	                - assume Hylt: y < 2.
	                  exact (RltI y 2 HyR H2R Hylt).
		                - assume Hyeq: y = 2.
		                  apply FalseE.
		                  claim H1y: Rlt 1 y.
		                  { rewrite Hyeq.
		                    exact H12. }
		                  exact (Hyle1 H1y).
	                - assume H2lty: 2 < y.
	                  apply FalseE.
	                  claim H2y: Rlt 2 y.
	                  { exact (RltI 2 y H2R HyR H2lty). }
	                  claim H1y: Rlt 1 y.
	                  { exact (Rlt_tra 1 2 y H12 H2y). }
	                  exact (Hyle1 H1y). }
              witness (eps_ 1).
              witness y.
              witness (eps_ 1).
              witness 2.
              prove p = (eps_ 1, y) /\ b = (eps_ 1, 2) /\
                    (Rlt (eps_ 1) (eps_ 1) \/ ((eps_ 1) = (eps_ 1) /\ Rlt y 2)).
              apply andI.
              + apply andI.
                * exact Hpy.
                * reflexivity.
              + apply orIR.
                apply andI.
                * reflexivity.
                * exact Hy2. }
          exact (SepI (setprod R R)
                      (fun p0:set => order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b)
                      p
                      HpRR
                      (andI (order_rel (setprod R R) a p)
                            (order_rel (setprod R R) p b)
                            Hord1
                            Hord2)). }
        exact (binintersectI V ordered_square p HpV HpSq).
      - let p. assume Hp: p :e V :/\: ordered_square.
        prove p :e U.
        (** reduce to the defining predicate for U in the Sep **)
        claim HpPair: p :e V /\ p :e ordered_square.
        { exact (binintersectE V ordered_square p Hp). }
	        claim HpSq: p :e ordered_square.
	        { exact (andER (p :e V) (p :e ordered_square) HpPair). }
	        claim Hexists: exists y:set, p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
	        { (** extract a coordinate representation of p from HpSq **)
	          claim HsqDef: ordered_square = setprod unit_interval unit_interval.
	          { reflexivity. }
	          claim HpProd: p :e setprod unit_interval unit_interval.
	          { rewrite <- HsqDef.
	            exact HpSq. }
            claim HpV: p :e V.
            { exact (andEL (p :e V) (p :e ordered_square) HpPair). }
            claim Hpord: order_rel (setprod R R) a p /\ order_rel (setprod R R) p b.
            { exact (SepE2 (setprod R R)
                           (fun p0:set => order_rel (setprod R R) a p0 /\ order_rel (setprod R R) p0 b)
                           p
                           HpV). }
            claim Hord1: order_rel (setprod R R) a p.
            { exact (andEL (order_rel (setprod R R) a p)
                          (order_rel (setprod R R) p b)
                          Hpord). }
            claim Hord2: order_rel (setprod R R) p b.
            { exact (andER (order_rel (setprod R R) a p)
                          (order_rel (setprod R R) p b)
                          Hpord). }
            claim Hex_ap: exists a1 a2 b1 b2:set,
              a = (a1, a2) /\ p = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
            { exact (order_rel_setprod_R_R_unfold a p Hord1). }
            claim Hex_pb: exists a1 a2 b1 b2:set,
              p = (a1, a2) /\ b = (b1, b2) /\ (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
            { exact (order_rel_setprod_R_R_unfold p b Hord2). }
	          set y := proj1 p.
	          claim HyU: y :e unit_interval.
	          { exact (proj1_Sigma unit_interval (fun _ : set => unit_interval) p HpProd). }
	          (** from y :e unit_interval, obtain ~(Rlt 1 y) **)
	          claim Hyprop: ~(Rlt 1 y).
	          { exact (andER (~(Rlt y 0)) (~(Rlt 1 y))
	                        (SepE2 R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t)) y HyU)). }
	          witness y.
	          (** the remaining identification of the first coordinate and the strict inequality are the key work **)
	          prove p = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
            claim Heps1R: (eps_ 1) :e R.
            { claim H1omega: 1 :e omega.
              { exact (nat_p_omega 1 nat_1). }
              claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
              { exact (SNo_eps_SNoS_omega 1 H1omega). }
              exact (SNoS_omega_real (eps_ 1) Heps1SNoS). }
	            claim HpFirst: p = (eps_ 1, y) /\ Rlt (eps_ 1) y.
	            { apply Hex_ap.
	              let a1. assume Hex_a2.
	              apply Hex_a2.
	              let a2. assume Hex_b1.
	              apply Hex_b1.
	              let b1. assume Hex_b2.
	              apply Hex_b2.
	              let b2. assume Hap.
	              claim Hcore1: a = (a1, a2) /\ p = (b1, b2).
	              { exact (andEL (a = (a1, a2) /\ p = (b1, b2))
	                            (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
	                            Hap). }
              claim HaEq: a = (a1, a2).
              { exact (andEL (a = (a1, a2)) (p = (b1, b2)) Hcore1). }
              claim HpEq: p = (b1, b2).
              { exact (andER (a = (a1, a2)) (p = (b1, b2)) Hcore1). }
              claim Hdisj1: Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2).
              { exact (andER (a = (a1, a2) /\ p = (b1, b2))
                            (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2))
                            Hap). }
              (** normalize a1 and a2 using a = (eps_ 1, eps_ 1) **)
              claim HaDef: a = (eps_ 1, eps_ 1).
              { reflexivity. }
              claim Ha0: a 0 = eps_ 1.
              { rewrite HaDef.
                exact (tuple_2_0_eq (eps_ 1) (eps_ 1)). }
              claim Ha1: a 1 = eps_ 1.
              { rewrite HaDef.
                exact (tuple_2_1_eq (eps_ 1) (eps_ 1)). }
              claim Ha0': a 0 = a1.
              { rewrite HaEq.
                exact (tuple_2_0_eq a1 a2). }
	              claim Ha1': a 1 = a2.
	              { rewrite HaEq.
	                exact (tuple_2_1_eq a1 a2). }
	              claim Ha1eq: a1 = eps_ 1.
	              { prove a1 = eps_ 1.
	                rewrite <- Ha0'.
	                exact Ha0. }
	              claim Ha2eq: a2 = eps_ 1.
	              { prove a2 = eps_ 1.
	                rewrite <- Ha1'.
	                exact Ha1. }
	              claim Hdisj1': Rlt (eps_ 1) b1 \/ ((eps_ 1) = b1 /\ Rlt (eps_ 1) b2).
	              { apply (Hdisj1 (Rlt (eps_ 1) b1 \/ ((eps_ 1) = b1 /\ Rlt (eps_ 1) b2))).
	                - assume Hlt: Rlt a1 b1.
	                  apply orIL.
	                  prove Rlt (eps_ 1) b1.
	                  rewrite <- Ha1eq at 1.
	                  exact Hlt.
	                - assume Hc: a1 = b1 /\ Rlt a2 b2.
	                  claim Ha1b1: a1 = b1.
	                  { exact (andEL (a1 = b1) (Rlt a2 b2) Hc). }
	                  claim Ha2b2: Rlt a2 b2.
	                  { exact (andER (a1 = b1) (Rlt a2 b2) Hc). }
	                  claim Heq: (eps_ 1) = b1.
	                  { prove (eps_ 1) = b1.
	                    rewrite <- Ha1eq at 1.
	                    exact Ha1b1. }
	                  claim Hltb2: Rlt (eps_ 1) b2.
	                  { prove Rlt (eps_ 1) b2.
	                    rewrite <- Ha2eq at 1.
	                    exact Ha2b2. }
	                  apply orIR.
	                  exact (andI ((eps_ 1) = b1) (Rlt (eps_ 1) b2) Heq Hltb2). }
	              (** extract coordinate information for p<b **)
	              apply Hex_pb.
	              let c1. assume Hex_c2.
	              apply Hex_c2.
	              let c2. assume Hex_d1.
	              apply Hex_d1.
	              let d1. assume Hex_d2.
	              apply Hex_d2.
	              let d2. assume Hpb.
	              claim Hcore2: p = (c1, c2) /\ b = (d1, d2).
	              { exact (andEL (p = (c1, c2) /\ b = (d1, d2))
	                            (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
	                            Hpb). }
              claim HpEq2: p = (c1, c2).
              { exact (andEL (p = (c1, c2)) (b = (d1, d2)) Hcore2). }
              claim HbEq: b = (d1, d2).
              { exact (andER (p = (c1, c2)) (b = (d1, d2)) Hcore2). }
              claim Hdisj2: Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2).
              { exact (andER (p = (c1, c2) /\ b = (d1, d2))
                            (Rlt c1 d1 \/ (c1 = d1 /\ Rlt c2 d2))
                            Hpb). }
              claim Hp0b1: p 0 = b1.
              { rewrite HpEq.
                exact (tuple_2_0_eq b1 b2). }
	              claim Hp0c1: p 0 = c1.
	              { rewrite HpEq2.
	                exact (tuple_2_0_eq c1 c2). }
	              claim Hc1eq: c1 = b1.
	              { prove c1 = b1.
	                rewrite <- Hp0c1 at 1.
	                exact Hp0b1. }
              claim Hp1b2: p 1 = b2.
              { rewrite HpEq.
                exact (tuple_2_1_eq b1 b2). }
	              claim Hp1c2: p 1 = c2.
	              { rewrite HpEq2.
	                exact (tuple_2_1_eq c1 c2). }
	              claim Hc2eq: c2 = b2.
	              { prove c2 = b2.
	                rewrite <- Hp1c2 at 1.
	                exact Hp1b2. }
              claim HbDef: b = (eps_ 1, 2).
              { reflexivity. }
              claim Hb0: b 0 = eps_ 1.
              { rewrite HbDef.
                exact (tuple_2_0_eq (eps_ 1) 2). }
              claim Hb1: b 1 = 2.
              { rewrite HbDef.
                exact (tuple_2_1_eq (eps_ 1) 2). }
              claim Hb0': b 0 = d1.
              { rewrite HbEq.
                exact (tuple_2_0_eq d1 d2). }
	              claim Hb1': b 1 = d2.
	              { rewrite HbEq.
	                exact (tuple_2_1_eq d1 d2). }
	              claim Hd1eq: d1 = eps_ 1.
	              { prove d1 = eps_ 1.
	                rewrite <- Hb0' at 1.
	                exact Hb0. }
	              claim Hd2eq: d2 = 2.
	              { prove d2 = 2.
	                rewrite <- Hb1' at 1.
	                exact Hb1. }
	              claim Hdisj2': Rlt b1 (eps_ 1) \/ (b1 = eps_ 1 /\ Rlt b2 2).
	              { apply (Hdisj2 (Rlt b1 (eps_ 1) \/ (b1 = eps_ 1 /\ Rlt b2 2))).
	                - assume Hlt: Rlt c1 d1.
		                  apply orIL.
		                  prove Rlt b1 (eps_ 1).
		                  rewrite <- Hc1eq at 1.
		                  rewrite <- Hd1eq.
		                  exact Hlt.
	                - assume Hc: c1 = d1 /\ Rlt c2 d2.
	                  claim Hc1d1: c1 = d1.
	                  { exact (andEL (c1 = d1) (Rlt c2 d2) Hc). }
	                  claim Hc2d2: Rlt c2 d2.
	                  { exact (andER (c1 = d1) (Rlt c2 d2) Hc). }
		                  claim Hb1eq: b1 = eps_ 1.
		                  { prove b1 = eps_ 1.
		                    rewrite <- Hc1eq at 1.
		                    rewrite <- Hd1eq.
		                    exact Hc1d1. }
		                  claim Hb2lt: Rlt b2 2.
		                  { prove Rlt b2 2.
		                    rewrite <- Hc2eq at 1.
		                    rewrite <- Hd2eq.
		                    exact Hc2d2. }
	                  apply orIR.
	                  exact (andI (b1 = eps_ 1) (Rlt b2 2) Hb1eq Hb2lt). }
	              (** compute y = b2 **)
	              claim HyP1: y = p 1.
	              { rewrite <- (proj1_ap_1 p).
	                reflexivity. }
	              claim HyEq: y = b2.
	              { prove y = b2.
	                rewrite HyP1.
	                exact Hp1b2. }
	              (** finish by eliminating the two-way disjunction for a<p **)
	              apply (Hdisj1' (p = (eps_ 1, y) /\ Rlt (eps_ 1) y)).
	              - assume Hlt: Rlt (eps_ 1) b1.
	                apply FalseE.
	                apply (Hdisj2' False).
	                - assume Hlt2: Rlt b1 (eps_ 1).
	                  exact ((not_Rlt_sym (eps_ 1) b1 Hlt) Hlt2).
	                - assume Hc: b1 = eps_ 1 /\ Rlt b2 2.
                  claim Hb1eq: b1 = eps_ 1.
                  { exact (andEL (b1 = eps_ 1) (Rlt b2 2) Hc). }
                  claim Hbad: Rlt (eps_ 1) (eps_ 1).
                  { rewrite <- Hb1eq at 2.
                    exact Hlt. }
                  exact ((not_Rlt_refl (eps_ 1) Heps1R) Hbad).
	              - assume Hc: (eps_ 1) = b1 /\ Rlt (eps_ 1) b2.
	                claim Heq: (eps_ 1) = b1.
	                { exact (andEL ((eps_ 1) = b1) (Rlt (eps_ 1) b2) Hc). }
	                claim Hltb2: Rlt (eps_ 1) b2.
	                { exact (andER ((eps_ 1) = b1) (Rlt (eps_ 1) b2) Hc). }
	                claim HpEq0: p = (eps_ 1, b2).
	                { prove p = (eps_ 1, b2).
	                  rewrite Heq.
	                  exact HpEq. }
	                claim HpEq1: p = (eps_ 1, y).
	                { prove p = (eps_ 1, y).
	                  rewrite HyEq.
	                  exact HpEq0. }
	                claim Hylt: Rlt (eps_ 1) y.
	                { rewrite HyEq.
	                  exact Hltb2. }
	                exact (andI (p = (eps_ 1, y)) (Rlt (eps_ 1) y) HpEq1 Hylt). }
            apply andI.
            - exact HpFirst.
            - exact Hyprop. }
	        exact (SepI ordered_square
	                    (fun p0:set => exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
	                    p
	                    HpSq
	                    Hexists).
    }
    claim Hex: exists W :e R2_dictionary_order_topology, U = W :/\: ordered_square.
    { witness V.
      apply andI.
      - exact HVTx.
      - exact HeqU. }
    exact (SepI (Power ordered_square)
                (fun U0:set => exists W :e R2_dictionary_order_topology, U0 = W :/\: ordered_square)
                U
                HUpow
                Hex).
  }
  claim HUprod: U :e Tprod.
  { rewrite <- Heq.
    exact HUdic.
  }
  claim HUnprod: ~(U :e Tprod).
  { (** U is not open in the product (standard) topology on I×I **)
    assume HUin: U :e Tprod.
	    set p0 := (eps_ 1, 1).
	    (** show p0 :e U **)
	    claim Hp0U: p0 :e U.
	    { (** eps_ 1 and 1 are in the unit interval **)
	      claim H1omega: 1 :e omega.
	      { exact (nat_p_omega 1 nat_1). }
	      claim Heps1SNoS: eps_ 1 :e SNoS_ omega.
	      { exact (SNo_eps_SNoS_omega 1 H1omega). }
      claim Heps1R: eps_ 1 :e R.
      { exact (SNoS_omega_real (eps_ 1) Heps1SNoS). }
      claim HdefR: R = real.
      { reflexivity. }
      claim H1R: 1 :e R.
      { rewrite HdefR. exact real_1. }
      claim H0R: 0 :e R.
      { rewrite HdefR. exact real_0. }
      claim H0in1: 0 :e 1.
      { claim H0Ord: ordinal 0.
        { exact (nat_p_ordinal 0 nat_0). }
        exact (ordinal_0_In_ordsucc 0 H0Ord). }
      claim Heps1lt1: eps_ 1 < 1.
      { claim Heps1ltE0: eps_ 1 < eps_ 0.
        { exact (SNo_eps_decr 1 H1omega 0 H0in1). }
        rewrite <- (eps_0_1) at 2.
        exact Heps1ltE0. }
      claim Heps1lt1R: Rlt (eps_ 1) 1.
      { exact (RltI (eps_ 1) 1 Heps1R H1R Heps1lt1). }
      claim H0lt1: Rlt 0 1.
      { exact (RltI 0 1 H0R H1R SNoLt_0_1). }
      claim H0lteps1: Rlt 0 (eps_ 1).
      { exact (RltI 0 (eps_ 1) H0R Heps1R (SNo_eps_pos 1 H1omega)). }
      claim Hnlt_eps10: ~(Rlt (eps_ 1) 0).
      { exact (not_Rlt_sym 0 (eps_ 1) H0lteps1). }
      claim Hnlt_1eps1: ~(Rlt 1 (eps_ 1)).
      { exact (not_Rlt_sym (eps_ 1) 1 Heps1lt1R). }
      claim Hnlt_10: ~(Rlt 1 0).
      { exact (not_Rlt_sym 0 1 H0lt1). }
      claim Hnlt_11: ~(Rlt 1 1).
      { exact (not_Rlt_refl 1 H1R). }
      claim Heps1U: (eps_ 1) :e unit_interval.
      { exact (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t))
                   (eps_ 1)
                   Heps1R
                   (andI (~(Rlt (eps_ 1) 0)) (~(Rlt 1 (eps_ 1))) Hnlt_eps10 Hnlt_1eps1)). }
      claim H1U: 1 :e unit_interval.
	      { exact (SepI R (fun t:set => ~(Rlt t 0) /\ ~(Rlt 1 t))
	                   1
	                   H1R
	                   (andI (~(Rlt 1 0)) (~(Rlt 1 1)) Hnlt_10 Hnlt_11)). }
		      claim Hp0Sq: p0 :e ordered_square.
		      { prove (eps_ 1, 1) :e setprod unit_interval unit_interval.
		        exact (tuple_2_setprod_by_pair_Sigma unit_interval unit_interval (eps_ 1) 1 Heps1U H1U). }
	      claim Hp0Ex: exists y:set, p0 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
	      { witness 1.
	        prove p0 = (eps_ 1,1) /\ Rlt (eps_ 1) 1 /\ ~(Rlt 1 1).
	        apply andI.
	        - apply andI.
	          + reflexivity.
	          + exact Heps1lt1R.
	        - exact Hnlt_11. }
	      exact (SepI ordered_square
	                  (fun q:set => exists y:set, q = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
	                  p0
	                  Hp0Sq
	                  Hp0Ex).
	    }
    (** use the defining refinement property of generated_topology for Tprod **)
    set X1 := setprod unit_interval unit_interval.
    set B1 := product_subbasis unit_interval unit_interval_topology unit_interval unit_interval_topology.
    claim HTdef: Tprod = generated_topology X1 B1.
    { reflexivity. }
    claim HUgen: U :e generated_topology X1 B1.
    { rewrite <- HTdef.
      exact HUin. }
    claim Href: forall x :e U, exists b :e B1, x :e b /\ b c= U.
    { exact (SepE2 (Power X1)
                   (fun U0:set => forall x :e U0, exists b :e B1, x :e b /\ b c= U0)
                   U
                   HUgen). }
    (** obtain a product-subbasis rectangle b with p0 :e b and b c= U **)
    claim Href0: exists b :e B1, p0 :e b /\ b c= U.
    { exact (Href p0 Hp0U). }
    (** destruct the subbasis element containing p0 **)
    apply Href0.
    let b0. assume Hb0pair.
    apply Hb0pair.
    assume Hb0B: b0 :e B1.
    assume Hb0core: p0 :e b0 /\ b0 c= U.
    claim Hp0b0: p0 :e b0.
    { exact (andEL (p0 :e b0) (b0 c= U) Hb0core). }
    claim Hb0subU: b0 c= U.
    { exact (andER (p0 :e b0) (b0 c= U) Hb0core). }
    (** expand membership in product_subbasis to obtain a rectangle representation **)
    apply (famunionE unit_interval_topology
                     (fun U0:set => {rectangle_set U0 V|V :e unit_interval_topology})
                     b0
                     Hb0B).
    let U0. assume HU0pair.
    apply HU0pair.
    assume HU0Tx: U0 :e unit_interval_topology.
    assume Hb0Repl: b0 :e {rectangle_set U0 V|V :e unit_interval_topology}.
    apply (ReplE unit_interval_topology (fun V0:set => rectangle_set U0 V0) b0 Hb0Repl).
    let V0. assume HV0pair.
    apply HV0pair.
    assume HV0Ty: V0 :e unit_interval_topology.
	    assume Hb0eq: b0 = rectangle_set U0 V0.
	    claim Hp0rect: p0 :e rectangle_set U0 V0.
	    { rewrite <- Hb0eq.
	      exact Hp0b0. }
    (** extract coordinate membership eps_1:e U0 and 1:e V0 **)
    claim Hp00: p0 0 = eps_ 1.
    { claim Hp0def: p0 = (eps_ 1, 1).
      { reflexivity. }
      rewrite Hp0def.
      exact (tuple_2_0_eq (eps_ 1) 1). }
    claim Hp01: p0 1 = 1.
    { claim Hp0def: p0 = (eps_ 1, 1).
      { reflexivity. }
      rewrite Hp0def.
      exact (tuple_2_1_eq (eps_ 1) 1). }
    claim HepsU0: (eps_ 1) :e U0.
    { claim Hp0U0: (p0 0) :e U0.
      { exact (ap0_Sigma U0 (fun _ : set => V0) p0 Hp0rect). }
      rewrite <- Hp00.
      exact Hp0U0. }
	    claim H1V0: 1 :e V0.
	    { claim Hp0V0: (p0 1) :e V0.
	      { exact (ap1_Sigma U0 (fun _ : set => V0) p0 Hp0rect). }
	      rewrite <- Hp01.
	      exact Hp0V0. }
	    (** choose another x in U0 distinct from eps_ 1 and form (x,1) in the rectangle **)
	    claim Hexother: exists x:set, x :e U0 /\ x <> eps_ 1.
	    { exact (unit_interval_open_neighborhood_has_other_point U0 HU0Tx HepsU0). }
	    apply Hexother.
	    let x. assume Hxpair.
	    claim HxU0: x :e U0.
	    { exact (andEL (x :e U0) (x <> eps_ 1) Hxpair). }
	    claim Hxneq: x <> eps_ 1.
	    { exact (andER (x :e U0) (x <> eps_ 1) Hxpair). }
	    set p1 := (x,1).
		    claim Hp1b0: p1 :e b0.
		    { rewrite Hb0eq.
		      prove p1 :e rectangle_set U0 V0.
		      exact (tuple_2_rectangle_set U0 V0 x 1 HxU0 H1V0). }
	    claim Hp1U: p1 :e U.
	    { exact (Hb0subU p1 Hp1b0). }
	    (** from p1:e U, extract p1=(eps_ 1,y) and compare first coordinates **)
	    claim Hstrip: exists y:set, p1 = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y).
	    { exact (SepE2 ordered_square
	                   (fun q:set => exists y:set, q = (eps_ 1,y) /\ Rlt (eps_ 1) y /\ ~(Rlt 1 y))
	                   p1
	                   Hp1U). }
		    apply Hstrip.
		    let y. assume Hyprop.
		    claim Hycore: p1 = (eps_ 1,y) /\ Rlt (eps_ 1) y.
		    { exact (andEL (p1 = (eps_ 1,y) /\ Rlt (eps_ 1) y)
		                  (~(Rlt 1 y))
		                  Hyprop). }
		    claim HyPair: p1 = (eps_ 1,y).
		    { exact (andEL (p1 = (eps_ 1,y))
		                  (Rlt (eps_ 1) y)
		                  Hycore). }
	    claim Hp10: p1 0 = x.
	    { claim Hp1def: p1 = (x,1).
	      { reflexivity. }
	      rewrite Hp1def.
	      exact (tuple_2_0_eq x 1). }
	    claim Hp10': p1 0 = eps_ 1.
	    { rewrite HyPair.
	      exact (tuple_2_0_eq (eps_ 1) y). }
	    claim Hxeq: x = eps_ 1.
	    { rewrite <- Hp10.
	      exact Hp10'. }
	    apply FalseE.
	    exact (Hxneq Hxeq).
	  }
	  exact (HUnprod HUprod).
Qed.

(** from §17 Definition: interior and closure of a set **) 
(** LATEX VERSION: Interior of A is union of opens inside A; closure of A consists of points whose every open neighborhood meets A. **)
Definition interior_of : set -> set -> set -> set := fun X T A =>
  {x :e X | exists U:set, U :e T /\ x :e U /\ U c= A}.
Definition closure_of : set -> set -> set -> set := fun X T A =>
  {x :e X | forall U:set, U :e T -> x :e U -> U :/\: A <> Empty}.

(** helper: in the finite complement topology, the closure of an infinite subset is all of X **)
(** LATEX VERSION: Not a numbered item; standard fact used when computing closures in the finite complement topology. **)
Theorem closure_infinite_finite_complement : forall X A:set,
  A c= X ->
  infinite A ->
  closure_of X (finite_complement_topology X) A = X.
let X A.
assume HAsub: A c= X.
assume HinfA: infinite A.
apply set_ext.
- (** closure subset X is definitional **)
  let x. assume Hx: x :e closure_of X (finite_complement_topology X) A.
  exact (SepE1 X (fun x0:set => forall U:set, U :e finite_complement_topology X -> x0 :e U -> U :/\: A <> Empty) x Hx).
- (** show every x :e X lies in the closure **)
  let x. assume HxX: x :e X.
  prove x :e closure_of X (finite_complement_topology X) A.
  claim Hcl: forall U:set, U :e finite_complement_topology X -> x :e U -> U :/\: A <> Empty.
  { let U. assume HU: U :e finite_complement_topology X.
    assume HxU: x :e U.
    prove U :/\: A <> Empty.
    (** In the finite complement topology: finite (X\\U) unless U is empty. **)
    claim HUne: U <> Empty.
    { exact (elem_implies_nonempty U x HxU). }
    claim HUcases: finite (X :\: U) \/ U = Empty.
    { exact (SepE2 (Power X) (fun U0:set => finite (X :\: U0) \/ U0 = Empty) U HU). }
    claim HfinComp: finite (X :\: U).
    { apply (HUcases (finite (X :\: U))).
      - assume Hfin. exact Hfin.
      - assume HUe.
        apply FalseE.
        exact (HUne HUe). }
    (** If U∩A were empty then A ⊆ X\\U, hence A finite, contradiction. **)
    assume Hempty: U :/\: A = Empty.
    claim Hsub: A c= X :\: U.
    { let a. assume HaA: a :e A.
      prove a :e X :\: U.
      claim HaX: a :e X.
      { exact (HAsub a HaA). }
      claim HanotU: a /:e U.
      { assume HaU: a :e U.
        claim HaUA: a :e U :/\: A.
        { exact (binintersectI U A a HaU HaA). }
        claim HaE: a :e Empty.
        { rewrite <- Hempty. exact HaUA. }
        exact (EmptyE a HaE). }
      exact (setminusI X U a HaX HanotU). }
    claim HfinA: finite A.
    { exact (Subq_finite (X :\: U) HfinComp A Hsub). }
    exact (HinfA HfinA). }
  exact (SepI X (fun x0:set => forall U:set, U :e finite_complement_topology X -> x0 :e U -> U :/\: A <> Empty) x HxX Hcl).
Qed.

(** Helper: A is a subset of its closure **)
Theorem subset_of_closure : forall X Tx A:set,
  topology_on X Tx -> A c= X -> A c= closure_of X Tx A.
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove A c= closure_of X Tx A.
let x. assume Hx: x :e A.
prove x :e closure_of X Tx A.
(** Show x :e X and for all U open containing x, U ∩ A ≠ ∅ **)
claim HxX: x :e X.
{ exact (HA x Hx). }
claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
{ let U. assume HU: U :e Tx. assume HxU: x :e U.
  prove U :/\: A <> Empty.
  assume Hempty: U :/\: A = Empty.
  (** Derive contradiction: x :e U and x :e A, so x :e U ∩ A **)
  claim HxUA: x :e U :/\: A.
  { exact (binintersectI U A x HxU Hx). }
  claim HxEmpty: x :e Empty.
  { rewrite <- Hempty. exact HxUA. }
  exact (EmptyE x HxEmpty). }
exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hcond).
Qed.

(** Helper: Closure is monotone **)
Theorem closure_monotone : forall X Tx A B:set,
  topology_on X Tx -> A c= B -> B c= X -> closure_of X Tx A c= closure_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HAB: A c= B.
assume HB: B c= X.
prove closure_of X Tx A c= closure_of X Tx B.
let x. assume Hx: x :e closure_of X Tx A.
prove x :e closure_of X Tx B.
(** x satisfies: x :e X and for all U open containing x, U ∩ A ≠ ∅ **)
claim HxX: x :e X.
{ exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
claim HcondA: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
{ exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
(** Need to show: for all U open containing x, U ∩ B ≠ ∅ **)
claim HcondB: forall U:set, U :e Tx -> x :e U -> U :/\: B <> Empty.
{ let U. assume HU: U :e Tx. assume HxU: x :e U.
  prove U :/\: B <> Empty.
  (** We know U ∩ A ≠ ∅, and A ⊆ B, so U ∩ A ⊆ U ∩ B **)
  claim HUA_ne: U :/\: A <> Empty.
  { exact (HcondA U HU HxU). }
  assume Hempty: U :/\: B = Empty.
  (** Show U ∩ A = ∅ by showing U ∩ A ⊆ U ∩ B = ∅ **)
  claim HUA_sub_UB: U :/\: A c= U :/\: B.
  { let y. assume Hy: y :e U :/\: A.
    claim HyU: y :e U.
    { exact (binintersectE1 U A y Hy). }
    claim HyA: y :e A.
    { exact (binintersectE2 U A y Hy). }
    claim HyB: y :e B.
    { exact (HAB y HyA). }
    exact (binintersectI U B y HyU HyB). }
  claim HUA_empty: U :/\: A = Empty.
  { apply Empty_Subq_eq.
    claim HUB_sub_Empty: U :/\: B c= Empty.
    { rewrite Hempty. exact (Subq_ref Empty). }
    exact (Subq_tra (U :/\: A) (U :/\: B) Empty HUA_sub_UB HUB_sub_Empty). }
  exact (HUA_ne HUA_empty). }
exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: B <> Empty) x HxX HcondB).
Qed.

(** Helper: closure in a finer topology is smaller **)
(** LATEX VERSION: If T1 is finer than T2, then cl_{T1}(A) ⊆ cl_{T2}(A). **)
Theorem closure_finer_than_Subq : forall X T1 T2 A:set,
  finer_than T1 T2 ->
  closure_of X T1 A c= closure_of X T2 A.
let X T1 T2 A.
assume Hfin: finer_than T1 T2.
prove closure_of X T1 A c= closure_of X T2 A.
let x. assume Hx: x :e closure_of X T1 A.
prove x :e closure_of X T2 A.
claim HxX: x :e X.
{ exact (SepE1 X (fun x0:set => forall U:set, U :e T1 -> x0 :e U -> U :/\: A <> Empty) x Hx). }
claim Hcond: forall U:set, U :e T1 -> x :e U -> U :/\: A <> Empty.
{ exact (SepE2 X (fun x0:set => forall U:set, U :e T1 -> x0 :e U -> U :/\: A <> Empty) x Hx). }
claim Hcond2: forall U:set, U :e T2 -> x :e U -> U :/\: A <> Empty.
{ let U. assume HU2: U :e T2. assume HxU: x :e U.
  prove U :/\: A <> Empty.
  claim HU1: U :e T1.
  { exact (Hfin U HU2). }
  exact (Hcond U HU1 HxU). }
exact (SepI X (fun x0:set => forall U:set, U :e T2 -> x0 :e U -> U :/\: A <> Empty) x HxX Hcond2).
Qed.

(** Helper: interior of A is contained in A **)
Theorem interior_subset : forall X Tx A:set,
  topology_on X Tx -> interior_of X Tx A c= A.
let X Tx A.
assume Htop: topology_on X Tx.
prove interior_of X Tx A c= A.
let x. assume Hx: x :e interior_of X Tx A.
prove x :e A.
claim Hexists: exists U:set, U :e Tx /\ x :e U /\ U c= A.
{ exact (SepE2 X (fun x0 => exists U:set, U :e Tx /\ x0 :e U /\ U c= A) x Hx). }
apply Hexists.
let U. assume HU_conj: U :e Tx /\ x :e U /\ U c= A.
(** Conjunction is left-associative: ((U :e Tx /\ x :e U) /\ U c= A) **)
claim HU_and_x: U :e Tx /\ x :e U.
{ exact (andEL (U :e Tx /\ x :e U) (U c= A) HU_conj). }
claim HUsub: U c= A.
{ exact (andER (U :e Tx /\ x :e U) (U c= A) HU_conj). }
claim HxU: x :e U.
{ exact (andER (U :e Tx) (x :e U) HU_and_x). }
exact (HUsub x HxU).
Qed.

(** Helper: interior is monotone **)
Theorem interior_monotone : forall X Tx A B:set,
  topology_on X Tx -> A c= B -> interior_of X Tx A c= interior_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HAB: A c= B.
prove interior_of X Tx A c= interior_of X Tx B.
let x. assume Hx: x :e interior_of X Tx A.
prove x :e interior_of X Tx B.
claim HxX: x :e X.
{ exact (SepE1 X (fun x0 => exists U:set, U :e Tx /\ x0 :e U /\ U c= A) x Hx). }
claim Hexists: exists U:set, U :e Tx /\ x :e U /\ U c= A.
{ exact (SepE2 X (fun x0 => exists U:set, U :e Tx /\ x0 :e U /\ U c= A) x Hx). }
apply Hexists.
let U. assume HU_conj: U :e Tx /\ x :e U /\ U c= A.
(** Conjunction is left-associative: ((U :e Tx /\ x :e U) /\ U c= A) **)
claim HU_and_x: U :e Tx /\ x :e U.
{ exact (andEL (U :e Tx /\ x :e U) (U c= A) HU_conj). }
claim HUsub_A: U c= A.
{ exact (andER (U :e Tx /\ x :e U) (U c= A) HU_conj). }
claim HU: U :e Tx.
{ exact (andEL (U :e Tx) (x :e U) HU_and_x). }
claim HxU: x :e U.
{ exact (andER (U :e Tx) (x :e U) HU_and_x). }
claim HUsub_B: U c= B.
{ exact (Subq_tra U A B HUsub_A HAB). }
(** Now construct the witness for x :e interior_of X Tx B **)
claim Hwitness: U :e Tx /\ x :e U /\ U c= B.
{ apply andI.
  - apply andI.
    + exact HU.
    + exact HxU.
  - exact HUsub_B. }
claim Hexists_B: exists V:set, V :e Tx /\ x :e V /\ V c= B.
{ witness U.
  exact Hwitness. }
exact (SepI X (fun x0 => exists V:set, V :e Tx /\ x0 :e V /\ V c= B) x HxX Hexists_B).
Qed.

(** Helper: open sets equal their interior **)
Theorem open_interior_eq : forall X Tx U:set,
  topology_on X Tx -> U :e Tx -> interior_of X Tx U = U.
let X Tx U.
assume Htop: topology_on X Tx.
assume HU: U :e Tx.
prove interior_of X Tx U = U.
apply set_ext.
- (** interior(U) ⊆ U **)
  exact (interior_subset X Tx U Htop).
- (** U ⊆ interior(U) **)
  let x. assume Hx: x :e U.
  prove x :e interior_of X Tx U.
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U Htop HU). }
  claim HxX: x :e X.
  { exact (HUsub x Hx). }
  claim Hwitness: U :e Tx /\ x :e U /\ U c= U.
  { apply andI.
    - apply andI.
      + exact HU.
      + exact Hx.
    - exact (Subq_ref U). }
  claim Hexists: exists V:set, V :e Tx /\ x :e V /\ V c= U.
  { witness U.
    exact Hwitness. }
  exact (SepI X (fun x0 => exists V:set, V :e Tx /\ x0 :e V /\ V c= U) x HxX Hexists).
Qed.

(** Helper: interior of empty set is empty **)
Theorem interior_of_empty : forall X Tx:set,
  topology_on X Tx -> interior_of X Tx Empty = Empty.
let X Tx.
assume Htop: topology_on X Tx.
prove interior_of X Tx Empty = Empty.
apply set_ext.
- (** interior(Empty) ⊆ Empty **)
  exact (interior_subset X Tx Empty Htop).
- (** Empty ⊆ interior(Empty) **)
  exact (Subq_Empty (interior_of X Tx Empty)).
Qed.

(** Helper: interior of whole space is the space **)
Theorem interior_of_space : forall X Tx:set,
  topology_on X Tx -> interior_of X Tx X = X.
let X Tx.
assume Htop: topology_on X Tx.
prove interior_of X Tx X = X.
claim HXopen: X :e Tx.
{ exact (topology_has_X X Tx Htop). }
exact (open_interior_eq X Tx X Htop HXopen).
Qed.

(** Helper: interior is open **)
Theorem interior_is_open : forall X Tx A:set,
  topology_on X Tx -> A c= X -> interior_of X Tx A :e Tx.
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove interior_of X Tx A :e Tx.
  (** Strategy: interior(A) is the union of all open sets contained in A; the union of a family of open sets is open. **)
set F := {U :e Tx | U c= A}.
claim Hint_eq_union: interior_of X Tx A = Union F.
{ apply set_ext.
  - (** interior(A) ⊆ Union(F) **)
    let x. assume Hx: x :e interior_of X Tx A.
    prove x :e Union F.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0 => exists U:set, U :e Tx /\ x0 :e U /\ U c= A) x Hx). }
    claim Hexists: exists U:set, U :e Tx /\ x :e U /\ U c= A.
    { exact (SepE2 X (fun x0 => exists U:set, U :e Tx /\ x0 :e U /\ U c= A) x Hx). }
    apply Hexists.
    let U. assume HU_conj: U :e Tx /\ x :e U /\ U c= A.
    claim HU_and_x: U :e Tx /\ x :e U.
    { exact (andEL (U :e Tx /\ x :e U) (U c= A) HU_conj). }
    claim HUsub: U c= A.
    { exact (andER (U :e Tx /\ x :e U) (U c= A) HU_conj). }
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (x :e U) HU_and_x). }
    claim HxU: x :e U.
    { exact (andER (U :e Tx) (x :e U) HU_and_x). }
    claim HUinF: U :e F.
    { apply SepI.
      - exact HU.
      - exact HUsub. }
    exact (UnionI F x U HxU HUinF).
  - (** Union(F) ⊆ interior(A) **)
    let x. assume Hx: x :e Union F.
    prove x :e interior_of X Tx A.
    apply (UnionE_impred F x Hx (x :e interior_of X Tx A)).
    let U. assume HxU: x :e U. assume HUinF: U :e F.
    claim HU: U :e Tx.
    { exact (SepE1 Tx (fun U0 => U0 c= A) U HUinF). }
    claim HUsub: U c= A.
    { exact (SepE2 Tx (fun U0 => U0 c= A) U HUinF). }
    claim HUsub_X: U c= X.
    { exact (topology_elem_subset X Tx U Htop HU). }
    claim HxX: x :e X.
    { exact (HUsub_X x HxU). }
    claim Hwitness: U :e Tx /\ x :e U /\ U c= A.
    { apply andI.
      - apply andI.
        + exact HU.
        + exact HxU.
      - exact HUsub. }
    claim Hexists: exists V:set, V :e Tx /\ x :e V /\ V c= A.
    { witness U. exact Hwitness. }
    exact (SepI X (fun x0 => exists V:set, V :e Tx /\ x0 :e V /\ V c= A) x HxX Hexists). }
(** Now show Union F is open **)
claim HF_sub_Tx: F c= Tx.
{ let U. assume HU: U :e F.
  exact (SepE1 Tx (fun U0 => U0 c= A) U HU). }
claim Hunion_in_Tx: Union F :e Tx.
{ exact (topology_union_closed X Tx F Htop HF_sub_Tx). }
(** By Hint_eq_union, interior_of X Tx A = Union F, so interior is open **)
(** Use equality: if A = B and B :e Tx, then A :e Tx **)
claim Heq_substitution: forall S T:set, S = T -> T :e Tx -> S :e Tx.
{ let S T. assume HeqST: S = T. assume HTinTx: T :e Tx.
  (** Rewrite S as T in the goal S :e Tx **)
  prove S :e Tx.
  claim HST_equiv: forall P:set -> prop, P T -> P S.
  { let P. assume HPT: P T.
    (** Use symmetry of equality and substitution **)
    prove P S.
    rewrite HeqST.
    exact HPT. }
  exact (HST_equiv (fun X0 => X0 :e Tx) HTinTx). }
exact (Heq_substitution (interior_of X Tx A) (Union F) Hint_eq_union Hunion_in_Tx).
Qed.

(** Helper: union of interiors contained in interior of union **)
Theorem interior_union_contains_union_interiors : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  interior_of X Tx A :\/: interior_of X Tx B c= interior_of X Tx (A :\/: B).
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove interior_of X Tx A :\/: interior_of X Tx B c= interior_of X Tx (A :\/: B).
(** Use monotonicity: A ⊆ A∪B and B ⊆ A∪B **)
claim HAB_union_A: A c= A :\/: B.
{ let x. assume Hx: x :e A. exact (binunionI1 A B x Hx). }
claim HAB_union_B: B c= A :\/: B.
{ let x. assume Hx: x :e B. exact (binunionI2 A B x Hx). }
claim HAB_sub: A :\/: B c= X.
{ let x. assume Hx: x :e A :\/: B.
  apply (binunionE A B x Hx).
  - assume HxA: x :e A. exact (HA x HxA).
  - assume HxB: x :e B. exact (HB x HxB). }
claim HintA: interior_of X Tx A c= interior_of X Tx (A :\/: B).
{ exact (interior_monotone X Tx A (A :\/: B) Htop HAB_union_A). }
claim HintB: interior_of X Tx B c= interior_of X Tx (A :\/: B).
{ exact (interior_monotone X Tx B (A :\/: B) Htop HAB_union_B). }
let x. assume Hx: x :e interior_of X Tx A :\/: interior_of X Tx B.
apply (binunionE (interior_of X Tx A) (interior_of X Tx B) x Hx).
- assume HxA: x :e interior_of X Tx A. exact (HintA x HxA).
- assume HxB: x :e interior_of X Tx B. exact (HintB x HxB).
Qed.

(** Helper: interior of intersection contains intersection of interiors **)
Theorem interior_intersection_contains_intersection : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  interior_of X Tx (A :/\: B) c= interior_of X Tx A :/\: interior_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove interior_of X Tx (A :/\: B) c= interior_of X Tx A :/\: interior_of X Tx B.
(** Use monotonicity: A ∩ B ⊆ A and A ∩ B ⊆ B **)
claim HAB_A: A :/\: B c= A.
{ exact (binintersect_Subq_1 A B). }
claim HAB_B: A :/\: B c= B.
{ exact (binintersect_Subq_2 A B). }
claim HintAB_A: interior_of X Tx (A :/\: B) c= interior_of X Tx A.
{ exact (interior_monotone X Tx (A :/\: B) A Htop HAB_A). }
claim HintAB_B: interior_of X Tx (A :/\: B) c= interior_of X Tx B.
{ exact (interior_monotone X Tx (A :/\: B) B Htop HAB_B). }
let x. assume Hx: x :e interior_of X Tx (A :/\: B).
apply binintersectI.
- exact (HintAB_A x Hx).
- exact (HintAB_B x Hx).
Qed.

(** Helper: interior of intersection of open sets **)
Theorem interior_intersection_of_opens : forall X Tx U V:set,
  topology_on X Tx -> U :e Tx -> V :e Tx ->
  interior_of X Tx (U :/\: V) = U :/\: V.
let X Tx U V.
assume Htop: topology_on X Tx.
assume HU: U :e Tx.
assume HV: V :e Tx.
prove interior_of X Tx (U :/\: V) = U :/\: V.
(** Strategy: U ∩ V is open (by topology axioms), and open sets equal their interior **)
claim HUV_open: U :/\: V :e Tx.
{ exact (lemma_intersection_two_open X Tx U V Htop HU HV). }
exact (open_interior_eq X Tx (U :/\: V) Htop HUV_open).
Qed.

(** Helper: interior is idempotent **)
Theorem interior_idempotent : forall X Tx A:set,
  topology_on X Tx -> A c= X -> interior_of X Tx (interior_of X Tx A) = interior_of X Tx A.
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove interior_of X Tx (interior_of X Tx A) = interior_of X Tx A.
(** Strategy: interior(A) is open, and open sets equal their interior **)
claim HintA_open: interior_of X Tx A :e Tx.
{ exact (interior_is_open X Tx A Htop HA). }
exact (open_interior_eq X Tx (interior_of X Tx A) Htop HintA_open).
Qed.

(** Helper: interior-closure duality **)

Theorem not_in_closure_has_disjoint_open : forall X Tx A x:set,
  topology_on X Tx -> A c= X -> x :e X -> x /:e closure_of X Tx A ->
  exists U:set, U :e Tx /\ x :e U /\ U :/\: A = Empty.
let X Tx A x.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HxX: x :e X.
assume Hxnotcl: x /:e closure_of X Tx A.
prove exists U:set, U :e Tx /\ x :e U /\ U :/\: A = Empty.
(** By definition, x ∈ cl(A) means x ∈ X and ∀U open, x ∈ U → U ∩ A ≠ ∅ **)
(** Since x ∉ cl(A) and x ∈ X, there must exist U open with x ∈ U and U ∩ A = ∅ **)
apply (xm (exists U:set, U :e Tx /\ x :e U /\ U :/\: A = Empty)).
- assume H. exact H.
- assume Hnoex: ~(exists U:set, U :e Tx /\ x :e U /\ U :/\: A = Empty).
  (** Then ∀U open, x ∈ U → U ∩ A ≠ ∅, which means x ∈ cl(A) **)
  apply FalseE.
  apply Hxnotcl.
  prove x :e closure_of X Tx A.
  prove x :e {y :e X | forall U:set, U :e Tx -> y :e U -> U :/\: A <> Empty}.
  apply SepI.
  + exact HxX.
  + prove forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
    let U. assume HU: U :e Tx. assume HxU: x :e U.
    prove U :/\: A <> Empty.
    assume Heq: U :/\: A = Empty.
    apply Hnoex.
    witness U.
    prove U :e Tx /\ x :e U /\ U :/\: A = Empty.
    apply andI.
    * apply andI.
      + exact HU.
      + exact HxU.
    * exact Heq.
Qed.

Theorem closure_is_closed : forall X Tx A:set,
  topology_on X Tx -> A c= X -> closed_in X Tx (closure_of X Tx A).
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove closed_in X Tx (closure_of X Tx A).
(** Strategy: Show X \ cl(A) is open by showing it's a union of open sets **)
(** For each x ∈ X \ cl(A), there exists open Uₓ with x ∈ Uₓ and Uₓ ∩ A = ∅ **)
(** Then X \ cl(A) = ⋃{Uₓ : x ∈ X \ cl(A)}, which is open **)
prove topology_on X Tx /\ (closure_of X Tx A c= X /\ exists U :e Tx, closure_of X Tx A = X :\: U).
apply andI.
- exact Htop.
- prove closure_of X Tx A c= X /\ exists U :e Tx, closure_of X Tx A = X :\: U.
  apply andI.
  + (** closure(A) ⊆ X **)
    prove closure_of X Tx A c= X.
    let x. assume Hx: x :e closure_of X Tx A.
    exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx).
  + (** Prove X \ cl(A) is open **)
    set Complement := X :\: closure_of X Tx A.
    set OpenFamily := {U :e Tx | U :/\: A = Empty}.
    claim Hcomp_eq: Complement = Union OpenFamily.
    { apply set_ext.
      - (** Complement ⊆ Union OpenFamily **)
        let x. assume Hx: x :e Complement.
        prove x :e Union OpenFamily.
        claim HxX: x :e X.
        { exact (setminusE1 X (closure_of X Tx A) x Hx). }
        claim Hxnotcl: x /:e closure_of X Tx A.
        { exact (setminusE2 X (closure_of X Tx A) x Hx). }
        claim Hexists: exists U:set, U :e Tx /\ x :e U /\ U :/\: A = Empty.
        { exact (not_in_closure_has_disjoint_open X Tx A x Htop HA HxX Hxnotcl). }
        apply Hexists.
        let U. assume HU_parts.
        claim HU_and_xU: U :e Tx /\ x :e U.
        { exact (andEL (U :e Tx /\ x :e U) (U :/\: A = Empty) HU_parts). }
        claim HU: U :e Tx.
        { exact (andEL (U :e Tx) (x :e U) HU_and_xU). }
        claim HxU: x :e U.
        { exact (andER (U :e Tx) (x :e U) HU_and_xU). }
        claim HUdisj: U :/\: A = Empty.
        { exact (andER (U :e Tx /\ x :e U) (U :/\: A = Empty) HU_parts). }
        claim HUinFam: U :e OpenFamily.
        { exact (SepI Tx (fun V => V :/\: A = Empty) U HU HUdisj). }
        exact (UnionI OpenFamily x U HxU HUinFam).
      - (** Union OpenFamily ⊆ Complement **)
        let x. assume Hx: x :e Union OpenFamily.
        prove x :e Complement.
        apply (UnionE_impred OpenFamily x Hx).
        let U. assume HxU: x :e U. assume HUFam: U :e OpenFamily.
        claim HU: U :e Tx.
        { exact (SepE1 Tx (fun V => V :/\: A = Empty) U HUFam). }
        claim HUdisj: U :/\: A = Empty.
        { exact (SepE2 Tx (fun V => V :/\: A = Empty) U HUFam). }
        claim HUsub: U c= X.
        { exact (topology_elem_subset X Tx U Htop HU). }
        claim HxX: x :e X.
        { exact (HUsub x HxU). }
        apply setminusI.
        + exact HxX.
        + assume Hxcl: x :e closure_of X Tx A.
          claim Hcond: forall V:set, V :e Tx -> x :e V -> V :/\: A <> Empty.
          { exact (SepE2 X (fun y => forall V:set, V :e Tx -> y :e V -> V :/\: A <> Empty) x Hxcl). }
          claim Hcontra: U :/\: A <> Empty.
          { exact (Hcond U HU HxU). }
          exact (Hcontra HUdisj). }
    claim Hopen_subset: OpenFamily c= Tx.
    { let U. assume HU: U :e OpenFamily.
      exact (SepE1 Tx (fun V => V :/\: A = Empty) U HU). }
    claim Hcomp_open: Complement :e Tx.
    { rewrite Hcomp_eq.
      exact (topology_union_closed X Tx OpenFamily Htop Hopen_subset). }
    witness Complement.
    apply andI.
    * exact Hcomp_open.
    * (** closure(A) = X \ Complement **)
      apply set_ext.
      + let x. assume Hx: x :e closure_of X Tx A.
        prove x :e X :\: Complement.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
        apply setminusI.
        * exact HxX.
        * assume Hxcomp: x :e Complement.
          claim Hxnotcl: x /:e closure_of X Tx A.
          { exact (setminusE2 X (closure_of X Tx A) x Hxcomp). }
          exact (Hxnotcl Hx).
      + let x. assume Hx: x :e X :\: Complement.
        prove x :e closure_of X Tx A.
        claim HxX: x :e X.
        { exact (setminusE1 X Complement x Hx). }
        claim Hxnotcomp: x /:e Complement.
        { exact (setminusE2 X Complement x Hx). }
        apply (xm (x :e closure_of X Tx A)).
        * assume H. exact H.
        * assume Hxnotcl: x /:e closure_of X Tx A.
          apply FalseE.
          apply Hxnotcomp.
          apply setminusI.
          - exact HxX.
          - exact Hxnotcl.
Qed.

Theorem interior_closure_complement_duality : forall X Tx A:set,
  topology_on X Tx -> A c= X ->
  interior_of X Tx A = X :\: closure_of X Tx (X :\: A).
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove interior_of X Tx A = X :\: closure_of X Tx (X :\: A).
(** Strategy: int(A) is the largest open subset of A; X \\ cl(X\\A) is open (complement of closed), and we show it equals int(A). **)
claim HXA_sub: X :\: A c= X.
{ let x. assume Hx: x :e X :\: A.
  exact (setminusE1 X A x Hx). }
(** cl(X\A) is closed, so X \ cl(X\A) is open **)
claim Hclosed: closed_in X Tx (closure_of X Tx (X :\: A)).
{ exact (closure_is_closed X Tx (X :\: A) Htop HXA_sub). }
(** Extract that there exists U open with cl(X\A) = X \ U, so X \ cl(X\A) = U is open **)
claim Hclosed_parts: topology_on X Tx /\ (closure_of X Tx (X :\: A) c= X /\ exists U :e Tx, closure_of X Tx (X :\: A) = X :\: U).
{ exact Hclosed. }
claim Hexists: exists U :e Tx, closure_of X Tx (X :\: A) = X :\: U.
{ claim Hpart2: closure_of X Tx (X :\: A) c= X /\ exists U :e Tx, closure_of X Tx (X :\: A) = X :\: U.
  { exact (andER (topology_on X Tx) (closure_of X Tx (X :\: A) c= X /\ exists U :e Tx, closure_of X Tx (X :\: A) = X :\: U) Hclosed_parts). }
  exact (andER (closure_of X Tx (X :\: A) c= X) (exists U :e Tx, closure_of X Tx (X :\: A) = X :\: U) Hpart2). }
apply Hexists.
let U. assume HU_conj: U :e Tx /\ closure_of X Tx (X :\: A) = X :\: U.
claim HU_open: U :e Tx.
{ exact (andEL (U :e Tx) (closure_of X Tx (X :\: A) = X :\: U) HU_conj). }
claim Heq_clXA: closure_of X Tx (X :\: A) = X :\: U.
{ exact (andER (U :e Tx) (closure_of X Tx (X :\: A) = X :\: U) HU_conj). }
(** Now show X \ cl(X\A) = U **)
claim HcompU: X :\: closure_of X Tx (X :\: A) = U.
{ apply set_ext.
  - let x. assume Hx: x :e X :\: closure_of X Tx (X :\: A).
    prove x :e U.
    claim HxX: x :e X.
    { exact (setminusE1 X (closure_of X Tx (X :\: A)) x Hx). }
    claim Hxnotcl: x /:e closure_of X Tx (X :\: A).
    { exact (setminusE2 X (closure_of X Tx (X :\: A)) x Hx). }
    (** From Heq_clXA: cl(X\A) = X \ U, so x ∉ cl(X\A) means x ∉ X \ U, i.e., x ∈ U **)
    apply (xm (x :e U)).
    + assume H. exact H.
    + assume HxnotU: x /:e U.
      apply FalseE.
      apply Hxnotcl.
      (** x ∈ X and x ∉ U, so x ∈ X \ U = cl(X\A) **)
      claim HxXminusU: x :e X :\: U.
      { apply setminusI. exact HxX. exact HxnotU. }
      (** Use Heq_clXA: cl(X\A) = X \ U **)
      prove x :e closure_of X Tx (X :\: A).
      rewrite Heq_clXA.
      exact HxXminusU.
  - let x. assume Hx: x :e U.
    prove x :e X :\: closure_of X Tx (X :\: A).
    claim HUsub: U c= X.
    { exact (topology_elem_subset X Tx U Htop HU_open). }
    claim HxX: x :e X.
    { exact (HUsub x Hx). }
    apply setminusI.
    + exact HxX.
    + assume Hxcl: x :e closure_of X Tx (X :\: A).
      (** From Heq_clXA: cl(X\A) = X \ U, so x ∈ cl(X\A) means x ∈ X \ U, so x ∉ U **)
      claim HxXminusU: x :e X :\: U.
      { rewrite <- Heq_clXA. exact Hxcl. }
      claim HxnotU: x /:e U.
      { exact (setminusE2 X U x HxXminusU). }
      exact (HxnotU Hx). }
(** Now show U ⊆ A **)
claim HUsub_A: U c= A.
{ let x. assume Hx: x :e U.
  prove x :e A.
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U Htop HU_open). }
  claim HxX: x :e X.
  { exact (HUsub x Hx). }
  apply (xm (x :e A)).
  - assume H. exact H.
  - assume HxnotA: x /:e A.
    (** Then x ∈ X \ A, so x ∈ cl(X\A) = X \ U, so x ∉ U, contradiction **)
    apply FalseE.
    claim HxXminusA: x :e X :\: A.
    { apply setminusI. exact HxX. exact HxnotA. }
    claim Hxincl: x :e closure_of X Tx (X :\: A).
    { exact (subset_of_closure X Tx (X :\: A) Htop HXA_sub x HxXminusA). }
    claim HxXminusU: x :e X :\: U.
    { rewrite <- Heq_clXA. exact Hxincl. }
    claim HxnotU: x /:e U.
    { exact (setminusE2 X U x HxXminusU). }
    exact (HxnotU Hx). }
(** Finally show int(A) = U **)
claim Hint_eq_U: interior_of X Tx A = U.
{ apply set_ext.
- (** int(A) ⊆ U **)
  let x. assume Hx: x :e interior_of X Tx A.
  prove x :e U.
  claim HxX: x :e X.
  { exact (SepE1 X (fun y => exists V:set, V :e Tx /\ y :e V /\ V c= A) x Hx). }
  claim Hexists_V: exists V:set, V :e Tx /\ x :e V /\ V c= A.
  { exact (SepE2 X (fun y => exists V:set, V :e Tx /\ y :e V /\ V c= A) x Hx). }
  apply Hexists_V.
  let V. assume HV_conj.
  claim HV_and_xV: V :e Tx /\ x :e V.
  { exact (andEL (V :e Tx /\ x :e V) (V c= A) HV_conj). }
  claim HV: V :e Tx.
  { exact (andEL (V :e Tx) (x :e V) HV_and_xV). }
  claim HxV: x :e V.
  { exact (andER (V :e Tx) (x :e V) HV_and_xV). }
  claim HVsub: V c= A.
  { exact (andER (V :e Tx /\ x :e V) (V c= A) HV_conj). }
  (** Show x ∉ cl(X\A), which means x ∈ U **)
  apply (xm (x :e U)).
  + assume H. exact H.
  + assume HxnotU: x /:e U.
    (** Then x ∈ X \ U = cl(X\A), but V is open with x ∈ V ⊆ A, so V ∩ (X\A) = ∅, contradiction **)
    apply FalseE.
    claim HxXminusU: x :e X :\: U.
    { apply setminusI. exact HxX. exact HxnotU. }
    claim Hxcl: x :e closure_of X Tx (X :\: A).
    { rewrite Heq_clXA. exact HxXminusU. }
    (** x ∈ cl(X\A) means V ∩ (X\A) ≠ ∅ **)
    claim Hcond: forall W:set, W :e Tx -> x :e W -> W :/\: (X :\: A) <> Empty.
    { exact (SepE2 X (fun y => forall W:set, W :e Tx -> y :e W -> W :/\: (X :\: A) <> Empty) x Hxcl). }
    claim HVmeets: V :/\: (X :\: A) <> Empty.
    { exact (Hcond V HV HxV). }
    (** But V ⊆ A, so V ∩ (X\A) = ∅ **)
    claim HVdisj: V :/\: (X :\: A) = Empty.
    { apply set_ext.
      - let y. assume Hy: y :e V :/\: (X :\: A).
        prove y :e Empty.
        claim HyV: y :e V.
        { exact (binintersectE1 V (X :\: A) y Hy). }
        claim HyXminusA: y :e X :\: A.
        { exact (binintersectE2 V (X :\: A) y Hy). }
        claim HyA: y :e A.
        { exact (HVsub y HyV). }
        claim HynotA: y /:e A.
        { exact (setminusE2 X A y HyXminusA). }
        apply FalseE.
        exact (HynotA HyA).
      - exact (Subq_Empty (V :/\: (X :\: A))). }
    exact (HVmeets HVdisj).
- (** U ⊆ int(A) **)
  let x. assume Hx: x :e U.
  prove x :e interior_of X Tx A.
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U Htop HU_open). }
  claim HxX: x :e X.
  { exact (HUsub x Hx). }
  prove x :e {y :e X | exists V:set, V :e Tx /\ y :e V /\ V c= A}.
  apply SepI.
  + exact HxX.
  + prove exists V:set, V :e Tx /\ x :e V /\ V c= A.
    witness U.
    prove U :e Tx /\ x :e U /\ U c= A.
    apply andI.
    * apply andI.
      - exact HU_open.
      - exact Hx.
    * exact HUsub_A. }
(** Now use HcompU to get the final result **)
prove interior_of X Tx A = X :\: closure_of X Tx (X :\: A).
rewrite HcompU.
exact Hint_eq_U.
Qed.


(** Helper: closure contains the set **)
Theorem closure_contains_set : forall X Tx A:set,
  topology_on X Tx -> A c= X -> A c= closure_of X Tx A.
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
exact (subset_of_closure X Tx A Htop HA).
Qed.

(** Helper: closure is in X **)
Theorem closure_in_space : forall X Tx A:set,
  topology_on X Tx -> closure_of X Tx A c= X.
let X Tx A.
assume Htop: topology_on X Tx.
prove closure_of X Tx A c= X.
let x. assume Hx: x :e closure_of X Tx A.
prove x :e X.
exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx).
Qed.

(** Helper: closure is contained in any closed superset **)
Theorem closure_subset_of_closed_superset : forall X Tx A C:set,
  topology_on X Tx ->
  A c= C ->
  closed_in X Tx C ->
  closure_of X Tx A c= C.
let X Tx A C.
assume Htop: topology_on X Tx.
assume HAC: A c= C.
assume HC: closed_in X Tx C.
prove closure_of X Tx A c= C.
let x. assume Hx: x :e closure_of X Tx A.
prove x :e C.
apply (xm (x :e C)).
- assume HxC: x :e C. exact HxC.
- assume HxnotC: x /:e C.
  claim HCparts: C c= X /\ exists U :e Tx, C = X :\: U.
  { exact (andER (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HC). }
  claim HxX: x :e X.
  { exact (closure_in_space X Tx A Htop x Hx). }
  claim HcondA: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
  { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
  apply (andER (C c= X) (exists U :e Tx, C = X :\: U) HCparts).
  let U. assume HUconj: U :e Tx /\ C = X :\: U.
  claim HU: U :e Tx.
  { exact (andEL (U :e Tx) (C = X :\: U) HUconj). }
  claim HCeq: C = X :\: U.
  { exact (andER (U :e Tx) (C = X :\: U) HUconj). }
  claim HxU: x :e U.
  { apply (xm (x :e U)).
    - assume H. exact H.
    - assume HxnotU: x /:e U.
      apply FalseE.
      apply HxnotC.
      claim HxXU: x :e X :\: U.
      { exact (setminusI X U x HxX HxnotU). }
      rewrite HCeq.
      exact HxXU. }
  claim HUAne: U :/\: A <> Empty.
  { exact (HcondA U HU HxU). }
  claim HUAempty: U :/\: A = Empty.
  { apply Empty_Subq_eq.
    let y. assume Hy: y :e U :/\: A.
    prove y :e Empty.
    claim HyU: y :e U.
    { exact (binintersectE1 U A y Hy). }
    claim HyA: y :e A.
    { exact (binintersectE2 U A y Hy). }
    claim HyC: y :e C.
    { exact (HAC y HyA). }
    claim HyXU: y :e X :\: U.
    { rewrite <- HCeq. exact HyC. }
    claim HynotU: y /:e U.
    { exact (setminusE2 X U y HyXU). }
    apply FalseE.
    exact (HynotU HyU). }
  apply FalseE.
  exact (HUAne HUAempty).
Qed.

(** Helper: closure of union contains union of closures **)
Theorem closure_union_contains_union_closures : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  closure_of X Tx A :\/: closure_of X Tx B c= closure_of X Tx (A :\/: B).
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove closure_of X Tx A :\/: closure_of X Tx B c= closure_of X Tx (A :\/: B).
(** Use monotonicity of closure with A c= A∪B and B c= A∪B **)
claim HAB_union: A c= A :\/: B.
{ let x. assume Hx: x :e A. exact (binunionI1 A B x Hx). }
claim HBB_union: B c= A :\/: B.
{ let x. assume Hx: x :e B. exact (binunionI2 A B x Hx). }
claim HAB_sub: A :\/: B c= X.
{ let x. assume Hx: x :e A :\/: B.
  apply (binunionE A B x Hx).
  - assume HxA: x :e A. exact (HA x HxA).
  - assume HxB: x :e B. exact (HB x HxB). }
claim HclA: closure_of X Tx A c= closure_of X Tx (A :\/: B).
{ exact (closure_monotone X Tx A (A :\/: B) Htop HAB_union HAB_sub). }
claim HclB: closure_of X Tx B c= closure_of X Tx (A :\/: B).
{ exact (closure_monotone X Tx B (A :\/: B) Htop HBB_union HAB_sub). }
let x. assume Hx: x :e closure_of X Tx A :\/: closure_of X Tx B.
apply (binunionE (closure_of X Tx A) (closure_of X Tx B) x Hx).
- assume HxA: x :e closure_of X Tx A. exact (HclA x HxA).
- assume HxB: x :e closure_of X Tx B. exact (HclB x HxB).
Qed.

(** Helper: closure of empty set is empty **)
Theorem closure_of_empty : forall X Tx:set,
  topology_on X Tx -> closure_of X Tx Empty = Empty.
let X Tx.
assume Htop: topology_on X Tx.
prove closure_of X Tx Empty = Empty.
apply set_ext.
- prove closure_of X Tx Empty c= Empty.
  let x. assume Hx: x :e closure_of X Tx Empty.
  prove x :e Empty.
  (** x :e closure means: x :e X and for all U open with x :e U, U ∩ Empty ≠ Empty; but U ∩ Empty = Empty, so this is impossible. **)
  apply (SepE X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: Empty <> Empty) x Hx).
  assume HxX: x :e X.
  assume Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: Empty <> Empty.
  (** Get X itself as an open set containing x **)
  claim HXopen: X :e Tx.
  { exact (topology_has_X X Tx Htop). }
  claim HXne: X :/\: Empty <> Empty.
  { exact (Hcond X HXopen HxX). }
  (** But X ∩ Empty = Empty **)
  claim HXempty: X :/\: Empty = Empty.
  { apply set_ext.
    - let y. assume Hy: y :e X :/\: Empty.
      exact (binintersectE2 X Empty y Hy).
    - exact (Subq_Empty (X :/\: Empty)). }
  apply HXne.
  exact HXempty.
- exact (Subq_Empty (closure_of X Tx Empty)).
Qed.

(** Helper: closure of the whole space is the space itself **)
Theorem closure_of_space : forall X Tx:set,
  topology_on X Tx -> closure_of X Tx X = X.
let X Tx.
assume Htop: topology_on X Tx.
prove closure_of X Tx X = X.
apply set_ext.
- exact (closure_in_space X Tx X Htop).
- exact (subset_of_closure X Tx X Htop (Subq_ref X)).
Qed.

(** Helper: union of two closed sets is closed **)
Theorem union_of_closed_is_closed : forall X Tx C D:set,
  topology_on X Tx -> closed_in X Tx C -> closed_in X Tx D ->
  closed_in X Tx (C :\/: D).
let X Tx C D.
assume Htop: topology_on X Tx.
assume HC: closed_in X Tx C.
assume HD: closed_in X Tx D.
prove closed_in X Tx (C :\/: D).
(** Proof: reuse the earlier lemma `closed_binunion`, which only needs `closed_in` hypotheses. **)
exact (closed_binunion X Tx C D HC HD).
Qed.

(** Helper: Empty is closed **)
Theorem empty_is_closed : forall X Tx:set,
  topology_on X Tx -> closed_in X Tx Empty.
let X Tx.
assume Htop: topology_on X Tx.
prove closed_in X Tx Empty.
(** Empty = X \ X, and X is open **)
prove topology_on X Tx /\ (Empty c= X /\ exists U :e Tx, Empty = X :\: U).
apply andI.
- exact Htop.
- apply andI.
  + exact (Subq_Empty X).
  + witness X.
    apply andI.
    * exact (topology_has_X X Tx Htop).
    * prove Empty = X :\: X.
      apply set_ext.
      - exact (Subq_Empty (X :\: X)).
      - let x. assume Hx: x :e X :\: X.
        claim HxX: x :e X.
        { exact (setminusE1 X X x Hx). }
        claim HxnotX: x /:e X.
        { exact (setminusE2 X X x Hx). }
        prove x :e Empty.
        apply FalseE.
        exact (HxnotX HxX).
Qed.

(** Helper: X is closed **)
Theorem space_is_closed : forall X Tx:set,
  topology_on X Tx -> closed_in X Tx X.
let X Tx.
assume Htop: topology_on X Tx.
prove closed_in X Tx X.
(** X = X \ Empty, and Empty is open **)
prove topology_on X Tx /\ (X c= X /\ exists U :e Tx, X = X :\: U).
apply andI.
- exact Htop.
- apply andI.
  + exact (Subq_ref X).
  + witness Empty.
    apply andI.
    * exact (topology_has_empty X Tx Htop).
    * prove X = X :\: Empty.
      apply set_ext.
      - let x. assume Hx: x :e X.
        apply setminusI.
        + exact Hx.
        + assume Hcontra: x :e Empty.
          exact (EmptyE x Hcontra False).
      - let x. assume Hx: x :e X :\: Empty.
        exact (setminusE1 X Empty x Hx).
Qed.

(** Helper: binary union as union of pair family **)
Theorem binunion_eq_Union_UPair : forall U V:set, U :\/: V = Union (UPair U V).
let U V.
apply set_ext.
- let x. assume Hx: x :e U :\/: V.
  apply (binunionE U V x Hx).
  + assume HxU: x :e U.
    apply (UnionI (UPair U V) x U HxU).
    exact (UPairI1 U V).
  + assume HxV: x :e V.
    apply (UnionI (UPair U V) x V HxV).
    exact (UPairI2 U V).
- let x. assume Hx: x :e Union (UPair U V).
  apply (UnionE_impred (UPair U V) x Hx (x :e U :\/: V)).
  let Z. assume HxZ: x :e Z. assume HZin: Z :e UPair U V.
  apply (UPairE Z U V HZin).
  + assume HZeqU: Z = U.
    claim HxU: x :e U.
    { rewrite <- HZeqU. exact HxZ. }
    exact (binunionI1 U V x HxU).
  + assume HZeqV: Z = V.
    claim HxV: x :e V.
    { rewrite <- HZeqV. exact HxZ. }
    exact (binunionI2 U V x HxV).
Qed.

(** Helper: union of a pair family equals binary union **)
Theorem Union_UPair_eq_binunion : forall U V:set, Union (UPair U V) = U :\/: V.
let U V.
rewrite (binunion_eq_Union_UPair U V).
reflexivity.
Qed.

(** Helper: Binary union of open sets is open **)
Theorem lemma_union_two_open : forall X T U V:set,
  topology_on X T -> U :e T -> V :e T -> U :\/: V :e T.
let X T U V.
assume HT: topology_on X T.
assume HU: U :e T.
assume HV: V :e T.
prove U :\/: V :e T.
claim HUFamSub: UPair U V c= T.
{ let W. assume HW: W :e UPair U V.
  apply (UPairE W U V HW).
  - assume HWeqU. rewrite HWeqU. exact HU.
  - assume HWeqV. rewrite HWeqV. exact HV. }
claim HUnion: Union (UPair U V) :e T.
{ exact (topology_union_closed X T (UPair U V) HT HUFamSub). }
rewrite <- (Union_UPair_eq_binunion U V).
exact HUnion.
Qed.

(** Helper: intersection of two closed sets is closed **)
Theorem intersection_of_closed_is_closed : forall X Tx C D:set,
  topology_on X Tx -> closed_in X Tx C -> closed_in X Tx D ->
  closed_in X Tx (C :/\: D).
let X Tx C D.
assume Htop: topology_on X Tx.
assume HC: closed_in X Tx C.
assume HD: closed_in X Tx D.
prove closed_in X Tx (C :/\: D).
(** Proof: reuse the earlier lemma `closed_binintersect`, which only needs `closed_in` hypotheses. **)
exact (closed_binintersect X Tx C D HC HD).
Qed.

Theorem closed_closure_eq : forall X Tx C:set,
  topology_on X Tx -> closed_in X Tx C -> closure_of X Tx C = C.
let X Tx C.
assume Htop: topology_on X Tx.
assume HC: closed_in X Tx C.
prove closure_of X Tx C = C.
(** closed_in means there exists U :e Tx such that C = X :\: U **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HC). }
claim HCsub_and_ex: C c= X /\ exists U :e Tx, C = X :\: U.
{ exact (andER (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HC). }
claim HCsub: C c= X.
{ exact (andEL (C c= X) (exists U :e Tx, C = X :\: U) HCsub_and_ex). }
apply set_ext.
- (** closure(C) ⊆ C **)
  prove closure_of X Tx C c= C.
  (** We show: x ∈ closure(C) implies x ∈ C; otherwise x ∈ X \\ C and X \\ C is open, contradicting that every open neighborhood of x meets C. **)
  let x. assume Hx: x :e closure_of X Tx C.
  prove x :e C.
  (** Use excluded middle **)
  apply (xm (x :e C)).
  + assume HxC: x :e C. exact HxC.
  + assume HxnotC: x /:e C.
    (** Get the open U such that C = X \ U **)
    claim Hex: exists U :e Tx, C = X :\: U.
    { exact (andER (C c= X) (exists U :e Tx, C = X :\: U) HCsub_and_ex). }
    apply Hex.
    let U. assume HU_conj: U :e Tx /\ C = X :\: U.
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (C = X :\: U) HU_conj). }
    claim HCeq: C = X :\: U.
    { exact (andER (U :e Tx) (C = X :\: U) HU_conj). }
    (** x ∈ closure(C) means x ∈ X and every open containing x meets C **)
    claim HxX: x :e X.
    { exact (closure_in_space X Tx C Htop x Hx). }
    claim Hcond: forall V:set, V :e Tx -> x :e V -> V :/\: C <> Empty.
    { exact (SepE2 X (fun x0 => forall V:set, V :e Tx -> x0 :e V -> V :/\: C <> Empty) x Hx). }
    (** Since x ∉ C and C = X \ U, we have x ∈ U **)
    claim HxU: x :e U.
    { (** x ∈ X and x ∉ C = X \ U implies x ∈ U **)
      apply (xm (x :e U)).
      - assume H. exact H.
      - assume HxnotU: x /:e U.
        (** Then x ∈ X \ U = C, contradicting x ∉ C **)
        apply HxnotC.
        claim HxXU: x :e X :\: U.
        { apply setminusI. exact HxX. exact HxnotU. }
        rewrite HCeq. exact HxXU. }
    (** Now U is open, x ∈ U, so U ∩ C ≠ Empty by Hcond **)
    claim HUC_ne: U :/\: C <> Empty.
    { exact (Hcond U HU HxU). }
    (** But U ∩ C = Empty since C = X \ U **)
    claim HUC_empty: U :/\: C = Empty.
    { apply set_ext.
      - let y. assume Hy: y :e U :/\: C.
        prove y :e Empty.
        claim HyU: y :e U.
        { exact (binintersectE1 U C y Hy). }
        claim HyC: y :e C.
        { exact (binintersectE2 U C y Hy). }
        (** C = X \ U, so y ∈ C means y ∈ X and y ∉ U **)
        claim HyXU: y :e X :\: U.
        { rewrite <- HCeq. exact HyC. }
        claim HynotU: y /:e U.
        { exact (setminusE2 X U y HyXU). }
        (** Contradiction: y ∈ U and y ∉ U **)
        apply FalseE.
        exact (HynotU HyU).
      - exact (Subq_Empty (U :/\: C)). }
    (** Contradiction **)
    apply FalseE.
    exact (HUC_ne HUC_empty).
- (** C ⊆ closure(C) **)
  exact (subset_of_closure X Tx C Htop HCsub).
Qed.

(** Helper: closure of intersection of closed sets **)
Theorem closure_intersection_of_closed : forall X Tx C D:set,
  topology_on X Tx -> closed_in X Tx C -> closed_in X Tx D ->
  closure_of X Tx (C :/\: D) = C :/\: D.
let X Tx C D.
assume Htop: topology_on X Tx.
assume HC: closed_in X Tx C.
assume HD: closed_in X Tx D.
prove closure_of X Tx (C :/\: D) = C :/\: D.
(** Strategy: C ∩ D is closed (by intersection_of_closed_is_closed), so closure(C ∩ D) = C ∩ D **)
claim HCD_closed: closed_in X Tx (C :/\: D).
{ exact (intersection_of_closed_is_closed X Tx C D Htop HC HD). }
claim HCD_sub: C :/\: D c= X.
{ let x. assume Hx: x :e C :/\: D.
  claim HxC: x :e C.
  { exact (binintersectE1 C D x Hx). }
  claim HC_sub: C c= X.
  { exact (andEL (C c= X) (exists U :e Tx, C = X :\: U)
           (andER (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HC)). }
  exact (HC_sub x HxC). }
apply set_ext.
- (** closure(C ∩ D) ⊆ C ∩ D **)
  let x. assume Hx: x :e closure_of X Tx (C :/\: D).
  prove x :e C :/\: D.
  rewrite <- (closed_closure_eq X Tx (C :/\: D) Htop HCD_closed).
  exact Hx.
- (** C ∩ D ⊆ closure(C ∩ D) **)
  exact (subset_of_closure X Tx (C :/\: D) Htop HCD_sub).
Qed.

(** Helper: closure of union of closed sets **)
Theorem closure_union_of_closed : forall X Tx C D:set,
  topology_on X Tx -> closed_in X Tx C -> closed_in X Tx D ->
  closure_of X Tx (C :\/: D) = C :\/: D.
let X Tx C D.
assume Htop: topology_on X Tx.
assume HC: closed_in X Tx C.
assume HD: closed_in X Tx D.
prove closure_of X Tx (C :\/: D) = C :\/: D.
(** Strategy: C ∪ D is closed (by closed set axioms), so closure(C ∪ D) = C ∪ D **)
(** First need to show C ∪ D is closed, then apply closed_closure_eq **)
(** First prove that union of two closed sets is closed **)
claim HCD_closed: closed_in X Tx (C :\/: D).
{ exact (union_of_closed_is_closed X Tx C D Htop HC HD). }
(** Now prove closure(C ∪ D) = C ∪ D directly **)
claim HCD_sub: C :\/: D c= X.
{ let x. assume Hx: x :e C :\/: D.
  apply (binunionE C D x Hx).
  - assume HxC: x :e C.
    claim HC_sub: C c= X.
    { exact (andEL (C c= X) (exists U :e Tx, C = X :\: U)
             (andER (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HC)). }
    exact (HC_sub x HxC).
  - assume HxD: x :e D.
    claim HD_sub: D c= X.
    { exact (andEL (D c= X) (exists V :e Tx, D = X :\: V)
             (andER (topology_on X Tx) (D c= X /\ exists V :e Tx, D = X :\: V) HD)). }
    exact (HD_sub x HxD). }
(** Prove closure(C ∪ D) = C ∪ D by double inclusion **)
apply set_ext.
- (** closure(C ∪ D) ⊆ C ∪ D **)
  (** Since C ∪ D is closed, closure(C ∪ D) ⊆ C ∪ D **)
  let x. assume Hx: x :e closure_of X Tx (C :\/: D).
  prove x :e C :\/: D.
  rewrite <- (closed_closure_eq X Tx (C :\/: D) Htop HCD_closed).
  exact Hx.
- (** C ∪ D ⊆ closure(C ∪ D) **)
  exact (subset_of_closure X Tx (C :\/: D) Htop HCD_sub).
Qed.

(** Helper: closure is idempotent **)
Theorem closure_idempotent : forall X Tx A:set,
  topology_on X Tx -> A c= X -> closure_of X Tx (closure_of X Tx A) = closure_of X Tx A.
let X Tx A.
assume Htop: topology_on X Tx.
assume HA: A c= X.
prove closure_of X Tx (closure_of X Tx A) = closure_of X Tx A.
(** Strategy: cl(cl(A)) is the closure of a closed set, so equals itself **)
(** Equivalently: cl(A) is closed, and closed sets equal their closure **)
claim HclA_sub: closure_of X Tx A c= X.
{ exact (closure_in_space X Tx A Htop). }
(** To show cl(cl(A)) = cl(A), use that cl(A) ⊆ cl(cl(A)) and cl(cl(A)) ⊆ cl(A) **)
apply set_ext.
- (** cl(cl(A)) ⊆ cl(A) **)
  (** Since cl(A) is closed, cl(cl(A)) = cl(A), so cl(cl(A)) ⊆ cl(A) **)
  claim HclA_closed: closed_in X Tx (closure_of X Tx A).
  { exact (closure_is_closed X Tx A Htop HA). }
  claim Heq: closure_of X Tx (closure_of X Tx A) = closure_of X Tx A.
  { exact (closed_closure_eq X Tx (closure_of X Tx A) Htop HclA_closed). }
  let x. assume Hx: x :e closure_of X Tx (closure_of X Tx A).
  rewrite <- Heq.
  exact Hx.
- (** cl(A) ⊆ cl(cl(A)) **)
  exact (subset_of_closure X Tx (closure_of X Tx A) Htop HclA_sub).
Qed.

(** Helper: closure of intersection is subset of intersection of closures **)
Theorem closure_intersection_contained : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  closure_of X Tx (A :/\: B) c= closure_of X Tx A :/\: closure_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove closure_of X Tx (A :/\: B) c= closure_of X Tx A :/\: closure_of X Tx B.
(** Use monotonicity: A ∩ B ⊆ A and A ∩ B ⊆ B **)
claim HAB_A: A :/\: B c= A.
{ exact (binintersect_Subq_1 A B). }
claim HAB_B: A :/\: B c= B.
{ exact (binintersect_Subq_2 A B). }
claim HAB_X: A :/\: B c= X.
{ let x. assume Hx: x :e A :/\: B.
  exact (HA x (binintersectE1 A B x Hx)). }
claim HclAB_A: closure_of X Tx (A :/\: B) c= closure_of X Tx A.
{ exact (closure_monotone X Tx (A :/\: B) A Htop HAB_A HA). }
claim HclAB_B: closure_of X Tx (A :/\: B) c= closure_of X Tx B.
{ exact (closure_monotone X Tx (A :/\: B) B Htop HAB_B HB). }
let x. assume Hx: x :e closure_of X Tx (A :/\: B).
apply binintersectI.
- exact (HclAB_A x Hx).
- exact (HclAB_B x Hx).
Qed.

(** Helper: closed sets equal their closure **)

(** from §17 Theorem 17.1: properties of closed sets **)
(** LATEX VERSION: Theorem 17.1: Closed sets contain X and ∅, are closed under arbitrary intersections and finite unions. **)
Theorem closed_sets_axioms : forall X T:set,
  topology_on X T ->
  let C := {X :\: U|U :e T} in
    X :e C /\ Empty :e C /\
    (forall F:set, F :e Power C -> intersection_of_family X F :e C) /\
    (forall A B:set, A :e C -> B :e C -> A :\/: B :e C).
let X T.
assume HT: topology_on X T.
prove let C := {X :\: U|U :e T} in
    X :e C /\ Empty :e C /\
    (forall F:set, F :e Power C -> intersection_of_family X F :e C) /\
    (forall A B:set, A :e C -> B :e C -> A :\/: B :e C).
set C := {X :\: U|U :e T}.
prove X :e C /\ Empty :e C /\
    (forall F:set, F :e Power C -> intersection_of_family X F :e C) /\
    (forall A B:set, A :e C -> B :e C -> A :\/: B :e C).
  (** Strategy: Use De Morgan laws and topology axioms: X = X\\∅, ∅ = X\\X, intersections of complements are complements of unions, and unions of complements are complements of intersections. **)
claim Hempty_in_T: Empty :e T.
{ exact (topology_has_empty X T HT). }
claim HX_in_T: X :e T.
{ exact (topology_has_X X T HT). }
(** Build the 4-way conjunction left-to-right **)
claim Hpart1: X :e C.
{ (** Use ReplEq: need to show exists U :e T such that X = X :\: U **)
  prove X :e {X :\: U|U :e T}.
  apply (ReplEq T (fun U => X :\: U) X).
  assume _ H. apply H.
  witness Empty.
  apply andI.
  * exact Hempty_in_T.
  * prove X = X :\: Empty.
    apply set_ext.
    - let x. assume Hx: x :e X.
      apply setminusI.
      + exact Hx.
      + assume Hcontra: x :e Empty.
        exact (EmptyE x Hcontra False).
    - let x. assume Hx: x :e X :\: Empty.
      exact (setminusE1 X Empty x Hx). }
claim Hpart2: X :e C /\ Empty :e C.
{ apply andI.
  - exact Hpart1.
  - prove Empty :e {X :\: U|U :e T}.
    apply (ReplEq T (fun U => X :\: U) Empty).
    assume _ H. apply H.
    witness X.
    apply andI.
    * exact HX_in_T.
    * prove Empty = X :\: X.
      apply set_ext.
      - let x. assume Hx: x :e Empty.
        exact (EmptyE x Hx (x :e X :\: X)).
      - let x. assume Hx: x :e X :\: X.
        claim HxX: x :e X.
        { exact (setminusE1 X X x Hx). }
        claim HxnotX: x /:e X.
        { exact (setminusE2 X X x Hx). }
        apply FalseE.
        exact (HxnotX HxX).
}
claim Hpart3: (X :e C /\ Empty :e C) /\ (forall F:set, F :e Power C -> intersection_of_family X F :e C).
{ apply andI.
  - exact Hpart2.
  - (** Arbitrary intersections: ∩(X\Uᵢ) = X \ (⋃Uᵢ) **)
    let F. assume HF: F :e Power C.
    prove intersection_of_family X F :e C.
    (** Handle empty case separately **)
    apply (xm (F = Empty)).
    + assume HFempty: F = Empty.
      (** With new definition: ∩∅ = X since all x in X vacuously satisfy "forall U :e Empty, x :e U" **)
      claim Hintersect_empty: intersection_of_family X F = X.
      { rewrite HFempty.
        (** intersection_of_family X ∅ = {x :e X | forall U :e ∅, x :e U} = X since condition is vacuous **)
        apply set_ext.
        - let x. assume Hx: x :e intersection_of_family X Empty.
          exact (SepE1 X (fun y => forall U0:set, U0 :e Empty -> y :e U0) x Hx).
        - let x. assume Hx: x :e X.
          (** Show x :e intersection_of_family X Empty **)
          claim Hvacuous: forall U0:set, U0 :e Empty -> x :e U0.
          { let U0. assume HU: U0 :e Empty.
            apply FalseE.
            exact (EmptyE U0 HU).
          }
          exact (SepI X (fun y => forall U0:set, U0 :e Empty -> y :e U0) x Hx Hvacuous).
      }
      rewrite Hintersect_empty.
      exact (andEL (X :e C) (Empty :e C) Hpart2).
    + assume HFnonempty: F <> Empty.
      (** Extract the family of open sets: G = {U :e T | X \ U :e F} **)
      set G := {U :e T | X :\: U :e F}.
      (** Show ∩F = X \ ⋃G **)
      prove intersection_of_family X F :e {X :\: U|U :e T}.
    apply (ReplEq T (fun U => X :\: U) (intersection_of_family X F)).
    assume _ H. apply H.
    witness (Union G).
    apply andI.
    * (** ⋃G :e T **)
      claim HGsub: G c= T.
      { let U. assume HU: U :e G.
        exact (SepE1 T (fun U0 => X :\: U0 :e F) U HU). }
      exact (topology_union_closed X T G HT HGsub).
    * (** ∩F = X \ ⋃G by De Morgan **)
      prove intersection_of_family X F = X :\: Union G.
      apply set_ext.
      - (** ∩F ⊆ X \ ⋃G **)
        let x. assume Hx: x :e intersection_of_family X F.
        prove x :e X :\: Union G.
        apply setminusI.
        + (** x ∈ X: directly from new definition of intersection_of_family X F **)
          exact (SepE1 X (fun y => forall U0:set, U0 :e F -> y :e U0) x Hx).
        + (** x ∉ ⋃G **)
          assume Hcontra: x :e Union G.
          apply (UnionE_impred G x Hcontra).
          let U. assume HxU: x :e U. assume HUG: U :e G.
          claim HXminusU_in_F: X :\: U :e F.
          { exact (SepE2 T (fun U0 => X :\: U0 :e F) U HUG). }
          claim Hxall: forall Y :e F, x :e Y.
          { exact (SepE2 X (fun y => forall U0:set, U0 :e F -> y :e U0) x Hx). }
          claim Hx_in_XminusU: x :e X :\: U.
          { exact (Hxall (X :\: U) HXminusU_in_F). }
          claim HxnotU: x /:e U.
          { exact (setminusE2 X U x Hx_in_XminusU). }
          exact (HxnotU HxU).
      - (** X \ ⋃G ⊆ ∩F **)
        let x. assume Hx: x :e X :\: Union G.
        prove x :e intersection_of_family X F.
        claim HxX: x :e X.
        { exact (setminusE1 X (Union G) x Hx). }
        claim HxnotUG: x /:e Union G.
        { exact (setminusE2 X (Union G) x Hx). }
        (** Show x ∈ X and forall Y :e F, x :e Y **)
        prove x :e {y :e X|forall U0:set, U0 :e F -> y :e U0}.
        apply SepI.
        + (** x ∈ X: already have this **)
          exact HxX.
        + (** forall Y :e F, x :e Y **)
          let Y. assume HYF: Y :e F.
          prove x :e Y.
          claim HYC: Y :e C.
          { exact (PowerE C F HF Y HYF). }
          apply (ReplE T (fun U => X :\: U) Y HYC).
          let U. assume H. apply H.
          assume HU: U :e T. assume HYeq: Y = X :\: U.
          claim HUG: U :e G.
          { apply SepI.
            - exact HU.
            - prove X :\: U :e F.
              rewrite <- HYeq. exact HYF. }
          claim HxnotU: x /:e U.
          { assume Hcontra: x :e U.
            apply HxnotUG.
            exact (UnionI G x U Hcontra HUG). }
          rewrite HYeq.
          apply setminusI.
          * exact HxX.
          * exact HxnotU.
}
apply andI.
- exact Hpart3.
- (** Binary unions: (X\U) ∪ (X\V) = X \ (U ∩ V) **)
  let A B. assume HA: A :e C. assume HB: B :e C.
  prove A :\/: B :e C.
  (** A = X \ U for some U ∈ T **)
  apply (ReplE T (fun U => X :\: U) A HA).
  let U. assume H1. apply H1.
  assume HU: U :e T. assume HAeq: A = X :\: U.
  (** B = X \ V for some V ∈ T **)
  apply (ReplE T (fun U => X :\: U) B HB).
  let V. assume H2. apply H2.
  assume HV: V :e T. assume HBeq: B = X :\: V.
  (** Show A ∪ B = X \ (U ∩ V) and U ∩ V ∈ T **)
  prove A :\/: B :e {X :\: W|W :e T}.
  apply (ReplEq T (fun W => X :\: W) (A :\/: B)).
  assume _ H. apply H.
  witness (U :/\: V).
  apply andI.
  * (** U ∩ V ∈ T **)
    exact (topology_binintersect_closed X T U V HT HU HV).
  * (** A ∪ B = X \ (U ∩ V) by De Morgan **)
    prove A :\/: B = X :\: (U :/\: V).
    rewrite HAeq. rewrite HBeq.
    apply set_ext.
    + (** (X\U) ∪ (X\V) ⊆ X \ (U ∩ V) **)
      let x. assume Hx: x :e (X :\: U) :\/: (X :\: V).
      apply (binunionE (X :\: U) (X :\: V) x Hx).
      - assume HxA: x :e X :\: U.
        claim HxX: x :e X.
        { exact (setminusE1 X U x HxA). }
        claim HxnotU: x /:e U.
        { exact (setminusE2 X U x HxA). }
        apply setminusI.
        * exact HxX.
        * assume Hcontra: x :e U :/\: V.
          claim HxU: x :e U.
          { exact (binintersectE1 U V x Hcontra). }
          exact (HxnotU HxU).
      - assume HxB: x :e X :\: V.
        claim HxX: x :e X.
        { exact (setminusE1 X V x HxB). }
        claim HxnotV: x /:e V.
        { exact (setminusE2 X V x HxB). }
        apply setminusI.
        * exact HxX.
        * assume Hcontra: x :e U :/\: V.
          claim HxV: x :e V.
          { exact (binintersectE2 U V x Hcontra). }
          exact (HxnotV HxV).
    + (** X \ (U ∩ V) ⊆ (X\U) ∪ (X\V) **)
      let x. assume Hx: x :e X :\: (U :/\: V).
      claim HxX: x :e X.
      { exact (setminusE1 X (U :/\: V) x Hx). }
      claim HxnotUV: x /:e U :/\: V.
      { exact (setminusE2 X (U :/\: V) x Hx). }
      (** x ∉ U ∩ V means x ∉ U or x ∉ V **)
      apply (xm (x :e U)).
      - assume HxU: x :e U.
        (** Then x ∉ V, so x ∈ X \ V **)
        claim HxnotV: x /:e V.
        { assume HxV: x :e V.
          apply HxnotUV.
          exact (binintersectI U V x HxU HxV). }
        apply binunionI2.
        exact (setminusI X V x HxX HxnotV).
      - assume HxnotU: x /:e U.
        (** Then x ∈ X \ U **)
        apply binunionI1.
        exact (setminusI X U x HxX HxnotU).
Qed.

(** from §17 Theorem 17.2: closed sets in subspaces as intersections **) 
(** LATEX VERSION: Closed sets in a subspace are precisely intersections of the subspace with closed sets of the ambient space. **)
Theorem closed_in_subspace_iff_intersection : forall X Tx Y A:set,
  topology_on X Tx -> Y c= X ->
  (closed_in Y (subspace_topology X Tx Y) A <->
   exists C:set, closed_in X Tx C /\ A = C :/\: Y).
let X Tx Y A.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
prove closed_in Y (subspace_topology X Tx Y) A <-> exists C:set, closed_in X Tx C /\ A = C :/\: Y.
apply iffI.
- assume HAclosed: closed_in Y (subspace_topology X Tx Y) A.
  prove exists C:set, closed_in X Tx C /\ A = C :/\: Y.
  claim HTsubspace: topology_on Y (subspace_topology X Tx Y).
  { exact (subspace_topology_is_topology X Tx Y HTx HY). }
  claim HAdef: topology_on Y (subspace_topology X Tx Y) /\ (A c= Y /\ exists U :e subspace_topology X Tx Y, A = Y :\: U).
  { exact HAclosed. }
  claim HAandEx: A c= Y /\ exists U :e subspace_topology X Tx Y, A = Y :\: U.
  { exact (andER (topology_on Y (subspace_topology X Tx Y)) (A c= Y /\ exists U :e subspace_topology X Tx Y, A = Y :\: U) HAdef). }
  claim HexU: exists U :e subspace_topology X Tx Y, A = Y :\: U.
  { exact (andER (A c= Y) (exists U :e subspace_topology X Tx Y, A = Y :\: U) HAandEx). }
  apply HexU.
  let U. assume HandEq. apply HandEq.
  assume HUsubspace: U :e subspace_topology X Tx Y.
  assume HAeq: A = Y :\: U.
claim HUexV: exists V :e Tx, U = V :/\: Y.
{ exact (subspace_topologyE X Tx Y U HUsubspace). }
apply HUexV.
let V. assume HVandEq. apply HVandEq.
assume HV: V :e Tx. assume HUeq: U = V :/\: Y.
  set C := X :\: V.
  claim HCclosed: closed_in X Tx C.
  { prove topology_on X Tx /\ (C c= X /\ exists W :e Tx, C = X :\: W).
    apply andI.
    - exact HTx.
    - apply andI.
      + exact (setminus_Subq X V).
      + witness V.
        apply andI.
        * exact HV.
        * reflexivity.
  }
  claim HAeqC: A = C :/\: Y.
  { rewrite HAeq.
    rewrite HUeq.
    prove Y :\: (V :/\: Y) = (X :\: V) :/\: Y.
    apply set_ext.
    - let x. assume Hx: x :e Y :\: (V :/\: Y).
      claim HxY: x :e Y.
      { exact (setminusE1 Y (V :/\: Y) x Hx). }
      claim HxnotVY: x /:e V :/\: Y.
      { exact (setminusE2 Y (V :/\: Y) x Hx). }
      claim HxnotV: x /:e V.
      { assume HxV: x :e V.
        apply HxnotVY.
        apply binintersectI.
        - exact HxV.
        - exact HxY.
      }
      claim HxX: x :e X.
      { exact (HY x HxY). }
      apply binintersectI.
      + apply setminusI.
        * exact HxX.
        * exact HxnotV.
      + exact HxY.
    - let x. assume Hx: x :e (X :\: V) :/\: Y.
      claim HxXV: x :e X :\: V.
      { exact (binintersectE1 (X :\: V) Y x Hx). }
      claim HxY: x :e Y.
      { exact (binintersectE2 (X :\: V) Y x Hx). }
      claim HxnotV: x /:e V.
      { exact (setminusE2 X V x HxXV). }
      apply setminusI.
      + exact HxY.
      + assume HxVY: x :e V :/\: Y.
        apply HxnotV.
        exact (binintersectE1 V Y x HxVY).
  }
  witness C.
  apply andI.
  - exact HCclosed.
  - exact HAeqC.
- assume Hexists: exists C:set, closed_in X Tx C /\ A = C :/\: Y.
  prove closed_in Y (subspace_topology X Tx Y) A.
  apply Hexists.
  let C. assume HCandEq. apply HCandEq.
  assume HCclosed: closed_in X Tx C.
  assume HAeq: A = C :/\: Y.
  claim HTsubspace: topology_on Y (subspace_topology X Tx Y).
  { exact (subspace_topology_is_topology X Tx Y HTx HY). }
  claim HCdef: topology_on X Tx /\ (C c= X /\ exists V :e Tx, C = X :\: V).
  { exact HCclosed. }
  claim HCandEx: C c= X /\ exists V :e Tx, C = X :\: V.
  { exact (andER (topology_on X Tx) (C c= X /\ exists V :e Tx, C = X :\: V) HCdef). }
  claim HexV: exists V :e Tx, C = X :\: V.
  { exact (andER (C c= X) (exists V :e Tx, C = X :\: V) HCandEx). }
  apply HexV.
  let V. assume HVandEq. apply HVandEq.
  assume HV: V :e Tx. assume HCeq: C = X :\: V.
  set U := V :/\: Y.
  claim HUsubspace: U :e subspace_topology X Tx Y.
  { claim HUinPowerY: U :e Power Y.
    { apply PowerI.
      exact (binintersect_Subq_2 V Y). }
    claim HPred: exists W :e Tx, U = W :/\: Y.
    { witness V.
      apply andI.
      - exact HV.
      - reflexivity.
    }
    exact (SepI (Power Y) (fun U0:set => exists W :e Tx, U0 = W :/\: Y) U HUinPowerY HPred).
  }
  claim HAeqYU: A = Y :\: U.
  { rewrite HAeq.
    rewrite HCeq.
    prove (X :\: V) :/\: Y = Y :\: (V :/\: Y).
    apply set_ext.
    - let x. assume Hx: x :e (X :\: V) :/\: Y.
      claim HxXV: x :e X :\: V.
      { exact (binintersectE1 (X :\: V) Y x Hx). }
      claim HxY: x :e Y.
      { exact (binintersectE2 (X :\: V) Y x Hx). }
      claim HxnotV: x /:e V.
      { exact (setminusE2 X V x HxXV). }
      apply setminusI.
      + exact HxY.
      + assume HxVY: x :e V :/\: Y.
        apply HxnotV.
        exact (binintersectE1 V Y x HxVY).
    - let x. assume Hx: x :e Y :\: (V :/\: Y).
      claim HxY: x :e Y.
      { exact (setminusE1 Y (V :/\: Y) x Hx). }
      claim HxnotVY: x /:e V :/\: Y.
      { exact (setminusE2 Y (V :/\: Y) x Hx). }
      claim HxnotV: x /:e V.
      { assume HxV: x :e V.
        apply HxnotVY.
        apply binintersectI.
        - exact HxV.
        - exact HxY.
      }
      claim HxX: x :e X.
      { exact (HY x HxY). }
      apply binintersectI.
      + apply setminusI.
        * exact HxX.
        * exact HxnotV.
      + exact HxY.
  }
  claim HAsub: A c= Y.
  { rewrite HAeq.
    exact (binintersect_Subq_2 C Y). }
  prove topology_on Y (subspace_topology X Tx Y) /\ (A c= Y /\ exists U :e subspace_topology X Tx Y, A = Y :\: U).
  apply andI.
  - exact HTsubspace.
  - apply andI.
    + exact HAsub.
    + witness U.
      apply andI.
      * exact HUsubspace.
      * exact HAeqYU.
Qed.

(** from §17 Theorem 17.3: closedness passes up when subspace is closed **) 
(** LATEX VERSION: If Y is closed in X, a set closed in the subspace Y is closed in X. **)
Theorem closed_in_closed_subspace : forall X Tx Y A:set,
  topology_on X Tx -> closed_in X Tx Y ->
  closed_in Y (subspace_topology X Tx Y) A ->
  closed_in X Tx A.
let X Tx Y A.
assume HTx: topology_on X Tx.
assume HY: closed_in X Tx Y.
assume HA: closed_in Y (subspace_topology X Tx Y) A.
prove closed_in X Tx A.
  (** Strategy: A = C ∩ Y with C closed in X; write C = X\\U and Y = X\\V, then A = X\\(U∪V) and U∪V is open. **)
claim HYsub: Y c= X.
{ exact (andEL (Y c= X) (exists U :e Tx, Y = X :\: U) (andER (topology_on X Tx) (Y c= X /\ exists U :e Tx, Y = X :\: U) HY)). }
claim Hexists: exists C:set, closed_in X Tx C /\ A = C :/\: Y.
{ apply (iffEL (closed_in Y (subspace_topology X Tx Y) A) (exists C:set, closed_in X Tx C /\ A = C :/\: Y) (closed_in_subspace_iff_intersection X Tx Y A HTx HYsub)).
  exact HA. }
apply Hexists.
let C.
assume HCandA: closed_in X Tx C /\ A = C :/\: Y.
claim HCclosed: closed_in X Tx C.
{ exact (andEL (closed_in X Tx C) (A = C :/\: Y) HCandA). }
claim HAeq: A = C :/\: Y.
{ exact (andER (closed_in X Tx C) (A = C :/\: Y) HCandA). }
(** C is closed in X, so C = X \ U for some U ∈ Tx **)
claim HCexists: exists U :e Tx, C = X :\: U.
{ exact (andER (C c= X) (exists U :e Tx, C = X :\: U) (andER (topology_on X Tx) (C c= X /\ exists U :e Tx, C = X :\: U) HCclosed)). }
apply HCexists.
let U.
assume HU: U :e Tx /\ C = X :\: U.
claim HUinTx: U :e Tx.
{ exact (andEL (U :e Tx) (C = X :\: U) HU). }
claim HCeq: C = X :\: U.
{ exact (andER (U :e Tx) (C = X :\: U) HU). }
(** Y is closed in X, so Y = X \ V for some V ∈ Tx **)
claim HYexists: exists V :e Tx, Y = X :\: V.
{ exact (andER (Y c= X) (exists V :e Tx, Y = X :\: V) (andER (topology_on X Tx) (Y c= X /\ exists V :e Tx, Y = X :\: V) HY)). }
apply HYexists.
let V.
assume HV: V :e Tx /\ Y = X :\: V.
claim HVinTx: V :e Tx.
{ exact (andEL (V :e Tx) (Y = X :\: V) HV). }
claim HYeq: Y = X :\: V.
{ exact (andER (V :e Tx) (Y = X :\: V) HV). }
(** Now A = C ∩ Y = (X\U) ∩ (X\V) = X \ (U∪V) **)
claim HAeqSetminus: A = (X :\: U) :/\: (X :\: V).
{ rewrite HAeq.
  rewrite HCeq.
  rewrite HYeq.
  reflexivity. }
(** Prove (X\U) ∩ (X\V) = X \ (U∪V) by set extensionality **)
claim HDeM: (X :\: U) :/\: (X :\: V) = X :\: (U :\/: V).
{ apply set_ext.
  - let x.
    assume Hx: x :e (X :\: U) :/\: (X :\: V).
    prove x :e X :\: (U :\/: V).
    claim HxXU: x :e X :\: U.
    { exact (binintersectE1 (X :\: U) (X :\: V) x Hx). }
    claim HxXV: x :e X :\: V.
    { exact (binintersectE2 (X :\: U) (X :\: V) x Hx). }
    claim HxX: x :e X.
    { exact (setminusE1 X U x HxXU). }
    claim HxninU: x /:e U.
    { exact (setminusE2 X U x HxXU). }
    claim HxninV: x /:e V.
    { exact (setminusE2 X V x HxXV). }
    apply setminusI.
    + exact HxX.
    + assume HxUV: x :e U :\/: V.
      prove False.
      apply (binunionE U V x HxUV).
      * assume HxU: x :e U.
        exact (HxninU HxU).
      * assume HxV: x :e V.
        exact (HxninV HxV).
  - let x.
    assume Hx: x :e X :\: (U :\/: V).
    prove x :e (X :\: U) :/\: (X :\: V).
    claim HxX: x :e X.
    { exact (setminusE1 X (U :\/: V) x Hx). }
    claim HxninUV: x /:e U :\/: V.
    { exact (setminusE2 X (U :\/: V) x Hx). }
    apply binintersectI.
    + prove x :e X :\: U.
      apply setminusI.
      * exact HxX.
      * assume HxU: x :e U.
        prove False.
        claim HxUV: x :e U :\/: V.
        { exact (binunionI1 U V x HxU). }
        exact (HxninUV HxUV).
    + prove x :e X :\: V.
      apply setminusI.
      * exact HxX.
      * assume HxV: x :e V.
        prove False.
        claim HxUV: x :e U :\/: V.
        { exact (binunionI2 U V x HxV). }
        exact (HxninUV HxUV). }
(** So A = X \ (U∪V), and since U,V ∈ Tx, we have U∪V ∈ Tx **)
  claim HUV: U :\/: V :e Tx.
  { exact (lemma_union_two_open X Tx U V HTx HUinTx HVinTx). }
  (** Now A = X \ (U∪V) where U∪V ∈ Tx **)
  claim HAeqFinal: A = X :\: (U :\/: V).
  { rewrite HAeqSetminus.
    exact HDeM. }
(** Therefore A is closed in X **)
prove topology_on X Tx /\ (A c= X /\ exists U0 :e Tx, A = X :\: U0).
apply andI.
- exact HTx.
- apply andI.
  + prove A c= X.
    rewrite HAeqFinal.
    exact (setminus_Subq X (U :\/: V)).
  + prove exists U0 :e Tx, A = X :\: U0.
    witness (U :\/: V).
    apply andI.
    * exact HUV.
    * exact HAeqFinal.
Qed.

(** from §17 Theorem 17.4: closure in subspace equals intersection **)
(** LATEX VERSION: Closure in a subspace equals the ambient closure intersected with the subspace. **)
Theorem closure_in_subspace : forall X Tx Y A:set,
  topology_on X Tx -> Y c= X -> A c= Y ->
  closure_of Y (subspace_topology X Tx Y) A = (closure_of X Tx A) :/\: Y.
let X Tx Y A.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
assume HA: A c= Y.
prove closure_of Y (subspace_topology X Tx Y) A = (closure_of X Tx A) :/\: Y.
claim HTy: topology_on Y (subspace_topology X Tx Y).
{ exact (subspace_topology_is_topology X Tx Y HTx HY). }
apply set_ext.
- (** closure_of Y (subspace_topology X Tx Y) A c= (closure_of X Tx A) :/\: Y **)
  let y. assume Hy: y :e closure_of Y (subspace_topology X Tx Y) A.
  prove y :e (closure_of X Tx A) :/\: Y.
  claim HyY: y :e Y.
  { exact (SepE1 Y (fun y0 => forall U:set, U :e subspace_topology X Tx Y -> y0 :e U -> U :/\: A <> Empty) y Hy). }
  claim HysubCond: forall U:set, U :e subspace_topology X Tx Y -> y :e U -> U :/\: A <> Empty.
  { exact (SepE2 Y (fun y0 => forall U:set, U :e subspace_topology X Tx Y -> y0 :e U -> U :/\: A <> Empty) y Hy). }
  apply binintersectI.
  + (** y :e closure_of X Tx A **)
    prove y :e closure_of X Tx A.
    claim HyX: y :e X.
    { exact (HY y HyY). }
    claim HyCond: forall V:set, V :e Tx -> y :e V -> V :/\: A <> Empty.
    { let V. assume HV: V :e Tx. assume HyV: y :e V.
      prove V :/\: A <> Empty.
      set U := V :/\: Y.
      claim HU: U :e subspace_topology X Tx Y.
      { claim HUinPower: U :e Power Y.
        { apply PowerI. exact (binintersect_Subq_2 V Y). }
        claim HPred: exists W :e Tx, U = W :/\: Y.
        { witness V. apply andI. exact HV. reflexivity. }
        exact (SepI (Power Y) (fun U0 => exists W :e Tx, U0 = W :/\: Y) U HUinPower HPred). }
      claim HyU: y :e U.
      { apply binintersectI. exact HyV. exact HyY. }
      claim HUA_ne: U :/\: A <> Empty.
      { exact (HysubCond U HU HyU). }
      prove V :/\: A <> Empty.
      assume HVA_empty: V :/\: A = Empty.
      claim HUA_sub_VA: U :/\: A c= V :/\: A.
      { let z. assume Hz: z :e U :/\: A.
        claim HzU: z :e U.
        { exact (binintersectE1 U A z Hz). }
        claim HzV: z :e V.
        { exact (binintersectE1 V Y z HzU). }
        claim HzA: z :e A.
        { exact (binintersectE2 U A z Hz). }
        exact (binintersectI V A z HzV HzA). }
      claim HUA_sub_Empty: U :/\: A c= Empty.
      { rewrite <- HVA_empty. exact HUA_sub_VA. }
      claim HUA_empty: U :/\: A = Empty.
      { exact (Empty_Subq_eq (U :/\: A) HUA_sub_Empty). }
      exact (HUA_ne HUA_empty). }
    exact (SepI X (fun y0 => forall V:set, V :e Tx -> y0 :e V -> V :/\: A <> Empty) y HyX HyCond).
  + exact HyY.
- (** (closure_of X Tx A) :/\: Y c= closure_of Y (subspace_topology X Tx Y) A **)
  let y. assume Hy: y :e (closure_of X Tx A) :/\: Y.
  prove y :e closure_of Y (subspace_topology X Tx Y) A.
  claim HyClX: y :e closure_of X Tx A.
  { exact (binintersectE1 (closure_of X Tx A) Y y Hy). }
  claim HyY: y :e Y.
  { exact (binintersectE2 (closure_of X Tx A) Y y Hy). }
  claim HyXCond: forall V:set, V :e Tx -> y :e V -> V :/\: A <> Empty.
  { exact (SepE2 X (fun y0 => forall V:set, V :e Tx -> y0 :e V -> V :/\: A <> Empty) y HyClX). }
  claim HySubCond: forall U:set, U :e subspace_topology X Tx Y -> y :e U -> U :/\: A <> Empty.
  { let U. assume HU: U :e subspace_topology X Tx Y. assume HyU: y :e U.
    prove U :/\: A <> Empty.
    claim HUex: exists V :e Tx, U = V :/\: Y.
    { exact (subspace_topologyE X Tx Y U HU). }
    apply HUex.
    let V. assume HVandEq. apply HVandEq.
    assume HV: V :e Tx. assume HUeq: U = V :/\: Y.
    claim HyV: y :e V.
    { claim HyVY: y :e V :/\: Y.
      { rewrite <- HUeq. exact HyU. }
      exact (binintersectE1 V Y y HyVY). }
    claim HVA_ne: V :/\: A <> Empty.
    { exact (HyXCond V HV HyV). }
    rewrite HUeq.
    prove (V :/\: Y) :/\: A <> Empty.
    assume HVYAempty: (V :/\: Y) :/\: A = Empty.
    (** If (V ∩ Y) ∩ A is empty but V ∩ A is nonempty, we derive a contradiction using A ⊆ Y to move a witness into Y. **)
    claim HVA_sub_VYA: V :/\: (Y :/\: A) c= V :/\: A.
    { let z. assume Hz: z :e V :/\: (Y :/\: A).
      claim HzV: z :e V.
      { exact (binintersectE1 V (Y :/\: A) z Hz). }
      claim HzYA: z :e Y :/\: A.
      { exact (binintersectE2 V (Y :/\: A) z Hz). }
      claim HzA: z :e A.
      { exact (binintersectE2 Y A z HzYA). }
      exact (binintersectI V A z HzV HzA). }
    claim HVYAeq: V :/\: (Y :/\: A) = (V :/\: Y) :/\: A.
    { apply set_ext.
      - let z. assume Hz: z :e V :/\: (Y :/\: A).
        claim HzV: z :e V.
        { exact (binintersectE1 V (Y :/\: A) z Hz). }
        claim HzYA: z :e Y :/\: A.
        { exact (binintersectE2 V (Y :/\: A) z Hz). }
        claim HzY: z :e Y.
        { exact (binintersectE1 Y A z HzYA). }
        claim HzA: z :e A.
        { exact (binintersectE2 Y A z HzYA). }
        claim HzVY: z :e V :/\: Y.
        { exact (binintersectI V Y z HzV HzY). }
        exact (binintersectI (V :/\: Y) A z HzVY HzA).
      - let z. assume Hz: z :e (V :/\: Y) :/\: A.
        claim HzVY: z :e V :/\: Y.
        { exact (binintersectE1 (V :/\: Y) A z Hz). }
        claim HzV: z :e V.
        { exact (binintersectE1 V Y z HzVY). }
        claim HzY: z :e Y.
        { exact (binintersectE2 V Y z HzVY). }
        claim HzA: z :e A.
        { exact (binintersectE2 (V :/\: Y) A z Hz). }
        claim HzYA: z :e Y :/\: A.
        { exact (binintersectI Y A z HzY HzA). }
        exact (binintersectI V (Y :/\: A) z HzV HzYA). }
    claim HVYAempty2: V :/\: (Y :/\: A) = Empty.
    { rewrite HVYAeq. exact HVYAempty. }
    (** We know V ∩ A is nonempty; to contradict emptiness of V ∩ (Y ∩ A) we need a witness in A to also lie in Y (using A ⊆ Y). **)
    (** Key issue: need A ⊆ Y (or restate with A ∩ Y) so that a witness w ∈ A is also in Y. **)
    (** Alternative: use y :e closure implies y in closure of A :/\: Y **)
    (** Since we have V :/\: A <> Empty, pick witness w **)
    claim Hex_w: exists w:set, w :e V :/\: A.
    { apply (dneg (exists w:set, w :e V :/\: A)).
      assume Hnot: ~(exists w:set, w :e V :/\: A).
      claim HVAempty: V :/\: A = Empty.
      { apply Empty_Subq_eq.
        let w. assume Hw: w :e V :/\: A.
        apply FalseE.
        apply Hnot.
        witness w. exact Hw.
      }
      exact (HVA_ne HVAempty).
    }
    apply Hex_w.
    let w. assume Hw: w :e V :/\: A.
    (** w :e V and w :e A. Since A c= Y, we have w :e Y, so w :e V :/\: (Y :/\: A), contradicting HVYAempty2. **)
    claim HwV: w :e V.
    { exact (binintersectE1 V A w Hw). }
    claim HwA: w :e A.
    { exact (binintersectE2 V A w Hw). }
    claim HwY: w :e Y.
    { exact (HA w HwA). }
    claim HwYA: w :e Y :/\: A.
    { exact (binintersectI Y A w HwY HwA). }
    claim HwVYA: w :e V :/\: (Y :/\: A).
    { exact (binintersectI V (Y :/\: A) w HwV HwYA). }
    claim HVYAnonempty: V :/\: (Y :/\: A) <> Empty.
    { assume HVYAempty_contra: V :/\: (Y :/\: A) = Empty.
      claim Hwempty: w :e Empty.
      { rewrite <- HVYAempty_contra. exact HwVYA. }
      exact (EmptyE w Hwempty False). }
    exact (HVYAnonempty HVYAempty2).
    }
  exact (SepI Y (fun y0 => forall U:set, U :e subspace_topology X Tx Y -> y0 :e U -> U :/\: A <> Empty) y HyY HySubCond).
Qed.

(** from §17 Theorem 17.5: closure via neighborhoods/basis **) 
(** LATEX VERSION: Characterization of closure: x is in closure of A iff every open neighborhood of x meets A. **)
Theorem closure_characterization : forall X Tx A x:set,
  topology_on X Tx -> x :e X ->
  (x :e closure_of X Tx A <-> (forall U :e Tx, x :e U -> U :/\: A <> Empty)).
let X Tx A x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
prove x :e closure_of X Tx A <-> (forall U :e Tx, x :e U -> U :/\: A <> Empty).
(** Strategy: unfold definition of closure_of using SepE and SepI **)
apply iffI.
- assume Hx: x :e closure_of X Tx A.
  prove forall U :e Tx, x :e U -> U :/\: A <> Empty.
  (** closure_of X Tx A = {x :e X | forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty} **)
  exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx).
- assume Hcond: forall U :e Tx, x :e U -> U :/\: A <> Empty.
  prove x :e closure_of X Tx A.
  (** Have x :e X as hypothesis; just need to apply SepI with x and the condition **)
  exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hcond).
Qed.

(** from §17 Corollary 17.7: closed iff contains all limit points **) 
(** LATEX VERSION: Limit point x of A means every neighborhood of x contains a point of A different from x; closure equals A plus its limit points. **)
Definition limit_point_of : set -> set -> set -> set -> prop := fun X Tx A x =>
  topology_on X Tx /\ x :e X /\
  forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
Definition limit_points_of : set -> set -> set -> set := fun X Tx A => {x :e X|limit_point_of X Tx A x}.

(** LATEX VERSION: Corollary 17.7: The closure of A equals A together with all its limit points. **)
Theorem closure_equals_set_plus_limit_points : forall X Tx A:set,
  topology_on X Tx -> A c= X ->
  closure_of X Tx A = A :\/: limit_points_of X Tx A.
let X Tx A.
assume HTx: topology_on X Tx.
assume HA: A c= X.
prove closure_of X Tx A = A :\/: limit_points_of X Tx A.
  (** Strategy: cl(A) = A ∪ lim(A) by double inclusion: A ⊆ cl(A), lim(A) ⊆ cl(A), and if x ∈ cl(A) with x ∉ A then x is a limit point. **)
apply set_ext.
- (** cl(A) ⊆ A ∪ lim(A) **)
  let x. assume Hx: x :e closure_of X Tx A.
  prove x :e A :\/: limit_points_of X Tx A.
  apply (xm (x :e A)).
  + assume HxA: x :e A.
    apply binunionI1.
    exact HxA.
  + assume HxnotA: x /:e A.
    (** Show x is a limit point **)
    apply binunionI2.
    prove x :e limit_points_of X Tx A.
    prove x :e {y :e X|limit_point_of X Tx A y}.
    claim HxX: x :e X.
    { exact (closure_in_space X Tx A HTx x Hx). }
    claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
    { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
    apply SepI.
    * exact HxX.
    * prove limit_point_of X Tx A x.
      prove topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
      apply andI.
      - apply andI.
        + exact HTx.
        + exact HxX.
      - prove forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
          let U. assume HU: U :e Tx. assume HxU: x :e U.
          prove exists y:set, y :e A /\ y <> x /\ y :e U.
          claim HUne: U :/\: A <> Empty.
          { exact (Hcond U HU HxU). }
          claim Hexists: exists y:set, y :e U :/\: A.
          { apply (xm (exists y:set, y :e U :/\: A)).
            - assume H. exact H.
            - assume Hnoex: ~(exists y:set, y :e U :/\: A).
              apply FalseE.
              apply HUne.
              apply set_ext.
              + let y. assume Hy: y :e U :/\: A.
                apply FalseE.
                apply Hnoex.
                witness y. exact Hy.
              + exact (Subq_Empty (U :/\: A)). }
          apply Hexists.
          let y. assume Hy: y :e U :/\: A.
          witness y.
          claim HyU: y :e U.
          { exact (binintersectE1 U A y Hy). }
          claim HyA: y :e A.
          { exact (binintersectE2 U A y Hy). }
          prove y :e A /\ y <> x /\ y :e U.
          apply andI.
          - apply andI.
            + exact HyA.
            + prove y <> x.
              assume Heq: y = x.
              apply HxnotA.
              rewrite <- Heq.
              exact HyA.
          - exact HyU.
- (** A ∪ lim(A) ⊆ cl(A) **)
  let x. assume Hx: x :e A :\/: limit_points_of X Tx A.
  prove x :e closure_of X Tx A.
  apply (binunionE A (limit_points_of X Tx A) x Hx).
  + assume HxA: x :e A.
    (** Show x ∈ cl(A) directly. Need x ∈ X first. **)
    apply (xm (x :e X)).
    * assume HxX: x :e X.
      (** Now show for all U open containing x, U ∩ A ≠ ∅ **)
      prove x :e {y :e X | forall U:set, U :e Tx -> y :e U -> U :/\: A <> Empty}.
      apply SepI.
      - exact HxX.
      - prove forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
        let U. assume HU: U :e Tx. assume HxU: x :e U.
        assume Hempty: U :/\: A = Empty.
        (** x ∈ U and x ∈ A, so x ∈ U ∩ A, contradiction **)
        claim HxUA: x :e U :/\: A.
        { apply binintersectI. exact HxU. exact HxA. }
        claim HxEmpty: x :e Empty.
        { rewrite <- Hempty. exact HxUA. }
        exact (EmptyE x HxEmpty).
    * assume HxnotX: x /:e X.
      (** x ∉ X but x ∈ A. But we have A ⊆ X, so x ∈ A implies x ∈ X, contradiction. **)
      apply FalseE.
      claim HxX: x :e X.
      { exact (HA x HxA). }
      exact (HxnotX HxX).
  + assume Hxlim: x :e limit_points_of X Tx A.
    (** x is a limit point, so for all U open containing x, exists y ∈ A with y ≠ x in U, thus U ∩ A ≠ ∅ **)
    claim Hlimparts: x :e X /\ limit_point_of X Tx A x.
    { exact (SepE X (fun y => limit_point_of X Tx A y) x Hxlim). }
    claim HxX: x :e X.
    { exact (andEL (x :e X) (limit_point_of X Tx A x) Hlimparts). }
    claim Hlim: limit_point_of X Tx A x.
    { exact (andER (x :e X) (limit_point_of X Tx A x) Hlimparts). }
    claim Hlim_cond: forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
    { claim Hlim_full: topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
      { exact Hlim. }
      exact (andER (topology_on X Tx /\ x :e X) (forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U) Hlim_full). }
    prove x :e {y :e X | forall U:set, U :e Tx -> y :e U -> U :/\: A <> Empty}.
    apply SepI.
    * exact HxX.
    * prove forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
      let U. assume HU: U :e Tx. assume HxU: x :e U.
      prove U :/\: A <> Empty.
      claim Hexists: exists y:set, y :e A /\ y <> x /\ y :e U.
      { exact (Hlim_cond U HU HxU). }
      apply Hexists.
      let y. assume Hy_parts: y :e A /\ y <> x /\ y :e U.
      (** Extract components from (y :e A /\ y <> x) /\ y :e U **)
      claim Hy_left: y :e A /\ y <> x.
      { exact (andEL (y :e A /\ y <> x) (y :e U) Hy_parts). }
      claim HyA: y :e A.
      { exact (andEL (y :e A) (y <> x) Hy_left). }
      claim HyU: y :e U.
      { exact (andER (y :e A /\ y <> x) (y :e U) Hy_parts). }
      assume Heq: U :/\: A = Empty.
      claim HyUA: y :e U :/\: A.
      { apply binintersectI. exact HyU. exact HyA. }
      claim HyEmpty: y :e Empty.
      { rewrite <- Heq. exact HyUA. }
      exact (EmptyE y HyEmpty).
Qed.

(** from §17: closed sets contain all limit points **)
(** LATEX VERSION: A set A is closed iff it contains all its limit points. **)
Theorem closed_iff_contains_limit_points : forall X Tx A:set,
  topology_on X Tx -> A c= X ->
  (closed_in X Tx A <-> limit_points_of X Tx A c= A).
let X Tx A.
assume HTx: topology_on X Tx.
assume HA: A c= X.
prove closed_in X Tx A <-> limit_points_of X Tx A c= A.
(** Strategy: A closed iff cl(A) = A iff A ∪ lim(A) = A iff lim(A) ⊆ A **)
apply iffI.
- (** Forward: If A closed, then lim(A) ⊆ A **)
  assume HAclosed: closed_in X Tx A.
  prove limit_points_of X Tx A c= A.
  let x. assume Hx: x :e limit_points_of X Tx A.
  prove x :e A.
  (** A is closed means cl(A) = A. We have cl(A) = A ∪ lim(A), so A = A ∪ lim(A), thus lim(A) ⊆ A. **)
  claim Heq_cl: closure_of X Tx A = A.
  { exact (closed_closure_eq X Tx A HTx HAclosed). }
  (** Use closure_equals_set_plus_limit_points: cl(A) = A ∪ lim(A) **)
  claim Heq_union: closure_of X Tx A = A :\/: limit_points_of X Tx A.
  { exact (closure_equals_set_plus_limit_points X Tx A HTx HA). }
  (** From Heq_cl: A = cl(A), and Heq_union: cl(A) = A ∪ lim(A), we get A = A ∪ lim(A) **)
  (** So x ∈ lim(A) implies x ∈ A ∪ lim(A) = A **)
  claim HxclA: x :e closure_of X Tx A.
  { rewrite Heq_union. apply binunionI2. exact Hx. }
  claim HxA: x :e A.
  { rewrite <- Heq_cl. exact HxclA. }
  exact HxA.
- (** Backward: If lim(A) ⊆ A, then A closed **)
  assume Hlim_sub: limit_points_of X Tx A c= A.
  prove closed_in X Tx A.
  (** Strategy: use cl(A)=A∪lim(A) and lim(A)⊆A to get cl(A)=A; since cl(A) is closed, A is closed. **)
  claim Heq_union: closure_of X Tx A = A :\/: limit_points_of X Tx A.
  { exact (closure_equals_set_plus_limit_points X Tx A HTx HA). }
  (** Show A ∪ lim(A) = A when lim(A) ⊆ A **)
  claim Hunion_eq: A :\/: limit_points_of X Tx A = A.
  { apply set_ext.
    - let x. assume Hx: x :e A :\/: limit_points_of X Tx A.
      prove x :e A.
      apply (binunionE A (limit_points_of X Tx A) x Hx).
      + assume HxA: x :e A. exact HxA.
      + assume Hxlim: x :e limit_points_of X Tx A.
        exact (Hlim_sub x Hxlim).
    - let x. assume HxA: x :e A.
      prove x :e A :\/: limit_points_of X Tx A.
      apply binunionI1. exact HxA. }
  (** Therefore cl(A) = A **)
  claim HclA_eq: closure_of X Tx A = A.
  { rewrite Heq_union. exact Hunion_eq. }
  (** cl(A) is closed by closure_is_closed **)
  claim HclA_closed: closed_in X Tx (closure_of X Tx A).
  { exact (closure_is_closed X Tx A HTx HA). }
  (** Since A = cl(A) and cl(A) is closed, A is closed **)
  prove closed_in X Tx A.
  rewrite <- HclA_eq.
  exact HclA_closed.
Qed.

(** from §17 Definition: Hausdorff and T1 spaces **) 
(** LATEX VERSION: Hausdorff (T₂): distinct points have disjoint neighborhoods; T₁: all finite sets closed. **)
Definition Hausdorff_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.

(** Helper: extract topology_on from Hausdorff_space **)
Theorem Hausdorff_space_topology : forall X Tx:set,
  Hausdorff_space X Tx -> topology_on X Tx.
let X Tx.
assume H: Hausdorff_space X Tx.
exact (andEL (topology_on X Tx)
             (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
               exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
             H).
Qed.

(** Helper: extract the separation axiom from Hausdorff_space **)
Theorem Hausdorff_space_separation : forall X Tx x1 x2:set,
  Hausdorff_space X Tx -> x1 :e X -> x2 :e X -> x1 <> x2 ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
let X Tx x1 x2.
assume H: Hausdorff_space X Tx.
assume Hx1: x1 :e X.
assume Hx2: x2 :e X.
assume Hneq: x1 <> x2.
claim Hsep: forall a b:set, a :e X -> b :e X -> a <> b ->
  exists U V:set, U :e Tx /\ V :e Tx /\ a :e U /\ b :e V /\ U :/\: V = Empty.
{ exact (andER (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               H). }
exact (Hsep x1 x2 Hx1 Hx2 Hneq).
Qed.

(** from §17: the T1 axiom **)
(** LATEX VERSION: The T1 axiom says that finite point sets are closed. **)
(** FIXED: Quantifier scope error; T1_space requires finite subsets of X to be closed (F c= X -> finite F -> closed_in X Tx F), not all finite sets. **)
Definition T1_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\ (forall F:set, F c= X -> finite F -> closed_in X Tx F).

(** Helper: extract topology_on from T1_space **)
Theorem T1_space_topology : forall X Tx:set,
  T1_space X Tx -> topology_on X Tx.
let X Tx.
assume H: T1_space X Tx.
exact (andEL (topology_on X Tx)
             (forall F:set, F c= X -> finite F -> closed_in X Tx F)
             H).
Qed.

(** Helper: extract finite closedness axiom from T1_space **)
Theorem T1_space_finite_closed : forall X Tx F:set,
  T1_space X Tx -> F c= X -> finite F -> closed_in X Tx F.
let X Tx F.
assume H: T1_space X Tx.
assume HFsub: F c= X.
assume HFfin: finite F.
claim Hfin: forall G:set, G c= X -> finite G -> closed_in X Tx G.
{ exact (andER (topology_on X Tx)
               (forall G:set, G c= X -> finite G -> closed_in X Tx G)
               H). }
exact (Hfin F HFsub HFfin).
Qed.

(** helper: in a Hausdorff space, the complement of a singleton is open **)
Theorem Hausdorff_singleton_complement_open : forall X Tx x:set,
  Hausdorff_space X Tx -> x :e X -> X :\: {x} :e Tx.
let X Tx x.
assume HH: Hausdorff_space X Tx.
assume HxX: x :e X.
prove X :\: {x} :e Tx.
claim Htop: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HH). }
claim HSep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ let x1 x2.
  assume Hx1: x1 :e X.
  assume Hx2: x2 :e X.
  assume Hneq: x1 <> x2.
  exact (Hausdorff_space_separation X Tx x1 x2 HH Hx1 Hx2 Hneq). }
(** family of open sets missing x, indexed by points y in X with y<>x **)
set UFam := {V :e Power X |
  exists y:set,
    y :e X /\ y <> x /\ V :e Tx /\ y :e V /\ x /:e V}.
claim HUFam_sub: UFam c= Tx.
{ let V. assume HV: V :e UFam.
  claim HVpred: exists y:set, y :e X /\ y <> x /\ V :e Tx /\ y :e V /\ x /:e V.
  { exact (SepE2 (Power X)
                 (fun V0 : set =>
                   exists y:set, y :e X /\ y <> x /\ V0 :e Tx /\ y :e V0 /\ x /:e V0)
                 V
                 HV). }
  apply HVpred.
  let y. assume Hy_conj: y :e X /\ y <> x /\ V :e Tx /\ y :e V /\ x /:e V.
  claim H0: ((y :e X /\ y <> x) /\ V :e Tx) /\ y :e V.
  { exact (andEL (((y :e X /\ y <> x) /\ V :e Tx) /\ y :e V) (x /:e V) Hy_conj). }
  claim H1: (y :e X /\ y <> x) /\ V :e Tx.
  { exact (andEL ((y :e X /\ y <> x) /\ V :e Tx) (y :e V) H0). }
  exact (andER (y :e X /\ y <> x) (V :e Tx) H1). }
claim HUnionOpen: Union UFam :e Tx.
{ exact (topology_union_closed X Tx UFam Htop HUFam_sub). }
claim HUnionEq: Union UFam = X :\: {x}.
{ apply set_ext.
  - let z. assume Hz: z :e Union UFam.
    prove z :e X :\: {x}.
    apply (UnionE_impred UFam z Hz (z :e X :\: {x})).
    let V. assume HzV: z :e V. assume HV: V :e UFam.
    claim HVpow: V :e Power X.
    { exact (SepE1 (Power X)
                   (fun V0 : set =>
                     exists y:set, y :e X /\ y <> x /\ V0 :e Tx /\ y :e V0 /\ x /:e V0)
                   V
                   HV). }
    claim HVsubX: V c= X.
    { exact (PowerE X V HVpow). }
    claim HzX: z :e X.
    { exact (HVsubX z HzV). }
    claim HVpred: exists y:set, y :e X /\ y <> x /\ V :e Tx /\ y :e V /\ x /:e V.
    { exact (SepE2 (Power X)
                   (fun V0 : set =>
                     exists y:set, y :e X /\ y <> x /\ V0 :e Tx /\ y :e V0 /\ x /:e V0)
                   V
                   HV). }
	    apply HVpred.
	    let y. assume Hy_conj: y :e X /\ y <> x /\ V :e Tx /\ y :e V /\ x /:e V.
	    claim HxNotV: x /:e V.
	    { exact (andER (((y :e X /\ y <> x) /\ V :e Tx) /\ y :e V) (x /:e V) Hy_conj). }
	    claim HznotSing: z /:e {x}.
	    { assume HzSing: z :e {x}.
	      claim Hzeq: z = x.
      { exact (SingE x z HzSing). }
      claim HxV: x :e V.
      { rewrite <- Hzeq. exact HzV. }
      exact (HxNotV HxV). }
    exact (setminusI X {x} z HzX HznotSing).
  - let z. assume Hz: z :e X :\: {x}.
    prove z :e Union UFam.
    claim HzX: z :e X.
    { exact (setminusE1 X {x} z Hz). }
    claim HznotSing: z /:e {x}.
    { exact (setminusE2 X {x} z Hz). }
    claim Hzneq: z <> x.
    { assume Hzeq: z = x.
      claim HzSing: z :e {x}.
      { rewrite Hzeq. exact (SingI x). }
      exact (HznotSing HzSing). }
    claim HexUV: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ z :e V /\ U :/\: V = Empty.
    { exact (HSep x z HxX HzX (neq_i_sym z x Hzneq)). }
    apply HexUV.
    let U. assume HexV: exists V:set, U :e Tx /\ V :e Tx /\ x :e U /\ z :e V /\ U :/\: V = Empty.
    apply HexV.
    let V. assume Hconj: U :e Tx /\ V :e Tx /\ x :e U /\ z :e V /\ U :/\: V = Empty.
    claim Hconj1: ((U :e Tx /\ V :e Tx) /\ x :e U) /\ z :e V.
    { exact (andEL (((U :e Tx /\ V :e Tx) /\ x :e U) /\ z :e V) (U :/\: V = Empty) Hconj). }
    claim HUVempty: U :/\: V = Empty.
    { exact (andER (((U :e Tx /\ V :e Tx) /\ x :e U) /\ z :e V) (U :/\: V = Empty) Hconj). }
    claim Hconj2: (U :e Tx /\ V :e Tx) /\ x :e U.
    { exact (andEL ((U :e Tx /\ V :e Tx) /\ x :e U) (z :e V) Hconj1). }
    claim HUV1: U :e Tx /\ V :e Tx.
    { exact (andEL (U :e Tx /\ V :e Tx) (x :e U) Hconj2). }
    claim HxU: x :e U.
    { exact (andER (U :e Tx /\ V :e Tx) (x :e U) Hconj2). }
    claim HVTx: V :e Tx.
    { exact (andER (U :e Tx) (V :e Tx) HUV1). }
    claim HzV: z :e V.
    { exact (andER ((U :e Tx /\ V :e Tx) /\ x :e U) (z :e V) Hconj1). }
    claim HxNotV: x /:e V.
    { assume HxV: x :e V.
      claim HxUV: x :e U :/\: V.
      { exact (binintersectI U V x HxU HxV). }
      claim HxEmp: x :e Empty.
      { rewrite <- HUVempty. exact HxUV. }
      exact (EmptyE x HxEmp False). }
    claim HVpow: V :e Power X.
    { claim HTsub: Tx c= Power X.
      { exact (topology_subset_axiom X Tx Htop). }
      exact (HTsub V HVTx). }
    claim HVin: V :e UFam.
    { apply (SepI (Power X)
                  (fun V0 : set =>
                    exists y:set, y :e X /\ y <> x /\ V0 :e Tx /\ y :e V0 /\ x /:e V0)
                  V
                  HVpow).
      witness z.
      apply andI.
      { apply andI.
        { apply andI.
          { apply andI.
            exact HzX.
            exact Hzneq. }
          exact HVTx. }
        exact HzV. }
      { exact HxNotV. } }
    exact (UnionI UFam z V HzV HVin).
}
rewrite <- HUnionEq.
exact HUnionOpen.
Qed.

(** helper: in a Hausdorff space, singletons are closed **)
Theorem Hausdorff_singletons_closed : forall X Tx x:set,
  Hausdorff_space X Tx -> x :e X -> closed_in X Tx {x}.
let X Tx x.
assume HH: Hausdorff_space X Tx.
assume HxX: x :e X.
prove closed_in X Tx {x}.
claim Htop: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HH). }
claim HxSub: {x} c= X.
{ let y. assume Hy: y :e {x}.
  claim Hyeq: y = x.
  { exact (SingE x y Hy). }
  rewrite Hyeq. exact HxX. }
claim HUopen: X :\: {x} :e Tx.
{ exact (Hausdorff_singleton_complement_open X Tx x HH HxX). }
claim Hclosed: closed_in X Tx (X :\: (X :\: {x})).
{ exact (closed_of_open_complement X Tx (X :\: {x}) Htop HUopen). }
claim Heq: X :\: (X :\: {x}) = {x}.
{ exact (setminus_setminus_eq X {x} HxSub). }
rewrite <- Heq.
exact Hclosed.
Qed.

(** from §17 Theorem 17.8: finite sets closed in Hausdorff **) 
(** LATEX VERSION: In any Hausdorff space, every finite subset is closed. **)
Theorem finite_sets_closed_in_Hausdorff : forall X Tx:set,
  Hausdorff_space X Tx -> forall F:set, F c= X -> finite F -> closed_in X Tx F.
let X Tx.
assume HH: Hausdorff_space X Tx.
let F.
assume HFsub: F c= X.
assume HF: finite F.
prove closed_in X Tx F.
claim Htop: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HH). }
claim Hclosed_empty: closed_in X Tx Empty.
{ exact (empty_is_closed X Tx Htop). }
claim Hall: forall F0:set, finite F0 -> (F0 c= X -> closed_in X Tx F0).
{ exact (finite_ind
           (fun F0:set => F0 c= X -> closed_in X Tx F0)
           (fun _ => Hclosed_empty)
           (fun F0 y:set =>
              fun HFin0 HyNotin IH =>
                fun HsubUnion =>
                  union_of_closed_is_closed X Tx F0 {y} Htop
                    (IH (fun z Hz => HsubUnion z (binunionI1 F0 {y} z Hz)))
                    (Hausdorff_singletons_closed X Tx y HH
                      (HsubUnion y (binunionI2 F0 {y} y (SingI y)))))
         ). }
exact ((Hall F HF) HFsub).
Qed.

(** from §17 Theorem 17.9: limit points in T1 spaces have infinite neighborhoods **) 
(** LATEX VERSION: In T₁ spaces, x is a limit point of A iff every neighborhood of x meets A in infinitely many points. **)
Theorem limit_points_infinite_neighborhoods : forall X Tx A x:set,
  T1_space X Tx ->
  x :e X ->
  (limit_point_of X Tx A x <->
  (forall U :e Tx, x :e U -> infinite (U :/\: A))).
let X Tx A x.
assume HT1: T1_space X Tx.
assume HxX: x :e X.
prove limit_point_of X Tx A x <-> (forall U :e Tx, x :e U -> infinite (U :/\: A)).
claim Htop: topology_on X Tx.
{ exact (T1_space_topology X Tx HT1). }
claim Hfinite_closed: forall F:set, F c= X -> finite F -> closed_in X Tx F.
{ let F. assume HFsub. assume HFfin.
  exact (T1_space_finite_closed X Tx F HT1 HFsub HFfin). }
apply iffI.
- (** limit point gives infinite intersections **)
  assume Hlim: limit_point_of X Tx A x.
  prove forall U :e Tx, x :e U -> infinite (U :/\: A).
  let U. assume HU: U :e Tx. assume HxU: x :e U.
  prove infinite (U :/\: A).
  prove ~finite (U :/\: A).
  assume Hfin: finite (U :/\: A).
  claim Hnbr: forall W:set, W :e Tx -> x :e W -> exists y:set, y :e A /\ y <> x /\ y :e W.
  { exact (andER (topology_on X Tx /\ x :e X) (forall W:set, W :e Tx -> x :e W -> exists y:set, y :e A /\ y <> x /\ y :e W)
           Hlim). }
  apply (xm (x :e A)).
  + (** case x in A: remove all other A-points from U **)
    assume HxA: x :e A.
    set F := (U :/\: A) :\: {x}.
    claim HFsub: F c= U :/\: A.
    { exact (setminus_Subq (U :/\: A) {x}). }
    claim HFfin: finite F.
    { exact (Subq_finite (U :/\: A) Hfin F HFsub). }
    claim HFsubX: F c= X.
    { let z. assume HzF: z :e F.
      claim HzUA: z :e U :/\: A.
      { exact (setminusE1 (U :/\: A) {x} z HzF). }
      claim HzU: z :e U.
      { exact (binintersectE1 U A z HzUA). }
      claim HUsubX: U c= X.
      { exact (topology_elem_subset X Tx U Htop HU). }
      exact (HUsubX z HzU). }
    claim HFclosed: closed_in X Tx F.
    { exact (Hfinite_closed F HFsubX HFfin). }
    claim HXFopen: open_in X Tx (X :\: F).
    { exact (open_of_closed_complement X Tx F HFclosed). }
    claim HXF: X :\: F :e Tx.
    { exact (andER (topology_on X Tx) (X :\: F :e Tx) HXFopen). }
    set V := U :/\: (X :\: F).
    claim HV: V :e Tx.
    { exact (topology_binintersect_closed X Tx U (X :\: F) Htop HU HXF). }
    claim HxnotF: x /:e F.
    { assume HxF: x :e F.
      claim HxnotSing: x /:e {x}.
      { exact (setminusE2 (U :/\: A) {x} x HxF). }
      exact (HxnotSing (SingI x)). }
    claim HxXF: x :e X :\: F.
    { exact (setminusI X F x HxX HxnotF). }
    claim HxV: x :e V.
    { exact (binintersectI U (X :\: F) x HxU HxXF). }
	    apply (Hnbr V HV HxV).
	    let y. assume Hyconj: y :e A /\ y <> x /\ y :e V.
	    claim HyAneq: y :e A /\ y <> x.
	    { exact (andEL (y :e A /\ y <> x) (y :e V) Hyconj). }
	    claim HyA: y :e A.
	    { exact (andEL (y :e A) (y <> x) HyAneq). }
	    claim Hyneq: y <> x.
	    { exact (andER (y :e A) (y <> x) HyAneq). }
	    claim HyV: y :e V.
	    { exact (andER (y :e A /\ y <> x) (y :e V) Hyconj). }
    claim HyU: y :e U.
    { exact (binintersectE1 U (X :\: F) y HyV). }
    claim HyXF: y :e X :\: F.
    { exact (binintersectE2 U (X :\: F) y HyV). }
    claim HyNotF: y /:e F.
    { exact (setminusE2 X F y HyXF). }
    claim HyUA: y :e U :/\: A.
    { exact (binintersectI U A y HyU HyA). }
    claim HyNotSing: y /:e {x}.
    { assume HySing: y :e {x}.
      claim Hyeq: y = x.
      { exact (SingE x y HySing). }
      exact (Hyneq Hyeq). }
    claim HyF: y :e F.
    { exact (setminusI (U :/\: A) {x} y HyUA HyNotSing). }
    exact (HyNotF HyF).
  + (** case x not in A: remove all A-points from U **)
    assume HxnotA: x /:e A.
    set F := U :/\: A.
    claim HFsubX: F c= X.
    { let z. assume HzF: z :e F.
      claim HzU: z :e U.
      { exact (binintersectE1 U A z HzF). }
      claim HUsubX: U c= X.
      { exact (topology_elem_subset X Tx U Htop HU). }
      exact (HUsubX z HzU). }
    claim HFclosed: closed_in X Tx F.
    { exact (Hfinite_closed F HFsubX Hfin). }
    claim HXFopen: open_in X Tx (X :\: F).
    { exact (open_of_closed_complement X Tx F HFclosed). }
    claim HXF: X :\: F :e Tx.
    { exact (andER (topology_on X Tx) (X :\: F :e Tx) HXFopen). }
    set V := U :/\: (X :\: F).
    claim HV: V :e Tx.
    { exact (topology_binintersect_closed X Tx U (X :\: F) Htop HU HXF). }
    claim HxnotF: x /:e F.
    { assume HxF: x :e F.
      claim HxA': x :e A.
      { exact (binintersectE2 U A x HxF). }
      exact (HxnotA HxA'). }
    claim HxXF: x :e X :\: F.
    { exact (setminusI X F x HxX HxnotF). }
    claim HxV: x :e V.
    { exact (binintersectI U (X :\: F) x HxU HxXF). }
	    apply (Hnbr V HV HxV).
	    let y. assume Hyconj: y :e A /\ y <> x /\ y :e V.
	    claim HyAneq: y :e A /\ y <> x.
	    { exact (andEL (y :e A /\ y <> x) (y :e V) Hyconj). }
	    claim HyA: y :e A.
	    { exact (andEL (y :e A) (y <> x) HyAneq). }
	    claim Hyneq: y <> x.
	    { exact (andER (y :e A) (y <> x) HyAneq). }
	    claim HyV: y :e V.
	    { exact (andER (y :e A /\ y <> x) (y :e V) Hyconj). }
    claim HyU: y :e U.
    { exact (binintersectE1 U (X :\: F) y HyV). }
    claim HyXF: y :e X :\: F.
    { exact (binintersectE2 U (X :\: F) y HyV). }
    claim HyNotF: y /:e F.
    { exact (setminusE2 X F y HyXF). }
    claim HyF: y :e F.
    { exact (binintersectI U A y HyU HyA). }
    exact (HyNotF HyF).
- (** infinite intersections give limit point **)
  assume Hinf: forall U :e Tx, x :e U -> infinite (U :/\: A).
  prove limit_point_of X Tx A x.
  prove topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
  apply andI.
  - apply andI.
    + exact Htop.
    + exact HxX.
  - let U. assume HU: U :e Tx. assume HxU: x :e U.
    claim HinfUA: infinite (U :/\: A).
    { exact (Hinf U HU HxU). }
    claim Hnotfin: ~finite (U :/\: A).
    { exact HinfUA. }
    apply (xm (exists y:set, y :e U :/\: A /\ y <> x)).
    + assume Hex. apply Hex.
      let y. assume Hypair.
      witness y.
      claim HyUA: y :e U :/\: A.
      { exact (andEL (y :e U :/\: A) (y <> x) Hypair). }
      claim Hyneq: y <> x.
      { exact (andER (y :e U :/\: A) (y <> x) Hypair). }
      claim HyU: y :e U.
      { exact (binintersectE1 U A y HyUA). }
      claim HyA: y :e A.
      { exact (binintersectE2 U A y HyUA). }
      apply andI.
      - apply andI.
        + exact HyA.
        + exact Hyneq.
      - exact HyU.
    + assume Hno: ~(exists y:set, y :e U :/\: A /\ y <> x).
      claim HsubSing: U :/\: A c= {x}.
      { let y. assume HyUA: y :e U :/\: A.
        apply (xm (y = x)).
        - assume Heq: y = x.
          rewrite Heq.
          exact (SingI x).
        - assume Hneq: ~(y = x).
          apply FalseE.
          apply Hno.
          witness y.
          apply andI.
          - exact HyUA.
          - assume Heq: y = x.
            exact (Hneq Heq). }
	      claim HfinUA: finite (U :/\: A).
	      { exact (Subq_finite {x} (Sing_finite x) (U :/\: A) HsubSing). }
	      apply FalseE.
	      exact (Hnotfin HfinUA).
Qed.

(** from §17 Theorem 17.10: uniqueness of limits in Hausdorff spaces **) 
(** LATEX VERSION: In Hausdorff spaces, sequences (or nets) have at most one limit. **)
Theorem Hausdorff_unique_limits : forall X Tx seq x y:set,
  Hausdorff_space X Tx ->
  x :e X ->
  y :e X ->
  x <> y ->
  function_on seq omega X ->
  (forall U:set, U :e Tx -> x :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) ->
  (forall U:set, U :e Tx -> y :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) ->
  False.
let X Tx seq x y.
assume HH: Hausdorff_space X Tx.
assume HxX: x :e X.
assume HyX: y :e X.
assume Hneq: x <> y.
assume Hseq: function_on seq omega X.
assume Hx: forall U:set, U :e Tx -> x :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
assume Hy: forall U:set, U :e Tx -> y :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
prove False.
  (** Strategy: separate x and y by disjoint opens U,V; convergence forces the sequence eventually in U and eventually in V, contradicting U ∩ V = ∅. **)
(** Extract topology and separation property **)
claim HTx: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HH). }
claim HSep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 -> exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ let x1 x2.
  assume Hx1: x1 :e X.
  assume Hx2: x2 :e X.
  assume Hneq12: x1 <> x2.
  exact (Hausdorff_space_separation X Tx x1 x2 HH Hx1 Hx2 Hneq12). }
(** Apply separation to x and y **)
claim HexUV: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
{ exact (HSep x y HxX HyX Hneq). }
(** Handle nested existentials - need to carefully unpack structure **)
(** Unpack the existential for U and V **)
apply HexUV.
let U. assume HexV: exists V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
apply HexV.
let V. assume Hconj: U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
(** Extract all the conjuncts - remember /\ is left-associative **)
(** Hconj is: (((U :e Tx /\ V :e Tx) /\ x :e U) /\ y :e V) /\ U :/\: V = Empty **)
claim HU: U :e Tx.
{ exact (andEL (U :e Tx) (V :e Tx)
         (andEL (U :e Tx /\ V :e Tx) (x :e U)
          (andEL (U :e Tx /\ V :e Tx /\ x :e U) (y :e V)
           (andEL (U :e Tx /\ V :e Tx /\ x :e U /\ y :e V) (U :/\: V = Empty) Hconj)))). }
claim HV: V :e Tx.
{ exact (andER (U :e Tx) (V :e Tx)
         (andEL (U :e Tx /\ V :e Tx) (x :e U)
          (andEL (U :e Tx /\ V :e Tx /\ x :e U) (y :e V)
           (andEL (U :e Tx /\ V :e Tx /\ x :e U /\ y :e V) (U :/\: V = Empty) Hconj)))). }
claim HxU: x :e U.
{ exact (andER (U :e Tx /\ V :e Tx) (x :e U)
          (andEL (U :e Tx /\ V :e Tx /\ x :e U) (y :e V)
           (andEL (U :e Tx /\ V :e Tx /\ x :e U /\ y :e V) (U :/\: V = Empty) Hconj))). }
claim HyV: y :e V.
{ exact (andER (U :e Tx /\ V :e Tx /\ x :e U) (y :e V)
           (andEL (U :e Tx /\ V :e Tx /\ x :e U /\ y :e V) (U :/\: V = Empty) Hconj)). }
claim HUV_empty: U :/\: V = Empty.
{ exact (andER (U :e Tx /\ V :e Tx /\ x :e U /\ y :e V) (U :/\: V = Empty) Hconj). }
(** Now we have U, V open, disjoint, x :e U, y :e V **)
(** Sequence converges to x: eventually in U **)
claim HexNx: exists Nx:set, Nx :e omega /\ forall n:set, n :e omega -> Nx c= n -> apply_fun seq n :e U.
{ exact (Hx U HU HxU). }
apply HexNx.
let Nx. assume HNx_and_conv.
claim HNx: Nx :e omega.
{ exact (andEL (Nx :e omega) (forall n:set, n :e omega -> Nx c= n -> apply_fun seq n :e U) HNx_and_conv). }
claim Hconv_x: forall n:set, n :e omega -> Nx c= n -> apply_fun seq n :e U.
{ exact (andER (Nx :e omega) (forall n:set, n :e omega -> Nx c= n -> apply_fun seq n :e U) HNx_and_conv). }
(** Sequence converges to y: eventually in V **)
claim HexNy: exists Ny:set, Ny :e omega /\ forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e V.
{ exact (Hy V HV HyV). }
apply HexNy.
let Ny. assume HNy_and_conv.
claim HNy: Ny :e omega.
{ exact (andEL (Ny :e omega) (forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e V) HNy_and_conv). }
claim Hconv_y: forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e V.
{ exact (andER (Ny :e omega) (forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e V) HNy_and_conv). }
(** Take n = ordsucc (Nx ∪ Ny), which is >= both Nx and Ny **)
(** Since Nx, Ny are ordinals in omega, Nx ∪ Ny = max(Nx, Ny) **)
set N := ordsucc (Nx :\/: Ny).
claim HN_omega: N :e omega.
{ claim Hmax_omega: Nx :\/: Ny :e omega.
  { (** Nx ∪ Ny is the max of two elements of omega, hence in omega **)
    apply (xm (Nx :e Ny)).
    - assume HNx_in_Ny: Nx :e Ny.
      (** If Nx < Ny, then Nx ∪ Ny = Ny **)
      claim Hmax_eq_Ny: Nx :\/: Ny = Ny.
      { (** Nx ⊆ Ny since Nx :e Ny and Ny is an ordinal (transitive) **)
        claim HNx_sub_Ny: Nx c= Ny.
        { (** Ny is a natural, hence ordinal, hence TransSet **)
          claim HNy_nat: nat_p Ny.
          { exact (omega_nat_p Ny HNy). }
          claim HNy_ord: ordinal Ny.
          { exact (nat_p_ordinal Ny HNy_nat). }
          claim HNy_trans: TransSet Ny.
          { exact (andEL (TransSet Ny) (forall beta :e Ny, TransSet beta) HNy_ord). }
          (** Now use TransSet property: x :e Ny implies x c= Ny **)
          exact (HNy_trans Nx HNx_in_Ny).
        }
        apply set_ext.
        - (** Nx :\/: Ny c= Ny **)
          claim HNy_refl: Ny c= Ny.
          { exact (Subq_ref Ny). }
          exact (binunion_Subq_min Nx Ny Ny HNx_sub_Ny HNy_refl).
        - (** Ny c= Nx :\/: Ny **)
          exact (binunion_Subq_2 Nx Ny).
      }
      rewrite Hmax_eq_Ny.
      exact HNy.
    - assume HNx_nin_Ny: Nx /:e Ny.
      (** If Nx >= Ny, then Ny ⊆ Nx **)
      claim HNy_sub_or_eq_Nx: Ny c= Nx.
      { (** In omega, if Nx /:e Ny, then Ny :e Nx or Ny = Nx (trichotomy) **)
        (** Use ordinal trichotomy: Nx and Ny are ordinals since they're in omega **)
        claim HNx_nat: nat_p Nx.
        { exact (omega_nat_p Nx HNx). }
        claim HNy_nat: nat_p Ny.
        { exact (omega_nat_p Ny HNy). }
        claim HNx_ord: ordinal Nx.
        { exact (nat_p_ordinal Nx HNx_nat). }
        claim HNy_ord: ordinal Ny.
        { exact (nat_p_ordinal Ny HNy_nat). }
        (** Apply ordinal_In_Or_Subq: either Nx :e Ny or Ny c= Nx **)
        claim Hcases: Nx :e Ny \/ Ny c= Nx.
        { exact (ordinal_In_Or_Subq Nx Ny HNx_ord HNy_ord). }
        (** We have Nx /:e Ny, so must have Ny c= Nx **)
        apply (Hcases (Ny c= Nx)).
        - assume HNx_in_Ny: Nx :e Ny.
          apply FalseE.
          exact (HNx_nin_Ny HNx_in_Ny).
        - assume H. exact H.
      }
      claim Hmax_eq_Nx: Nx :\/: Ny = Nx.
      { apply set_ext.
        - (** Nx :\/: Ny c= Nx **)
          claim HNx_refl: Nx c= Nx.
          { exact (Subq_ref Nx). }
          exact (binunion_Subq_min Nx Ny Nx HNx_refl HNy_sub_or_eq_Nx).
        - (** Nx c= Nx :\/: Ny **)
          exact (binunion_Subq_1 Nx Ny).
      }
      rewrite Hmax_eq_Nx.
      exact HNx.
  }
  exact (omega_ordsucc (Nx :\/: Ny) Hmax_omega).
}
claim HNx_sub_N: Nx c= N.
{ (** Nx ⊆ Nx ∪ Ny ⊂ ordsucc(Nx ∪ Ny) **)
  claim HNx_sub_union: Nx c= Nx :\/: Ny.
  { exact (binunion_Subq_1 Nx Ny). }
  claim Hunion_sub_ordsucc: Nx :\/: Ny c= ordsucc (Nx :\/: Ny).
  { exact (ordsuccI1 (Nx :\/: Ny)). }
  exact (Subq_tra Nx (Nx :\/: Ny) (ordsucc (Nx :\/: Ny)) HNx_sub_union Hunion_sub_ordsucc).
}
claim HNy_sub_N: Ny c= N.
{ (** Ny ⊆ Nx ∪ Ny ⊂ ordsucc(Nx ∪ Ny) **)
  claim HNy_sub_union: Ny c= Nx :\/: Ny.
  { exact (binunion_Subq_2 Nx Ny). }
  claim Hunion_sub_ordsucc: Nx :\/: Ny c= ordsucc (Nx :\/: Ny).
  { exact (ordsuccI1 (Nx :\/: Ny)). }
  exact (Subq_tra Ny (Nx :\/: Ny) (ordsucc (Nx :\/: Ny)) HNy_sub_union Hunion_sub_ordsucc).
}
(** Then apply_fun seq N is in both U and V **)
claim Hseq_N_in_U: apply_fun seq N :e U.
{ exact (Hconv_x N HN_omega HNx_sub_N). }
claim Hseq_N_in_V: apply_fun seq N :e V.
{ exact (Hconv_y N HN_omega HNy_sub_N). }
(** So apply_fun seq N :e U ∩ V **)
claim Hseq_N_in_UV: apply_fun seq N :e U :/\: V.
{ exact (binintersectI U V (apply_fun seq N) Hseq_N_in_U Hseq_N_in_V). }
(** But U ∩ V = ∅, so apply_fun seq N :e ∅, which is False **)
claim Hseq_N_in_empty: apply_fun seq N :e Empty.
{ rewrite <- HUV_empty. exact Hseq_N_in_UV. }
exact (EmptyE (apply_fun seq N) Hseq_N_in_empty False).
Qed.

(** from §17 Theorem 17.11: Hausdorff stability under constructions **) 
(** LATEX VERSION: Products of Hausdorff spaces are Hausdorff. **)
Theorem Hausdorff_stability : forall X Tx Y Ty:set,
  Hausdorff_space X Tx /\ Hausdorff_space Y Ty ->
  Hausdorff_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume H: Hausdorff_space X Tx /\ Hausdorff_space Y Ty.
prove Hausdorff_space (setprod X Y) (product_topology X Tx Y Ty).
(** Strategy: Same as ex17_11_product_Hausdorff - use rectangles to separate distinct points **)
(** Extract components from Hausdorff definitions **)
claim HX: Hausdorff_space X Tx.
{ exact (andEL (Hausdorff_space X Tx) (Hausdorff_space Y Ty) H). }
claim HY: Hausdorff_space Y Ty.
{ exact (andER (Hausdorff_space X Tx) (Hausdorff_space Y Ty) H). }
claim HTx: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HX). }
claim HTy: topology_on Y Ty.
{ exact (Hausdorff_space_topology Y Ty HY). }
claim HSepX: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 -> exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ let x1 x2.
  assume Hx1: x1 :e X.
  assume Hx2: x2 :e X.
  assume Hneq12: x1 <> x2.
  exact (Hausdorff_space_separation X Tx x1 x2 HX Hx1 Hx2 Hneq12). }
claim HSepY: forall y1 y2:set, y1 :e Y -> y2 :e Y -> y1 <> y2 -> exists U V:set, U :e Ty /\ V :e Ty /\ y1 :e U /\ y2 :e V /\ U :/\: V = Empty.
{ let y1 y2.
  assume Hy1: y1 :e Y.
  assume Hy2: y2 :e Y.
  assume Hneq12: y1 <> y2.
  exact (Hausdorff_space_separation Y Ty y1 y2 HY Hy1 Hy2 Hneq12). }
(** Build Hausdorff property for product **)
claim HTProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\
      (forall p1 p2:set, p1 :e setprod X Y -> p2 :e setprod X Y -> p1 <> p2 ->
       exists U V:set, U :e product_topology X Tx Y Ty /\ V :e product_topology X Tx Y Ty /\
                       p1 :e U /\ p2 :e V /\ U :/\: V = Empty).
apply andI.
- exact HTProd.
- let p1 p2. assume Hp1: p1 :e setprod X Y. assume Hp2: p2 :e setprod X Y. assume Hne: p1 <> p2.
  prove exists U V:set, U :e product_topology X Tx Y Ty /\ V :e product_topology X Tx Y Ty /\
                        p1 :e U /\ p2 :e V /\ U :/\: V = Empty.
  (** Decompose p1 = (x1,y1), p2 = (x2,y2) **)
  apply (Sigma_E X (fun _ : set => Y) p1 Hp1).
  let x1. assume Hx1_pair.
  apply Hx1_pair.
  assume Hx1X Hexy1.
  apply Hexy1.
  let y1. assume Hy1_pair.
  apply Hy1_pair.
  assume Hy1Y Hp1eq.
  apply (Sigma_E X (fun _ : set => Y) p2 Hp2).
  let x2. assume Hx2_pair.
  apply Hx2_pair.
  assume Hx2X Hexy2.
  apply Hexy2.
  let y2. assume Hy2_pair.
  apply Hy2_pair.
  assume Hy2Y Hp2eq.
  (** Split by whether x-coordinates coincide **)
  apply (xm (x1 = x2)).
  - assume Hx12: x1 = x2.
    claim Hy12: y1 <> y2.
    { assume HyEq: y1 = y2.
      claim HpEq: p1 = p2.
      { rewrite Hp1eq.
        rewrite Hp2eq.
        rewrite Hx12.
        rewrite HyEq.
        reflexivity. }
      exact (Hne HpEq). }
    (** Separate by y-coordinate using opens in Ty **)
    apply (HSepY y1 y2 Hy1Y Hy2Y Hy12).
    let U. assume HexV.
    apply HexV.
    let V. assume HUV_conj.
    apply HUV_conj.
    assume Hcore HUVempty.
    apply Hcore.
    assume Hcore2 Hy2V.
    apply Hcore2.
    assume Hcore3 Hy1U.
    apply Hcore3.
    assume HU HV.
    set R1 := rectangle_set X U.
    set R2 := rectangle_set X V.
    witness R1.
    witness R2.
    prove R1 :e product_topology X Tx Y Ty /\ R2 :e product_topology X Tx Y Ty /\ p1 :e R1 /\ p2 :e R2 /\ R1 :/\: R2 = Empty.
    apply andI.
    + apply andI.
      * apply andI.
        { apply andI.
          (** R1 open in product topology **)
          - claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
            { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
            claim HXTx: X :e Tx.
            { exact (topology_has_X X Tx HTx). }
            claim HR1sub: R1 :e product_subbasis X Tx Y Ty.
            { prove R1 :e product_subbasis X Tx Y Ty.
              claim HR1fam: rectangle_set X U :e {rectangle_set X V0|V0 :e Ty}.
              { exact (ReplI Ty (fun V0:set => rectangle_set X V0) U HU). }
              exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) X (rectangle_set X U) HXTx HR1fam). }
            exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis R1 HR1sub).
          (** R2 open in product topology **)
          - claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
            { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
            claim HXTx: X :e Tx.
            { exact (topology_has_X X Tx HTx). }
            claim HR2sub: R2 :e product_subbasis X Tx Y Ty.
            { prove R2 :e product_subbasis X Tx Y Ty.
              claim HR2fam: rectangle_set X V :e {rectangle_set X V0|V0 :e Ty}.
              { exact (ReplI Ty (fun V0:set => rectangle_set X V0) V HV). }
              exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) X (rectangle_set X V) HXTx HR2fam). }
            exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis R2 HR2sub). }
        (** p1 in R1 **)
        { rewrite Hp1eq.
          exact (pair_Sigma X (fun _ : set => U) x1 Hx1X y1 Hy1U). }
      (** p2 in R2 **)
      * rewrite Hp2eq.
        rewrite <- Hx12 at 1.
        exact (pair_Sigma X (fun _ : set => V) x1 Hx1X y2 Hy2V).
    (** disjointness of rectangles **)
    + prove R1 :/\: R2 = Empty.
      apply set_ext.
      { let p. assume Hp: p :e R1 :/\: R2.
        prove p :e Empty.
        apply FalseE.
        claim HpR1: p :e R1.
        { exact (binintersectE1 R1 R2 p Hp). }
        claim HpR2: p :e R2.
        { exact (binintersectE2 R1 R2 p Hp). }
        claim Hcoords1: exists x :e X, exists y :e U, p :e setprod {x} {y}.
        { exact (setprod_elem_decompose X U p HpR1). }
        apply Hcoords1.
        let x. assume Hx_pair.
        claim HxX': x :e X.
        { exact (andEL (x :e X) (exists y0 :e U, p :e setprod {x} {y0}) Hx_pair). }
        claim Hexy: exists y0 :e U, p :e setprod {x} {y0}.
        { exact (andER (x :e X) (exists y0 :e U, p :e setprod {x} {y0}) Hx_pair). }
        apply Hexy.
        let y. assume Hy_pair.
        claim HyU': y :e U.
        { exact (andEL (y :e U) (p :e setprod {x} {y}) Hy_pair). }
        claim Hpsing1: p :e setprod {x} {y}.
        { exact (andER (y :e U) (p :e setprod {x} {y}) Hy_pair). }
        claim Hcoords2: exists x0 :e X, exists y0 :e V, p :e setprod {x0} {y0}.
        { exact (setprod_elem_decompose X V p HpR2). }
        apply Hcoords2.
        let x0. assume Hx0_pair.
        claim Hexy0: exists y0 :e V, p :e setprod {x0} {y0}.
        { exact (andER (x0 :e X) (exists y0 :e V, p :e setprod {x0} {y0}) Hx0_pair). }
        apply Hexy0.
        let y0. assume Hy0_pair.
        claim Hpsing2: p :e setprod {x0} {y0}.
        { exact (andER (y0 :e V) (p :e setprod {x0} {y0}) Hy0_pair). }
        claim HyV': y :e V.
        { exact (andER (x :e X) (y :e V) (setprod_coords_in x y X V p Hpsing1 HpR2)). }
        claim HyUV: y :e U :/\: V.
        { exact (binintersectI U V y HyU' HyV'). }
        claim HyE: y :e Empty.
        { rewrite <- HUVempty. exact HyUV. }
        exact (EmptyE y HyE False). }
      { exact (Subq_Empty (R1 :/\: R2)). }
  - assume Hx12n: x1 <> x2.
    (** Separate by x-coordinate using opens in Tx **)
    apply (HSepX x1 x2 Hx1X Hx2X Hx12n).
    let U. assume HexV.
    apply HexV.
    let V. assume HUV_conj.
    apply HUV_conj.
    assume Hcore HUVempty.
    apply Hcore.
    assume Hcore2 Hx2V.
    apply Hcore2.
    assume Hcore3 Hx1U.
    apply Hcore3.
    assume HU HV.
    set R1 := rectangle_set U Y.
    set R2 := rectangle_set V Y.
    witness R1.
    witness R2.
    prove R1 :e product_topology X Tx Y Ty /\ R2 :e product_topology X Tx Y Ty /\ p1 :e R1 /\ p2 :e R2 /\ R1 :/\: R2 = Empty.
    apply andI.
    + apply andI.
      * apply andI.
        { apply andI.
          (** R1 open in product topology **)
          - claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
            { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
            claim HYTy: Y :e Ty.
            { exact (topology_has_X Y Ty HTy). }
            claim HR1sub: R1 :e product_subbasis X Tx Y Ty.
            { prove R1 :e product_subbasis X Tx Y Ty.
              claim HR1fam: rectangle_set U Y :e {rectangle_set U V0|V0 :e Ty}.
              { exact (ReplI Ty (fun V0:set => rectangle_set U V0) Y HYTy). }
              exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) U (rectangle_set U Y) HU HR1fam). }
            exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis R1 HR1sub).
          (** R2 open in product topology **)
          - claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
            { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
            claim HYTy: Y :e Ty.
            { exact (topology_has_X Y Ty HTy). }
            claim HR2sub: R2 :e product_subbasis X Tx Y Ty.
            { prove R2 :e product_subbasis X Tx Y Ty.
              claim HR2fam: rectangle_set V Y :e {rectangle_set V V0|V0 :e Ty}.
              { exact (ReplI Ty (fun V0:set => rectangle_set V V0) Y HYTy). }
              exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) V (rectangle_set V Y) HV HR2fam). }
            exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis R2 HR2sub). }
        (** p1 in R1 **)
        { rewrite Hp1eq.
          exact (pair_Sigma U (fun _ : set => Y) x1 Hx1U y1 Hy1Y). }
      (** p2 in R2 **)
      * rewrite Hp2eq.
        exact (pair_Sigma V (fun _ : set => Y) x2 Hx2V y2 Hy2Y).
    (** disjointness of rectangles **)
    + prove R1 :/\: R2 = Empty.
      apply set_ext.
      { let p. assume Hp: p :e R1 :/\: R2.
        prove p :e Empty.
        apply FalseE.
        claim HpR1: p :e R1.
        { exact (binintersectE1 R1 R2 p Hp). }
        claim HpR2: p :e R2.
        { exact (binintersectE2 R1 R2 p Hp). }
        claim Hcoords1: exists x :e U, exists y :e Y, p :e setprod {x} {y}.
        { exact (setprod_elem_decompose U Y p HpR1). }
        apply Hcoords1.
        let x. assume Hx_pair.
        claim HxU': x :e U.
        { exact (andEL (x :e U) (exists y0 :e Y, p :e setprod {x} {y0}) Hx_pair). }
        claim Hexy: exists y0 :e Y, p :e setprod {x} {y0}.
        { exact (andER (x :e U) (exists y0 :e Y, p :e setprod {x} {y0}) Hx_pair). }
        apply Hexy.
        let y. assume Hy_pair.
        claim Hpsing1: p :e setprod {x} {y}.
        { exact (andER (y :e Y) (p :e setprod {x} {y}) Hy_pair). }
        claim Hcoords2: exists x0 :e V, exists y0 :e Y, p :e setprod {x0} {y0}.
        { exact (setprod_elem_decompose V Y p HpR2). }
        apply Hcoords2.
        let x0. assume Hx0_pair.
        claim Hexy0: exists y0 :e Y, p :e setprod {x0} {y0}.
        { exact (andER (x0 :e V) (exists y0 :e Y, p :e setprod {x0} {y0}) Hx0_pair). }
        apply Hexy0.
        let y0. assume Hy0_pair.
        claim Hpsing2: p :e setprod {x0} {y0}.
        { exact (andER (y0 :e Y) (p :e setprod {x0} {y0}) Hy0_pair). }
        claim HxV': x :e V.
        { exact (andEL (x :e V) (y :e Y) (setprod_coords_in x y V Y p Hpsing1 HpR2)). }
        claim HxUV: x :e U :/\: V.
        { exact (binintersectI U V x HxU' HxV'). }
        claim HxE: x :e Empty.
        { rewrite <- HUVempty. exact HxUV. }
        exact (EmptyE x HxE False). }
      { exact (Subq_Empty (R1 :/\: R2)). }
Qed.

(** from §17 Exercises 1–20: closures, boundaries, Hausdorff properties **) 
(** LATEX VERSION: Exercise 1: Given a notion of closed sets satisfying axioms, prove they come from a topology. **)
Theorem ex17_1_topology_from_closed_sets : forall X Tx:set,
  closed_in X Tx X -> (forall A:set, closed_in X Tx A -> closed_in X Tx (X :\: A)) -> topology_on X Tx.
let X Tx.
assume H1: closed_in X Tx X.
assume H2: forall A:set, closed_in X Tx A -> closed_in X Tx (X :\: A).
prove topology_on X Tx.
(** By definition, closed_in X Tx X means topology_on X Tx /\ ... **)
(** So we can extract topology_on X Tx directly from H1 **)
exact (andEL (topology_on X Tx) (X c= X /\ exists U :e Tx, X = X :\: U) H1).
Qed.

(** LATEX VERSION: Exercise 2: If Y is closed in X and A is closed in the subspace Y, then A is closed in X. **)
Theorem ex17_2_closed_in_closed_subspace : forall X Tx Y A:set,
  closed_in X Tx Y -> closed_in Y (subspace_topology X Tx Y) A -> closed_in X Tx A.
let X Tx Y A.
assume HY: closed_in X Tx Y.
assume HA: closed_in Y (subspace_topology X Tx Y) A.
prove closed_in X Tx A.
(** Extract topology_on X Tx from closed_in X Tx Y and apply closed_in_closed_subspace **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (Y c= X /\ exists U :e Tx, Y = X :\: U) HY). }
exact (closed_in_closed_subspace X Tx Y A HTx HY HA).
Qed.

(** LATEX VERSION: Exercise 3: Products of closed sets are closed in the product topology. **)
Theorem ex17_3_product_of_closed_sets_closed : forall X Tx Y Ty A B:set,
  closed_in X Tx A -> closed_in Y Ty B ->
  closed_in (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
let X Tx Y Ty A B.
assume HA: closed_in X Tx A.
assume HB: closed_in Y Ty B.
prove closed_in (setprod X Y) (product_topology X Tx Y Ty) (setprod A B).
  (** Strategy: (X×Y)\\(A×B) = (X\\A)×Y ∪ X×(Y\\B); X\\A and Y\\B are open, products are open, and unions are open. **)
(** Extract topologies and components from closed_in **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (A c= X /\ exists U :e Tx, A = X :\: U) HA). }
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty) (B c= Y /\ exists V :e Ty, B = Y :\: V) HB). }
claim HAparts: A c= X /\ exists U :e Tx, A = X :\: U.
{ exact (andER (topology_on X Tx) (A c= X /\ exists U :e Tx, A = X :\: U) HA). }
claim HBparts: B c= Y /\ exists V :e Ty, B = Y :\: V.
{ exact (andER (topology_on Y Ty) (B c= Y /\ exists V :e Ty, B = Y :\: V) HB). }
claim HAsub: A c= X.
{ exact (andEL (A c= X) (exists U :e Tx, A = X :\: U) HAparts). }
claim HBsub: B c= Y.
{ exact (andEL (B c= Y) (exists V :e Ty, B = Y :\: V) HBparts). }
claim HexU: exists U :e Tx, A = X :\: U.
{ exact (andER (A c= X) (exists U :e Tx, A = X :\: U) HAparts). }
claim HexV: exists V :e Ty, B = Y :\: V.
{ exact (andER (B c= Y) (exists V :e Ty, B = Y :\: V) HBparts). }
(** Build the closed set property for product **)
claim HTProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\
      (setprod A B c= setprod X Y /\
       exists W :e product_topology X Tx Y Ty, setprod A B = (setprod X Y) :\: W).
	apply andI.
	- exact HTProd.
	- apply andI.
	  + (** A×B ⊆ X×Y **)
	    exact (setprod_Subq A B X Y HAsub HBsub).
	  + (** exists open W such that A×B = (X×Y) \ W **)
	    apply HexU.
	    let U. assume HU_conj.
	    claim HUinTx: U :e Tx.
	    { exact (andEL (U :e Tx) (A = X :\: U) HU_conj). }
	    claim HAeq: A = X :\: U.
	    { exact (andER (U :e Tx) (A = X :\: U) HU_conj). }
	    apply HexV.
	    let V. assume HV_conj.
	    claim HVinTy: V :e Ty.
	    { exact (andEL (V :e Ty) (B = Y :\: V) HV_conj). }
	    claim HBeq: B = Y :\: V.
	    { exact (andER (V :e Ty) (B = Y :\: V) HV_conj). }
	    claim HUsubX: U c= X.
	    { exact (topology_elem_subset X Tx U HTx HUinTx). }
	    claim HVsubY: V c= Y.
	    { exact (topology_elem_subset Y Ty V HTy HVinTy). }
	    claim HXminusA: X :\: A = U.
	    { rewrite HAeq at 1.
	      exact (setminus_setminus_eq X U HUsubX). }
	    claim HYminusB: Y :\: B = V.
	    { rewrite HBeq at 1.
	      exact (setminus_setminus_eq Y V HVsubY). }
	    set W1 := setprod (X :\: A) Y.
	    set W2 := setprod X (Y :\: B).
	    set W := W1 :\/: W2.
	    witness W.
	    apply andI.
	    - (** W is open in product topology **)
	      claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
	      { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
	      claim HW1sub: W1 :e product_subbasis X Tx Y Ty.
	      { prove W1 :e product_subbasis X Tx Y Ty.
	        rewrite HXminusA.
	        claim HYTy: Y :e Ty.
	        { exact (topology_has_X Y Ty HTy). }
	        claim HW1fam: rectangle_set U Y :e {rectangle_set U V0|V0 :e Ty}.
	        { exact (ReplI Ty (fun V0:set => rectangle_set U V0) Y HYTy). }
	        exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) U (rectangle_set U Y) HUinTx HW1fam). }
	      claim HW2sub: W2 :e product_subbasis X Tx Y Ty.
	      { prove W2 :e product_subbasis X Tx Y Ty.
	        rewrite HYminusB.
	        claim HXTx: X :e Tx.
	        { exact (topology_has_X X Tx HTx). }
	        claim HW2fam: rectangle_set X V :e {rectangle_set X V0|V0 :e Ty}.
	        { exact (ReplI Ty (fun V0:set => rectangle_set X V0) V HVinTy). }
	        exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) X (rectangle_set X V) HXTx HW2fam). }
	      claim HW1open: W1 :e product_topology X Tx Y Ty.
	      { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis W1 HW1sub). }
	      claim HW2open: W2 :e product_topology X Tx Y Ty.
	      { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis W2 HW2sub). }
	      exact (lemma_union_two_open (setprod X Y) (product_topology X Tx Y Ty) W1 W2 HTProd HW1open HW2open).
	    - (** A×B is complement of W **)
	      prove setprod A B = setprod X Y :\: W.
	      apply set_ext.
	      + let p. assume Hp: p :e setprod A B.
	        prove p :e setprod X Y :\: W.
	        claim HpXY: p :e setprod X Y.
	        { exact ((setprod_Subq A B X Y HAsub HBsub) p Hp). }
	        claim Hexab: exists x :e A, exists y :e B, p :e setprod {x} {y}.
	        { exact (setprod_elem_decompose A B p Hp). }
		        claim HpNotW: p /:e W.
		        { apply Hexab.
		          let x. assume Hx_conj.
		          claim HxA': x :e A.
		          { exact (andEL (x :e A) (exists y0 :e B, p :e setprod {x} {y0}) Hx_conj). }
		          claim Hexy: exists y0 :e B, p :e setprod {x} {y0}.
		          { exact (andER (x :e A) (exists y0 :e B, p :e setprod {x} {y0}) Hx_conj). }
		          apply Hexy.
		          let y. assume Hy_conj.
		          claim HyB: y :e B.
		          { exact (andEL (y :e B) (p :e setprod {x} {y}) Hy_conj). }
		          claim Hpsing: p :e setprod {x} {y}.
		          { exact (andER (y :e B) (p :e setprod {x} {y}) Hy_conj). }
		          assume HpW: p :e W.
		          apply (binunionE W1 W2 p HpW).
		          - assume HpW1: p :e W1.
		            claim Hxy: x :e (X :\: A) /\ y :e Y.
		            { exact (setprod_coords_in x y (X :\: A) Y p Hpsing HpW1). }
		            claim HxXA: x :e X :\: A.
		            { exact (andEL (x :e X :\: A) (y :e Y) Hxy). }
		            exact ((setminusE2 X A x HxXA) HxA').
	          - assume HpW2: p :e W2.
	            claim Hxy: x :e X /\ y :e (Y :\: B).
	            { exact (setprod_coords_in x y X (Y :\: B) p Hpsing HpW2). }
	            claim HyYB: y :e Y :\: B.
	            { exact (andER (x :e X) (y :e Y :\: B) Hxy). }
		            exact ((setminusE2 Y B y HyYB) HyB). }
		        exact (setminusI (setprod X Y) W p HpXY HpNotW).
	      + let p. assume Hp: p :e setprod X Y :\: W.
	        prove p :e setprod A B.
	        claim HpXY: p :e setprod X Y.
	        { exact (setminusE1 (setprod X Y) W p Hp). }
	        claim HpNotW: p /:e W.
	        { exact (setminusE2 (setprod X Y) W p Hp). }
		        claim Hexxy: exists x :e X, exists y :e Y, p :e setprod {x} {y}.
		        { exact (setprod_elem_decompose X Y p HpXY). }
		        apply Hexxy.
		        let x. assume Hx_conj.
		        claim HxX: x :e X.
		        { exact (andEL (x :e X) (exists y0 :e Y, p :e setprod {x} {y0}) Hx_conj). }
		        claim Hexy: exists y0 :e Y, p :e setprod {x} {y0}.
		        { exact (andER (x :e X) (exists y0 :e Y, p :e setprod {x} {y0}) Hx_conj). }
		        apply Hexy.
		        let y. assume Hy_conj.
		        claim HyY: y :e Y.
		        { exact (andEL (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
		        claim Hpsing: p :e setprod {x} {y}.
		        { exact (andER (y :e Y) (p :e setprod {x} {y}) Hy_conj). }
		        claim HxA: x :e A.
	        { apply (xm (x :e A)).
	          - assume H. exact H.
	          - assume HxNotA: ~(x :e A).
	            claim HxXA: x :e X :\: A.
	            { exact (setminusI X A x HxX HxNotA). }
	            claim HxSingSub: {x} c= X :\: A.
	            { exact (singleton_subset x (X :\: A) HxXA). }
	            claim HySingSub: {y} c= Y.
	            { exact (singleton_subset y Y HyY). }
	            claim HpW1: p :e W1.
	            { claim Hsub: setprod {x} {y} c= W1.
	              { exact (setprod_Subq {x} {y} (X :\: A) Y HxSingSub HySingSub). }
	              exact (Hsub p Hpsing). }
	            apply FalseE.
	            exact (HpNotW (binunionI1 W1 W2 p HpW1)). }
	        claim HyB: y :e B.
	        { apply (xm (y :e B)).
	          - assume H. exact H.
	          - assume HyNotB: ~(y :e B).
	            claim HyYB: y :e Y :\: B.
	            { exact (setminusI Y B y HyY HyNotB). }
	            claim HySingSub: {y} c= Y :\: B.
	            { exact (singleton_subset y (Y :\: B) HyYB). }
	            claim HxSingSub: {x} c= X.
	            { exact (singleton_subset x X HxX). }
	            claim HpW2: p :e W2.
	            { claim Hsub: setprod {x} {y} c= W2.
	              { exact (setprod_Subq {x} {y} X (Y :\: B) HxSingSub HySingSub). }
	              exact (Hsub p Hpsing). }
	            apply FalseE.
	            exact (HpNotW (binunionI2 W1 W2 p HpW2)). }
	        claim HxSingSubA: {x} c= A.
	        { exact (singleton_subset x A HxA). }
	        claim HySingSubB: {y} c= B.
	        { exact (singleton_subset y B HyB). }
	        claim HpAB: p :e setprod A B.
	        { claim Hsub: setprod {x} {y} c= setprod A B.
	          { exact (setprod_Subq {x} {y} A B HxSingSubA HySingSubB). }
	          exact (Hsub p Hpsing). }
	        exact HpAB.
Qed.

(** LATEX VERSION: Exercise 4: For open U and closed A, U\\A is open and A\\U is closed. **)
Theorem ex17_4_open_minus_closed_and_closed_minus_open : forall X Tx U A:set,
  topology_on X Tx -> open_in X Tx U -> closed_in X Tx A ->
  open_in X Tx (U :\: A) /\ closed_in X Tx (A :\: U).
let X Tx U A.
assume Htop: topology_on X Tx.
assume HU: open_in X Tx U.
assume HA: closed_in X Tx A.
prove open_in X Tx (U :\: A) /\ closed_in X Tx (A :\: U).
(** Strategy: U\A = U ∩ V for some V open (from A = X\V); A\U = A ∩ (X\U) closed **)
claim HUtop: U :e Tx.
{ exact (andER (topology_on X Tx) (U :e Tx) HU). }
claim HAdef: A c= X /\ (exists V :e Tx, A = X :\: V).
{ exact (andER (topology_on X Tx) (A c= X /\ (exists V :e Tx, A = X :\: V)) HA). }
claim HexV: exists V :e Tx, A = X :\: V.
{ exact (andER (A c= X) (exists V :e Tx, A = X :\: V) HAdef). }
apply HexV.
let V. assume HVandEq. apply HVandEq.
assume HV: V :e Tx.
assume HAeq: A = X :\: V.
apply andI.
- prove open_in X Tx (U :\: A).
  (** U :\: A = U :\: (X :\: V) = U :/\: V when U c= X **)
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U Htop HUtop). }
  claim HUminusA_eq_UinterV: U :\: A = U :/\: V.
  { rewrite HAeq.
    apply set_ext.
    + let x. assume Hx: x :e U :\: (X :\: V).
      claim HxU: x :e U.
      { exact (setminusE1 U (X :\: V) x Hx). }
      claim HxnotXV: x /:e X :\: V.
      { exact (setminusE2 U (X :\: V) x Hx). }
      claim HxV: x :e V.
      { claim HxX: x :e X.
        { exact (HUsub x HxU). }
        apply xm (x :e V).
        * assume Hv. exact Hv.
        * assume Hnv.
          apply FalseE.
          apply HxnotXV.
          exact (setminusI X V x HxX Hnv). }
      exact (binintersectI U V x HxU HxV).
    + let x. assume Hx: x :e U :/\: V.
      claim HxU: x :e U.
      { exact (binintersectE1 U V x Hx). }
      claim HxV: x :e V.
      { exact (binintersectE2 U V x Hx). }
      claim HxnotXV: x /:e X :\: V.
      { assume H. apply (setminusE2 X V x H). exact HxV. }
      exact (setminusI U (X :\: V) x HxU HxnotXV). }
  rewrite HUminusA_eq_UinterV.
  claim HUinterV: U :/\: V :e Tx.
  { exact (topology_binintersect_closed X Tx U V Htop HUtop HV). }
  exact (andI (topology_on X Tx) (U :/\: V :e Tx) Htop HUinterV).
- prove closed_in X Tx (A :\: U).
  (** A :\: U = (X :\: V) :\: U = X :\: (V :\/: U), and V :\/: U is open **)
  claim HAsub: A c= X.
  { exact (andEL (A c= X) (exists V0 :e Tx, A = X :\: V0) HAdef). }
  claim HAminusU_sub: A :\: U c= X.
  { let x. assume Hx. claim HxA: x :e A. { exact (setminusE1 A U x Hx). }
    exact (HAsub x HxA). }
  claim HVU: V :\/: U :e Tx.
  { exact (lemma_union_two_open X Tx V U Htop HV HUtop). }
  claim HAminusU_eq_XminusVU: A :\: U = X :\: (V :\/: U).
  { rewrite HAeq.
    apply set_ext.
    + let x. assume Hx: x :e (X :\: V) :\: U.
      claim HxXV: x :e X :\: V.
      { exact (setminusE1 (X :\: V) U x Hx). }
      claim HxnotU: x /:e U.
      { exact (setminusE2 (X :\: V) U x Hx). }
      claim HxX: x :e X.
      { exact (setminusE1 X V x HxXV). }
      claim HxnotV: x /:e V.
      { exact (setminusE2 X V x HxXV). }
      claim HxnotVU: x /:e V :\/: U.
      { assume H. apply (binunionE V U x H).
        - assume HxV. exact (HxnotV HxV).
        - assume HxU. exact (HxnotU HxU). }
      exact (setminusI X (V :\/: U) x HxX HxnotVU).
    + let x. assume Hx: x :e X :\: (V :\/: U).
      claim HxX: x :e X.
      { exact (setminusE1 X (V :\/: U) x Hx). }
      claim HxnotVU: x /:e V :\/: U.
      { exact (setminusE2 X (V :\/: U) x Hx). }
      claim HxnotV: x /:e V.
      { assume HxV. apply HxnotVU. exact (binunionI1 V U x HxV). }
      claim HxnotU: x /:e U.
      { assume HxU. apply HxnotVU. exact (binunionI2 V U x HxU). }
      claim HxXV: x :e X :\: V.
      { exact (setminusI X V x HxX HxnotV). }
      exact (setminusI (X :\: V) U x HxXV HxnotU). }
  claim HPred: exists W :e Tx, A :\: U = X :\: W.
  { witness (V :\/: U).
    apply andI.
    - exact HVU.
    - exact HAminusU_eq_XminusVU. }
  exact (andI (topology_on X Tx) (A :\: U c= X /\ (exists W :e Tx, A :\: U = X :\: W)) Htop (andI (A :\: U c= X) (exists W :e Tx, A :\: U = X :\: W) HAminusU_sub HPred)).
Qed.

(** from §17 Exercise 5: closure of (a,b) subset [a,b] **)
(** LATEX VERSION: Exercise 5: Let X be an ordered set in the order topology. Show that cl((a,b)) c= [a,b]. Under what conditions does equality hold **)
Theorem ex17_5_closure_of_interval_in_order_topology : forall X a b:set,
  simply_ordered_set X ->
  a :e X ->
  b :e X ->
  closure_of X (order_topology X) (order_interval X a b) c= closed_interval_in X a b.
let X a b.
assume Hso: simply_ordered_set X.
assume HaX: a :e X.
assume HbX: b :e X.
prove closure_of X (order_topology X) (order_interval X a b) c= closed_interval_in X a b.
set Tx := order_topology X.
claim HTx: topology_on X Tx.
{ rewrite <- (open_rays_subbasis_for_order_topology X Hso).
  exact (topology_from_subbasis_is_topology X (open_rays_subbasis X) (open_rays_subbasis_is_subbasis X)). }
claim Hsub: order_interval X a b c= closed_interval_in X a b.
{ let x. assume Hx: x :e order_interval X a b.
  prove x :e closed_interval_in X a b.
  claim Hxpack: x :e X /\ (order_rel X a x /\ order_rel X x b).
  { exact (order_intervalE X a b x Hx). }
  claim HxX: x :e X.
  { exact (andEL (x :e X) (order_rel X a x /\ order_rel X x b) Hxpack). }
  claim Hrel: order_rel X a x /\ order_rel X x b.
  { exact (andER (x :e X) (order_rel X a x /\ order_rel X x b) Hxpack). }
	  claim Hax: order_rel X a x.
	  { exact (andEL (order_rel X a x) (order_rel X x b) Hrel). }
	  claim Hxb: order_rel X x b.
	  { exact (andER (order_rel X a x) (order_rel X x b) Hrel). }
	  claim Hci_def: closed_interval_in X a b =
	    {x0 :e X | (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)}.
	  { reflexivity. }
	  rewrite Hci_def.
	  apply (SepI X
	    (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b))
	    x HxX).
	  apply andI.
	  - exact (orIR (x = a) (order_rel X a x) Hax).
	  - exact (orIR (x = b) (order_rel X x b) Hxb). }
claim Hclosed: closed_in X Tx (closed_interval_in X a b).
{ prove closed_in X Tx (closed_interval_in X a b).
  apply (closed_inI X Tx (closed_interval_in X a b)).
  - exact HTx.
  - (** subset of X **)
    let x. assume Hx: x :e closed_interval_in X a b.
    prove x :e X.
    exact (SepE1 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx).
  - (** complement witness is the union of two open rays **)
    set U := (open_ray_lower X a) :\/: (open_ray_upper X b).
    witness U.
    apply andI.
    + (** U is open in the order topology **)
      claim HUaSub: open_ray_lower X a :e open_rays_subbasis X.
      { exact (open_ray_lower_in_open_rays_subbasis X a HaX). }
      claim HUbSub: open_ray_upper X b :e open_rays_subbasis X.
      { exact (open_ray_upper_in_open_rays_subbasis X b HbX). }
      claim HUaTx: open_ray_lower X a :e Tx.
      { exact ((open_rays_subbasis_sub_order_topology X Hso) (open_ray_lower X a) HUaSub). }
      claim HUbTx: open_ray_upper X b :e Tx.
      { exact ((open_rays_subbasis_sub_order_topology X Hso) (open_ray_upper X b) HUbSub). }
      exact (topology_binunion_closed X Tx (open_ray_lower X a) (open_ray_upper X b) HTx HUaTx HUbTx).
    + (** closed_interval_in = X \\ U **)
      apply set_ext.
      - let x. assume Hx: x :e closed_interval_in X a b.
        prove x :e X :\: U.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
        claim Hcond: (x = a \/ order_rel X a x) /\ (x = b \/ order_rel X x b).
        { exact (SepE2 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
        claim Hleft: x = a \/ order_rel X a x.
        { exact (andEL (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
        claim Hright: x = b \/ order_rel X x b.
        { exact (andER (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
	        claim HnotLower: ~(order_rel X x a).
	        { apply Hleft.
	          - assume Heq: x = a.
	            rewrite Heq at 1.
	            exact (order_rel_irref X a).
	          - assume Hax: order_rel X a x.
	            assume Hxa: order_rel X x a.
	            claim Haa: order_rel X a a.
            { exact (order_rel_trans X a x a Hso HaX HxX HaX Hax Hxa). }
            exact ((order_rel_irref X a) Haa). }
	        claim HnotUpper: ~(order_rel X b x).
	        { apply Hright.
	          - assume Heq: x = b.
	            rewrite Heq.
	            exact (order_rel_irref X b).
	          - assume Hxb: order_rel X x b.
	            assume Hbx: order_rel X b x.
	            claim Hbb: order_rel X b b.
            { exact (order_rel_trans X b x b Hso HbX HxX HbX Hbx Hxb). }
            exact ((order_rel_irref X b) Hbb). }
        apply (setminusI X U x HxX).
        assume HxU: x :e U.
        apply (binunionE (open_ray_lower X a) (open_ray_upper X b) x HxU).
        + assume HxLow: x :e open_ray_lower X a.
          claim Hxa: order_rel X x a.
          { exact (SepE2 X (fun t:set => order_rel X t a) x HxLow). }
          exact (HnotLower Hxa).
        + assume HxUp: x :e open_ray_upper X b.
          claim Hbx: order_rel X b x.
          { exact (SepE2 X (fun t:set => order_rel X b t) x HxUp). }
          exact (HnotUpper Hbx).
      - let x. assume Hx: x :e X :\: U.
        prove x :e closed_interval_in X a b.
        claim Hxpair: x :e X /\ x /:e U.
        { exact (setminusE X U x Hx). }
        claim HxX: x :e X.
        { exact (andEL (x :e X) (x /:e U) Hxpair). }
        claim HxNotU: x /:e U.
        { exact (andER (x :e X) (x /:e U) Hxpair). }
        claim HnotLowSet: ~(x :e open_ray_lower X a).
        { assume HxLow: x :e open_ray_lower X a.
          exact (HxNotU (binunionI1 (open_ray_lower X a) (open_ray_upper X b) x HxLow)). }
        claim HnotUpSet: ~(x :e open_ray_upper X b).
        { assume HxUp: x :e open_ray_upper X b.
          exact (HxNotU (binunionI2 (open_ray_lower X a) (open_ray_upper X b) x HxUp)). }
        claim HnotLower: ~(order_rel X x a).
        { assume Hxa: order_rel X x a.
          claim HxLow: x :e open_ray_lower X a.
          { exact (SepI X (fun t:set => order_rel X t a) x HxX Hxa). }
          exact (HnotLowSet HxLow). }
        claim HnotUpper: ~(order_rel X b x).
        { assume Hbx: order_rel X b x.
          claim HxUp: x :e open_ray_upper X b.
          { exact (SepI X (fun t:set => order_rel X b t) x HxX Hbx). }
          exact (HnotUpSet HxUp). }
        claim Hleft: x = a \/ order_rel X a x.
        { apply (order_rel_trichotomy_or_impred X x a Hso HxX HaX (x = a \/ order_rel X a x)).
          - assume Hxa: order_rel X x a.
            apply FalseE.
            exact (HnotLower Hxa).
          - assume Heq: x = a.
            exact (orIL (x = a) (order_rel X a x) Heq).
          - assume Hax: order_rel X a x.
            exact (orIR (x = a) (order_rel X a x) Hax). }
        claim Hright: x = b \/ order_rel X x b.
        { apply (order_rel_trichotomy_or_impred X x b Hso HxX HbX (x = b \/ order_rel X x b)).
          - assume Hxb: order_rel X x b.
            exact (orIR (x = b) (order_rel X x b) Hxb).
          - assume Heq: x = b.
            exact (orIL (x = b) (order_rel X x b) Heq).
          - assume Hbx: order_rel X b x.
            apply FalseE.
            exact (HnotUpper Hbx). }
        claim Hdef: closed_interval_in X a b =
          {x0 :e X | (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)}.
        { reflexivity. }
        rewrite Hdef.
        exact (SepI X
          (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b))
          x
          HxX
          (andI (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hleft Hright)).
}
exact (closure_subset_of_closed_superset X Tx (order_interval X a b) (closed_interval_in X a b)
  HTx Hsub Hclosed).
Qed.

(** from §17 Exercise 5: conditions for equality cl((a,b)) = [a,b] **)
(** LATEX VERSION: Equality holds under additional hypotheses on the endpoints, e.g. when the order has no gaps at a and b within X. **)
(** Helper definition for Exercise 5: no immediate successor and predecessor endpoints **)
Definition no_immediate_successor : set -> set -> prop := fun X a =>
  forall c:set, c :e X -> order_rel X a c ->
    exists x:set, x :e X /\ order_rel X a x /\ order_rel X x c.

(** from §17 Exercise 5: conditions for equality cl((a,b)) = [a,b] **)
(** LATEX VERSION: Equality holds under additional hypotheses on the endpoints, e.g. when the order has no gaps at a and b within X. **)
Definition no_immediate_predecessor : set -> set -> prop := fun X b =>
  forall c:set, c :e X -> order_rel X c b ->
    exists x:set, x :e X /\ order_rel X c x /\ order_rel X x b.

(** from §17 Exercise 5: local basis meets open interval witness **)
(** LATEX VERSION: For x in [a,b], every order-topology basis neighborhood of x meets (a,b), assuming no immediate successor at a and no immediate predecessor at b. **)
Theorem ex17_5_basis_elem_meets_interval : forall X a b x b0:set,
  simply_ordered_set X ->
  a :e X -> b :e X -> order_rel X a b ->
  no_immediate_successor X a ->
  no_immediate_predecessor X b ->
  x :e closed_interval_in X a b ->
  b0 :e order_topology_basis X ->
  x :e b0 ->
  exists y:set, y :e b0 /\ y :e order_interval X a b.
let X a b x b0.
assume Hso: simply_ordered_set X.
assume Ha: a :e X.
assume Hb: b :e X.
assume Hab: order_rel X a b.
assume Hsucc: no_immediate_successor X a.
assume Hpred: no_immediate_predecessor X b.
assume Hx: x :e closed_interval_in X a b.
assume Hb0B: b0 :e order_topology_basis X.
assume Hxb0: x :e b0.
prove exists y:set, y :e b0 /\ y :e order_interval X a b.
set FamInt := {I :e Power X | exists a0 :e X, exists b0x :e X,
        I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b0x}}.
set FamLow := {I :e Power X | exists b0x :e X, I = {x0 :e X | order_rel X x0 b0x}}.
set FamUp := {I :e Power X | exists a0 :e X, I = {x0 :e X | order_rel X a0 x0}}.
set Bold := (FamInt :\/: FamLow) :\/: FamUp.
claim Hb0BX: b0 :e Bold :\/: {X}.
{ exact Hb0B. }
apply (binunionE Bold {X} b0 Hb0BX).
- assume Hb0Bold: b0 :e Bold.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
  claim Hcond: (x = a \/ order_rel X a x) /\ (x = b \/ order_rel X x b).
  { exact (SepE2 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
  claim Hleft: x = a \/ order_rel X a x.
  { exact (andEL (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
  claim Hright: x = b \/ order_rel X x b.
  { exact (andER (x = a \/ order_rel X a x) (x = b \/ order_rel X x b) Hcond). }
  apply (binunionE (FamInt :\/: FamLow) FamUp b0 Hb0Bold).
  - assume Hb0IntLow: b0 :e FamInt :\/: FamLow.
    apply (binunionE FamInt FamLow b0 Hb0IntLow).
    - assume Hb0Int: b0 :e FamInt.
      claim Hex: exists a0 :e X, exists b1 :e X,
        b0 = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1}.
      { exact (SepE2 (Power X)
          (fun I:set => exists a0 :e X, exists b1 :e X,
            I = {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1})
          b0 Hb0Int). }
      apply Hex.
      let a0. assume Ha0core.
      apply Ha0core.
      assume Ha0X Ha0rest.
      apply Ha0rest.
      let b1. assume Hb1core.
      apply Hb1core.
      assume Hb1X Hb0def.
      claim HxIn: x :e {x0 :e X | order_rel X a0 x0 /\ order_rel X x0 b1}.
      { rewrite <- Hb0def.
        exact Hxb0. }
      claim HxProp: order_rel X a0 x /\ order_rel X x b1.
      { exact (SepE2 X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) x HxIn). }
      claim Ha0x: order_rel X a0 x.
      { exact (andEL (order_rel X a0 x) (order_rel X x b1) HxProp). }
      claim Hxb1: order_rel X x b1.
      { exact (andER (order_rel X a0 x) (order_rel X x b1) HxProp). }
      apply Hleft.
      - assume Hxa: x = a.
        claim Ha0a: order_rel X a0 a.
        { rewrite <- Hxa.
          exact Ha0x. }
        claim Hab1: order_rel X a b1.
        { rewrite <- Hxa.
          exact Hxb1. }
        apply (order_rel_trichotomy_or_impred X b1 b Hso Hb1X Hb (exists y:set, y :e b0 /\ y :e order_interval X a b)).
        - assume Hb1ltb: order_rel X b1 b.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b1.
          { exact (Hsucc b1 Hb1X Hab1). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb1.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0a Hay). }
          claim Hyb: order_rel X y b.
          { exact (order_rel_trans X y b1 b Hso HyX Hb1X Hb Hyb1 Hb1ltb). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                  (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hb1eq: b1 = b.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hsucc b Hb Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0a Hay). }
          claim Hyb1: order_rel X y b1.
          { rewrite Hb1eq.
            exact Hyb. }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                  (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hbltb1: order_rel X b b1.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hsucc b Hb Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0a Hay). }
          claim Hyb1: order_rel X y b1.
          { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hbltb1). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                  (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
      - assume Hax: order_rel X a x.
        apply Hright.
        - assume Hxb: x = b.
          claim Hb1gtb: order_rel X b b1.
          { rewrite <- Hxb.
            exact Hxb1. }
          apply (order_rel_trichotomy_or_impred X a0 a Hso Ha0X Ha (exists y:set, y :e b0 /\ y :e order_interval X a b)).
          - assume Ha0lta: order_rel X a0 a.
            claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
            { exact (Hpred a Ha Hab). }
            apply Hexy0.
            let y. assume Hycore.
            apply Hycore.
            assume HyXpair Hyb.
            claim HyX: y :e X.
            { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
            claim Hay: order_rel X a y.
            { exact (andER (y :e X) (order_rel X a y) HyXpair). }
            claim Ha0y: order_rel X a0 y.
            { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0lta Hay). }
            claim Hyb1: order_rel X y b1.
            { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hb1gtb). }
            witness y.
            apply andI.
            - prove y :e b0.
              rewrite Hb0def.
              exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                    (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
            - prove y :e order_interval X a b.
              exact (order_intervalI X a b y HyX Hay Hyb).
          - assume Ha0eq: a0 = a.
            claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
            { exact (Hpred a Ha Hab). }
            apply Hexy0.
            let y. assume Hycore.
            apply Hycore.
            assume HyXpair Hyb.
            claim HyX: y :e X.
            { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
            claim Hay: order_rel X a y.
            { exact (andER (y :e X) (order_rel X a y) HyXpair). }
            claim Ha0y: order_rel X a0 y.
            { rewrite Ha0eq.
              exact Hay. }
            claim Hyb1: order_rel X y b1.
            { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hb1gtb). }
            witness y.
            apply andI.
            - prove y :e b0.
              rewrite Hb0def.
              exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                    (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
            - prove y :e order_interval X a b.
              exact (order_intervalI X a b y HyX Hay Hyb).
          - assume Halta0: order_rel X a a0.
            claim Hlt: order_rel X a0 b.
            { rewrite <- Hxb.
              exact Ha0x. }
            claim Hexy0: exists y:set, y :e X /\ order_rel X a0 y /\ order_rel X y b.
            { exact (Hpred a0 Ha0X Hlt). }
            apply Hexy0.
            let y. assume Hycore.
            apply Hycore.
            assume HyXpair Hyb.
            claim HyX: y :e X.
            { exact (andEL (y :e X) (order_rel X a0 y) HyXpair). }
            claim Ha0y: order_rel X a0 y.
            { exact (andER (y :e X) (order_rel X a0 y) HyXpair). }
            claim Hay: order_rel X a y.
            { exact (order_rel_trans X a a0 y Hso Ha Ha0X HyX Halta0 Ha0y). }
            claim Hyb1: order_rel X y b1.
            { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hb1gtb). }
            witness y.
            apply andI.
            - prove y :e b0.
              rewrite Hb0def.
              exact (SepI X (fun x0:set => order_rel X a0 x0 /\ order_rel X x0 b1) y HyX
                    (andI (order_rel X a0 y) (order_rel X y b1) Ha0y Hyb1)).
            - prove y :e order_interval X a b.
              exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hxb: order_rel X x b.
          witness x.
          apply andI.
          - exact Hxb0.
          - exact (order_intervalI X a b x HxX Hax Hxb).
    - assume Hb0Low: b0 :e FamLow.
      claim Hex: exists b1 :e X, b0 = {x0 :e X | order_rel X x0 b1}.
      { exact (SepE2 (Power X)
          (fun I:set => exists b1 :e X, I = {x0 :e X | order_rel X x0 b1})
          b0 Hb0Low). }
      apply Hex.
      let b1. assume Hb1core.
      apply Hb1core.
      assume Hb1X Hb0def.
      claim HxIn: x :e {x0 :e X | order_rel X x0 b1}.
      { rewrite <- Hb0def.
        exact Hxb0. }
      claim Hxb1: order_rel X x b1.
      { exact (SepE2 X (fun x0:set => order_rel X x0 b1) x HxIn). }
      apply Hleft.
      - assume Hxa: x = a.
        claim Hab1: order_rel X a b1.
        { rewrite <- Hxa.
          exact Hxb1. }
        apply (order_rel_trichotomy_or_impred X b1 b Hso Hb1X Hb (exists y:set, y :e b0 /\ y :e order_interval X a b)).
        - assume Hb1ltb: order_rel X b1 b.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b1.
          { exact (Hsucc b1 Hb1X Hab1). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb1.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Hyb: order_rel X y b.
          { exact (order_rel_trans X y b1 b Hso HyX Hb1X Hb Hyb1 Hb1ltb). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X x0 b1) y HyX Hyb1).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hb1eq: b1 = b.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hsucc b Hb Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Hyb1: order_rel X y b1.
          { rewrite Hb1eq.
            exact Hyb. }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X x0 b1) y HyX Hyb1).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hbltb1: order_rel X b b1.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hsucc b Hb Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Hyb1: order_rel X y b1.
          { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hbltb1). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X x0 b1) y HyX Hyb1).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
      - assume Hax: order_rel X a x.
        apply Hright.
        - assume Hxb: x = b.
          claim Hb1gtb: order_rel X b b1.
          { rewrite <- Hxb.
            exact Hxb1. }
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hpred a Ha Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Hyb1: order_rel X y b1.
          { exact (order_rel_trans X y b b1 Hso HyX Hb Hb1X Hyb Hb1gtb). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X x0 b1) y HyX Hyb1).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Hxb: order_rel X x b.
          witness x.
          apply andI.
          - exact Hxb0.
          - exact (order_intervalI X a b x HxX Hax Hxb).
  - assume Hb0Up: b0 :e FamUp.
    claim Hex: exists a0 :e X, b0 = {x0 :e X | order_rel X a0 x0}.
    { exact (SepE2 (Power X)
        (fun I:set => exists a0 :e X, I = {x0 :e X | order_rel X a0 x0})
        b0 Hb0Up). }
    apply Hex.
    let a0. assume Ha0core.
    apply Ha0core.
    assume Ha0X Hb0def.
    claim HxIn: x :e {x0 :e X | order_rel X a0 x0}.
    { rewrite <- Hb0def.
      exact Hxb0. }
    claim Ha0x: order_rel X a0 x.
    { exact (SepE2 X (fun x0:set => order_rel X a0 x0) x HxIn). }
    apply Hleft.
    - assume Hxa: x = a.
      claim Ha0a: order_rel X a0 a.
      { rewrite <- Hxa.
        exact Ha0x. }
      claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
      { exact (Hsucc b Hb Hab). }
      apply Hexy0.
      let y. assume Hycore.
      apply Hycore.
      assume HyXpair Hyb.
      claim HyX: y :e X.
      { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
      claim Hay: order_rel X a y.
      { exact (andER (y :e X) (order_rel X a y) HyXpair). }
      claim Ha0y: order_rel X a0 y.
      { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0a Hay). }
      witness y.
      apply andI.
      - prove y :e b0.
        rewrite Hb0def.
        exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Ha0y).
      - prove y :e order_interval X a b.
        exact (order_intervalI X a b y HyX Hay Hyb).
    - assume Hax: order_rel X a x.
      apply Hright.
      - assume Hxb: x = b.
        claim Ha0b: order_rel X a0 b.
        { rewrite <- Hxb.
          exact Ha0x. }
        apply (order_rel_trichotomy_or_impred X a0 a Hso Ha0X Ha (exists y:set, y :e b0 /\ y :e order_interval X a b)).
        - assume Ha0lta: order_rel X a0 a.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hpred a Ha Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { exact (order_rel_trans X a0 a y Hso Ha0X Ha HyX Ha0lta Hay). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Ha0y).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Ha0eq: a0 = a.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
          { exact (Hpred a Ha Hab). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (andER (y :e X) (order_rel X a y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { rewrite Ha0eq.
            exact Hay. }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Ha0y).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
        - assume Halta0: order_rel X a a0.
          claim Hexy0: exists y:set, y :e X /\ order_rel X a0 y /\ order_rel X y b.
          { exact (Hpred a0 Ha0X Ha0b). }
          apply Hexy0.
          let y. assume Hycore.
          apply Hycore.
          assume HyXpair Hyb.
          claim HyX: y :e X.
          { exact (andEL (y :e X) (order_rel X a0 y) HyXpair). }
          claim Ha0y: order_rel X a0 y.
          { exact (andER (y :e X) (order_rel X a0 y) HyXpair). }
          claim Hay: order_rel X a y.
          { exact (order_rel_trans X a a0 y Hso Ha Ha0X HyX Halta0 Ha0y). }
          witness y.
          apply andI.
          - prove y :e b0.
            rewrite Hb0def.
            exact (SepI X (fun x0:set => order_rel X a0 x0) y HyX Ha0y).
          - prove y :e order_interval X a b.
            exact (order_intervalI X a b y HyX Hay Hyb).
      - assume Hxb: order_rel X x b.
        witness x.
        apply andI.
        - exact Hxb0.
        - exact (order_intervalI X a b x HxX Hax Hxb).
- assume Hb0X: b0 :e {X}.
  claim Hb0eq: b0 = X.
  { exact (SingE X b0 Hb0X). }
  claim Hexy0: exists y:set, y :e X /\ order_rel X a y /\ order_rel X y b.
  { exact (Hsucc b Hb Hab). }
  apply Hexy0.
  let y. assume Hycore.
  apply Hycore.
  assume HyXpair Hyb.
  claim HyX: y :e X.
  { exact (andEL (y :e X) (order_rel X a y) HyXpair). }
  claim Hay: order_rel X a y.
  { exact (andER (y :e X) (order_rel X a y) HyXpair). }
  witness y.
  apply andI.
  - prove y :e b0.
    rewrite Hb0eq.
    exact HyX.
  - prove y :e order_interval X a b.
    exact (order_intervalI X a b y HyX Hay Hyb).
Qed.

(** from §17 Exercise 5: conditions for equality cl((a,b)) = [a,b] **)
(** LATEX VERSION: Exercise 5: Equality holds when the endpoints are limit points of (a,b) from within X, e.g. in a dense order without gaps **)
Theorem ex17_5_closure_of_interval_eq_conditions : forall X a b:set,
  simply_ordered_set X ->
  a :e X -> b :e X -> order_rel X a b ->
  no_immediate_successor X a ->
  no_immediate_predecessor X b ->
  closure_of X (order_topology X) (order_interval X a b) = closed_interval_in X a b.
let X a b.
assume Hso: simply_ordered_set X.
assume Ha: a :e X.
assume Hb: b :e X.
assume Hab: order_rel X a b.
assume Hsucc: no_immediate_successor X a.
assume Hpred: no_immediate_predecessor X b.
prove closure_of X (order_topology X) (order_interval X a b) = closed_interval_in X a b.
apply set_ext.
- let x. assume Hx: x :e closure_of X (order_topology X) (order_interval X a b).
  exact (ex17_5_closure_of_interval_in_order_topology X a b Hso Ha Hb x Hx).
- let x. assume Hx: x :e closed_interval_in X a b.
  prove x :e closure_of X (order_topology X) (order_interval X a b).
  set Tx := order_topology X.
  set I := order_interval X a b.
  set B := order_topology_basis X.
  claim HTx: topology_on X Tx.
  { exact (order_topology_is_topology X Hso). }
  claim HI_subX: I c= X.
  { exact (order_interval_subset X a b). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => (x0 = a \/ order_rel X a x0) /\ (x0 = b \/ order_rel X x0 b)) x Hx). }
  claim Hdefcl: closure_of X (order_topology X) (order_interval X a b) =
    {x0 :e X | forall U:set, U :e Tx -> x0 :e U -> U :/\: I <> Empty}.
  { reflexivity. }
  rewrite Hdefcl.
  apply (SepI X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: I <> Empty) x HxX).
  let U. assume HU: U :e Tx. assume HxU: x :e U.
  prove U :/\: I <> Empty.
  claim HUgen: U :e generated_topology X B.
  { exact HU. }
  claim Hexb: exists b0 :e B, x :e b0 /\ b0 c= U.
  { exact (generated_topology_local_refine X B U x HUgen HxU). }
  apply Hexb.
  let b0. assume Hb0core.
  apply Hb0core.
  assume Hb0B Hb0pair.
  claim Hxb0: x :e b0.
  { exact (andEL (x :e b0) (b0 c= U) Hb0pair). }
  claim Hb0subU: b0 c= U.
  { exact (andER (x :e b0) (b0 c= U) Hb0pair). }
  claim Hexy: exists y:set, y :e b0 /\ y :e I.
  { exact (ex17_5_basis_elem_meets_interval X a b x b0 Hso Ha Hb Hab Hsucc Hpred Hx Hb0B Hxb0). }
  apply Hexy.
  let y. assume Hycore.
  apply Hycore.
  assume Hyb0 HyI.
  assume Hempty: U :/\: I = Empty.
  claim HyU: y :e U.
  { exact (Hb0subU y Hyb0). }
  claim HyUI: y :e U :/\: I.
  { exact (binintersectI U I y HyU HyI). }
  claim HyE: y :e Empty.
  { rewrite <- Hempty. exact HyUI. }
  exact (EmptyE y HyE).
Qed.

(** Helper: closure is idempotent and closed **)
(** LATEX VERSION: Closure is closed and idempotent: cl(cl(A)) = cl(A), and cl(A) is closed **)
Theorem closure_idempotent_and_closed : forall X Tx A:set,
  topology_on X Tx ->
  closure_of X Tx (closure_of X Tx A) = closure_of X Tx A /\
  closed_in X Tx (closure_of X Tx A).
let X Tx A.
assume Htop: topology_on X Tx.
prove closure_of X Tx (closure_of X Tx A) = closure_of X Tx A /\ closed_in X Tx (closure_of X Tx A).
(** Strategy: Prove part 2 first (cl(A) is closed), then use it for part 1 (idempotence) **)
set clA := closure_of X Tx A.
claim HclA_sub: clA c= X.
{ let x. assume Hx: x :e clA.
  prove x :e X.
  exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
(** To show clA is closed we want closure_is_closed, but that yields closed_in X Tx (closure_of X Tx clA); we instead prove closed_in X Tx clA directly via the closure definition. **)
apply andI.
- (** cl(cl(A)) = cl(A) - idempotence follows from closure being closed **)
  prove closure_of X Tx clA = clA.
  claim HclA_closed: closed_in X Tx clA.
  { (** Apply closure_is_closed with (A :/\: X) instead of A **)
    (** Since closure_of X Tx (A :/\: X) = closure_of X Tx A, and (A :/\: X) c= X **)
    claim HAX_sub: A :/\: X c= X.
    { exact (binintersect_Subq_2 A X). }
    claim Heq_closure: closure_of X Tx (A :/\: X) = closure_of X Tx A.
    { apply set_ext.
      - let x. assume Hx: x :e closure_of X Tx (A :/\: X).
        prove x :e closure_of X Tx A.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x Hx). }
        claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: (A :/\: X) <> Empty.
        { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x Hx). }
        claim Hpred: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
        { let U. assume HU: U :e Tx. assume HxU: x :e U.
          claim HUX: U c= X.
          { exact (topology_elem_subset X Tx U Htop HU). }
          claim Hinter1: U :/\: (A :/\: X) <> Empty.
          { exact (Hcond U HU HxU). }
          (** U :/\: (A :/\: X) = (U :/\: A) :/\: X, but since U c= X, this equals U :/\: A **)
          claim Heq_inter: U :/\: (A :/\: X) = U :/\: A.
          { apply set_ext.
            - let y. assume Hy: y :e U :/\: (A :/\: X).
              claim HyU: y :e U.
              { exact (binintersectE1 U (A :/\: X) y Hy). }
              claim HyAX: y :e A :/\: X.
              { exact (binintersectE2 U (A :/\: X) y Hy). }
              claim HyA: y :e A.
              { exact (binintersectE1 A X y HyAX). }
              exact (binintersectI U A y HyU HyA).
            - let y. assume Hy: y :e U :/\: A.
              claim HyU: y :e U.
              { exact (binintersectE1 U A y Hy). }
              claim HyA: y :e A.
              { exact (binintersectE2 U A y Hy). }
              claim HyX: y :e X.
              { exact (HUX y HyU). }
              claim HyAX: y :e A :/\: X.
              { exact (binintersectI A X y HyA HyX). }
              exact (binintersectI U (A :/\: X) y HyU HyAX). }
          rewrite <- Heq_inter.
          exact Hinter1. }
        exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hpred).
      - let x. assume Hx: x :e closure_of X Tx A.
        prove x :e closure_of X Tx (A :/\: X).
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
        claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
        { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
        claim Hpred: forall U:set, U :e Tx -> x :e U -> U :/\: (A :/\: X) <> Empty.
        { let U. assume HU: U :e Tx. assume HxU: x :e U.
          claim HUX: U c= X.
          { exact (topology_elem_subset X Tx U Htop HU). }
          claim Hinter1: U :/\: A <> Empty.
          { exact (Hcond U HU HxU). }
          claim Heq_inter: U :/\: (A :/\: X) = U :/\: A.
          { apply set_ext.
            - let y. assume Hy: y :e U :/\: (A :/\: X).
              claim HyU: y :e U.
              { exact (binintersectE1 U (A :/\: X) y Hy). }
              claim HyAX: y :e A :/\: X.
              { exact (binintersectE2 U (A :/\: X) y Hy). }
              claim HyA: y :e A.
              { exact (binintersectE1 A X y HyAX). }
              exact (binintersectI U A y HyU HyA).
            - let y. assume Hy: y :e U :/\: A.
              claim HyU: y :e U.
              { exact (binintersectE1 U A y Hy). }
              claim HyA: y :e A.
              { exact (binintersectE2 U A y Hy). }
              claim HyX: y :e X.
              { exact (HUX y HyU). }
              claim HyAX: y :e A :/\: X.
              { exact (binintersectI A X y HyA HyX). }
              exact (binintersectI U (A :/\: X) y HyU HyAX). }
          rewrite Heq_inter.
          exact Hinter1. }
        exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x HxX Hpred).
    }
    rewrite <- Heq_closure.
    exact (closure_is_closed X Tx (A :/\: X) Htop HAX_sub).
  }
  exact (closed_closure_eq X Tx clA Htop HclA_closed).
- (** cl(A) is closed **)
  prove closed_in X Tx clA.
  (** Same proof as above **)
  claim HAX_sub: A :/\: X c= X.
  { exact (binintersect_Subq_2 A X). }
  claim Heq_closure: closure_of X Tx (A :/\: X) = closure_of X Tx A.
  { apply set_ext.
    - let x. assume Hx: x :e closure_of X Tx (A :/\: X).
      prove x :e closure_of X Tx A.
      claim HxX: x :e X.
      { exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x Hx). }
      claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: (A :/\: X) <> Empty.
      { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x Hx). }
      claim Hpred: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
      { let U. assume HU: U :e Tx. assume HxU: x :e U.
        claim HUX: U c= X.
        { exact (topology_elem_subset X Tx U Htop HU). }
        claim Hinter1: U :/\: (A :/\: X) <> Empty.
        { exact (Hcond U HU HxU). }
        claim Heq_inter: U :/\: (A :/\: X) = U :/\: A.
        { apply set_ext.
          - let y. assume Hy: y :e U :/\: (A :/\: X).
            claim HyU: y :e U.
            { exact (binintersectE1 U (A :/\: X) y Hy). }
            claim HyAX: y :e A :/\: X.
            { exact (binintersectE2 U (A :/\: X) y Hy). }
            claim HyA: y :e A.
            { exact (binintersectE1 A X y HyAX). }
            exact (binintersectI U A y HyU HyA).
          - let y. assume Hy: y :e U :/\: A.
            claim HyU: y :e U.
            { exact (binintersectE1 U A y Hy). }
            claim HyA: y :e A.
            { exact (binintersectE2 U A y Hy). }
            claim HyX: y :e X.
            { exact (HUX y HyU). }
            claim HyAX: y :e A :/\: X.
            { exact (binintersectI A X y HyA HyX). }
            exact (binintersectI U (A :/\: X) y HyU HyAX). }
        rewrite <- Heq_inter.
        exact Hinter1. }
      exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hpred).
    - let x. assume Hx: x :e closure_of X Tx A.
      prove x :e closure_of X Tx (A :/\: X).
      claim HxX: x :e X.
      { exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
      claim Hcond: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
      { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hx). }
      claim Hpred: forall U:set, U :e Tx -> x :e U -> U :/\: (A :/\: X) <> Empty.
      { let U. assume HU: U :e Tx. assume HxU: x :e U.
        claim HUX: U c= X.
        { exact (topology_elem_subset X Tx U Htop HU). }
        claim Hinter1: U :/\: A <> Empty.
        { exact (Hcond U HU HxU). }
        claim Heq_inter: U :/\: (A :/\: X) = U :/\: A.
        { apply set_ext.
          - let y. assume Hy: y :e U :/\: (A :/\: X).
            claim HyU: y :e U.
            { exact (binintersectE1 U (A :/\: X) y Hy). }
            claim HyAX: y :e A :/\: X.
            { exact (binintersectE2 U (A :/\: X) y Hy). }
            claim HyA: y :e A.
            { exact (binintersectE1 A X y HyAX). }
            exact (binintersectI U A y HyU HyA).
          - let y. assume Hy: y :e U :/\: A.
            claim HyU: y :e U.
            { exact (binintersectE1 U A y Hy). }
            claim HyA: y :e A.
            { exact (binintersectE2 U A y Hy). }
            claim HyX: y :e X.
            { exact (HUX y HyU). }
            claim HyAX: y :e A :/\: X.
            { exact (binintersectI A X y HyA HyX). }
            exact (binintersectI U (A :/\: X) y HyU HyAX). }
        rewrite Heq_inter.
        exact Hinter1. }
      exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: X) <> Empty) x HxX Hpred).
  }
  rewrite <- Heq_closure.
  exact (closure_is_closed X Tx (A :/\: X) Htop HAX_sub).
Qed.

(** from §17 Exercise 6(a): monotonicity of closure **)
(** LATEX VERSION: If A c= B then cl(A) c= cl(B). **)
Theorem ex17_6a_closure_monotone : forall X Tx A B:set,
  topology_on X Tx -> A c= B -> B c= X -> closure_of X Tx A c= closure_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HAB: A c= B.
assume HB: B c= X.
prove closure_of X Tx A c= closure_of X Tx B.
exact (closure_monotone X Tx A B Htop HAB HB).
Qed.

(** from §17 Exercise 6(b): closure of a union **)
(** LATEX VERSION: cl(A :\/: B) = cl(A) :\/: cl(B). **)
Theorem ex17_6b_closure_binunion : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  closure_of X Tx (A :\/: B) = closure_of X Tx A :\/: closure_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove closure_of X Tx (A :\/: B) = closure_of X Tx A :\/: closure_of X Tx B.
set clA := closure_of X Tx A.
set clB := closure_of X Tx B.
apply set_ext.
- (** closure(A∪B) c= cl(A) ∪ cl(B) **)
  claim Hsup: closure_of X Tx (A :\/: B) c= clA :\/: clB.
  { (** clA ∪ clB is closed and contains A ∪ B **)
    claim HclA_closed: closed_in X Tx clA.
    { claim Hc: closure_of X Tx (closure_of X Tx A) = closure_of X Tx A /\ closed_in X Tx (closure_of X Tx A).
      { exact (closure_idempotent_and_closed X Tx A Htop). }
      exact (andER (closure_of X Tx (closure_of X Tx A) = closure_of X Tx A) (closed_in X Tx (closure_of X Tx A)) Hc). }
    claim HclB_closed: closed_in X Tx clB.
    { claim Hc: closure_of X Tx (closure_of X Tx B) = closure_of X Tx B /\ closed_in X Tx (closure_of X Tx B).
      { exact (closure_idempotent_and_closed X Tx B Htop). }
      exact (andER (closure_of X Tx (closure_of X Tx B) = closure_of X Tx B) (closed_in X Tx (closure_of X Tx B)) Hc). }
    claim HclUnionClosed: closed_in X Tx (clA :\/: clB).
    { exact (union_of_closed_is_closed X Tx clA clB Htop HclA_closed HclB_closed). }
    claim HABsub: A :\/: B c= clA :\/: clB.
    { let y. assume Hy: y :e A :\/: B.
      apply (binunionE A B y Hy).
      - assume HyA: y :e A.
        claim HyclA: y :e clA.
        { exact (subset_of_closure X Tx A Htop HA y HyA). }
        exact (binunionI1 clA clB y HyclA).
      - assume HyB: y :e B.
        claim HyclB: y :e clB.
        { exact (subset_of_closure X Tx B Htop HB y HyB). }
        exact (binunionI2 clA clB y HyclB). }
    exact (closure_subset_of_closed_superset X Tx (A :\/: B) (clA :\/: clB) Htop HABsub HclUnionClosed). }
  let x. assume Hx: x :e closure_of X Tx (A :\/: B).
  exact (Hsup x Hx).
- (** cl(A) ∪ cl(B) c= closure(A∪B) **)
  claim Hsub: clA :\/: clB c= closure_of X Tx (A :\/: B).
  { exact (closure_union_contains_union_closures X Tx A B Htop HA HB). }
  exact Hsub.
Qed.

(** from §17 Exercise 6(c): closure of an arbitrary union contains union of closures **)
(** LATEX VERSION: cl(Union A_alpha) c=?; always have cl(Union A_alpha) c>= Union cl(A_alpha). **)
Theorem ex17_6c_closure_Union_contains_Union_closures : forall X Tx Fam:set,
  topology_on X Tx ->
  (forall A:set, A :e Fam -> A c= X) ->
  Union {closure_of X Tx A|A :e Fam} c= closure_of X Tx (Union Fam).
let X Tx Fam.
assume Htop: topology_on X Tx.
assume HFsub: forall A:set, A :e Fam -> A c= X.
prove Union {closure_of X Tx A|A :e Fam} c= closure_of X Tx (Union Fam).
set ClFam := {closure_of X Tx A|A :e Fam}.
claim HUnionSubX: Union Fam c= X.
{ let x. assume Hx: x :e Union Fam.
  apply (UnionE_impred Fam x Hx).
  let A. assume HxA. assume HAFam.
  exact ((HFsub A HAFam) x HxA). }
let x. assume Hx: x :e Union ClFam.
prove x :e closure_of X Tx (Union Fam).
apply (UnionE_impred ClFam x Hx).
let W. assume HxW. assume HWClFam.
apply (ReplE Fam (fun A:set => closure_of X Tx A) W HWClFam).
let A. assume HAconj.
claim HAFam: A :e Fam.
{ exact (andEL (A :e Fam) (W = closure_of X Tx A) HAconj). }
claim HWeq: W = closure_of X Tx A.
{ exact (andER (A :e Fam) (W = closure_of X Tx A) HAconj). }
claim HxclA: x :e closure_of X Tx A.
{ rewrite <- HWeq. exact HxW. }
claim HASubUnion: A c= Union Fam.
{ let y. assume Hy: y :e A.
  exact (UnionI Fam y A Hy HAFam). }
claim HxclUnion: x :e closure_of X Tx (Union Fam).
{ exact (closure_monotone X Tx A (Union Fam) Htop HASubUnion HUnionSubX x HxclA). }
exact HxclUnion.
Qed.

(** from §17 Exercise 7: critique the attempted proof about closures of unions **)
(** LATEX VERSION: Criticize the proof that cl(Union A_alpha) c= Union cl(A_alpha). **)
Theorem ex17_7_counterexample_union_closure :
  exists X Tx Fam:set,
    topology_on X Tx /\
    (forall A:set, A :e Fam -> A c= X) /\
    ~ (closure_of X Tx (Union Fam) c= Union {closure_of X Tx A|A :e Fam}).
claim HXomega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
witness omega.
witness (finite_complement_topology omega).
set X := omega.
set Tx := finite_complement_topology omega.
set Fam := {{n}|n :e X :\: {0}}.
witness Fam.
prove topology_on X Tx /\ (forall A:set, A :e Fam -> A c= X) /\ ~ (closure_of X Tx (Union Fam) c= Union {closure_of X Tx A|A :e Fam}).
apply andI.
- (** topology and subset property **)
  apply andI.
  + exact (finite_complement_topology_on X).
  + (** every member of Fam is a subset of X **)
    let A. assume HA: A :e Fam.
    prove A c= X.
    apply (ReplE (X :\: {0}) (fun n:set => {n}) A HA).
    let n. assume Hnconj.
    claim HninX0: n :e X :\: {0}.
    { exact (andEL (n :e X :\: {0}) (A = {n}) Hnconj). }
    claim HAeq: A = {n}.
    { exact (andER (n :e X :\: {0}) (A = {n}) Hnconj). }
    rewrite HAeq.
    let x. assume Hx: x :e {n}.
    claim HxEq: x = n.
    { exact (SingE n x Hx). }
    rewrite HxEq.
    exact (setminusE1 X {0} n HninX0).
- (** counterexample element: 0 **)
  prove ~ (closure_of X Tx (Union Fam) c= Union {closure_of X Tx A|A :e Fam}).
  assume Hsub: closure_of X Tx (Union Fam) c= Union {closure_of X Tx A|A :e Fam}.
    set ClFam := {closure_of X Tx A|A :e Fam}.
    claim Htop: topology_on X Tx.
    { exact (finite_complement_topology_on X). }
    (** Union Fam = X\\{0} **)
    claim HUnionEq: Union Fam = X :\: {0}.
    { apply set_ext.
      - let x. assume Hx: x :e Union Fam.
        prove x :e X :\: {0}.
        apply (UnionE_impred Fam x Hx).
        let A. assume HxA. assume HAFam.
        apply (ReplE (X :\: {0}) (fun n:set => {n}) A HAFam).
        let n. assume Hnconj.
        claim HninX0: n :e X :\: {0}.
        { exact (andEL (n :e X :\: {0}) (A = {n}) Hnconj). }
        claim HAeq: A = {n}.
        { exact (andER (n :e X :\: {0}) (A = {n}) Hnconj). }
        claim HxEq: x = n.
        { claim HxSing: x :e {n}.
          { rewrite <- HAeq. exact HxA. }
          exact (SingE n x HxSing). }
        rewrite HxEq.
        exact HninX0.
      - let x. assume Hx: x :e X :\: {0}.
        prove x :e Union Fam.
        claim HSingFam: {x} :e Fam.
        { exact (ReplI (X :\: {0}) (fun n:set => {n}) x Hx). }
        exact (UnionI Fam x {x} (SingI x) HSingFam).
    }
    (** X\\{0} is infinite, so Union Fam is infinite **)
    claim HsubXX: X c= X.
    { let x. assume Hx: x :e X. exact Hx. }
    claim Hatleast: atleastp omega X.
    { exact (Subq_atleastp omega X HsubXX). }
    claim HinfX: infinite X.
    { exact (atleastp_omega_infinite X Hatleast). }
    claim HinfUnion: infinite (Union Fam).
    { rewrite HUnionEq.
      exact (infinite_remove1 X HinfX 0). }
    (** 0 is in closure(Union Fam) **)
    claim H0in_closure: 0 :e closure_of X Tx (Union Fam).
    { apply (iffER (0 :e closure_of X Tx (Union Fam))
                   (forall U :e Tx, 0 :e U -> U :/\: (Union Fam) <> Empty)
                   (closure_characterization X Tx (Union Fam) 0 Htop HXomega)).
      let U. assume HU: U :e Tx. assume H0U: 0 :e U.
      prove U :/\: (Union Fam) <> Empty.
      claim HUdata: finite (X :\: U) \/ U = Empty.
      { exact (SepE2 (Power X) (fun U0:set => finite (X :\: U0) \/ U0 = Empty) U HU). }
      apply HUdata (U :/\: (Union Fam) <> Empty).
      - assume HUfin: finite (X :\: U).
        prove U :/\: (Union Fam) <> Empty.
        assume Hinter: U :/\: (Union Fam) = Empty.
        (** show Union Fam ⊆ X\\U, hence finite, contradiction **)
        claim Hsub: Union Fam c= X :\: U.
        { let x. assume HxUFam: x :e Union Fam.
          prove x :e X :\: U.
          claim HxX: x :e X.
          { apply (UnionE_impred Fam x HxUFam).
            let A. assume HxA. assume HAFam.
            apply (ReplE (X :\: {0}) (fun n:set => {n}) A HAFam).
            let n. assume Hnconj.
            claim HninX0: n :e X :\: {0}.
            { exact (andEL (n :e X :\: {0}) (A = {n}) Hnconj). }
            claim HAeq: A = {n}.
            { exact (andER (n :e X :\: {0}) (A = {n}) Hnconj). }
            claim HxEq: x = n.
            { claim HxSing: x :e {n}.
              { rewrite <- HAeq. exact HxA. }
              exact (SingE n x HxSing). }
            rewrite HxEq.
            exact (setminusE1 X {0} n HninX0). }
          claim HxnotU: x /:e U.
          { assume HxU: x :e U.
            claim HxInter: x :e U :/\: (Union Fam).
            { apply binintersectI.
              - exact HxU.
              - exact HxUFam. }
            claim HxEmpty: x :e Empty.
            { rewrite <- Hinter. exact HxInter. }
            exact (EmptyE x HxEmpty). }
          exact (setminusI X U x HxX HxnotU). }
        claim HfinUFam: finite (Union Fam).
        { exact (Subq_finite (X :\: U) HUfin (Union Fam) Hsub). }
        apply HinfUnion.
        exact HfinUFam.
      - assume HUempty: U = Empty.
        prove U :/\: (Union Fam) <> Empty.
        assume Hinter: U :/\: (Union Fam) = Empty.
        claim HUne: U <> Empty.
        { exact (elem_implies_nonempty U 0 H0U). }
        apply FalseE.
        exact (HUne HUempty). }
    (** 0 is not in the union of the closures **)
    claim H0not_union_closures: 0 /:e Union ClFam.
    { assume H0in: 0 :e Union ClFam.
      apply (UnionE_impred ClFam 0 H0in).
      let W. assume H0W: 0 :e W. assume HWCl: W :e ClFam.
      apply (ReplE Fam (fun A:set => closure_of X Tx A) W HWCl).
      let A. assume HAconj.
      claim HAFam: A :e Fam.
      { exact (andEL (A :e Fam) (W = closure_of X Tx A) HAconj). }
      claim HWeq: W = closure_of X Tx A.
      { exact (andER (A :e Fam) (W = closure_of X Tx A) HAconj). }
      claim H0clA: 0 :e closure_of X Tx A.
      { rewrite <- HWeq. exact H0W. }
      apply (ReplE (X :\: {0}) (fun n:set => {n}) A HAFam).
      let n. assume Hnconj.
      claim HninX0: n :e X :\: {0}.
      { exact (andEL (n :e X :\: {0}) (A = {n}) Hnconj). }
      claim HAeq: A = {n}.
      { exact (andER (n :e X :\: {0}) (A = {n}) Hnconj). }
      claim HninX: n :e X.
      { exact (setminusE1 X {0} n HninX0). }
      claim HSingSub: {n} c= X.
      { let x. assume Hx: x :e {n}.
        claim HxEq: x = n.
        { exact (SingE n x Hx). }
        rewrite HxEq.
        exact HninX. }
      claim Hclosed: closed_in X Tx {n}.
      { prove topology_on X Tx /\ ({n} c= X /\ exists U :e Tx, {n} = X :\: U).
        apply andI.
        - exact Htop.
        - apply andI.
          + exact HSingSub.
          + witness (X :\: {n}).
            apply andI.
            * (** X\\{n} is open in the finite complement topology **)
              claim HUpow: (X :\: {n}) :e Power X.
              { exact (setminus_In_Power X {n}). }
              claim HfinComp: finite (X :\: (X :\: {n})).
              { rewrite (setminus_setminus_eq X {n} HSingSub).
                exact (Sing_finite n). }
              exact (SepI (Power X) (fun U0:set => finite (X :\: U0) \/ U0 = Empty)
                          (X :\: {n})
                          HUpow
                          (orIL (finite (X :\: (X :\: {n}))) ((X :\: {n}) = Empty) HfinComp)).
            * (** {n} = X\\(X\\{n}) **)
              rewrite (setminus_setminus_eq X {n} HSingSub).
              reflexivity. }
      claim Heq_cl: closure_of X Tx {n} = {n}.
      { exact (closed_closure_eq X Tx {n} Htop Hclosed). }
      claim H0clSing: 0 :e closure_of X Tx {n}.
      { rewrite <- HAeq. exact H0clA. }
      claim H0inSing: 0 :e {n}.
      { rewrite <- Heq_cl. exact H0clSing. }
      claim H0eqn: 0 = n.
      { exact (SingE n 0 H0inSing). }
      claim Hn0: n = 0.
      { rewrite <- H0eqn. reflexivity. }
      claim Hnnot0: n /:e {0}.
      { exact (setminusE2 X {0} n HninX0). }
      claim Hnin0: n :e {0}.
      { rewrite Hn0. exact (SingI 0). }
      exact (Hnnot0 Hnin0). }
    (** contradict the assumed subset **)
    claim H0in_right: 0 :e Union ClFam.
    { exact (Hsub 0 H0in_closure). }
    exact (H0not_union_closures H0in_right).
Qed.

(** from §17 Exercise 8(a): closure of intersection is contained in intersection of closures **)
(** LATEX VERSION: Determine whether cl(A :/\\: B) = cl(A) :/\\: cl(B); always have inclusion c= . **)
Theorem ex17_8a_closure_intersection_Subq_intersection_closures : forall X Tx A B:set,
  topology_on X Tx ->
  closure_of X Tx (A :/\: B) c= closure_of X Tx A :/\: closure_of X Tx B.
let X Tx A B.
assume Htop: topology_on X Tx.
prove closure_of X Tx (A :/\: B) c= closure_of X Tx A :/\: closure_of X Tx B.
(** Strategy: x ∈ cl(A∩B) implies every open neighborhood meets A∩B, hence meets A and meets B, so x ∈ cl(A) ∩ cl(B). **)
let x.
assume Hx: x :e closure_of X Tx (A :/\: B).
prove x :e closure_of X Tx A :/\: closure_of X Tx B.
claim HxX: x :e X.
{ exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: B) <> Empty) x Hx). }
claim HxAB: forall U:set, U :e Tx -> x :e U -> U :/\: (A :/\: B) <> Empty.
{ exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: (A :/\: B) <> Empty) x Hx). }
apply binintersectI.
- prove x :e closure_of X Tx A.
  claim HxA: x :e X /\ (forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty).
  { apply andI.
    + exact HxX.
    + let U. assume HU: U :e Tx. assume HxU: x :e U.
      prove U :/\: A <> Empty.
      claim HABne: U :/\: (A :/\: B) <> Empty.
      { exact (HxAB U HU HxU). }
      assume Hempty: U :/\: A = Empty.
      apply HABne.
      apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: (A :/\: B).
      claim HyU: y :e U.
      { exact (binintersectE1 U (A :/\: B) y Hy). }
      claim HyAB: y :e A :/\: B.
      { exact (binintersectE2 U (A :/\: B) y Hy). }
      claim HyA: y :e A.
      { exact (binintersectE1 A B y HyAB). }
      claim HyUA: y :e U :/\: A.
      { apply binintersectI.
        - exact HyU.
        - exact HyA. }
      rewrite <- Hempty. exact HyUA.
  }
  exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX (andER (x :e X) (forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty) HxA)).
- prove x :e closure_of X Tx B.
  claim HxB: x :e X /\ (forall U:set, U :e Tx -> x :e U -> U :/\: B <> Empty).
  { apply andI.
    + exact HxX.
    + let U. assume HU: U :e Tx. assume HxU: x :e U.
      prove U :/\: B <> Empty.
      claim HABne: U :/\: (A :/\: B) <> Empty.
      { exact (HxAB U HU HxU). }
      assume Hempty: U :/\: B = Empty.
      apply HABne.
      apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: (A :/\: B).
      claim HyU: y :e U.
      { exact (binintersectE1 U (A :/\: B) y Hy). }
      claim HyAB: y :e A :/\: B.
      { exact (binintersectE2 U (A :/\: B) y Hy). }
      claim HyB: y :e B.
      { exact (binintersectE2 A B y HyAB). }
      claim HyUB: y :e U :/\: B.
      { apply binintersectI.
        - exact HyU.
        - exact HyB. }
      rewrite <- Hempty. exact HyUB.
  }
  exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: B <> Empty) x HxX (andER (x :e X) (forall U:set, U :e Tx -> x :e U -> U :/\: B <> Empty) HxB)).
Qed.

(** from §17 Exercise 8(b): closure of an arbitrary intersection and intersection of closures **)
(** LATEX VERSION: Determine whether cl(Intersection A_alpha) = Intersection cl(A_alpha); always have inclusion c= . **)
Theorem ex17_8b_closure_intersection_family_Subq_intersection_closures : forall X Tx Fam:set,
  topology_on X Tx ->
  (forall A:set, A :e Fam -> A c= X) ->
  closure_of X Tx (intersection_of_family X Fam) c=
    intersection_of_family X {closure_of X Tx A|A :e Fam}.
let X Tx Fam.
assume Htop: topology_on X Tx.
assume HFsub: forall A:set, A :e Fam -> A c= X.
prove closure_of X Tx (intersection_of_family X Fam) c= intersection_of_family X {closure_of X Tx A|A :e Fam}.
set Aint := intersection_of_family X Fam.
set ClFam := {closure_of X Tx A|A :e Fam}.
claim HAintSubX: Aint c= X.
{ let x. assume Hx: x :e Aint.
  exact (SepE1 X (fun x0 => forall U:set, U :e Fam -> x0 :e U) x Hx). }
let x. assume Hx: x :e closure_of X Tx Aint.
prove x :e intersection_of_family X ClFam.
claim HxX: x :e X.
{ exact (SepE1 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: Aint <> Empty) x Hx). }
claim Hdef: intersection_of_family X ClFam = {x0 :e X|forall U:set, U :e ClFam -> x0 :e U}.
{ reflexivity. }
rewrite Hdef.
apply SepI.
- exact HxX.
- let W. assume HW: W :e ClFam.
  prove x :e W.
  apply (ReplE Fam (fun A:set => closure_of X Tx A) W HW).
  let A. assume HAconj.
  claim HAFam: A :e Fam.
  { exact (andEL (A :e Fam) (W = closure_of X Tx A) HAconj). }
  claim HWeq: W = closure_of X Tx A.
  { exact (andER (A :e Fam) (W = closure_of X Tx A) HAconj). }
  claim HAintSubA: Aint c= A.
  { let y. assume Hy: y :e Aint.
    claim Hcond: forall U:set, U :e Fam -> y :e U.
    { exact (SepE2 X (fun x0 => forall U:set, U :e Fam -> x0 :e U) y Hy). }
    exact (Hcond A HAFam). }
  claim HxclA: x :e closure_of X Tx A.
  { exact (closure_monotone X Tx Aint A Htop HAintSubA (HFsub A HAFam) x Hx). }
  rewrite HWeq.
  exact HxclA.
Qed.

(** from §17 Exercise 8(c): closure of set difference **)
(** LATEX VERSION: Determine whether cl(A-B) = cl(A) - cl(B); at least cl(A-B) c= cl(A). **)
Theorem ex17_8c_closure_setminus_Subq_closure_left : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  closure_of X Tx (A :\: B) c= closure_of X Tx A.
let X Tx A B.
assume Htop: topology_on X Tx.
assume HA: A c= X.
assume HB: B c= X.
prove closure_of X Tx (A :\: B) c= closure_of X Tx A.
claim Hsub: A :\: B c= A.
{ let x. assume Hx: x :e A :\: B.
  exact (setminusE1 A B x Hx). }
exact (closure_monotone X Tx (A :\: B) A Htop Hsub HA).
Qed.

(** from §17 Exercise 8(c): counterexample to equality cl(A-B) = cl(A) - cl(B) **)
(** LATEX VERSION: Give an example where the equality fails. **)
Theorem ex17_8c_counterexample_equality_fails :
  exists X Tx A B:set,
    topology_on X Tx /\
    A c= X /\ B c= X /\
    closure_of X Tx (A :\: B) <> (closure_of X Tx A :\: closure_of X Tx B).
set X0 := {0} :\/: {1}.
set Tx0 := indiscrete_topology X0.
set A0 := X0.
set B0 := {0}.
witness X0.
witness Tx0.
witness A0.
witness B0.
prove topology_on X0 Tx0 /\ A0 c= X0 /\ B0 c= X0 /\ closure_of X0 Tx0 (A0 :\: B0) <> (closure_of X0 Tx0 A0 :\: closure_of X0 Tx0 B0).
apply andI.
- apply andI.
  - apply andI.
    + exact (indiscrete_topology_on X0).
    + exact (Subq_ref X0).
  - (** B0 c= X0 **)
    let x. assume Hx: x :e B0.
    prove x :e X0.
    claim Hxeq: x = 0.
    { exact (SingE 0 x Hx). }
    rewrite Hxeq.
    exact (binunionI1 {0} {1} 0 (SingI 0)).
- (** inequality **)
  assume Heq: closure_of X0 Tx0 (A0 :\: B0) = (closure_of X0 Tx0 A0 :\: closure_of X0 Tx0 B0).
  (** show 0 in left **)
  claim H0X0: 0 :e X0.
  { exact (binunionI1 {0} {1} 0 (SingI 0)). }
  claim H0in_left: 0 :e closure_of X0 Tx0 (A0 :\: B0).
  { apply (iffER (0 :e closure_of X0 Tx0 (A0 :\: B0))
                 (forall U :e Tx0, 0 :e U -> U :/\: (A0 :\: B0) <> Empty)
                 (closure_characterization X0 Tx0 (A0 :\: B0) 0 (indiscrete_topology_on X0) H0X0)).
    let U. assume HU: U :e Tx0.
    assume H0U: 0 :e U.
    prove U :/\: (A0 :\: B0) <> Empty.
    (** In the indiscrete topology, U is either Empty or X0; since 0 in U, we must have U = X0 **)
    claim HUcases: U = Empty \/ U = X0.
    { claim HU': U :e indiscrete_topology X0.
      { exact HU. }
      exact (iffEL (U :e indiscrete_topology X0) (U = Empty \/ U = X0) (indiscrete_open_iff X0 U) HU'). }
	    apply HUcases.
	    - assume HUe: U = Empty.
	      apply FalseE.
	      claim H0notU: 0 /:e U.
	      { rewrite HUe.
	        exact (EmptyE 0). }
	      exact (H0notU H0U).
	    - assume HUX: U = X0.
	      rewrite HUX.
      (** witness 1 in X0 \\ {0} **)
      claim H1X0: 1 :e X0.
      { exact (binunionI2 {0} {1} 1 (SingI 1)). }
      claim H1notB0: 1 /:e B0.
      { assume H1B0: 1 :e B0.
        claim H10: 1 = 0.
        { exact (SingE 0 1 H1B0). }
        exact (neq_1_0 H10). }
      claim H1in: 1 :e A0 :\: B0.
      { apply setminusI.
        - exact H1X0.
        - exact H1notB0. }
      claim H1in_inter: 1 :e X0 :/\: (A0 :\: B0).
      { exact (binintersectI X0 (A0 :\: B0) 1 H1X0 H1in). }
      exact (elem_implies_nonempty (X0 :/\: (A0 :\: B0)) 1 H1in_inter). }
  (** show 0 not in right **)
  claim H0in_clB: 0 :e closure_of X0 Tx0 B0.
  { claim HB0sub: B0 c= X0.
    { let x. assume Hx: x :e B0.
      prove x :e X0.
      claim Hxeq: x = 0.
      { exact (SingE 0 x Hx). }
      rewrite Hxeq.
      exact (binunionI1 {0} {1} 0 (SingI 0)). }
    exact (subset_of_closure X0 Tx0 B0 (indiscrete_topology_on X0) HB0sub 0 (SingI 0)). }
  claim H0not_right: 0 /:e (closure_of X0 Tx0 A0 :\: closure_of X0 Tx0 B0).
  { assume H0R: 0 :e (closure_of X0 Tx0 A0 :\: closure_of X0 Tx0 B0).
    claim H0not_clB: 0 /:e closure_of X0 Tx0 B0.
    { exact (setminusE2 (closure_of X0 Tx0 A0) (closure_of X0 Tx0 B0) 0 H0R). }
    exact (H0not_clB H0in_clB). }
  (** contradiction via equality **)
  apply H0not_right.
  rewrite <- Heq.
  exact H0in_left.
Qed.

(** LATEX VERSION: Exercise 9: Closure of A×B in product is product of closures. **)
Theorem ex17_9_closure_of_product_subset : forall X Y Tx Ty A B:set,
  topology_on X Tx -> topology_on Y Ty ->
  closure_of (setprod X Y) (product_topology X Tx Y Ty) (setprod A B) =
    setprod (closure_of X Tx A) (closure_of Y Ty B).
let X Y Tx Ty A B.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove closure_of (setprod X Y) (product_topology X Tx Y Ty) (setprod A B) = setprod (closure_of X Tx A) (closure_of Y Ty B).
set Xprod := setprod X Y.
set Tprod := product_topology X Tx Y Ty.
set P := setprod A B.
set clA := closure_of X Tx A.
set clB := closure_of Y Ty B.
apply set_ext.
- let p. assume Hp: p :e closure_of Xprod Tprod P.
  prove p :e setprod clA clB.
  claim HpXprod: p :e Xprod.
  { exact (SepE1 Xprod (fun p0 => forall W:set, W :e Tprod -> p0 :e W -> W :/\: P <> Empty) p Hp). }
  claim Hpcl: forall W:set, W :e Tprod -> p :e W -> W :/\: P <> Empty.
  { exact (SepE2 Xprod (fun p0 => forall W:set, W :e Tprod -> p0 :e W -> W :/\: P <> Empty) p Hp). }
  apply (setprod_elem_decompose X Y p HpXprod).
  let x. assume Hxconj.
  claim HxX: x :e X.
  { exact (andEL (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hxconj). }
  apply (andER (x :e X) (exists y :e Y, p :e setprod {x} {y}) Hxconj).
  let y. assume Hyconj.
  claim HyY: y :e Y.
  { exact (andEL (y :e Y) (p :e setprod {x} {y}) Hyconj). }
  claim HpXYsing: p :e setprod {x} {y}.
  { exact (andER (y :e Y) (p :e setprod {x} {y}) Hyconj). }
  (** show x :e clA **)
  claim HxclA: x :e clA.
  { prove x :e closure_of X Tx A.
    claim Hxcond: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
    { let U. assume HU: U :e Tx. assume HxU: x :e U.
      (** apply closure condition in product to the open rectangle U×Y **)
      set WY := rectangle_set U Y.
      claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
      { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
      claim HYopen: Y :e Ty.
      { exact (topology_has_X Y Ty HTy). }
      claim HWYsub: WY :e product_subbasis X Tx Y Ty.
      { prove WY :e product_subbasis X Tx Y Ty.
        claim HWYV: rectangle_set U Y :e {rectangle_set U V|V :e Ty}.
        { exact (ReplI Ty (fun V1:set => rectangle_set U V1) Y HYopen). }
        exact (famunionI Tx (fun U1:set => {rectangle_set U1 V|V :e Ty}) U (rectangle_set U Y) HU HWYV). }
      claim HWYopen: WY :e Tprod.
      { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty)
                HBasis WY HWYsub). }
      claim HpWY: p :e WY.
      { (** {x}×{y} ⊆ U×Y, hence p ∈ U×Y **)
        claim Hsx: {x} c= U.
        { exact (singleton_subset x U HxU). }
        claim Hsy: {y} c= Y.
        { exact (singleton_subset y Y HyY). }
        claim Hsub: setprod {x} {y} c= setprod U Y.
        { exact (setprod_Subq {x} {y} U Y Hsx Hsy). }
        exact (Hsub p HpXYsing). }
      claim Hnonemp: WY :/\: P <> Empty.
      { exact (Hpcl WY HWYopen HpWY). }
      apply (nonempty_has_element (WY :/\: P) Hnonemp).
      let q. assume HqInt.
      (** from q ∈ (U×Y) ∩ (A×B), get a ∈ U∩A **)
      claim HqWY: q :e WY.
      { exact (binintersectE1 WY P q HqInt). }
      claim HqP: q :e P.
      { exact (binintersectE2 WY P q HqInt). }
      apply (setprod_elem_decompose A B q HqP).
      let a. assume Haconj.
      claim HaA: a :e A.
      { exact (andEL (a :e A) (exists b :e B, q :e setprod {a} {b}) Haconj). }
      apply (andER (a :e A) (exists b :e B, q :e setprod {a} {b}) Haconj).
      let b. assume Hbconj.
      claim HbB: b :e B.
      { exact (andEL (b :e B) (q :e setprod {a} {b}) Hbconj). }
      claim Hqabsing: q :e setprod {a} {b}.
      { exact (andER (b :e B) (q :e setprod {a} {b}) Hbconj). }
      claim Hcoords: a :e U /\ b :e Y.
      { exact (setprod_coords_in a b U Y q Hqabsing HqWY). }
      claim HaU: a :e U.
      { exact (andEL (a :e U) (b :e Y) Hcoords). }
      claim HaUA: a :e U :/\: A.
      { exact (binintersectI U A a HaU HaA). }
      prove U :/\: A <> Empty.
      assume Hempty: U :/\: A = Empty.
      claim HaE: a :e Empty.
      { rewrite <- Hempty. exact HaUA. }
      exact (EmptyE a HaE). }
    exact (SepI X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hxcond). }
  (** show y :e clB **)
  claim HyclB: y :e clB.
  { prove y :e closure_of Y Ty B.
    claim Hycond: forall V:set, V :e Ty -> y :e V -> V :/\: B <> Empty.
    { let V. assume HV: V :e Ty. assume HyV: y :e V.
      set WX := rectangle_set X V.
      claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
      { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
      claim HXopen: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HWXsub: WX :e product_subbasis X Tx Y Ty.
      { prove WX :e product_subbasis X Tx Y Ty.
        claim HWXV: rectangle_set X V :e {rectangle_set X V0|V0 :e Ty}.
        { exact (ReplI Ty (fun V1:set => rectangle_set X V1) V HV). }
        exact (famunionI Tx (fun U1:set => {rectangle_set U1 V0|V0 :e Ty}) X (rectangle_set X V) HXopen HWXV). }
      claim HWXopen: WX :e Tprod.
      { exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty)
                HBasis WX HWXsub). }
      claim HpWX: p :e WX.
      { claim Hsx: {x} c= X.
        { exact (singleton_subset x X HxX). }
        claim Hsy: {y} c= V.
        { exact (singleton_subset y V HyV). }
        claim Hsub: setprod {x} {y} c= setprod X V.
        { exact (setprod_Subq {x} {y} X V Hsx Hsy). }
        exact (Hsub p HpXYsing). }
      claim Hnonemp: WX :/\: P <> Empty.
      { exact (Hpcl WX HWXopen HpWX). }
      apply (nonempty_has_element (WX :/\: P) Hnonemp).
      let q. assume HqInt.
      claim HqWX: q :e WX.
      { exact (binintersectE1 WX P q HqInt). }
      claim HqP: q :e P.
      { exact (binintersectE2 WX P q HqInt). }
      apply (setprod_elem_decompose A B q HqP).
      let a. assume Haconj.
      claim HaA: a :e A.
      { exact (andEL (a :e A) (exists b :e B, q :e setprod {a} {b}) Haconj). }
      apply (andER (a :e A) (exists b :e B, q :e setprod {a} {b}) Haconj).
      let b. assume Hbconj.
      claim HbB: b :e B.
      { exact (andEL (b :e B) (q :e setprod {a} {b}) Hbconj). }
      claim Hqabsing: q :e setprod {a} {b}.
      { exact (andER (b :e B) (q :e setprod {a} {b}) Hbconj). }
      claim Hcoords: a :e X /\ b :e V.
      { exact (setprod_coords_in a b X V q Hqabsing HqWX). }
      claim HbV: b :e V.
      { exact (andER (a :e X) (b :e V) Hcoords). }
      claim HbVB: b :e V :/\: B.
      { exact (binintersectI V B b HbV HbB). }
      prove V :/\: B <> Empty.
      assume Hempty: V :/\: B = Empty.
      claim HbE: b :e Empty.
      { rewrite <- Hempty. exact HbVB. }
      exact (EmptyE b HbE). }
    exact (SepI Y (fun y0 => forall V:set, V :e Ty -> y0 :e V -> V :/\: B <> Empty) y HyY Hycond). }
  (** conclude p ∈ clA×clB using {x}×{y} ⊆ clA×clB **)
  claim Hsx: {x} c= clA.
  { exact (singleton_subset x clA HxclA). }
  claim Hsy: {y} c= clB.
  { exact (singleton_subset y clB HyclB). }
  claim Hsub: setprod {x} {y} c= setprod clA clB.
  { exact (setprod_Subq {x} {y} clA clB Hsx Hsy). }
  exact (Hsub p HpXYsing).
- let p. assume Hp: p :e setprod clA clB.
  prove p :e closure_of Xprod Tprod P.
  claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HTprod: topology_on (setprod X Y) Tprod.
  { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
  (** decompose p into x∈clA, y∈clB and p∈{x}×{y} **)
  apply (setprod_elem_decompose clA clB p Hp).
  let x. assume Hxconj.
  claim HxclA: x :e clA.
  { exact (andEL (x :e clA) (exists y :e clB, p :e setprod {x} {y}) Hxconj). }
  apply (andER (x :e clA) (exists y :e clB, p :e setprod {x} {y}) Hxconj).
  let y. assume Hyconj.
  claim HyclB: y :e clB.
  { exact (andEL (y :e clB) (p :e setprod {x} {y}) Hyconj). }
  claim HpXYsing: p :e setprod {x} {y}.
  { exact (andER (y :e clB) (p :e setprod {x} {y}) Hyconj). }
  (** show p ∈ X×Y to satisfy closure_of's carrier condition **)
  claim HclAsubX: clA c= X.
  { exact (closure_in_space X Tx A HTx). }
  claim HclBsubY: clB c= Y.
  { exact (closure_in_space Y Ty B HTy). }
  claim HpXprod: p :e Xprod.
  { claim Hsub: setprod clA clB c= setprod X Y.
    { exact (setprod_Subq clA clB X Y HclAsubX HclBsubY). }
    exact (Hsub p Hp). }
  (** main closure condition for p **)
  claim Hpcond: forall W:set, W :e Tprod -> p :e W -> W :/\: P <> Empty.
  { let W. assume HW: W :e Tprod. assume HpW: p :e W.
    (** from openness of W, extract rectangle basis element b containing p, b ⊆ W **)
    claim HWgen: W :e generated_topology (setprod X Y) (product_subbasis X Tx Y Ty).
    { exact HW. }
    claim HWprop: forall p0 :e W, exists b :e product_subbasis X Tx Y Ty, p0 :e b /\ b c= W.
    { exact (SepE2 (Power (setprod X Y))
                   (fun U0:set => forall p0 :e U0, exists b :e product_subbasis X Tx Y Ty, p0 :e b /\ b c= U0)
                   W HWgen). }
    claim Hexb: exists b :e product_subbasis X Tx Y Ty, p :e b /\ b c= W.
    { exact (HWprop p HpW). }
    apply Hexb.
    let b. assume Hbconj.
    claim HbSub: b :e product_subbasis X Tx Y Ty.
    { exact (andEL (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= W) Hbconj). }
    claim Hpb: p :e b.
    { exact (andEL (p :e b) (b c= W) (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= W) Hbconj)). }
    claim HbW: b c= W.
    { exact (andER (p :e b) (b c= W) (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= W) Hbconj)). }
    (** decode b as rectangle_set U0 V0 **)
    apply (famunionE Tx (fun U1:set => {rectangle_set U1 V|V :e Ty}) b HbSub).
    let U0. assume HU0conj.
    claim HU0Tx: U0 :e Tx.
    { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
    claim HbInRepl: b :e {rectangle_set U0 V|V :e Ty}.
    { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0conj). }
    apply (ReplE Ty (fun V:set => rectangle_set U0 V) b HbInRepl).
    let V0. assume HV0conj.
    claim HV0Ty: V0 :e Ty.
    { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
    claim Hbeq: b = rectangle_set U0 V0.
    { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0conj). }
    claim HpbRect: p :e rectangle_set U0 V0.
    { rewrite <- Hbeq.
      exact Hpb. }
    (** from p ∈ {x}×{y} and p ∈ U0×V0, get x∈U0 and y∈V0 **)
    claim Hcoords: x :e U0 /\ y :e V0.
    { exact (setprod_coords_in x y U0 V0 p HpXYsing HpbRect). }
    claim HxU0: x :e U0.
    { exact (andEL (x :e U0) (y :e V0) Hcoords). }
    claim HyV0: y :e V0.
    { exact (andER (x :e U0) (y :e V0) Hcoords). }
    (** use x ∈ clA to get U0∩A nonempty **)
    claim HxclAprop: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
    { exact (SepE2 X (fun x0 => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxclA). }
    claim HU0Ane: U0 :/\: A <> Empty.
    { exact (HxclAprop U0 HU0Tx HxU0). }
    apply (nonempty_has_element (U0 :/\: A) HU0Ane).
    let a. assume HaUA.
    claim HaU0: a :e U0.
    { exact (binintersectE1 U0 A a HaUA). }
    claim HaA: a :e A.
    { exact (binintersectE2 U0 A a HaUA). }
    (** use y ∈ clB to get V0∩B nonempty **)
    claim HyclBprop: forall V:set, V :e Ty -> y :e V -> V :/\: B <> Empty.
    { exact (SepE2 Y (fun y0 => forall V:set, V :e Ty -> y0 :e V -> V :/\: B <> Empty) y HyclB). }
    claim HV0Bne: V0 :/\: B <> Empty.
    { exact (HyclBprop V0 HV0Ty HyV0). }
    apply (nonempty_has_element (V0 :/\: B) HV0Bne).
    let b0. assume HbVB.
    claim HbV0: b0 :e V0.
    { exact (binintersectE1 V0 B b0 HbVB). }
    claim HbB: b0 :e B.
    { exact (binintersectE2 V0 B b0 HbVB). }
	    (** now (a,b0) ∈ (U0×V0) ⊆ W and (a,b0) ∈ A×B **)
	    set q := (a,b0).
	    claim HqRect: q :e rectangle_set U0 V0.
	    { exact (tuple_2_rectangle_set U0 V0 a b0 HaU0 HbV0). }
	    claim Hqb: q :e b.
	    { rewrite Hbeq.
	      exact HqRect. }
    claim HqW: q :e W.
    { exact (HbW q Hqb). }
    claim HqP: q :e P.
    { exact (tuple_2_setprod_by_pair_Sigma A B a b0 HaA HbB). }
    set I := W :/\: P.
    claim HqInt: q :e W :/\: P.
    { exact (binintersectI W P q HqW HqP). }
    exact (elem_implies_nonempty (W :/\: P) q HqInt). }
  exact (SepI Xprod (fun p0 => forall W:set, W :e Tprod -> p0 :e W -> W :/\: P <> Empty) p HpXprod Hpcond).
Qed.

(** LATEX VERSION: Exercise 10: Order topology is Hausdorff. **)
Theorem ex17_10_order_topology_Hausdorff : forall X:set,
  simply_ordered_set X ->
  Hausdorff_space X (order_topology X).
let X.
assume Hso: simply_ordered_set X.
prove Hausdorff_space X (order_topology X).
prove topology_on X (order_topology X) /\
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact (order_topology_is_topology X Hso).
- let x1 x2.
  assume Hx1X: x1 :e X.
  assume Hx2X: x2 :e X.
  assume Hne: x1 <> x2.
  prove exists U V:set, U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  apply (order_rel_trichotomy_or_impred X x1 x2 Hso Hx1X Hx2X
    (exists U V:set, U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
  - (** x1 < x2 **)
    assume H12: order_rel X x1 x2.
    set I := order_interval X x1 x2.
    apply (xm (I = Empty)).
    + (** no point strictly between: rays around endpoints are disjoint **)
      assume HIEmpty: I = Empty.
      set U := open_ray_lower X x2.
      set V := open_ray_upper X x1.
      witness U. witness V.
      prove U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
      apply andI.
      - apply andI.
        - apply andI.
          - apply andI.
            + claim HUsub: U :e open_rays_subbasis X.
              { exact (open_ray_lower_in_open_rays_subbasis X x2 Hx2X). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) U HUsub).
            + claim HVsub: V :e open_rays_subbasis X.
              { exact (open_ray_upper_in_open_rays_subbasis X x1 Hx1X). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) V HVsub).
          - (** x1 ∈ (-∞,x2) **)
            prove x1 :e U.
            exact (SepI X (fun t:set => order_rel X t x2) x1 Hx1X H12).
        - (** x2 ∈ (x1,∞) **)
          prove x2 :e V.
          exact (SepI X (fun t:set => order_rel X x1 t) x2 Hx2X H12).
      - (** U ∩ V is the open interval (x1,x2), which is empty by hypothesis **)
        prove U :/\: V = Empty.
        apply set_ext.
        - let y. assume Hy: y :e U :/\: V.
          prove y :e Empty.
          claim HyU: y :e U.
          { exact (binintersectE1 U V y Hy). }
          claim HyV: y :e V.
          { exact (binintersectE2 U V y Hy). }
          claim HyX: y :e X.
          { exact (SepE1 X (fun t:set => order_rel X t x2) y HyU). }
          claim Hylt2: order_rel X y x2.
          { exact (SepE2 X (fun t:set => order_rel X t x2) y HyU). }
          claim H1lty: order_rel X x1 y.
          { exact (SepE2 X (fun t:set => order_rel X x1 t) y HyV). }
          claim HyI: y :e I.
          { exact (SepI X (fun t:set => order_rel X x1 t /\ order_rel X t x2) y HyX (andI (order_rel X x1 y) (order_rel X y x2) H1lty Hylt2)). }
          rewrite <- HIEmpty.
          exact HyI.
        - let y. assume Hy: y :e Empty.
          prove y :e U :/\: V.
          apply FalseE.
          exact (EmptyE y Hy).
    + (** there is a point c with x1<c<x2: separate by rays around c **)
      assume HInon: ~(I = Empty).
      claim HIne: I <> Empty.
      { assume HIeq: I = Empty.
        exact (HInon HIeq). }
      apply (nonempty_has_element I HIne).
      let c. assume HcI: c :e I.
      set U := open_ray_lower X c.
      set V := open_ray_upper X c.
      witness U. witness V.
      prove U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
      claim HcX: c :e X.
      { exact (SepE1 X (fun t:set => order_rel X x1 t /\ order_rel X t x2) c HcI). }
      claim HcProp: order_rel X x1 c /\ order_rel X c x2.
      { exact (SepE2 X (fun t:set => order_rel X x1 t /\ order_rel X t x2) c HcI). }
      claim Hx1c: order_rel X x1 c.
      { exact (andEL (order_rel X x1 c) (order_rel X c x2) HcProp). }
      claim Hcx2: order_rel X c x2.
      { exact (andER (order_rel X x1 c) (order_rel X c x2) HcProp). }
      apply andI.
      - apply andI.
        - apply andI.
          - apply andI.
            + claim HUsub: U :e open_rays_subbasis X.
              { exact (open_ray_lower_in_open_rays_subbasis X c HcX). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) U HUsub).
            + claim HVsub: V :e open_rays_subbasis X.
              { exact (open_ray_upper_in_open_rays_subbasis X c HcX). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) V HVsub).
          - (** x1 ∈ (-∞,c) **)
            prove x1 :e U.
            exact (SepI X (fun t:set => order_rel X t c) x1 Hx1X Hx1c).
        - (** x2 ∈ (c,∞) **)
          prove x2 :e V.
          exact (SepI X (fun t:set => order_rel X c t) x2 Hx2X Hcx2).
      - (** rays around c are disjoint by irreflexivity + transitivity **)
        prove U :/\: V = Empty.
        apply set_ext.
        - let y. assume Hy: y :e U :/\: V.
          prove y :e Empty.
          claim HyU: y :e U.
          { exact (binintersectE1 U V y Hy). }
          claim HyV: y :e V.
          { exact (binintersectE2 U V y Hy). }
          claim HyX: y :e X.
          { exact (SepE1 X (fun t:set => order_rel X t c) y HyU). }
          claim Hyc: order_rel X y c.
          { exact (SepE2 X (fun t:set => order_rel X t c) y HyU). }
          claim Hcy: order_rel X c y.
          { exact (SepE2 X (fun t:set => order_rel X c t) y HyV). }
          claim Hyy: order_rel X y y.
          { exact (order_rel_trans X y c y Hso HyX HcX HyX Hyc Hcy). }
          apply FalseE.
          exact (order_rel_irref X y Hyy).
        - let y. assume Hy: y :e Empty.
          prove y :e U :/\: V.
          apply FalseE.
          exact (EmptyE y Hy).
  - (** x1 = x2, contradiction **)
    assume Heq: x1 = x2.
    exact (FalseE (Hne Heq)
                  (exists U V:set, U :e order_topology X /\ V :e order_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
  - (** x2 < x1: symmetric **)
    assume H21: order_rel X x2 x1.
    set I := order_interval X x2 x1.
    apply (xm (I = Empty)).
    + assume HIEmpty: I = Empty.
      set U0 := open_ray_lower X x1.
      set V0 := open_ray_upper X x2.
      witness V0. witness U0.
      prove V0 :e order_topology X /\ U0 :e order_topology X /\ x1 :e V0 /\ x2 :e U0 /\ V0 :/\: U0 = Empty.
      apply andI.
      - apply andI.
        - apply andI.
          - apply andI.
            + claim HVsub: V0 :e open_rays_subbasis X.
              { exact (open_ray_upper_in_open_rays_subbasis X x2 Hx2X). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) V0 HVsub).
            + claim HUsub: U0 :e open_rays_subbasis X.
              { exact (open_ray_lower_in_open_rays_subbasis X x1 Hx1X). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) U0 HUsub).
          - prove x1 :e V0.
            exact (SepI X (fun t:set => order_rel X x2 t) x1 Hx1X H21).
        - prove x2 :e U0.
          exact (SepI X (fun t:set => order_rel X t x1) x2 Hx2X H21).
      - prove V0 :/\: U0 = Empty.
        apply set_ext.
        - let y. assume Hy: y :e V0 :/\: U0.
          prove y :e Empty.
          claim HyV: y :e V0.
          { exact (binintersectE1 V0 U0 y Hy). }
          claim HyU: y :e U0.
          { exact (binintersectE2 V0 U0 y Hy). }
          claim HyX: y :e X.
          { exact (SepE1 X (fun t:set => order_rel X t x1) y HyU). }
          claim Hylt1: order_rel X y x1.
          { exact (SepE2 X (fun t:set => order_rel X t x1) y HyU). }
          claim H2lty: order_rel X x2 y.
          { exact (SepE2 X (fun t:set => order_rel X x2 t) y HyV). }
          claim HyI: y :e I.
          { exact (SepI X (fun t:set => order_rel X x2 t /\ order_rel X t x1) y HyX (andI (order_rel X x2 y) (order_rel X y x1) H2lty Hylt1)). }
          rewrite <- HIEmpty.
          exact HyI.
        - let y. assume Hy: y :e Empty.
          prove y :e V0 :/\: U0.
          apply FalseE.
          exact (EmptyE y Hy).
    + assume HInon: ~(I = Empty).
      claim HIne: I <> Empty.
      { assume HIeq: I = Empty.
        exact (HInon HIeq). }
      apply (nonempty_has_element I HIne).
      let c. assume HcI: c :e I.
      set U0 := open_ray_lower X c.
      set V0 := open_ray_upper X c.
      witness V0. witness U0.
      prove V0 :e order_topology X /\ U0 :e order_topology X /\ x1 :e V0 /\ x2 :e U0 /\ V0 :/\: U0 = Empty.
      claim HcX: c :e X.
      { exact (SepE1 X (fun t:set => order_rel X x2 t /\ order_rel X t x1) c HcI). }
      claim HcProp: order_rel X x2 c /\ order_rel X c x1.
      { exact (SepE2 X (fun t:set => order_rel X x2 t /\ order_rel X t x1) c HcI). }
      claim Hx2c: order_rel X x2 c.
      { exact (andEL (order_rel X x2 c) (order_rel X c x1) HcProp). }
      claim Hcx1: order_rel X c x1.
      { exact (andER (order_rel X x2 c) (order_rel X c x1) HcProp). }
      apply andI.
      - apply andI.
        - apply andI.
          - apply andI.
            + claim HVsub: V0 :e open_rays_subbasis X.
              { exact (open_ray_upper_in_open_rays_subbasis X c HcX). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) V0 HVsub).
            + claim HUsub: U0 :e open_rays_subbasis X.
              { exact (open_ray_lower_in_open_rays_subbasis X c HcX). }
              exact ((open_rays_subbasis_sub_order_topology X Hso) U0 HUsub).
          - prove x1 :e V0.
            exact (SepI X (fun t:set => order_rel X c t) x1 Hx1X Hcx1).
        - prove x2 :e U0.
          exact (SepI X (fun t:set => order_rel X t c) x2 Hx2X Hx2c).
      - prove V0 :/\: U0 = Empty.
        apply set_ext.
        - let y. assume Hy: y :e V0 :/\: U0.
          prove y :e Empty.
          claim HyV: y :e V0.
          { exact (binintersectE1 V0 U0 y Hy). }
          claim HyU: y :e U0.
          { exact (binintersectE2 V0 U0 y Hy). }
          claim HyX: y :e X.
          { exact (SepE1 X (fun t:set => order_rel X t c) y HyU). }
          claim Hyc: order_rel X y c.
          { exact (SepE2 X (fun t:set => order_rel X t c) y HyU). }
          claim Hcy: order_rel X c y.
          { exact (SepE2 X (fun t:set => order_rel X c t) y HyV). }
          claim Hyy: order_rel X y y.
          { exact (order_rel_trans X y c y Hso HyX HcX HyX Hyc Hcy). }
          apply FalseE.
          exact (order_rel_irref X y Hyy).
        - let y. assume Hy: y :e Empty.
          prove y :e V0 :/\: U0.
          apply FalseE.
          exact (EmptyE y Hy).
Qed.

(** LATEX VERSION: Exercise 11: Product of Hausdorff spaces is Hausdorff. **)
Theorem ex17_11_product_Hausdorff : forall X Tx Y Ty:set,
  Hausdorff_space X Tx -> Hausdorff_space Y Ty ->
  Hausdorff_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HX: Hausdorff_space X Tx.
assume HY: Hausdorff_space Y Ty.
prove Hausdorff_space (setprod X Y) (product_topology X Tx Y Ty).
apply (Hausdorff_stability X Tx Y Ty).
apply andI.
- exact HX.
- exact HY.
Qed.

(** LATEX VERSION: Exercise 12: Subspaces of Hausdorff spaces are Hausdorff. **)
Theorem ex17_12_subspace_Hausdorff : forall X Tx Y:set,
  Hausdorff_space X Tx -> Y c= X -> Hausdorff_space Y (subspace_topology X Tx Y).
let X Tx Y.
assume HX: Hausdorff_space X Tx.
assume HYsubX: Y c= X.
prove Hausdorff_space Y (subspace_topology X Tx Y).
claim HTx: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HX). }
claim HTy: topology_on Y (subspace_topology X Tx Y).
{ exact (subspace_topology_is_topology X Tx Y HTx HYsubX). }
prove topology_on Y (subspace_topology X Tx Y) /\
      (forall y1 y2:set, y1 :e Y -> y2 :e Y -> y1 <> y2 ->
       exists U V:set, U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\
                       y1 :e U /\ y2 :e V /\ U :/\: V = Empty).
apply andI.
- exact HTy.
- let y1 y2. assume Hy1: y1 :e Y. assume Hy2: y2 :e Y. assume Hne: y1 <> y2.
  prove exists U V:set, U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\
                        y1 :e U /\ y2 :e V /\ U :/\: V = Empty.
  (** Strategy: y1,y2 distinct in Y are distinct in X; take disjoint Tx-neighborhoods U',V' and intersect with Y to get disjoint subspace neighborhoods. **)
claim Hsepax:
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ let x1 x2.
  assume Hx1: x1 :e X.
  assume Hx2: x2 :e X.
  assume Hneq: x1 <> x2.
  exact (Hausdorff_space_separation X Tx x1 x2 HX Hx1 Hx2 Hneq). }
  claim Hy1X: y1 :e X.
  { exact (HYsubX y1 Hy1). }
  claim Hy2X: y2 :e X.
  { exact (HYsubX y2 Hy2). }
  claim HexistsUV:
    exists U V:set, U :e Tx /\ V :e Tx /\ y1 :e U /\ y2 :e V /\ U :/\: V = Empty.
  { exact (Hsepax y1 y2 Hy1X Hy2X Hne). }
  set U0 := Eps_i (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ y1 :e U /\ y2 :e V /\ U :/\: V = Empty).
  claim HU0ex:
    exists V:set, U0 :e Tx /\ V :e Tx /\ y1 :e U0 /\ y2 :e V /\ U0 :/\: V = Empty.
  { exact (Eps_i_ex (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ y1 :e U /\ y2 :e V /\ U :/\: V = Empty)
                    HexistsUV). }
  set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ y1 :e U0 /\ y2 :e V /\ U0 :/\: V = Empty).
  claim HV0prop:
    U0 :e Tx /\ V0 :e Tx /\ y1 :e U0 /\ y2 :e V0 /\ U0 :/\: V0 = Empty.
  { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ y1 :e U0 /\ y2 :e V /\ U0 :/\: V = Empty)
                    HU0ex). }
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx)
                 (V0 :e Tx)
                 (andEL (U0 :e Tx /\ V0 :e Tx)
                        (y1 :e U0)
                        (andEL ((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0)
                               (y2 :e V0)
                               (andEL (((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0) /\ y2 :e V0)
                                      (U0 :/\: V0 = Empty)
                                      HV0prop)))). }
  claim HV0Tx: V0 :e Tx.
  { exact (andER (U0 :e Tx)
                 (V0 :e Tx)
                 (andEL (U0 :e Tx /\ V0 :e Tx)
                        (y1 :e U0)
                        (andEL ((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0)
                               (y2 :e V0)
                               (andEL (((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0) /\ y2 :e V0)
                                      (U0 :/\: V0 = Empty)
                                      HV0prop)))). }
  claim Hy1U0: y1 :e U0.
  { exact (andER (U0 :e Tx /\ V0 :e Tx)
                 (y1 :e U0)
                 (andEL ((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0)
                        (y2 :e V0)
                        (andEL (((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0) /\ y2 :e V0)
                               (U0 :/\: V0 = Empty)
                               HV0prop))). }
  claim Hy2V0: y2 :e V0.
  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0)
                 (y2 :e V0)
                 (andEL (((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0) /\ y2 :e V0)
                        (U0 :/\: V0 = Empty)
                        HV0prop)). }
  claim Hdisj: U0 :/\: V0 = Empty.
  { exact (andER (((U0 :e Tx /\ V0 :e Tx) /\ y1 :e U0) /\ y2 :e V0)
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  set U := U0 :/\: Y.
  set V := V0 :/\: Y.
  claim HUinST: U :e subspace_topology X Tx Y.
  { claim HUPowY: U :e Power Y.
    { apply PowerI.
      let z. assume Hz: z :e U.
      exact (binintersectE2 U0 Y z Hz). }
    claim HUdef: exists V' :e Tx, U = V' :/\: Y.
    { witness U0.
      apply andI.
      - exact HU0Tx.
      - reflexivity. }
    exact (SepI (Power Y) (fun U1:set => exists V' :e Tx, U1 = V' :/\: Y) U HUPowY HUdef).
  }
  claim HVinST: V :e subspace_topology X Tx Y.
  { claim HVPowY: V :e Power Y.
    { apply PowerI.
      let z. assume Hz: z :e V.
      exact (binintersectE2 V0 Y z Hz). }
    claim HVdef: exists V' :e Tx, V = V' :/\: Y.
    { witness V0.
      apply andI.
      - exact HV0Tx.
      - reflexivity. }
    exact (SepI (Power Y) (fun U1:set => exists V' :e Tx, U1 = V' :/\: Y) V HVPowY HVdef).
  }
  claim Hy1U: y1 :e U.
  { exact (binintersectI U0 Y y1 Hy1U0 Hy1). }
  claim Hy2V: y2 :e V.
  { exact (binintersectI V0 Y y2 Hy2V0 Hy2). }
  claim HUVempty: U :/\: V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e U :/\: V.
    prove z :e Empty.
    claim HzU: z :e U.
    { exact (binintersectE1 U V z Hz). }
    claim HzV: z :e V.
    { exact (binintersectE2 U V z Hz). }
    claim HzU0: z :e U0.
    { exact (binintersectE1 U0 Y z HzU). }
    claim HzV0: z :e V0.
    { exact (binintersectE1 V0 Y z HzV). }
    claim HzU0V0: z :e U0 :/\: V0.
    { exact (binintersectI U0 V0 z HzU0 HzV0). }
    rewrite <- Hdisj.
    exact HzU0V0.
  }
  witness U.
  witness V.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        { exact HUinST. }
        { exact HVinST. }
      * exact Hy1U.
    + exact Hy2V.
  - exact HUVempty.
Qed.

(** LATEX VERSION: Exercise 13: Diagonal is closed in X×X iff X is Hausdorff. **)
Theorem ex17_13_diagonal_closed_iff_Hausdorff : forall X Tx:set,
  topology_on X Tx ->
  (Hausdorff_space X Tx <->
    closed_in (setprod X X) (product_topology X Tx X Tx) {(x,x)|x :e X}).
let X Tx.
assume Htop: topology_on X Tx.
prove Hausdorff_space X Tx <-> closed_in (setprod X X) (product_topology X Tx X Tx) {(x,x)|x :e X}.
apply iffI.
- assume HH: Hausdorff_space X Tx.
  prove closed_in (setprod X X) (product_topology X Tx X Tx) {(x,x)|x :e X}.
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
                 HH). }
  claim HSep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  { exact (andER (topology_on X Tx)
                 (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
                 HH). }
  set D := {(t,t)|t :e X}.
  set U := setprod X X :\: D.
  claim HTprod: topology_on (setprod X X) (product_topology X Tx X Tx).
  { exact (product_topology_is_topology X Tx X Tx HTx HTx). }
  claim HDsub: D c= setprod X X.
  { let p. assume HpD: p :e D.
	    apply (ReplE X (fun t:set => (t,t)) p HpD).
	    let x. assume Hxpair.
	    claim HxX: x :e X.
	    { exact (andEL (x :e X) (p = (x,x)) Hxpair). }
	    claim Hpeq: p = (x,x).
	    { exact (andER (x :e X) (p = (x,x)) Hxpair). }
	    rewrite Hpeq.
	    exact (tuple_2_setprod_by_pair_Sigma X X x x HxX HxX). }
  claim HUinProd: U :e product_topology X Tx X Tx.
  { prove U :e product_topology X Tx X Tx.
    prove U :e generated_topology (setprod X X) (product_subbasis X Tx X Tx).
    claim HUPow: U :e Power (setprod X X).
    { apply PowerI (setprod X X) U.
      exact (setminus_Subq (setprod X X) D). }
    claim Hprop: forall p :e U, exists b :e product_subbasis X Tx X Tx, p :e b /\ b c= U.
    { let p. assume HpU: p :e U.
      claim HpXY: p :e setprod X X.
      { exact (setminusE1 (setprod X X) D p HpU). }
      claim HpnotD: p /:e D.
      { exact (setminusE2 (setprod X X) D p HpU). }
      apply (Sigma_E X (fun _ : set => X) p HpXY).
      let x. assume Hxpair.
      apply Hxpair.
      assume HxX Hexy.
      apply Hexy.
      let y. assume Hypair.
      apply Hypair.
      assume HyX Hpeq.
      claim Hxy: x <> y.
      { assume HxyEq: x = y.
        claim HpInD: p :e D.
	        { claim Hex: exists t :e X, p = (t,t).
	          { witness x.
	            apply andI.
	            - exact HxX.
	            - rewrite Hpeq.
	              rewrite <- HxyEq.
	              exact (tuple_pair x x). }
	          exact (iffER (p :e D) (exists t :e X, p = (t,t)) (ReplEq X (fun t:set => (t,t)) p) Hex). }
        exact (HpnotD HpInD). }
      claim HexUV: exists U0 V0:set, U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ y :e V0 /\ U0 :/\: V0 = Empty.
      { exact (HSep x y HxX HyX Hxy). }
      apply HexUV.
      let U0. assume HexV0.
      apply HexV0.
      let V0. assume HUV_conj.
      apply HUV_conj.
      assume Hleft HUVempty.
      apply Hleft.
      assume Hleft2 HyV0.
      apply Hleft2.
      assume Hleft3 HxU0.
      apply Hleft3.
      assume HU0 HV0.
      set b := rectangle_set U0 V0.
      witness b.
      apply andI.
      - (** b in product_subbasis **)
        prove b :e product_subbasis X Tx X Tx.
        claim HbV: rectangle_set U0 V0 :e {rectangle_set U0 V|V :e Tx}.
        { exact (ReplI Tx (fun V:set => rectangle_set U0 V) V0 HV0). }
        exact (famunionI Tx (fun U1:set => {rectangle_set U1 V|V :e Tx}) U0 (rectangle_set U0 V0) HU0 HbV).
      - apply andI.
        + (** p in b **)
          rewrite Hpeq.
          exact (pair_Sigma U0 (fun _ : set => V0) x HxU0 y HyV0).
        + (** b subset U **)
          prove b c= U.
          let q. assume Hqb: q :e b.
          prove q :e U.
          apply setminusI.
          * (** q in X×X **)
            claim HU0subX: U0 c= X.
            { exact (topology_elem_subset X Tx U0 HTx HU0). }
            claim HV0subX: V0 c= X.
            { exact (topology_elem_subset X Tx V0 HTx HV0). }
            exact (setprod_Subq U0 V0 X X HU0subX HV0subX q Hqb).
          * (** q not in D **)
            assume HqD: q :e D.
            apply (ReplE X (fun t:set => (t,t)) q HqD).
            let z. assume Hzconj.
            claim HzX: z :e X.
            { exact (andEL (z :e X) (q = (z,z)) Hzconj). }
            claim Hqeq: q = (z,z).
            { exact (andER (z :e X) (q = (z,z)) Hzconj). }
            claim Hsing: q :e setprod {z} {z}.
            { rewrite Hqeq.
              exact (tuple_2_setprod_by_pair_Sigma {z} {z} z z (SingI z) (SingI z)). }
            claim HzUV: z :e U0 /\ z :e V0.
            { exact (setprod_coords_in z z U0 V0 q Hsing Hqb). }
            claim HzU0: z :e U0.
            { exact (andEL (z :e U0) (z :e V0) HzUV). }
            claim HzV0: z :e V0.
            { exact (andER (z :e U0) (z :e V0) HzUV). }
            claim HzInt: z :e U0 :/\: V0.
            { exact (binintersectI U0 V0 z HzU0 HzV0). }
            claim HzE: z :e Empty.
            { rewrite <- HUVempty. exact HzInt. }
            exact (EmptyE z HzE).
    }
    exact (SepI (Power (setprod X X)) (fun U0:set => forall p0 :e U0, exists b :e product_subbasis X Tx X Tx, p0 :e b /\ b c= U0) U HUPow Hprop). }
  prove topology_on (setprod X X) (product_topology X Tx X Tx) /\ (D c= setprod X X /\ exists W :e product_topology X Tx X Tx, D = setprod X X :\: W).
  apply andI.
  - exact HTprod.
  - apply andI.
    + exact HDsub.
    + witness U.
      apply andI.
      * exact HUinProd.
      * (** D = (X×X) \\ U **)
        prove D = setprod X X :\: U.
        rewrite (setminus_setminus_eq (setprod X X) D HDsub).
        reflexivity.
- assume Hclosed: closed_in (setprod X X) (product_topology X Tx X Tx) {(x,x)|x :e X}.
  prove Hausdorff_space X Tx.
  set D := {(t,t)|t :e X}.
  claim HDsub: D c= setprod X X.
  { exact (andEL (D c= setprod X X) (exists U :e product_topology X Tx X Tx, D = setprod X X :\: U)
                 (andER (topology_on (setprod X X) (product_topology X Tx X Tx))
                        (D c= setprod X X /\ exists U :e product_topology X Tx X Tx, D = setprod X X :\: U)
                        Hclosed)). }
  claim HexU: exists U :e product_topology X Tx X Tx, D = setprod X X :\: U.
  { exact (andER (D c= setprod X X) (exists U :e product_topology X Tx X Tx, D = setprod X X :\: U)
                 (andER (topology_on (setprod X X) (product_topology X Tx X Tx))
                        (D c= setprod X X /\ exists U :e product_topology X Tx X Tx, D = setprod X X :\: U)
                        Hclosed)). }
  apply HexU.
  let U. assume HUconj.
  claim HUopen: U :e product_topology X Tx X Tx.
  { exact (andEL (U :e product_topology X Tx X Tx) (D = setprod X X :\: U) HUconj). }
  claim HDeq: D = setprod X X :\: U.
  { exact (andER (U :e product_topology X Tx X Tx) (D = setprod X X :\: U) HUconj). }
  claim HUsubXY: U c= setprod X X.
  { exact (generated_topology_subset (setprod X X) (product_subbasis X Tx X Tx) U HUopen). }
  claim HcompEq: setprod X X :\: D = U.
  { rewrite HDeq.
    exact (setminus_setminus_eq (setprod X X) U HUsubXY). }
  prove topology_on X Tx /\
        forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
          exists U0 V0:set, U0 :e Tx /\ V0 :e Tx /\ x1 :e U0 /\ x2 :e V0 /\ U0 :/\: V0 = Empty.
  apply andI.
  - exact Htop.
  - let x1 x2. assume Hx1X: x1 :e X. assume Hx2X: x2 :e X. assume Hx12: x1 <> x2.
    prove exists U0 V0:set, U0 :e Tx /\ V0 :e Tx /\ x1 :e U0 /\ x2 :e V0 /\ U0 :/\: V0 = Empty.
	    set p := (x1,x2).
    claim HpNotD: p /:e D.
    { assume HpD: p :e D.
	      apply (ReplE X (fun t:set => (t,t)) p HpD).
	      let z. assume Hzconj.
	      claim Hpeq: p = (z,z).
	      { exact (andER (z :e X) (p = (z,z)) Hzconj). }
      claim HpSing: p :e setprod {x1} {x2}.
      { exact (tuple_2_setprod_by_pair_Sigma {x1} {x2} x1 x2 (SingI x1) (SingI x2)). }
      claim HzzIn: (z,z) :e setprod {x1} {x2}.
      { rewrite <- Hpeq.
        exact HpSing. }
      claim HzzSing: (z,z) :e setprod {z} {z}.
      { exact (tuple_2_setprod_by_pair_Sigma {z} {z} z z (SingI z) (SingI z)). }
      claim HzIn: z :e {x1} /\ z :e {x2}.
      { exact (setprod_coords_in z z {x1} {x2} (z,z) HzzSing HzzIn). }
      claim Hzx1: z :e {x1}.
      { exact (andEL (z :e {x1}) (z :e {x2}) HzIn). }
      claim Hzx2: z :e {x2}.
      { exact (andER (z :e {x1}) (z :e {x2}) HzIn). }
      claim HzEqx1: z = x1.
      { exact (SingE x1 z Hzx1). }
      claim HzEqx2: z = x2.
      { exact (SingE x2 z Hzx2). }
      claim Hx12eq: x1 = x2.
      { rewrite <- HzEqx1.
        rewrite HzEqx2.
        reflexivity. }
      exact (Hx12 Hx12eq). }
	    claim HpInU: p :e U.
	    { rewrite <- HcompEq.
	      exact (setminusI (setprod X X) D p
	              (tuple_2_setprod_by_pair_Sigma X X x1 x2 Hx1X Hx2X)
	              HpNotD). }
	    claim HUprop: forall z :e U, exists b :e product_subbasis X Tx X Tx, z :e b /\ b c= U.
	    { exact (SepE2 (Power (setprod X X))
                   (fun U0:set => forall p0 :e U0, exists b :e product_subbasis X Tx X Tx, p0 :e b /\ b c= U0)
                   U HUopen). }
    claim Hexb: exists b :e product_subbasis X Tx X Tx, p :e b /\ b c= U.
    { exact (HUprop p HpInU). }
    apply Hexb.
    let b. assume Hbconj.
    claim HbSub: b :e product_subbasis X Tx X Tx.
    { exact (andEL (b :e product_subbasis X Tx X Tx) (p :e b /\ b c= U) Hbconj). }
    claim Hpb: p :e b.
    { exact (andEL (p :e b) (b c= U) (andER (b :e product_subbasis X Tx X Tx) (p :e b /\ b c= U) Hbconj)). }
    claim HbU: b c= U.
    { exact (andER (p :e b) (b c= U) (andER (b :e product_subbasis X Tx X Tx) (p :e b /\ b c= U) Hbconj)). }
    (** Decode b as a rectangle U0×V0 **)
    apply (famunionE Tx (fun U1:set => {rectangle_set U1 V|V :e Tx}) b HbSub).
    let U0. assume HU0conj.
    claim HU0Tx: U0 :e Tx.
    { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Tx}) HU0conj). }
    claim HbInRepl: b :e {rectangle_set U0 V|V :e Tx}.
    { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Tx}) HU0conj). }
    apply (ReplE Tx (fun V:set => rectangle_set U0 V) b HbInRepl).
    let V0. assume HV0conj.
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (b = rectangle_set U0 V0) HV0conj). }
    claim Hbeq: b = rectangle_set U0 V0.
    { exact (andER (V0 :e Tx) (b = rectangle_set U0 V0) HV0conj). }
    claim HpbRect: p :e rectangle_set U0 V0.
    { rewrite <- Hbeq.
      exact Hpb. }
    claim HpSing: p :e setprod {x1} {x2}.
    { exact (tuple_2_setprod_by_pair_Sigma {x1} {x2} x1 x2 (SingI x1) (SingI x2)). }
    claim Hcoords: x1 :e U0 /\ x2 :e V0.
    { exact (setprod_coords_in x1 x2 U0 V0 p HpSing HpbRect). }
    claim Hx1U0: x1 :e U0.
    { exact (andEL (x1 :e U0) (x2 :e V0) Hcoords). }
    claim Hx2V0: x2 :e V0.
    { exact (andER (x1 :e U0) (x2 :e V0) Hcoords). }
    (** Show U0 ∩ V0 = ∅, otherwise diagonal meets b ⊆ U = complement of D **)
    claim HUVempty: U0 :/\: V0 = Empty.
    { apply set_ext.
      - let z. assume Hz: z :e U0 :/\: V0.
        prove z :e Empty.
        apply FalseE.
        claim HzU0: z :e U0.
        { exact (binintersectE1 U0 V0 z Hz). }
        claim HzV0: z :e V0.
        { exact (binintersectE2 U0 V0 z Hz). }
        claim HzX: z :e X.
        { exact (topology_elem_subset X Tx U0 Htop HU0Tx z HzU0). }
	        set q := (z,z).
	        claim HqInb: q :e rectangle_set U0 V0.
	        { exact (tuple_2_rectangle_set U0 V0 z z HzU0 HzV0). }
        claim HqInb0: q :e b.
        { rewrite Hbeq.
          exact HqInb. }
        claim HqInU: q :e U.
        { exact (HbU q HqInb0). }
        claim HqInD: q :e D.
	        { exact (ReplI X (fun t:set => (t,t)) z HzX). }
        claim HqNotU: q /:e U.
        { claim HqXYU: q :e setprod X X :\: U.
          { rewrite <- HDeq.
            exact HqInD. }
          exact (setminusE2 (setprod X X) U q HqXYU). }
        exact (HqNotU HqInU).
      - exact (Subq_Empty (U0 :/\: V0)). }
    witness U0.
    witness V0.
    apply andI.
    - apply andI.
      + apply andI.
        * apply andI.
          { exact HU0Tx. }
          { exact HV0Tx. }
        * exact Hx1U0.
      + exact Hx2V0.
    - exact HUVempty.
Qed.

(** LATEX VERSION: In the finite complement topology on R, to what point or points does the sequence x_n = 1/n converge? **)
(** For this exercise we represent the sequence by n ↦ 1/(n+1), so it is a function on omega. **)
Definition seq_one_over_n : set := (fun n :e omega => {inv_nat (ordsucc n)}).

Theorem seq_one_over_n_apply : forall n:set, n :e omega ->
  apply_fun seq_one_over_n n = inv_nat (ordsucc n).
let n. assume Hn: n :e omega.
prove apply_fun seq_one_over_n n = inv_nat (ordsucc n).
set f := seq_one_over_n.
claim HinvIn: inv_nat (ordsucc n) :e {inv_nat (ordsucc n)}.
{ exact (SingI (inv_nat (ordsucc n))). }
claim HpairIn: (n, inv_nat (ordsucc n)) :e f.
{ exact (lamI2 omega (fun k : set => {inv_nat (ordsucc k)}) n Hn (inv_nat (ordsucc n)) HinvIn). }
claim Happair: (n, apply_fun f n) :e f.
{ exact (Eps_i_ax (fun y:set => (n,y) :e f) (inv_nat (ordsucc n)) HpairIn). }
apply (lamE omega (fun k : set => {inv_nat (ordsucc k)}) (n, apply_fun f n) Happair).
let x0. assume Hx0_conj.
apply Hx0_conj.
assume Hx0 Hexy0.
apply Hexy0.
let y0. assume Hy0_conj.
apply Hy0_conj.
assume Hy0 Heq.
claim HeqT: (n, apply_fun f n) = (x0, y0).
{ rewrite <- (tuple_pair x0 y0).
  exact Heq. }
claim H0eq: (n, apply_fun f n) 0 = (x0, y0) 0.
{ rewrite HeqT. reflexivity. }
claim H1eq: (n, apply_fun f n) 1 = (x0, y0) 1.
{ rewrite HeqT. reflexivity. }
claim Hnx0: n = x0.
{ prove n = x0.
  rewrite <- (tuple_2_0_eq n (apply_fun f n)).
  rewrite <- (tuple_2_0_eq x0 y0).
  exact H0eq. }
claim Happ: apply_fun f n = y0.
{ prove apply_fun f n = y0.
  rewrite <- (tuple_2_1_eq n (apply_fun f n)).
  rewrite <- (tuple_2_1_eq x0 y0).
  exact H1eq. }
claim Hy0eq: y0 = inv_nat (ordsucc x0).
{ exact (SingE (inv_nat (ordsucc x0)) y0 Hy0). }
claim Hx0n: x0 = n.
{ rewrite Hnx0. reflexivity. }
rewrite Happ.
rewrite Hy0eq.
rewrite Hx0n.
reflexivity.
Qed.

Theorem inv_nat_ordsucc_inj : forall n m:set,
  n :e omega -> m :e omega -> inv_nat (ordsucc n) = inv_nat (ordsucc m) -> n = m.
let n m.
assume Hn: n :e omega.
assume Hm: m :e omega.
assume Heq: inv_nat (ordsucc n) = inv_nat (ordsucc m).
prove n = m.
claim Hn_ord: ordinal n.
{ exact (ordinal_Hered omega omega_ordinal n Hn). }
claim Hm_ord: ordinal m.
{ exact (ordinal_Hered omega omega_ordinal m Hm). }
claim Hposn: 0 < ordsucc n.
{ exact (ordinal_ordsucc_pos n Hn_ord). }
claim Hposm: 0 < ordsucc m.
{ exact (ordinal_ordsucc_pos m Hm_ord). }
claim Hn1: ordsucc n :e omega.
{ exact (omega_ordsucc n Hn). }
claim Hm1: ordsucc m :e omega.
{ exact (omega_ordsucc m Hm). }
claim HSn: SNo (ordsucc n).
{ exact (omega_SNo (ordsucc n) Hn1). }
claim HSm: SNo (ordsucc m).
{ exact (omega_SNo (ordsucc m) Hm1). }
claim Hposcase_n: inv_nat (ordsucc n) = recip_SNo_pos (ordsucc n).
{ exact (recip_SNo_poscase (ordsucc n) Hposn). }
claim Hposcase_m: inv_nat (ordsucc m) = recip_SNo_pos (ordsucc m).
{ exact (recip_SNo_poscase (ordsucc m) Hposm). }
claim Hpos_eq: recip_SNo_pos (ordsucc n) = recip_SNo_pos (ordsucc m).
{ prove recip_SNo_pos (ordsucc n) = recip_SNo_pos (ordsucc m).
  rewrite <- Hposcase_n.
  rewrite <- Hposcase_m.
  exact Heq. }
claim Hinv_eq: recip_SNo_pos (recip_SNo_pos (ordsucc n)) = recip_SNo_pos (recip_SNo_pos (ordsucc m)).
{ prove recip_SNo_pos (recip_SNo_pos (ordsucc n)) = recip_SNo_pos (recip_SNo_pos (ordsucc m)).
  rewrite Hpos_eq.
  reflexivity. }
claim Hord: ordsucc n = ordsucc m.
{ prove ordsucc n = ordsucc m.
  rewrite <- (recip_SNo_pos_invol (ordsucc n) HSn Hposn).
  rewrite <- (recip_SNo_pos_invol (ordsucc m) HSm Hposm).
  exact Hinv_eq. }
exact (ordsucc_inj n m Hord).
Qed.

Theorem omega_binunion : forall a b:set, a :e omega -> b :e omega -> a :\/: b :e omega.
let a b.
assume Ha: a :e omega.
assume Hb: b :e omega.
prove a :\/: b :e omega.
apply (xm (a :e b)).
- assume Hab: a :e b.
  claim Hsub: a c= b.
  { claim Hb_nat: nat_p b.
    { exact (omega_nat_p b Hb). }
    claim Hb_ord: ordinal b.
    { exact (nat_p_ordinal b Hb_nat). }
    claim Hb_trans: TransSet b.
    { exact (andEL (TransSet b) (forall beta :e b, TransSet beta) Hb_ord). }
    exact (Hb_trans a Hab). }
  claim Heq: a :\/: b = b.
  { apply set_ext.
    - exact (binunion_Subq_min a b b Hsub (Subq_ref b)).
    - exact (binunion_Subq_2 a b). }
  rewrite Heq.
  exact Hb.
- assume Hanb: a /:e b.
  claim Ha_nat: nat_p a.
  { exact (omega_nat_p a Ha). }
  claim Hb_nat: nat_p b.
  { exact (omega_nat_p b Hb). }
  claim Ha_ord: ordinal a.
  { exact (nat_p_ordinal a Ha_nat). }
  claim Hb_ord: ordinal b.
  { exact (nat_p_ordinal b Hb_nat). }
  claim Hcases: a :e b \/ b c= a.
  { exact (ordinal_In_Or_Subq a b Ha_ord Hb_ord). }
  claim Hsub: b c= a.
  { apply (Hcases (b c= a)).
    - assume Hab: a :e b.
      apply FalseE.
      exact (Hanb Hab).
    - assume H. exact H. }
  claim Heq: a :\/: b = a.
  { apply set_ext.
    - exact (binunion_Subq_min a b a (Subq_ref a) Hsub).
    - exact (binunion_Subq_1 a b). }
  rewrite Heq.
  exact Ha.
Qed.

Theorem seq_one_over_n_inj : forall n m:set, n :e omega -> m :e omega ->
  apply_fun seq_one_over_n n = apply_fun seq_one_over_n m -> n = m.
let n m.
assume Hn: n :e omega.
assume Hm: m :e omega.
assume Heq: apply_fun seq_one_over_n n = apply_fun seq_one_over_n m.
prove n = m.
claim HnEq: apply_fun seq_one_over_n n = inv_nat (ordsucc n).
{ exact (seq_one_over_n_apply n Hn). }
claim HmEq: apply_fun seq_one_over_n m = inv_nat (ordsucc m).
{ exact (seq_one_over_n_apply m Hm). }
claim Heq': inv_nat (ordsucc n) = inv_nat (ordsucc m).
{ prove inv_nat (ordsucc n) = inv_nat (ordsucc m).
  rewrite <- HnEq.
  rewrite <- HmEq.
  exact Heq. }
exact (inv_nat_ordsucc_inj n m Hn Hm Heq').
Qed.

(** helper: K_set is infinite (inject omega via n ↦ 1/(n+1)) **)
(** LATEX VERSION: Not a numbered item; used to show K is infinite when analyzing closure in the finite complement topology. **)
Theorem K_set_infinite : infinite K_set.
prove infinite K_set.
(** show atleastp omega K_set by exhibiting an injection omega -> K_set **)
claim Hatleast: exists f : set -> set, inj omega K_set f.
{ witness (fun n:set => inv_nat (ordsucc n)).
  prove inj omega K_set (fun n:set => inv_nat (ordsucc n)).
  (** expand `inj` to its defining conjunction **)
  prove (forall u :e omega, inv_nat (ordsucc u) :e K_set)
    /\ (forall u v :e omega, inv_nat (ordsucc u) = inv_nat (ordsucc v) -> u = v).
  apply andI.
  - let n. assume Hn: n :e omega.
    prove inv_nat (ordsucc n) :e K_set.
    claim HsuccO: ordsucc n :e omega.
    { exact (omega_ordsucc n Hn). }
    claim HsuccNot0: ordsucc n /:e {0}.
    { assume Hmem: ordsucc n :e {0}.
      claim Heq0: ordsucc n = 0.
      { exact (SingE 0 (ordsucc n) Hmem). }
      exact (neq_ordsucc_0 n Heq0). }
    claim HsuccIn: ordsucc n :e omega :\: {0}.
    { exact (setminusI omega {0} (ordsucc n) HsuccO HsuccNot0). }
    exact (ReplI (omega :\: {0}) (fun k:set => inv_nat k) (ordsucc n) HsuccIn).
  - let n. assume Hn: n :e omega.
    let m. assume Hm: m :e omega.
    assume Heq: inv_nat (ordsucc n) = inv_nat (ordsucc m).
    exact (inv_nat_ordsucc_inj n m Hn Hm Heq). }
exact (atleastp_omega_infinite K_set Hatleast).
Qed.

Theorem ex17_14_sequence_in_finite_complement_topology : forall x:set,
  x :e R ->
  forall U:set,
    U :e finite_complement_topology R ->
    x :e U ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n :e U.
let x.
assume HxR: x :e R.
let U.
assume HU: U :e finite_complement_topology R.
assume HxU: x :e U.
prove exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n :e U.
(** let F = R\\U, which is finite since U is nonempty **)
claim HUpow: U :e Power R.
{ exact (SepE1 (Power R) (fun U0:set => finite (R :\: U0) \/ U0 = Empty) U HU). }
claim Hcases: finite (R :\: U) \/ U = Empty.
{ exact (SepE2 (Power R) (fun U0:set => finite (R :\: U0) \/ U0 = Empty) U HU). }
claim HUne: U <> Empty.
{ assume HUe: U = Empty.
  claim HxEmpty: x :e Empty.
  { rewrite <- HUe. exact HxU. }
  exact (EmptyE x HxEmpty). }
claim HF: finite (R :\: U).
{ apply Hcases.
  - assume Hfin. exact Hfin.
  - assume HUe.
    apply FalseE.
    exact (HUne HUe). }
set F := R :\: U.
claim HF_def: F = R :\: U.
{ reflexivity. }
claim HF_fin: finite F.
{ rewrite HF_def. exact HF. }
(** build a bound N so that for all n>=N, the sequence value is not in F **)
claim Hbound: exists N:set, N :e omega /\
  forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e F.
{ apply (finite_ind (fun A:set => exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e A)).
  - (** base **)
    prove exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e Empty.
    witness 0.
    apply andI.
    + exact (nat_p_omega 0 nat_0).
    + let n. assume Hn. assume Hsub.
      exact (EmptyE (apply_fun seq_one_over_n n)).
  - (** step **)
    let A y.
    assume HAfin: finite A.
    assume HynA: y /:e A.
    assume HIA: exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e A.
    prove exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e (A :\/: {y}).
    apply HIA.
    let N0. assume HN0.
    claim HN0o: N0 :e omega.
    { exact (andEL (N0 :e omega) (forall n:set, n :e omega -> N0 c= n -> apply_fun seq_one_over_n n /:e A) HN0). }
    claim HN0prop: forall n:set, n :e omega -> N0 c= n -> apply_fun seq_one_over_n n /:e A.
    { exact (andER (N0 :e omega) (forall n:set, n :e omega -> N0 c= n -> apply_fun seq_one_over_n n /:e A) HN0). }
    (** case split: y occurs as a sequence value or not **)
    apply (xm (exists k:set, k :e omega /\ apply_fun seq_one_over_n k = y)).
    - assume Hexk: exists k:set, k :e omega /\ apply_fun seq_one_over_n k = y.
      apply Hexk.
      let k. assume Hkpair.
      claim Hk: k :e omega.
      { exact (andEL (k :e omega) (apply_fun seq_one_over_n k = y) Hkpair). }
      claim Hkeq: apply_fun seq_one_over_n k = y.
      { exact (andER (k :e omega) (apply_fun seq_one_over_n k = y) Hkpair). }
      set N := ordsucc (N0 :\/: ordsucc k).
      witness N.
      apply andI.
      + (** N in omega **)
        claim Hk1: ordsucc k :e omega.
        { exact (omega_ordsucc k Hk). }
        claim Hmax: N0 :\/: ordsucc k :e omega.
        { exact (omega_binunion N0 (ordsucc k) HN0o Hk1). }
        exact (omega_ordsucc (N0 :\/: ordsucc k) Hmax).
      + let n. assume Hn: n :e omega. assume HNsub: N c= n.
        prove apply_fun seq_one_over_n n /:e (A :\/: {y}).
        (** first, n is beyond N0 so the value is not in A **)
        claim HN0sub: N0 c= n.
        { let t. assume Ht: t :e N0.
          claim HtN: t :e N.
          { claim Htmax: t :e (N0 :\/: ordsucc k).
            { exact (binunionI1 N0 (ordsucc k) t Ht). }
            exact (ordsuccI1 (N0 :\/: ordsucc k) t Htmax). }
          exact (HNsub t HtN). }
        claim HnotA: apply_fun seq_one_over_n n /:e A.
        { exact (HN0prop n Hn HN0sub). }
        (** also, n is beyond k, so the value is not y by injectivity **)
        claim HkInN: k :e N.
        { claim HkInSk: k :e ordsucc k.
          { exact (ordsuccI2 k). }
          claim HkInMax: k :e (N0 :\/: ordsucc k).
          { exact (binunionI2 N0 (ordsucc k) k HkInSk). }
          exact (ordsuccI1 (N0 :\/: ordsucc k) k HkInMax). }
        claim HkInNn: k :e n.
        { exact (HNsub k HkInN). }
	        claim Hneqnk: n <> k.
	        { assume Hnk: n = k.
	          claim Hkin: k :e k.
	          { rewrite <- Hnk at 2. exact HkInNn. }
	          exact (In_irref k Hkin). }
	        claim Hneqval: apply_fun seq_one_over_n n <> y.
	        { assume Hval: apply_fun seq_one_over_n n = y.
	          claim HnEqk: n = k.
	          { claim Hkeq': y = apply_fun seq_one_over_n k.
	            { prove y = apply_fun seq_one_over_n k.
	              symmetry.
	              exact Hkeq. }
	            claim Heqnk: apply_fun seq_one_over_n n = apply_fun seq_one_over_n k.
	            { exact (eq_i_tra (apply_fun seq_one_over_n n) y (apply_fun seq_one_over_n k) Hval Hkeq'). }
	            exact (seq_one_over_n_inj n k Hn Hk Heqnk). }
	          exact (Hneqnk HnEqk). }
        (** combine **)
        assume Hmem: apply_fun seq_one_over_n n :e (A :\/: {y}).
        apply (binunionE' A {y} (apply_fun seq_one_over_n n) False).
        - assume HinA. exact (HnotA HinA).
        - assume HinSing.
          claim Heqv: apply_fun seq_one_over_n n = y.
          { exact (SingE y (apply_fun seq_one_over_n n) HinSing). }
          exact (Hneqval Heqv).
        - exact Hmem.
    - assume Hno: ~(exists k:set, k :e omega /\ apply_fun seq_one_over_n k = y).
      (** N0 already works **)
      witness N0.
      apply andI.
      + exact HN0o.
      + let n. assume Hn: n :e omega. assume HN0sub: N0 c= n.
        prove apply_fun seq_one_over_n n /:e (A :\/: {y}).
        claim HnotA: apply_fun seq_one_over_n n /:e A.
        { exact (HN0prop n Hn HN0sub). }
        claim Hnoty: apply_fun seq_one_over_n n /:e {y}.
        { assume Hin.
          claim Heqv: apply_fun seq_one_over_n n = y.
          { exact (SingE y (apply_fun seq_one_over_n n) Hin). }
          apply Hno.
          witness n.
          apply andI.
          - exact Hn.
          - exact Heqv. }
        assume Hmem: apply_fun seq_one_over_n n :e (A :\/: {y}).
        apply (binunionE' A {y} (apply_fun seq_one_over_n n) False).
        - assume HinA. exact (HnotA HinA).
        - assume HinS. exact (Hnoty HinS).
        - exact Hmem.
  - (** apply to F **)
    exact HF_fin.
}
apply Hbound.
let N. assume HNpair.
claim HN: N :e omega.
{ exact (andEL (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e F) HNpair). }
claim HNprop: forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e F.
{ exact (andER (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq_one_over_n n /:e F) HNpair). }
witness N.
apply andI.
- exact HN.
- let n. assume Hn: n :e omega. assume HNsub: N c= n.
  (** show the value lies in U by contradiction: otherwise it would be in F=R\\U **)
  claim HvalR: apply_fun seq_one_over_n n :e R.
  { rewrite (seq_one_over_n_apply n Hn).
    exact (inv_nat_real (ordsucc n) (omega_ordsucc n Hn)). }
  claim HnotF: apply_fun seq_one_over_n n /:e F.
  { exact (HNprop n Hn HNsub). }
  apply (xm (apply_fun seq_one_over_n n :e U)).
  * assume HvalU. exact HvalU.
  * assume HnotU: ~(apply_fun seq_one_over_n n :e U).
    claim HinF: apply_fun seq_one_over_n n :e F.
    { prove apply_fun seq_one_over_n n :e F.
      rewrite HF_def.
      apply setminusI.
      - exact HvalR.
      - exact HnotU. }
    exact (FalseE (HnotF HinF) (apply_fun seq_one_over_n n :e U)).
Qed.

(** helper: T1_space is equivalent to all singleton subsets being closed **)
Theorem lemma_T1_singletons_closed : forall X Tx:set,
  topology_on X Tx ->
  (T1_space X Tx <-> (forall x:set, x :e X -> closed_in X Tx {x})).
let X Tx.
assume Htop: topology_on X Tx.
prove T1_space X Tx <-> (forall x:set, x :e X -> closed_in X Tx {x}).
apply iffI.
- (** Forward: T1_space → singletons closed **)
  assume HT1: T1_space X Tx.
  prove forall x:set, x :e X -> closed_in X Tx {x}.
  let x.
  assume Hx: x :e X.
  prove closed_in X Tx {x}.
  (** T1_space says all finite subsets of X are closed; {x} is finite, hence closed. **)
  claim Hx_finite: finite {x}.
  { exact (Sing_finite x). }
  claim Hx_sub: {x} c= X.
  { let y. assume Hy: y :e {x}.
    claim Hyeq: y = x.
    { exact (SingE x y Hy). }
    rewrite Hyeq. exact Hx. }
  exact (T1_space_finite_closed X Tx {x} HT1 Hx_sub Hx_finite).
- (** Backward: singletons closed → T1_space **)
  assume Hsing: forall x:set, x :e X -> closed_in X Tx {x}.
  prove T1_space X Tx.
  prove topology_on X Tx /\ (forall F:set, F c= X -> finite F -> closed_in X Tx F).
  apply andI.
  + exact Htop.
  + prove forall F:set, F c= X -> finite F -> closed_in X Tx F.
    let F. assume HFsub: F c= X. assume HF: finite F.
	    prove closed_in X Tx F.
			    (** Strategy: prove finite unions of singletons are closed (use union_of_closed_is_closed and induction on finite sets). **)
		    claim Hclosed_empty: closed_in X Tx Empty.
		    { exact (empty_is_closed X Tx Htop). }
		    claim Hclosed_union: forall A B:set, closed_in X Tx A -> closed_in X Tx B -> closed_in X Tx (A :\/: B).
		    { let A B. assume HA. assume HB.
		      exact (union_of_closed_is_closed X Tx A B Htop HA HB). }
		    claim Hall: forall F0:set, finite F0 -> (F0 c= X -> closed_in X Tx F0).
		    { exact (finite_ind
		               (fun F0:set => F0 c= X -> closed_in X Tx F0)
		               (fun _ => Hclosed_empty)
	               (fun F0 y:set =>
	                  fun HFin0 HyNotin IH =>
                    fun HsubUnion =>
		                      Hclosed_union F0 {y}
		                        (IH (fun z Hz => HsubUnion z (binunionI1 F0 {y} z Hz)))
		                        (Hsing y (HsubUnion y (binunionI2 F0 {y} y (SingI y)))))
		               ). }
	    claim Hspec: F c= X -> closed_in X Tx F.
	    { exact (Hall F HF). }
	    exact (Hspec HFsub).
Qed.

(** helper: in a T1 space, the complement of a singleton is open **)
(** LATEX VERSION: In a T1 space, X\\{x} is open for every x∈X. **)
Theorem T1_singleton_complement_open : forall X Tx x:set,
  T1_space X Tx -> x :e X -> X :\: {x} :e Tx.
let X Tx x.
assume HT1: T1_space X Tx.
assume HxX: x :e X.
prove X :\: {x} :e Tx.
claim Htop: topology_on X Tx.
{ exact (T1_space_topology X Tx HT1). }
claim Hsing: closed_in X Tx {x}.
{ exact ((iffEL (T1_space X Tx)
                (forall z:set, z :e X -> closed_in X Tx {z})
                (lemma_T1_singletons_closed X Tx Htop) HT1) x HxX). }
claim Hdef: topology_on X Tx /\ ({x} c= X /\ exists U :e Tx, {x} = X :\: U).
{ exact Hsing. }
claim Hsubex: {x} c= X /\ exists U :e Tx, {x} = X :\: U.
{ exact (andER (topology_on X Tx) ({x} c= X /\ exists U :e Tx, {x} = X :\: U) Hdef). }
claim HexU: exists U :e Tx, {x} = X :\: U.
{ exact (andER ({x} c= X) (exists U :e Tx, {x} = X :\: U) Hsubex). }
apply HexU.
let U. assume HUeq.
claim HUinTx: U :e Tx.
{ exact (andEL (U :e Tx) ({x} = X :\: U) HUeq). }
claim Hxeq: {x} = X :\: U.
{ exact (andER (U :e Tx) ({x} = X :\: U) HUeq). }
claim HxnotU: x /:e U.
{ claim HxIn: x :e X :\: U.
  { rewrite <- Hxeq. exact (SingI x). }
  exact (setminusE2 X U x HxIn). }
claim HeqU: U = X :\: {x}.
{ apply set_ext.
  - let z. assume HzU: z :e U.
    prove z :e X :\: {x}.
    claim HzX: z :e X.
    { claim HTsub: Tx c= Power X.
      { exact (topology_subset_axiom X Tx Htop). }
      claim HUPow: U :e Power X.
      { exact (HTsub U HUinTx). }
      claim HUsub: U c= X.
      { exact (PowerE X U HUPow). }
      exact (HUsub z HzU). }
    apply setminusI.
    + exact HzX.
    + assume HzSing: z :e {x}.
      claim Hzeq: z = x.
      { exact (SingE x z HzSing). }
      claim HxU: x :e U.
      { prove x :e U.
        rewrite <- Hzeq.
        exact HzU. }
      exact (HxnotU HxU).
  - let z. assume Hz: z :e X :\: {x}.
    prove z :e U.
    apply (xm (z :e U)).
    + assume HzU: z :e U.
      exact HzU.
    + assume HznotU: z /:e U.
      claim HzIn: z :e X :\: U.
      { exact (setminusI X U z (setminusE1 X {x} z Hz) HznotU). }
      claim HzSing: z :e {x}.
      { rewrite Hxeq. exact HzIn. }
      claim Hfalse: False.
      { exact ((setminusE2 X {x} z Hz) HzSing). }
      apply FalseE.
      exact Hfalse.
	}
rewrite <- HeqU.
exact HUinTx.
Qed.

(** helper: subspaces of T1 spaces are T1 **)
(** LATEX VERSION: If X is T1, then every subspace Y⊂X is T1 in the subspace topology. **)
Theorem subspace_T1 : forall X Tx Y:set,
  topology_on X Tx -> Y c= X -> T1_space X Tx -> T1_space Y (subspace_topology X Tx Y).
let X Tx Y.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
assume HT1: T1_space X Tx.
prove T1_space Y (subspace_topology X Tx Y).
claim HTy: topology_on Y (subspace_topology X Tx Y).
{ exact (subspace_topology_is_topology X Tx Y HTx HY). }
apply (iffER (T1_space Y (subspace_topology X Tx Y))
             (forall y:set, y :e Y -> closed_in Y (subspace_topology X Tx Y) {y})
             (lemma_T1_singletons_closed Y (subspace_topology X Tx Y) HTy)).
prove forall y:set, y :e Y -> closed_in Y (subspace_topology X Tx Y) {y}.
let y. assume HyY: y :e Y.
prove closed_in Y (subspace_topology X Tx Y) {y}.
apply (iffER (closed_in Y (subspace_topology X Tx Y) {y})
             (exists C:set, closed_in X Tx C /\ {y} = C :/\: Y)
             (closed_in_subspace_iff_intersection X Tx Y {y} HTx HY)).
witness {y}.
apply andI.
- (** singleton closed in X by T1 **)
  exact ((iffEL (T1_space X Tx)
                (forall z:set, z :e X -> closed_in X Tx {z})
                (lemma_T1_singletons_closed X Tx HTx) HT1) y (HY y HyY)).
- (** {y} = {y} ∩ Y since y∈Y **)
  apply set_ext.
  * let z. assume Hz: z :e {y}.
    prove z :e {y} :/\: Y.
    claim Hzeq: z = y.
    { exact (SingE y z Hz). }
    rewrite Hzeq.
    exact (binintersectI {y} Y y (SingI y) HyY).
  * let z. assume Hz: z :e {y} :/\: Y.
    prove z :e {y}.
    exact (binintersectE1 {y} Y z Hz).
Qed.

(** LATEX VERSION: Exercise 15: Show the T1 axiom is equivalent to the condition that for each pair of points of X, each has a neighborhood not containing the other. **)
Theorem ex17_15_T1_characterization : forall X Tx:set,
  topology_on X Tx ->
  (T1_space X Tx <->
    forall x y:set, x :e X -> y :e X -> x <> y ->
      (exists U:set, U :e Tx /\ x :e U /\ y /:e U) /\
      (exists V:set, V :e Tx /\ y :e V /\ x /:e V)).
let X Tx.
assume Htop: topology_on X Tx.
prove T1_space X Tx <->
    forall x y:set, x :e X -> y :e X -> x <> y ->
      (exists U:set, U :e Tx /\ x :e U /\ y /:e U) /\
      (exists V:set, V :e Tx /\ y :e V /\ x /:e V).
apply iffI.
- assume HT1: T1_space X Tx.
  prove forall x y:set, x :e X -> y :e X -> x <> y ->
      (exists U:set, U :e Tx /\ x :e U /\ y /:e U) /\
      (exists V:set, V :e Tx /\ y :e V /\ x /:e V).
	  claim Hsing_closed: forall z:set, z :e X -> closed_in X Tx {z}.
	  { exact (iffEL (T1_space X Tx) (forall z:set, z :e X -> closed_in X Tx {z})
	                 (lemma_T1_singletons_closed X Tx Htop) HT1). }
  let x y.
  assume HxX: x :e X.
  assume HyX: y :e X.
  assume Hne: x <> y.
  prove (exists U:set, U :e Tx /\ x :e U /\ y /:e U) /\ (exists V:set, V :e Tx /\ y :e V /\ x /:e V).
  apply andI.
  - (** neighborhood of x missing y from closedness of {y} **)
    claim Hcy: closed_in X Tx {y}.
    { exact (Hsing_closed y HyX). }
    claim Hcy2: {y} c= X /\ exists U :e Tx, {y} = X :\: U.
    { exact (andER (topology_on X Tx) ({y} c= X /\ exists U :e Tx, {y} = X :\: U) Hcy). }
    claim HexU: exists U:set, U :e Tx /\ {y} = X :\: U.
    { exact (andER ({y} c= X) (exists U :e Tx, {y} = X :\: U) Hcy2). }
    set U := Eps_i (fun U0:set => U0 :e Tx /\ {y} = X :\: U0).
    claim HUprop: U :e Tx /\ {y} = X :\: U.
    { exact (Eps_i_ex (fun U0:set => U0 :e Tx /\ {y} = X :\: U0) HexU). }
    claim HUopen: U :e Tx.
    { exact (andEL (U :e Tx) ({y} = X :\: U) HUprop). }
    claim Heq: {y} = X :\: U.
    { exact (andER (U :e Tx) ({y} = X :\: U) HUprop). }
    witness U.
    apply andI.
    - apply andI.
      + exact HUopen.
      + (** x is in U since x≠y and {y}=X\\U **)
        claim Hxnoty: x /:e {y}.
        { assume Hxy: x :e {y}.
          claim Hxyeq: x = y.
          { exact (SingE y x Hxy). }
          exact (Hne Hxyeq). }
        claim Hxnot: x /:e (X :\: U).
        { rewrite <- Heq. exact Hxnoty. }
        apply (xm (x :e U)).
        * assume HxU: x :e U. exact HxU.
        * assume HxnotU: ~(x :e U).
          claim HxXU: x :e X :\: U.
          { exact (setminusI X U x HxX HxnotU). }
          exact (FalseE (Hxnot HxXU) (x :e U)).
    - (** y not in U since y ∈ X\\U = {y} **)
      assume HyU: y :e U.
      claim HySing: y :e {y}.
      { exact (SingI y). }
      claim HyXU: y :e X :\: U.
      { prove y :e X :\: U.
        rewrite <- Heq.
        exact HySing. }
      exact ((setminusE2 X U y HyXU) HyU).
  - (** neighborhood of y missing x from closedness of {x} **)
    claim Hcx: closed_in X Tx {x}.
    { exact (Hsing_closed x HxX). }
    claim Hcx2: {x} c= X /\ exists V :e Tx, {x} = X :\: V.
    { exact (andER (topology_on X Tx) ({x} c= X /\ exists V :e Tx, {x} = X :\: V) Hcx). }
    claim HexV: exists V:set, V :e Tx /\ {x} = X :\: V.
    { exact (andER ({x} c= X) (exists V :e Tx, {x} = X :\: V) Hcx2). }
    set V := Eps_i (fun V0:set => V0 :e Tx /\ {x} = X :\: V0).
    claim HVprop: V :e Tx /\ {x} = X :\: V.
    { exact (Eps_i_ex (fun V0:set => V0 :e Tx /\ {x} = X :\: V0) HexV). }
    claim HVopen: V :e Tx.
    { exact (andEL (V :e Tx) ({x} = X :\: V) HVprop). }
    claim Heq: {x} = X :\: V.
    { exact (andER (V :e Tx) ({x} = X :\: V) HVprop). }
    witness V.
    apply andI.
    - apply andI.
      + exact HVopen.
      + (** y in V since y≠x and {x}=X\\V **)
	        claim Hynotx: y /:e {x}.
	        { assume Hyx: y :e {x}.
	          claim Hyxeq: y = x.
	          { exact (SingE x y Hyx). }
	          claim Hxyeq: x = y.
	          { rewrite Hyxeq. reflexivity. }
	          exact (Hne Hxyeq). }
        claim Hynot: y /:e (X :\: V).
        { rewrite <- Heq. exact Hynotx. }
        apply (xm (y :e V)).
        * assume HyV: y :e V. exact HyV.
        * assume HynotV: ~(y :e V).
          claim HyXV: y :e X :\: V.
          { exact (setminusI X V y HyX HynotV). }
          exact (FalseE (Hynot HyXV) (y :e V)).
    - (** x not in V since x ∈ X\\V = {x} **)
      assume HxV: x :e V.
      claim HxSing: x :e {x}.
      { exact (SingI x). }
      claim HxXV: x :e X :\: V.
      { prove x :e X :\: V.
        rewrite <- Heq.
        exact HxSing. }
      exact ((setminusE2 X V x HxXV) HxV).
- assume Hsep:
    forall x y:set, x :e X -> y :e X -> x <> y ->
      (exists U:set, U :e Tx /\ x :e U /\ y /:e U) /\
      (exists V:set, V :e Tx /\ y :e V /\ x /:e V).
  prove T1_space X Tx.
  (** it suffices to prove all singletons are closed **)
  apply (iffER (T1_space X Tx) (forall z:set, z :e X -> closed_in X Tx {z})
               (lemma_T1_singletons_closed X Tx Htop)).
  prove forall z:set, z :e X -> closed_in X Tx {z}.
  let x. assume HxX: x :e X.
  prove closed_in X Tx {x}.
  (** show X\\{x} is open as union of all open sets not containing x **)
  set UFam := {U :e Tx|x /:e U}.
  claim HUnionOpen: Union UFam :e Tx.
  { claim HUFamSub: UFam c= Tx.
    { let U. assume HU: U :e UFam.
      exact (SepE1 Tx (fun U0:set => x /:e U0) U HU). }
    exact (topology_union_closed X Tx UFam Htop HUFamSub). }
  claim HUnionEq: Union UFam = X :\: {x}.
	  { apply set_ext.
	    - let y. assume HyU: y :e Union UFam.
	      prove y :e X :\: {x}.
	      claim HyUex: exists W:set, y :e W /\ W :e UFam.
	      { exact (UnionE UFam y HyU). }
	      set U := Eps_i (fun U0:set => y :e U0 /\ U0 :e UFam).
	      claim HUprop: y :e U /\ U :e UFam.
	      { exact (Eps_i_ex (fun U0:set => y :e U0 /\ U0 :e UFam) HyUex). }
      claim HyU0: y :e U.
      { exact (andEL (y :e U) (U :e UFam) HUprop). }
      claim HUin: U :e UFam.
      { exact (andER (y :e U) (U :e UFam) HUprop). }
      claim HUinTx: U :e Tx.
      { exact (SepE1 Tx (fun U0:set => x /:e U0) U HUin). }
      claim HUSubX: U c= X.
      { exact (topology_elem_subset X Tx U Htop HUinTx). }
      claim HyX: y :e X.
      { exact (HUSubX y HyU0). }
      claim Hynotx: y /:e {x}.
      { assume Hyx: y :e {x}.
	        claim Hyxeq: y = x.
	        { exact (SingE x y Hyx). }
		        claim HxnotU: x /:e U.
		        { exact (SepE2 Tx (fun U0:set => x /:e U0) U HUin). }
			        claim HynotU: y /:e U.
			        { assume HyU1: y :e U.
			          claim Hxy: x = y.
			          { prove x = y.
			            symmetry.
			            exact Hyxeq. }
				          claim HxU1: x :e U.
				          { prove x :e U.
				            rewrite Hxy at 1.
				            exact HyU1. }
				          exact (HxnotU HxU1). }
		        exact (HynotU HyU0). }
	      exact (setminusI X {x} y HyX Hynotx).
    - let y. assume HyXx: y :e X :\: {x}.
      prove y :e Union UFam.
      claim HyX: y :e X.
      { exact (setminusE1 X {x} y HyXx). }
	      claim Hynot: y /:e {x}.
	      { exact (setminusE2 X {x} y HyXx). }
	      claim Hyne: y <> x.
	      { assume Heq.
	        claim Hyx: y :e {x}.
	        { prove y :e {x}.
	          rewrite Heq.
	          exact (SingI x). }
	        exact (Hynot Hyx). }
	      claim Hsep_yx: exists V:set, V :e Tx /\ y :e V /\ x /:e V.
	      { exact (andEL (exists V:set, V :e Tx /\ y :e V /\ x /:e V)
	                     (exists U:set, U :e Tx /\ x :e U /\ y /:e U)
	                     (Hsep y x HyX HxX Hyne)). }
      set V := Eps_i (fun V0:set => V0 :e Tx /\ y :e V0 /\ x /:e V0).
	      claim HVprop: V :e Tx /\ y :e V /\ x /:e V.
	      { exact (Eps_i_ex (fun V0:set => V0 :e Tx /\ y :e V0 /\ x /:e V0) Hsep_yx). }
	      claim HVleft: V :e Tx /\ y :e V.
	      { exact (andEL (V :e Tx /\ y :e V) (x /:e V) HVprop). }
	      claim HVinTx: V :e Tx.
	      { exact (andEL (V :e Tx) (y :e V) HVleft). }
	      claim HyV: y :e V.
	      { exact (andER (V :e Tx) (y :e V) HVleft). }
	      claim HxnotV: x /:e V.
	      { exact (andER (V :e Tx /\ y :e V) (x /:e V) HVprop). }
      claim HVinFam: V :e UFam.
      { exact (SepI Tx (fun U0:set => x /:e U0) V HVinTx HxnotV). }
      exact (UnionI UFam y V HyV HVinFam).
  }
  (** {x} is closed as complement of the open set X\\{x} **)
  prove topology_on X Tx /\ ({x} c= X /\ exists U :e Tx, {x} = X :\: U).
  apply andI.
  - exact Htop.
  - apply andI.
    + let z. assume Hz: z :e {x}.
      claim Hzeq: z = x.
      { exact (SingE x z Hz). }
      rewrite Hzeq.
      exact HxX.
	    + witness (Union UFam).
		      apply andI.
		      * exact HUnionOpen.
      * apply set_ext.
        { let z. assume Hz: z :e {x}.
          prove z :e X :\: Union UFam.
          claim Hzeq: z = x.
          { exact (SingE x z Hz). }
          rewrite Hzeq.
          apply setminusI.
          - exact HxX.
          - assume Hxin: x :e Union UFam.
            claim Hxin': x :e X :\: {x}.
            { prove x :e X :\: {x}.
              rewrite <- HUnionEq.
              exact Hxin. }
            exact ((setminusE2 X {x} x Hxin') (SingI x)).
        }
        { let z. assume Hz: z :e X :\: Union UFam.
          prove z :e {x}.
          (** use setminus_setminus_eq with U = Union UFam = X\\{x} **)
          claim HsingSub: {x} c= X.
          { let t. assume Ht: t :e {x}.
            claim Hteq: t = x.
            { exact (SingE x t Ht). }
            rewrite Hteq.
            exact HxX. }
          rewrite <- (setminus_setminus_eq X {x} HsingSub).
          rewrite <- HUnionEq.
          exact Hz.
        }
Qed.

(** LATEX VERSION: Exercise 16(a): Determine the closure of K={1/n : n in Zplus} under each of the five R topologies from §13 Exercise 7. **)
Definition R_nonneg_set : set := {x :e R|0 <= x}.

(** helper: the closure of K_set in the K-topology is K_set (K_set is closed in the K-topology) **)
Theorem closure_of_K_in_R_K_topology :
  closure_of R R_K_topology K_set = K_set.
apply set_ext.
- let x. assume Hx: x :e closure_of R R_K_topology K_set.
  prove x :e K_set.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => forall U:set, U :e R_K_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  claim Hcl: forall U:set, U :e R_K_topology -> x :e U -> U :/\: K_set <> Empty.
  { exact (SepE2 R (fun x0:set => forall U:set, U :e R_K_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  apply (xm (x :e K_set)).
  - assume HxK: x :e K_set.
    exact HxK.
  - assume HxnotK: ~(x :e K_set).
    apply FalseE.
    (** choose a standard open interval I containing x, then remove K_set: U = I\\K_set **)
    claim HexI: exists I :e R_standard_basis, x :e I.
    { exact (basis_on_cover R R_standard_basis R_standard_basis_is_basis_local x HxR). }
    apply HexI.
    let I. assume HIpair.
    claim HIstd: I :e R_standard_basis.
    { exact (andEL (I :e R_standard_basis) (x :e I) HIpair). }
    claim HxI: x :e I.
    { exact (andER (I :e R_standard_basis) (x :e I) HIpair). }
    (** destruct I = open_interval a b **)
    claim Hexa: exists a :e R, I :e {open_interval a b|b :e R}.
    { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) I HIstd). }
    apply Hexa.
    let a. assume Hapair.
    claim HaR: a :e R.
    { exact (andEL (a :e R) (I :e {open_interval a b|b :e R}) Hapair). }
    claim HIfam: I :e {open_interval a b|b :e R}.
    { exact (andER (a :e R) (I :e {open_interval a b|b :e R}) Hapair). }
    claim Hexb: exists b :e R, I = open_interval a b.
    { exact (ReplE R (fun b0 : set => open_interval a b0) I HIfam). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbR: b :e R.
    { exact (andEL (b :e R) (I = open_interval a b) Hbpair). }
    claim HIeq: I = open_interval a b.
    { exact (andER (b :e R) (I = open_interval a b) Hbpair). }
    set U := open_interval a b :\: K_set.
    claim HUopen: U :e R_K_topology.
    { (** U is a basis element in the generated K-topology **)
      claim HUk: U :e R_K_basis.
      { claim HUr: U :e {open_interval a b0 :\: K_set|b0 :e R}.
        { exact (ReplI R (fun b0 : set => open_interval a b0 :\: K_set) b HbR). }
        exact (famunionI R (fun a0 : set => {open_interval a0 b0 :\: K_set|b0 :e R}) a U HaR HUr). }
      claim HUinB: U :e (R_standard_basis :\/: R_K_basis).
      { exact (binunionI2 R_standard_basis R_K_basis U HUk). }
      exact (basis_in_generated R (R_standard_basis :\/: R_K_basis) U R_standard_plus_K_basis_is_basis_local HUinB). }
    claim HxU: x :e U.
    { claim HxOpen: x :e open_interval a b.
      { rewrite <- HIeq.
        exact HxI. }
      exact (setminusI (open_interval a b) K_set x HxOpen HxnotK). }
    claim Hne: U :/\: K_set <> Empty.
    { exact (Hcl U HUopen HxU). }
    (** but (open_interval a b \\ K_set) ∩ K_set is empty **)
    claim Hempty: U :/\: K_set = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: K_set.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U K_set y Hy). }
      claim HyK: y :e K_set.
      { exact (binintersectE2 U K_set y Hy). }
      claim HyNotK: y /:e K_set.
      { exact (setminusE2 (open_interval a b) K_set y HyU). }
      exact (HyNotK HyK). }
    exact (Hne Hempty).
- (** K_set is always a subset of its closure **)
  let x. assume Hx: x :e K_set.
  prove x :e closure_of R R_K_topology K_set.
  claim HKsub: K_set c= R.
  { exact K_set_Subq_R. }
  claim Hsub: K_set c= closure_of R R_K_topology K_set.
  { exact (subset_of_closure R R_K_topology K_set R_K_topology_is_topology_local HKsub). }
  exact (Hsub x Hx).
Qed.

(** helper: closure of K_set in the left ray topology is the nonnegative reals **)
Theorem closure_of_K_in_R_ray_topology :
  closure_of R R_ray_topology K_set = R_nonneg_set.
apply set_ext.
- (** closure subset R_nonneg_set **)
  let x. assume Hx: x :e closure_of R R_ray_topology K_set.
  prove x :e R_nonneg_set.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => forall U:set, U :e R_ray_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  claim Hcl: forall U:set, U :e R_ray_topology -> x :e U -> U :/\: K_set <> Empty.
  { exact (SepE2 R (fun x0:set => forall U:set, U :e R_ray_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim H0lex: 0 <= x.
  { (** by trichotomy of < on surreals, exclude x<0 using the closure condition **)
    apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (0 <= x)).
    - assume Hxlt0: x < 0.
      apply FalseE.
      set U0 := {y :e R|Rlt y 0}.
      claim HU0pow: U0 :e Power R.
      { apply PowerI.
        let y. assume Hy: y :e U0.
        exact (SepE1 R (fun y0:set => Rlt y0 0) y Hy). }
      claim HU0disj: U0 = Empty \/ U0 = R \/ (exists a :e R, U0 = {y :e R|Rlt y a}).
      { (** left-assoc: (U0=Empty \/ U0=R) \/ exists a ... **)
        apply orIR.
        witness 0.
        apply andI.
        - exact real_0.
        - reflexivity. }
      claim HU0top: U0 :e R_ray_topology.
      { exact (SepI (Power R) (fun U:set => U = Empty \/ U = R \/ (exists a :e R, U = {y :e R|Rlt y a})) U0 HU0pow HU0disj). }
      claim HxU0: x :e U0.
      { claim HxRlt0: Rlt x 0.
        { exact (RltI x 0 HxR real_0 Hxlt0). }
        exact (SepI R (fun y:set => Rlt y 0) x HxR HxRlt0). }
      claim Hne: U0 :/\: K_set <> Empty.
      { exact (Hcl U0 HU0top HxU0). }
      claim Hempty: U0 :/\: K_set = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e U0 :/\: K_set.
        prove z :e Empty.
        apply FalseE.
        claim HzU0: z :e U0.
        { exact (binintersectE1 U0 K_set z Hz). }
        claim HzK: z :e K_set.
        { exact (binintersectE2 U0 K_set z Hz). }
        claim Hzlt0: Rlt z 0.
        { exact (SepE2 R (fun y0:set => Rlt y0 0) z HzU0). }
        apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) z HzK False).
        let n. assume HnIn: n :e omega :\: {0}. assume Hzeq: z = inv_nat n.
        claim Hzpos: Rlt 0 z.
        { rewrite Hzeq.
          exact (inv_nat_pos n HnIn). }
        claim H00: Rlt 0 0.
        { exact (Rlt_tra 0 z 0 Hzpos Hzlt0). }
        exact ((not_Rlt_refl 0 real_0) H00). }
      exact (Hne Hempty).
    - assume Hx0: x = 0.
      rewrite Hx0.
      exact (SNoLe_ref 0).
    - assume H0ltx: 0 < x.
      exact (SNoLtLe 0 x H0ltx). }
  exact (SepI R (fun x0:set => 0 <= x0) x HxR H0lex).
- (** R_nonneg_set subset closure **)
  let x. assume Hx: x :e R_nonneg_set.
  prove x :e closure_of R R_ray_topology K_set.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => 0 <= x0) x Hx). }
  claim H0lex: 0 <= x.
  { exact (SepE2 R (fun x0:set => 0 <= x0) x Hx). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim Hcl: forall U:set, U :e R_ray_topology -> x :e U -> U :/\: K_set <> Empty.
  { let U. assume HU: U :e R_ray_topology. assume HxU: x :e U.
    prove U :/\: K_set <> Empty.
    claim HUcases: U = Empty \/ U = R \/ (exists a :e R, U = {y :e R|Rlt y a}).
    { exact (SepE2 (Power R) (fun U0 : set => U0 = Empty \/ U0 = R \/ (exists a0 :e R, U0 = {y :e R|Rlt y a0})) U HU). }
    apply (HUcases (U :/\: K_set <> Empty)).
    - assume HUR: U = Empty \/ U = R.
      apply (HUR (U :/\: K_set <> Empty)).
      + assume HUe: U = Empty.
        apply FalseE.
        claim HxE: x :e Empty.
        { rewrite <- HUe.
          exact HxU. }
        exact (EmptyE x HxE).
      + assume HUeqR: U = R.
        (** pick a K_set element below 1; it lies in U=R **)
        claim Hexy: exists y:set, y :e halfopen_interval_left 0 1 /\ y :e K_set.
        { exact (K_set_meets_lower_limit_neighborhood_0 0 1 real_0 real_1 (not_Rlt_refl 0 real_0) (RltI 0 1 real_0 real_1 SNoLt_0_1)). }
        apply Hexy.
        let y. assume Hypair.
        claim HyK: y :e K_set.
        { exact (andER (y :e halfopen_interval_left 0 1) (y :e K_set) Hypair). }
        claim HyU: y :e U.
        { rewrite HUeqR.
          exact (K_set_Subq_R y HyK). }
        claim HyInt: y :e U :/\: K_set.
        { exact (binintersectI U K_set y HyU HyK). }
        exact (elem_implies_nonempty (U :/\: K_set) y HyInt).
    - assume Hex: exists a :e R, U = {y :e R|Rlt y a}.
      apply Hex.
      let a. assume Hapair.
      claim HaR: a :e R.
      { exact (andEL (a :e R) (U = {y :e R|Rlt y a}) Hapair). }
      claim HUeq: U = {y :e R|Rlt y a}.
      { exact (andER (a :e R) (U = {y :e R|Rlt y a}) Hapair). }
      claim HxUa: x :e {y :e R|Rlt y a}.
      { rewrite <- HUeq.
        exact HxU. }
      claim Hxlt: Rlt x a.
      { exact (SepE2 R (fun y0:set => Rlt y0 a) x HxUa). }
      claim HxltS: x < a.
      { exact (RltE_lt x a Hxlt). }
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim H0ltaS: 0 < a.
      { exact (SNoLeLt_tra 0 x a SNo_0 HxS HaS H0lex HxltS). }
      claim H0lta: Rlt 0 a.
      { exact (RltI 0 a real_0 HaR H0ltaS). }
      claim Hexy: exists y:set, y :e halfopen_interval_left 0 a /\ y :e K_set.
      { exact (K_set_meets_lower_limit_neighborhood_0 0 a real_0 HaR (not_Rlt_refl 0 real_0) H0lta). }
      apply Hexy.
      let y. assume Hypair.
      claim Hyhalf: y :e halfopen_interval_left 0 a.
      { exact (andEL (y :e halfopen_interval_left 0 a) (y :e K_set) Hypair). }
      claim HyK: y :e K_set.
      { exact (andER (y :e halfopen_interval_left 0 a) (y :e K_set) Hypair). }
      claim Hylt: Rlt y a.
      { exact (andER (~(Rlt y 0)) (Rlt y a) (SepE2 R (fun y0:set => ~(Rlt y0 0) /\ Rlt y0 a) y Hyhalf)). }
      claim HyU: y :e U.
      { rewrite HUeq.
        exact (SepI R (fun y0:set => Rlt y0 a) y (K_set_Subq_R y HyK) Hylt). }
      claim HyInt: y :e U :/\: K_set.
      { exact (binintersectI U K_set y HyU HyK). }
      exact (elem_implies_nonempty (U :/\: K_set) y HyInt). }
  exact (SepI R (fun x0:set => forall U:set, U :e R_ray_topology -> x0 :e U -> U :/\: K_set <> Empty) x HxR Hcl).
Qed.

(** helper: for x>0 not in K_set, there is a standard open neighborhood disjoint from K_set **)
(** LATEX VERSION: Not a numbered item; used to isolate points x>0 from the discrete set {1/n} in the standard topology. **)
Theorem K_set_above_positive_bound_finite : forall b:set,
  b :e R ->
  Rlt 0 b ->
  finite (K_set :/\: {y :e R|Rlt b y}).
let b.
assume HbR: b :e R.
assume Hbpos: Rlt 0 b.
prove finite (K_set :/\: {y :e R|Rlt b y}).
set V := {y :e R|Rlt b y}.
set r := recip_SNo b.
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim H0ltb: 0 < b.
{ exact (RltE_lt 0 b Hbpos). }
claim HrS: SNo r.
{ exact (SNo_recip_SNo b HbS). }
claim HrR: r :e R.
{ exact (real_recip_SNo b HbR). }
claim Hrpos: 0 < r.
{ exact (recip_SNo_of_pos_is_pos b HbS H0ltb). }
claim Hrnonneg: 0 <= r.
{ exact (SNoLtLe 0 r Hrpos). }
claim Hexn: exists n :e omega, n <= r /\ r < ordsucc n.
{ exact (nonneg_real_nat_interval r HrR Hrnonneg). }
apply Hexn.
let n. assume Hnpair.
claim HnOmega: n :e omega.
{ exact (andEL (n :e omega) (n <= r /\ r < ordsucc n) Hnpair). }
claim Hnrest: n <= r /\ r < ordsucc n.
{ exact (andER (n :e omega) (n <= r /\ r < ordsucc n) Hnpair). }
claim HrltN: r < ordsucc n.
{ exact (andER (n <= r) (r < ordsucc n) Hnrest). }
set N := ordsucc n.
claim HNOmega: N :e omega.
{ exact (omega_ordsucc n HnOmega). }
claim HNS: SNo N.
{ exact (omega_SNo N HNOmega). }
claim HNNat: nat_p N.
{ exact (omega_nat_p N HNOmega). }
claim HNOrd: ordinal N.
{ exact (nat_p_ordinal N HNNat). }
claim HNfin: finite N.
{ exact (nat_finite N HNNat). }
set I := N :\: {0}.
claim HIfin: finite I.
{ exact (Subq_finite N HNfin I (setminus_Subq N {0})). }
set Big := {inv_nat m|m :e I}.
claim HBigFin: finite Big.
{ exact (Repl_finite (fun m:set => inv_nat m) I HIfin). }
claim Hsub: K_set :/\: V c= Big.
{ let x. assume Hx: x :e K_set :/\: V.
  prove x :e Big.
  claim HxK: x :e K_set.
  { exact (binintersectE1 K_set V x Hx). }
  claim HxV: x :e V.
  { exact (binintersectE2 K_set V x Hx). }
  apply (ReplE (omega :\: {0}) (fun m:set => inv_nat m) x HxK).
  let m. assume Hmconj.
  claim HmIn: m :e omega :\: {0}.
  { exact (andEL (m :e omega :\: {0}) (x = inv_nat m) Hmconj). }
  claim Hxeq: x = inv_nat m.
  { exact (andER (m :e omega :\: {0}) (x = inv_nat m) Hmconj). }
  rewrite Hxeq.
  claim HmOmega: m :e omega.
  { exact (setminusE1 omega {0} m HmIn). }
  claim Hmnot0: m /:e {0}.
  { exact (setminusE2 omega {0} m HmIn). }
  claim HmS: SNo m.
  { exact (omega_SNo m HmOmega). }
  claim HmNat: nat_p m.
  { exact (omega_nat_p m HmOmega). }
  claim HmOrd: ordinal m.
  { exact (nat_p_ordinal m HmNat). }
  claim Hmne0: m <> 0.
  { assume Hm0: m = 0.
    claim Hmin0: m :e {0}.
    { rewrite Hm0. exact (SingI 0). }
    exact (Hmnot0 Hmin0). }
  claim Hmcase: m = 0 \/ exists k:set, nat_p k /\ m = ordsucc k.
  { exact (nat_inv m HmNat). }
  claim Hexk: exists k:set, nat_p k /\ m = ordsucc k.
  { apply (Hmcase (exists k:set, nat_p k /\ m = ordsucc k)).
    - assume Hm0: m = 0.
      apply FalseE.
      exact (Hmne0 Hm0).
    - assume H. exact H. }
  apply Hexk.
  let k. assume Hkconj.
  claim Hkeq: m = ordsucc k.
  { exact (andER (nat_p k) (m = ordsucc k) Hkconj). }
  claim HkNat: nat_p k.
  { exact (andEL (nat_p k) (m = ordsucc k) Hkconj). }
  claim HkOrd: ordinal k.
  { exact (nat_p_ordinal k HkNat). }
  claim H0ltm: 0 < m.
  { rewrite Hkeq.
    exact (ordinal_ordsucc_pos k HkOrd). }
  claim HVdef: V = {y :e R|Rlt b y}.
  { reflexivity. }
  claim HxVsep: x :e {y :e R|Rlt b y}.
  { rewrite <- HVdef.
    exact HxV. }
  claim HmVsep: inv_nat m :e {y :e R|Rlt b y}.
  { rewrite <- Hxeq.
    exact HxVsep. }
  claim HbInvRlt: Rlt b (inv_nat m).
  { exact (SepE2 R (fun y0:set => Rlt b y0) (inv_nat m) HmVsep). }
  claim HbInvLt: b < inv_nat m.
  { exact (RltE_lt b (inv_nat m) HbInvRlt). }
  claim HinvS: SNo (inv_nat m).
  { exact (SNo_recip_SNo m HmS). }
  claim HmbLt: mul_SNo m b < mul_SNo m (inv_nat m).
  { exact (pos_mul_SNo_Lt m b (inv_nat m) HmS H0ltm HbS HinvS HbInvLt). }
  claim HmbLt1: mul_SNo m b < 1.
  { claim Hminv: mul_SNo m (inv_nat m) = 1.
    { exact (recip_SNo_invR m HmS Hmne0). }
    rewrite <- Hminv.
    exact HmbLt. }
  claim HmLtrdiv: m < div_SNo 1 b.
  { exact (div_SNo_pos_LtR 1 b m SNo_1 HbS HmS H0ltb HmbLt1). }
  claim Hrdiv: div_SNo 1 b = r.
  { claim Hdivdef: div_SNo 1 b = mul_SNo 1 (recip_SNo b).
    { reflexivity. }
    rewrite Hdivdef.
    rewrite (mul_SNo_oneL (recip_SNo b) (SNo_recip_SNo b HbS)).
    reflexivity. }
  claim HmLtr: m < r.
  { rewrite <- Hrdiv.
    exact HmLtrdiv. }
  claim HmLtN: m < N.
  { exact (SNoLt_tra m r N HmS HrS HNS HmLtr HrltN). }
  claim HmInN: m :e N.
  { exact (ordinal_SNoLt_In m N HmOrd HNOrd HmLtN). }
  claim HmInI: m :e I.
  { apply setminusI.
    - exact HmInN.
    - exact Hmnot0. }
  exact (ReplI I (fun t:set => inv_nat t) m HmInI). }
exact (Subq_finite Big HBigFin (K_set :/\: V) Hsub).
Qed.

Theorem standard_open_neighborhood_disjoint_from_K_set_pos : forall x:set,
  x :e R -> 0 < x -> ~(x :e K_set) ->
  exists U:set, U :e R_standard_topology /\ x :e U /\ U :/\: K_set = Empty.
let x.
assume HxR: x :e R.
assume H0ltx: 0 < x.
assume HxnotK: ~(x :e K_set).
prove exists U:set, U :e R_standard_topology /\ x :e U /\ U :/\: K_set = Empty.
claim H0ltxR: Rlt 0 x.
{ exact (RltI 0 x real_0 HxR H0ltx). }
(** pick b in K_set with b < x (using the standard fact that 1/n < x for some n) **)
claim Hexb: exists b:set, b :e halfopen_interval_left 0 x /\ b :e K_set.
{ exact (K_set_meets_lower_limit_neighborhood_0 0 x real_0 HxR (not_Rlt_refl 0 real_0) H0ltxR). }
apply Hexb.
let b. assume Hbpair.
claim Hbhalf: b :e halfopen_interval_left 0 x.
{ exact (andEL (b :e halfopen_interval_left 0 x) (b :e K_set) Hbpair). }
claim HbK: b :e K_set.
{ exact (andER (b :e halfopen_interval_left 0 x) (b :e K_set) Hbpair). }
claim HbR: b :e R.
{ exact (K_set_Subq_R b HbK). }
claim Hbprop: ~(Rlt b 0) /\ Rlt b x.
{ exact (SepE2 R (fun y0:set => ~(Rlt y0 0) /\ Rlt y0 x) b Hbhalf). }
claim HbLtX: Rlt b x.
{ exact (andER (~(Rlt b 0)) (Rlt b x) Hbprop). }
claim Hbpos: Rlt 0 b.
{ apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) b HbK (Rlt 0 b)).
  let n. assume HnIn: n :e omega :\: {0}. assume Hbeq: b = inv_nat n.
  rewrite Hbeq.
  exact (inv_nat_pos n HnIn). }

set V := {y :e R|Rlt b y}.
claim HVopen: V :e R_standard_topology.
{ exact (open_ray_in_R_standard_topology b HbR). }
claim HxV: x :e V.
{ exact (SepI R (fun y0:set => Rlt b y0) x HxR HbLtX). }

(** Let F = K_set ∩ V (a finite subset of K_set above b). **)
set F := K_set :/\: V.
claim HFfin: finite F.
{ claim HFdef: F = K_set :/\: {y :e R|Rlt b y}.
  { reflexivity. }
  rewrite HFdef.
  exact (K_set_above_positive_bound_finite b HbR Hbpos). }
claim HFsubR: F c= R.
{ let z. assume HzF: z :e F.
  claim HzK: z :e K_set.
  { exact (binintersectE1 K_set V z HzF). }
  exact (K_set_Subq_R z HzK). }

(** U = V ∩ (R\\F) is open, contains x, and is disjoint from K_set. **)
set U := V :/\: (R :\: F).
claim HRmF: R :\: F :e R_standard_topology.
{ exact (finite_complement_open_in_R_standard_topology F HFfin HFsubR). }
claim HUopen: U :e R_standard_topology.
{ exact (topology_binintersect_closed R R_standard_topology V (R :\: F)
         (R_standard_topology_is_topology_local)
         HVopen
         HRmF). }
claim HxnotF: x /:e F.
{ assume HxF: x :e F.
  claim HxK': x :e K_set.
  { exact (binintersectE1 K_set V x HxF). }
  exact (HxnotK HxK'). }
claim HxRmF: x :e R :\: F.
{ exact (setminusI R F x HxR HxnotF). }
claim HxU: x :e U.
{ exact (binintersectI V (R :\: F) x HxV HxRmF). }

claim HUempty: U :/\: K_set = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e U :/\: K_set.
  prove z :e Empty.
  apply FalseE.
  claim HzU: z :e U.
  { exact (binintersectE1 U K_set z Hz). }
  claim HzK: z :e K_set.
  { exact (binintersectE2 U K_set z Hz). }
  claim HzV_RmF: z :e V :/\: (R :\: F).
  { exact HzU. }
  claim HzV: z :e V.
  { exact (binintersectE1 V (R :\: F) z HzV_RmF). }
  claim HzRmF: z :e R :\: F.
  { exact (binintersectE2 V (R :\: F) z HzV_RmF). }
  claim HzF: z :e F.
  { exact (binintersectI K_set V z HzK HzV). }
  claim HznotF: z /:e F.
  { exact (setminusE2 R F z HzRmF). }
  exact (HznotF HzF). }

witness U.
apply andI.
- apply andI.
  + exact HUopen.
  + exact HxU.
- exact HUempty.
Qed.

(** helper: closure of K_set in the upper limit topology is K_set **)
Theorem closure_of_K_in_R_upper_limit_topology :
  closure_of R R_upper_limit_topology K_set = K_set.
apply set_ext.
- (** closure subset K_set **)
  let x. assume Hx: x :e closure_of R R_upper_limit_topology K_set.
  prove x :e K_set.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => forall U:set, U :e R_upper_limit_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  claim Hcl: forall U:set, U :e R_upper_limit_topology -> x :e U -> U :/\: K_set <> Empty.
  { exact (SepE2 R (fun x0:set => forall U:set, U :e R_upper_limit_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  apply (xm (x :e K_set)).
  - assume HxK: x :e K_set.
    exact HxK.
  - assume HxnotK: ~(x :e K_set).
    apply FalseE.
    claim HxS: SNo x.
    { exact (real_SNo x HxR). }
    apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 False).
    - (** case x < 0: use left ray (-∞,0) open in standard hence in upper limit **)
      assume Hxlt0: x < 0.
      set U0 := {y :e R|Rlt y 0}.
      claim HU0std: U0 :e R_standard_topology.
      { exact (open_left_ray_in_R_standard_topology 0 real_0). }
      claim Hcont: finer_than R_upper_limit_topology R_standard_topology.
      { claim Hall:
          (((finer_than R_upper_limit_topology R_standard_topology /\
             finer_than R_K_topology R_standard_topology) /\
            finer_than R_standard_topology R_finite_complement_topology) /\
           finer_than R_standard_topology R_ray_topology).
        { exact ex13_7_R_topology_containments. }
        claim Hleft:
          ((finer_than R_upper_limit_topology R_standard_topology /\
            finer_than R_K_topology R_standard_topology) /\
           finer_than R_standard_topology R_finite_complement_topology).
        { exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                         finer_than R_K_topology R_standard_topology) /\
                        finer_than R_standard_topology R_finite_complement_topology)
                       (finer_than R_standard_topology R_ray_topology)
                       Hall). }
        claim Hpair:
          (finer_than R_upper_limit_topology R_standard_topology /\
           finer_than R_K_topology R_standard_topology).
        { exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                        finer_than R_K_topology R_standard_topology)
                       (finer_than R_standard_topology R_finite_complement_topology)
                       Hleft). }
        exact (andEL (finer_than R_upper_limit_topology R_standard_topology)
                     (finer_than R_K_topology R_standard_topology)
                     Hpair). }
      claim HU0: U0 :e R_upper_limit_topology.
      { exact (Hcont U0 HU0std). }
      claim HxU0: x :e U0.
      { claim HxRlt0: Rlt x 0.
        { exact (RltI x 0 HxR real_0 Hxlt0). }
        exact (SepI R (fun y0:set => Rlt y0 0) x HxR HxRlt0). }
      claim Hne: U0 :/\: K_set <> Empty.
      { exact (Hcl U0 HU0 HxU0). }
      claim Hempty: U0 :/\: K_set = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e U0 :/\: K_set.
        prove z :e Empty.
        apply FalseE.
        claim HzU0: z :e U0.
        { exact (binintersectE1 U0 K_set z Hz). }
        claim HzK: z :e K_set.
        { exact (binintersectE2 U0 K_set z Hz). }
        claim Hzlt0: Rlt z 0.
        { exact (SepE2 R (fun y0:set => Rlt y0 0) z HzU0). }
        apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) z HzK False).
        let n. assume HnIn: n :e omega :\: {0}. assume Hzeq: z = inv_nat n.
        claim Hzpos: Rlt 0 z.
        { rewrite Hzeq.
          exact (inv_nat_pos n HnIn). }
        claim H00: Rlt 0 0.
        { exact (Rlt_tra 0 z 0 Hzpos Hzlt0). }
        exact ((not_Rlt_refl 0 real_0) H00). }
        exact (Hne Hempty).
    - (** case x = 0: use basic upper-limit neighborhood (-1,0] **)
      assume Hx0: x = 0.
      set U1 := halfopen_interval_right (minus_SNo 1) 0.
      claim Hm1R: minus_SNo 1 :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim Hm10: Rlt (minus_SNo 1) 0.
      { exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0). }
      claim HU1basis: U1 :e R_upper_limit_basis.
      { claim HU1fam: U1 :e {halfopen_interval_right (minus_SNo 1) b|b :e R}.
        { exact (ReplI R (fun b0:set => halfopen_interval_right (minus_SNo 1) b0) 0 real_0). }
        exact (famunionI R (fun a0:set => {halfopen_interval_right a0 b|b :e R}) (minus_SNo 1) U1 Hm1R HU1fam). }
      claim HU1: U1 :e R_upper_limit_topology.
      { exact (basis_in_generated R R_upper_limit_basis U1 R_upper_limit_basis_is_basis_local HU1basis). }
      claim H0U1: 0 :e U1.
      { exact (halfopen_interval_right_rightmem (minus_SNo 1) 0 Hm10). }
      claim HxU1: x :e U1.
      { rewrite Hx0.
        exact H0U1. }
      claim Hne: U1 :/\: K_set <> Empty.
      { exact (Hcl U1 HU1 HxU1). }
      claim Hempty: U1 :/\: K_set = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e U1 :/\: K_set.
        prove z :e Empty.
        apply FalseE.
        claim HzU1: z :e U1.
        { exact (binintersectE1 U1 K_set z Hz). }
        claim HzK: z :e K_set.
        { exact (binintersectE2 U1 K_set z Hz). }
        claim Hzprop: Rlt (minus_SNo 1) z /\ ~(Rlt 0 z).
        { exact (SepE2 R (fun y0:set => Rlt (minus_SNo 1) y0 /\ ~(Rlt 0 y0)) z HzU1). }
        claim Hnot0z: ~(Rlt 0 z).
        { exact (andER (Rlt (minus_SNo 1) z) (~(Rlt 0 z)) Hzprop). }
        apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) z HzK False).
        let n. assume HnIn: n :e omega :\: {0}. assume Hzeq: z = inv_nat n.
        claim Hzpos: Rlt 0 z.
        { rewrite Hzeq.
          exact (inv_nat_pos n HnIn). }
        exact (Hnot0z Hzpos). }
      exact (Hne Hempty).
    - (** case 0 < x: reduce to existence of a standard open neighborhood disjoint from K_set **)
      assume H0ltx: 0 < x.
      claim Hcont: finer_than R_upper_limit_topology R_standard_topology.
      { claim Hall:
          (((finer_than R_upper_limit_topology R_standard_topology /\
             finer_than R_K_topology R_standard_topology) /\
            finer_than R_standard_topology R_finite_complement_topology) /\
           finer_than R_standard_topology R_ray_topology).
        { exact ex13_7_R_topology_containments. }
        claim Hleft:
          ((finer_than R_upper_limit_topology R_standard_topology /\
            finer_than R_K_topology R_standard_topology) /\
           finer_than R_standard_topology R_finite_complement_topology).
        { exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                         finer_than R_K_topology R_standard_topology) /\
                        finer_than R_standard_topology R_finite_complement_topology)
                       (finer_than R_standard_topology R_ray_topology)
                       Hall). }
        claim Hpair:
          (finer_than R_upper_limit_topology R_standard_topology /\
           finer_than R_K_topology R_standard_topology).
        { exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                        finer_than R_K_topology R_standard_topology)
                       (finer_than R_standard_topology R_finite_complement_topology)
                       Hleft). }
        exact (andEL (finer_than R_upper_limit_topology R_standard_topology)
                     (finer_than R_K_topology R_standard_topology)
                     Hpair). }
      claim HexU:
        exists U:set, U :e R_standard_topology /\ x :e U /\ U :/\: K_set = Empty.
      { exact (standard_open_neighborhood_disjoint_from_K_set_pos x HxR H0ltx HxnotK). }
      apply HexU.
      let U. assume HUpair.
      claim HUleft: U :e R_standard_topology /\ x :e U.
      { exact (andEL (U :e R_standard_topology /\ x :e U) (U :/\: K_set = Empty) HUpair). }
      claim HUstd: U :e R_standard_topology.
      { exact (andEL (U :e R_standard_topology) (x :e U) HUleft). }
      claim HxU: x :e U.
      { exact (andER (U :e R_standard_topology) (x :e U) HUleft). }
      claim HU: U :e R_upper_limit_topology.
      { exact (Hcont U HUstd). }
      claim Hne: U :/\: K_set <> Empty.
      { exact (Hcl U HU HxU). }
      claim HUempty: U :/\: K_set = Empty.
      { exact (andER (U :e R_standard_topology /\ x :e U) (U :/\: K_set = Empty) HUpair). }
      exact (Hne HUempty).
- (** K_set subset closure **)
  let x. assume Hx: x :e K_set.
  prove x :e closure_of R R_upper_limit_topology K_set.
  claim HKsub: K_set c= R.
  { exact K_set_Subq_R. }
  claim Hsub: K_set c= closure_of R R_upper_limit_topology K_set.
  { exact (subset_of_closure R R_upper_limit_topology K_set R_upper_limit_topology_is_topology_local HKsub). }
  exact (Hsub x Hx).
Qed.

(** helper: closure of K_set in the standard topology is K_set union {0} **)
Theorem closure_of_K_in_R_standard_topology :
  closure_of R R_standard_topology K_set = K_set :\/: {0}.
apply set_ext.
- (** closure subset K_set ∪ {0} **)
  let x. assume Hx: x :e closure_of R R_standard_topology K_set.
  prove x :e K_set :\/: {0}.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => forall U:set, U :e R_standard_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  claim Hcl: forall U:set, U :e R_standard_topology -> x :e U -> U :/\: K_set <> Empty.
  { exact (SepE2 R (fun x0:set => forall U:set, U :e R_standard_topology -> x0 :e U -> U :/\: K_set <> Empty) x Hx). }
  apply (xm (x = 0)).
  - assume Hx0: x = 0.
    rewrite Hx0.
    exact (binunionI2 K_set {0} 0 (SingI 0)).
  - assume Hxne0: ~(x = 0).
    apply (SNoLt_trichotomy_or_impred x 0 (real_SNo x HxR) SNo_0 (x :e K_set :\/: {0})).
    - (** x < 0 impossible for a closure point: use open ray (-∞,0) disjoint from K_set **)
      assume Hxlt0: x < 0.
      apply FalseE.
      set U0 := {y :e R|Rlt y 0}.
      claim HU0: U0 :e R_standard_topology.
      { exact (open_left_ray_in_R_standard_topology 0 real_0). }
      claim HxU0: x :e U0.
      { claim HxRlt0: Rlt x 0.
        { exact (RltI x 0 HxR real_0 Hxlt0). }
        exact (SepI R (fun y0:set => Rlt y0 0) x HxR HxRlt0). }
      claim Hne: U0 :/\: K_set <> Empty.
      { exact (Hcl U0 HU0 HxU0). }
      claim Hempty: U0 :/\: K_set = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e U0 :/\: K_set.
        prove z :e Empty.
        apply FalseE.
        claim HzU0: z :e U0.
        { exact (binintersectE1 U0 K_set z Hz). }
        claim HzK: z :e K_set.
        { exact (binintersectE2 U0 K_set z Hz). }
        claim Hzlt0: Rlt z 0.
        { exact (SepE2 R (fun y0:set => Rlt y0 0) z HzU0). }
        apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) z HzK False).
        let n. assume HnIn: n :e omega :\: {0}. assume Hzeq: z = inv_nat n.
        claim Hzpos: Rlt 0 z.
        { rewrite Hzeq.
          exact (inv_nat_pos n HnIn). }
        claim H00: Rlt 0 0.
        { exact (Rlt_tra 0 z 0 Hzpos Hzlt0). }
        exact ((not_Rlt_refl 0 real_0) H00). }
      exact (Hne Hempty).
    - (** x = 0 contradicts Hxne0 **)
      assume Hxeq0: x = 0.
      apply FalseE.
      exact (Hxne0 Hxeq0).
    - (** 0 < x: need an open neighborhood disjoint from K_set unless x∈K_set (pending) **)
      assume H0ltx: 0 < x.
      apply (xm (x :e K_set)).
      + assume HxK: x :e K_set.
        exact (binunionI1 K_set {0} x HxK).
      + assume HxnotK: ~(x :e K_set).
        apply FalseE.
        claim HexU:
          exists U:set, U :e R_standard_topology /\ x :e U /\ U :/\: K_set = Empty.
        { exact (standard_open_neighborhood_disjoint_from_K_set_pos x HxR H0ltx HxnotK). }
        apply HexU.
        let U. assume HUpair.
        claim HUleft: U :e R_standard_topology /\ x :e U.
        { exact (andEL (U :e R_standard_topology /\ x :e U) (U :/\: K_set = Empty) HUpair). }
        claim HU: U :e R_standard_topology.
        { exact (andEL (U :e R_standard_topology) (x :e U) HUleft). }
        claim HxU: x :e U.
        { exact (andER (U :e R_standard_topology) (x :e U) HUleft). }
        claim Hne: U :/\: K_set <> Empty.
        { exact (Hcl U HU HxU). }
        claim HUempty: U :/\: K_set = Empty.
        { exact (andER (U :e R_standard_topology /\ x :e U) (U :/\: K_set = Empty) HUpair). }
        exact (Hne HUempty).
- (** K_set ∪ {0} subset closure **)
  let x. assume Hx: x :e K_set :\/: {0}.
  prove x :e closure_of R R_standard_topology K_set.
  apply (binunionE' K_set {0} x (x :e closure_of R R_standard_topology K_set)).
  - assume HxK: x :e K_set.
    claim HKsub: K_set c= R.
    { exact K_set_Subq_R. }
    claim Hsub: K_set c= closure_of R R_standard_topology K_set.
    { exact (subset_of_closure R R_standard_topology K_set R_standard_topology_is_topology_local HKsub). }
    exact (Hsub x HxK).
  - assume Hx0: x :e {0}.
    claim Hxeq0: x = 0.
    { exact (SingE 0 x Hx0). }
    rewrite Hxeq0.
    prove 0 :e closure_of R R_standard_topology K_set.
    claim Hcl: forall U:set, U :e R_standard_topology -> 0 :e U -> U :/\: K_set <> Empty.
    { let U. assume HU: U :e R_standard_topology. assume H0U: 0 :e U.
      prove U :/\: K_set <> Empty.
      (** refine U at 0 to a basis neighborhood open_interval a b ⊆ U **)
      claim HUprop: forall x0 :e U, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U.
      { exact (SepE2 (Power R)
                     (fun U0 : set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                     U
                     HU). }
      claim Hexb0: exists b0 :e R_standard_basis, 0 :e b0 /\ b0 c= U.
      { exact (HUprop 0 H0U). }
      apply Hexb0.
      let b0. assume Hb0pair.
      claim Hb0Std: b0 :e R_standard_basis.
      { exact (andEL (b0 :e R_standard_basis) (0 :e b0 /\ b0 c= U) Hb0pair). }
      claim Hb0rest: 0 :e b0 /\ b0 c= U.
      { exact (andER (b0 :e R_standard_basis) (0 :e b0 /\ b0 c= U) Hb0pair). }
      claim H0b0: 0 :e b0.
      { exact (andEL (0 :e b0) (b0 c= U) Hb0rest). }
      claim Hb0subU: b0 c= U.
      { exact (andER (0 :e b0) (b0 c= U) Hb0rest). }
      (** destruct b0 = open_interval a b **)
      claim Hexa: exists a :e R, b0 :e {open_interval a b|b :e R}.
      { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) b0 Hb0Std). }
      apply Hexa.
      let a. assume Hapair.
      claim HaR: a :e R.
      { exact (andEL (a :e R) (b0 :e {open_interval a b|b :e R}) Hapair). }
      claim Hb0fam: b0 :e {open_interval a b|b :e R}.
      { exact (andER (a :e R) (b0 :e {open_interval a b|b :e R}) Hapair). }
      claim Hexb: exists b :e R, b0 = open_interval a b.
      { exact (ReplE R (fun b0' : set => open_interval a b0') b0 Hb0fam). }
      apply Hexb.
      let b. assume Hbpair.
      claim HbR: b :e R.
      { exact (andEL (b :e R) (b0 = open_interval a b) Hbpair). }
      claim Hb0eq: b0 = open_interval a b.
      { exact (andER (b :e R) (b0 = open_interval a b) Hbpair). }
      (** extract a<0 and 0<b from 0∈(a,b) **)
      claim H0in: 0 :e open_interval a b.
      { rewrite <- Hb0eq.
        exact H0b0. }
      claim H0prop: Rlt a 0 /\ Rlt 0 b.
      { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) 0 H0in). }
      claim Ha0: Rlt a 0.
      { exact (andEL (Rlt a 0) (Rlt 0 b) H0prop). }
      claim H0b: Rlt 0 b.
      { exact (andER (Rlt a 0) (Rlt 0 b) H0prop). }
      (** choose y = 1/N < b in K_set, then y∈(a,b) ⊆ U **)
      claim Hexy: exists y:set, y :e halfopen_interval_left 0 b /\ y :e K_set.
      { exact (K_set_meets_lower_limit_neighborhood_0 0 b real_0 HbR (not_Rlt_refl 0 real_0) H0b). }
      apply Hexy.
      let y. assume Hypair.
      claim Hyhalf: y :e halfopen_interval_left 0 b.
      { exact (andEL (y :e halfopen_interval_left 0 b) (y :e K_set) Hypair). }
      claim HyK: y :e K_set.
      { exact (andER (y :e halfopen_interval_left 0 b) (y :e K_set) Hypair). }
      claim HyR: y :e R.
      { exact (K_set_Subq_R y HyK). }
      claim Hyltb: Rlt y b.
      { exact (andER (~(Rlt y 0)) (Rlt y b) (SepE2 R (fun z:set => ~(Rlt z 0) /\ Rlt z b) y Hyhalf)). }
      claim Hypos: Rlt 0 y.
      { apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) y HyK (Rlt 0 y)).
        let n. assume HnIn: n :e omega :\: {0}. assume Hyeq: y = inv_nat n.
        rewrite Hyeq.
        exact (inv_nat_pos n HnIn). }
      claim Hay: Rlt a y.
      { exact (Rlt_tra a 0 y Ha0 Hypos). }
      claim HyinInt: y :e open_interval a b.
      { exact (SepI R (fun z:set => Rlt a z /\ Rlt z b) y HyR (andI (Rlt a y) (Rlt y b) Hay Hyltb)). }
      claim Hyb0: y :e b0.
      { rewrite Hb0eq.
        exact HyinInt. }
      claim HyU: y :e U.
      { exact (Hb0subU y Hyb0). }
      claim HyInt: y :e U :/\: K_set.
      { exact (binintersectI U K_set y HyU HyK). }
      exact (elem_implies_nonempty (U :/\: K_set) y HyInt). }
    exact (SepI R (fun x0:set => forall U:set, U :e R_standard_topology -> x0 :e U -> U :/\: K_set <> Empty) 0 real_0 Hcl).
  - exact Hx.
Qed.

Theorem ex17_16a_closure_of_K_in_five_topologies :
  closure_of R R_standard_topology K_set = K_set :\/: {0} /\
  closure_of R R_K_topology K_set = K_set /\
  closure_of R R_finite_complement_topology K_set = R /\
  closure_of R R_upper_limit_topology K_set = K_set /\
  closure_of R R_ray_topology K_set = R_nonneg_set.
prove closure_of R R_standard_topology K_set = K_set :\/: {0} /\
  closure_of R R_K_topology K_set = K_set /\
  closure_of R R_finite_complement_topology K_set = R /\
  closure_of R R_upper_limit_topology K_set = K_set /\
  closure_of R R_ray_topology K_set = R_nonneg_set.
apply andI.
- (** prove the first four conjuncts together: ((((A /\ B) /\ C) /\ D)) **)
  apply andI.
  + apply andI.
    * (** A /\ B **)
      apply andI.
      - exact closure_of_K_in_R_standard_topology.
      - exact closure_of_K_in_R_K_topology.
    * (** C: finite complement topology **)
      claim HKinf: infinite K_set.
      { exact K_set_infinite. }
      claim HKsub: K_set c= R.
      { exact K_set_Subq_R. }
      claim HTdef: R_finite_complement_topology = finite_complement_topology R.
      { reflexivity. }
      rewrite HTdef.
      exact (closure_infinite_finite_complement R K_set HKsub HKinf).
  + (** D: upper limit topology **)
    exact closure_of_K_in_R_upper_limit_topology.
- (** E: ray topology **)
  exact closure_of_K_in_R_ray_topology.
Qed.

(** helper: in the left ray topology, any open set containing 1 contains 0 **)
Theorem ray_topology_contains_0_if_contains_1 : forall U:set,
  U :e R_ray_topology -> 1 :e U -> 0 :e U.
let U.
assume HU: U :e R_ray_topology.
assume H1U: 1 :e U.
prove 0 :e U.
claim HUcases: U = Empty \/ U = R \/ exists a :e R, U = {x :e R|Rlt x a}.
{ exact (SepE2 (Power R) (fun U0 : set => U0 = Empty \/ U0 = R \/ exists a0 :e R, U0 = {x :e R|Rlt x a0}) U HU). }
apply (HUcases (0 :e U)).
- assume HUR: U = Empty \/ U = R.
  apply (HUR (0 :e U)).
  + assume HUe: U = Empty.
    apply FalseE.
    claim H1Empty: 1 :e Empty.
    prove 1 :e Empty.
    rewrite <- HUe at 2.
    exact H1U.
    exact ((EmptyE 1) H1Empty).
  + assume HUeqR: U = R.
    rewrite HUeqR.
    exact real_0.
- assume Hex: exists a :e R, U = {x :e R|Rlt x a}.
  apply Hex.
  let a.
  assume Hapair: a :e R /\ U = {x :e R|Rlt x a}.
  claim HaR: a :e R.
  { exact (andEL (a :e R) (U = {x :e R|Rlt x a}) Hapair). }
  claim HUeq: U = {x :e R|Rlt x a}.
  { exact (andER (a :e R) (U = {x :e R|Rlt x a}) Hapair). }
  rewrite HUeq.
  prove 0 :e {x :e R|Rlt x a}.
  claim H1in: 1 :e {x :e R|Rlt x a}.
  { rewrite <- HUeq.
    exact H1U. }
  claim H1lt: Rlt 1 a.
  { exact (SepE2 R (fun x0:set => Rlt x0 a) 1 H1in). }
  claim H0lt1: Rlt 0 1.
  { exact (RltI 0 1 real_0 real_1 SNoLt_0_1). }
  claim H0lta: Rlt 0 a.
  { exact (Rlt_tra 0 1 a H0lt1 H1lt). }
  exact (SepI R (fun x0:set => Rlt x0 a) 0 real_0 H0lta).
Qed.

(** helper: the left ray topology on R is not Hausdorff **)
Theorem ray_topology_not_Hausdorff : ~Hausdorff_space R R_ray_topology.
assume HH: Hausdorff_space R R_ray_topology.
prove False.
claim Hsep: forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
  exists U V:set, U :e R_ray_topology /\ V :e R_ray_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ exact (andER (topology_on R R_ray_topology)
               (forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
                 exists U V:set, U :e R_ray_topology /\ V :e R_ray_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
claim H01ne: 0 <> 1.
{ assume H01eq: 0 = 1.
  claim H00lt: 0 < 0.
  { rewrite H01eq at 2.
    exact SNoLt_0_1. }
  exact ((SNoLt_irref 0) H00lt). }
claim HUVex: exists U V:set, U :e R_ray_topology /\ V :e R_ray_topology /\ 0 :e U /\ 1 :e V /\ U :/\: V = Empty.
{ exact (Hsep 0 1 real_0 real_1 H01ne). }
apply HUVex.
let U.
assume HVex: exists V:set, U :e R_ray_topology /\ V :e R_ray_topology /\ 0 :e U /\ 1 :e V /\ U :/\: V = Empty.
apply HVex.
let V.
assume HUV.
claim HUVleft: (((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U) /\ 1 :e V).
{ exact (andEL (((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U) /\ 1 :e V)
               (U :/\: V = Empty)
               HUV). }
claim HUVempty: U :/\: V = Empty.
{ exact (andER (((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U) /\ 1 :e V)
               (U :/\: V = Empty)
               HUV). }
claim HUVleft2: ((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U).
{ exact (andEL ((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U)
               (1 :e V)
               HUVleft). }
claim H1V: 1 :e V.
{ exact (andER ((U :e R_ray_topology /\ V :e R_ray_topology) /\ 0 :e U)
               (1 :e V)
               HUVleft). }
claim HUVleft3: (U :e R_ray_topology /\ V :e R_ray_topology).
{ exact (andEL (U :e R_ray_topology /\ V :e R_ray_topology)
               (0 :e U)
               HUVleft2). }
claim H0U: 0 :e U.
{ exact (andER (U :e R_ray_topology /\ V :e R_ray_topology)
               (0 :e U)
               HUVleft2). }
claim HU: U :e R_ray_topology.
{ exact (andEL (U :e R_ray_topology)
               (V :e R_ray_topology)
               HUVleft3). }
claim HV: V :e R_ray_topology.
{ exact (andER (U :e R_ray_topology)
               (V :e R_ray_topology)
               HUVleft3). }
claim H0V: 0 :e V.
{ exact (ray_topology_contains_0_if_contains_1 V HV H1V). }
claim H0UV: 0 :e U :/\: V.
{ exact (binintersectI U V 0 H0U H0V). }
claim H0Empty: 0 :e Empty.
prove 0 :e Empty.
rewrite <- HUVempty at 2.
exact H0UV.
exact (EmptyE 0 H0Empty).
Qed.

(** helper: the left ray topology on R is not T1 **)
Theorem ray_topology_not_T1 : ~T1_space R R_ray_topology.
assume HT1: T1_space R R_ray_topology.
prove False.
claim Hfinite_closed: forall F:set, F c= R -> finite F -> closed_in R R_ray_topology F.
{ exact (andER (topology_on R R_ray_topology)
               (forall F:set, F c= R -> finite F -> closed_in R R_ray_topology F)
               HT1). }
claim Hsub0: {0} c= R.
{ let x. assume Hx0: x :e {0}.
  claim Hxeq: x = 0.
  { exact (SingE 0 x Hx0). }
  rewrite Hxeq.
  exact real_0. }
claim Hfin0: finite {0}.
{ exact (Sing_finite 0). }
claim Hclosed0: closed_in R R_ray_topology {0}.
{ exact (Hfinite_closed {0} Hsub0 Hfin0). }
claim Hclosed0core: {0} c= R /\ exists U :e R_ray_topology, {0} = R :\: U.
{ exact (andER (topology_on R R_ray_topology)
               ({0} c= R /\ exists U :e R_ray_topology, {0} = R :\: U)
               Hclosed0). }
claim HexUtyped: exists U :e R_ray_topology, {0} = R :\: U.
{ exact (andER ({0} c= R) (exists U :e R_ray_topology, {0} = R :\: U) Hclosed0core). }
apply HexUtyped.
let U.
assume HUrep: U :e R_ray_topology /\ {0} = R :\: U.
claim HU: U :e R_ray_topology.
{ exact (andEL (U :e R_ray_topology) ({0} = R :\: U) HUrep). }
claim Heq: {0} = R :\: U.
{ exact (andER (U :e R_ray_topology) ({0} = R :\: U) HUrep). }
claim H1in: 1 :e U.
{ claim H1not0: 1 /:e {0}.
  { assume H10: 1 :e {0}.
    claim H10eq: 1 = 0.
    { exact (SingE 0 1 H10). }
    claim H00lt: 0 < 0.
    { rewrite <- H10eq at 2.
      exact SNoLt_0_1. }
    exact ((SNoLt_irref 0) H00lt). }
  prove 1 :e U.
  apply (xm (1 :e U)).
  - assume H. exact H.
  - assume HnU: ~(1 :e U).
    claim H1incomp: 1 :e R :\: U.
    { exact (setminusI R U 1 real_1 HnU). }
    claim H1in0: 1 :e {0}.
    { claim Hsubst: forall S T:set, S = T -> 1 :e T -> 1 :e S.
      { let S T.
        assume HeqST: S = T.
        assume H1inT: 1 :e T.
        prove 1 :e S.
        rewrite HeqST.
        exact H1inT. }
      exact (Hsubst {0} (R :\: U) Heq H1incomp). }
    apply FalseE.
    exact (H1not0 H1in0). }
claim H0in: 0 :e U.
{ exact (ray_topology_contains_0_if_contains_1 U HU H1in). }
claim H0incomp: 0 :e R :\: U.
{ rewrite <- Heq.
  exact (SingI 0). }
claim H0not: 0 /:e U.
{ exact (setminusE2 R U 0 H0incomp). }
exact (H0not H0in).
Qed.

(** helper: X minus Empty equals X **)
Theorem setminus_Empty_eq : forall X:set, X :\: Empty = X.
let X.
apply set_ext.
- let x. assume Hx: x :e X :\: Empty.
  exact (setminusE1 X Empty x Hx).
- let x. assume HxX: x :e X.
  exact (setminusI X Empty x HxX (EmptyE x)).
Qed.

(** helper: R is infinite **)
Theorem infinite_R : infinite R.
(** from pre-topology: real is uncountable, so in particular infinite **)
(** LATEX VERSION: Not a numbered item; uses the earlier uncountability result for R to conclude R is infinite. **)
claim Hunc: atleastp omega real /\ ~equip real omega.
{ exact form100_22_real_uncountable. }
claim Hatleast: atleastp omega real.
{ exact (andEL (atleastp omega real) (~equip real omega) Hunc). }
prove infinite R.
exact (atleastp_omega_infinite real Hatleast).
Qed.

(** helper: finite complement topology is T1 **)
Theorem finite_complement_topology_T1 : forall X:set, T1_space X (finite_complement_topology X).
let X.
claim Htop: topology_on X (finite_complement_topology X).
{ exact (finite_complement_topology_on X). }
prove topology_on X (finite_complement_topology X) /\ (forall F:set, F c= X -> finite F -> closed_in X (finite_complement_topology X) F).
apply andI.
- exact Htop.
- let F. assume HFsub: F c= X. assume HFfin: finite F.
  prove closed_in X (finite_complement_topology X) F.
  prove topology_on X (finite_complement_topology X) /\ (F c= X /\ exists U :e finite_complement_topology X, F = X :\: U).
  apply andI.
  + exact Htop.
  + apply andI.
    * exact HFsub.
    * witness (X :\: F).
      apply andI.
      - (** X\\F is open in the finite complement topology **)
        claim HUpow: (X :\: F) :e Power X.
        { exact (setminus_In_Power X F). }
        claim Hfin: finite (X :\: (X :\: F)).
        { rewrite (setminus_setminus_eq X F HFsub).
          exact HFfin. }
        exact (SepI (Power X) (fun U0:set => finite (X :\: U0) \/ U0 = Empty)
                    (X :\: F)
                    HUpow
                    (orIL (finite (X :\: (X :\: F))) ((X :\: F) = Empty) Hfin)).
      - (** F = X\\(X\\F) **)
        rewrite (setminus_setminus_eq X F HFsub).
        reflexivity.
Qed.

(** helper: the finite complement topology on R is not Hausdorff **)
Theorem R_finite_complement_not_Hausdorff : ~Hausdorff_space R R_finite_complement_topology.
assume HH: Hausdorff_space R R_finite_complement_topology.
prove False.
claim Hsep: forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
  exists U V:set, U :e R_finite_complement_topology /\ V :e R_finite_complement_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ exact (andER (topology_on R R_finite_complement_topology)
               (forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
                 exists U V:set, U :e R_finite_complement_topology /\ V :e R_finite_complement_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
claim H01ne: 0 <> 1.
{ assume H01eq: 0 = 1.
  claim H00lt: 0 < 0.
  { rewrite H01eq at 2.
    exact SNoLt_0_1. }
  exact ((SNoLt_irref 0) H00lt). }
claim HUVex: exists U V:set, U :e R_finite_complement_topology /\ V :e R_finite_complement_topology /\ 0 :e U /\ 1 :e V /\ U :/\: V = Empty.
{ exact (Hsep 0 1 real_0 real_1 H01ne). }
apply HUVex.
let U.
assume HVex: exists V:set, U :e R_finite_complement_topology /\ V :e R_finite_complement_topology /\ 0 :e U /\ 1 :e V /\ U :/\: V = Empty.
apply HVex.
let V.
assume HUV: U :e R_finite_complement_topology /\ V :e R_finite_complement_topology /\ 0 :e U /\ 1 :e V /\ U :/\: V = Empty.
claim Hleft: (((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U) /\ 1 :e V).
{ exact (andEL (((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U) /\ 1 :e V)
               (U :/\: V = Empty)
               HUV). }
claim HUVempty: U :/\: V = Empty.
{ exact (andER (((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U) /\ 1 :e V)
               (U :/\: V = Empty)
               HUV). }
claim Hleft2: ((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U).
{ exact (andEL ((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U) (1 :e V) Hleft). }
claim H1V: 1 :e V.
{ exact (andER ((U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) /\ 0 :e U) (1 :e V) Hleft). }
claim Hpair: (U :e R_finite_complement_topology /\ V :e R_finite_complement_topology).
{ exact (andEL (U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) (0 :e U) Hleft2). }
claim H0U: 0 :e U.
{ exact (andER (U :e R_finite_complement_topology /\ V :e R_finite_complement_topology) (0 :e U) Hleft2). }
claim HU: U :e R_finite_complement_topology.
{ exact (andEL (U :e R_finite_complement_topology) (V :e R_finite_complement_topology) Hpair). }
claim HV: V :e R_finite_complement_topology.
{ exact (andER (U :e R_finite_complement_topology) (V :e R_finite_complement_topology) Hpair). }

(** from HU and H0U, derive finite (R\\U); similarly for V **)
(** LATEX VERSION: Not a numbered item; bookkeeping step using the definition of the finite complement topology. **)
claim HUcases: finite (R :\: U) \/ U = Empty.
{ exact (SepE2 (Power R) (fun U0:set => finite (R :\: U0) \/ U0 = Empty) U HU). }
claim HUfin: finite (R :\: U).
{ apply (HUcases (finite (R :\: U))).
  - assume Hfin. exact Hfin.
  - assume HUe: U = Empty.
    apply FalseE.
    claim H0Empty: 0 :e Empty.
    { rewrite <- HUe at 2.
      exact H0U. }
    exact (EmptyE 0 H0Empty). }
claim HVcases: finite (R :\: V) \/ V = Empty.
{ exact (SepE2 (Power R) (fun U0:set => finite (R :\: U0) \/ U0 = Empty) V HV). }
claim HVfin: finite (R :\: V).
{ apply (HVcases (finite (R :\: V))).
  - assume Hfin. exact Hfin.
  - assume HVe: V = Empty.
    apply FalseE.
    claim H1Empty: 1 :e Empty.
    { rewrite <- HVe at 2.
      exact H1V. }
    exact (EmptyE 1 H1Empty). }

(** then (R\\U) ∪ (R\\V) is finite, and so is R\\(U∩V) by subset **)
claim HfinUnion: finite ((R :\: U) :\/: (R :\: V)).
{ exact (binunion_finite (R :\: U) HUfin (R :\: V) HVfin). }
claim Hsub: R :\: (U :/\: V) c= (R :\: U) :\/: (R :\: V).
{ let x. assume Hx: x :e R :\: (U :/\: V).
  claim HxR: x :e R.
  { exact (setminusE1 R (U :/\: V) x Hx). }
  claim HxNotUV: x /:e (U :/\: V).
  { exact (setminusE2 R (U :/\: V) x Hx). }
  apply (xm (x :e U)).
  - assume HxU: x :e U.
    claim HxNotV: x /:e V.
    { assume HxV: x :e V.
      claim HxUV: x :e U :/\: V.
      { exact (binintersectI U V x HxU HxV). }
      exact (HxNotUV HxUV). }
    claim HxRV: x :e R :\: V.
    { exact (setminusI R V x HxR HxNotV). }
    exact (binunionI2 (R :\: U) (R :\: V) x HxRV).
  - assume HxNotU: ~(x :e U).
    claim HxRU: x :e R :\: U.
    { exact (setminusI R U x HxR HxNotU). }
    exact (binunionI1 (R :\: U) (R :\: V) x HxRU). }
claim HfinDiff: finite (R :\: (U :/\: V)).
{ exact (Subq_finite ((R :\: U) :\/: (R :\: V)) HfinUnion (R :\: (U :/\: V)) Hsub). }
claim HfinR: finite R.
{ claim HeqR: R :\: (U :/\: V) = R.
  { rewrite HUVempty.
    rewrite (setminus_Empty_eq R).
    reflexivity. }
  rewrite <- HeqR.
  exact HfinDiff. }
exact (infinite_R HfinR).
Qed.

(** helper: the standard topology on R is Hausdorff and T1 **)
Theorem R_standard_topology_Hausdorff : Hausdorff_space R R_standard_topology.
prove Hausdorff_space R R_standard_topology.
prove topology_on R R_standard_topology /\
  forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
    exists U V:set, U :e R_standard_topology /\ V :e R_standard_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact R_standard_topology_is_topology_local.
- let x1 x2.
  assume Hx1R: x1 :e R.
  assume Hx2R: x2 :e R.
  assume Hneq: x1 <> x2.
  claim Hx1S: SNo x1.
  { exact (real_SNo x1 Hx1R). }
  claim Hx2S: SNo x2.
  { exact (real_SNo x2 Hx2R). }
  apply (SNoLt_trichotomy_or_impred x1 x2 Hx1S Hx2S
          (exists U V:set, U :e R_standard_topology /\ V :e R_standard_topology /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
  - assume Hlt12: x1 < x2.
    claim Hx1x2: Rlt x1 x2.
    { exact (RltI x1 x2 Hx1R Hx2R Hlt12). }
    apply (rational_dense_between_reals x1 x2 Hx1R Hx2R Hx1x2).
    let q. assume Hqcore.
    apply Hqcore.
    assume HqQ: q :e rational_numbers.
    assume Hqconj: Rlt x1 q /\ Rlt q x2.
    claim HqR: q :e R.
    { exact (rational_numbers_in_R q HqQ). }
    set U := {x :e R | Rlt x q}.
    set V := {x :e R | Rlt q x}.
    witness U.
    witness V.
    claim HUopen: U :e R_standard_topology.
    { exact (open_left_ray_in_R_standard_topology q HqR). }
    claim HVopen: V :e R_standard_topology.
    { exact (open_ray_in_R_standard_topology q HqR). }
    claim Hx1ltq: Rlt x1 q.
    { exact (andEL (Rlt x1 q) (Rlt q x2) Hqconj). }
    claim Hqltx2: Rlt q x2.
    { exact (andER (Rlt x1 q) (Rlt q x2) Hqconj). }
    claim Hx1U: x1 :e U.
    { exact (SepI R (fun x0 : set => Rlt x0 q) x1 Hx1R Hx1ltq). }
    claim Hx2V: x2 :e V.
    { exact (SepI R (fun x0 : set => Rlt q x0) x2 Hx2R Hqltx2). }
    claim HUVempty: U :/\: V = Empty.
    { apply Empty_Subq_eq.
      let x. assume HxUV: x :e U :/\: V.
      prove x :e Empty.
      apply FalseE.
      claim HxU: x :e U.
      { exact (binintersectE1 U V x HxUV). }
      claim HxV: x :e V.
      { exact (binintersectE2 U V x HxUV). }
      claim Hxltq: Rlt x q.
      { exact (SepE2 R (fun x0 : set => Rlt x0 q) x HxU). }
      claim Hqltx: Rlt q x.
      { exact (SepE2 R (fun x0 : set => Rlt q x0) x HxV). }
      claim Hqq: Rlt q q.
      { exact (Rlt_tra q x q Hqltx Hxltq). }
      exact ((not_Rlt_refl q HqR) Hqq). }
    apply andI.
    - prove ((U :e R_standard_topology /\ V :e R_standard_topology) /\ x1 :e U) /\ x2 :e V.
      apply andI.
      + prove (U :e R_standard_topology /\ V :e R_standard_topology) /\ x1 :e U.
        apply andI.
        * prove U :e R_standard_topology /\ V :e R_standard_topology.
          apply andI.
          - exact HUopen.
          - exact HVopen.
        * exact Hx1U.
      + exact Hx2V.
    - exact HUVempty.
  - assume Heq: x1 = x2.
    apply FalseE.
    exact (Hneq Heq).
  - assume Hlt21: x2 < x1.
    claim Hx2x1: Rlt x2 x1.
    { exact (RltI x2 x1 Hx2R Hx1R Hlt21). }
    apply (rational_dense_between_reals x2 x1 Hx2R Hx1R Hx2x1).
    let q. assume Hqcore.
    apply Hqcore.
    assume HqQ: q :e rational_numbers.
    assume Hqconj: Rlt x2 q /\ Rlt q x1.
    claim HqR: q :e R.
    { exact (rational_numbers_in_R q HqQ). }
    set U := {x :e R | Rlt q x}.
    set V := {x :e R | Rlt x q}.
    witness U.
    witness V.
    claim HUopen: U :e R_standard_topology.
    { exact (open_ray_in_R_standard_topology q HqR). }
    claim HVopen: V :e R_standard_topology.
    { exact (open_left_ray_in_R_standard_topology q HqR). }
    claim Hqltx1: Rlt q x1.
    { exact (andER (Rlt x2 q) (Rlt q x1) Hqconj). }
    claim Hx2ltq: Rlt x2 q.
    { exact (andEL (Rlt x2 q) (Rlt q x1) Hqconj). }
    claim Hx1U: x1 :e U.
    { exact (SepI R (fun x0 : set => Rlt q x0) x1 Hx1R Hqltx1). }
    claim Hx2V: x2 :e V.
    { exact (SepI R (fun x0 : set => Rlt x0 q) x2 Hx2R Hx2ltq). }
    claim HUVempty: U :/\: V = Empty.
    { apply Empty_Subq_eq.
      let x. assume HxUV: x :e U :/\: V.
      prove x :e Empty.
      apply FalseE.
      claim HxU: x :e U.
      { exact (binintersectE1 U V x HxUV). }
      claim HxV: x :e V.
      { exact (binintersectE2 U V x HxUV). }
      claim Hqltx: Rlt q x.
      { exact (SepE2 R (fun x0 : set => Rlt q x0) x HxU). }
      claim Hxltq: Rlt x q.
      { exact (SepE2 R (fun x0 : set => Rlt x0 q) x HxV). }
      claim Hqq: Rlt q q.
      { exact (Rlt_tra q x q Hqltx Hxltq). }
      exact ((not_Rlt_refl q HqR) Hqq). }
    apply andI.
    - prove ((U :e R_standard_topology /\ V :e R_standard_topology) /\ x1 :e U) /\ x2 :e V.
      apply andI.
      + prove (U :e R_standard_topology /\ V :e R_standard_topology) /\ x1 :e U.
        apply andI.
        * prove U :e R_standard_topology /\ V :e R_standard_topology.
          apply andI.
          - exact HUopen.
          - exact HVopen.
        * exact Hx1U.
      + exact Hx2V.
    - exact HUVempty.
Qed.

Theorem R_standard_topology_T1 : T1_space R R_standard_topology.
claim Htop: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
apply (iffER (T1_space R R_standard_topology)
             (forall z:set, z :e R -> closed_in R R_standard_topology {z})
             (lemma_T1_singletons_closed R R_standard_topology Htop)).
prove forall z:set, z :e R -> closed_in R R_standard_topology {z}.
let z. assume HzR: z :e R.
prove closed_in R R_standard_topology {z}.
claim HzSub: {z} c= R.
{ let y. assume Hy: y :e {z}.
  claim Heq: y = z.
  { exact (SingE z y Hy). }
  rewrite Heq. exact HzR. }
claim HUopen: R :\: {z} :e R_standard_topology.
{ rewrite (Sing_eq_UPair z).
  exact (R_minus_singleton_in_R_standard_topology z HzR). }
claim Hclosed: closed_in R R_standard_topology (R :\: (R :\: {z})).
{ exact (closed_of_open_complement R R_standard_topology (R :\: {z}) Htop HUopen). }
claim Heq: R :\: (R :\: {z}) = {z}.
{ exact (setminus_setminus_eq R {z} HzSub). }
rewrite <- Heq.
exact Hclosed.
Qed.

(** helper: Hausdorff is preserved by passing to a finer topology **)
Theorem finer_preserves_Hausdorff : forall X Tx Ty:set,
  Hausdorff_space X Tx ->
  topology_on X Ty ->
  Tx c= Ty ->
  Hausdorff_space X Ty.
let X Tx Ty.
assume HH: Hausdorff_space X Tx.
assume HTy: topology_on X Ty.
assume Hsub: Tx c= Ty.
prove Hausdorff_space X Ty.
prove topology_on X Ty /\
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact HTy.
- claim Hsep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  { exact (andER (topology_on X Tx)
                 (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
                 HH). }
  let x1 x2.
  assume Hx1: x1 :e X.
  assume Hx2: x2 :e X.
  assume Hne: x1 <> x2.
  apply (Hsep x1 x2 Hx1 Hx2 Hne).
  let U. assume HexV.
  apply HexV.
	  let V. assume HUV.
	  witness U.
	  witness V.
	  claim Hpre: (((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V).
	  { exact (andEL (((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V)
	                 (U :/\: V = Empty)
	                 HUV). }
	  claim Hempty: U :/\: V = Empty.
	  { exact (andER (((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V)
	                 (U :/\: V = Empty)
	                 HUV). }
	  claim Hpre2: ((U :e Tx /\ V :e Tx) /\ x1 :e U).
	  { exact (andEL ((U :e Tx /\ V :e Tx) /\ x1 :e U) (x2 :e V) Hpre). }
	  claim Hx2V: x2 :e V.
	  { exact (andER ((U :e Tx /\ V :e Tx) /\ x1 :e U) (x2 :e V) Hpre). }
	  claim Hpair: (U :e Tx /\ V :e Tx).
	  { exact (andEL (U :e Tx /\ V :e Tx) (x1 :e U) Hpre2). }
	  claim Hx1U: x1 :e U.
	  { exact (andER (U :e Tx /\ V :e Tx) (x1 :e U) Hpre2). }
	  claim HUinTx: U :e Tx.
	  { exact (andEL (U :e Tx) (V :e Tx) Hpair). }
	  claim HVinTx: V :e Tx.
	  { exact (andER (U :e Tx) (V :e Tx) Hpair). }
  claim HUinTy: U :e Ty.
  { exact (Hsub U HUinTx). }
	  claim HVinTy: V :e Ty.
	  { exact (Hsub V HVinTx). }
	  prove U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
	  apply andI.
	  - prove ((U :e Ty /\ V :e Ty) /\ x1 :e U) /\ x2 :e V.
	    apply andI.
	    + prove (U :e Ty /\ V :e Ty) /\ x1 :e U.
	      apply andI.
	      * prove U :e Ty /\ V :e Ty.
	        apply andI.
	        - exact HUinTy.
	        - exact HVinTy.
	      * exact Hx1U.
	    + exact Hx2V.
	  - exact Hempty.
Qed.

(** helper: the upper limit topology on R is Hausdorff and T1 **)
Theorem R_upper_limit_topology_Hausdorff : Hausdorff_space R R_upper_limit_topology.
claim HcontAll: finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology /\
                finer_than R_standard_topology R_finite_complement_topology /\
                finer_than R_standard_topology R_ray_topology.
{ exact ex13_7_R_topology_containments. }
claim Hleft1: (finer_than R_upper_limit_topology R_standard_topology /\
               finer_than R_K_topology R_standard_topology) /\
              finer_than R_standard_topology R_finite_complement_topology.
{ exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                 finer_than R_K_topology R_standard_topology) /\
                finer_than R_standard_topology R_finite_complement_topology)
               (finer_than R_standard_topology R_ray_topology)
               HcontAll). }
claim Hleft2: finer_than R_upper_limit_topology R_standard_topology /\
              finer_than R_K_topology R_standard_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology)
               (finer_than R_standard_topology R_finite_complement_topology)
               Hleft1). }
claim Hsub: R_standard_topology c= R_upper_limit_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology)
               (finer_than R_K_topology R_standard_topology)
               Hleft2). }
exact (finer_preserves_Hausdorff R R_standard_topology R_upper_limit_topology
       R_standard_topology_Hausdorff
       R_upper_limit_topology_is_topology_local
       Hsub).
Qed.

Theorem R_upper_limit_topology_T1 : T1_space R R_upper_limit_topology.
claim HtopStd: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HtopUpper: topology_on R R_upper_limit_topology.
{ exact R_upper_limit_topology_is_topology_local. }
claim HcontAll: finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology /\
                finer_than R_standard_topology R_finite_complement_topology /\
                finer_than R_standard_topology R_ray_topology.
{ exact ex13_7_R_topology_containments. }
claim Hleft1: (finer_than R_upper_limit_topology R_standard_topology /\
               finer_than R_K_topology R_standard_topology) /\
              finer_than R_standard_topology R_finite_complement_topology.
{ exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                 finer_than R_K_topology R_standard_topology) /\
                finer_than R_standard_topology R_finite_complement_topology)
               (finer_than R_standard_topology R_ray_topology)
               HcontAll). }
claim Hleft2: finer_than R_upper_limit_topology R_standard_topology /\
              finer_than R_K_topology R_standard_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology)
               (finer_than R_standard_topology R_finite_complement_topology)
               Hleft1). }
claim Hsub: R_standard_topology c= R_upper_limit_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology)
               (finer_than R_K_topology R_standard_topology)
               Hleft2). }
claim HpropStd:
  forall x y:set, x :e R -> y :e R -> x <> y ->
    (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
    (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V).
{ exact (iffEL (T1_space R R_standard_topology)
               (forall x y:set, x :e R -> y :e R -> x <> y ->
                 (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V))
               (ex17_15_T1_characterization R R_standard_topology HtopStd)
               R_standard_topology_T1). }
apply (iffER (T1_space R R_upper_limit_topology)
             (forall x y:set, x :e R -> y :e R -> x <> y ->
               (exists U:set, U :e R_upper_limit_topology /\ x :e U /\ y /:e U) /\
               (exists V:set, V :e R_upper_limit_topology /\ y :e V /\ x /:e V))
             (ex17_15_T1_characterization R R_upper_limit_topology HtopUpper)).
let x y.
assume HxR: x :e R.
assume HyR: y :e R.
assume Hne: x <> y.
claim Hprop: (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
             (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V).
{ exact (HpropStd x y HxR HyR Hne). }
apply andI.
- claim HexU: exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U.
  { exact (andEL (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U)
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V)
                 Hprop). }
	  apply HexU.
	  let U. assume HU.
	  witness U.
	  claim Hpre: U :e R_standard_topology /\ x :e U.
	  { exact (andEL (U :e R_standard_topology /\ x :e U) (y /:e U) HU). }
	  claim HUinStd: U :e R_standard_topology.
	  { exact (andEL (U :e R_standard_topology) (x :e U) Hpre). }
	  claim HxU: x :e U.
	  { exact (andER (U :e R_standard_topology) (x :e U) Hpre). }
	  claim Hnoty: y /:e U.
	  { exact (andER (U :e R_standard_topology /\ x :e U) (y /:e U) HU). }
	  claim HUinUpper: U :e R_upper_limit_topology.
	  { exact (Hsub U HUinStd). }
	  prove U :e R_upper_limit_topology /\ x :e U /\ y /:e U.
	  apply andI.
	  - prove U :e R_upper_limit_topology /\ x :e U.
	    apply andI.
	    + exact HUinUpper.
	    + exact HxU.
	  - exact Hnoty.
- claim HexV: exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V.
  { exact (andER (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U)
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V)
                 Hprop). }
	  apply HexV.
	  let V. assume HV.
	  witness V.
	  claim Hpre: V :e R_standard_topology /\ y :e V.
	  { exact (andEL (V :e R_standard_topology /\ y :e V) (x /:e V) HV). }
	  claim HVinStd: V :e R_standard_topology.
	  { exact (andEL (V :e R_standard_topology) (y :e V) Hpre). }
	  claim HyV: y :e V.
	  { exact (andER (V :e R_standard_topology) (y :e V) Hpre). }
	  claim Hnotx: x /:e V.
	  { exact (andER (V :e R_standard_topology /\ y :e V) (x /:e V) HV). }
	  claim HVinUpper: V :e R_upper_limit_topology.
	  { exact (Hsub V HVinStd). }
	  prove V :e R_upper_limit_topology /\ y :e V /\ x /:e V.
	  apply andI.
	  - prove V :e R_upper_limit_topology /\ y :e V.
	    apply andI.
	    + exact HVinUpper.
	    + exact HyV.
	  - exact Hnotx.
Qed.

(** helper: the K topology on R is Hausdorff and T1 **)
Theorem R_K_topology_Hausdorff : Hausdorff_space R R_K_topology.
claim HcontAll: finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology /\
                finer_than R_standard_topology R_finite_complement_topology /\
                finer_than R_standard_topology R_ray_topology.
{ exact ex13_7_R_topology_containments. }
claim Hleft1: (finer_than R_upper_limit_topology R_standard_topology /\
               finer_than R_K_topology R_standard_topology) /\
              finer_than R_standard_topology R_finite_complement_topology.
{ exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                 finer_than R_K_topology R_standard_topology) /\
                finer_than R_standard_topology R_finite_complement_topology)
               (finer_than R_standard_topology R_ray_topology)
               HcontAll). }
claim Hleft2: finer_than R_upper_limit_topology R_standard_topology /\
              finer_than R_K_topology R_standard_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology)
               (finer_than R_standard_topology R_finite_complement_topology)
               Hleft1). }
claim Hsub: R_standard_topology c= R_K_topology.
{ exact (andER (finer_than R_upper_limit_topology R_standard_topology)
               (finer_than R_K_topology R_standard_topology)
               Hleft2). }
exact (finer_preserves_Hausdorff R R_standard_topology R_K_topology
       R_standard_topology_Hausdorff
       R_K_topology_is_topology_local
       Hsub).
Qed.

Theorem R_K_topology_T1 : T1_space R R_K_topology.
claim HtopStd: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HtopK: topology_on R R_K_topology.
{ exact R_K_topology_is_topology_local. }
claim HcontAll: finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology /\
                finer_than R_standard_topology R_finite_complement_topology /\
                finer_than R_standard_topology R_ray_topology.
{ exact ex13_7_R_topology_containments. }
claim Hleft1: (finer_than R_upper_limit_topology R_standard_topology /\
               finer_than R_K_topology R_standard_topology) /\
              finer_than R_standard_topology R_finite_complement_topology.
{ exact (andEL ((finer_than R_upper_limit_topology R_standard_topology /\
                 finer_than R_K_topology R_standard_topology) /\
                finer_than R_standard_topology R_finite_complement_topology)
               (finer_than R_standard_topology R_ray_topology)
               HcontAll). }
claim Hleft2: finer_than R_upper_limit_topology R_standard_topology /\
              finer_than R_K_topology R_standard_topology.
{ exact (andEL (finer_than R_upper_limit_topology R_standard_topology /\
                finer_than R_K_topology R_standard_topology)
               (finer_than R_standard_topology R_finite_complement_topology)
               Hleft1). }
claim Hsub: R_standard_topology c= R_K_topology.
{ exact (andER (finer_than R_upper_limit_topology R_standard_topology)
               (finer_than R_K_topology R_standard_topology)
               Hleft2). }
claim HpropStd:
  forall x y:set, x :e R -> y :e R -> x <> y ->
    (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
    (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V).
{ exact (iffEL (T1_space R R_standard_topology)
               (forall x y:set, x :e R -> y :e R -> x <> y ->
                 (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V))
               (ex17_15_T1_characterization R R_standard_topology HtopStd)
               R_standard_topology_T1). }
apply (iffER (T1_space R R_K_topology)
             (forall x y:set, x :e R -> y :e R -> x <> y ->
               (exists U:set, U :e R_K_topology /\ x :e U /\ y /:e U) /\
               (exists V:set, V :e R_K_topology /\ y :e V /\ x /:e V))
             (ex17_15_T1_characterization R R_K_topology HtopK)).
let x y.
assume HxR: x :e R.
assume HyR: y :e R.
assume Hne: x <> y.
claim Hprop: (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U) /\
             (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V).
{ exact (HpropStd x y HxR HyR Hne). }
apply andI.
- claim HexU: exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U.
  { exact (andEL (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U)
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V)
                 Hprop). }
  apply HexU.
  let U. assume HU.
  witness U.
  claim Hpre: U :e R_standard_topology /\ x :e U.
  { exact (andEL (U :e R_standard_topology /\ x :e U) (y /:e U) HU). }
  claim HUinStd: U :e R_standard_topology.
  { exact (andEL (U :e R_standard_topology) (x :e U) Hpre). }
  claim HxU: x :e U.
  { exact (andER (U :e R_standard_topology) (x :e U) Hpre). }
  claim Hnoty: y /:e U.
  { exact (andER (U :e R_standard_topology /\ x :e U) (y /:e U) HU). }
  claim HUinK: U :e R_K_topology.
  { exact (Hsub U HUinStd). }
  prove U :e R_K_topology /\ x :e U /\ y /:e U.
  apply andI.
  - prove U :e R_K_topology /\ x :e U.
    apply andI.
    + exact HUinK.
    + exact HxU.
  - exact Hnoty.
- claim HexV: exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V.
  { exact (andER (exists U:set, U :e R_standard_topology /\ x :e U /\ y /:e U)
                 (exists V:set, V :e R_standard_topology /\ y :e V /\ x /:e V)
                 Hprop). }
  apply HexV.
  let V. assume HV.
  witness V.
  claim Hpre: V :e R_standard_topology /\ y :e V.
  { exact (andEL (V :e R_standard_topology /\ y :e V) (x /:e V) HV). }
  claim HVinStd: V :e R_standard_topology.
  { exact (andEL (V :e R_standard_topology) (y :e V) Hpre). }
  claim HyV: y :e V.
  { exact (andER (V :e R_standard_topology) (y :e V) Hpre). }
  claim Hnotx: x /:e V.
  { exact (andER (V :e R_standard_topology /\ y :e V) (x /:e V) HV). }
  claim HVinK: V :e R_K_topology.
  { exact (Hsub V HVinStd). }
  prove V :e R_K_topology /\ y :e V /\ x /:e V.
  apply andI.
  - prove V :e R_K_topology /\ y :e V.
    apply andI.
    + exact HVinK.
    + exact HyV.
  - exact Hnotx.
Qed.

(** LATEX VERSION: Exercise 16(b): For the same five R topologies, determine which satisfy the Hausdorff and the T1 axioms. **)
Theorem ex17_16b_Hausdorff_and_T1_for_five_topologies :
  (Hausdorff_space R R_standard_topology /\ T1_space R R_standard_topology) /\
  (Hausdorff_space R R_upper_limit_topology /\ T1_space R R_upper_limit_topology) /\
  (Hausdorff_space R R_K_topology /\ T1_space R R_K_topology) /\
  (~Hausdorff_space R R_finite_complement_topology /\ T1_space R R_finite_complement_topology) /\
  (~Hausdorff_space R R_ray_topology /\ ~T1_space R R_ray_topology).
prove (Hausdorff_space R R_standard_topology /\ T1_space R R_standard_topology) /\
  (Hausdorff_space R R_upper_limit_topology /\ T1_space R R_upper_limit_topology) /\
  (Hausdorff_space R R_K_topology /\ T1_space R R_K_topology) /\
  (~Hausdorff_space R R_finite_complement_topology /\ T1_space R R_finite_complement_topology) /\
  (~Hausdorff_space R R_ray_topology /\ ~T1_space R R_ray_topology).
apply andI.
- apply andI.
  * prove (Hausdorff_space R R_standard_topology /\ T1_space R R_standard_topology) /\
          (Hausdorff_space R R_upper_limit_topology /\ T1_space R R_upper_limit_topology) /\
          (Hausdorff_space R R_K_topology /\ T1_space R R_K_topology).
	    apply andI.
		    { apply andI.
		      - prove Hausdorff_space R R_standard_topology /\ T1_space R R_standard_topology.
		        apply andI.
		        + exact R_standard_topology_Hausdorff.
		        + exact R_standard_topology_T1.
		      - prove Hausdorff_space R R_upper_limit_topology /\ T1_space R R_upper_limit_topology.
		        apply andI.
		        + exact R_upper_limit_topology_Hausdorff.
		        + exact R_upper_limit_topology_T1.
		    }
		    { prove Hausdorff_space R R_K_topology /\ T1_space R R_K_topology.
		      apply andI.
		      - exact R_K_topology_Hausdorff.
		      - exact R_K_topology_T1.
		    }
	  * prove ~Hausdorff_space R R_finite_complement_topology /\ T1_space R R_finite_complement_topology.
	    apply andI.
	    { exact R_finite_complement_not_Hausdorff. }
	    { exact (finite_complement_topology_T1 R). }
- prove ~Hausdorff_space R R_ray_topology /\ ~T1_space R R_ray_topology.
  apply andI.
  + exact ray_topology_not_Hausdorff.
  + exact ray_topology_not_T1.
Qed.

(** LATEX VERSION: Exercise 17: Compare closures of A=(0,sqrt 2) and B=(sqrt 2,3) in the lower limit topology and the topology generated by the rational half open basis C. **)
(** Helper: basic real membership facts used in Exercise 17 definitions **)
Theorem real_2 : 2 :e R.
prove 2 :e R.
rewrite <- add_SNo_1_1_2.
exact (real_add_SNo 1 real_1 1 real_1).
Qed.

Theorem ordsucc_2_eq_3 : ordsucc 2 = 3.
reflexivity.
Qed.

Theorem add_SNo_2_1_eq_3 : add_SNo 2 1 = 3.
claim H2omega : 2 :e omega.
{ exact (nat_p_omega 2 nat_2). }
rewrite (add_SNo_1_ordsucc 2 H2omega).
rewrite ordsucc_2_eq_3.
reflexivity.
Qed.

Theorem real_3 : 3 :e R.
prove 3 :e R.
rewrite <- add_SNo_2_1_eq_3.
exact (real_add_SNo 2 real_2 1 real_1).
Qed.

(** from §17 Exercise 17: closures of (0,sqrt2) and (sqrt2,3) **)
(** LATEX VERSION: Consider the intervals A=(0,sqrt2) and B=(sqrt2,3) when comparing closures in different topologies on R. **)
Definition sqrt2 : set := sqrt_SNo_nonneg 2.

(** Helper: sqrt2 is real **)
Theorem sqrt2_in_R : sqrt2 :e R.
prove sqrt2 :e R.
exact (sqrt_SNo_nonneg_real 2 real_2 (SNoLtLe 0 2 SNoLt_0_2)).
Qed.

(** Helper: sqrt2 is positive **)
Theorem SNoLt_0_sqrt2 : 0 < sqrt2.
prove 0 < sqrt2.
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim H0le2: 0 <= 2.
{ exact (SNoLtLe 0 2 SNoLt_0_2). }
claim H0les2: 0 <= sqrt2.
{ exact (sqrt_SNo_nonneg_nonneg 2 SNo_2 H0le2). }
apply (SNoLt_trichotomy_or_impred sqrt2 0 Hs2S SNo_0 (0 < sqrt2)).
- assume Hs2lt0: sqrt2 < 0.
  apply FalseE.
  claim H0lt0: 0 < 0.
  { exact (SNoLeLt_tra 0 sqrt2 0 SNo_0 Hs2S SNo_0 H0les2 Hs2lt0). }
  exact ((SNoLt_irref 0) H0lt0).
- assume Heq: sqrt2 = 0.
  apply FalseE.
  claim Htmp: mul_SNo sqrt2 sqrt2 = 2.
  { exact (sqrt_SNo_nonneg_sqr 2 SNo_2 (SNoLtLe 0 2 SNoLt_0_2)). }
  claim Hs2sqr0: mul_SNo 0 0 = 2.
  { rewrite <- Heq at 1.
    rewrite <- Heq at 1.
    exact Htmp. }
  claim H00: mul_SNo 0 0 = 0.
  { exact (mul_SNo_zeroL 0 SNo_0). }
  claim H02: 0 = 2.
  { rewrite <- H00 at 1.
    exact Hs2sqr0. }
  exact (neq_0_2 H02).
- assume H0lts2: 0 < sqrt2.
  exact H0lts2.
Qed.

(** Helper: 3 is a rational number **)
Theorem three_in_rational_numbers : 3 :e rational_numbers.
prove 3 :e rational.
claim H3nat: nat_p 3.
{ rewrite <- ordsucc_2_eq_3.
  exact (nat_ordsucc 2 nat_2). }
claim H3omega: 3 :e omega.
{ exact (nat_p_omega 3 H3nat). }
claim H3SNoS: 3 :e SNoS_ omega.
{ exact (omega_SNoS_omega 3 H3omega). }
exact (Subq_SNoS_omega_rational 3 H3SNoS).
Qed.

(** Helper: sqrt2 is not rational **)
Theorem sqrt2_not_rational_numbers : sqrt2 /:e rational_numbers.
assume Hs2Q: sqrt2 :e rational_numbers.
prove False.
claim Hirr: sqrt2 :e real :\: rational.
{ exact sqrt_2_irrational. }
claim HnotRat: sqrt2 /:e rational.
{ exact (setminusE2 real rational sqrt2 Hirr). }
claim HdefQ: rational_numbers = rational.
{ reflexivity. }
claim Hs2Rat: sqrt2 :e rational.
{ rewrite <- HdefQ.
  exact Hs2Q. }
exact (HnotRat Hs2Rat).
Qed.

(** from §17 Exercise 17: topology generated by basis C (rational half open intervals) **)
(** LATEX VERSION: Consider the topology given by the basis C from Exercise 8 of §13, consisting of half-open intervals with rational endpoints. **)
Definition R_C_topology : set := generated_topology R rational_halfopen_intervals_basis.

(** Helper: the lower limit topology is finer than the rational half-open topology **)
(** LATEX VERSION: Since the half-open rational intervals are among the half-open real intervals, the topology they generate is coarser than the lower limit topology. **)
Theorem R_lower_limit_finer_than_R_C : finer_than R_lower_limit_topology R_C_topology.
prove finer_than R_lower_limit_topology R_C_topology.
(** apply generated_topology_finer_weak with T = R_lower_limit_topology and generators B = rational_halfopen_intervals_basis **)
claim HTlower: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HBsub: forall b :e rational_halfopen_intervals_basis, b :e R_lower_limit_topology.
{ let b. assume HbB: b :e rational_halfopen_intervals_basis.
  prove b :e R_lower_limit_topology.
  (** show b is a lower-limit basis element, then lift to the generated topology **)
  claim Hexq1: exists q1 :e rational_numbers, b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
  { exact (famunionE rational_numbers
           (fun q1 : set => {halfopen_interval_left q1 q2|q2 :e rational_numbers})
           b
           HbB). }
  apply Hexq1.
  let q1. assume Hq1pair. apply Hq1pair.
  assume Hq1Q: q1 :e rational_numbers.
  assume HbFam: b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
  claim Hexq2: exists q2 :e rational_numbers, b = halfopen_interval_left q1 q2.
  { exact (ReplE rational_numbers (fun q2 : set => halfopen_interval_left q1 q2) b HbFam). }
  apply Hexq2.
  let q2. assume Hq2pair.
  claim Hq2Q: q2 :e rational_numbers.
  { exact (andEL (q2 :e rational_numbers) (b = halfopen_interval_left q1 q2) Hq2pair). }
  claim Hbeq: b = halfopen_interval_left q1 q2.
  { exact (andER (q2 :e rational_numbers) (b = halfopen_interval_left q1 q2) Hq2pair). }
  rewrite Hbeq.
  claim Hq1R: q1 :e R.
  { exact (rational_numbers_in_R q1 Hq1Q). }
  claim Hq2R: q2 :e R.
  { exact (rational_numbers_in_R q2 Hq2Q). }
  claim HbInLowerBasis: halfopen_interval_left q1 q2 :e R_lower_limit_basis.
  { prove halfopen_interval_left q1 q2 :e R_lower_limit_basis.
    claim HbFamR: halfopen_interval_left q1 q2 :e {halfopen_interval_left q1 bb|bb :e R}.
    { exact (ReplI R (fun bb : set => halfopen_interval_left q1 bb) q2 Hq2R). }
    exact (famunionI R (fun aa : set => {halfopen_interval_left aa bb|bb :e R})
                     q1
                     (halfopen_interval_left q1 q2)
                     Hq1R
                     HbFamR). }
  (** lift basis element into generated topology = R_lower_limit_topology **)
  claim HbInGen: halfopen_interval_left q1 q2 :e generated_topology R R_lower_limit_basis.
  { exact (generated_topology_contains_basis R R_lower_limit_basis
           R_lower_limit_basis_is_basis_local
           (halfopen_interval_left q1 q2)
           HbInLowerBasis). }
  exact HbInGen. }
exact (generated_topology_finer_weak R rational_halfopen_intervals_basis R_lower_limit_topology
       HTlower HBsub).
Qed.

(** from §17 Exercise 17: the interval A **)
(** LATEX VERSION: A = (0,sqrt2). **)
Definition ex17_17_interval_A : set := open_interval 0 sqrt2.
(** from §17 Exercise 17: the interval B **)
(** LATEX VERSION: B = (sqrt2,3). **)
Definition ex17_17_interval_B : set := open_interval sqrt2 3.
(** from §17 Exercise 17: closure of A in the lower limit topology **)
(** LATEX VERSION: In the lower limit topology, cl(A) = {x | 0 <= x < sqrt2}. **)
Definition ex17_17_interval_A_closure_lower : set := {x :e R|0 <= x /\ x < sqrt2}.
(** from §17 Exercise 17: closure of A in the C topology **)
(** LATEX VERSION: In the topology generated by rational half-open intervals, cl(A) = {x | 0 <= x <= sqrt2}. **)
Definition ex17_17_interval_A_closure_C : set := {x :e R|0 <= x /\ x <= sqrt2}.
(** from §17 Exercise 17: closure of B in the lower limit topology **)
(** LATEX VERSION: In the lower limit topology, cl(B) = {x | sqrt2 <= x < 3}. **)
Definition ex17_17_interval_B_closure_lower : set := {x :e R|sqrt2 <= x /\ x < 3}.

(** Helper for Exercise 17: closure(A) in lower limit topology is contained in {x|0<=x<x<sqrt2} **)
(** LATEX VERSION: In the lower limit topology, points <0 and points ≥sqrt2 have neighborhoods disjoint from A=(0,sqrt2). **)
Theorem ex17_17_closure_A_lower_Subq : closure_of R R_lower_limit_topology ex17_17_interval_A c= ex17_17_interval_A_closure_lower.
let x. assume Hx: x :e closure_of R R_lower_limit_topology ex17_17_interval_A.
prove x :e ex17_17_interval_A_closure_lower.
claim HxR: x :e R.
{ exact (SepE1 R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_A <> Empty) x Hx). }
claim Hxcl: forall U:set, U :e R_lower_limit_topology -> x :e U -> U :/\: ex17_17_interval_A <> Empty.
{ exact (SepE2 R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_A <> Empty) x Hx). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }

(** establish 0 <= x by ruling out x < 0 **)
claim Hnotxlt0: ~(x < 0).
{ assume Hxlt0: x < 0.
  apply FalseE.
  claim HxRlt0: Rlt x 0.
  { exact (RltI x 0 HxR real_0 Hxlt0). }
  set U := halfopen_interval_left x 0.
  claim HUopen: U :e R_lower_limit_topology.
  { exact (halfopen_interval_left_in_R_lower_limit_topology x 0 HxR real_0). }
  claim HxU: x :e U.
  { exact (halfopen_interval_left_leftmem x 0 HxRlt0). }
  claim Hne: U :/\: ex17_17_interval_A <> Empty.
  { exact (Hxcl U HUopen HxU). }
  claim Hempty: U :/\: ex17_17_interval_A = Empty.
  { apply Empty_Subq_eq.
    let y. assume Hy: y :e U :/\: ex17_17_interval_A.
    prove y :e Empty.
    apply FalseE.
    claim HyU: y :e U.
    { exact (binintersectE1 U ex17_17_interval_A y Hy). }
    claim HyA: y :e ex17_17_interval_A.
    { exact (binintersectE2 U ex17_17_interval_A y Hy). }
    claim HyUprop: ~(Rlt y x) /\ Rlt y 0.
    { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z 0) y HyU). }
    claim Hylt0: Rlt y 0.
    { exact (andER (~(Rlt y x)) (Rlt y 0) HyUprop). }
    claim HyAprop: Rlt 0 y /\ Rlt y sqrt2.
    { exact (SepE2 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA). }
    claim H0lty: Rlt 0 y.
    { exact (andEL (Rlt 0 y) (Rlt y sqrt2) HyAprop). }
    claim H00: Rlt 0 0.
    { exact (Rlt_tra 0 y 0 H0lty Hylt0). }
    exact ((not_Rlt_refl 0 real_0) H00). }
  exact (Hne Hempty). }

claim H0lex: 0 <= x.
{ apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (0 <= x)).
  - assume Hxlt0: x < 0.
    apply FalseE.
    exact (Hnotxlt0 Hxlt0).
  - assume Hx0: x = 0.
    rewrite Hx0.
    exact (SNoLe_ref 0).
  - assume H0ltx: 0 < x.
    exact (SNoLtLe 0 x H0ltx). }

(** establish x < sqrt2 by ruling out x = sqrt2 and sqrt2 < x **)
claim HxltS2: x < sqrt2.
{ apply (SNoLt_trichotomy_or_impred x sqrt2 HxS Hs2S (x < sqrt2)).
  - assume Hlt: x < sqrt2. exact Hlt.
  - assume Heq: x = sqrt2.
    apply FalseE.
    set b0 := add_SNo x 1.
    claim Hb0R: b0 :e R.
    { rewrite Heq.
      exact (real_add_SNo sqrt2 Hs2R 1 real_1). }
    claim HxInStd: x :e open_interval (add_SNo x (minus_SNo 1)) b0.
    { exact (real_in_open_interval_minus1_plus1 x HxR). }
    claim HxStdProp: Rlt (add_SNo x (minus_SNo 1)) x /\ Rlt x b0.
    { exact (SepE2 R (fun z:set => Rlt (add_SNo x (minus_SNo 1)) z /\ Rlt z b0) x HxInStd). }
    claim Hxb0: Rlt x b0.
    { exact (andER (Rlt (add_SNo x (minus_SNo 1)) x) (Rlt x b0) HxStdProp). }
    set U := halfopen_interval_left x b0.
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x b0 HxR Hb0R). }
    claim HxU: x :e U.
    { exact (halfopen_interval_left_leftmem x b0 Hxb0). }
    claim Hne: U :/\: ex17_17_interval_A <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: ex17_17_interval_A = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: ex17_17_interval_A.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U ex17_17_interval_A y Hy). }
      claim HyA: y :e ex17_17_interval_A.
      { exact (binintersectE2 U ex17_17_interval_A y Hy). }
      claim HyUprop: ~(Rlt y x) /\ Rlt y b0.
      { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z b0) y HyU). }
      claim Hnyx: ~(Rlt y x).
      { exact (andEL (~(Rlt y x)) (Rlt y b0) HyUprop). }
      claim HyAprop: Rlt 0 y /\ Rlt y sqrt2.
      { exact (SepE2 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA). }
      claim HyltS2: Rlt y sqrt2.
      { exact (andER (Rlt 0 y) (Rlt y sqrt2) HyAprop). }
      claim Hyltx: Rlt y x.
      { rewrite Heq.
        exact HyltS2. }
      exact (Hnyx Hyltx). }
    exact (Hne Hempty).
  - assume Hgt: sqrt2 < x.
    apply FalseE.
    set b0 := add_SNo x 1.
    claim Hb0R: b0 :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim HxInStd: x :e open_interval (add_SNo x (minus_SNo 1)) b0.
    { exact (real_in_open_interval_minus1_plus1 x HxR). }
    claim HxStdProp: Rlt (add_SNo x (minus_SNo 1)) x /\ Rlt x b0.
    { exact (SepE2 R (fun z:set => Rlt (add_SNo x (minus_SNo 1)) z /\ Rlt z b0) x HxInStd). }
    claim Hxb0: Rlt x b0.
    { exact (andER (Rlt (add_SNo x (minus_SNo 1)) x) (Rlt x b0) HxStdProp). }
    set U := halfopen_interval_left x b0.
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x b0 HxR Hb0R). }
    claim HxU: x :e U.
    { exact (halfopen_interval_left_leftmem x b0 Hxb0). }
    claim Hne: U :/\: ex17_17_interval_A <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: ex17_17_interval_A = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: ex17_17_interval_A.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U ex17_17_interval_A y Hy). }
      claim HyA: y :e ex17_17_interval_A.
      { exact (binintersectE2 U ex17_17_interval_A y Hy). }
      claim HyUprop: ~(Rlt y x) /\ Rlt y b0.
      { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z b0) y HyU). }
      claim Hnyx: ~(Rlt y x).
      { exact (andEL (~(Rlt y x)) (Rlt y b0) HyUprop). }
      claim HyAprop: Rlt 0 y /\ Rlt y sqrt2.
      { exact (SepE2 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA). }
      claim HyltS2R: Rlt y sqrt2.
      { exact (andER (Rlt 0 y) (Rlt y sqrt2) HyAprop). }
      claim HyS: SNo y.
      { exact (real_SNo y (SepE1 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA)). }
      claim HyltS2: y < sqrt2.
      { exact (RltE_lt y sqrt2 HyltS2R). }
      claim Hyltx: y < x.
      { exact (SNoLt_tra y sqrt2 x HyS Hs2S HxS HyltS2 Hgt). }
      claim Hyltrx: Rlt y x.
      { exact (RltI y x (SepE1 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA) HxR Hyltx). }
      exact (Hnyx Hyltrx). }
    exact (Hne Hempty). }

prove x :e ex17_17_interval_A_closure_lower.
exact (SepI R (fun z:set => 0 <= z /\ z < sqrt2) x HxR (andI (0 <= x) (x < sqrt2) H0lex HxltS2)).
Qed.

(** Helper for Exercise 17: {x|0<=x<x<sqrt2} is contained in the closure of A in the lower limit topology **)
(** LATEX VERSION: If 0<x<sqrt2 then x itself witnesses every neighborhood meets A; for x=0 use a basis element and density of rationals. **)
Theorem ex17_17_closure_A_lower_Supq :
  ex17_17_interval_A_closure_lower c= closure_of R R_lower_limit_topology ex17_17_interval_A.
let x. assume Hx: x :e ex17_17_interval_A_closure_lower.
prove x :e closure_of R R_lower_limit_topology ex17_17_interval_A.
claim HxR: x :e R.
{ exact (SepE1 R (fun z:set => 0 <= z /\ z < sqrt2) x Hx). }
claim HxProp: 0 <= x /\ x < sqrt2.
{ exact (SepE2 R (fun z:set => 0 <= z /\ z < sqrt2) x Hx). }
claim H0lex: 0 <= x.
{ exact (andEL (0 <= x) (x < sqrt2) HxProp). }
claim HxltS2: x < sqrt2.
{ exact (andER (0 <= x) (x < sqrt2) HxProp). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }

claim Hcl: forall U:set, U :e R_lower_limit_topology -> x :e U -> U :/\: ex17_17_interval_A <> Empty.
{ let U. assume HU: U :e R_lower_limit_topology.
  assume HxU: x :e U.
  prove U :/\: ex17_17_interval_A <> Empty.
  claim Hcases: 0 < x \/ 0 = x.
  { exact (SNoLeE 0 x SNo_0 HxS H0lex). }
  apply Hcases.
  - assume H0ltx: 0 < x.
    set A := ex17_17_interval_A.
    claim H0ltxR: Rlt 0 x.
    { exact (RltI 0 x real_0 HxR H0ltx). }
    claim HxltS2R: Rlt x sqrt2.
    { exact (RltI x sqrt2 HxR Hs2R HxltS2). }
    claim Hxconj: Rlt 0 x /\ Rlt x sqrt2.
    { apply andI.
      - exact H0ltxR.
      - exact HxltS2R. }
    claim HxA: x :e A.
    { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) x HxR Hxconj). }
    assume Hemp: U :/\: A = Empty.
    apply FalseE.
    claim HxUA: x :e U :/\: A.
    { exact (binintersectI U A x HxU HxA). }
    claim HxEmp: x :e Empty.
    { rewrite <- Hemp.
      exact HxUA. }
    exact (EmptyE x HxEmp).
  - assume H0eqx: 0 = x.
    set A := ex17_17_interval_A.
    claim H0U: 0 :e U.
    { rewrite H0eqx.
      exact HxU. }
    claim Hneigh: forall z :e U, exists b :e R_lower_limit_basis, z :e b /\ b c= U.
    { exact (SepE2 (Power R)
                   (fun U0 : set => forall z :e U0, exists b :e R_lower_limit_basis, z :e b /\ b c= U0)
                   U
                   HU). }
    claim Hexb: exists b :e R_lower_limit_basis, 0 :e b /\ b c= U.
    { exact (Hneigh 0 H0U). }
    apply Hexb.
    let b. assume Hbpair. apply Hbpair.
    assume HbB: b :e R_lower_limit_basis.
    assume Hbcore: 0 :e b /\ b c= U.
    claim H0b: 0 :e b.
    { exact (andEL (0 :e b) (b c= U) Hbcore). }
    claim HbsubU: b c= U.
    { exact (andER (0 :e b) (b c= U) Hbcore). }
    claim Hexa: exists a :e R, b :e {halfopen_interval_left a bb|bb :e R}.
    { exact (famunionE R (fun a0 : set => {halfopen_interval_left a0 bb|bb :e R}) b HbB). }
    apply Hexa.
    let a. assume Hapair. apply Hapair.
    assume HaR: a :e R.
    assume HbFam: b :e {halfopen_interval_left a bb|bb :e R}.
    claim Hexbb: exists bb :e R, b = halfopen_interval_left a bb.
    { exact (ReplE R (fun bb0 : set => halfopen_interval_left a bb0) b HbFam). }
    apply Hexbb.
    let bb. assume Hbbpair. apply Hbbpair.
    assume HbbR: bb :e R.
    assume Hbeq: b = halfopen_interval_left a bb.
    claim H0Inb: 0 :e halfopen_interval_left a bb.
    { rewrite <- Hbeq.
      exact H0b. }
    claim H0bprop: ~(Rlt 0 a) /\ Rlt 0 bb.
    { exact (SepE2 R (fun z:set => ~(Rlt z a) /\ Rlt z bb) 0 H0Inb). }
    claim Hnot0a: ~(Rlt 0 a).
    { exact (andEL (~(Rlt 0 a)) (Rlt 0 bb) H0bprop). }
    claim H0ltbb: Rlt 0 bb.
    { exact (andER (~(Rlt 0 a)) (Rlt 0 bb) H0bprop). }
    claim HbbS: SNo bb.
    { exact (real_SNo bb HbbR). }
    apply (SNoLt_trichotomy_or_impred bb sqrt2 HbbS Hs2S (U :/\: A <> Empty)).
    + assume HbbLtS2: bb < sqrt2.
      claim HbbLtS2R: Rlt bb sqrt2.
      { exact (RltI bb sqrt2 HbbR Hs2R HbbLtS2). }
      apply (rational_dense_between_reals 0 bb real_0 HbbR H0ltbb).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q bb.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q bb) Hqprop). }
      claim Hqltbb: Rlt q bb.
      { exact (andER (Rlt 0 q) (Rlt q bb) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqltS2: Rlt q sqrt2.
      { exact (Rlt_tra q bb sqrt2 Hqltbb HbbLtS2R). }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim H0a: Rlt 0 a.
        { exact (Rlt_tra 0 q a H0ltq Hqa). }
        exact (Hnot0a H0a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { claim HqconjA: Rlt 0 q /\ Rlt q sqrt2.
        { apply andI.
          - exact H0ltq.
          - exact HqltS2. }
        exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR HqconjA). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp).
    + assume HbbEqS2: bb = sqrt2.
      apply (rational_dense_between_reals 0 bb real_0 HbbR H0ltbb).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q bb.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q bb) Hqprop). }
      claim Hqltbb: Rlt q bb.
      { exact (andER (Rlt 0 q) (Rlt q bb) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqltS2: Rlt q sqrt2.
      { rewrite <- HbbEqS2.
        exact Hqltbb. }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim H0a: Rlt 0 a.
        { exact (Rlt_tra 0 q a H0ltq Hqa). }
        exact (Hnot0a H0a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { claim HqconjA: Rlt 0 q /\ Rlt q sqrt2.
        { apply andI.
          - exact H0ltq.
          - exact HqltS2. }
        exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR HqconjA). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp).
    + assume Hs2Ltbb: sqrt2 < bb.
      claim Hs2LtbbR: Rlt sqrt2 bb.
      { exact (RltI sqrt2 bb Hs2R HbbR Hs2Ltbb). }
      claim H0ltS2R: Rlt 0 sqrt2.
      { exact (RltI 0 sqrt2 real_0 Hs2R SNoLt_0_sqrt2). }
      apply (rational_dense_between_reals 0 sqrt2 real_0 Hs2R H0ltS2R).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q sqrt2.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim HqltS2: Rlt q sqrt2.
      { exact (andER (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hqltbb: Rlt q bb.
      { exact (Rlt_tra q sqrt2 bb HqltS2 Hs2LtbbR). }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim H0a: Rlt 0 a.
        { exact (Rlt_tra 0 q a H0ltq Hqa). }
        exact (Hnot0a H0a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { claim HqconjA: Rlt 0 q /\ Rlt q sqrt2.
        { apply andI.
          - exact H0ltq.
          - exact HqltS2. }
        exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR HqconjA). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp). }
exact (SepI R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_A <> Empty) x HxR Hcl).
Qed.

(** Helper for Exercise 17: closure(B) in lower limit topology is contained in {x|sqrt2<=x<x<3} **)
(** LATEX VERSION: In the lower limit topology, points <sqrt2 and points ≥3 have neighborhoods disjoint from B=(sqrt2,3). **)
Theorem ex17_17_closure_B_lower_Subq : closure_of R R_lower_limit_topology ex17_17_interval_B c= ex17_17_interval_B_closure_lower.
let x. assume Hx: x :e closure_of R R_lower_limit_topology ex17_17_interval_B.
prove x :e ex17_17_interval_B_closure_lower.
claim HxR: x :e R.
{ exact (SepE1 R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_B <> Empty) x Hx). }
claim Hxcl: forall U:set, U :e R_lower_limit_topology -> x :e U -> U :/\: ex17_17_interval_B <> Empty.
{ exact (SepE2 R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_B <> Empty) x Hx). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim H3S: SNo 3.
{ exact (real_SNo 3 real_3). }

(** establish sqrt2 <= x by ruling out x < sqrt2 **)
claim HnotxltS2: ~(x < sqrt2).
{ assume HxltS2: x < sqrt2.
  apply FalseE.
  claim HxRltS2: Rlt x sqrt2.
  { exact (RltI x sqrt2 HxR Hs2R HxltS2). }
  set U := halfopen_interval_left x sqrt2.
  claim HUopen: U :e R_lower_limit_topology.
  { exact (halfopen_interval_left_in_R_lower_limit_topology x sqrt2 HxR Hs2R). }
  claim HxU: x :e U.
  { exact (halfopen_interval_left_leftmem x sqrt2 HxRltS2). }
  claim Hne: U :/\: ex17_17_interval_B <> Empty.
  { exact (Hxcl U HUopen HxU). }
  claim Hempty: U :/\: ex17_17_interval_B = Empty.
  { apply Empty_Subq_eq.
    let y. assume Hy: y :e U :/\: ex17_17_interval_B.
    prove y :e Empty.
    apply FalseE.
    claim HyU: y :e U.
    { exact (binintersectE1 U ex17_17_interval_B y Hy). }
    claim HyB: y :e ex17_17_interval_B.
    { exact (binintersectE2 U ex17_17_interval_B y Hy). }
    claim HyUprop: ~(Rlt y x) /\ Rlt y sqrt2.
    { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z sqrt2) y HyU). }
    claim HyltS2: Rlt y sqrt2.
    { exact (andER (~(Rlt y x)) (Rlt y sqrt2) HyUprop). }
    claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
    { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
    claim Hs2lty: Rlt sqrt2 y.
    { exact (andEL (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
    claim Hs2ltS2: Rlt sqrt2 sqrt2.
    { exact (Rlt_tra sqrt2 y sqrt2 Hs2lty HyltS2). }
    exact ((not_Rlt_refl sqrt2 Hs2R) Hs2ltS2). }
  exact (Hne Hempty). }

claim Hs2lex: sqrt2 <= x.
{ apply (SNoLt_trichotomy_or_impred x sqrt2 HxS Hs2S (sqrt2 <= x)).
  - assume Hlt: x < sqrt2.
    apply FalseE.
    exact (HnotxltS2 Hlt).
  - assume Heq: x = sqrt2.
    rewrite Heq.
    exact (SNoLe_ref sqrt2).
  - assume Hgt: sqrt2 < x.
    exact (SNoLtLe sqrt2 x Hgt). }

(** establish x < 3 by ruling out x = 3 and 3 < x **)
claim Hxlt3: x < 3.
{ apply (SNoLt_trichotomy_or_impred x 3 HxS H3S (x < 3)).
  - assume Hlt: x < 3. exact Hlt.
  - assume Heq: x = 3.
    apply FalseE.
    set b0 := add_SNo x 1.
    claim Hb0R: b0 :e R.
    { rewrite Heq.
      exact (real_add_SNo 3 real_3 1 real_1). }
    claim HxInStd: x :e open_interval (add_SNo x (minus_SNo 1)) b0.
    { exact (real_in_open_interval_minus1_plus1 x HxR). }
    claim HxStdProp: Rlt (add_SNo x (minus_SNo 1)) x /\ Rlt x b0.
    { exact (SepE2 R (fun z:set => Rlt (add_SNo x (minus_SNo 1)) z /\ Rlt z b0) x HxInStd). }
    claim Hxb0: Rlt x b0.
    { exact (andER (Rlt (add_SNo x (minus_SNo 1)) x) (Rlt x b0) HxStdProp). }
    set U := halfopen_interval_left x b0.
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x b0 HxR Hb0R). }
    claim HxU: x :e U.
    { exact (halfopen_interval_left_leftmem x b0 Hxb0). }
    claim Hne: U :/\: ex17_17_interval_B <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: ex17_17_interval_B = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: ex17_17_interval_B.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U ex17_17_interval_B y Hy). }
      claim HyB: y :e ex17_17_interval_B.
      { exact (binintersectE2 U ex17_17_interval_B y Hy). }
      claim HyUprop: ~(Rlt y x) /\ Rlt y b0.
      { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z b0) y HyU). }
      claim Hnyx: ~(Rlt y x).
      { exact (andEL (~(Rlt y x)) (Rlt y b0) HyUprop). }
      claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
      { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim Hylt3: Rlt y 3.
      { exact (andER (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
      claim Hyltx: Rlt y x.
      { rewrite Heq.
        exact Hylt3. }
      exact (Hnyx Hyltx). }
    exact (Hne Hempty).
  - assume Hgt: 3 < x.
    apply FalseE.
    set b0 := add_SNo x 1.
    claim Hb0R: b0 :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim HxInStd: x :e open_interval (add_SNo x (minus_SNo 1)) b0.
    { exact (real_in_open_interval_minus1_plus1 x HxR). }
    claim HxStdProp: Rlt (add_SNo x (minus_SNo 1)) x /\ Rlt x b0.
    { exact (SepE2 R (fun z:set => Rlt (add_SNo x (minus_SNo 1)) z /\ Rlt z b0) x HxInStd). }
    claim Hxb0: Rlt x b0.
    { exact (andER (Rlt (add_SNo x (minus_SNo 1)) x) (Rlt x b0) HxStdProp). }
    set U := halfopen_interval_left x b0.
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x b0 HxR Hb0R). }
    claim HxU: x :e U.
    { exact (halfopen_interval_left_leftmem x b0 Hxb0). }
    claim Hne: U :/\: ex17_17_interval_B <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: ex17_17_interval_B = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: ex17_17_interval_B.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U ex17_17_interval_B y Hy). }
      claim HyB: y :e ex17_17_interval_B.
      { exact (binintersectE2 U ex17_17_interval_B y Hy). }
      claim HyUprop: ~(Rlt y x) /\ Rlt y b0.
      { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z b0) y HyU). }
      claim Hnyx: ~(Rlt y x).
      { exact (andEL (~(Rlt y x)) (Rlt y b0) HyUprop). }
      claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
      { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim HyR: y :e R.
      { exact (SepE1 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim Hylt3R: Rlt y 3.
      { exact (andER (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      claim Hylt3: y < 3.
      { exact (RltE_lt y 3 Hylt3R). }
      claim H3ltx: 3 < x.
      { exact Hgt. }
      claim Hyltx: y < x.
      { exact (SNoLt_tra y 3 x HyS H3S HxS Hylt3 H3ltx). }
      claim Hyltrx: Rlt y x.
      { exact (RltI y x HyR HxR Hyltx). }
      exact (Hnyx Hyltrx). }
    exact (Hne Hempty). }

prove x :e ex17_17_interval_B_closure_lower.
exact (SepI R (fun z:set => sqrt2 <= z /\ z < 3) x HxR (andI (sqrt2 <= x) (x < 3) Hs2lex Hxlt3)).
Qed.

(** Helper for Exercise 17: {x|sqrt2<=x<3} is contained in the closure of B in the lower limit topology **)
(** LATEX VERSION: If sqrt2<x<3 then x itself witnesses every neighborhood meets B; for x=sqrt2 use a basis element and density of rationals. **)
Theorem ex17_17_closure_B_lower_Supq :
  ex17_17_interval_B_closure_lower c= closure_of R R_lower_limit_topology ex17_17_interval_B.
let x. assume Hx: x :e ex17_17_interval_B_closure_lower.
prove x :e closure_of R R_lower_limit_topology ex17_17_interval_B.
claim HxR: x :e R.
{ exact (SepE1 R (fun z:set => sqrt2 <= z /\ z < 3) x Hx). }
claim HxProp: sqrt2 <= x /\ x < 3.
{ exact (SepE2 R (fun z:set => sqrt2 <= z /\ z < 3) x Hx). }
claim Hs2lex: sqrt2 <= x.
{ exact (andEL (sqrt2 <= x) (x < 3) HxProp). }
claim Hxlt3: x < 3.
{ exact (andER (sqrt2 <= x) (x < 3) HxProp). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim H3R: 3 :e R.
{ exact real_3. }
claim H3S: SNo 3.
{ exact (real_SNo 3 H3R). }

claim Hcl: forall U:set, U :e R_lower_limit_topology -> x :e U -> U :/\: ex17_17_interval_B <> Empty.
{ let U. assume HU: U :e R_lower_limit_topology.
  assume HxU: x :e U.
  prove U :/\: ex17_17_interval_B <> Empty.
  claim Hcases: sqrt2 < x \/ sqrt2 = x.
  { exact (SNoLeE sqrt2 x Hs2S HxS Hs2lex). }
  apply Hcases.
  - assume Hs2ltx: sqrt2 < x.
    set B := ex17_17_interval_B.
    claim Hs2ltxR: Rlt sqrt2 x.
    { exact (RltI sqrt2 x Hs2R HxR Hs2ltx). }
    claim Hxlt3R: Rlt x 3.
    { exact (RltI x 3 HxR H3R Hxlt3). }
    claim Hxconj: Rlt sqrt2 x /\ Rlt x 3.
    { apply andI.
      - exact Hs2ltxR.
      - exact Hxlt3R. }
    claim HxB: x :e B.
    { exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) x HxR Hxconj). }
    assume Hemp: U :/\: B = Empty.
    apply FalseE.
    claim HxUB: x :e U :/\: B.
    { exact (binintersectI U B x HxU HxB). }
    claim HxEmp: x :e Empty.
    { rewrite <- Hemp.
      exact HxUB. }
    exact (EmptyE x HxEmp).
  - assume Hs2eqx: sqrt2 = x.
    set B := ex17_17_interval_B.
    claim Hs2U: sqrt2 :e U.
    { rewrite Hs2eqx.
      exact HxU. }
    claim Hneigh: forall z :e U, exists b :e R_lower_limit_basis, z :e b /\ b c= U.
    { exact (SepE2 (Power R)
                   (fun U0 : set => forall z :e U0, exists b :e R_lower_limit_basis, z :e b /\ b c= U0)
                   U
                   HU). }
    claim Hexb: exists b :e R_lower_limit_basis, sqrt2 :e b /\ b c= U.
    { exact (Hneigh sqrt2 Hs2U). }
    apply Hexb.
    let b. assume Hbpair. apply Hbpair.
    assume HbB: b :e R_lower_limit_basis.
    assume Hbcore: sqrt2 :e b /\ b c= U.
    claim Hs2b: sqrt2 :e b.
    { exact (andEL (sqrt2 :e b) (b c= U) Hbcore). }
    claim HbsubU: b c= U.
    { exact (andER (sqrt2 :e b) (b c= U) Hbcore). }
    claim Hexa: exists a :e R, b :e {halfopen_interval_left a bb|bb :e R}.
    { exact (famunionE R (fun a0 : set => {halfopen_interval_left a0 bb|bb :e R}) b HbB). }
    apply Hexa.
    let a. assume Hapair. apply Hapair.
    assume HaR: a :e R.
    assume HbFam: b :e {halfopen_interval_left a bb|bb :e R}.
    claim Hexbb: exists bb :e R, b = halfopen_interval_left a bb.
    { exact (ReplE R (fun bb0 : set => halfopen_interval_left a bb0) b HbFam). }
    apply Hexbb.
    let bb. assume Hbbpair. apply Hbbpair.
    assume HbbR: bb :e R.
    assume Hbeq: b = halfopen_interval_left a bb.
    claim Hs2Inb: sqrt2 :e halfopen_interval_left a bb.
    { rewrite <- Hbeq.
      exact Hs2b. }
    claim Hs2bprop: ~(Rlt sqrt2 a) /\ Rlt sqrt2 bb.
    { exact (SepE2 R (fun z:set => ~(Rlt z a) /\ Rlt z bb) sqrt2 Hs2Inb). }
    claim Hnots2a: ~(Rlt sqrt2 a).
    { exact (andEL (~(Rlt sqrt2 a)) (Rlt sqrt2 bb) Hs2bprop). }
    claim Hs2ltbb: Rlt sqrt2 bb.
    { exact (andER (~(Rlt sqrt2 a)) (Rlt sqrt2 bb) Hs2bprop). }
    claim HbbS: SNo bb.
    { exact (real_SNo bb HbbR). }
    claim Hs2lt3R: Rlt sqrt2 3.
    { rewrite Hs2eqx.
      exact (RltI x 3 HxR H3R Hxlt3). }
    apply (SNoLt_trichotomy_or_impred bb 3 HbbS H3S (U :/\: B <> Empty)).
    + assume HbbLt3: bb < 3.
      claim HbbLt3R: Rlt bb 3.
      { exact (RltI bb 3 HbbR H3R HbbLt3). }
      apply (rational_dense_between_reals sqrt2 bb Hs2R HbbR Hs2ltbb).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q bb.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q bb) Hqprop). }
      claim Hqltbb: Rlt q bb.
      { exact (andER (Rlt sqrt2 q) (Rlt q bb) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hqlt3: Rlt q 3.
      { exact (Rlt_tra q bb 3 Hqltbb HbbLt3R). }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim Hs2a: Rlt sqrt2 a.
        { exact (Rlt_tra sqrt2 q a Hs2ltq Hqa). }
        exact (Hnots2a Hs2a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInB: q :e B.
      { claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
        { apply andI.
          - exact Hs2ltq.
          - exact Hqlt3. }
        exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp).
    + assume HbbEq3: bb = 3.
      apply (rational_dense_between_reals sqrt2 3 Hs2R H3R Hs2lt3R).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q 3.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim Hqlt3: Rlt q 3.
      { exact (andER (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hqltbb: Rlt q bb.
      { rewrite HbbEq3.
        exact Hqlt3. }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim Hs2a: Rlt sqrt2 a.
        { exact (Rlt_tra sqrt2 q a Hs2ltq Hqa). }
        exact (Hnots2a Hs2a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInB: q :e B.
      { claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
        { apply andI.
          - exact Hs2ltq.
          - exact Hqlt3. }
        exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp).
    + assume H3Ltbb: 3 < bb.
      apply (rational_dense_between_reals sqrt2 3 Hs2R H3R Hs2lt3R).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q 3.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim Hqlt3: Rlt q 3.
      { exact (andER (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim H3LtbbR: Rlt 3 bb.
      { exact (RltI 3 bb H3R HbbR H3Ltbb). }
      claim Hqltbb: Rlt q bb.
      { exact (Rlt_tra q 3 bb Hqlt3 H3LtbbR). }
      claim Hnotqa: ~(Rlt q a).
      { assume Hqa: Rlt q a.
        claim Hs2a: Rlt sqrt2 a.
        { exact (Rlt_tra sqrt2 q a Hs2ltq Hqa). }
        exact (Hnots2a Hs2a). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hqconj: ~(Rlt q a) /\ Rlt q bb.
        { apply andI.
          - exact Hnotqa.
          - exact Hqltbb. }
        exact (SepI R (fun z:set => ~(Rlt z a) /\ Rlt z bb) q HqR Hqconj). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInB: q :e B.
      { claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
        { apply andI.
          - exact Hs2ltq.
          - exact Hqlt3. }
        exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp). }
exact (SepI R (fun x0:set => forall U:set, U :e R_lower_limit_topology -> x0 :e U -> U :/\: ex17_17_interval_B <> Empty) x HxR Hcl).
Qed.

(** Helper for Exercise 17: closure(A) in C topology is contained in {x|0<=x<=sqrt2} **)
(** LATEX VERSION: For x<0 or x>sqrt2, a rational half-open neighborhood of x misses A=(0,sqrt2). **)
Theorem ex17_17_closure_A_C_Subq :
  closure_of R R_C_topology ex17_17_interval_A c= ex17_17_interval_A_closure_C.
let x. assume Hx: x :e closure_of R R_C_topology ex17_17_interval_A.
prove x :e ex17_17_interval_A_closure_C.
set A := ex17_17_interval_A.
claim HxR: x :e R.
{ exact (SepE1 R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: A <> Empty) x Hx). }
claim Hxcl: forall U:set, U :e R_C_topology -> x :e U -> U :/\: A <> Empty.
{ exact (SepE2 R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: A <> Empty) x Hx). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim HBasisC: basis_on R rational_halfopen_intervals_basis.
{ exact (andEL (basis_on R rational_halfopen_intervals_basis)
               (generated_topology R rational_halfopen_intervals_basis <> R_lower_limit_topology)
               ex13_8b_halfopen_rational_basis_topology). }

(** show 0 <= x by excluding x < 0 **)
claim H0lex: 0 <= x.
{ apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (0 <= x)).
  - assume Hxlt0: x < 0.
    apply FalseE.
    claim Hxlt0R: Rlt x 0.
    { exact (RltI x 0 HxR real_0 Hxlt0). }
    apply (rational_dense_between_reals x 0 HxR real_0 Hxlt0R).
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hq2prop: Rlt x q2 /\ Rlt q2 0.
    claim Hxltq2: Rlt x q2.
    { exact (andEL (Rlt x q2) (Rlt q2 0) Hq2prop). }
    claim Hq2lt0: Rlt q2 0.
    { exact (andER (Rlt x q2) (Rlt q2 0) Hq2prop). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    set a0 := add_SNo x (minus_SNo 1).
    claim Ha0R: a0 :e R.
    { exact (real_add_SNo x HxR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
    claim Ha0ltx: Rlt a0 x.
    { claim Hm1R: minus_SNo 1 :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (real_SNo (minus_SNo 1) Hm1R). }
      claim Ha0Def: a0 = add_SNo x (minus_SNo 1).
      { reflexivity. }
      claim Hx0: add_SNo x 0 = x.
      { exact (add_SNo_0R x HxS). }
      claim Hlt: add_SNo x (minus_SNo 1) < add_SNo x 0.
      { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
      claim Ha0ltxS: a0 < x.
      { rewrite Ha0Def.
        rewrite <- Hx0 at 2.
        exact Hlt. }
      exact (RltI a0 x Ha0R HxR Ha0ltxS). }
    apply (rational_dense_between_reals a0 x Ha0R HxR Ha0ltx).
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume Hq1prop: Rlt a0 q1 /\ Rlt q1 x.
    claim Hq1ltx: Rlt q1 x.
    { exact (andER (Rlt a0 q1) (Rlt q1 x) Hq1prop). }
    claim Hq1R: q1 :e R.
    { exact (rational_numbers_in_R q1 Hq1Q). }
    set U := halfopen_interval_left q1 q2.
    claim HUinB: U :e rational_halfopen_intervals_basis.
    { prove U :e rational_halfopen_intervals_basis.
      claim HUfam: U :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
      { exact (ReplI rational_numbers (fun qq:set => halfopen_interval_left q1 qq) q2 Hq2Q). }
      exact (famunionI rational_numbers
                       (fun aa:set => {halfopen_interval_left aa bb|bb :e rational_numbers})
                       q1 U Hq1Q HUfam). }
    claim HUopen: U :e R_C_topology.
    { exact (generated_topology_contains_basis R rational_halfopen_intervals_basis HBasisC U HUinB). }
    claim Hnxq1: ~(Rlt x q1).
    { exact (not_Rlt_sym q1 x Hq1ltx). }
    claim HxU: x :e U.
    { claim Hconj: ~(Rlt x q1) /\ Rlt x q2.
      { apply andI.
        - exact Hnxq1.
        - exact Hxltq2. }
      exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) x HxR Hconj). }
    claim Hne: U :/\: A <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: A = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: A.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U A y Hy). }
      claim HyA: y :e A.
      { exact (binintersectE2 U A y Hy). }
      claim HyUprop: ~(Rlt y q1) /\ Rlt y q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) y HyU). }
      claim Hyltq2: Rlt y q2.
      { exact (andER (~(Rlt y q1)) (Rlt y q2) HyUprop). }
      claim HyAprop: Rlt 0 y /\ Rlt y sqrt2.
      { exact (SepE2 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA). }
      claim H0lty: Rlt 0 y.
      { exact (andEL (Rlt 0 y) (Rlt y sqrt2) HyAprop). }
      claim H0ltq2: Rlt 0 q2.
      { exact (Rlt_tra 0 y q2 H0lty Hyltq2). }
      exact ((not_Rlt_refl 0 real_0) (Rlt_tra 0 q2 0 H0ltq2 Hq2lt0)). }
    exact (Hne Hempty).
  - assume Heq: x = 0.
    rewrite Heq.
    exact (SNoLe_ref 0).
  - assume H0ltx: 0 < x.
    exact (SNoLtLe 0 x H0ltx). }

(** show x <= sqrt2 by excluding sqrt2 < x **)
claim HxleS2: x <= sqrt2.
{ apply (SNoLt_trichotomy_or_impred sqrt2 x Hs2S HxS (x <= sqrt2)).
  - assume Hs2ltx: sqrt2 < x.
    apply FalseE.
    claim Hs2ltxR: Rlt sqrt2 x.
    { exact (RltI sqrt2 x Hs2R HxR Hs2ltx). }
    apply (rational_dense_between_reals sqrt2 x Hs2R HxR Hs2ltxR).
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume Hq1prop: Rlt sqrt2 q1 /\ Rlt q1 x.
    claim Hs2ltq1: Rlt sqrt2 q1.
    { exact (andEL (Rlt sqrt2 q1) (Rlt q1 x) Hq1prop). }
    claim Hq1ltx: Rlt q1 x.
    { exact (andER (Rlt sqrt2 q1) (Rlt q1 x) Hq1prop). }
    claim Hq1R: q1 :e R.
    { exact (rational_numbers_in_R q1 Hq1Q). }
    set x1 := add_SNo x 1.
    claim Hx1R: x1 :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim Hxltx1: x < x1.
    { claim Hlt0: add_SNo x 0 < add_SNo x 1.
      { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
      claim Hx0: add_SNo x 0 = x.
      { exact (add_SNo_0R x HxS). }
      claim Hx1Def: x1 = add_SNo x 1.
      { reflexivity. }
      rewrite <- Hx0 at 1.
      rewrite Hx1Def.
      exact Hlt0. }
    claim Hxltx1R: Rlt x x1.
    { exact (RltI x x1 HxR Hx1R Hxltx1). }
    apply (rational_dense_between_reals x x1 HxR Hx1R Hxltx1R).
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hq2prop: Rlt x q2 /\ Rlt q2 x1.
    claim Hxltq2: Rlt x q2.
    { exact (andEL (Rlt x q2) (Rlt q2 x1) Hq2prop). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    set U := halfopen_interval_left q1 q2.
    claim HUinB: U :e rational_halfopen_intervals_basis.
    { prove U :e rational_halfopen_intervals_basis.
      claim HUfam: U :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
      { exact (ReplI rational_numbers (fun qq:set => halfopen_interval_left q1 qq) q2 Hq2Q). }
      exact (famunionI rational_numbers
                       (fun aa:set => {halfopen_interval_left aa bb|bb :e rational_numbers})
                       q1 U Hq1Q HUfam). }
    claim HUopen: U :e R_C_topology.
    { exact (generated_topology_contains_basis R rational_halfopen_intervals_basis HBasisC U HUinB). }
    claim Hnxq1: ~(Rlt x q1).
    { exact (not_Rlt_sym q1 x Hq1ltx). }
    claim HxU: x :e U.
    { claim Hconj: ~(Rlt x q1) /\ Rlt x q2.
      { apply andI.
        - exact Hnxq1.
        - exact Hxltq2. }
      exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) x HxR Hconj). }
    claim Hne: U :/\: A <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: A = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: A.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U A y Hy). }
      claim HyA: y :e A.
      { exact (binintersectE2 U A y Hy). }
      claim HyUprop: ~(Rlt y q1) /\ Rlt y q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) y HyU). }
      claim Hnyq1: ~(Rlt y q1).
      { exact (andEL (~(Rlt y q1)) (Rlt y q2) HyUprop). }
      claim HyAprop: Rlt 0 y /\ Rlt y sqrt2.
      { exact (SepE2 R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) y HyA). }
      claim Hylts2: Rlt y sqrt2.
      { exact (andER (Rlt 0 y) (Rlt y sqrt2) HyAprop). }
      claim Hyltoq1: Rlt y q1.
      { exact (Rlt_tra y sqrt2 q1 Hylts2 Hs2ltq1). }
      exact (Hnyq1 Hyltoq1). }
    exact (Hne Hempty).
  - assume Heq: sqrt2 = x.
    rewrite <- Heq.
    exact (SNoLe_ref sqrt2).
  - assume HxltS2: x < sqrt2.
    exact (SNoLtLe x sqrt2 HxltS2). }

prove x :e ex17_17_interval_A_closure_C.
exact (SepI R (fun z:set => 0 <= z /\ z <= sqrt2) x HxR (andI (0 <= x) (x <= sqrt2) H0lex HxleS2)).
Qed.

(** Helper for Exercise 17: {x|0<=x<=sqrt2} is contained in closure(A) in C topology **)
(** LATEX VERSION: For x in A it is immediate; for x=0 or x=sqrt2 use rational basis neighborhoods and density of rationals. **)
Theorem ex17_17_closure_A_C_Supq :
  ex17_17_interval_A_closure_C c= closure_of R R_C_topology ex17_17_interval_A.
let x. assume Hx: x :e ex17_17_interval_A_closure_C.
prove x :e closure_of R R_C_topology ex17_17_interval_A.
set A := ex17_17_interval_A.
claim HxR: x :e R.
{ exact (SepE1 R (fun z:set => 0 <= z /\ z <= sqrt2) x Hx). }
claim HxProp: 0 <= x /\ x <= sqrt2.
{ exact (SepE2 R (fun z:set => 0 <= z /\ z <= sqrt2) x Hx). }
claim H0lex: 0 <= x.
{ exact (andEL (0 <= x) (x <= sqrt2) HxProp). }
claim HxleS2: x <= sqrt2.
{ exact (andER (0 <= x) (x <= sqrt2) HxProp). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }

claim Hcl: forall U:set, U :e R_C_topology -> x :e U -> U :/\: A <> Empty.
{ let U. assume HU: U :e R_C_topology.
  assume HxU: x :e U.
  prove U :/\: A <> Empty.
  claim Hcases0: 0 < x \/ 0 = x.
  { exact (SNoLeE 0 x SNo_0 HxS H0lex). }
  apply Hcases0.
  - assume H0ltx: 0 < x.
    claim HcasesS2: x < sqrt2 \/ x = sqrt2.
    { exact (SNoLeE x sqrt2 HxS Hs2S HxleS2). }
    apply HcasesS2.
    + assume HxltS2: x < sqrt2.
      claim H0ltxR: Rlt 0 x.
      { exact (RltI 0 x real_0 HxR H0ltx). }
      claim HxltS2R: Rlt x sqrt2.
      { exact (RltI x sqrt2 HxR Hs2R HxltS2). }
      claim HxA: x :e A.
      { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) x HxR (andI (Rlt 0 x) (Rlt x sqrt2) H0ltxR HxltS2R)). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HxUA: x :e U :/\: A.
      { exact (binintersectI U A x HxU HxA). }
      claim HxEmp: x :e Empty.
      { rewrite <- Hemp.
        exact HxUA. }
      exact (EmptyE x HxEmp).
    + assume HxeqS2: x = sqrt2.
      (** boundary x=sqrt2: use a rational half-open basis neighborhood inside U and pick q with q1<q<sqrt2 or 0<q<sqrt2 **)
      set s2 := sqrt2.
      claim Hs2U: s2 :e U.
      { rewrite <- HxeqS2.
        exact HxU. }
      claim Hneigh: forall z :e U, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U.
      { exact (SepE2 (Power R)
                     (fun U0:set => forall z :e U0, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U0)
                     U
                     HU). }
      claim Hexb: exists b :e rational_halfopen_intervals_basis, s2 :e b /\ b c= U.
      { exact (Hneigh s2 Hs2U). }
      apply Hexb.
      let b. assume Hbpair. apply Hbpair.
      assume HbB: b :e rational_halfopen_intervals_basis.
      assume Hbcore: s2 :e b /\ b c= U.
      claim Hs2b: s2 :e b.
      { exact (andEL (s2 :e b) (b c= U) Hbcore). }
      claim HbsubU: b c= U.
      { exact (andER (s2 :e b) (b c= U) Hbcore). }
      claim Hexq1: exists q1 :e rational_numbers, b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
      { exact (famunionE rational_numbers (fun q1:set => {halfopen_interval_left q1 q2|q2 :e rational_numbers}) b HbB). }
      apply Hexq1.
      let q1. assume Hq1pair. apply Hq1pair.
      assume Hq1Q: q1 :e rational_numbers.
      assume HbFam: b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
      claim Hexq2: exists q2 :e rational_numbers, b = halfopen_interval_left q1 q2.
      { exact (ReplE rational_numbers (fun q2:set => halfopen_interval_left q1 q2) b HbFam). }
      apply Hexq2.
      let q2. assume Hq2pair. apply Hq2pair.
      assume Hq2Q: q2 :e rational_numbers.
      assume Hbeq: b = halfopen_interval_left q1 q2.
      claim Hq1R: q1 :e R.
      { exact (rational_numbers_in_R q1 Hq1Q). }
      claim Hq2R: q2 :e R.
      { exact (rational_numbers_in_R q2 Hq2Q). }
      claim Hq1S: SNo q1.
      { exact (real_SNo q1 Hq1R). }
      claim Hq2S: SNo q2.
      { exact (real_SNo q2 Hq2R). }
      claim Hs2Inb: s2 :e halfopen_interval_left q1 q2.
      { rewrite <- Hbeq.
        exact Hs2b. }
      claim Hs2bprop: ~(Rlt s2 q1) /\ Rlt s2 q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) s2 Hs2Inb). }
      claim Hnots2q1: ~(Rlt s2 q1).
      { exact (andEL (~(Rlt s2 q1)) (Rlt s2 q2) Hs2bprop). }
      claim Hs2ltq2: Rlt s2 q2.
      { exact (andER (~(Rlt s2 q1)) (Rlt s2 q2) Hs2bprop). }
      claim H0ltS2R: Rlt 0 s2.
      { exact (RltI 0 s2 real_0 Hs2R SNoLt_0_sqrt2). }
      (** show q1 < s2 **)
      claim Hq1ltS2R: Rlt q1 s2.
      { apply (SNoLt_trichotomy_or_impred q1 s2 Hq1S Hs2S (Rlt q1 s2)).
        - assume Hlt: q1 < s2.
          exact (RltI q1 s2 Hq1R Hs2R Hlt).
        - assume Heq: q1 = s2.
          apply FalseE.
          claim Hs2Q: s2 :e rational_numbers.
          { rewrite <- Heq.
            exact Hq1Q. }
          exact (sqrt2_not_rational_numbers Hs2Q).
        - assume Hgt: s2 < q1.
          apply FalseE.
          claim Hs2ltq1: Rlt s2 q1.
          { exact (RltI s2 q1 Hs2R Hq1R Hgt). }
          exact (Hnots2q1 Hs2ltq1). }
      claim Hq1ltS2: q1 < s2.
      { exact (RltE_lt q1 s2 Hq1ltS2R). }
      (** choose q and show it lies in U and A **)
      apply (SNoLt_trichotomy_or_impred q1 0 Hq1S SNo_0 (U :/\: A <> Empty)).
      - assume Hq1lt0: q1 < 0.
        claim Hq1lt0R: Rlt q1 0.
        { exact (RltI q1 0 Hq1R real_0 Hq1lt0). }
        apply (rational_dense_between_reals 0 s2 real_0 Hs2R H0ltS2R).
        let q. assume Hqpair. apply Hqpair.
        assume HqQ: q :e rational_numbers.
        assume Hqprop: Rlt 0 q /\ Rlt q s2.
        claim H0ltq: Rlt 0 q.
        { exact (andEL (Rlt 0 q) (Rlt q s2) Hqprop). }
        claim HqltS2: Rlt q s2.
        { exact (andER (Rlt 0 q) (Rlt q s2) Hqprop). }
        claim HqR: q :e R.
        { exact (rational_numbers_in_R q HqQ). }
        claim Hqltq2: Rlt q q2.
        { exact (Rlt_tra q s2 q2 HqltS2 Hs2ltq2). }
        claim Hnotqq1: ~(Rlt q q1).
        { assume Hqq1: Rlt q q1.
          claim Hq0: Rlt q 0.
          { exact (Rlt_tra q q1 0 Hqq1 Hq1lt0R). }
          exact ((not_Rlt_sym 0 q H0ltq) Hq0). }
        claim HqInb: q :e b.
        { rewrite Hbeq.
          exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
        claim HqInU: q :e U.
        { exact (HbsubU q HqInb). }
        claim HqInA: q :e A.
        { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z s2) q HqR (andI (Rlt 0 q) (Rlt q s2) H0ltq HqltS2)). }
        assume Hemp: U :/\: A = Empty.
        apply FalseE.
        claim HqUA: q :e U :/\: A.
        { exact (binintersectI U A q HqInU HqInA). }
        claim HqEmp: q :e Empty.
        { rewrite <- Hemp.
          exact HqUA. }
        exact (EmptyE q HqEmp).
      - assume Hq1eq0: q1 = 0.
        apply (rational_dense_between_reals 0 s2 real_0 Hs2R H0ltS2R).
        let q. assume Hqpair. apply Hqpair.
        assume HqQ: q :e rational_numbers.
        assume Hqprop: Rlt 0 q /\ Rlt q s2.
        claim H0ltq: Rlt 0 q.
        { exact (andEL (Rlt 0 q) (Rlt q s2) Hqprop). }
        claim HqltS2: Rlt q s2.
        { exact (andER (Rlt 0 q) (Rlt q s2) Hqprop). }
        claim HqR: q :e R.
        { exact (rational_numbers_in_R q HqQ). }
        claim Hqltq2: Rlt q q2.
        { exact (Rlt_tra q s2 q2 HqltS2 Hs2ltq2). }
        claim Hnotqq1: ~(Rlt q q1).
        { rewrite Hq1eq0.
          exact (not_Rlt_sym 0 q H0ltq). }
        claim HqInb: q :e b.
        { rewrite Hbeq.
          exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
        claim HqInU: q :e U.
        { exact (HbsubU q HqInb). }
        claim HqInA: q :e A.
        { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z s2) q HqR (andI (Rlt 0 q) (Rlt q s2) H0ltq HqltS2)). }
        assume Hemp: U :/\: A = Empty.
        apply FalseE.
        claim HqUA: q :e U :/\: A.
        { exact (binintersectI U A q HqInU HqInA). }
        claim HqEmp: q :e Empty.
        { rewrite <- Hemp.
          exact HqUA. }
        exact (EmptyE q HqEmp).
      - assume H0ltq1: 0 < q1.
        apply (rational_dense_between_reals q1 s2 Hq1R Hs2R Hq1ltS2R).
        let q. assume Hqpair. apply Hqpair.
        assume HqQ: q :e rational_numbers.
        assume Hqprop: Rlt q1 q /\ Rlt q s2.
        claim Hq1ltq: Rlt q1 q.
        { exact (andEL (Rlt q1 q) (Rlt q s2) Hqprop). }
        claim HqltS2: Rlt q s2.
        { exact (andER (Rlt q1 q) (Rlt q s2) Hqprop). }
        claim HqR: q :e R.
        { exact (rational_numbers_in_R q HqQ). }
        claim H0ltq: Rlt 0 q.
        { exact (Rlt_tra 0 q1 q (RltI 0 q1 real_0 Hq1R H0ltq1) Hq1ltq). }
        claim Hqltq2: Rlt q q2.
        { exact (Rlt_tra q s2 q2 HqltS2 Hs2ltq2). }
        claim Hnotqq1: ~(Rlt q q1).
        { exact (not_Rlt_sym q1 q Hq1ltq). }
        claim HqInb: q :e b.
        { rewrite Hbeq.
          exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
        claim HqInU: q :e U.
        { exact (HbsubU q HqInb). }
        claim HqInA: q :e A.
        { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z s2) q HqR (andI (Rlt 0 q) (Rlt q s2) H0ltq HqltS2)). }
        assume Hemp: U :/\: A = Empty.
        apply FalseE.
        claim HqUA: q :e U :/\: A.
        { exact (binintersectI U A q HqInU HqInA). }
        claim HqEmp: q :e Empty.
        { rewrite <- Hemp.
          exact HqUA. }
        exact (EmptyE q HqEmp).
  - assume H0eqx: 0 = x.
    claim H0U: 0 :e U.
    { rewrite H0eqx.
      exact HxU. }
    claim Hneigh: forall z :e U, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U.
    { exact (SepE2 (Power R)
                   (fun U0:set => forall z :e U0, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U0)
                   U
                   HU). }
    claim Hexb: exists b :e rational_halfopen_intervals_basis, 0 :e b /\ b c= U.
    { exact (Hneigh 0 H0U). }
    apply Hexb.
    let b. assume Hbpair. apply Hbpair.
    assume HbB: b :e rational_halfopen_intervals_basis.
    assume Hbcore: 0 :e b /\ b c= U.
    claim H0b: 0 :e b.
    { exact (andEL (0 :e b) (b c= U) Hbcore). }
    claim HbsubU: b c= U.
    { exact (andER (0 :e b) (b c= U) Hbcore). }
    claim Hexq1: exists q1 :e rational_numbers, b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
    { exact (famunionE rational_numbers (fun q1:set => {halfopen_interval_left q1 q2|q2 :e rational_numbers}) b HbB). }
    apply Hexq1.
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume HbFam: b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
    claim Hexq2: exists q2 :e rational_numbers, b = halfopen_interval_left q1 q2.
    { exact (ReplE rational_numbers (fun q2:set => halfopen_interval_left q1 q2) b HbFam). }
    apply Hexq2.
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hbeq: b = halfopen_interval_left q1 q2.
    claim Hq1R: q1 :e R.
    { exact (rational_numbers_in_R q1 Hq1Q). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    claim H0Inb: 0 :e halfopen_interval_left q1 q2.
    { rewrite <- Hbeq.
      exact H0b. }
    claim H0bprop: ~(Rlt 0 q1) /\ Rlt 0 q2.
    { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) 0 H0Inb). }
    claim H0ltq2: Rlt 0 q2.
    { exact (andER (~(Rlt 0 q1)) (Rlt 0 q2) H0bprop). }
    claim H0ltS2R: Rlt 0 sqrt2.
    { exact (RltI 0 sqrt2 real_0 Hs2R SNoLt_0_sqrt2). }
    apply (SNoLt_trichotomy_or_impred q2 sqrt2 (real_SNo q2 Hq2R) Hs2S (U :/\: A <> Empty)).
    + assume Hq2ltS2: q2 < sqrt2.
      claim Hq2ltS2R: Rlt q2 sqrt2.
      { exact (RltI q2 sqrt2 Hq2R Hs2R Hq2ltS2). }
      apply (rational_dense_between_reals 0 q2 real_0 Hq2R H0ltq2).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q q2.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q q2) Hqprop). }
      claim Hqltq2: Rlt q q2.
      { exact (andER (Rlt 0 q) (Rlt q q2) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqltS2: Rlt q sqrt2.
      { exact (Rlt_tra q q2 sqrt2 Hqltq2 Hq2ltS2R). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hnotqq1: ~(Rlt q q1).
        { assume Hqq1: Rlt q q1.
          claim H0ltq1: Rlt 0 q1.
          { exact (Rlt_tra 0 q q1 H0ltq Hqq1). }
          exact ((andEL (~(Rlt 0 q1)) (Rlt 0 q2) H0bprop) H0ltq1). }
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR (andI (Rlt 0 q) (Rlt q sqrt2) H0ltq HqltS2)). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp).
    + assume Hq2eqS2: q2 = sqrt2.
      apply (rational_dense_between_reals 0 sqrt2 real_0 Hs2R H0ltS2R).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q sqrt2.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim HqltS2: Rlt q sqrt2.
      { exact (andER (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim Hqltq2: Rlt q q2.
      { rewrite Hq2eqS2.
        exact HqltS2. }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hnotqq1: ~(Rlt q q1).
        { assume Hqq1: Rlt q q1.
          claim H0ltq1: Rlt 0 q1.
          { exact (Rlt_tra 0 q q1 H0ltq Hqq1). }
          exact ((andEL (~(Rlt 0 q1)) (Rlt 0 q2) H0bprop) H0ltq1). }
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR (andI (Rlt 0 q) (Rlt q sqrt2) H0ltq HqltS2)). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp).
    + assume Hs2ltq2: sqrt2 < q2.
      apply (rational_dense_between_reals 0 sqrt2 real_0 Hs2R H0ltS2R).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt 0 q /\ Rlt q sqrt2.
      claim H0ltq: Rlt 0 q.
      { exact (andEL (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim HqltS2: Rlt q sqrt2.
      { exact (andER (Rlt 0 q) (Rlt q sqrt2) Hqprop). }
      claim Hs2ltq2R: Rlt sqrt2 q2.
      { exact (RltI sqrt2 q2 Hs2R Hq2R Hs2ltq2). }
      claim Hqltq2: Rlt q q2.
      { exact (Rlt_tra q sqrt2 q2 HqltS2 Hs2ltq2R). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        claim Hnotqq1: ~(Rlt q q1).
        { assume Hqq1: Rlt q q1.
          claim H0ltq1: Rlt 0 q1.
          { exact (Rlt_tra 0 q q1 H0ltq Hqq1). }
          exact ((andEL (~(Rlt 0 q1)) (Rlt 0 q2) H0bprop) H0ltq1). }
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR (andI (~(Rlt q q1)) (Rlt q q2) Hnotqq1 Hqltq2)). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqInA: q :e A.
      { exact (SepI R (fun z:set => Rlt 0 z /\ Rlt z sqrt2) q HqR (andI (Rlt 0 q) (Rlt q sqrt2) H0ltq HqltS2)). }
      assume Hemp: U :/\: A = Empty.
      apply FalseE.
      claim HqUA: q :e U :/\: A.
      { exact (binintersectI U A q HqInU HqInA). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUA. }
      exact (EmptyE q HqEmp). }
exact (SepI R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: A <> Empty) x HxR Hcl).
Qed.

(** Helper for Exercise 17: closure(B) in C topology is contained in {x|sqrt2<=x<3} **)
(** LATEX VERSION: For x<sqrt2 or x>=3, a rational half-open neighborhood of x misses B=(sqrt2,3). **)
Theorem ex17_17_closure_B_C_Subq :
  closure_of R R_C_topology ex17_17_interval_B c= ex17_17_interval_B_closure_lower.
let x. assume Hx: x :e closure_of R R_C_topology ex17_17_interval_B.
prove x :e ex17_17_interval_B_closure_lower.
set B := ex17_17_interval_B.
claim HxR: x :e R.
{ exact (SepE1 R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: B <> Empty) x Hx). }
claim Hxcl: forall U:set, U :e R_C_topology -> x :e U -> U :/\: B <> Empty.
{ exact (SepE2 R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: B <> Empty) x Hx). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim H3R: 3 :e R.
{ exact real_3. }
claim H3S: SNo 3.
{ exact (real_SNo 3 H3R). }
claim HBasisC: basis_on R rational_halfopen_intervals_basis.
{ exact (andEL (basis_on R rational_halfopen_intervals_basis)
               (generated_topology R rational_halfopen_intervals_basis <> R_lower_limit_topology)
               ex13_8b_halfopen_rational_basis_topology). }

(** first show sqrt2 <= x by excluding x < sqrt2 **)
claim Hs2lex: sqrt2 <= x.
{ apply (SNoLt_trichotomy_or_impred x sqrt2 HxS Hs2S (sqrt2 <= x)).
  - assume HxltS2: x < sqrt2.
    apply FalseE.
    claim HxltS2R: Rlt x sqrt2.
    { exact (RltI x sqrt2 HxR Hs2R HxltS2). }
    apply (rational_dense_between_reals x sqrt2 HxR Hs2R HxltS2R).
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hq2prop: Rlt x q2 /\ Rlt q2 sqrt2.
    claim Hxltq2: Rlt x q2.
    { exact (andEL (Rlt x q2) (Rlt q2 sqrt2) Hq2prop). }
    claim Hq2ltS2: Rlt q2 sqrt2.
    { exact (andER (Rlt x q2) (Rlt q2 sqrt2) Hq2prop). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    set a0 := add_SNo x (minus_SNo 1).
    claim Ha0R: a0 :e R.
    { exact (real_add_SNo x HxR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
    claim Ha0ltx: Rlt a0 x.
    { claim Hm1R: minus_SNo 1 :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (real_SNo (minus_SNo 1) Hm1R). }
      claim Ha0Def: a0 = add_SNo x (minus_SNo 1).
      { reflexivity. }
      claim Hx0: add_SNo x 0 = x.
      { exact (add_SNo_0R x HxS). }
      claim Hlt: add_SNo x (minus_SNo 1) < add_SNo x 0.
      { exact (add_SNo_Lt2 x (minus_SNo 1) 0 HxS Hm1S SNo_0 minus_1_lt_0). }
      claim Ha0ltxS: a0 < x.
      { rewrite Ha0Def.
        rewrite <- Hx0 at 2.
        exact Hlt. }
      exact (RltI a0 x Ha0R HxR Ha0ltxS). }
    apply (rational_dense_between_reals a0 x Ha0R HxR Ha0ltx).
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume Hq1prop: Rlt a0 q1 /\ Rlt q1 x.
    claim Hq1ltx: Rlt q1 x.
    { exact (andER (Rlt a0 q1) (Rlt q1 x) Hq1prop). }
    claim Hq1R: q1 :e R.
    { exact (rational_numbers_in_R q1 Hq1Q). }
    set U := halfopen_interval_left q1 q2.
    claim HUinB: U :e rational_halfopen_intervals_basis.
    { prove U :e rational_halfopen_intervals_basis.
      claim HUfam: U :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
      { exact (ReplI rational_numbers (fun qq:set => halfopen_interval_left q1 qq) q2 Hq2Q). }
      exact (famunionI rational_numbers
                       (fun aa:set => {halfopen_interval_left aa bb|bb :e rational_numbers})
                       q1 U Hq1Q HUfam). }
    claim HUopen: U :e R_C_topology.
    { exact (generated_topology_contains_basis R rational_halfopen_intervals_basis HBasisC U HUinB). }
    claim Hnxq1: ~(Rlt x q1).
    { exact (not_Rlt_sym q1 x Hq1ltx). }
    claim HxU: x :e U.
    { claim Hconj: ~(Rlt x q1) /\ Rlt x q2.
      { apply andI.
        - exact Hnxq1.
        - exact Hxltq2. }
      exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) x HxR Hconj). }
    claim Hne: U :/\: B <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: B = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: B.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U B y Hy). }
      claim HyB: y :e B.
      { exact (binintersectE2 U B y Hy). }
      claim HyUprop: ~(Rlt y q1) /\ Rlt y q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) y HyU). }
      claim Hyltq2: Rlt y q2.
      { exact (andER (~(Rlt y q1)) (Rlt y q2) HyUprop). }
      claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
      { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim Hs2lty: Rlt sqrt2 y.
      { exact (andEL (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
      claim Hs2ltq2: Rlt sqrt2 q2.
      { exact (Rlt_tra sqrt2 y q2 Hs2lty Hyltq2). }
      exact ((not_Rlt_refl sqrt2 Hs2R) (Rlt_tra sqrt2 q2 sqrt2 Hs2ltq2 Hq2ltS2)). }
    exact (Hne Hempty).
  - assume Heq: x = sqrt2.
    rewrite Heq.
    exact (SNoLe_ref sqrt2).
  - assume Hgt: sqrt2 < x.
    exact (SNoLtLe sqrt2 x Hgt). }

(** next show x < 3 by excluding x = 3 and 3 < x **)
claim Hxlt3: x < 3.
{ apply (SNoLt_trichotomy_or_impred x 3 HxS H3S (x < 3)).
  - assume Hlt: x < 3. exact Hlt.
  - assume Heq: x = 3.
    apply FalseE.
    set x1 := add_SNo 3 1.
    claim Hx1R: x1 :e R.
    { exact (real_add_SNo 3 real_3 1 real_1). }
    claim H3ltx1: 3 < x1.
    { claim Hlt0: add_SNo 3 0 < add_SNo 3 1.
      { exact (add_SNo_Lt2 3 0 1 H3S SNo_0 SNo_1 SNoLt_0_1). }
      claim Hlt1: 3 < add_SNo 3 1.
      { rewrite <- (add_SNo_0R 3 H3S) at 1.
        exact Hlt0. }
      claim Hx1Def: x1 = add_SNo 3 1.
      { reflexivity. }
      rewrite <- Hx1Def.
      exact Hlt1. }
    claim H3ltx1R: Rlt 3 x1.
    { exact (RltI 3 x1 H3R Hx1R H3ltx1). }
    apply (rational_dense_between_reals 3 x1 H3R Hx1R H3ltx1R).
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hq2prop: Rlt 3 q2 /\ Rlt q2 x1.
    claim H3ltq2: Rlt 3 q2.
    { exact (andEL (Rlt 3 q2) (Rlt q2 x1) Hq2prop). }
    set q1 := 3.
    claim Hq1Def: q1 = 3.
    { reflexivity. }
    claim Hq1Q: q1 :e rational_numbers.
    { rewrite Hq1Def.
      exact three_in_rational_numbers. }
    set U := halfopen_interval_left q1 q2.
    claim HUinB: U :e rational_halfopen_intervals_basis.
    { prove U :e rational_halfopen_intervals_basis.
      claim HUfam: U :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
      { exact (ReplI rational_numbers (fun qq:set => halfopen_interval_left q1 qq) q2 Hq2Q). }
      exact (famunionI rational_numbers
                       (fun aa:set => {halfopen_interval_left aa bb|bb :e rational_numbers})
                       q1 U Hq1Q HUfam). }
    claim HUopen: U :e R_C_topology.
    { exact (generated_topology_contains_basis R rational_halfopen_intervals_basis HBasisC U HUinB). }
    claim HxU: x :e U.
    { rewrite Heq.
      claim Hnot33: ~(Rlt 3 3).
      { exact (not_Rlt_refl 3 H3R). }
      claim Hnot3q1: ~(Rlt 3 q1).
      { rewrite Hq1Def.
        exact Hnot33. }
      claim Hconj: ~(Rlt 3 q1) /\ Rlt 3 q2.
      { apply andI.
        - exact Hnot3q1.
        - exact H3ltq2. }
      exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) 3 H3R Hconj). }
    claim Hne: U :/\: B <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: B = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: B.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U B y Hy). }
      claim HyB: y :e B.
      { exact (binintersectE2 U B y Hy). }
      claim HyUprop: ~(Rlt y q1) /\ Rlt y q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) y HyU). }
      claim Hny3: ~(Rlt y 3).
      { rewrite <- Hq1Def.
        exact (andEL (~(Rlt y q1)) (Rlt y q2) HyUprop). }
      claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
      { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim Hylt3: Rlt y 3.
      { exact (andER (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
      exact (Hny3 Hylt3). }
    exact (Hne Hempty).
  - assume Hgt: 3 < x.
    apply FalseE.
    claim HgtR: Rlt 3 x.
    { exact (RltI 3 x H3R HxR Hgt). }
    apply (rational_dense_between_reals 3 x H3R HxR HgtR).
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume Hq1prop: Rlt 3 q1 /\ Rlt q1 x.
    claim H3ltq1: Rlt 3 q1.
    { exact (andEL (Rlt 3 q1) (Rlt q1 x) Hq1prop). }
    claim Hq1ltx: Rlt q1 x.
    { exact (andER (Rlt 3 q1) (Rlt q1 x) Hq1prop). }
    set x1 := add_SNo x 1.
    claim Hx1R: x1 :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim Hxltx1: x < x1.
    { claim Hlt0: add_SNo x 0 < add_SNo x 1.
      { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
      claim Hx0: add_SNo x 0 = x.
      { exact (add_SNo_0R x HxS). }
      claim Hx1Def: x1 = add_SNo x 1.
      { reflexivity. }
      rewrite <- Hx0 at 1.
      rewrite Hx1Def.
      exact Hlt0. }
    claim Hxltx1R: Rlt x x1.
    { exact (RltI x x1 HxR Hx1R Hxltx1). }
    apply (rational_dense_between_reals x x1 HxR Hx1R Hxltx1R).
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hq2prop: Rlt x q2 /\ Rlt q2 x1.
    claim Hxltq2: Rlt x q2.
    { exact (andEL (Rlt x q2) (Rlt q2 x1) Hq2prop). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    set U := halfopen_interval_left q1 q2.
    claim HUinB: U :e rational_halfopen_intervals_basis.
    { prove U :e rational_halfopen_intervals_basis.
      claim HUfam: U :e {halfopen_interval_left q1 qq|qq :e rational_numbers}.
      { exact (ReplI rational_numbers (fun qq:set => halfopen_interval_left q1 qq) q2 Hq2Q). }
      exact (famunionI rational_numbers
                       (fun aa:set => {halfopen_interval_left aa bb|bb :e rational_numbers})
                       q1 U Hq1Q HUfam). }
    claim HUopen: U :e R_C_topology.
    { exact (generated_topology_contains_basis R rational_halfopen_intervals_basis HBasisC U HUinB). }
    claim Hnxq1: ~(Rlt x q1).
    { exact (not_Rlt_sym q1 x Hq1ltx). }
    claim HxU: x :e U.
    { claim Hconj: ~(Rlt x q1) /\ Rlt x q2.
      { apply andI.
        - exact Hnxq1.
        - exact Hxltq2. }
      exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) x HxR Hconj). }
    claim Hne: U :/\: B <> Empty.
    { exact (Hxcl U HUopen HxU). }
    claim Hempty: U :/\: B = Empty.
    { apply Empty_Subq_eq.
      let y. assume Hy: y :e U :/\: B.
      prove y :e Empty.
      apply FalseE.
      claim HyU: y :e U.
      { exact (binintersectE1 U B y Hy). }
      claim HyB: y :e B.
      { exact (binintersectE2 U B y Hy). }
      claim HyUprop: ~(Rlt y q1) /\ Rlt y q2.
      { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) y HyU). }
      claim Hnyq1: ~(Rlt y q1).
      { exact (andEL (~(Rlt y q1)) (Rlt y q2) HyUprop). }
      claim HyBprop: Rlt sqrt2 y /\ Rlt y 3.
      { exact (SepE2 R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) y HyB). }
      claim Hylt3: Rlt y 3.
      { exact (andER (Rlt sqrt2 y) (Rlt y 3) HyBprop). }
      claim Hyltq1: Rlt y q1.
      { exact (Rlt_tra y 3 q1 Hylt3 H3ltq1). }
      exact (Hnyq1 Hyltq1). }
    exact (Hne Hempty). }

prove x :e ex17_17_interval_B_closure_lower.
exact (SepI R (fun z:set => sqrt2 <= z /\ z < 3) x HxR (andI (sqrt2 <= x) (x < 3) Hs2lex Hxlt3)).
Qed.

(** Helper for Exercise 17: {x|sqrt2<=x<3} is contained in closure(B) in C topology **)
(** LATEX VERSION: For x in B it is immediate; for x=sqrt2 use a rational basis neighborhood and density of rationals above sqrt2. **)
Theorem ex17_17_closure_B_C_Supq :
  ex17_17_interval_B_closure_lower c= closure_of R R_C_topology ex17_17_interval_B.
let x. assume Hx: x :e ex17_17_interval_B_closure_lower.
prove x :e closure_of R R_C_topology ex17_17_interval_B.
set B := ex17_17_interval_B.
claim HxR: x :e R.
{ exact (SepE1 R (fun z:set => sqrt2 <= z /\ z < 3) x Hx). }
claim HxProp: sqrt2 <= x /\ x < 3.
{ exact (SepE2 R (fun z:set => sqrt2 <= z /\ z < 3) x Hx). }
claim Hs2lex: sqrt2 <= x.
{ exact (andEL (sqrt2 <= x) (x < 3) HxProp). }
claim Hxlt3: x < 3.
{ exact (andER (sqrt2 <= x) (x < 3) HxProp). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim Hs2R: sqrt2 :e R.
{ exact sqrt2_in_R. }
claim Hs2S: SNo sqrt2.
{ exact (real_SNo sqrt2 Hs2R). }
claim H3R: 3 :e R.
{ exact real_3. }
claim H3S: SNo 3.
{ exact (real_SNo 3 H3R). }

claim Hcl: forall U:set, U :e R_C_topology -> x :e U -> U :/\: B <> Empty.
{ let U. assume HU: U :e R_C_topology.
  assume HxU: x :e U.
  prove U :/\: B <> Empty.
  claim Hcases: sqrt2 < x \/ sqrt2 = x.
  { exact (SNoLeE sqrt2 x Hs2S HxS Hs2lex). }
  apply Hcases.
  - assume Hs2ltx: sqrt2 < x.
    claim Hs2ltxR: Rlt sqrt2 x.
    { exact (RltI sqrt2 x Hs2R HxR Hs2ltx). }
    claim Hxlt3R: Rlt x 3.
    { exact (RltI x 3 HxR H3R Hxlt3). }
    claim Hxconj: Rlt sqrt2 x /\ Rlt x 3.
    { apply andI.
      - exact Hs2ltxR.
      - exact Hxlt3R. }
    claim HxB: x :e B.
    { exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) x HxR Hxconj). }
    assume Hemp: U :/\: B = Empty.
    apply FalseE.
    claim HxUB: x :e U :/\: B.
    { exact (binintersectI U B x HxU HxB). }
    claim HxEmp: x :e Empty.
    { rewrite <- Hemp.
      exact HxUB. }
    exact (EmptyE x HxEmp).
  - assume Hs2eqx: sqrt2 = x.
    claim Hs2U: sqrt2 :e U.
    { rewrite Hs2eqx.
      exact HxU. }
    claim Hneigh: forall z :e U, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U.
    { exact (SepE2 (Power R)
                   (fun U0:set => forall z :e U0, exists b :e rational_halfopen_intervals_basis, z :e b /\ b c= U0)
                   U
                   HU). }
    claim Hexb: exists b :e rational_halfopen_intervals_basis, sqrt2 :e b /\ b c= U.
    { exact (Hneigh sqrt2 Hs2U). }
    apply Hexb.
    let b. assume Hbpair. apply Hbpair.
    assume HbB: b :e rational_halfopen_intervals_basis.
    assume Hbcore: sqrt2 :e b /\ b c= U.
    claim Hs2b: sqrt2 :e b.
    { exact (andEL (sqrt2 :e b) (b c= U) Hbcore). }
    claim HbsubU: b c= U.
    { exact (andER (sqrt2 :e b) (b c= U) Hbcore). }
    claim Hexq1: exists q1 :e rational_numbers, b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
    { exact (famunionE rational_numbers (fun q1:set => {halfopen_interval_left q1 q2|q2 :e rational_numbers}) b HbB). }
    apply Hexq1.
    let q1. assume Hq1pair. apply Hq1pair.
    assume Hq1Q: q1 :e rational_numbers.
    assume HbFam: b :e {halfopen_interval_left q1 q2|q2 :e rational_numbers}.
    claim Hexq2: exists q2 :e rational_numbers, b = halfopen_interval_left q1 q2.
    { exact (ReplE rational_numbers (fun q2:set => halfopen_interval_left q1 q2) b HbFam). }
    apply Hexq2.
    let q2. assume Hq2pair. apply Hq2pair.
    assume Hq2Q: q2 :e rational_numbers.
    assume Hbeq: b = halfopen_interval_left q1 q2.
    claim Hq1R: q1 :e R.
    { exact (rational_numbers_in_R q1 Hq1Q). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    claim Hs2Inb: sqrt2 :e halfopen_interval_left q1 q2.
    { rewrite <- Hbeq.
      exact Hs2b. }
    claim Hs2bprop: ~(Rlt sqrt2 q1) /\ Rlt sqrt2 q2.
    { exact (SepE2 R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) sqrt2 Hs2Inb). }
    claim Hs2ltq2: Rlt sqrt2 q2.
    { exact (andER (~(Rlt sqrt2 q1)) (Rlt sqrt2 q2) Hs2bprop). }
    claim Hq1neq: q1 <> sqrt2.
    { assume Heq: q1 = sqrt2.
      apply FalseE.
      claim Hs2Q: sqrt2 :e rational_numbers.
      { rewrite <- Heq.
        exact Hq1Q. }
      exact (sqrt2_not_rational_numbers Hs2Q). }
    claim Hq1S: SNo q1.
    { exact (real_SNo q1 Hq1R). }
    claim Hq1ltS2: Rlt q1 sqrt2.
    { apply (SNoLt_trichotomy_or_impred q1 sqrt2 Hq1S Hs2S (Rlt q1 sqrt2)).
      - assume Hlt: q1 < sqrt2.
        exact (RltI q1 sqrt2 Hq1R Hs2R Hlt).
      - assume Heq: q1 = sqrt2.
        apply FalseE.
        exact (Hq1neq Heq).
      - assume Hgt: sqrt2 < q1.
        apply FalseE.
        claim Hs2q1: Rlt sqrt2 q1.
        { exact (RltI sqrt2 q1 Hs2R Hq1R Hgt). }
        exact ((andEL (~(Rlt sqrt2 q1)) (Rlt sqrt2 q2) Hs2bprop) Hs2q1). }
    apply (SNoLt_trichotomy_or_impred q2 3 (real_SNo q2 Hq2R) H3S (U :/\: B <> Empty)).
    + assume Hq2lt3: q2 < 3.
      claim Hq2lt3R: Rlt q2 3.
      { exact (RltI q2 3 Hq2R H3R Hq2lt3). }
      apply (rational_dense_between_reals sqrt2 q2 Hs2R Hq2R Hs2ltq2).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q q2.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q q2) Hqprop). }
      claim Hqltq2: Rlt q q2.
      { exact (andER (Rlt sqrt2 q) (Rlt q q2) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqconjU: ~(Rlt q q1) /\ Rlt q q2.
      { apply andI.
        - exact (not_Rlt_sym q1 q (Rlt_tra q1 sqrt2 q Hq1ltS2 Hs2ltq)).
        - exact Hqltq2. }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR HqconjU). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim Hqlt3: Rlt q 3.
      { exact (Rlt_tra q q2 3 Hqltq2 Hq2lt3R). }
      claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
      { apply andI.
        - exact Hs2ltq.
        - exact Hqlt3. }
      claim HqInB: q :e B.
      { exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp).
    + assume Hq2eq3: q2 = 3.
      apply (rational_dense_between_reals sqrt2 3 Hs2R H3R (RltI sqrt2 3 Hs2R H3R (SNoLeLt_tra sqrt2 x 3 Hs2S HxS H3S Hs2lex Hxlt3))).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q 3.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim Hqlt3: Rlt q 3.
      { exact (andER (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim Hqltq2: Rlt q q2.
      { rewrite Hq2eq3.
        exact Hqlt3. }
      claim HqconjU: ~(Rlt q q1) /\ Rlt q q2.
      { apply andI.
        - exact (not_Rlt_sym q1 q (Rlt_tra q1 sqrt2 q Hq1ltS2 Hs2ltq)).
        - exact Hqltq2. }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR HqconjU). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
      { apply andI.
        - exact Hs2ltq.
        - exact Hqlt3. }
      claim HqInB: q :e B.
      { exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp).
    + assume H3ltq2: 3 < q2.
      apply (rational_dense_between_reals sqrt2 3 Hs2R H3R (RltI sqrt2 3 Hs2R H3R (SNoLeLt_tra sqrt2 x 3 Hs2S HxS H3S Hs2lex Hxlt3))).
      let q. assume Hqpair. apply Hqpair.
      assume HqQ: q :e rational_numbers.
      assume Hqprop: Rlt sqrt2 q /\ Rlt q 3.
      claim Hs2ltq: Rlt sqrt2 q.
      { exact (andEL (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim Hqlt3: Rlt q 3.
      { exact (andER (Rlt sqrt2 q) (Rlt q 3) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim H3ltq2R: Rlt 3 q2.
      { exact (RltI 3 q2 H3R Hq2R H3ltq2). }
      claim Hqltq2: Rlt q q2.
      { exact (Rlt_tra q 3 q2 Hqlt3 H3ltq2R). }
      claim HqconjU: ~(Rlt q q1) /\ Rlt q q2.
      { apply andI.
        - exact (not_Rlt_sym q1 q (Rlt_tra q1 sqrt2 q Hq1ltS2 Hs2ltq)).
        - exact Hqltq2. }
      claim HqInb: q :e b.
      { rewrite Hbeq.
        exact (SepI R (fun z:set => ~(Rlt z q1) /\ Rlt z q2) q HqR HqconjU). }
      claim HqInU: q :e U.
      { exact (HbsubU q HqInb). }
      claim HqconjB: Rlt sqrt2 q /\ Rlt q 3.
      { apply andI.
        - exact Hs2ltq.
        - exact Hqlt3. }
      claim HqInB: q :e B.
      { exact (SepI R (fun z:set => Rlt sqrt2 z /\ Rlt z 3) q HqR HqconjB). }
      assume Hemp: U :/\: B = Empty.
      apply FalseE.
      claim HqUB: q :e U :/\: B.
      { exact (binintersectI U B q HqInU HqInB). }
      claim HqEmp: q :e Empty.
      { rewrite <- Hemp.
        exact HqUB. }
      exact (EmptyE q HqEmp). }
exact (SepI R (fun x0:set => forall U:set, U :e R_C_topology -> x0 :e U -> U :/\: B <> Empty) x HxR Hcl).
Qed.

Theorem ex17_17_closures_of_A_B_in_two_topologies :
  closure_of R R_lower_limit_topology ex17_17_interval_A = ex17_17_interval_A_closure_lower /\
  closure_of R R_C_topology ex17_17_interval_A = ex17_17_interval_A_closure_C /\
  closure_of R R_lower_limit_topology ex17_17_interval_B = ex17_17_interval_B_closure_lower /\
  closure_of R R_C_topology ex17_17_interval_B = ex17_17_interval_B_closure_lower.
prove closure_of R R_lower_limit_topology ex17_17_interval_A = ex17_17_interval_A_closure_lower /\
  closure_of R R_C_topology ex17_17_interval_A = ex17_17_interval_A_closure_C /\
  closure_of R R_lower_limit_topology ex17_17_interval_B = ex17_17_interval_B_closure_lower /\
  closure_of R R_C_topology ex17_17_interval_B = ex17_17_interval_B_closure_lower.
apply andI.
- apply andI.
  - apply andI.
    - (** lower limit closure of A **)
      apply set_ext.
      + let x. assume Hx: x :e closure_of R R_lower_limit_topology ex17_17_interval_A.
        exact (ex17_17_closure_A_lower_Subq x Hx).
      + let x. assume Hx: x :e ex17_17_interval_A_closure_lower.
        exact (ex17_17_closure_A_lower_Supq x Hx).
    - (** C-topology closure of A **)
      apply set_ext.
      + let x. assume Hx: x :e closure_of R R_C_topology ex17_17_interval_A.
        exact (ex17_17_closure_A_C_Subq x Hx).
      + let x. assume Hx: x :e ex17_17_interval_A_closure_C.
        exact (ex17_17_closure_A_C_Supq x Hx).
  - (** lower limit closure of B **)
    apply set_ext.
    + let x. assume Hx: x :e closure_of R R_lower_limit_topology ex17_17_interval_B.
      exact (ex17_17_closure_B_lower_Subq x Hx).
    + let x. assume Hx: x :e ex17_17_interval_B_closure_lower.
      exact (ex17_17_closure_B_lower_Supq x Hx).
- (** C-topology closure of B **)
  apply set_ext.
  + let x. assume Hx: x :e closure_of R R_C_topology ex17_17_interval_B.
    exact (ex17_17_closure_B_C_Subq x Hx).
  + let x. assume Hx: x :e ex17_17_interval_B_closure_lower.
    exact (ex17_17_closure_B_C_Supq x Hx).
Qed.

(** LATEX VERSION: Exercise 18: Determine the closures of the subsets A,B,C,D,E of the ordered square listed in the text. **)
Definition ordsq_A : set := {(inv_nat n,0)|n :e omega :\: {0}}.
Definition ordsq_B : set := {(add_SNo 1 (minus_SNo (inv_nat n)),eps_ 1)|n :e omega :\: {0}}.
Definition ordsq_C : set := {p :e ordered_square|exists x:set, p = (x,0) /\ Rlt 0 x /\ Rlt x 1}.
Definition ordsq_D : set := {p :e ordered_square|exists x:set, p = (x,eps_ 1) /\ Rlt 0 x /\ Rlt x 1}.
Definition ordsq_E : set := {p :e ordered_square|exists y:set, p = (eps_ 1,y) /\ Rlt 0 y /\ Rlt y 1}.

(** from §17 Exercise 18: named corner points and closure description helper sets **)
(** LATEX VERSION: Use points (0,1) and (1,0); closure of E adds the endpoints (eps(1),0) and (eps(1),1). **)
Definition ordsq_p01 : set := (0,1).
Definition ordsq_p10 : set := (1,0).
Definition ordsq_E_closure : set := ordsq_E :\/: {(eps_ 1,0)} :\/: {(eps_ 1,1)}.

Theorem ex17_18_closures_in_ordered_square :
  closure_of ordered_square ordered_square_topology ordsq_A = ordsq_A :\/: {ordsq_p01} /\
  closure_of ordered_square ordered_square_topology ordsq_B = ordsq_B :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_C = ordsq_C :\/: {ordsq_p01} :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_D = ordsq_D :\/: ordsq_C :\/: {ordsq_p01} :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_E = ordsq_E_closure.
prove closure_of ordered_square ordered_square_topology ordsq_A = ordsq_A :\/: {ordsq_p01} /\
  closure_of ordered_square ordered_square_topology ordsq_B = ordsq_B :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_C = ordsq_C :\/: {ordsq_p01} :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_D = ordsq_D :\/: ordsq_C :\/: {ordsq_p01} :\/: {ordsq_p10} /\
  closure_of ordered_square ordered_square_topology ordsq_E = ordsq_E_closure.
(** conjunction is left-associative: ((((A /\ B) /\ C) /\ D) /\ E) **)
apply andI.
- (** (((A /\ B) /\ C) /\ D) **)
  apply andI.
  + (** ((A /\ B) /\ C) **)
    apply andI.
    * (** (A /\ B) **)
      apply andI.
      - (** closure(A) **)
        admit. (** FAIL **)
      - (** closure(B) **)
        admit. (** FAIL **)
    * (** closure(C) **)
      admit. (** FAIL **)
  + (** closure(D) **)
    admit. (** FAIL **)
- (** closure(E) **)
  admit. (** FAIL **)
Qed.

(** from §17 Exercise 19: boundary of a set **)
(** LATEX VERSION: For A c= X, define Bd A = cl(A) ∩ cl(X-A). **)
Definition boundary_of : set -> set -> set -> set := fun X Tx A =>
  closure_of X Tx A :/\: closure_of X Tx (X :\: A).

(** LATEX VERSION: Exercise 19: The boundary of A lies in closure(A) and in closure(X\\A). **)
Theorem ex17_19_boundary_properties : forall X Tx A:set,
  topology_on X Tx ->
  boundary_of X Tx A c= closure_of X Tx A /\
  boundary_of X Tx A c= closure_of X Tx (X :\: A).
let X Tx A.
assume Htop: topology_on X Tx.
prove boundary_of X Tx A c= closure_of X Tx A /\ boundary_of X Tx A c= closure_of X Tx (X :\: A).
(** boundary_of is defined as closure(A) ∩ closure(X\A), so both inclusions follow from binintersect_Subq **)
apply andI.
- prove boundary_of X Tx A c= closure_of X Tx A.
  exact (binintersect_Subq_1 (closure_of X Tx A) (closure_of X Tx (X :\: A))).
- prove boundary_of X Tx A c= closure_of X Tx (X :\: A).
  exact (binintersect_Subq_2 (closure_of X Tx A) (closure_of X Tx (X :\: A))).
Qed.

(** LATEX VERSION: Exercise 20: Boundary of a strip differs between standard and dictionary topologies on ℝ². **)
Theorem ex17_20_boundaries_and_interiors_in_R2 :
  boundary_of (setprod R R) R2_standard_topology ordered_square_open_strip <>
  boundary_of (setprod R R) R2_dictionary_order_topology ordered_square_open_strip.
prove boundary_of (setprod R R) R2_standard_topology ordered_square_open_strip <> boundary_of (setprod R R) R2_dictionary_order_topology ordered_square_open_strip.
admit. (** FAIL **)
Qed.

(** LATEX VERSION: Exercise 21: Kuratowski example in discrete topology gives maximal closure after complement. **)
Theorem ex17_21_Kuratowski_closure_complement_maximal : forall X:set,
  closure_of X (discrete_topology X) (X :\: Empty) = X.
let X.
prove closure_of X (discrete_topology X) (X :\: Empty) = X.
claim Htop: topology_on X (discrete_topology X).
{ exact (discrete_topology_on X). }
claim HXE: X :\: Empty = X.
{ apply set_ext.
  - let x. assume Hx: x :e X :\: Empty.
    exact (setminusE1 X Empty x Hx).
  - let x. assume Hx: x :e X.
    apply setminusI.
    + exact Hx.
    + assume Hfalse: x :e Empty.
      exact (EmptyE x Hfalse). }
(** Rewrite the LHS using HXE **)
rewrite HXE.
(** Now we need to prove closure_of X (discrete_topology X) X = X **)
apply set_ext.
- exact (closure_in_space X (discrete_topology X) X Htop).
- exact (subset_of_closure X (discrete_topology X) X Htop (Subq_ref X)).
Qed.

(** from §18 Definition: continuous map between topological spaces **) 
(** LATEX VERSION: Continuity defined via preimages of open sets being open. **)
Definition preimage_of : set -> set -> set -> set := fun X f V =>
  {x :e X | apply_fun f x :e V}.

(** Helper: preimage of union of a family **)
(** LATEX VERSION: f^{-1}(Union Fam) equals Union of the preimages f^{-1}(V) for V in Fam. **)
Theorem preimage_of_Union : forall X f Fam:set,
  preimage_of X f (Union Fam) = Union {preimage_of X f V|V :e Fam}.
let X f Fam.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f (Union Fam).
  prove x :e Union {preimage_of X f V|V :e Fam}.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e Union Fam) x Hx). }
  claim HfxU: apply_fun f x :e Union Fam.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e Union Fam) x Hx). }
  apply (UnionE_impred Fam (apply_fun f x) HfxU).
  let V. assume HfxV: apply_fun f x :e V.
  assume HVFam: V :e Fam.
  claim HxPre: x :e preimage_of X f V.
  { exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
  exact (UnionI {preimage_of X f V0|V0 :e Fam} x (preimage_of X f V) HxPre
               (ReplI Fam (fun V0:set => preimage_of X f V0) V HVFam)).
- let x. assume Hx: x :e Union {preimage_of X f V|V :e Fam}.
  prove x :e preimage_of X f (Union Fam).
  apply (UnionE_impred {preimage_of X f V|V :e Fam} x Hx).
  let W. assume HxW: x :e W.
  assume HW: W :e {preimage_of X f V|V :e Fam}.
  apply (ReplE_impred Fam (fun V0:set => preimage_of X f V0) W HW).
  let V. assume HVFam: V :e Fam.
  assume HWV: W = preimage_of X f V.
  claim HxPre: x :e preimage_of X f V.
  { rewrite <- HWV.
    exact HxW. }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e V) x HxPre). }
  claim HfxV: apply_fun f x :e V.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x HxPre). }
  claim HfxU: apply_fun f x :e Union Fam.
  { exact (UnionI Fam (apply_fun f x) V HfxV HVFam). }
  exact (SepI X (fun x0:set => apply_fun f x0 :e Union Fam) x HxX HfxU).
Qed.

(** Helper: preimage of binary intersection **)
(** LATEX VERSION: f^{-1}(U∩V) = f^{-1}(U) ∩ f^{-1}(V). **)
Theorem preimage_of_binintersect : forall X f U V:set,
  preimage_of X f (U :/\: V) = (preimage_of X f U) :/\: (preimage_of X f V).
let X f U V.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f (U :/\: V).
  prove x :e (preimage_of X f U) :/\: (preimage_of X f V).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U :/\: V) x Hx). }
  claim HfxUV: apply_fun f x :e U :/\: V.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U :/\: V) x Hx). }
  claim HfxU: apply_fun f x :e U.
  { exact (binintersectE1 U V (apply_fun f x) HfxUV). }
  claim HfxV: apply_fun f x :e V.
  { exact (binintersectE2 U V (apply_fun f x) HfxUV). }
  claim HxPreU: x :e preimage_of X f U.
  { exact (SepI X (fun x0:set => apply_fun f x0 :e U) x HxX HfxU). }
  claim HxPreV: x :e preimage_of X f V.
  { exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
  exact (binintersectI (preimage_of X f U) (preimage_of X f V) x HxPreU HxPreV).
- let x. assume Hx: x :e (preimage_of X f U) :/\: (preimage_of X f V).
  prove x :e preimage_of X f (U :/\: V).
  claim HxPreU: x :e preimage_of X f U.
  { exact (binintersectE1 (preimage_of X f U) (preimage_of X f V) x Hx). }
  claim HxPreV: x :e preimage_of X f V.
  { exact (binintersectE2 (preimage_of X f U) (preimage_of X f V) x Hx). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
  claim HfxU: apply_fun f x :e U.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
  claim HfxV: apply_fun f x :e V.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x HxPreV). }
  claim HfxUV: apply_fun f x :e U :/\: V.
  { exact (binintersectI U V (apply_fun f x) HfxU HfxV). }
  exact (SepI X (fun x0:set => apply_fun f x0 :e U :/\: V) x HxX HfxUV).
Qed.

(** Helper: preimage is monotone under inclusion **)
(** LATEX VERSION: If V subset W then f^{-1}(V) subset f^{-1}(W). **)
Theorem preimage_of_mono : forall X f V W:set,
  V c= W ->
  preimage_of X f V c= preimage_of X f W.
let X f V W.
assume HVW: V c= W.
let x. assume Hx: x :e preimage_of X f V.
prove x :e preimage_of X f W.
claim HxX: x :e X.
{ exact (SepE1 X (fun x0:set => apply_fun f x0 :e V) x Hx). }
claim HfxV: apply_fun f x :e V.
{ exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x Hx). }
claim HfxW: apply_fun f x :e W.
{ exact (HVW (apply_fun f x) HfxV). }
exact (SepI X (fun x0:set => apply_fun f x0 :e W) x HxX HfxW).
Qed.

(** Helper: preimage of binary union **)
(** LATEX VERSION: f^{-1}(U∪V) = f^{-1}(U) ∪ f^{-1}(V). **)
Theorem preimage_of_binunion : forall X f U V:set,
  preimage_of X f (U :\/: V) = (preimage_of X f U) :\/: (preimage_of X f V).
let X f U V.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f (U :\/: V).
  prove x :e (preimage_of X f U) :\/: (preimage_of X f V).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U :\/: V) x Hx). }
  claim HfxUV: apply_fun f x :e U :\/: V.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U :\/: V) x Hx). }
  apply (binunionE U V (apply_fun f x) HfxUV).
  * assume HfxU: apply_fun f x :e U.
    claim HxPreU: x :e preimage_of X f U.
    { exact (SepI X (fun x0:set => apply_fun f x0 :e U) x HxX HfxU). }
    exact (binunionI1 (preimage_of X f U) (preimage_of X f V) x HxPreU).
  * assume HfxV: apply_fun f x :e V.
    claim HxPreV: x :e preimage_of X f V.
    { exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
    exact (binunionI2 (preimage_of X f U) (preimage_of X f V) x HxPreV).
- let x. assume Hx: x :e (preimage_of X f U) :\/: (preimage_of X f V).
  prove x :e preimage_of X f (U :\/: V).
  apply (binunionE (preimage_of X f U) (preimage_of X f V) x Hx).
  * assume HxPreU: x :e preimage_of X f U.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
    claim HfxU: apply_fun f x :e U.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
    claim HfxUV: apply_fun f x :e U :\/: V.
    { exact (binunionI1 U V (apply_fun f x) HfxU). }
    exact (SepI X (fun x0:set => apply_fun f x0 :e U :\/: V) x HxX HfxUV).
  * assume HxPreV: x :e preimage_of X f V.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun f x0 :e V) x HxPreV). }
    claim HfxV: apply_fun f x :e V.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x HxPreV). }
    claim HfxUV: apply_fun f x :e U :\/: V.
    { exact (binunionI2 U V (apply_fun f x) HfxV). }
    exact (SepI X (fun x0:set => apply_fun f x0 :e U :\/: V) x HxX HfxUV).
Qed.

(** Helper: preimage of set difference **)
(** LATEX VERSION: f^{-1}(U\\V) = f^{-1}(U)\\f^{-1}(V). **)
Theorem preimage_of_setminus : forall X f U V:set,
  preimage_of X f (U :\: V) = (preimage_of X f U) :\: (preimage_of X f V).
let X f U V.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f (U :\: V).
  prove x :e (preimage_of X f U) :\: (preimage_of X f V).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U :\: V) x Hx). }
  claim HfxUV: apply_fun f x :e U :\: V.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U :\: V) x Hx). }
  claim HfxU: apply_fun f x :e U.
  { exact (setminusE1 U V (apply_fun f x) HfxUV). }
  claim HfxnotV: apply_fun f x /:e V.
  { exact (setminusE2 U V (apply_fun f x) HfxUV). }
  claim HxPreU: x :e preimage_of X f U.
  { exact (SepI X (fun x0:set => apply_fun f x0 :e U) x HxX HfxU). }
  claim HxnotPreV: x /:e preimage_of X f V.
  { assume HxPreV: x :e preimage_of X f V.
    claim HfxV: apply_fun f x :e V.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x HxPreV). }
    exact (HfxnotV HfxV). }
  exact (setminusI (preimage_of X f U) (preimage_of X f V) x HxPreU HxnotPreV).
- let x. assume Hx: x :e (preimage_of X f U) :\: (preimage_of X f V).
  prove x :e preimage_of X f (U :\: V).
  claim HxPreU: x :e preimage_of X f U.
  { exact (setminusE1 (preimage_of X f U) (preimage_of X f V) x Hx). }
  claim HxnotPreV: x /:e preimage_of X f V.
  { exact (setminusE2 (preimage_of X f U) (preimage_of X f V) x Hx). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
  claim HfxU: apply_fun f x :e U.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U) x HxPreU). }
  claim HfxnotV: apply_fun f x /:e V.
  { assume HfxV: apply_fun f x :e V.
    claim HxPreV: x :e preimage_of X f V.
    { exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
    exact (HxnotPreV HxPreV). }
  claim HfxUV: apply_fun f x :e U :\: V.
  { exact (setminusI U V (apply_fun f x) HfxU HfxnotV). }
  exact (SepI X (fun x0:set => apply_fun f x0 :e U :\: V) x HxX HfxUV).
Qed.

(** Helper: preimage of Empty **)
(** LATEX VERSION: f^{-1}(∅) = ∅. **)
Theorem preimage_of_Empty : forall X f:set,
  preimage_of X f Empty = Empty.
let X f.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f Empty.
  prove x :e Empty.
  claim HfxE: apply_fun f x :e Empty.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e Empty) x Hx). }
  exact (FalseE ((EmptyE (apply_fun f x)) HfxE) (x :e Empty)).
- let x. assume Hx: x :e Empty.
  prove x :e preimage_of X f Empty.
  apply FalseE.
  exact ((EmptyE x) Hx).
Qed.

(** Helper: preimage of whole codomain under a function_on map **)
(** LATEX VERSION: If f maps X into Y then f^{-1}(Y)=X. **)
Theorem preimage_of_whole : forall X Y f:set,
  function_on f X Y ->
  preimage_of X f Y = X.
let X Y f.
assume Hfun: function_on f X Y.
apply set_ext.
- let x. assume Hx: x :e preimage_of X f Y.
  exact (SepE1 X (fun x0:set => apply_fun f x0 :e Y) x Hx).
- let x. assume HxX: x :e X.
  prove x :e preimage_of X f Y.
  exact (SepI X (fun x0:set => apply_fun f x0 :e Y) x HxX (Hfun x HxX)).
Qed.

(** Helper: preimage of complement (relative to codomain) **)
(** LATEX VERSION: f^{-1}(Y\\V) = X\\f^{-1}(V) when f maps X to Y. **)
Theorem preimage_of_complement : forall X Y f V:set,
  function_on f X Y ->
  preimage_of X f (Y :\: V) = X :\: preimage_of X f V.
let X Y f V.
assume Hfun: function_on f X Y.
rewrite (preimage_of_setminus X f Y V).
rewrite (preimage_of_whole X Y f Hfun).
reflexivity.
Qed.

(** Helper: apply_fun for projections **)
(** LATEX VERSION: For p in X×Y, proj1(p)=p0 and proj2(p)=p1. **)
Theorem projection1_apply : forall X Y p:set,
  p :e setprod X Y -> apply_fun (projection1 X Y) p = p 0.
let X Y p.
assume Hp: p :e setprod X Y.
prove apply_fun (projection1 X Y) p = p 0.
prove Eps_i (fun z => (p,z) :e projection1 X Y) = p 0.
claim H1: (p, p 0) :e projection1 X Y.
{ exact (ReplI (setprod X Y) (fun q:set => (q, q 0)) p Hp). }
claim H2: (p, Eps_i (fun z => (p,z) :e projection1 X Y)) :e projection1 X Y.
{ exact (Eps_i_ax (fun z => (p,z) :e projection1 X Y) (p 0) H1). }
apply (ReplE_impred (setprod X Y) (fun q:set => (q, q 0))
                     (p, Eps_i (fun z => (p,z) :e projection1 X Y)) H2).
let q.
assume Hq: q :e setprod X Y.
assume Heq: (p, Eps_i (fun z => (p,z) :e projection1 X Y)) = (q, q 0).
claim Hpq: p = q.
{ rewrite <- (tuple_2_0_eq p (Eps_i (fun z => (p,z) :e projection1 X Y))).
  rewrite <- (tuple_2_0_eq q (q 0)).
  rewrite Heq.
  reflexivity. }
claim Hzq0: Eps_i (fun z => (p,z) :e projection1 X Y) = q 0.
{ rewrite <- (tuple_2_1_eq p (Eps_i (fun z => (p,z) :e projection1 X Y))).
  rewrite <- (tuple_2_1_eq q (q 0)).
  rewrite Heq.
  reflexivity. }
claim Hq0p0: q 0 = p 0.
{ rewrite <- Hpq.
  reflexivity. }
rewrite Hzq0.
exact Hq0p0.
Qed.

Theorem projection2_apply : forall X Y p:set,
  p :e setprod X Y -> apply_fun (projection2 X Y) p = p 1.
let X Y p.
assume Hp: p :e setprod X Y.
prove apply_fun (projection2 X Y) p = p 1.
prove Eps_i (fun z => (p,z) :e projection2 X Y) = p 1.
claim H1: (p, p 1) :e projection2 X Y.
{ exact (ReplI (setprod X Y) (fun q:set => (q, q 1)) p Hp). }
claim H2: (p, Eps_i (fun z => (p,z) :e projection2 X Y)) :e projection2 X Y.
{ exact (Eps_i_ax (fun z => (p,z) :e projection2 X Y) (p 1) H1). }
apply (ReplE_impred (setprod X Y) (fun q:set => (q, q 1))
                     (p, Eps_i (fun z => (p,z) :e projection2 X Y)) H2).
let q.
assume Hq: q :e setprod X Y.
assume Heq: (p, Eps_i (fun z => (p,z) :e projection2 X Y)) = (q, q 1).
claim Hpq: p = q.
{ rewrite <- (tuple_2_0_eq p (Eps_i (fun z => (p,z) :e projection2 X Y))).
  rewrite <- (tuple_2_0_eq q (q 1)).
  rewrite Heq.
  reflexivity. }
claim Hzq1: Eps_i (fun z => (p,z) :e projection2 X Y) = q 1.
{ rewrite <- (tuple_2_1_eq p (Eps_i (fun z => (p,z) :e projection2 X Y))).
  rewrite <- (tuple_2_1_eq q (q 1)).
  rewrite Heq.
  reflexivity. }
claim Hq1p1: q 1 = p 1.
{ rewrite <- Hpq.
  reflexivity. }
rewrite Hzq1.
exact Hq1p1.
Qed.

(** Helper: preimages of opens under projections are rectangles **)
(** LATEX VERSION: proj1^{-1}(U)=U×Y and proj2^{-1}(V)=X×V. **)
Theorem preimage_projection1_rectangle : forall X Y U:set,
  U c= X ->
  preimage_of (setprod X Y) (projection1 X Y) U = rectangle_set U Y.
let X Y U.
assume HUsub: U c= X.
apply set_ext.
- let p. assume Hp: p :e preimage_of (setprod X Y) (projection1 X Y) U.
  prove p :e rectangle_set U Y.
  claim HpXY: p :e setprod X Y.
  { exact (SepE1 (setprod X Y) (fun q => apply_fun (projection1 X Y) q :e U) p Hp). }
  claim HprojU: apply_fun (projection1 X Y) p :e U.
  { exact (SepE2 (setprod X Y) (fun q => apply_fun (projection1 X Y) q :e U) p Hp). }
  claim Happ: apply_fun (projection1 X Y) p = p 0.
  { exact (projection1_apply X Y p HpXY). }
  claim Hp0U: p 0 :e U.
  { rewrite <- Happ.
    exact HprojU. }
  claim Hp1Y: p 1 :e Y.
  { exact (ap1_Sigma X (fun _ : set => Y) p HpXY). }
	  claim Heta: p = (p 0, p 1).
	  { exact (setprod_eta X Y p HpXY). }
	  rewrite Heta.
	  exact (tuple_2_rectangle_set U Y (p 0) (p 1) Hp0U Hp1Y).
- let p. assume Hp: p :e rectangle_set U Y.
  prove p :e preimage_of (setprod X Y) (projection1 X Y) U.
  claim HpUY: p :e setprod U Y.
  { exact Hp. }
  claim Hp0U: p 0 :e U.
  { exact (ap0_Sigma U (fun _ : set => Y) p HpUY). }
  claim Hp1Y: p 1 :e Y.
  { exact (ap1_Sigma U (fun _ : set => Y) p HpUY). }
  claim Hp0X: p 0 :e X.
  { exact (HUsub (p 0) Hp0U). }
	  claim HpXY: p :e setprod X Y.
	  { claim Heta: p = (p 0, p 1).
	    { exact (setprod_eta U Y p HpUY). }
	    rewrite Heta.
	    exact (tuple_2_setprod_by_pair_Sigma X Y (p 0) (p 1) Hp0X Hp1Y). }
  claim Hprop: apply_fun (projection1 X Y) p :e U.
  { claim Happ: apply_fun (projection1 X Y) p = p 0.
    { exact (projection1_apply X Y p HpXY). }
    rewrite Happ.
    exact Hp0U. }
  exact (SepI (setprod X Y) (fun q => apply_fun (projection1 X Y) q :e U) p HpXY Hprop).
Qed.

Theorem preimage_projection2_rectangle : forall X Y V:set,
  V c= Y ->
  preimage_of (setprod X Y) (projection2 X Y) V = rectangle_set X V.
let X Y V.
assume HVsub: V c= Y.
apply set_ext.
- let p. assume Hp: p :e preimage_of (setprod X Y) (projection2 X Y) V.
  prove p :e rectangle_set X V.
  claim HpXY: p :e setprod X Y.
  { exact (SepE1 (setprod X Y) (fun q => apply_fun (projection2 X Y) q :e V) p Hp). }
  claim HprojV: apply_fun (projection2 X Y) p :e V.
  { exact (SepE2 (setprod X Y) (fun q => apply_fun (projection2 X Y) q :e V) p Hp). }
  claim Happ: apply_fun (projection2 X Y) p = p 1.
  { exact (projection2_apply X Y p HpXY). }
  claim Hp1V: p 1 :e V.
  { rewrite <- Happ.
    exact HprojV. }
  claim Hp0X: p 0 :e X.
  { exact (ap0_Sigma X (fun _ : set => Y) p HpXY). }
	  claim Heta: p = (p 0, p 1).
	  { exact (setprod_eta X Y p HpXY). }
	  rewrite Heta.
	  exact (tuple_2_rectangle_set X V (p 0) (p 1) Hp0X Hp1V).
- let p. assume Hp: p :e rectangle_set X V.
  prove p :e preimage_of (setprod X Y) (projection2 X Y) V.
  claim HpXV: p :e setprod X V.
  { exact Hp. }
  claim Hp0X: p 0 :e X.
  { exact (ap0_Sigma X (fun _ : set => V) p HpXV). }
  claim Hp1V: p 1 :e V.
  { exact (ap1_Sigma X (fun _ : set => V) p HpXV). }
  claim Hp1Y: p 1 :e Y.
  { exact (HVsub (p 1) Hp1V). }
	  claim HpXY: p :e setprod X Y.
	  { claim Heta: p = (p 0, p 1).
	    { exact (setprod_eta X V p HpXV). }
	    rewrite Heta.
	    exact (tuple_2_setprod_by_pair_Sigma X Y (p 0) (p 1) Hp0X Hp1Y). }
  claim Hprop: apply_fun (projection2 X Y) p :e V.
  { claim Happ: apply_fun (projection2 X Y) p = p 1.
    { exact (projection2_apply X Y p HpXY). }
    rewrite Happ.
    exact Hp1V. }
  exact (SepI (setprod X Y) (fun q => apply_fun (projection2 X Y) q :e V) p HpXY Hprop).
Qed.

(** from §18 Continuity of a Function: definition of continuity **)
(** LATEX VERSION: A function f: X -> Y is continuous if for each open set V of Y, the inverse image f^{-1}(V) is open in X. **)
(** SUSPICIOUS DEFINITION: `continuous_map` relies on `function_on` via `apply_fun`/`Eps_i`, so it enforces only preimage-openness and codomain membership, not totality of the graph; use `total_function_on` when totality is needed. **)
Definition continuous_map : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty f =>
    topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
    forall V:set, V :e Ty -> preimage_of X f V :e Tx.

(** helper: flip_unit_interval is continuous in the unit interval topology **)
(** NOTE: placed later, after continuity infrastructure **)

(** Helper: extract topology_on X Tx from continuous_map **)
Theorem continuous_map_topology_dom : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f -> topology_on X Tx.
let X Tx Y Ty f.
assume H: continuous_map X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
claim Htops: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft). }
exact (andEL (topology_on X Tx) (topology_on Y Ty) Htops).
Qed.

(** Helper: extract topology_on Y Ty from continuous_map **)
Theorem continuous_map_topology_cod : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f -> topology_on Y Ty.
let X Tx Y Ty f.
assume H: continuous_map X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
claim Htops: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft). }
exact (andER (topology_on X Tx) (topology_on Y Ty) Htops).
Qed.

(** Helper: extract function_on f X Y from continuous_map **)
Theorem continuous_map_function_on : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f -> function_on f X Y.
let X Tx Y Ty f.
assume H: continuous_map X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft).
Qed.

(** Helper: extract the preimage condition from continuous_map **)
Theorem continuous_map_preimage : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f ->
  forall V:set, V :e Ty -> preimage_of X f V :e Tx.
let X Tx Y Ty f.
assume H: continuous_map X Tx Y Ty f.
exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
             (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
             H).
Qed.

(** Helper: continuity is preserved when the domain topology is refined **)
(** LATEX VERSION: If T' is finer than T on X, then any T-continuous map is also T'-continuous. **)
Theorem continuous_map_domain_finer : forall X Tx Tx' Y Ty f:set,
  continuous_map X Tx Y Ty f ->
  topology_on X Tx' ->
  Tx c= Tx' ->
  continuous_map X Tx' Y Ty f.
let X Tx Tx' Y Ty f.
assume Hcont: continuous_map X Tx Y Ty f.
assume HTx': topology_on X Tx'.
assume Hsub: Tx c= Tx'.
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
prove continuous_map X Tx' Y Ty f.
prove topology_on X Tx' /\ topology_on Y Ty /\ function_on f X Y /\
  forall V:set, V :e Ty -> preimage_of X f V :e Tx'.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx'.
    * exact HTy.
  + exact Hfun.
- let V. assume HV: V :e Ty.
  claim Hpre: preimage_of X f V :e Tx.
  { exact (continuous_map_preimage X Tx Y Ty f Hcont V HV). }
  exact (Hsub (preimage_of X f V) Hpre).
Qed.

(** Helper: continuity is preserved when the codomain topology is coarsened **)
(** LATEX VERSION: If T' is coarser than T on Y, then any T-continuous map is also T'-continuous. **)
Theorem continuous_map_codomain_coarser : forall X Tx Y Ty Ty' f:set,
  continuous_map X Tx Y Ty f ->
  topology_on Y Ty' ->
  Ty' c= Ty ->
  continuous_map X Tx Y Ty' f.
let X Tx Y Ty Ty' f.
assume Hcont: continuous_map X Tx Y Ty f.
assume HTy': topology_on Y Ty'.
assume Hsub: Ty' c= Ty.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
prove continuous_map X Tx Y Ty' f.
prove topology_on X Tx /\ topology_on Y Ty' /\ function_on f X Y /\
  forall V:set, V :e Ty' -> preimage_of X f V :e Tx.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx.
    * exact HTy'.
  + exact Hfun.
- let V. assume HV': V :e Ty'.
  claim HV: V :e Ty.
  { exact (Hsub V HV'). }
exact (continuous_map_preimage X Tx Y Ty f Hcont V HV).
Qed.

(** Helper: restrict the range to a subspace containing f(X) **)
Theorem continuous_map_range_restrict : forall X Tx Y Ty f Z0:set,
  continuous_map X Tx Y Ty f ->
  Z0 c= Y ->
  (forall x:set, x :e X -> apply_fun f x :e Z0) ->
  continuous_map X Tx Z0 (subspace_topology Y Ty Z0) f.
let X Tx Y Ty f Z0.
assume Hcont: continuous_map X Tx Y Ty f.
assume HZ0sub: Z0 c= Y.
assume Himg: forall x:set, x :e X -> apply_fun f x :e Z0.
set Tz0 := subspace_topology Y Ty Z0.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hcont). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim HTz0: topology_on Z0 Tz0.
{ exact (subspace_topology_is_topology Y Ty Z0 HTy HZ0sub). }
claim HfunXZ0: function_on f X Z0.
{ let x. assume HxX: x :e X.
  exact (Himg x HxX). }
prove continuous_map X Tx Z0 Tz0 f.
prove topology_on X Tx /\ topology_on Z0 Tz0 /\ function_on f X Z0 /\
      forall B:set, B :e Tz0 -> preimage_of X f B :e Tx.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx.
    * exact HTz0.
  + exact HfunXZ0.
- let B. assume HB: B :e Tz0.
  claim Hex: exists V :e Ty, B = V :/\: Z0.
  { exact (subspace_topologyE Y Ty Z0 B HB). }
  apply Hex.
  let V. assume HVpair.
  claim HV: V :e Ty.
  { exact (andEL (V :e Ty) (B = V :/\: Z0) HVpair). }
  claim HB_eq: B = V :/\: Z0.
  { exact (andER (V :e Ty) (B = V :/\: Z0) HVpair). }
  claim HeqPre: preimage_of X f B = preimage_of X f V.
  { apply set_ext.
    - let x. assume Hx: x :e preimage_of X f B.
      prove x :e preimage_of X f V.
      claim HxX: x :e X.
      { exact (SepE1 X (fun u:set => apply_fun f u :e B) x Hx). }
      claim HfxB: apply_fun f x :e B.
      { exact (SepE2 X (fun u:set => apply_fun f u :e B) x Hx). }
      claim HfxVZ0: apply_fun f x :e V :/\: Z0.
      { rewrite <- HB_eq.
        exact HfxB. }
      claim HfxV: apply_fun f x :e V.
      { exact (binintersectE1 V Z0 (apply_fun f x) HfxVZ0). }
      exact (SepI X (fun u:set => apply_fun f u :e V) x HxX HfxV).
    - let x. assume Hx: x :e preimage_of X f V.
      prove x :e preimage_of X f B.
      claim HxX: x :e X.
      { exact (SepE1 X (fun u:set => apply_fun f u :e V) x Hx). }
      claim HfxV: apply_fun f x :e V.
      { exact (SepE2 X (fun u:set => apply_fun f u :e V) x Hx). }
      claim HfxZ0: apply_fun f x :e Z0.
      { exact (Himg x HxX). }
      claim HfxB: apply_fun f x :e B.
      { rewrite HB_eq.
        exact (binintersectI V Z0 (apply_fun f x) HfxV HfxZ0). }
      exact (SepI X (fun u:set => apply_fun f u :e B) x HxX HfxB). }
  rewrite HeqPre.
  exact (continuous_map_preimage X Tx Y Ty f Hcont V HV).
Qed.

(** Helper: expand the codomain from a subspace. **)
(** LATEX VERSION: If Ty is the subspace topology induced from (Z0,Tz0) on Y⊆Z0, then a continuous map X→Y is also continuous as X→Z0. **)
Theorem continuous_map_range_expand : forall X Tx Y Ty Z0 Tz0 f:set,
  continuous_map X Tx Y Ty f ->
  Y c= Z0 ->
  topology_on Z0 Tz0 ->
  Ty = subspace_topology Z0 Tz0 Y ->
  continuous_map X Tx Z0 Tz0 f.
let X Tx Y Ty Z0 Tz0 f.
assume Hf: continuous_map X Tx Y Ty f.
assume HYZ0: Y c= Z0.
assume HTz0: topology_on Z0 Tz0.
assume HTy_eq: Ty = subspace_topology Z0 Tz0 Y.
prove continuous_map X Tx Z0 Tz0 f.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hf). }
claim HpreY: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
claim Htmp: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
claim HfunXY: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty)
               (function_on f X Y)
               Htmp). }
claim HfunXZ0: function_on f X Z0.
{ let x. assume HxX: x :e X.
  exact (HYZ0 (apply_fun f x) (HfunXY x HxX)). }
prove (topology_on X Tx /\ topology_on Z0 Tz0 /\ function_on f X Z0) /\
      forall W:set, W :e Tz0 -> preimage_of X f W :e Tx.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx.
    * exact HTz0.
  + exact HfunXZ0.
- let W. assume HW: W :e Tz0.
  set B := W :/\: Y.
  claim HB_inTy: B :e Ty.
  { rewrite HTy_eq.
    claim HBpow: B :e Power Y.
    { apply PowerI.
      let y. assume HyB: y :e B.
      exact (binintersectE2 W Y y HyB). }
    claim Hex: exists Z :e Tz0, B = Z :/\: Y.
    { witness W.
      apply andI.
      - exact HW.
      - reflexivity. }
    exact (SepI (Power Y) (fun U0:set => exists V :e Tz0, U0 = V :/\: Y) B HBpow Hex). }
  claim HpreEq: preimage_of X f W = preimage_of X f B.
  { apply set_ext.
    - let x. assume Hx: x :e preimage_of X f W.
      prove x :e preimage_of X f B.
      claim HxX: x :e X.
      { exact (SepE1 X (fun u:set => apply_fun f u :e W) x Hx). }
      claim HfxW: apply_fun f x :e W.
      { exact (SepE2 X (fun u:set => apply_fun f u :e W) x Hx). }
      claim HfxY: apply_fun f x :e Y.
      { exact (HfunXY x HxX). }
      claim HfxB: apply_fun f x :e B.
      { exact (binintersectI W Y (apply_fun f x) HfxW HfxY). }
      exact (SepI X (fun u:set => apply_fun f u :e B) x HxX HfxB).
    - let x. assume Hx: x :e preimage_of X f B.
      prove x :e preimage_of X f W.
      claim HxX: x :e X.
      { exact (SepE1 X (fun u:set => apply_fun f u :e B) x Hx). }
      claim HfxB: apply_fun f x :e B.
      { exact (SepE2 X (fun u:set => apply_fun f u :e B) x Hx). }
      claim HfxW: apply_fun f x :e W.
      { exact (binintersectE1 W Y (apply_fun f x) HfxB). }
      exact (SepI X (fun u:set => apply_fun f u :e W) x HxX HfxW). }
  rewrite HpreEq.
  exact (HpreY B HB_inTy).
Qed.

(** Helper: subbasis criterion for continuity into generated_topology_from_subbasis **)
(** LATEX VERSION: If preimages of all subbasis elements are open, then f is continuous for the topology generated by the subbasis. **)
Theorem continuous_map_from_subbasis : forall X Tx Y S f:set,
  topology_on X Tx ->
  function_on f X Y ->
  subbasis_on Y S ->
  (forall s:set, s :e S -> preimage_of X f s :e Tx) ->
  continuous_map X Tx Y (generated_topology_from_subbasis Y S) f.
let X Tx Y S f.
assume HTx: topology_on X Tx.
assume Hfun: function_on f X Y.
assume HS: subbasis_on Y S.
assume HpreS: forall s:set, s :e S -> preimage_of X f s :e Tx.
set Ty := generated_topology_from_subbasis Y S.
claim HTy: topology_on Y Ty.
{ exact (topology_from_subbasis_is_topology Y S HS). }
(** Define Tpre as sets whose preimages are open. **)
set TpreFam : set := {U0 :e Power Y| preimage_of X f U0 :e Tx}.
claim HTpre: topology_on Y TpreFam.
{ claim HsubPow: TpreFam c= Power Y.
  { let U. assume HU: U :e TpreFam.
    exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
  claim Hempty: Empty :e TpreFam.
  { apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) Empty (Empty_In_Power Y)).
    rewrite (preimage_of_Empty X f).
    exact (topology_has_empty X Tx HTx). }
  claim HYin: Y :e TpreFam.
  { apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) Y (Self_In_Power Y)).
    rewrite (preimage_of_whole X Y f Hfun).
    exact (topology_has_X X Tx HTx). }
  claim Hunion: forall UFam :e Power TpreFam, Union UFam :e TpreFam.
  { let UFam. assume HUFamPow: UFam :e Power TpreFam.
    claim HUFsub: UFam c= TpreFam.
    { exact (PowerE TpreFam UFam HUFamPow). }
    claim HUnionPowY: Union UFam :e Power Y.
    { apply PowerI.
      let y. assume Hy: y :e Union UFam.
      apply (UnionE_impred UFam y Hy).
      let U. assume HyU: y :e U. assume HUUF: U :e UFam.
      claim HUTpre: U :e TpreFam.
      { exact (HUFsub U HUUF). }
      claim HUPowY: U :e Power Y.
      { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HUTpre). }
      exact (PowerE Y U HUPowY y HyU). }
    apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) (Union UFam) HUnionPowY).
    rewrite (preimage_of_Union X f UFam).
    set PreFam : set := {preimage_of X f U|U :e UFam}.
    claim HPreFamSub: PreFam c= Tx.
    { let W. assume HW: W :e PreFam.
      apply (ReplE_impred UFam (fun U0:set => preimage_of X f U0) W HW (W :e Tx)).
      let U. assume HUUF: U :e UFam. assume HWU: W = preimage_of X f U.
      claim HUTpre: U :e TpreFam.
      { exact (HUFsub U HUUF). }
      claim HpreU: preimage_of X f U :e Tx.
      { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HUTpre). }
      rewrite HWU.
      exact HpreU. }
    exact (topology_union_closed X Tx PreFam HTx HPreFamSub). }
  claim Hinter: forall U :e TpreFam, forall V :e TpreFam, U :/\: V :e TpreFam.
  { let U. assume HU: U :e TpreFam.
    let V. assume HV: V :e TpreFam.
    claim HUPow: U :e Power Y.
    { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
    claim HVPow: V :e Power Y.
    { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HV). }
    claim HUVPow: U :/\: V :e Power Y.
    { exact (binintersect_Power Y U V HUPow HVPow). }
    apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) (U :/\: V) HUVPow).
    rewrite (preimage_of_binintersect X f U V).
    claim HpreU: preimage_of X f U :e Tx.
    { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
    claim HpreV: preimage_of X f V :e Tx.
    { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HV). }
    exact (topology_binintersect_closed X Tx (preimage_of X f U) (preimage_of X f V) HTx HpreU HpreV). }
  claim HTpre_def: topology_on Y TpreFam =
    (TpreFam c= Power Y
     /\ Empty :e TpreFam
     /\ Y :e TpreFam
     /\ (forall UFam :e Power TpreFam, Union UFam :e TpreFam)
     /\ (forall U :e TpreFam, forall V :e TpreFam, U :/\: V :e TpreFam)).
  { reflexivity. }
  rewrite HTpre_def.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        - exact HsubPow.
        - exact Hempty.
      * exact HYin.
    + exact Hunion.
  - exact Hinter. }
(** S is contained in Tpre, so generated topology is contained in Tpre by minimality. **)
claim HSsub: S c= TpreFam.
{ let s. assume Hs: s :e S.
  prove s :e TpreFam.
  claim HSsubPow: S c= Power Y.
  { exact (andEL (S c= Power Y) (Union S = Y) HS). }
  claim HsPowY: s :e Power Y.
  { exact (HSsubPow s Hs). }
  exact (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) s HsPowY (HpreS s Hs)). }
claim Hmin: Ty c= TpreFam.
{ exact (topology_generated_by_basis_is_minimal Y S TpreFam HS HTpre HSsub). }
prove continuous_map X Tx Y Ty f.
prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\ forall V:set, V :e Ty -> preimage_of X f V :e Tx.
apply andI.
- prove (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y).
  apply andI.
  + prove topology_on X Tx /\ topology_on Y Ty.
    apply andI.
    * exact HTx.
    * exact HTy.
  + exact Hfun.
- let V. assume HV: V :e Ty.
  prove preimage_of X f V :e Tx.
  claim HVTpre: V :e TpreFam.
  { exact (Hmin V HV). }
  exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HVTpre).
Qed.

(** from §18 Continuity of a Function: continuous maps are functions defined on all points **)
(** LATEX VERSION: Continuity is defined for functions f:X->Y; in formalization we often require totality of the graph explicitly. **)
(** Helper: continuous_map variant with totality of the graph **)
Definition continuous_map_total : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty f =>
    topology_on X Tx /\ topology_on Y Ty /\ total_function_on f X Y /\
    forall V:set, V :e Ty -> preimage_of X f V :e Tx.

(** Helper: extract topology_on X Tx from continuous_map_total **)
Theorem continuous_map_total_topology_dom : forall X Tx Y Ty f:set,
  continuous_map_total X Tx Y Ty f -> topology_on X Tx.
let X Tx Y Ty f.
assume H: continuous_map_total X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
claim Htops: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (total_function_on f X Y) Hleft). }
exact (andEL (topology_on X Tx) (topology_on Y Ty) Htops).
Qed.

(** Helper: extract topology_on Y Ty from continuous_map_total **)
Theorem continuous_map_total_topology_cod : forall X Tx Y Ty f:set,
  continuous_map_total X Tx Y Ty f -> topology_on Y Ty.
let X Tx Y Ty f.
assume H: continuous_map_total X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
claim Htops: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (total_function_on f X Y) Hleft). }
exact (andER (topology_on X Tx) (topology_on Y Ty) Htops).
Qed.

(** Helper: extract total_function_on f X Y from continuous_map_total **)
Theorem continuous_map_total_total_function_on : forall X Tx Y Ty f:set,
  continuous_map_total X Tx Y Ty f -> total_function_on f X Y.
let X Tx Y Ty f.
assume H: continuous_map_total X Tx Y Ty f.
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               H). }
exact (andER (topology_on X Tx /\ topology_on Y Ty) (total_function_on f X Y) Hleft).
Qed.

(** Helper: extract the preimage condition from continuous_map_total **)
Theorem continuous_map_total_preimage : forall X Tx Y Ty f:set,
  continuous_map_total X Tx Y Ty f ->
  forall V:set, V :e Ty -> preimage_of X f V :e Tx.
let X Tx Y Ty f.
assume H: continuous_map_total X Tx Y Ty f.
exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
             (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
             H).
Qed.

(** Helper: continuous_map_total implies continuous_map **)
Theorem continuous_map_total_imp : forall X Tx Y Ty f:set,
  continuous_map_total X Tx Y Ty f -> continuous_map X Tx Y Ty f.
let X Tx Y Ty f.
assume H: continuous_map_total X Tx Y Ty f.
prove continuous_map X Tx Y Ty f.
prove ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y) /\
  (forall V:set, V :e Ty -> preimage_of X f V :e Tx).
claim Hcore: ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y) /\
  (forall V:set, V :e Ty -> preimage_of X f V :e Tx).
{ exact H. }
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hcore). }
claim Hright: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hcore). }
claim Htops: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (total_function_on f X Y) Hleft). }
claim Htot: total_function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (total_function_on f X Y) Hleft). }
claim Hfun: function_on f X Y.
{ exact (total_function_on_function_on f X Y Htot). }
apply andI.
- apply andI.
  + exact Htops.
  + exact Hfun.
- exact Hright.
Qed.

(** Helper: constant maps are continuous **)
Theorem const_fun_continuous : forall X Tx Y Ty x:set,
  topology_on X Tx -> topology_on Y Ty -> x :e Y ->
  continuous_map X Tx Y Ty (const_fun X x).
let X Tx Y Ty x.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HxY: x :e Y.
prove continuous_map X Tx Y Ty (const_fun X x).
prove topology_on X Tx /\ topology_on Y Ty /\ function_on (const_fun X x) X Y /\
      forall V:set, V :e Ty -> preimage_of X (const_fun X x) V :e Tx.
apply andI.
- (** left: (topology_on X Tx /\ topology_on Y Ty) /\ function_on ... **)
  apply andI.
  + apply andI.
    * exact HTx.
    * exact HTy.
  + (** function_on **)
    let a. assume HaX: a :e X.
    prove apply_fun (const_fun X x) a :e Y.
    claim Happ: apply_fun (const_fun X x) a = x.
    { exact (const_fun_apply X x a HaX). }
    rewrite Happ.
    exact HxY.
- (** preimage condition **)
  let V. assume HV: V :e Ty.
  claim Hcases: x :e V \/ x /:e V.
  { exact (xm (x :e V)). }
  apply (Hcases (preimage_of X (const_fun X x) V :e Tx)).
  + (** case x ∈ V: preimage = X **)
    assume HxV: x :e V.
    claim Heq: preimage_of X (const_fun X x) V = X.
    { apply set_ext.
      - let a. assume Ha: a :e preimage_of X (const_fun X x) V.
        prove a :e X.
        apply (SepE X (fun u => apply_fun (const_fun X x) u :e V) a Ha).
        assume HaX. assume _. exact HaX.
      - let a. assume HaX: a :e X.
        prove a :e preimage_of X (const_fun X x) V.
        prove a :e {u :e X | apply_fun (const_fun X x) u :e V}.
        apply (SepI X (fun u => apply_fun (const_fun X x) u :e V) a HaX).
        claim Happ: apply_fun (const_fun X x) a = x.
        { exact (const_fun_apply X x a HaX). }
        rewrite Happ.
        exact HxV.
    }
    rewrite Heq.
    exact (topology_has_X X Tx HTx).
  + (** case x ∉ V: preimage = Empty **)
    assume HxVn: x /:e V.
    claim Heq: preimage_of X (const_fun X x) V = Empty.
    { apply set_ext.
      - let a. assume Ha: a :e preimage_of X (const_fun X x) V.
        prove a :e Empty.
        apply FalseE.
        apply (SepE X (fun u => apply_fun (const_fun X x) u :e V) a Ha).
        assume HaX. assume Hav.
        claim Happ: apply_fun (const_fun X x) a = x.
        { exact (const_fun_apply X x a HaX). }
        claim HxV: x :e V.
        { rewrite <- Happ. exact Hav. }
        exact (HxVn HxV).
      - let a. assume HaE: a :e Empty.
        prove a :e preimage_of X (const_fun X x) V.
        apply FalseE.
        exact (EmptyE a HaE).
    }
    rewrite Heq.
    exact (topology_has_empty X Tx HTx).
Qed.

(** Helper: constant maps are continuous (total variant) **)
Theorem const_fun_continuous_total : forall X Tx Y Ty x:set,
  topology_on X Tx -> topology_on Y Ty -> x :e Y ->
  continuous_map_total X Tx Y Ty (const_fun X x).
let X Tx Y Ty x.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HxY: x :e Y.
prove continuous_map_total X Tx Y Ty (const_fun X x).
prove ((topology_on X Tx /\ topology_on Y Ty) /\ total_function_on (const_fun X x) X Y) /\
  forall V:set, V :e Ty -> preimage_of X (const_fun X x) V :e Tx.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx.
    * exact HTy.
  + exact (const_fun_total_function_on X Y x HxY).
- claim Hc: continuous_map X Tx Y Ty (const_fun X x).
  { exact (const_fun_continuous X Tx Y Ty x HTx HTy HxY). }
  exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on (const_fun X x) X Y)
               (forall V:set, V :e Ty -> preimage_of X (const_fun X x) V :e Tx)
               Hc).
Qed.

(** Helper: continuity preserves closed sets **)
Theorem continuous_preserves_closed : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f ->
  forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C).
let X Tx Y Ty f.
assume Hcont: continuous_map X Tx Y Ty f.
claim Hpreimg: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hcont). }
claim Hleft: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hcont). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (topology_on Y Ty)
               (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft)). }
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on X Tx) (topology_on Y Ty)
               (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft)). }
claim Hf: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hleft). }
let C. assume HC: closed_in Y Ty C.
claim Hright: C c= Y /\ exists U :e Ty, C = Y :\: U.
{ exact (andER (topology_on Y Ty) (C c= Y /\ exists U :e Ty, C = Y :\: U) HC). }
claim HCsub: C c= Y.
{ exact (andEL (C c= Y) (exists U :e Ty, C = Y :\: U) Hright). }
claim HU: exists U :e Ty, C = Y :\: U.
{ exact (andER (C c= Y) (exists U :e Ty, C = Y :\: U) Hright). }
apply HU.
let U. assume HU.
apply HU.
assume HUTy: U :e Ty.
assume HCeq: C = Y :\: U.
prove closed_in X Tx (preimage_of X f C).
prove topology_on X Tx /\ (preimage_of X f C c= X /\ exists V :e Tx, preimage_of X f C = X :\: V).
apply andI.
- exact HTx.
- prove preimage_of X f C c= X /\ exists V :e Tx, preimage_of X f C = X :\: V.
  apply andI.
  + prove preimage_of X f C c= X.
    let x. assume Hx: x :e preimage_of X f C.
    prove x :e X.
    exact (SepE1 X (fun x => apply_fun f x :e C) x Hx).
  + prove exists V :e Tx, preimage_of X f C = X :\: V.
    witness (preimage_of X f U).
    apply andI.
  + exact (Hpreimg U HUTy).
  + prove preimage_of X f C = X :\: preimage_of X f U.
    rewrite HCeq.
    prove preimage_of X f (Y :\: U) = X :\: preimage_of X f U.
    apply set_ext.
    * let x. assume Hx: x :e preimage_of X f (Y :\: U).
      prove x :e X :\: preimage_of X f U.
      apply (SepE X (fun x => apply_fun f x :e Y :\: U) x Hx).
      assume HxX: x :e X.
      assume Hfx: apply_fun f x :e Y :\: U.
      apply (setminusE Y U (apply_fun f x) Hfx).
      assume HfxY: apply_fun f x :e Y.
      assume HfxU: apply_fun f x /:e U.
      apply setminusI.
      { exact HxX. }
      { prove x /:e preimage_of X f U.
        assume Hxpre: x :e preimage_of X f U.
        apply (SepE X (fun x => apply_fun f x :e U) x Hxpre).
        assume _. assume HfxU2: apply_fun f x :e U.
        exact (HfxU HfxU2). }
    * let x. assume Hx: x :e X :\: preimage_of X f U.
      prove x :e preimage_of X f (Y :\: U).
      apply (setminusE X (preimage_of X f U) x Hx).
      assume HxX: x :e X.
      assume Hxpre: x /:e preimage_of X f U.
      prove x :e {x :e X | apply_fun f x :e Y :\: U}.
      apply SepI.
      { exact HxX. }
      { prove apply_fun f x :e Y :\: U.
        apply setminusI.
        { exact (Hf x HxX). }
        { prove apply_fun f x /:e U.
          assume HfxU: apply_fun f x :e U.
          claim Hxpre2: x :e preimage_of X f U.
          { exact (SepI X (fun x => apply_fun f x :e U) x HxX HfxU). }
          exact (Hxpre Hxpre2). } }
Qed.

(** Helper: continuity local neighborhood characterization **)
Theorem continuous_local_neighborhood : forall X Tx Y Ty f:set,
  topology_on X Tx -> topology_on Y Ty -> function_on f X Y ->
  (forall V:set, V :e Ty -> preimage_of X f V :e Tx) ->
  forall x:set, x :e X ->
    forall V:set, V :e Ty -> apply_fun f x :e V ->
      exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V.
let X Tx Y Ty f.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hf: function_on f X Y.
assume Hcont: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
let x. assume Hx: x :e X.
let V. assume HV: V :e Ty.
assume Hfx: apply_fun f x :e V.
witness (preimage_of X f V).
apply and3I.
- exact (Hcont V HV).
- prove x :e preimage_of X f V.
  prove x :e {x :e X | apply_fun f x :e V}.
  exact (SepI X (fun x => apply_fun f x :e V) x Hx Hfx).
- let u. assume Hu: u :e preimage_of X f V.
  prove apply_fun f u :e V.
  apply (SepE X (fun x => apply_fun f x :e V) u Hu).
  assume _. assume H. exact H.
Qed.

(** continuity at a point **)
(** LATEX VERSION: f is continuous at x if for every neighborhood V of f(x), there exists neighborhood U of x with f(U)⊆V. **)
(** FIXED: Formalized using open-set neighborhood criterion in the standard topology on R. **)
Definition continuous_at : set -> set -> prop := fun f x =>
  function_on f R R /\ x :e R /\
  forall V:set, V :e R_standard_topology -> apply_fun f x :e V ->
    exists U:set, U :e R_standard_topology /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V.

(** from §18 Theorem 18.1: equivalent formulations of continuity **) 
(** LATEX VERSION: Equivalent characterizations of continuity: open-preimage, closed-preimage, neighborhood criterion. **)
Theorem continuity_equiv_forms : forall X Tx Y Ty f:set,
  topology_on X Tx -> topology_on Y Ty ->
  (continuous_map X Tx Y Ty f <->
    function_on f X Y /\
    (forall V:set, V :e Ty -> preimage_of X f V :e Tx) /\
    (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C)) /\
    (forall x:set, x :e X ->
       forall V:set, V :e Ty -> apply_fun f x :e V ->
         exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V)).
let X Tx Y Ty f.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map X Tx Y Ty f <->
    function_on f X Y /\
    (forall V:set, V :e Ty -> preimage_of X f V :e Tx) /\
    (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C)) /\
    (forall x:set, x :e X ->
       forall V:set, V :e Ty -> apply_fun f x :e V ->
         exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V).
apply iffI.
- (** Forward direction: continuous_map implies all three conditions **)
  assume Hf: continuous_map X Tx Y Ty f.
  prove function_on f X Y /\
        (forall V:set, V :e Ty -> preimage_of X f V :e Tx) /\
        (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C)) /\
        (forall x:set, x :e X ->
           forall V:set, V :e Ty -> apply_fun f x :e V ->
             exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V).
  (** Extract components from continuous_map definition **)
  claim Hpreimage: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  { exact (andER (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                 (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                 Hf). }
  claim Hfun: function_on f X Y.
  { exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
                 (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                        (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                        Hf)). }
  (** Build (((Hfun /\ Hpreimage) /\ closed-preimage) /\ neighborhood) **)
  apply andI.
  - apply andI.
    + apply andI.
      * exact Hfun.
      * exact Hpreimage.
    + exact (continuous_preserves_closed X Tx Y Ty f Hf).
  - exact (continuous_local_neighborhood X Tx Y Ty f HTx HTy Hfun Hpreimage).
- (** Backward direction: three conditions imply continuous_map **)
  assume Hconds.
  prove continuous_map X Tx Y Ty f.
	  (** Extract function_on and preimage condition from Hconds, a left-associative conjunction: (((A /\ B) /\ C) /\ D). **)
  claim Habc:
    (function_on f X Y /\ (forall V:set, V :e Ty -> preimage_of X f V :e Tx)) /\
    (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C)).
  { exact (andEL (((function_on f X Y /\ (forall V:set, V :e Ty -> preimage_of X f V :e Tx)) /\
                   (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C))))
                 (forall x:set, x :e X ->
                    forall V:set, V :e Ty -> apply_fun f x :e V ->
                      exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V)
                 Hconds). }
  claim Hab:
    function_on f X Y /\ (forall V:set, V :e Ty -> preimage_of X f V :e Tx).
  { exact (andEL (function_on f X Y /\ (forall V:set, V :e Ty -> preimage_of X f V :e Tx))
                 (forall C:set, closed_in Y Ty C -> closed_in X Tx (preimage_of X f C))
                 Habc). }
  claim Hfun: function_on f X Y.
  { exact (andEL (function_on f X Y) (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hab). }
  claim Hpreimage: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  { exact (andER (function_on f X Y) (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hab). }
  (** Build continuous_map from components **)
  prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
        (forall V:set, V :e Ty -> preimage_of X f V :e Tx).
  apply andI.
  + apply andI.
    * apply andI.
      - exact HTx.
      - exact HTy.
    * exact Hfun.
  + exact Hpreimage.
Qed.

(** from §18: identity map is continuous **) 
(** LATEX VERSION: Identity map on any space is continuous. **)
(** FIXED: Identity function must use ordered pairs (tuple notation), not UPair. **)
Theorem identity_continuous : forall X Tx:set,
  topology_on X Tx ->
  let id := {(x,x)|x :e X} in
  continuous_map X Tx X Tx id.
let X Tx.
assume HTx: topology_on X Tx.
prove let id := {(x,x)|x :e X} in continuous_map X Tx X Tx id.
set id := {(x,x)|x :e X}.
prove continuous_map X Tx X Tx id.
  (** Strategy: unfold continuous_map; identity is function_on and preimage_of X id V = V for V :e Tx. **)
  (** Unfold: continuous_map = topology_on X Tx /\ topology_on X Tx /\ function_on id X X /\ (forall V, V :e Tx -> preimage_of X id V :e Tx), left-associative. **)
prove topology_on X Tx /\ topology_on X Tx /\ function_on id X X /\
  forall V:set, V :e Tx -> preimage_of X id V :e Tx.
(** Build the conjunction left-to-right **)
claim Hpart1: topology_on X Tx /\ topology_on X Tx.
{ apply andI. exact HTx. exact HTx. }
claim Hpart2: (topology_on X Tx /\ topology_on X Tx) /\ function_on id X X.
{ apply andI.
  - exact Hpart1.
  - (** function_on id X X **)
    prove function_on id X X.
    prove forall x:set, x :e X -> apply_fun id x :e X.
    let x. assume Hx: x :e X.
    prove apply_fun id x :e X.
    (** For x :e X, apply_fun id x = x and hence apply_fun id x :e X. **)
    claim Hid_x: apply_fun id x = x.
    { exact (identity_function_apply X x Hx). }
    rewrite Hid_x.
    exact Hx. }
apply andI.
- exact Hpart2.
- (** forall V:set, V :e Tx -> preimage_of X id V :e Tx **)
  let V. assume HV: V :e Tx.
  prove preimage_of X id V :e Tx.
  (** preimage_of X id V = {x :e X | apply_fun id x :e V} = {x :e X | x :e V} = V (when V c= X) **)
  claim HVsub: V c= X.
  { exact (topology_elem_subset X Tx V HTx HV). }
  claim Hpreimg_eq: preimage_of X id V = V.
  { apply set_ext.
    - let x. assume Hx: x :e preimage_of X id V.
      prove x :e V.
      claim HxX: x :e X.
      { exact (SepE1 X (fun y => apply_fun id y :e V) x Hx). }
      claim Hidx_in_V: apply_fun id x :e V.
      { exact (SepE2 X (fun y => apply_fun id y :e V) x Hx). }
      claim Hidx_eq: apply_fun id x = x.
      { exact (identity_function_apply X x HxX). }
      rewrite <- Hidx_eq.
      exact Hidx_in_V.
    - let x. assume Hx: x :e V.
      prove x :e preimage_of X id V.
      prove x :e {y :e X | apply_fun id y :e V}.
      claim HxX: x :e X.
      { exact (HVsub x Hx). }
      apply SepI.
      + exact HxX.
      + prove apply_fun id x :e V.
        claim Hidx_eq: apply_fun id x = x.
        { exact (identity_function_apply X x HxX). }
        rewrite Hidx_eq.
        exact Hx. }
  rewrite Hpreimg_eq.
  exact HV.
Qed.

(** Helper: the identity map is continuous from R_ell to the standard topology **)
(** LATEX VERSION: Since the standard topology is contained in the lower limit topology, the identity map is continuous from (R,R_ell) to (R,standard). **)
Theorem identity_continuous_R_lower_to_standard :
  continuous_map R R_lower_limit_topology R R_standard_topology {(x,x)|x :e R}.
prove continuous_map R R_lower_limit_topology R R_standard_topology {(x,x)|x :e R}.
claim Hstd: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim Hlower: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
set idR := {(x,x)|x :e R}.
claim HidStd: continuous_map R R_standard_topology R R_standard_topology idR.
{ exact (identity_continuous R R_standard_topology Hstd). }
claim Hinc: R_standard_topology c= R_lower_limit_topology.
{ exact R_lower_limit_finer_than_R_standard. }
exact (continuous_map_domain_finer R R_standard_topology R_lower_limit_topology
        R R_standard_topology idR
        HidStd Hlower Hinc).
Qed.

 (** from §18: composition of continuous maps is continuous **)
 (** LATEX VERSION: Composition of continuous functions remains continuous. **)
 (** FIXED: Function composition must use ordered pairs (tuple notation), not UPair. **)
Definition compose_fun : set -> set -> set -> set := fun X f g =>
  {(x, apply_fun g (apply_fun f x))|x :e X}.

(** Helper: compose_fun has domain subset X **)
Theorem graph_domain_subset_compose_fun : forall X f g:set,
  graph_domain_subset (compose_fun X f g) X.
let X f g.
exact (graph_domain_subset_graph X (fun x0:set => apply_fun g (apply_fun f x0))).
Qed.

(** Helper: compose_fun is functional **)
Theorem functional_graph_compose_fun : forall X f g:set,
  functional_graph (compose_fun X f g).
let X f g.
exact (functional_graph_graph X (fun x0:set => apply_fun g (apply_fun f x0))).
Qed.

(** Helper: compose_fun maps X into Z if f maps X into Y and g maps Y into Z **)
Theorem function_on_compose_fun : forall X Y Z f g:set,
  function_on f X Y ->
  function_on g Y Z ->
  function_on (compose_fun X f g) X Z.
let X Y Z f g.
assume Hf: function_on f X Y.
assume Hg: function_on g Y Z.
let x. assume HxX: x :e X.
prove apply_fun (compose_fun X f g) x :e Z.
claim HfxY: apply_fun f x :e Y.
{ exact (Hf x HxX). }
claim HgfxZ: apply_fun g (apply_fun f x) :e Z.
{ exact (Hg (apply_fun f x) HfxY). }
claim Hpair: (x, apply_fun g (apply_fun f x)) :e compose_fun X f g.
{ exact (ReplI X (fun x0:set => (x0, apply_fun g (apply_fun f x0))) x HxX). }
claim Hfuncomp: functional_graph (compose_fun X f g).
{ exact (functional_graph_compose_fun X f g). }
claim Happ: apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
{ exact (functional_graph_apply_fun_eq (compose_fun X f g) x (apply_fun g (apply_fun f x)) Hfuncomp Hpair). }
rewrite Happ.
exact HgfxZ.
Qed.

(** Helper: compose_fun is total_function_on under function_on assumptions **)
Theorem total_function_on_compose_fun : forall X Y Z f g:set,
  function_on f X Y ->
  function_on g Y Z ->
  total_function_on (compose_fun X f g) X Z.
let X Y Z f g.
assume Hf: function_on f X Y.
assume Hg: function_on g Y Z.
prove function_on (compose_fun X f g) X Z /\
  forall x:set, x :e X -> exists y:set, y :e Z /\ (x,y) :e compose_fun X f g.
apply andI.
- exact (function_on_compose_fun X Y Z f g Hf Hg).
- let x. assume HxX: x :e X.
  prove exists y:set, y :e Z /\ (x,y) :e compose_fun X f g.
  witness (apply_fun g (apply_fun f x)).
  apply andI.
  * claim HfxY: apply_fun f x :e Y.
    { exact (Hf x HxX). }
    exact (Hg (apply_fun f x) HfxY).
  * exact (ReplI X (fun x0:set => (x0, apply_fun g (apply_fun f x0))) x HxX).
Qed.

(** helper: compose_fun yields an element of function_space **)
(** LATEX VERSION: If f:X→Y and g:Y→Z, then g∘f ∈ function_space X Z. **)
Theorem compose_fun_in_function_space : forall X Y Z f g:set,
  function_on f X Y ->
  function_on g Y Z ->
  compose_fun X f g :e function_space X Z.
let X Y Z f g.
assume Hf: function_on f X Y.
assume Hg: function_on g Y Z.
claim Hsub: compose_fun X f g c= setprod X Z.
{ let p. assume Hp: p :e compose_fun X f g.
  prove p :e setprod X Z.
  apply (ReplE_impred X (fun x0:set => (x0, apply_fun g (apply_fun f x0))) p Hp (p :e setprod X Z)).
  let x. assume HxX: x :e X.
  assume Heq: p = (x, apply_fun g (apply_fun f x)).
  rewrite Heq.
  claim HfxY: apply_fun f x :e Y.
  { exact (Hf x HxX). }
  claim HgxZ: apply_fun g (apply_fun f x) :e Z.
  { exact (Hg (apply_fun f x) HfxY). }
  exact (tuple_2_setprod_by_pair_Sigma X Z x (apply_fun g (apply_fun f x)) HxX HgxZ). }
claim Hpow: compose_fun X f g :e Power (setprod X Z).
{ exact (PowerI (setprod X Z) (compose_fun X f g) Hsub). }
claim Hfun: function_on (compose_fun X f g) X Z.
{ exact (function_on_compose_fun X Y Z f g Hf Hg). }
exact (SepI (Power (setprod X Z)) (fun h0:set => function_on h0 X Z) (compose_fun X f g) Hpow Hfun).
Qed.

(** Helper: apply_fun on composed functions **)
Theorem compose_fun_apply : forall X f g x:set,
  x :e X -> apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
let X f g x. assume Hx.
prove apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
prove apply_fun {(y, apply_fun g (apply_fun f y)) | y :e X} x = apply_fun g (apply_fun f x).
prove Eps_i (fun z => (x, z) :e {(y, apply_fun g (apply_fun f y)) | y :e X}) = apply_fun g (apply_fun f x).
claim H1: (x, apply_fun g (apply_fun f x)) :e {(y, apply_fun g (apply_fun f y)) | y :e X}.
{ exact (ReplI X (fun y => (y, apply_fun g (apply_fun f y))) x Hx). }
claim H2: (x, Eps_i (fun z => (x, z) :e {(y, apply_fun g (apply_fun f y)) | y :e X})) :e {(y, apply_fun g (apply_fun f y)) | y :e X}.
{ exact (Eps_i_ax (fun z => (x, z) :e {(y, apply_fun g (apply_fun f y)) | y :e X}) (apply_fun g (apply_fun f x)) H1). }
apply (ReplE_impred X (fun y => (y, apply_fun g (apply_fun f y))) (x, Eps_i (fun z => (x, z) :e {(y, apply_fun g (apply_fun f y)) | y :e X})) H2).
let y.
assume Hy: y :e X.
assume Heq: (x, Eps_i (fun z => (x, z) :e {(y0, apply_fun g (apply_fun f y0)) | y0 :e X})) = (y, apply_fun g (apply_fun f y)).
claim Hx_eq: x = y.
{ rewrite <- (tuple_2_0_eq x (Eps_i (fun z => (x, z) :e {(y0, apply_fun g (apply_fun f y0)) | y0 :e X}))).
  rewrite <- (tuple_2_0_eq y (apply_fun g (apply_fun f y))).
  rewrite Heq.
  reflexivity. }
claim Hz_eq: Eps_i (fun z => (x, z) :e {(y0, apply_fun g (apply_fun f y0)) | y0 :e X}) = apply_fun g (apply_fun f y).
{ rewrite <- (tuple_2_1_eq x (Eps_i (fun z => (x, z) :e {(y0, apply_fun g (apply_fun f y0)) | y0 :e X}))).
  rewrite <- (tuple_2_1_eq y (apply_fun g (apply_fun f y))).
  rewrite Heq.
  reflexivity. }
rewrite Hz_eq.
rewrite <- Hx_eq.
reflexivity.
Qed.

(** Helper: preimage composition under function_on assumption **)
Theorem preimage_compose_fun : forall X Y f g W:set,
  function_on f X Y ->
  preimage_of X (compose_fun X f g) W = preimage_of X f (preimage_of Y g W).
let X Y f g W.
assume Hfun: function_on f X Y.
apply set_ext.
- let x. assume HxL: x :e preimage_of X (compose_fun X f g) W.
  prove x :e preimage_of X f (preimage_of Y g W).
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun (compose_fun X f g) x0 :e W) x HxL). }
  claim HxW: apply_fun (compose_fun X f g) x :e W.
  { exact (SepE2 X (fun x0:set => apply_fun (compose_fun X f g) x0 :e W) x HxL). }
  claim Hcomp: apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
  { exact (compose_fun_apply X f g x HxX). }
  claim HfxY: apply_fun f x :e Y.
  { exact (Hfun x HxX). }
  prove x :e {x0 :e X | apply_fun f x0 :e preimage_of Y g W}.
  claim HfxInPre: apply_fun f x :e preimage_of Y g W.
  { prove apply_fun f x :e {y :e Y | apply_fun g y :e W}.
    claim HgfxW: apply_fun g (apply_fun f x) :e W.
    { rewrite <- Hcomp.
      exact HxW. }
    exact (SepI Y (fun y0:set => apply_fun g y0 :e W) (apply_fun f x) HfxY HgfxW). }
  exact (SepI X (fun x0:set => apply_fun f x0 :e preimage_of Y g W) x HxX HfxInPre).
- let x. assume HxR: x :e preimage_of X f (preimage_of Y g W).
  prove x :e preimage_of X (compose_fun X f g) W.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => apply_fun f x0 :e preimage_of Y g W) x HxR). }
  claim HfxPre: apply_fun f x :e preimage_of Y g W.
  { exact (SepE2 X (fun x0:set => apply_fun f x0 :e preimage_of Y g W) x HxR). }
  claim HfxY: apply_fun f x :e Y.
  { exact (SepE1 Y (fun y0:set => apply_fun g y0 :e W) (apply_fun f x) HfxPre). }
  claim HgW: apply_fun g (apply_fun f x) :e W.
  { exact (SepE2 Y (fun y0:set => apply_fun g y0 :e W) (apply_fun f x) HfxPre). }
  claim Hcomp: apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
  { exact (compose_fun_apply X f g x HxX). }
  claim HcompW: apply_fun (compose_fun X f g) x :e W.
  { rewrite Hcomp.
    exact HgW. }
  exact (SepI X (fun x0:set => apply_fun (compose_fun X f g) x0 :e W) x HxX HcompW).
Qed.

 Theorem composition_continuous : forall X Tx Y Ty Z Tz f g:set,
   continuous_map X Tx Y Ty f ->
   continuous_map Y Ty Z Tz g ->
   continuous_map X Tx Z Tz (compose_fun X f g).
let X Tx Y Ty Z Tz f g.
assume Hf: continuous_map X Tx Y Ty f.
assume Hg: continuous_map Y Ty Z Tz g.
prove continuous_map X Tx Z Tz (compose_fun X f g).
set gf := compose_fun X f g.
  (** Strategy: show g∘f continuous by rewriting preimages: (g∘f)⁻¹(W) = f⁻¹(g⁻¹(W)). **)
(** Extract components from continuous_map definitions **)
(** Hf: topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\ (forall V...) **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (topology_on Y Ty)
          (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
            (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                   (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                   Hf))). }
claim HTy_from_f: topology_on Y Ty.
{ exact (andER (topology_on X Tx) (topology_on Y Ty)
          (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
            (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                   (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                   Hf))). }
claim Hfun_f: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
          (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                 (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                 Hf)). }
claim Hpreimg_f: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
(** Hg: topology_on Y Ty /\ topology_on Z Tz /\ function_on g Y Z /\ (forall W...) **)
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty) (topology_on Z Tz)
          (andEL (topology_on Y Ty /\ topology_on Z Tz) (function_on g Y Z)
            (andEL (topology_on Y Ty /\ topology_on Z Tz /\ function_on g Y Z)
                   (forall W:set, W :e Tz -> preimage_of Y g W :e Ty)
                   Hg))). }
claim HTz: topology_on Z Tz.
{ exact (andER (topology_on Y Ty) (topology_on Z Tz)
          (andEL (topology_on Y Ty /\ topology_on Z Tz) (function_on g Y Z)
            (andEL (topology_on Y Ty /\ topology_on Z Tz /\ function_on g Y Z)
                   (forall W:set, W :e Tz -> preimage_of Y g W :e Ty)
                   Hg))). }
claim Hfun_g: function_on g Y Z.
{ exact (andER (topology_on Y Ty /\ topology_on Z Tz) (function_on g Y Z)
          (andEL (topology_on Y Ty /\ topology_on Z Tz /\ function_on g Y Z)
                 (forall W:set, W :e Tz -> preimage_of Y g W :e Ty)
                 Hg)). }
claim Hpreimg_g: forall W:set, W :e Tz -> preimage_of Y g W :e Ty.
{ exact (andER (topology_on Y Ty /\ topology_on Z Tz /\ function_on g Y Z)
               (forall W:set, W :e Tz -> preimage_of Y g W :e Ty)
               Hg). }
(** Show gf = g∘f is continuous **)
(** Need: topology_on X Tx /\ topology_on Z Tz /\ function_on gf X Z /\ (forall W:set, W :e Tz -> preimage_of X gf W :e Tx) **)
(** Build the conjunction left-to-right due to left associativity **)
prove topology_on X Tx /\ topology_on Z Tz /\ function_on gf X Z /\
  (forall W:set, W :e Tz -> preimage_of X gf W :e Tx).
claim Hpart1: topology_on X Tx /\ topology_on Z Tz.
{ apply andI. exact HTx. exact HTz. }
claim Hpart2: (topology_on X Tx /\ topology_on Z Tz) /\ function_on gf X Z.
{ apply andI.
  - exact Hpart1.
  - (** Prove function_on gf X Z **)
    prove forall x:set, x :e X -> apply_fun gf x :e Z.
    let x. assume Hx: x :e X.
    prove apply_fun gf x :e Z.
    (** gf = {(x, apply_fun g (apply_fun f x))|x :e X} **)
    (** So apply_fun gf x should be apply_fun g (apply_fun f x) **)
    (** Since f: X -> Y, we have apply_fun f x :e Y **)
    claim Hfx: apply_fun f x :e Y.
    { exact (Hfun_f x Hx). }
    (** Since g: Y -> Z, we have apply_fun g (apply_fun f x) :e Z **)
    claim Hgfx: apply_fun g (apply_fun f x) :e Z.
    { exact (Hfun_g (apply_fun f x) Hfx). }
    (** Show apply_fun gf x :e Z using compose_fun_apply axiom **)
    claim Hgf_eq: apply_fun gf x = apply_fun g (apply_fun f x).
    { exact (compose_fun_apply X f g x Hx). }
    rewrite Hgf_eq.
    exact Hgfx.
}
apply andI.
- exact Hpart2.
- (** Prove preimages of open sets in Z are open in X **)
  let W. assume HW: W :e Tz.
  prove preimage_of X gf W :e Tx.
  (** Since g is continuous, preimage_of Y g W is open in Ty **)
  claim HgW_open: preimage_of Y g W :e Ty.
  { exact (Hpreimg_g W HW). }
  (** Since f is continuous, preimage_of X f (preimage_of Y g W) is open in Tx **)
  claim HfgW_open: preimage_of X f (preimage_of Y g W) :e Tx.
  { exact (Hpreimg_f (preimage_of Y g W) HgW_open). }
	  (** Show that preimage_of X gf W = preimage_of X f (preimage_of Y g W) **)
	  claim Hpreimg_eq: preimage_of X gf W = preimage_of X f (preimage_of Y g W).
	  { (** Use preimage composition property **)
	    exact (preimage_compose_fun X Y f g W Hfun_f).
	  }
  rewrite Hpreimg_eq.
  exact HfgW_open.
Qed.

(** from §18 Theorem 18.2: rules for constructing continuous functions **) 
(** LATEX VERSION: Theorem 18.2: Constant maps, inclusions, composites, domain restriction, range restriction/expansion, and local continuity formulation. **)
Theorem continuous_construction_rules : forall X Tx Y Ty Z Tz:set,
  topology_on X Tx -> topology_on Y Ty -> topology_on Z Tz ->
  (forall y0:set, y0 :e Y -> continuous_map X Tx Y Ty (const_fun X y0))
  /\
  (forall A:set, A c= X -> continuous_map A (subspace_topology X Tx A) X Tx {(y,y) | y :e A})
  /\
  (forall f g:set, continuous_map X Tx Y Ty f -> continuous_map Y Ty Z Tz g ->
    continuous_map X Tx Z Tz (compose_fun X f g))
  /\
  (forall f A:set, A c= X -> continuous_map X Tx Y Ty f ->
    continuous_map A (subspace_topology X Tx A) Y Ty f)
  /\
  ((forall f Z0:set, continuous_map X Tx Y Ty f -> Z0 c= Y ->
     (forall x:set, x :e X -> apply_fun f x :e Z0) ->
     continuous_map X Tx Z0 (subspace_topology Y Ty Z0) f)
   /\
   (forall f Z0 Tz0:set, continuous_map X Tx Y Ty f -> Y c= Z0 ->
     topology_on Z0 Tz0 -> Ty = subspace_topology Z0 Tz0 Y ->
     continuous_map X Tx Z0 Tz0 f))
  /\
  (forall f:set,
    (exists UFam:set, UFam c= Tx /\ Union UFam = X /\
      (forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f))
    -> continuous_map X Tx Y Ty f).
let X Tx Y Ty Z Tz.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HTz: topology_on Z Tz.
prove (forall y0:set, y0 :e Y -> continuous_map X Tx Y Ty (const_fun X y0))
  /\ (forall A:set, A c= X -> continuous_map A (subspace_topology X Tx A) X Tx {(y,y) | y :e A})
  /\ (forall f g:set, continuous_map X Tx Y Ty f -> continuous_map Y Ty Z Tz g ->
       continuous_map X Tx Z Tz (compose_fun X f g))
  /\ (forall f A:set, A c= X -> continuous_map X Tx Y Ty f ->
       continuous_map A (subspace_topology X Tx A) Y Ty f)
  /\ ((forall f Z0:set, continuous_map X Tx Y Ty f -> Z0 c= Y ->
        (forall x:set, x :e X -> apply_fun f x :e Z0) ->
        continuous_map X Tx Z0 (subspace_topology Y Ty Z0) f)
      /\
      (forall f Z0 Tz0:set, continuous_map X Tx Y Ty f -> Y c= Z0 ->
        topology_on Z0 Tz0 -> Ty = subspace_topology Z0 Tz0 Y ->
        continuous_map X Tx Z0 Tz0 f))
  /\ (forall f:set,
       (exists UFam:set, UFam c= Tx /\ Union UFam = X /\
         (forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f))
       -> continuous_map X Tx Y Ty f).
apply andI.
- (** left: (a) through (e) **)
  apply andI.
  + (** left: (a) through (d) **)
    apply andI.
    * (** left: (a) through (c) **)
      apply andI.
      { (** left: (a) and (b) **)
        apply andI.
        - (** (a) constant functions **)
          let y0. assume Hy0: y0 :e Y.
          exact (const_fun_continuous X Tx Y Ty y0 HTx HTy Hy0).
        - (** (b) inclusion of a subspace is continuous **)
          let A. assume HA: A c= X.
          set j := {(y,y) | y :e A}.
          prove continuous_map A (subspace_topology X Tx A) X Tx j.
          prove topology_on A (subspace_topology X Tx A) /\ topology_on X Tx /\ function_on j A X /\
                forall V:set, V :e Tx -> preimage_of A j V :e subspace_topology X Tx A.
          apply andI.
          - apply andI.
            + apply andI.
              * exact (subspace_topology_is_topology X Tx A HTx HA).
              * exact HTx.
            + let a. assume HaA: a :e A.
              prove apply_fun j a :e X.
              claim Haj: apply_fun j a = a.
              { exact (identity_function_apply A a HaA). }
              rewrite Haj.
              exact (HA a HaA).
          - let V. assume HV: V :e Tx.
            prove preimage_of A j V :e subspace_topology X Tx A.
            claim Heq: preimage_of A j V = V :/\: A.
            { apply set_ext.
              - let a. assume Ha: a :e preimage_of A j V.
                prove a :e V :/\: A.
                claim HaA: a :e A.
                { exact (SepE1 A (fun u:set => apply_fun j u :e V) a Ha). }
                claim Haj: apply_fun j a = a.
                { exact (identity_function_apply A a HaA). }
                claim HaV: a :e V.
                { rewrite <- Haj.
                  exact (SepE2 A (fun u:set => apply_fun j u :e V) a Ha). }
                exact (binintersectI V A a HaV HaA).
              - let a. assume Ha: a :e V :/\: A.
                prove a :e preimage_of A j V.
                claim HaV: a :e V.
                { exact (binintersectE1 V A a Ha). }
                claim HaA: a :e A.
                { exact (binintersectE2 V A a Ha). }
                prove a :e {u :e A | apply_fun j u :e V}.
                apply (SepI A (fun u:set => apply_fun j u :e V) a HaA).
                claim Haj: apply_fun j a = a.
                { exact (identity_function_apply A a HaA). }
                rewrite Haj.
                exact HaV.
            }
            rewrite Heq.
	            claim HVpow: (V :/\: A) :e Power A.
	            { apply PowerI.
	              let a. assume Ha: a :e V :/\: A.
	              exact (binintersectE2 V A a Ha). }
	            claim HexW: exists W :e Tx, V :/\: A = W :/\: A.
	            { witness V.
	              apply andI.
	              - exact HV.
	              - reflexivity. }
	            exact (SepI (Power A) (fun U0:set => exists W :e Tx, U0 = W :/\: A) (V :/\: A) HVpow HexW).
	      }
      { (** (c) composites **)
        let f. let g. assume Hf. assume Hg.
        exact (composition_continuous X Tx Y Ty Z Tz f g Hf Hg).
      }
	    * (** (d) restricting the domain **)
	      let f. let A. assume HA. assume Hf.
	      prove continuous_map A (subspace_topology X Tx A) Y Ty f.
	      claim HTA: topology_on A (subspace_topology X Tx A).
	      { exact (subspace_topology_is_topology X Tx A HTx HA). }
	      claim HpreX: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
	      { exact (andER (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
	                     (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
	                     Hf). }
	      claim Htmp: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
	      { exact (andEL (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
	                     (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
	                     Hf). }
	      claim HfunXY: function_on f X Y.
	      { exact (andER (topology_on X Tx /\ topology_on Y Ty)
	                     (function_on f X Y)
	                     Htmp). }
	      prove (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty /\ function_on f A Y)
	            /\ forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A.
	      apply andI.
	      - (** topology_on A /\ topology_on Y /\ function_on f A Y **)
	        apply andI.
	        + (** topology_on A /\ topology_on Y **)
	          apply andI.
	          * exact HTA.
	          * exact HTy.
	        + (** function_on f A Y **)
	          let a. assume HaA: a :e A.
	          prove apply_fun f a :e Y.
	          claim HaX: a :e X.
	          { exact (HA a HaA). }
	          exact (HfunXY a HaX).
	      - (** preimage condition in the subspace topology **)
	        let V. assume HV: V :e Ty.
	        prove preimage_of A f V :e subspace_topology X Tx A.
	        claim HWTx: preimage_of X f V :e Tx.
	        { exact (HpreX V HV). }
	        claim Heq: preimage_of A f V = (preimage_of X f V) :/\: A.
	        { apply set_ext.
	          - let a. assume Ha: a :e preimage_of A f V.
	            prove a :e (preimage_of X f V) :/\: A.
	            claim HaA: a :e A.
	            { exact (SepE1 A (fun u:set => apply_fun f u :e V) a Ha). }
	            claim HaX: a :e X.
	            { exact (HA a HaA). }
	            claim HafV: apply_fun f a :e V.
	            { exact (SepE2 A (fun u:set => apply_fun f u :e V) a Ha). }
		            claim HaPreX: a :e preimage_of X f V.
		            { exact (SepI X (fun u:set => apply_fun f u :e V) a HaX HafV). }
	            exact (binintersectI (preimage_of X f V) A a HaPreX HaA).
	          - let a. assume Ha: a :e (preimage_of X f V) :/\: A.
	            prove a :e preimage_of A f V.
	            claim HaPreX: a :e preimage_of X f V.
	            { exact (binintersectE1 (preimage_of X f V) A a Ha). }
	            claim HaA: a :e A.
	            { exact (binintersectE2 (preimage_of X f V) A a Ha). }
	            claim HafV: apply_fun f a :e V.
	            { exact (SepE2 X (fun u:set => apply_fun f u :e V) a HaPreX). }
		            exact (SepI A (fun u:set => apply_fun f u :e V) a HaA HafV).
	        }
	        rewrite Heq.
	        claim Hpow: ((preimage_of X f V) :/\: A) :e Power A.
	        { apply PowerI.
	          let a. assume Ha: a :e (preimage_of X f V) :/\: A.
	          exact (binintersectE2 (preimage_of X f V) A a Ha). }
	        claim HexW: exists W :e Tx, (preimage_of X f V) :/\: A = W :/\: A.
	        { witness (preimage_of X f V).
	          apply andI.
	          - exact HWTx.
	          - reflexivity. }
	        exact (SepI (Power A) (fun U0:set => exists W :e Tx, U0 = W :/\: A)
	                   ((preimage_of X f V) :/\: A) Hpow HexW).
	  + (** (e) restricting or expanding the range **)
	    apply andI.
	    - (** (e) restricting the range to a subspace Z0⊂Y containing f(X) **)
	      let f. let Z0. assume Hf. assume HZ0. assume Himg.
	      prove continuous_map X Tx Z0 (subspace_topology Y Ty Z0) f.
	      (** Extract preimage axiom for f: X -> Y **)
	      claim HpreY: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
	      { exact (andER (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
	                     (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
	                     Hf). }
	      (** Z0 with the subspace topology is a topological space **)
	      claim HTz0: topology_on Z0 (subspace_topology Y Ty Z0).
	      { exact (subspace_topology_is_topology Y Ty Z0 HTy HZ0). }
	      (** function_on f X Z0 **)
	      claim HfunXZ0: function_on f X Z0.
	      { let x. assume HxX: x :e X.
	        exact (Himg x HxX). }
	      (** prove the continuity conjunction **)
	      prove (topology_on X Tx /\ topology_on Z0 (subspace_topology Y Ty Z0) /\ function_on f X Z0)
	            /\ forall B:set, B :e subspace_topology Y Ty Z0 -> preimage_of X f B :e Tx.
	      apply andI.
	      - (** topologies and function_on **)
	        apply andI.
	        + apply andI.
	          * exact HTx.
	          * exact HTz0.
	        + exact HfunXZ0.
		      - let B. assume HB: B :e subspace_topology Y Ty Z0.
		        (** B is of the form V ∩ Z0 for some V open in Y **)
		        claim Hex: exists V :e Ty, B = V :/\: Z0.
		        { exact (subspace_topologyE Y Ty Z0 B HB). }
		        apply Hex.
		        let V. assume HVpair.
		        claim HV: V :e Ty.
		        { exact (andEL (V :e Ty) (B = V :/\: Z0) HVpair). }
	        claim HB_eq: B = V :/\: Z0.
	        { exact (andER (V :e Ty) (B = V :/\: Z0) HVpair). }
	        claim HeqPre: preimage_of X f B = preimage_of X f V.
	        { apply set_ext.
	          - let x. assume Hx: x :e preimage_of X f B.
	            prove x :e preimage_of X f V.
	            claim HxX: x :e X.
	            { exact (SepE1 X (fun u:set => apply_fun f u :e B) x Hx). }
	            claim HfxB: apply_fun f x :e B.
	            { exact (SepE2 X (fun u:set => apply_fun f u :e B) x Hx). }
	            claim HfxVz0: apply_fun f x :e V :/\: Z0.
	            { rewrite <- HB_eq. exact HfxB. }
	            claim HfxV: apply_fun f x :e V.
	            { exact (binintersectE1 V Z0 (apply_fun f x) HfxVz0). }
	            exact (SepI X (fun u:set => apply_fun f u :e V) x HxX HfxV).
	          - let x. assume Hx: x :e preimage_of X f V.
	            prove x :e preimage_of X f B.
	            claim HxX: x :e X.
	            { exact (SepE1 X (fun u:set => apply_fun f u :e V) x Hx). }
	            claim HfxV: apply_fun f x :e V.
	            { exact (SepE2 X (fun u:set => apply_fun f u :e V) x Hx). }
	            claim HfxZ0: apply_fun f x :e Z0.
	            { exact (HfunXZ0 x HxX). }
	            claim HfxB: apply_fun f x :e B.
	            { rewrite HB_eq.
	              exact (binintersectI V Z0 (apply_fun f x) HfxV HfxZ0). }
	            exact (SepI X (fun u:set => apply_fun f u :e B) x HxX HfxB).
	        }
	        rewrite HeqPre.
	        exact (HpreY V HV).
	    - (** (e) expanding the range: if Y is a subspace of Z0, continuity as X→Y implies continuity as X→Z0 **)
	      let f. let Z0. let Tz0.
	      assume Hf: continuous_map X Tx Y Ty f.
	      assume HYZ0: Y c= Z0.
	      assume HTz0: topology_on Z0 Tz0.
	      assume HTy_eq: Ty = subspace_topology Z0 Tz0 Y.
	      prove continuous_map X Tx Z0 Tz0 f.
	      claim HpreY: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
	      { exact (andER (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
	                     (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
	                     Hf). }
	      claim Htmp: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
	      { exact (andEL (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
	                     (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
	                     Hf). }
	      claim HfunXY: function_on f X Y.
	      { exact (andER (topology_on X Tx /\ topology_on Y Ty)
	                     (function_on f X Y)
	                     Htmp). }
	      claim HfunXZ0: function_on f X Z0.
	      { let x. assume HxX: x :e X.
	        exact (HYZ0 (apply_fun f x) (HfunXY x HxX)). }
	      prove (topology_on X Tx /\ topology_on Z0 Tz0 /\ function_on f X Z0) /\
	            forall W:set, W :e Tz0 -> preimage_of X f W :e Tx.
	      apply andI.
	      - apply andI.
	        + apply andI.
	          * exact HTx.
	          * exact HTz0.
	        + exact HfunXZ0.
	      - let W. assume HW: W :e Tz0.
	        set B := W :/\: Y.
	        claim HB_inTy: B :e Ty.
	        { rewrite HTy_eq.
	          (** show B is in the subspace topology on Y **)
	          claim HBpow: B :e Power Y.
	          { apply PowerI.
	            let y. assume HyB: y :e B.
	            exact (binintersectE2 W Y y HyB). }
	          claim Hex: exists V :e Tz0, B = V :/\: Y.
	          { witness W.
	            apply andI.
	            - exact HW.
	            - reflexivity. }
	          exact (SepI (Power Y) (fun U0:set => exists V :e Tz0, U0 = V :/\: Y) B HBpow Hex). }
	        claim HeqPre: preimage_of X f W = preimage_of X f B.
	        { apply set_ext.
	          - let x. assume Hx: x :e preimage_of X f W.
	            prove x :e preimage_of X f B.
	            claim HxX: x :e X.
	            { exact (SepE1 X (fun u:set => apply_fun f u :e W) x Hx). }
	            claim HfxW: apply_fun f x :e W.
	            { exact (SepE2 X (fun u:set => apply_fun f u :e W) x Hx). }
	            claim HfxY: apply_fun f x :e Y.
	            { exact (HfunXY x HxX). }
	            claim HfxB: apply_fun f x :e B.
	            { exact (binintersectI W Y (apply_fun f x) HfxW HfxY). }
	            exact (SepI X (fun u:set => apply_fun f u :e B) x HxX HfxB).
	          - let x. assume Hx: x :e preimage_of X f B.
	            prove x :e preimage_of X f W.
	            claim HxX: x :e X.
	            { exact (SepE1 X (fun u:set => apply_fun f u :e B) x Hx). }
	            claim HfxB: apply_fun f x :e B.
	            { exact (SepE2 X (fun u:set => apply_fun f u :e B) x Hx). }
	            claim HfxW: apply_fun f x :e W.
	            { exact (binintersectE1 W Y (apply_fun f x) HfxB). }
	            exact (SepI X (fun u:set => apply_fun f u :e W) x HxX HfxW).
	        }
	        rewrite HeqPre.
	        exact (HpreY B HB_inTy).
- (** (f) local formulation **)
  let f. assume Hloc.
  prove continuous_map X Tx Y Ty f.
  apply Hloc.
	  let UFam. assume HUFconj.
	  claim HUFpair: (UFam c= Tx /\ Union UFam = X) /\ (forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f).
	  { exact HUFconj. }
	  claim HUFsub_union: UFam c= Tx /\ Union UFam = X.
	  { exact (andEL (UFam c= Tx /\ Union UFam = X)
	                 (forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f)
	                 HUFpair). }
	  claim HcontU: forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f.
	  { exact (andER (UFam c= Tx /\ Union UFam = X)
	                 (forall U:set, U :e UFam -> continuous_map U (subspace_topology X Tx U) Y Ty f)
	                 HUFpair). }
	  claim HUFsub: UFam c= Tx.
	  { exact (andEL (UFam c= Tx) (Union UFam = X) HUFsub_union). }
	  claim HUnionEq: Union UFam = X.
	  { exact (andER (UFam c= Tx) (Union UFam = X) HUFsub_union). }
  (** derive function_on f X Y from the local continuity hypotheses **)
  claim HfunXY: function_on f X Y.
  { let x. assume HxX: x :e X.
	    claim HxUnion: x :e Union UFam.
	    { rewrite HUnionEq. exact HxX. }
    apply (UnionE UFam x HxUnion).
    let U. assume HxUconj.
    claim HxU: x :e U.
    { exact (andEL (x :e U) (U :e UFam) HxUconj). }
    claim HUUF: U :e UFam.
    { exact (andER (x :e U) (U :e UFam) HxUconj). }
    claim HcU: continuous_map U (subspace_topology X Tx U) Y Ty f.
    { exact (HcontU U HUUF). }
    claim Htmp: (topology_on U (subspace_topology X Tx U) /\ topology_on Y Ty) /\ function_on f U Y.
    { exact (andEL ((topology_on U (subspace_topology X Tx U) /\ topology_on Y Ty) /\ function_on f U Y)
                   (forall V:set, V :e Ty -> preimage_of U f V :e subspace_topology X Tx U)
                   HcU). }
    claim HfunUY: function_on f U Y.
    { exact (andER (topology_on U (subspace_topology X Tx U) /\ topology_on Y Ty)
                   (function_on f U Y)
                   Htmp). }
    exact (HfunUY x HxU). }
  (** now prove continuity of f by the preimage definition **)
  prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
        forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  apply andI.
  - apply andI.
    + apply andI.
      * exact HTx.
      * exact HTy.
    + exact HfunXY.
  - let V. assume HV: V :e Ty.
    set S := preimage_of X f V.
    (** define Fam = {W open in X | W ⊆ S} **)
    set Fam := {W :e Power X | W :e Tx /\ W c= S}.
    claim HFamSubTx: Fam c= Tx.
    { let W. assume HW: W :e Fam.
      claim HWpred: W :e Tx /\ W c= S.
      { exact (SepE2 (Power X) (fun W0:set => W0 :e Tx /\ W0 c= S) W HW). }
      exact (andEL (W :e Tx) (W c= S) HWpred). }
    claim HUnionFamEq: Union Fam = S.
    { apply set_ext.
      - let x. assume Hx: x :e Union Fam.
        prove x :e S.
        apply (UnionE Fam x Hx).
        let W. assume HxWconj.
        claim HxW: x :e W.
        { exact (andEL (x :e W) (W :e Fam) HxWconj). }
        claim HWFam: W :e Fam.
        { exact (andER (x :e W) (W :e Fam) HxWconj). }
        claim HWpred: W :e Tx /\ W c= S.
        { exact (SepE2 (Power X) (fun W0:set => W0 :e Tx /\ W0 c= S) W HWFam). }
        claim HWsubS: W c= S.
        { exact (andER (W :e Tx) (W c= S) HWpred). }
        exact (HWsubS x HxW).
      - let x. assume Hx: x :e S.
        prove x :e Union Fam.
        (** choose a cover element U with x ∈ U **)
        claim HxX: x :e X.
        { exact (SepE1 X (fun u:set => apply_fun f u :e V) x Hx). }
	        claim HxUnion: x :e Union UFam.
	        { rewrite HUnionEq. exact HxX. }
        apply (UnionE UFam x HxUnion).
        let U. assume HxUconj.
        claim HxU: x :e U.
        { exact (andEL (x :e U) (U :e UFam) HxUconj). }
        claim HUUF: U :e UFam.
        { exact (andER (x :e U) (U :e UFam) HxUconj). }
        claim HUTx: U :e Tx.
        { exact (HUFsub U HUUF). }
        claim HUSubX: U c= X.
        { exact (topology_elem_subset X Tx U HTx HUTx). }
        claim HcU: continuous_map U (subspace_topology X Tx U) Y Ty f.
        { exact (HcontU U HUUF). }
        (** from continuity on U: preimage_of U f V is open in the subspace topology **)
        claim HpreU: preimage_of U f V :e subspace_topology X Tx U.
        { exact (andER (((topology_on U (subspace_topology X Tx U) /\ topology_on Y Ty) /\ function_on f U Y))
                       (forall V0:set, V0 :e Ty -> preimage_of U f V0 :e subspace_topology X Tx U)
                       HcU
                       V
                       HV). }
        claim HexW0: exists W0 :e Tx, preimage_of U f V = W0 :/\: U.
        { exact (SepE2 (Power U) (fun U0:set => exists W0 :e Tx, U0 = W0 :/\: U) (preimage_of U f V) HpreU). }
        apply HexW0.
        let W0. assume HW0pair.
        claim HW0Tx: W0 :e Tx.
        { exact (andEL (W0 :e Tx) (preimage_of U f V = W0 :/\: U) HW0pair). }
        claim HeqPreU: preimage_of U f V = W0 :/\: U.
        { exact (andER (W0 :e Tx) (preimage_of U f V = W0 :/\: U) HW0pair). }
        set W := W0 :/\: U.
        (** show x ∈ W **)
        claim HfxV: apply_fun f x :e V.
        { exact (SepE2 X (fun u:set => apply_fun f u :e V) x Hx). }
        claim HxPreU: x :e preimage_of U f V.
        { prove x :e {u :e U | apply_fun f u :e V}.
          apply (SepI U (fun u:set => apply_fun f u :e V) x HxU).
          exact HfxV. }
        claim HxW: x :e W.
        { rewrite <- HeqPreU. exact HxPreU. }
        (** show W ∈ Fam and then x ∈ Union Fam by UnionI **)
        claim HWsubS: W c= S.
        { let z. assume Hz: z :e W.
          prove z :e S.
          claim HzU: z :e U.
          { exact (binintersectE2 W0 U z Hz). }
          claim HzX: z :e X.
          { exact (HUSubX z HzU). }
	          claim HzPreU: z :e preimage_of U f V.
	          { rewrite HeqPreU.
	            exact Hz. }
          claim HfzV: apply_fun f z :e V.
          { exact (SepE2 U (fun u:set => apply_fun f u :e V) z HzPreU). }
          exact (SepI X (fun u:set => apply_fun f u :e V) z HzX HfzV). }
        claim HWpow: W :e Power X.
        { apply PowerI.
          let z. assume Hz: z :e W.
          claim HzU: z :e U.
          { exact (binintersectE2 W0 U z Hz). }
          exact (HUSubX z HzU). }
        claim HWFam: W :e Fam.
        { exact (SepI (Power X) (fun W1:set => W1 :e Tx /\ W1 c= S) W HWpow
                 (andI (W :e Tx) (W c= S)
                   (topology_binintersect_closed X Tx W0 U HTx HW0Tx HUTx)
                   HWsubS)). }
        exact (UnionI Fam x W HxW HWFam).
    }
    rewrite <- HUnionFamEq.
    exact (topology_union_closed X Tx Fam HTx HFamSubTx).
Qed.

(** helper: restricting the domain to a subspace preserves continuity **)
(** LATEX VERSION: If f is continuous on X and A⊂X, then f restricted to A is continuous with the subspace topology on A. **)
Theorem continuous_on_subspace_rule : forall X Tx Y Ty f A:set,
  topology_on X Tx -> topology_on Y Ty -> A c= X ->
  continuous_map X Tx Y Ty f ->
  continuous_map A (subspace_topology X Tx A) Y Ty f.
let X Tx Y Ty f A.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HA: A c= X.
assume Hf: continuous_map X Tx Y Ty f.
prove continuous_map A (subspace_topology X Tx A) Y Ty f.
claim HTA: topology_on A (subspace_topology X Tx A).
{ exact (subspace_topology_is_topology X Tx A HTx HA). }
claim HpreX: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
claim Htmp: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL (((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y))
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
claim HfunXY: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty)
               (function_on f X Y)
               Htmp). }
prove topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty /\ function_on f A Y /\
  forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A.
apply andI.
- apply andI.
  + apply andI.
    * exact HTA.
    * exact HTy.
  + (** function_on f A Y **)
    let a. assume HaA: a :e A.
    prove apply_fun f a :e Y.
    claim HaX: a :e X.
    { exact (HA a HaA). }
    exact (HfunXY a HaX).
- let V. assume HV: V :e Ty.
  prove preimage_of A f V :e subspace_topology X Tx A.
  set U := preimage_of X f V.
  claim HU_open: U :e Tx.
  { exact (HpreX V HV). }
  claim Heq: preimage_of A f V = U :/\: A.
  { apply set_ext.
    - let a. assume Ha: a :e preimage_of A f V.
      prove a :e U :/\: A.
      claim HaA: a :e A.
      { exact (SepE1 A (fun u:set => apply_fun f u :e V) a Ha). }
      claim HaU: a :e U.
      { claim HaX: a :e X.
        { exact (HA a HaA). }
        claim HaV: apply_fun f a :e V.
        { exact (SepE2 A (fun u:set => apply_fun f u :e V) a Ha). }
        exact (SepI X (fun x:set => apply_fun f x :e V) a HaX HaV). }
      exact (binintersectI U A a HaU HaA).
    - let a. assume Ha: a :e U :/\: A.
      prove a :e preimage_of A f V.
      claim HaU: a :e U.
      { exact (binintersectE1 U A a Ha). }
      claim HaA: a :e A.
      { exact (binintersectE2 U A a Ha). }
      claim HaV: apply_fun f a :e V.
      { exact (SepE2 X (fun x:set => apply_fun f x :e V) a HaU). }
      exact (SepI A (fun u:set => apply_fun f u :e V) a HaA HaV).
  }
  rewrite Heq.
  claim HWpow: (U :/\: A) :e Power A.
  { apply PowerI.
    let a. assume Ha: a :e U :/\: A.
    exact (binintersectE2 U A a Ha). }
  claim HexW: exists W :e Tx, U :/\: A = W :/\: A.
  { witness U.
    apply andI.
    - exact HU_open.
    - reflexivity. }
  exact (SepI (Power A) (fun U0:set => exists W :e Tx, U0 = W :/\: A) (U :/\: A) HWpow HexW).
Qed.

(** helper: flip_unit_interval is continuous in the unit interval topology **)
(** LATEX VERSION: The map t |-> 1 - t is continuous on the unit interval I. **)
Theorem flip_unit_interval_continuous :
  continuous_map unit_interval unit_interval_topology unit_interval unit_interval_topology flip_unit_interval.
prove continuous_map unit_interval unit_interval_topology unit_interval unit_interval_topology flip_unit_interval.
set Tx := unit_interval_topology.

(** first prove continuity as a map into R, then restrict the range to unit_interval **)
claim HcontR: continuous_map unit_interval Tx R R_standard_topology flip_unit_interval.
{ set S := open_rays_subbasis R.

  claim HTx: topology_on unit_interval Tx.
  { exact unit_interval_topology_on. }

  claim HfunR: function_on flip_unit_interval unit_interval R.
  { let t. assume Ht: t :e unit_interval.
    exact (flip_unit_interval_in_R t Ht). }

  claim HS: subbasis_on R S.
  { exact (open_rays_subbasis_is_subbasis R). }

  claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
  { rewrite open_rays_subbasis_for_order_topology_R.
    rewrite standard_topology_is_order_topology.
    reflexivity. }
  rewrite <- Hgen.

  claim Hflip_upper: forall a t:set,
    a :e R -> t :e R ->
    (Rlt a (add_SNo 1 (minus_SNo t)) <-> Rlt t (add_SNo 1 (minus_SNo a))).
  { let a t.
    assume HaR: a :e R.
    assume HtR: t :e R.
    prove (Rlt a (add_SNo 1 (minus_SNo t)) <-> Rlt t (add_SNo 1 (minus_SNo a))).
    apply iffI.
    - assume Hlt: Rlt a (add_SNo 1 (minus_SNo t)).
      prove Rlt t (add_SNo 1 (minus_SNo a)).
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim HtS: SNo t.
      { exact (real_SNo t HtR). }
      claim HmaS: SNo (minus_SNo a).
      { exact (SNo_minus_SNo a HaS). }
      claim HmtS: SNo (minus_SNo t).
      { exact (SNo_minus_SNo t HtS). }
      claim HsumS: SNo (add_SNo 1 (minus_SNo t)).
      { exact (SNo_add_SNo 1 (minus_SNo t) SNo_1 HmtS). }
      claim HltS: a < add_SNo 1 (minus_SNo t).
      { exact (RltE_lt a (add_SNo 1 (minus_SNo t)) Hlt). }
      claim H1: add_SNo a t < add_SNo (add_SNo 1 (minus_SNo t)) t.
      { exact (add_SNo_Lt1 a t (add_SNo 1 (minus_SNo t)) HaS HtS HsumS HltS). }
      claim HeqR: add_SNo (add_SNo 1 (minus_SNo t)) t = 1.
      { rewrite <- (add_SNo_assoc 1 (minus_SNo t) t SNo_1 HmtS HtS).
        rewrite (add_SNo_minus_SNo_linv t HtS).
        exact (add_SNo_0R 1 SNo_1). }
      claim H2: add_SNo a t < 1.
      { rewrite <- HeqR.
        exact H1. }
      claim H2c: add_SNo t a < 1.
      { rewrite (add_SNo_com t a HtS HaS).
        exact H2. }
      claim Hm1S: SNo (minus_SNo a).
      { exact HmaS. }
      claim H3: add_SNo (add_SNo t a) (minus_SNo a) < add_SNo 1 (minus_SNo a).
      { exact (add_SNo_Lt1 (add_SNo t a) (minus_SNo a) 1
               (SNo_add_SNo t a HtS HaS) Hm1S SNo_1 H2c). }
      claim HeqL: add_SNo (add_SNo t a) (minus_SNo a) = t.
      { rewrite <- (add_SNo_assoc t a (minus_SNo a) HtS HaS Hm1S).
        rewrite (add_SNo_minus_SNo_rinv a HaS).
        exact (add_SNo_0R t HtS). }
      claim H4: t < add_SNo 1 (minus_SNo a).
      { rewrite <- HeqL at 1.
        exact H3. }
      claim Hflip_aR: add_SNo 1 (minus_SNo a) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HaReal: a :e real.
        { rewrite <- HdefR.
          exact HaR. }
        claim HmaReal: (minus_SNo a) :e real.
        { exact (real_minus_SNo a HaReal). }
        exact (real_add_SNo 1 real_1 (minus_SNo a) HmaReal). }
      exact (RltI t (add_SNo 1 (minus_SNo a)) HtR Hflip_aR H4).
    - assume Hlt: Rlt t (add_SNo 1 (minus_SNo a)).
      prove Rlt a (add_SNo 1 (minus_SNo t)).
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim HtS: SNo t.
      { exact (real_SNo t HtR). }
      claim HmaS: SNo (minus_SNo a).
      { exact (SNo_minus_SNo a HaS). }
      claim HmtS: SNo (minus_SNo t).
      { exact (SNo_minus_SNo t HtS). }
      claim Hflip_aS: SNo (add_SNo 1 (minus_SNo a)).
      { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 HmaS). }
      claim HltS: t < add_SNo 1 (minus_SNo a).
      { exact (RltE_lt t (add_SNo 1 (minus_SNo a)) Hlt). }
      claim H1: add_SNo t a < add_SNo (add_SNo 1 (minus_SNo a)) a.
      { exact (add_SNo_Lt1 t a (add_SNo 1 (minus_SNo a)) HtS HaS Hflip_aS HltS). }
      claim HeqR: add_SNo (add_SNo 1 (minus_SNo a)) a = 1.
      { rewrite <- (add_SNo_assoc 1 (minus_SNo a) a SNo_1 HmaS HaS).
        rewrite (add_SNo_minus_SNo_linv a HaS).
        exact (add_SNo_0R 1 SNo_1). }
      claim H2: add_SNo t a < 1.
      { rewrite <- HeqR.
        exact H1. }
      claim H2c: add_SNo a t < 1.
      { rewrite (add_SNo_com a t HaS HtS).
        exact H2. }
      claim Hm1S: SNo (minus_SNo t).
      { exact HmtS. }
      claim H3: add_SNo (add_SNo a t) (minus_SNo t) < add_SNo 1 (minus_SNo t).
      { exact (add_SNo_Lt1 (add_SNo a t) (minus_SNo t) 1
               (SNo_add_SNo a t HaS HtS) Hm1S SNo_1 H2c). }
      claim HeqL: add_SNo (add_SNo a t) (minus_SNo t) = a.
      { rewrite <- (add_SNo_assoc a t (minus_SNo t) HaS HtS Hm1S).
        rewrite (add_SNo_minus_SNo_rinv t HtS).
        exact (add_SNo_0R a HaS). }
      claim H4: a < add_SNo 1 (minus_SNo t).
      { rewrite <- HeqL at 1.
        exact H3. }
      claim Hflip_tR: add_SNo 1 (minus_SNo t) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HtReal: t :e real.
        { rewrite <- HdefR.
          exact HtR. }
        claim HmtReal: (minus_SNo t) :e real.
        { exact (real_minus_SNo t HtReal). }
        exact (real_add_SNo 1 real_1 (minus_SNo t) HmtReal). }
      exact (RltI a (add_SNo 1 (minus_SNo t)) HaR Hflip_tR H4). }

  claim Hflip_lower: forall t b:set,
    t :e R -> b :e R ->
    (Rlt (add_SNo 1 (minus_SNo t)) b <-> Rlt (add_SNo 1 (minus_SNo b)) t).
  { let t b.
    assume HtR: t :e R.
    assume HbR: b :e R.
    prove (Rlt (add_SNo 1 (minus_SNo t)) b <-> Rlt (add_SNo 1 (minus_SNo b)) t).
    apply iffI.
    - assume Hlt: Rlt (add_SNo 1 (minus_SNo t)) b.
      prove Rlt (add_SNo 1 (minus_SNo b)) t.
      claim HtS: SNo t.
      { exact (real_SNo t HtR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim HmtS: SNo (minus_SNo t).
      { exact (SNo_minus_SNo t HtS). }
      claim HmbS: SNo (minus_SNo b).
      { exact (SNo_minus_SNo b HbS). }
      claim HsumS: SNo (add_SNo 1 (minus_SNo t)).
      { exact (SNo_add_SNo 1 (minus_SNo t) SNo_1 HmtS). }
      claim HltS: add_SNo 1 (minus_SNo t) < b.
      { exact (RltE_lt (add_SNo 1 (minus_SNo t)) b Hlt). }
      claim H1: add_SNo (add_SNo 1 (minus_SNo t)) t < add_SNo b t.
      { exact (add_SNo_Lt1 (add_SNo 1 (minus_SNo t)) t b HsumS HtS HbS HltS). }
      claim HeqL: add_SNo (add_SNo 1 (minus_SNo t)) t = 1.
      { rewrite <- (add_SNo_assoc 1 (minus_SNo t) t SNo_1 HmtS HtS).
        rewrite (add_SNo_minus_SNo_linv t HtS).
        exact (add_SNo_0R 1 SNo_1). }
      claim H2: 1 < add_SNo b t.
      { rewrite <- HeqL at 1.
        exact H1. }
      claim H2c: 1 < add_SNo t b.
      { rewrite <- (add_SNo_com b t HbS HtS).
        exact H2. }
      claim Hm1S: SNo (minus_SNo b).
      { exact HmbS. }
      claim H3: add_SNo 1 (minus_SNo b) < add_SNo (add_SNo t b) (minus_SNo b).
      { exact (add_SNo_Lt1 1 (minus_SNo b) (add_SNo t b)
               SNo_1 Hm1S (SNo_add_SNo t b HtS HbS) H2c). }
      claim HeqR: add_SNo (add_SNo t b) (minus_SNo b) = t.
      { rewrite <- (add_SNo_assoc t b (minus_SNo b) HtS HbS Hm1S).
        rewrite (add_SNo_minus_SNo_rinv b HbS).
        exact (add_SNo_0R t HtS). }
      claim H4: add_SNo 1 (minus_SNo b) < t.
      { rewrite <- HeqR.
        exact H3. }
      claim Hflip_bR: add_SNo 1 (minus_SNo b) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HbReal: b :e real.
        { rewrite <- HdefR.
          exact HbR. }
        claim HmbReal: (minus_SNo b) :e real.
        { exact (real_minus_SNo b HbReal). }
        exact (real_add_SNo 1 real_1 (minus_SNo b) HmbReal). }
      exact (RltI (add_SNo 1 (minus_SNo b)) t Hflip_bR HtR H4).
    - assume Hlt: Rlt (add_SNo 1 (minus_SNo b)) t.
      prove Rlt (add_SNo 1 (minus_SNo t)) b.
      claim HtS: SNo t.
      { exact (real_SNo t HtR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim HmtS: SNo (minus_SNo t).
      { exact (SNo_minus_SNo t HtS). }
      claim HmbS: SNo (minus_SNo b).
      { exact (SNo_minus_SNo b HbS). }
      claim HsumS: SNo (add_SNo 1 (minus_SNo b)).
      { exact (SNo_add_SNo 1 (minus_SNo b) SNo_1 HmbS). }
      claim HltS: add_SNo 1 (minus_SNo b) < t.
      { exact (RltE_lt (add_SNo 1 (minus_SNo b)) t Hlt). }
      claim H1: add_SNo (add_SNo 1 (minus_SNo b)) b < add_SNo t b.
      { exact (add_SNo_Lt1 (add_SNo 1 (minus_SNo b)) b t HsumS HbS HtS HltS). }
      claim HeqL: add_SNo (add_SNo 1 (minus_SNo b)) b = 1.
      { rewrite <- (add_SNo_assoc 1 (minus_SNo b) b SNo_1 HmbS HbS).
        rewrite (add_SNo_minus_SNo_linv b HbS).
        exact (add_SNo_0R 1 SNo_1). }
      claim H2: 1 < add_SNo t b.
      { rewrite <- HeqL at 1.
        exact H1. }
      claim H2c: 1 < add_SNo b t.
      { rewrite <- (add_SNo_com t b HtS HbS).
        exact H2. }
      claim Hm1S: SNo (minus_SNo t).
      { exact HmtS. }
      claim H3: add_SNo 1 (minus_SNo t) < add_SNo (add_SNo b t) (minus_SNo t).
      { exact (add_SNo_Lt1 1 (minus_SNo t) (add_SNo b t)
               SNo_1 Hm1S (SNo_add_SNo b t HbS HtS) H2c). }
      claim HeqR: add_SNo (add_SNo b t) (minus_SNo t) = b.
      { rewrite <- (add_SNo_assoc b t (minus_SNo t) HbS HtS Hm1S).
        rewrite (add_SNo_minus_SNo_rinv t HtS).
        exact (add_SNo_0R b HbS). }
      claim H4: add_SNo 1 (minus_SNo t) < b.
      { rewrite <- HeqR.
        exact H3. }
      claim Hflip_tR: add_SNo 1 (minus_SNo t) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HtReal: t :e real.
        { rewrite <- HdefR.
          exact HtR. }
        claim HmtReal: (minus_SNo t) :e real.
        { exact (real_minus_SNo t HtReal). }
        exact (real_add_SNo 1 real_1 (minus_SNo t) HmtReal). }
      exact (RltI (add_SNo 1 (minus_SNo t)) b Hflip_tR HbR H4). }

  claim HpreS: forall s:set, s :e S -> preimage_of unit_interval flip_unit_interval s :e Tx.
  { let s. assume HsS: s :e S.
    prove preimage_of unit_interval flip_unit_interval s :e Tx.
    apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                       :\/:
                       {I :e Power R | exists b :e R, I = open_ray_lower R b})
                      {R}
                      s
                      (preimage_of unit_interval flip_unit_interval s :e Tx)).
    - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                        :\/:
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}).
      apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}
                        s
                        (preimage_of unit_interval flip_unit_interval s :e Tx)).
      + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
        claim Hex: exists a :e R, s = open_ray_upper R a.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                      s Hsu). }
        apply Hex.
        let a. assume Hcore.
        apply Hcore.
        assume HaR: a :e R.
        assume Hseq: s = open_ray_upper R a.
        rewrite Hseq.
        set c := add_SNo 1 (minus_SNo a).
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HaReal: a :e real.
          { rewrite <- HdefR.
            exact HaR. }
          claim HmaReal: (minus_SNo a) :e real.
          { exact (real_minus_SNo a HaReal). }
          exact (real_add_SNo 1 real_1 (minus_SNo a) HmaReal). }

        claim HpreEq: preimage_of unit_interval flip_unit_interval (open_ray_upper R a)
                      = (open_ray_lower R c) :/\: unit_interval.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval flip_unit_interval (open_ray_upper R a).
            prove t :e (open_ray_lower R c) :/\: unit_interval.
            claim HtI: t :e unit_interval.
            { exact (SepE1 unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_upper R a) t Ht). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun flip_unit_interval t :e open_ray_upper R a.
            { exact (SepE2 unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_upper R a) t Ht). }
            claim Hrel: order_rel R a (apply_fun flip_unit_interval t).
            { exact (SepE2 R (fun x0 : set => order_rel R a x0) (apply_fun flip_unit_interval t) Himg). }
            claim Hrlt: Rlt a (apply_fun flip_unit_interval t).
            { exact (order_rel_R_implies_Rlt a (apply_fun flip_unit_interval t) Hrel). }
            claim Hrlt2: Rlt a (add_SNo 1 (minus_SNo t)).
            { rewrite <- (flip_unit_interval_apply t HtI).
              exact Hrlt. }
            claim Hrlt3: Rlt t c.
            { exact (iffEL (Rlt a (add_SNo 1 (minus_SNo t))) (Rlt t (add_SNo 1 (minus_SNo a)))
                          (Hflip_upper a t HaR HtR) Hrlt2). }
            claim Hrel2: order_rel R t c.
            { exact (Rlt_implies_order_rel_R t c Hrlt3). }
            claim HtRay: t :e open_ray_lower R c.
            { exact (SepI R (fun x0 : set => order_rel R x0 c) t HtR Hrel2). }
            exact (binintersectI (open_ray_lower R c) unit_interval t HtRay HtI).
          - let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval.
            prove t :e preimage_of unit_interval flip_unit_interval (open_ray_upper R a).
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval t Ht). }
            claim HtI: t :e unit_interval.
            { exact (binintersectE2 (open_ray_lower R c) unit_interval t Ht). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R t c.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 c) t HtRay). }
            claim Hrlt: Rlt t c.
            { exact (order_rel_R_implies_Rlt t c Hrel). }
            claim Hrlt2: Rlt a (add_SNo 1 (minus_SNo t)).
            { exact (iffER (Rlt a (add_SNo 1 (minus_SNo t))) (Rlt t (add_SNo 1 (minus_SNo a)))
                          (Hflip_upper a t HaR HtR) Hrlt). }
            claim Hrlt3: Rlt a (apply_fun flip_unit_interval t).
            { rewrite (flip_unit_interval_apply t HtI).
              exact Hrlt2. }
            claim Hrel2: order_rel R a (apply_fun flip_unit_interval t).
            { exact (Rlt_implies_order_rel_R a (apply_fun flip_unit_interval t) Hrlt3). }
            claim HimgR: apply_fun flip_unit_interval t :e R.
            { exact (HfunR t HtI). }
            claim Himg: apply_fun flip_unit_interval t :e open_ray_upper R a.
            { exact (SepI R (fun x0 : set => order_rel R a x0) (apply_fun flip_unit_interval t) HimgR Hrel2). }
            exact (SepI unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_upper R a) t HtI Himg). }

        rewrite HpreEq.
        set Z0 := open_ray_lower R c.
        claim HZ0open: Z0 :e R_standard_topology.
        { rewrite <- standard_topology_is_order_topology.
          claim HsRay: Z0 :e open_rays_subbasis R.
          { exact (open_ray_lower_in_open_rays_subbasis R c HcR). }
          exact (open_rays_subbasis_sub_order_topology_R Z0 HsRay). }
        claim HZ0cap: Z0 :/\: unit_interval :e Tx.
        { prove Z0 :/\: unit_interval :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim Hpow: Z0 :/\: unit_interval :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0 :/\: unit_interval.
            exact (binintersectE2 Z0 unit_interval t Ht). }
          claim Hex: exists Z :e R_standard_topology, Z0 :/\: unit_interval = Z :/\: unit_interval.
          { witness Z0.
            apply andI.
            - exact HZ0open.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      (Z0 :/\: unit_interval) Hpow Hex). }
        exact HZ0cap.
      + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
        claim Hex: exists b :e R, s = open_ray_lower R b.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                      s Hsl). }
        apply Hex.
        let b. assume Hcore.
        apply Hcore.
        assume HbR: b :e R.
        assume Hseq: s = open_ray_lower R b.
        rewrite Hseq.
        set c := add_SNo 1 (minus_SNo b).
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HbReal: b :e real.
          { rewrite <- HdefR.
            exact HbR. }
          claim HmbReal: (minus_SNo b) :e real.
          { exact (real_minus_SNo b HbReal). }
          exact (real_add_SNo 1 real_1 (minus_SNo b) HmbReal). }

        claim HpreEq: preimage_of unit_interval flip_unit_interval (open_ray_lower R b)
                      = (open_ray_upper R c) :/\: unit_interval.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval flip_unit_interval (open_ray_lower R b).
            prove t :e (open_ray_upper R c) :/\: unit_interval.
            claim HtI: t :e unit_interval.
            { exact (SepE1 unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_lower R b) t Ht). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun flip_unit_interval t :e open_ray_lower R b.
            { exact (SepE2 unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_lower R b) t Ht). }
            claim Hrel: order_rel R (apply_fun flip_unit_interval t) b.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 b) (apply_fun flip_unit_interval t) Himg). }
            claim Hrlt: Rlt (apply_fun flip_unit_interval t) b.
            { exact (order_rel_R_implies_Rlt (apply_fun flip_unit_interval t) b Hrel). }
            claim Hrlt2: Rlt (add_SNo 1 (minus_SNo t)) b.
            { rewrite <- (flip_unit_interval_apply t HtI).
              exact Hrlt. }
            claim Hrlt3: Rlt c t.
            { exact (iffEL (Rlt (add_SNo 1 (minus_SNo t)) b) (Rlt (add_SNo 1 (minus_SNo b)) t)
                          (Hflip_lower t b HtR HbR) Hrlt2). }
            claim Hrel2: order_rel R c t.
            { exact (Rlt_implies_order_rel_R c t Hrlt3). }
            claim HtRay: t :e open_ray_upper R c.
            { exact (SepI R (fun x0 : set => order_rel R c x0) t HtR Hrel2). }
            exact (binintersectI (open_ray_upper R c) unit_interval t HtRay HtI).
          - let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval.
            prove t :e preimage_of unit_interval flip_unit_interval (open_ray_lower R b).
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval t Ht). }
            claim HtI: t :e unit_interval.
            { exact (binintersectE2 (open_ray_upper R c) unit_interval t Ht). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R c t.
            { exact (SepE2 R (fun x0 : set => order_rel R c x0) t HtRay). }
            claim Hrlt: Rlt c t.
            { exact (order_rel_R_implies_Rlt c t Hrel). }
            claim Hrlt2: Rlt (add_SNo 1 (minus_SNo t)) b.
            { exact (iffER (Rlt (add_SNo 1 (minus_SNo t)) b) (Rlt (add_SNo 1 (minus_SNo b)) t)
                          (Hflip_lower t b HtR HbR) Hrlt). }
            claim Hrlt3: Rlt (apply_fun flip_unit_interval t) b.
            { rewrite (flip_unit_interval_apply t HtI).
              exact Hrlt2. }
            claim Hrel2: order_rel R (apply_fun flip_unit_interval t) b.
            { exact (Rlt_implies_order_rel_R (apply_fun flip_unit_interval t) b Hrlt3). }
            claim HimgR: apply_fun flip_unit_interval t :e R.
            { exact (HfunR t HtI). }
            claim Himg: apply_fun flip_unit_interval t :e open_ray_lower R b.
            { exact (SepI R (fun x0 : set => order_rel R x0 b) (apply_fun flip_unit_interval t) HimgR Hrel2). }
            exact (SepI unit_interval (fun u : set => apply_fun flip_unit_interval u :e open_ray_lower R b) t HtI Himg). }

        rewrite HpreEq.
        set Z0 := open_ray_upper R c.
        claim HZ0open: Z0 :e R_standard_topology.
        { rewrite <- standard_topology_is_order_topology.
          claim HsRay: Z0 :e open_rays_subbasis R.
          { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
          exact (open_rays_subbasis_sub_order_topology_R Z0 HsRay). }
        claim HZ0cap: Z0 :/\: unit_interval :e Tx.
        { prove Z0 :/\: unit_interval :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim Hpow: Z0 :/\: unit_interval :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0 :/\: unit_interval.
            exact (binintersectE2 Z0 unit_interval t Ht). }
          claim Hex: exists Z :e R_standard_topology, Z0 :/\: unit_interval = Z :/\: unit_interval.
          { witness Z0.
            apply andI.
            - exact HZ0open.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      (Z0 :/\: unit_interval) Hpow Hex). }
        exact HZ0cap.
      + exact Hs0.
    - assume HsR: s :e {R}.
      claim Hseq: s = R.
      { exact (SingE R s HsR). }
      rewrite Hseq.
      claim Heq: preimage_of unit_interval flip_unit_interval R = unit_interval.
      { exact (preimage_of_whole unit_interval R flip_unit_interval HfunR). }
      rewrite Heq.
      exact (topology_has_X unit_interval Tx HTx).
    - exact HsS. }

  exact (continuous_map_from_subbasis unit_interval Tx R S flip_unit_interval
          HTx HfunR HS HpreS). }

claim Himg: forall t:set, t :e unit_interval -> apply_fun flip_unit_interval t :e unit_interval.
{ let t. assume Ht: t :e unit_interval.
  exact (flip_unit_interval_function_on t Ht). }

exact (continuous_map_range_restrict unit_interval Tx R R_standard_topology flip_unit_interval unit_interval
        HcontR unit_interval_sub_R Himg).
Qed.

(** from §18 Definition: homeomorphism **) 
(** LATEX VERSION: A homeomorphism is a bijective continuous map whose inverse is continuous. **)
Definition homeomorphism : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty f =>
    continuous_map X Tx Y Ty f /\
    exists g:set, continuous_map Y Ty X Tx g /\
      (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
      (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).

(** Helper: extract continuous_map from homeomorphism **)
Theorem homeomorphism_continuous : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f -> continuous_map X Tx Y Ty f.
let X Tx Y Ty f.
assume H: homeomorphism X Tx Y Ty f.
exact (andEL (continuous_map X Tx Y Ty f)
             (exists g:set, continuous_map Y Ty X Tx g /\
               (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
               (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
             H).
Qed.

(** Helper: extract existence of inverse package from homeomorphism **)
Theorem homeomorphism_inverse_package : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f ->
  exists g:set, continuous_map Y Ty X Tx g /\
    (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
    (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
let X Tx Y Ty f.
assume H: homeomorphism X Tx Y Ty f.
exact (andER (continuous_map X Tx Y Ty f)
             (exists g:set, continuous_map Y Ty X Tx g /\
               (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
               (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
             H).
Qed.

(** helper: homeomorphism implies both are topological spaces **)
Theorem homeomorphism_topology_left : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f -> topology_on X Tx.
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
exact (continuous_map_topology_dom X Tx Y Ty f (homeomorphism_continuous X Tx Y Ty f Hhom)).
Qed.

Theorem homeomorphism_topology_right : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f -> topology_on Y Ty.
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
exact (continuous_map_topology_cod X Tx Y Ty f (homeomorphism_continuous X Tx Y Ty f Hhom)).
Qed.

(** from §16 Exercise 8: helper definition of straight line by affine equation **)
(** LATEX VERSION: A straight line in R×R can be described by an affine equation ax+by=c with not both a and b zero. **)
Definition affine_line_R2 : set -> set -> set -> set :=
  fun a b c =>
    {p :e EuclidPlane |
      add_SNo (mul_SNo a (R2_xcoord p)) (mul_SNo b (R2_ycoord p)) = c}.

(** Helper: affine_line_R2 is a subset of EuclidPlane **)
Theorem affine_line_R2_subset : forall a b c:set, affine_line_R2 a b c c= EuclidPlane.
let a b c.
prove affine_line_R2 a b c c= EuclidPlane.
let p.
assume Hp: p :e affine_line_R2 a b c.
exact (SepE1 EuclidPlane
         (fun p0:set => add_SNo (mul_SNo a (R2_xcoord p0)) (mul_SNo b (R2_ycoord p0)) = c)
         p Hp).
Qed.

(** Helper: affine_line_R2 is in Power EuclidPlane **)
Theorem affine_line_R2_in_Power : forall a b c:set, affine_line_R2 a b c :e Power EuclidPlane.
let a b c.
exact (PowerI EuclidPlane (affine_line_R2 a b c) (affine_line_R2_subset a b c)).
Qed.

(** Helper: affine_line_R2 is a subset of setprod R R **)
Theorem affine_line_R2_subset_R2 : forall a b c:set, affine_line_R2 a b c c= setprod R R.
let a b c.
claim Heq: EuclidPlane = setprod R R.
{ reflexivity. }
rewrite <- Heq.
exact (affine_line_R2_subset a b c).
Qed.

(** Helper: affine_line_R2 is in Power (setprod R R) **)
Theorem affine_line_R2_in_Power_R2 : forall a b c:set, affine_line_R2 a b c :e Power (setprod R R).
let a b c.
exact (PowerI (setprod R R) (affine_line_R2 a b c) (affine_line_R2_subset_R2 a b c)).
Qed.

(** from §16 Exercise 8: parametrizations of affine lines **)
(** LATEX VERSION: For ax+by=c, if b is not zero one can solve for y as a function of x; if b=0 one can solve for x as a constant and parametrize by y. **)
Definition affine_line_R2_param_by_x : set -> set -> set -> set :=
  fun a b c =>
    graph R (fun x:set => (x, div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b)).

Definition affine_line_R2_param_by_y : set -> set -> set -> set :=
  fun a b c =>
    graph R (fun y:set => (div_SNo c a, y)).

(** Helper: apply_fun on affine_line_R2_param_by_x **)
Theorem affine_line_R2_param_by_x_apply : forall a b c x:set,
  x :e R ->
  apply_fun (affine_line_R2_param_by_x a b c) x =
    (x, div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b).
let a b c x.
assume HxR: x :e R.
exact (apply_fun_graph R (fun x0:set => (x0, div_SNo (add_SNo c (minus_SNo (mul_SNo a x0))) b)) x HxR).
Qed.
(** Helper: apply_fun on affine_line_R2_param_by_y **)
Theorem affine_line_R2_param_by_y_apply : forall a b c y:set,
  y :e R ->
  apply_fun (affine_line_R2_param_by_y a b c) y = (div_SNo c a, y).
let a b c y.
assume HyR: y :e R.
exact (apply_fun_graph R (fun y0:set => (div_SNo c a, y0)) y HyR).
Qed.

(** Helper: projection2 composed with affine_line_R2_param_by_y is the identity on R **)
Theorem projection2_after_affine_line_R2_param_by_y : forall a b c y:set,
  a :e R -> c :e R -> y :e R ->
  apply_fun (projection2 R R) (apply_fun (affine_line_R2_param_by_y a b c) y) = y.
let a b c y.
assume HaR: a :e R.
assume HcR: c :e R.
assume HyR: y :e R.
rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
set x0 := div_SNo c a.
claim Hx0R: x0 :e R.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim Hx0Real: x0 :e real.
  { exact (real_div_SNo c HcReal a HaReal). }
  rewrite HdefR.
  exact Hx0Real. }
claim Hxy: (x0,y) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R x0 y Hx0R HyR). }
claim Happ2: apply_fun (projection2 R R) (x0,y) = (x0,y) 1.
{ exact (projection2_apply R R (x0,y) Hxy). }
rewrite Happ2.
exact (tuple_2_1_eq x0 y).
Qed.

(** Helper: affine_line_R2_param_by_y after projection2 is identity on the vertical slice **)
Theorem affine_line_R2_param_by_y_after_projection2_on_slice : forall a b c p:set,
  a :e R -> c :e R ->
  p :e setprod {div_SNo c a} R ->
  apply_fun (affine_line_R2_param_by_y a b c) (apply_fun (projection2 R R) p) = p.
let a b c p.
assume HaR: a :e R.
assume HcR: c :e R.
assume Hp: p :e setprod {div_SNo c a} R.
set x0 := div_SNo c a.
claim Hp0Sing: (p 0) :e {x0}.
{ exact (ap0_Sigma {x0} (fun _ : set => R) p Hp). }
claim Hp1R: (p 1) :e R.
{ exact (ap1_Sigma {x0} (fun _ : set => R) p Hp). }
claim Hp0eq: (p 0) = x0.
{ exact (singleton_elem (p 0) x0 Hp0Sing). }
claim Heta: p = (p 0, p 1).
{ exact (setprod_eta {x0} R p Hp). }
claim HpRR: p :e setprod R R.
{ claim HSingSub: {x0} c= R.
  { claim HdefR: R = real.
    { reflexivity. }
    claim HaReal: a :e real.
    { rewrite <- HdefR. exact HaR. }
    claim HcReal: c :e real.
    { rewrite <- HdefR. exact HcR. }
    claim Hx0Real: x0 :e real.
    { exact (real_div_SNo c HcReal a HaReal). }
    claim Hx0R: x0 :e R.
    { rewrite HdefR. exact Hx0Real. }
    exact (singleton_subset x0 R Hx0R). }
  exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p Hp). }
claim Happ2: apply_fun (projection2 R R) p = p 1.
{ exact (projection2_apply R R p HpRR). }
rewrite Happ2.
rewrite (affine_line_R2_param_by_y_apply a b c (p 1) Hp1R).
rewrite <- Hp0eq.
rewrite <- Heta.
reflexivity.
Qed.

(** Helper: affine_line_R2_param_by_x maps into EuclidPlane **)
Theorem affine_line_R2_param_by_x_function_on : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  function_on (affine_line_R2_param_by_x a b c) R EuclidPlane.
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
let x. assume HxR: x :e R.
prove apply_fun (affine_line_R2_param_by_x a b c) x :e EuclidPlane.
rewrite (affine_line_R2_param_by_x_apply a b c x HxR).
claim HdefR: R = real.
{ reflexivity. }
claim HaReal: a :e real.
{ rewrite <- HdefR. exact HaR. }
claim HbReal: b :e real.
{ rewrite <- HdefR. exact HbR. }
claim HcReal: c :e real.
{ rewrite <- HdefR. exact HcR. }
claim HxReal: x :e real.
{ rewrite <- HdefR. exact HxR. }
claim HmulReal: mul_SNo a x :e real.
{ exact (real_mul_SNo a HaReal x HxReal). }
claim HmReal: minus_SNo (mul_SNo a x) :e real.
{ exact (real_minus_SNo (mul_SNo a x) HmulReal). }
claim HnumReal: add_SNo c (minus_SNo (mul_SNo a x)) :e real.
{ exact (real_add_SNo c HcReal (minus_SNo (mul_SNo a x)) HmReal). }
claim HdivReal: div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b :e real.
{ exact (real_div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) HnumReal b HbReal). }
claim HdivR: div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b :e R.
{ rewrite HdefR. exact HdivReal. }
exact (tuple_2_setprod_by_pair_Sigma R R x (div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b) HxR HdivR).
Qed.

(** Helper: projection1 composed with affine_line_R2_param_by_x is the identity on R **)
Theorem projection1_after_affine_line_R2_param_by_x : forall a b c x:set,
  a :e R -> b :e R -> c :e R -> x :e R ->
  apply_fun (projection1 R R) (apply_fun (affine_line_R2_param_by_x a b c) x) = x.
let a b c x.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume HxR: x :e R.
set f := affine_line_R2_param_by_x a b c.
claim Hfx: apply_fun f x :e EuclidPlane.
{ exact (affine_line_R2_param_by_x_function_on a b c HaR HbR HcR x HxR). }
claim Happ1: apply_fun (projection1 R R) (apply_fun f x) = (apply_fun f x) 0.
{ exact (projection1_apply R R (apply_fun f x) Hfx). }
rewrite Happ1.
rewrite (affine_line_R2_param_by_x_apply a b c x HxR).
exact (tuple_2_0_eq x (div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b)).
Qed.

(** Helper: affine_line_R2_param_by_y maps into EuclidPlane **)
Theorem affine_line_R2_param_by_y_function_on : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  function_on (affine_line_R2_param_by_y a b c) R EuclidPlane.
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
let y. assume HyR: y :e R.
prove apply_fun (affine_line_R2_param_by_y a b c) y :e EuclidPlane.
rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
claim HdefR: R = real.
{ reflexivity. }
claim HaReal: a :e real.
{ rewrite <- HdefR. exact HaR. }
claim HcReal: c :e real.
{ rewrite <- HdefR. exact HcR. }
claim HdivReal: div_SNo c a :e real.
{ exact (real_div_SNo c HcReal a HaReal). }
claim HdivR: div_SNo c a :e R.
{ rewrite HdefR. exact HdivReal. }
exact (tuple_2_setprod_by_pair_Sigma R R (div_SNo c a) y HdivR HyR).
Qed.

(** Helper: projection1 is continuous for the product topology **)
(** LATEX VERSION: Coordinate projections are continuous for the product topology. **)
Theorem projection1_continuous_in_product : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection1 X Y).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection1 X Y).
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\ topology_on X Tx /\
  function_on (projection1 X Y) (setprod X Y) X /\
  forall U:set, U :e Tx -> preimage_of (setprod X Y) (projection1 X Y) U :e product_topology X Tx Y Ty.
apply andI.
- apply andI.
  + apply andI.
    * exact (product_topology_is_topology X Tx Y Ty HTx HTy).
    * exact HTx.
  + (** function_on **)
    let p. assume Hp: p :e setprod X Y.
    prove apply_fun (projection1 X Y) p :e X.
    claim Happ: apply_fun (projection1 X Y) p = p 0.
    { exact (projection1_apply X Y p Hp). }
    rewrite Happ.
    exact (ap0_Sigma X (fun _ : set => Y) p Hp).
- let U. assume HU: U :e Tx.
  prove preimage_of (setprod X Y) (projection1 X Y) U :e product_topology X Tx Y Ty.
  claim HUsub: U c= X.
  { exact (topology_elem_subset X Tx U HTx HU). }
  claim HpreEq: preimage_of (setprod X Y) (projection1 X Y) U = rectangle_set U Y.
  { exact (preimage_projection1_rectangle X Y U HUsub). }
  rewrite HpreEq.
  claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HYTy: Y :e Ty.
  { exact (topology_has_X Y Ty HTy). }
  claim HRsub: rectangle_set U Y :e product_subbasis X Tx Y Ty.
  { claim HRfam: rectangle_set U Y :e {rectangle_set U V0|V0 :e Ty}.
    { exact (ReplI Ty (fun V0:set => rectangle_set U V0) Y HYTy). }
    exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) U (rectangle_set U Y) HU HRfam). }
  exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis (rectangle_set U Y) HRsub).
Qed.

(** Helper: projection2 is continuous for the product topology **)
(** LATEX VERSION: Coordinate projections are continuous for the product topology. **)
Theorem projection2_continuous_in_product : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection2 X Y).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection2 X Y).
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\ topology_on Y Ty /\
  function_on (projection2 X Y) (setprod X Y) Y /\
  forall V:set, V :e Ty -> preimage_of (setprod X Y) (projection2 X Y) V :e product_topology X Tx Y Ty.
apply andI.
- apply andI.
  + apply andI.
    * exact (product_topology_is_topology X Tx Y Ty HTx HTy).
    * exact HTy.
  + (** function_on **)
    let p. assume Hp: p :e setprod X Y.
    prove apply_fun (projection2 X Y) p :e Y.
    claim Happ: apply_fun (projection2 X Y) p = p 1.
    { exact (projection2_apply X Y p Hp). }
    rewrite Happ.
    exact (ap1_Sigma X (fun _ : set => Y) p Hp).
- let V. assume HV: V :e Ty.
  prove preimage_of (setprod X Y) (projection2 X Y) V :e product_topology X Tx Y Ty.
  claim HVsub: V c= Y.
  { exact (topology_elem_subset Y Ty V HTy HV). }
  claim HpreEq: preimage_of (setprod X Y) (projection2 X Y) V = rectangle_set X V.
  { exact (preimage_projection2_rectangle X Y V HVsub). }
  rewrite HpreEq.
  claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HXTx: X :e Tx.
  { exact (topology_has_X X Tx HTx). }
  claim HRsub: rectangle_set X V :e product_subbasis X Tx Y Ty.
  { claim HRfam: rectangle_set X V :e {rectangle_set X V0|V0 :e Ty}.
    { exact (ReplI Ty (fun V0:set => rectangle_set X V0) V HV). }
    exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) X (rectangle_set X V) HXTx HRfam). }
  exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis (rectangle_set X V) HRsub).
Qed.

(** Helper: projection2 is continuous on a vertical slice as a subspace **)
(** LATEX VERSION: The projection to the second factor is continuous when restricted to any vertical slice {x0}×Y with the subspace topology. **)
Theorem projection2_continuous_on_vertical_slice : forall x0 Tx Ty:set,
  topology_on R Tx -> topology_on R Ty -> x0 :e R ->
  continuous_map (setprod {x0} R)
    (subspace_topology EuclidPlane (product_topology R Tx R Ty) (setprod {x0} R))
    R Ty (projection2 R R).
let x0 Tx Ty.
assume HTx: topology_on R Tx.
assume HTy: topology_on R Ty.
assume Hx0R: x0 :e R.
set X := EuclidPlane.
set A := setprod {x0} R.
set Tprod := product_topology R Tx R Ty.
set Ta := subspace_topology X Tprod A.
claim HTprod: topology_on X Tprod.
{ exact (product_topology_is_topology R Tx R Ty HTx HTy). }
claim HAsub: A c= X.
{ let p. assume HpA: p :e A.
  prove p :e X.
  claim HSingSub: {x0} c= R.
  { exact (singleton_subset x0 R Hx0R). }
  exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p HpA). }
claim HTa: topology_on A Ta.
{ exact (subspace_topology_is_topology X Tprod A HTprod HAsub). }
prove continuous_map A Ta R Ty (projection2 R R).
prove topology_on A Ta /\ topology_on R Ty /\ function_on (projection2 R R) A R /\
  forall V:set, V :e Ty -> preimage_of A (projection2 R R) V :e Ta.
apply andI.
- apply andI.
  + apply andI.
    * exact HTa.
    * exact HTy.
  + (** function_on **)
    let p. assume HpA: p :e A.
    prove apply_fun (projection2 R R) p :e R.
    claim HpRR: p :e setprod R R.
    { claim HSingSub: {x0} c= R.
      { exact (singleton_subset x0 R Hx0R). }
      exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p HpA). }
    claim Happ: apply_fun (projection2 R R) p = p 1.
    { exact (projection2_apply R R p HpRR). }
    rewrite Happ.
    exact (ap1_Sigma {x0} (fun _ : set => R) p HpA).
- let V. assume HV: V :e Ty.
  prove preimage_of A (projection2 R R) V :e Ta.
  set U := preimage_of X (projection2 R R) V.
  claim HcontFull: continuous_map X Tprod R Ty (projection2 R R).
  { exact (projection2_continuous_in_product R Tx R Ty HTx HTy). }
  claim HUopen: U :e Tprod.
  { exact (continuous_map_preimage X Tprod R Ty (projection2 R R) HcontFull V HV). }
  claim HeqPre: preimage_of A (projection2 R R) V = U :/\: A.
  { apply set_ext.
    - let p. assume Hp: p :e preimage_of A (projection2 R R) V.
      prove p :e U :/\: A.
      claim HpA: p :e A.
      { exact (SepE1 A (fun q:set => apply_fun (projection2 R R) q :e V) p Hp). }
      claim HpRR: p :e setprod R R.
      { claim HSingSub: {x0} c= R.
        { exact (singleton_subset x0 R Hx0R). }
        exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p HpA). }
      claim HprojV: apply_fun (projection2 R R) p :e V.
      { exact (SepE2 A (fun q:set => apply_fun (projection2 R R) q :e V) p Hp). }
      claim HpX: p :e X.
      { exact HpRR. }
      claim HpU: p :e U.
      { exact (SepI X (fun q:set => apply_fun (projection2 R R) q :e V) p HpX HprojV). }
      exact (binintersectI U A p HpU HpA).
    - let p. assume Hp: p :e U :/\: A.
      prove p :e preimage_of A (projection2 R R) V.
      claim HpU: p :e U.
      { exact (binintersectE1 U A p Hp). }
      claim HpA: p :e A.
      { exact (binintersectE2 U A p Hp). }
      claim HprojV: apply_fun (projection2 R R) p :e V.
      { exact (SepE2 X (fun q:set => apply_fun (projection2 R R) q :e V) p HpU). }
      exact (SepI A (fun q:set => apply_fun (projection2 R R) q :e V) p HpA HprojV). }
  rewrite HeqPre.
  claim Hpow: (U :/\: A) :e Power A.
  { apply PowerI.
    let p. assume Hp: p :e U :/\: A.
    exact (binintersectE2 U A p Hp). }
  claim HexW: exists W :e Tprod, U :/\: A = W :/\: A.
  { witness U.
    apply andI.
    - exact HUopen.
    - reflexivity. }
  exact (SepI (Power A) (fun U0:set => exists W :e Tprod, U0 = W :/\: A) (U :/\: A) Hpow HexW).
Qed.

(** Helper: affine_line_R2_param_by_y is continuous into product_topology, with the domain using the second-factor topology **)
(** LATEX VERSION: The map y ↦ (x0,y) is continuous into a product topology, since the preimage of each basic rectangle is either the corresponding second-factor open set or empty. **)
Theorem affine_line_R2_param_by_y_continuous_in_product : forall a b c Tx Ty:set,
  topology_on R Tx -> topology_on R Ty ->
  a :e R -> c :e R ->
  continuous_map R Ty EuclidPlane (product_topology R Tx R Ty) (affine_line_R2_param_by_y a b c).
let a b c Tx Ty.
assume HTx: topology_on R Tx.
assume HTy: topology_on R Ty.
assume HaR: a :e R.
assume HcR: c :e R.
set f := affine_line_R2_param_by_y a b c.
set X := EuclidPlane.
set Tprod := product_topology R Tx R Ty.
prove continuous_map R Ty X Tprod f.
prove topology_on R Ty /\ topology_on X Tprod /\ function_on f R X /\
  forall W:set, W :e Tprod -> preimage_of R f W :e Ty.
apply andI.
- apply andI.
  + apply andI.
    * exact HTy.
    * exact (product_topology_is_topology R Tx R Ty HTx HTy).
  + (** function_on **)
    let y. assume HyR: y :e R.
    prove apply_fun f y :e X.
    rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
    claim HdefR: R = real.
    { reflexivity. }
    claim HaReal: a :e real.
    { rewrite <- HdefR. exact HaR. }
    claim HcReal: c :e real.
    { rewrite <- HdefR. exact HcR. }
    claim Hx0Real: div_SNo c a :e real.
    { exact (real_div_SNo c HcReal a HaReal). }
    claim Hx0R: div_SNo c a :e R.
    { rewrite HdefR. exact Hx0Real. }
    exact (tuple_2_setprod_by_pair_Sigma R R (div_SNo c a) y Hx0R HyR).
- let W. assume HW: W :e Tprod.
  prove preimage_of R f W :e Ty.
  claim HBasis: basis_on X (product_subbasis R Tx R Ty).
  { exact (product_subbasis_is_basis R Tx R Ty HTx HTy). }
  claim HWopen: open_in X Tprod W.
  { exact (andI (topology_on X Tprod) (W :e Tprod)
                (product_topology_is_topology R Tx R Ty HTx HTy) HW). }
  apply (open_sets_as_unions_of_basis X (product_subbasis R Tx R Ty) HBasis W HWopen).
  let Fam. assume HFamPair.
  claim HFamPow: Fam :e Power (product_subbasis R Tx R Ty).
  { exact (andEL (Fam :e Power (product_subbasis R Tx R Ty)) (Union Fam = W) HFamPair). }
  claim HUnionEq: Union Fam = W.
  { exact (andER (Fam :e Power (product_subbasis R Tx R Ty)) (Union Fam = W) HFamPair). }
  claim HFamSub: Fam c= product_subbasis R Tx R Ty.
  { exact (PowerE (product_subbasis R Tx R Ty) Fam HFamPow). }
  set PreFam := {preimage_of R f b0|b0 :e Fam}.
  claim HpreEq1: preimage_of R f W = preimage_of R f (Union Fam).
  { rewrite <- HUnionEq.
    reflexivity. }
  claim HpreEq2: preimage_of R f (Union Fam) = Union PreFam.
  { rewrite (preimage_of_Union R f Fam).
    reflexivity. }
  rewrite HpreEq1.
  rewrite HpreEq2.
  claim HPreFamSub: PreFam c= Ty.
  { let P. assume HP: P :e PreFam.
    apply (ReplE_impred Fam (fun b0:set => preimage_of R f b0) P HP).
    let b0. assume Hb0Fam: b0 :e Fam.
    assume HPeq: P = preimage_of R f b0.
    claim Hb0Sub: b0 :e product_subbasis R Tx R Ty.
    { exact (HFamSub b0 Hb0Fam). }
    claim HexU: exists U :e Tx, b0 :e {rectangle_set U V|V :e Ty}.
    { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b0 Hb0Sub). }
    apply HexU.
    let U. assume HUconj: U :e Tx /\ b0 :e {rectangle_set U V|V :e Ty}.
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (b0 :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim Hb0Repl: b0 :e {rectangle_set U V|V :e Ty}.
    { exact (andER (U :e Tx) (b0 :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim HexV: exists V :e Ty, b0 = rectangle_set U V.
    { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b0 Hb0Repl). }
    apply HexV.
    let V. assume HVconj: V :e Ty /\ b0 = rectangle_set U V.
    claim HV: V :e Ty.
    { exact (andEL (V :e Ty) (b0 = rectangle_set U V) HVconj). }
    claim Hbeq: b0 = rectangle_set U V.
    { exact (andER (V :e Ty) (b0 = rectangle_set U V) HVconj). }
    rewrite HPeq.
    rewrite Hbeq.
    set x0 := div_SNo c a.
    claim Hx0R: x0 :e R.
    { claim HdefR: R = real.
      { reflexivity. }
      claim HaReal: a :e real.
      { rewrite <- HdefR. exact HaR. }
      claim HcReal: c :e real.
      { rewrite <- HdefR. exact HcR. }
      claim Hx0Real: x0 :e real.
      { exact (real_div_SNo c HcReal a HaReal). }
      rewrite HdefR.
      exact Hx0Real. }
    apply (xm (x0 :e U)).
    - assume Hx0U: x0 :e U.
      claim HVR: V c= R.
      { exact (topology_elem_subset R Ty V HTy HV). }
      claim HeqPre: preimage_of R f (rectangle_set U V) = V.
      { apply set_ext.
        - let y. assume Hy: y :e preimage_of R f (rectangle_set U V).
          prove y :e V.
          claim HyR: y :e R.
          { exact (SepE1 R (fun y0:set => apply_fun f y0 :e rectangle_set U V) y Hy). }
          claim Hfy: apply_fun f y :e rectangle_set U V.
          { exact (SepE2 R (fun y0:set => apply_fun f y0 :e rectangle_set U V) y Hy). }
          claim Happ: apply_fun f y = (x0,y).
          { rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
            reflexivity. }
          claim Hxy: (x0,y) :e rectangle_set U V.
          { rewrite <- Happ.
            exact Hfy. }
          claim HyV0: (x0,y) 1 :e V.
          { exact (ap1_Sigma U (fun _ : set => V) (x0,y) Hxy). }
          claim HyV: y :e V.
          { rewrite <- (tuple_2_1_eq x0 y).
            exact HyV0. }
          exact HyV.
        - let y. assume HyV: y :e V.
          prove y :e preimage_of R f (rectangle_set U V).
          claim HyR: y :e R.
          { exact (HVR y HyV). }
	          claim Hxy: (x0,y) :e rectangle_set U V.
	          { exact (tuple_2_rectangle_set U V x0 y Hx0U HyV). }
          claim Happ: apply_fun f y = (x0,y).
          { rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
            reflexivity. }
          claim Hprop: apply_fun f y :e rectangle_set U V.
          { rewrite Happ.
            exact Hxy. }
          exact (SepI R (fun y0:set => apply_fun f y0 :e rectangle_set U V) y HyR Hprop). }
      rewrite HeqPre.
      exact HV.
    - assume Hx0notU: ~ (x0 :e U).
      claim HeqPre: preimage_of R f (rectangle_set U V) = Empty.
      { apply set_ext.
        - let y. assume Hy: y :e preimage_of R f (rectangle_set U V).
          apply FalseE.
          claim HyR: y :e R.
          { exact (SepE1 R (fun y0:set => apply_fun f y0 :e rectangle_set U V) y Hy). }
          claim Hfy: apply_fun f y :e rectangle_set U V.
          { exact (SepE2 R (fun y0:set => apply_fun f y0 :e rectangle_set U V) y Hy). }
          claim Happ: apply_fun f y = (x0,y).
          { rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
            reflexivity. }
          claim Hxy: (x0,y) :e rectangle_set U V.
          { rewrite <- Happ.
            exact Hfy. }
          claim Hx0U0: (x0,y) 0 :e U.
          { exact (ap0_Sigma U (fun _ : set => V) (x0,y) Hxy). }
          claim Hx0U: x0 :e U.
          { rewrite <- (tuple_2_0_eq x0 y).
            exact Hx0U0. }
          exact (Hx0notU Hx0U).
        - let y. assume Hy: y :e Empty.
          apply FalseE.
          exact (EmptyE y Hy). }
      rewrite HeqPre.
      exact (topology_has_empty R Ty HTy). }
  claim HPreFamPow: PreFam :e Power Ty.
  { apply PowerI.
    exact HPreFamSub. }
  exact (topology_union_axiom R Ty HTy PreFam HPreFamPow).
Qed.

(** Helper: param by x lands in the affine line when b is not zero **)
Theorem affine_line_R2_param_by_x_in_line : forall a b c x:set,
  a :e R -> b :e R -> c :e R -> x :e R ->
  b <> 0 ->
  apply_fun (affine_line_R2_param_by_x a b c) x :e affine_line_R2 a b c.
let a b c x.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume HxR: x :e R.
assume Hb0: b <> 0.
prove apply_fun (affine_line_R2_param_by_x a b c) x :e affine_line_R2 a b c.
rewrite (affine_line_R2_param_by_x_apply a b c x HxR).
set y := div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b.
claim Hydef: y = div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b.
{ reflexivity. }
rewrite <- Hydef.
prove (x,y) :e affine_line_R2 a b c.
claim Hdef: affine_line_R2 a b c =
  {p :e EuclidPlane | add_SNo (mul_SNo a (R2_xcoord p)) (mul_SNo b (R2_ycoord p)) = c}.
{ reflexivity. }
rewrite Hdef.
claim HxyPlane: (x,y) :e EuclidPlane.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HbReal: b :e real.
  { rewrite <- HdefR. exact HbR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim HxReal: x :e real.
  { rewrite <- HdefR. exact HxR. }
  claim HmulReal: mul_SNo a x :e real.
  { exact (real_mul_SNo a HaReal x HxReal). }
  claim HmReal: minus_SNo (mul_SNo a x) :e real.
  { exact (real_minus_SNo (mul_SNo a x) HmulReal). }
  claim HnumReal: add_SNo c (minus_SNo (mul_SNo a x)) :e real.
  { exact (real_add_SNo c HcReal (minus_SNo (mul_SNo a x)) HmReal). }
  claim HyReal: y :e real.
  { rewrite Hydef.
    exact (real_div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) HnumReal b HbReal). }
  claim HyR: y :e R.
  { rewrite HdefR. exact HyReal. }
  exact (tuple_2_setprod_by_pair_Sigma R R x y HxR HyR). }

claim Hprop: add_SNo (mul_SNo a (R2_xcoord (x,y))) (mul_SNo b (R2_ycoord (x,y))) = c.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HbReal: b :e real.
  { rewrite <- HdefR. exact HbR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim HxReal: x :e real.
  { rewrite <- HdefR. exact HxR. }
  claim HaS: SNo a.
  { exact (real_SNo a HaReal). }
  claim HbS: SNo b.
  { exact (real_SNo b HbReal). }
  claim HcS: SNo c.
  { exact (real_SNo c HcReal). }
  claim HxS: SNo x.
  { exact (real_SNo x HxReal). }
  claim HaxS: SNo (mul_SNo a x).
  { exact (SNo_mul_SNo a x HaS HxS). }
  claim HnumS: SNo (add_SNo c (minus_SNo (mul_SNo a x))).
  { exact (SNo_add_SNo c (minus_SNo (mul_SNo a x)) HcS (SNo_minus_SNo (mul_SNo a x) HaxS)). }
  claim HyS: SNo y.
  { rewrite Hydef.
    exact (SNo_div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b HnumS HbS). }
  claim Hbmul: mul_SNo b y = add_SNo c (minus_SNo (mul_SNo a x)).
  { rewrite Hydef.
    rewrite (mul_div_SNo_invR (add_SNo c (minus_SNo (mul_SNo a x))) b HnumS HbS Hb0).
    reflexivity. }
  rewrite (R2_xcoord_tuple x y).
  rewrite (R2_ycoord_tuple x y).
  rewrite Hbmul.
  (** simplify ax + (c - ax) = c **)
  claim HaxS2: SNo (mul_SNo a x).
  { exact HaxS. }
  claim HmAxS: SNo (minus_SNo (mul_SNo a x)).
  { exact (SNo_minus_SNo (mul_SNo a x) HaxS2). }
  rewrite (add_SNo_assoc (mul_SNo a x) c (minus_SNo (mul_SNo a x)) HaxS2 HcS HmAxS).
  rewrite (add_SNo_com (mul_SNo a x) c HaxS2 HcS).
  rewrite <- (add_SNo_assoc c (mul_SNo a x) (minus_SNo (mul_SNo a x)) HcS HaxS2 HmAxS).
  rewrite (add_SNo_minus_SNo_rinv (mul_SNo a x) HaxS2).
  exact (add_SNo_0R c HcS). }

exact (SepI EuclidPlane
        (fun p0:set => add_SNo (mul_SNo a (R2_xcoord p0)) (mul_SNo b (R2_ycoord p0)) = c)
        (x,y)
        HxyPlane
        Hprop).
Qed.

(** Helper: affine_line_R2_param_by_x after projection1 is identity on the line (when b is not zero) **)
Theorem affine_line_R2_param_by_x_after_projection1_on_line : forall a b c p:set,
  a :e R -> b :e R -> c :e R -> b <> 0 ->
  p :e affine_line_R2 a b c ->
  apply_fun (affine_line_R2_param_by_x a b c) (apply_fun (projection1 R R) p) = p.
let a b c p.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hbne: b <> 0.
assume Hp: p :e affine_line_R2 a b c.
prove apply_fun (affine_line_R2_param_by_x a b c) (apply_fun (projection1 R R) p) = p.
claim HpRR: p :e setprod R R.
{ exact (affine_line_R2_subset_R2 a b c p Hp). }
claim Hpeta: p = (p 0, p 1).
{ exact (setprod_eta R R p HpRR). }
claim Hp0R: p 0 :e R.
{ exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
claim Hp1R: p 1 :e R.
{ exact (ap1_Sigma R (fun _ : set => R) p HpRR). }
claim Happ1: apply_fun (projection1 R R) p = p 0.
{ exact (projection1_apply R R p HpRR). }
rewrite Happ1.
rewrite (affine_line_R2_param_by_x_apply a b c (p 0) Hp0R).
rewrite Hpeta at 3.
claim Hycoord: div_SNo (add_SNo c (minus_SNo (mul_SNo a (p 0)))) b = p 1.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HbReal: b :e real.
  { rewrite <- HdefR. exact HbR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim Hp0Real: p 0 :e real.
  { rewrite <- HdefR. exact Hp0R. }
  claim Hp1Real: p 1 :e real.
  { rewrite <- HdefR. exact Hp1R. }
  claim HaS: SNo a.
  { exact (real_SNo a HaReal). }
  claim HbS: SNo b.
  { exact (real_SNo b HbReal). }
  claim HcS: SNo c.
  { exact (real_SNo c HcReal). }
  claim Hp0S: SNo (p 0).
  { exact (real_SNo (p 0) Hp0Real). }
  claim Hp1S: SNo (p 1).
  { exact (real_SNo (p 1) Hp1Real). }
  claim HaxS: SNo (mul_SNo a (p 0)).
  { exact (SNo_mul_SNo a (p 0) HaS Hp0S). }
  claim HbyS: SNo (mul_SNo b (p 1)).
  { exact (SNo_mul_SNo b (p 1) HbS Hp1S). }
  claim HmAxS: SNo (minus_SNo (mul_SNo a (p 0))).
  { exact (SNo_minus_SNo (mul_SNo a (p 0)) HaxS). }
  claim Hline0:
    add_SNo (mul_SNo a (R2_xcoord p)) (mul_SNo b (R2_ycoord p)) = c.
  { exact (SepE2 EuclidPlane
           (fun p0:set => add_SNo (mul_SNo a (R2_xcoord p0)) (mul_SNo b (R2_ycoord p0)) = c)
           p
           Hp). }
  claim Hline:
    add_SNo (mul_SNo a (p 0)) (mul_SNo b (p 1)) = c.
  { claim Hxcoord: R2_xcoord p = p 0.
    { reflexivity. }
    claim Hycoord0: R2_ycoord p = p 1.
    { reflexivity. }
    rewrite <- Hxcoord.
    rewrite <- Hycoord0.
    exact Hline0. }
  claim HbyEq: add_SNo c (minus_SNo (mul_SNo a (p 0))) = mul_SNo b (p 1).
  { rewrite <- Hline at 1.
    rewrite <- (add_SNo_assoc (mul_SNo a (p 0)) (mul_SNo b (p 1)) (minus_SNo (mul_SNo a (p 0))) HaxS HbyS HmAxS).
    rewrite (add_SNo_com (mul_SNo b (p 1)) (minus_SNo (mul_SNo a (p 0))) HbyS HmAxS) at 1.
    rewrite (add_SNo_assoc (mul_SNo a (p 0)) (minus_SNo (mul_SNo a (p 0))) (mul_SNo b (p 1)) HaxS HmAxS HbyS).
    rewrite (add_SNo_minus_SNo_rinv (mul_SNo a (p 0)) HaxS).
    exact (add_SNo_0L (mul_SNo b (p 1)) HbyS). }
  claim HxtermS: SNo (add_SNo c (minus_SNo (mul_SNo a (p 0)))).
  { exact (SNo_add_SNo c (minus_SNo (mul_SNo a (p 0))) HcS HmAxS). }
  exact (mul_div_SNo_nonzero_eq
    (add_SNo c (minus_SNo (mul_SNo a (p 0))))
    b
    (p 1)
    HxtermS
    HbS
    Hp1S
    Hbne
    HbyEq). }
rewrite Hycoord.
reflexivity.
Qed.

(** Helper: param by y lands in the affine line when b is zero and a is not zero **)
Theorem affine_line_R2_param_by_y_in_line : forall a b c y:set,
  a :e R -> b :e R -> c :e R -> y :e R ->
  b = 0 ->
  a <> 0 ->
  apply_fun (affine_line_R2_param_by_y a b c) y :e affine_line_R2 a b c.
let a b c y.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume HyR: y :e R.
assume Hb0: b = 0.
assume Ha0: a <> 0.
prove apply_fun (affine_line_R2_param_by_y a b c) y :e affine_line_R2 a b c.
rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
set x0 := div_SNo c a.
prove (x0,y) :e affine_line_R2 a b c.
claim Hdef: affine_line_R2 a b c =
  {p :e EuclidPlane | add_SNo (mul_SNo a (R2_xcoord p)) (mul_SNo b (R2_ycoord p)) = c}.
{ reflexivity. }
rewrite Hdef.
claim HxyPlane: (x0,y) :e EuclidPlane.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim HxReal: x0 :e real.
  { exact (real_div_SNo c HcReal a HaReal). }
  claim HxR: x0 :e R.
  { rewrite HdefR. exact HxReal. }
  exact (tuple_2_setprod_by_pair_Sigma R R x0 y HxR HyR). }

claim Hprop: add_SNo (mul_SNo a (R2_xcoord (x0,y))) (mul_SNo b (R2_ycoord (x0,y))) = c.
{ claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HbReal: b :e real.
  { rewrite <- HdefR. exact HbR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim HaS: SNo a.
  { exact (real_SNo a HaReal). }
  claim HbS: SNo b.
  { exact (real_SNo b HbReal). }
  claim HcS: SNo c.
  { exact (real_SNo c HcReal). }
  claim Hx0Real: x0 :e real.
  { exact (real_div_SNo c HcReal a HaReal). }
  claim Hx0S: SNo x0.
  { exact (real_SNo x0 Hx0Real). }
  rewrite (R2_xcoord_tuple x0 y).
  rewrite (R2_ycoord_tuple x0 y).
  rewrite Hb0.
  claim HyReal: y :e real.
  { rewrite <- HdefR. exact HyR. }
  claim HyS: SNo y.
  { exact (real_SNo y HyReal). }
  rewrite (mul_SNo_zeroL y HyS).
  rewrite (add_SNo_0R (mul_SNo a x0) (SNo_mul_SNo a x0 HaS Hx0S)).
  (** a times (c/a) equals c **)
  claim Hmul: mul_SNo a x0 = c.
  { claim Hx0def: x0 = div_SNo c a.
    { reflexivity. }
    rewrite Hx0def.
    rewrite (mul_div_SNo_invR c a HcS HaS Ha0).
    reflexivity. }
  exact Hmul. }

exact (SepI EuclidPlane
        (fun p0:set => add_SNo (mul_SNo a (R2_xcoord p0)) (mul_SNo b (R2_ycoord p0)) = c)
        (x0,y)
        HxyPlane
        Hprop).
Qed.

(** Helper: if b=0 then the affine line is the vertical slice {c/a} times R **)
Theorem affine_line_R2_b0_eq_slice : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  b = 0 ->
  a <> 0 ->
  affine_line_R2 a b c = setprod {div_SNo c a} R.
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hb0: b = 0.
assume Ha0: a <> 0.
set x0 := div_SNo c a.
apply set_ext.
- let p. assume Hp: p :e affine_line_R2 a b c.
  prove p :e setprod {x0} R.
  claim HpRR: p :e setprod R R.
  { exact (affine_line_R2_subset_R2 a b c p Hp). }
  claim Hp0R: (p 0) :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
  claim Hp1R: (p 1) :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpRR). }
  claim Heqdef: add_SNo (mul_SNo a (R2_xcoord p)) (mul_SNo b (R2_ycoord p)) = c.
  { exact (SepE2 EuclidPlane
              (fun p0:set => add_SNo (mul_SNo a (R2_xcoord p0)) (mul_SNo b (R2_ycoord p0)) = c)
              p
              Hp). }
  claim Hxdef: R2_xcoord p = p 0.
  { reflexivity. }
  claim Hydef: R2_ycoord p = p 1.
  { reflexivity. }
  claim Hmul: mul_SNo a (p 0) = c.
  { claim Heq0: add_SNo (mul_SNo a (p 0)) (mul_SNo b (p 1)) = c.
    { rewrite <- Hxdef.
      rewrite <- Hydef.
      exact Heqdef. }
    claim HdefR: R = real.
    { reflexivity. }
    claim Hp1Real: (p 1) :e real.
    { rewrite <- HdefR. exact Hp1R. }
    claim Hp1S: SNo (p 1).
    { exact (real_SNo (p 1) Hp1Real). }
    claim Hbterm: mul_SNo b (p 1) = 0.
    { rewrite Hb0.
      exact (mul_SNo_zeroL (p 1) Hp1S). }
    claim Heq2: add_SNo (mul_SNo a (p 0)) 0 = c.
    { claim HlhsEq: add_SNo (mul_SNo a (p 0)) (mul_SNo b (p 1)) = add_SNo (mul_SNo a (p 0)) 0.
      { rewrite Hbterm.
        reflexivity. }
      rewrite <- HlhsEq.
      exact Heq0. }
    claim Hap0: SNo (mul_SNo a (p 0)).
    { claim HaReal: a :e real.
      { rewrite <- HdefR. exact HaR. }
      claim Hp0Real: (p 0) :e real.
      { rewrite <- HdefR. exact Hp0R. }
      exact (SNo_mul_SNo a (p 0) (real_SNo a HaReal) (real_SNo (p 0) Hp0Real)). }
    rewrite <- (add_SNo_0R (mul_SNo a (p 0)) Hap0).
    exact Heq2. }
  claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim Hp0Real: (p 0) :e real.
  { rewrite <- HdefR. exact Hp0R. }
  claim HaS: SNo a.
  { exact (real_SNo a HaReal). }
  claim HcS: SNo c.
  { exact (real_SNo c HcReal). }
  claim Hp0S: SNo (p 0).
  { exact (real_SNo (p 0) Hp0Real). }
  claim Hmul2: c = mul_SNo a (p 0).
  { rewrite Hmul.
    reflexivity. }
  claim HdivEq: div_SNo c a = (p 0).
  { exact (mul_div_SNo_nonzero_eq c a (p 0) HcS HaS Hp0S Ha0 Hmul2). }
  claim Hx0def: x0 = div_SNo c a.
  { reflexivity. }
  claim Hx0eq: x0 = (p 0).
  { rewrite Hx0def.
    exact HdivEq. }
  claim Hp0Sing: (p 0) :e {x0}.
  { rewrite <- Hx0eq.
    exact (SingI x0). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta R R p HpRR). }
  rewrite Heta.
  exact (tuple_2_setprod_by_pair_Sigma {x0} R (p 0) (p 1) Hp0Sing Hp1R).
- let p. assume Hp: p :e setprod {x0} R.
  prove p :e affine_line_R2 a b c.
  claim Hp0Sing: (p 0) :e {x0}.
  { exact (ap0_Sigma {x0} (fun _ : set => R) p Hp). }
  claim Hp1R: (p 1) :e R.
  { exact (ap1_Sigma {x0} (fun _ : set => R) p Hp). }
  claim Hp0eq: (p 0) = x0.
  { exact (singleton_elem (p 0) x0 Hp0Sing). }
  claim HpRR: p :e setprod R R.
  { claim HSingSub: {x0} c= R.
    { claim Hx0Real: x0 :e real.
      { claim HdefR: R = real.
        { reflexivity. }
        claim HaReal: a :e real.
        { rewrite <- HdefR. exact HaR. }
        claim HcReal: c :e real.
        { rewrite <- HdefR. exact HcR. }
        exact (real_div_SNo c HcReal a HaReal). }
      claim Hx0R: x0 :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR. exact Hx0Real. }
      exact (singleton_subset x0 R Hx0R). }
    exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p Hp). }
  claim Hdef: affine_line_R2 a b c =
    {q :e EuclidPlane | add_SNo (mul_SNo a (R2_xcoord q)) (mul_SNo b (R2_ycoord q)) = c}.
  { reflexivity. }
  rewrite Hdef.
  claim HxyPlane: p :e EuclidPlane.
  { claim Heq: EuclidPlane = setprod R R.
    { reflexivity. }
    rewrite Heq.
    exact HpRR. }
  prove p :e {q :e EuclidPlane | add_SNo (mul_SNo a (R2_xcoord q)) (mul_SNo b (R2_ycoord q)) = c}.
  apply (SepI EuclidPlane
          (fun q:set => add_SNo (mul_SNo a (R2_xcoord q)) (mul_SNo b (R2_ycoord q)) = c)
          p
          HxyPlane).
  claim Hxdef: R2_xcoord p = p 0.
  { reflexivity. }
  claim Hydef: R2_ycoord p = p 1.
  { reflexivity. }
  rewrite Hxdef.
  rewrite Hydef.
  rewrite Hb0.
  claim HdefR: R = real.
  { reflexivity. }
  claim HaReal: a :e real.
  { rewrite <- HdefR. exact HaR. }
  claim HcReal: c :e real.
  { rewrite <- HdefR. exact HcR. }
  claim Hp1Real: (p 1) :e real.
  { rewrite <- HdefR. exact Hp1R. }
  claim Hp1S: SNo (p 1).
  { exact (real_SNo (p 1) Hp1Real). }
  rewrite (mul_SNo_zeroL (p 1) Hp1S).
  rewrite Hp0eq.
  claim HaS: SNo a.
  { exact (real_SNo a HaReal). }
  claim HcS: SNo c.
  { exact (real_SNo c HcReal). }
  claim Hx0Real: x0 :e real.
  { exact (real_div_SNo c HcReal a HaReal). }
  claim Hx0S: SNo x0.
  { exact (real_SNo x0 Hx0Real). }
  rewrite (add_SNo_0R (mul_SNo a x0) (SNo_mul_SNo a x0 HaS Hx0S)).
  claim Hmul: mul_SNo a x0 = c.
  { claim Hx0def: x0 = div_SNo c a.
    { reflexivity. }
    rewrite Hx0def.
    rewrite (mul_div_SNo_invR c a HcS HaS Ha0).
    reflexivity. }
  exact Hmul.
Qed.

(** from §16 Exercise 8: helper predicate for negative slope in affine form **)
(** LATEX VERSION: For ax+by=c with b not zero, the slope is negative exactly when a and b have the same sign. **)
Definition same_sign_nonzero_R : set -> set -> prop :=
  fun a b => (Rlt 0 a /\ Rlt 0 b) \/ (Rlt a 0 /\ Rlt b 0).

(** helper for §16 Exercise 8: in the same-sign case, the line graph decreases in y as x increases **)
(** LATEX VERSION: If a and b have the same sign and b is nonzero, then for x1<x2 we have (c-ax2)/b < (c-ax1)/b. **)
Theorem affine_line_R2_param_by_x_y_decreases_same_sign : forall a b c x1 x2:set,
  a :e R -> b :e R -> c :e R ->
  b <> 0 ->
  same_sign_nonzero_R a b ->
  x1 :e R -> x2 :e R ->
  Rlt x1 x2 ->
  Rlt (div_SNo (add_SNo c (minus_SNo (mul_SNo a x2))) b)
      (div_SNo (add_SNo c (minus_SNo (mul_SNo a x1))) b).
let a b c x1 x2.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hbne: b <> 0.
assume Hsign: same_sign_nonzero_R a b.
assume Hx1R: x1 :e R.
assume Hx2R: x2 :e R.
assume Hx12: Rlt x1 x2.
prove Rlt (div_SNo (add_SNo c (minus_SNo (mul_SNo a x2))) b)
          (div_SNo (add_SNo c (minus_SNo (mul_SNo a x1))) b).
claim HdefR: R = real.
{ reflexivity. }
claim HaReal: a :e real.
{ rewrite <- HdefR. exact HaR. }
claim HbReal: b :e real.
{ rewrite <- HdefR. exact HbR. }
claim HcReal: c :e real.
{ rewrite <- HdefR. exact HcR. }
claim Hx1Real: x1 :e real.
{ rewrite <- HdefR. exact Hx1R. }
claim Hx2Real: x2 :e real.
{ rewrite <- HdefR. exact Hx2R. }
claim HaS: SNo a.
{ exact (real_SNo a HaReal). }
claim HbS: SNo b.
{ exact (real_SNo b HbReal). }
claim HcS: SNo c.
{ exact (real_SNo c HcReal). }
claim Hx1S: SNo x1.
{ exact (real_SNo x1 Hx1Real). }
claim Hx2S: SNo x2.
{ exact (real_SNo x2 Hx2Real). }
claim Hx12lt: x1 < x2.
{ exact (RltE_lt x1 x2 Hx12). }
set num1 := add_SNo c (minus_SNo (mul_SNo a x1)).
set num2 := add_SNo c (minus_SNo (mul_SNo a x2)).
claim Hnum1S: SNo num1.
{ exact (SNo_add_SNo c (minus_SNo (mul_SNo a x1)) HcS
          (SNo_minus_SNo (mul_SNo a x1) (SNo_mul_SNo a x1 HaS Hx1S))). }
claim Hnum2S: SNo num2.
{ exact (SNo_add_SNo c (minus_SNo (mul_SNo a x2)) HcS
          (SNo_minus_SNo (mul_SNo a x2) (SNo_mul_SNo a x2 HaS Hx2S))). }
claim Hy1Real: div_SNo (add_SNo c (minus_SNo (mul_SNo a x1))) b :e real.
{ exact (real_div_SNo (add_SNo c (minus_SNo (mul_SNo a x1))) (real_add_SNo c HcReal (minus_SNo (mul_SNo a x1)) (real_minus_SNo (mul_SNo a x1) (real_mul_SNo a HaReal x1 Hx1Real)))
         b HbReal). }
claim Hy2Real: div_SNo (add_SNo c (minus_SNo (mul_SNo a x2))) b :e real.
{ exact (real_div_SNo (add_SNo c (minus_SNo (mul_SNo a x2))) (real_add_SNo c HcReal (minus_SNo (mul_SNo a x2)) (real_minus_SNo (mul_SNo a x2) (real_mul_SNo a HaReal x2 Hx2Real)))
         b HbReal). }
claim Hy1R: div_SNo (add_SNo c (minus_SNo (mul_SNo a x1))) b :e R.
{ rewrite HdefR. exact Hy1Real. }
claim Hy2R: div_SNo (add_SNo c (minus_SNo (mul_SNo a x2))) b :e R.
{ rewrite HdefR. exact Hy2Real. }
apply Hsign.
- (** positive case: 0<a and 0<b **)
  assume Hpos: Rlt 0 a /\ Rlt 0 b.
  claim H0a: Rlt 0 a.
  { exact (andEL (Rlt 0 a) (Rlt 0 b) Hpos). }
  claim H0b: Rlt 0 b.
  { exact (andER (Rlt 0 a) (Rlt 0 b) Hpos). }
  claim H0alt: 0 < a.
  { exact (RltE_lt 0 a H0a). }
  claim H0blt: 0 < b.
  { exact (RltE_lt 0 b H0b). }
  claim Hax1ax2: mul_SNo a x1 < mul_SNo a x2.
  { exact (pos_mul_SNo_Lt a x1 x2 HaS H0alt Hx1S Hx2S Hx12lt). }
  claim HmAx2mAx1: minus_SNo (mul_SNo a x2) < minus_SNo (mul_SNo a x1).
  { exact (minus_SNo_Lt_contra (mul_SNo a x1) (mul_SNo a x2)
            (SNo_mul_SNo a x1 HaS Hx1S) (SNo_mul_SNo a x2 HaS Hx2S) Hax1ax2). }
  claim Hnum2num1: num2 < num1.
  { exact (add_SNo_Lt2 c (minus_SNo (mul_SNo a x2)) (minus_SNo (mul_SNo a x1))
            HcS (SNo_minus_SNo (mul_SNo a x2) (SNo_mul_SNo a x2 HaS Hx2S))
            (SNo_minus_SNo (mul_SNo a x1) (SNo_mul_SNo a x1 HaS Hx1S))
            HmAx2mAx1). }
  claim HrecipPos: 0 < recip_SNo b.
  { exact (recip_SNo_of_pos_is_pos b HbS H0blt). }
  claim HrecipS: SNo (recip_SNo b).
  { exact (SNo_recip_SNo b HbS). }
  claim HdivLt: div_SNo num2 b < div_SNo num1 b.
  { claim Heq2: div_SNo num2 b = mul_SNo num2 (recip_SNo b).
    { reflexivity. }
    claim Heq1: div_SNo num1 b = mul_SNo num1 (recip_SNo b).
    { reflexivity. }
    rewrite Heq2.
    rewrite Heq1.
    exact (pos_mul_SNo_Lt' num2 num1 (recip_SNo b) Hnum2S Hnum1S HrecipS HrecipPos Hnum2num1). }
  exact (RltI (div_SNo num2 b) (div_SNo num1 b) Hy2R Hy1R HdivLt).
- (** negative case: a<0 and b<0 **)
  assume Hneg: Rlt a 0 /\ Rlt b 0.
  claim Ha0: Rlt a 0.
  { exact (andEL (Rlt a 0) (Rlt b 0) Hneg). }
  claim Hb0: Rlt b 0.
  { exact (andER (Rlt a 0) (Rlt b 0) Hneg). }
  claim Halt0: a < 0.
  { exact (RltE_lt a 0 Ha0). }
  claim Hblt0: b < 0.
  { exact (RltE_lt b 0 Hb0). }
  claim Hax2ax1: mul_SNo a x2 < mul_SNo a x1.
  { exact (neg_mul_SNo_Lt a x2 x1 HaS Halt0 Hx2S Hx1S Hx12lt). }
  claim HmAx1mAx2: minus_SNo (mul_SNo a x1) < minus_SNo (mul_SNo a x2).
  { exact (minus_SNo_Lt_contra (mul_SNo a x2) (mul_SNo a x1)
            (SNo_mul_SNo a x2 HaS Hx2S) (SNo_mul_SNo a x1 HaS Hx1S) Hax2ax1). }
  claim Hnum1num2: num1 < num2.
  { exact (add_SNo_Lt2 c (minus_SNo (mul_SNo a x1)) (minus_SNo (mul_SNo a x2))
            HcS (SNo_minus_SNo (mul_SNo a x1) (SNo_mul_SNo a x1 HaS Hx1S))
            (SNo_minus_SNo (mul_SNo a x2) (SNo_mul_SNo a x2 HaS Hx2S))
            HmAx1mAx2). }
  claim HrecipNeg: recip_SNo b < 0.
  { (** recip_SNo b = -recip_SNo_pos (-b) and recip_SNo_pos (-b) is positive **)
    claim HminusbS: SNo (minus_SNo b).
    { exact (SNo_minus_SNo b HbS). }
    claim HminusbPos: 0 < minus_SNo b.
    { (** from b<0 get 0 < -b **)
      claim H0ltminusb: minus_SNo 0 < minus_SNo b.
      { exact (minus_SNo_Lt_contra b 0 HbS SNo_0 Hblt0). }
      prove 0 < minus_SNo b.
      rewrite <- (minus_SNo_0) at 1.
      exact H0ltminusb. }
    claim HrecipPosDef: recip_SNo b = minus_SNo (recip_SNo_pos (minus_SNo b)).
    { rewrite (recip_SNo_negcase b HbS Hblt0).
      reflexivity. }
    claim HtS: SNo (recip_SNo_pos (minus_SNo b)).
    { exact (SNo_recip_SNo_pos (minus_SNo b) HminusbS HminusbPos). }
    claim HtPos: 0 < recip_SNo_pos (minus_SNo b).
    { exact (recip_SNo_pos_is_pos (minus_SNo b) HminusbS HminusbPos). }
    rewrite HrecipPosDef.
    claim HnegT: minus_SNo (recip_SNo_pos (minus_SNo b)) < 0.
    { claim Hmtltm0: minus_SNo (recip_SNo_pos (minus_SNo b)) < minus_SNo 0.
      { exact (minus_SNo_Lt_contra 0 (recip_SNo_pos (minus_SNo b)) SNo_0 HtS HtPos). }
      prove minus_SNo (recip_SNo_pos (minus_SNo b)) < 0.
      rewrite <- (minus_SNo_0) at 1.
      exact Hmtltm0. }
    exact HnegT. }
  claim HrecipS: SNo (recip_SNo b).
  { exact (SNo_recip_SNo b HbS). }
  claim HdivLt: div_SNo num2 b < div_SNo num1 b.
  { claim Heq2: div_SNo num2 b = mul_SNo num2 (recip_SNo b).
    { reflexivity. }
    claim Heq1: div_SNo num1 b = mul_SNo num1 (recip_SNo b).
    { reflexivity. }
    rewrite Heq2.
    rewrite Heq1.
    (** use commutativity and multiply on the left by the negative factor **)
    rewrite (mul_SNo_com num2 (recip_SNo b) Hnum2S HrecipS).
    rewrite (mul_SNo_com num1 (recip_SNo b) Hnum1S HrecipS).
    exact (neg_mul_SNo_Lt (recip_SNo b) num2 num1 HrecipS HrecipNeg Hnum2S Hnum1S Hnum1num2). }
  exact (RltI (div_SNo num2 b) (div_SNo num1 b) Hy2R Hy1R HdivLt).
Qed.

(** Helper for ex16_8_lines_in_lower_limit_products: in the same_sign case, each singleton on the line is open in the R_lower_limit_topology product subspace topology **)
Theorem affine_line_R2_singleton_open_same_sign : forall a b c p:set,
  a :e R -> b :e R -> c :e R ->
  b <> 0 -> same_sign_nonzero_R a b ->
  p :e affine_line_R2 a b c ->
  {p} :e subspace_topology (setprod R R)
    (product_topology R R_lower_limit_topology R R_lower_limit_topology)
    (affine_line_R2 a b c).
let a b c p.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hbne: b <> 0.
assume Hsign: same_sign_nonzero_R a b.
assume HpL: p :e affine_line_R2 a b c.
prove {p} :e subspace_topology (setprod R R)
  (product_topology R R_lower_limit_topology R R_lower_limit_topology)
  (affine_line_R2 a b c).
claim HdefTL:
  subspace_topology (setprod R R)
    (product_topology R R_lower_limit_topology R R_lower_limit_topology)
    (affine_line_R2 a b c)
  = {U0 :e Power (affine_line_R2 a b c) |
       exists V0 :e (product_topology R R_lower_limit_topology R R_lower_limit_topology),
         U0 = V0 :/\: (affine_line_R2 a b c)}.
{ reflexivity. }
rewrite HdefTL.
apply (SepI (Power (affine_line_R2 a b c))
  (fun U0:set => exists V0 :e (product_topology R R_lower_limit_topology R R_lower_limit_topology),
    U0 = V0 :/\: (affine_line_R2 a b c)) {p}).
- apply PowerI (affine_line_R2 a b c) {p}.
  let q. assume Hq: q :e {p}.
  prove q :e affine_line_R2 a b c.
  claim Hqeq: q = p.
  { exact (SingE p q Hq). }
  rewrite Hqeq.
  exact HpL.
- claim HpRR: p :e setprod R R.
  { exact (affine_line_R2_subset_R2 a b c p HpL). }
  set x := p 0.
  set y := p 1.
  claim HxR: x :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
  claim HyR: y :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpRR). }
  claim HdefR: R = real.
  { reflexivity. }
  claim HxReal: x :e real.
  { rewrite <- HdefR. exact HxR. }
  claim HyReal: y :e real.
  { rewrite <- HdefR. exact HyR. }
  claim HxS: SNo x.
  { exact (real_SNo x HxReal). }
  claim HyS: SNo y.
  { exact (real_SNo y HyReal). }
  set x1 := add_SNo x 1.
  set y1 := add_SNo y 1.
  claim Hx1Real: x1 :e real.
  { exact (real_add_SNo x HxReal 1 real_1). }
  claim Hy1Real: y1 :e real.
  { exact (real_add_SNo y HyReal 1 real_1). }
  claim Hx1R: x1 :e R.
  { rewrite HdefR. exact Hx1Real. }
  claim Hy1R: y1 :e R.
  { rewrite HdefR. exact Hy1Real. }
  claim Hx1def: x1 = add_SNo x 1.
  { reflexivity. }
  claim Hy1def: y1 = add_SNo y 1.
  { reflexivity. }
  claim Hxltx1: x < x1.
  { prove x < x1.
    rewrite Hx1def.
    claim H0S: SNo 0.
    { exact SNo_0. }
    claim H1S: SNo 1.
    { exact SNo_1. }
    claim H0lt1: 0 < 1.
    { exact SNoLt_0_1. }
    claim Hx0ltx1: add_SNo x 0 < add_SNo x 1.
    { exact (add_SNo_Lt2 x 0 1 HxS H0S H1S H0lt1). }
    rewrite <- (add_SNo_0R x HxS) at 1.
    exact Hx0ltx1. }
  claim Hylt1: y < y1.
  { prove y < y1.
    rewrite Hy1def.
    claim H0S: SNo 0.
    { exact SNo_0. }
    claim H1S: SNo 1.
    { exact SNo_1. }
    claim H0lt1: 0 < 1.
    { exact SNoLt_0_1. }
    claim Hy0lty1: add_SNo y 0 < add_SNo y 1.
    { exact (add_SNo_Lt2 y 0 1 HyS H0S H1S H0lt1). }
    rewrite <- (add_SNo_0R y HyS) at 1.
    exact Hy0lty1. }
  claim HRlt_x_x1: Rlt x x1.
  { exact (RltI x x1 HxR Hx1R Hxltx1). }
  claim HRlt_y_y1: Rlt y y1.
  { exact (RltI y y1 HyR Hy1R Hylt1). }
  set U := halfopen_interval_left x x1.
  set V := halfopen_interval_left y y1.
  claim HxU: x :e U.
  { exact (halfopen_interval_left_leftmem x x1 HRlt_x_x1). }
  claim HyV: y :e V.
  { exact (halfopen_interval_left_leftmem y y1 HRlt_y_y1). }
  claim HUinBasis: U :e R_lower_limit_basis.
  { prove U :e R_lower_limit_basis.
    claim HUfam: U :e {halfopen_interval_left x b0|b0 :e R}.
    { exact (ReplI R (fun b0:set => halfopen_interval_left x b0) x1 Hx1R). }
    exact (famunionI R (fun a0:set => {halfopen_interval_left a0 b0|b0 :e R}) x U HxR HUfam). }
  claim HVinBasis: V :e R_lower_limit_basis.
  { prove V :e R_lower_limit_basis.
    claim HVfam: V :e {halfopen_interval_left y b0|b0 :e R}.
    { exact (ReplI R (fun b0:set => halfopen_interval_left y b0) y1 Hy1R). }
    exact (famunionI R (fun a0:set => {halfopen_interval_left a0 b0|b0 :e R}) y V HyR HVfam). }
  claim HBasis: basis_on R R_lower_limit_basis.
  { exact R_lower_limit_basis_is_basis_local. }
  claim HUopen: U :e R_lower_limit_topology.
  { exact (generated_topology_contains_basis R R_lower_limit_basis HBasis U HUinBasis). }
  claim HVopen: V :e R_lower_limit_topology.
  { exact (generated_topology_contains_basis R R_lower_limit_basis HBasis V HVinBasis). }
  claim HWsub: rectangle_set U V :e product_subbasis R R_lower_limit_topology R R_lower_limit_topology.
  { prove rectangle_set U V :e product_subbasis R R_lower_limit_topology R R_lower_limit_topology.
    claim HWV: rectangle_set U V :e {rectangle_set U V0|V0 :e R_lower_limit_topology}.
    { exact (ReplI R_lower_limit_topology (fun V0:set => rectangle_set U V0) V HVopen). }
    exact (famunionI R_lower_limit_topology (fun U0:set => {rectangle_set U0 V0|V0 :e R_lower_limit_topology}) U (rectangle_set U V) HUopen HWV). }
  claim HBsub: basis_on (setprod R R) (product_subbasis R R_lower_limit_topology R R_lower_limit_topology).
  { exact (product_subbasis_is_basis R R_lower_limit_topology R R_lower_limit_topology R_lower_limit_topology_is_topology R_lower_limit_topology_is_topology). }
  claim HWopen: rectangle_set U V :e product_topology R R_lower_limit_topology R R_lower_limit_topology.
  { exact (generated_topology_contains_basis (setprod R R) (product_subbasis R R_lower_limit_topology R R_lower_limit_topology) HBsub (rectangle_set U V) HWsub). }
  claim HsingEq: {p} = (rectangle_set U V) :/\: affine_line_R2 a b c.
  { apply set_ext.
    - let q. assume Hq: q :e {p}.
      prove q :e (rectangle_set U V) :/\: affine_line_R2 a b c.
      claim Hqeq: q = p.
      { exact (SingE p q Hq). }
      rewrite Hqeq.
						      apply binintersectI.
						      + claim Hpeta: p = (p 0, p 1).
						        { exact (setprod_eta R R p HpRR). }
						        claim Hxdef: x = p 0.
						        { reflexivity. }
						        claim Hydef: y = p 1.
						        { reflexivity. }
						        claim Hp0U: p 0 :e U.
						        { rewrite <- Hxdef. exact HxU. }
						        claim Hp1V: p 1 :e V.
						        { rewrite <- Hydef. exact HyV. }
						        rewrite Hpeta at 1.
						        rewrite rectangle_set_def.
						        exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1V).
						      + exact HpL.
				    - let q. assume Hq: q :e (rectangle_set U V) :/\: affine_line_R2 a b c.
				      prove q :e {p}.
      claim HqL: q :e affine_line_R2 a b c.
      { exact (binintersectE2 (rectangle_set U V) (affine_line_R2 a b c) q Hq). }
      claim HqW: q :e rectangle_set U V.
      { exact (binintersectE1 (rectangle_set U V) (affine_line_R2 a b c) q Hq). }
      claim HqUV: q :e setprod U V.
      { exact HqW. }
      set qx := q 0.
      set qy := q 1.
      claim HqRR: q :e setprod R R.
      { exact (affine_line_R2_subset_R2 a b c q HqL). }
      claim HqxR: qx :e R.
      { exact (ap0_Sigma R (fun _ : set => R) q HqRR). }
      claim HqyR: qy :e R.
      { exact (ap1_Sigma R (fun _ : set => R) q HqRR). }
      claim HqxS: SNo qx.
      { claim HqxReal: qx :e real.
        { rewrite <- HdefR. exact HqxR. }
        exact (real_SNo qx HqxReal). }
      claim HqyS: SNo qy.
      { claim HqyReal: qy :e real.
        { rewrite <- HdefR. exact HqyR. }
        exact (real_SNo qy HqyReal). }
      claim HqxU: qx :e U.
      { exact (ap0_Sigma U (fun _ : set => V) q HqUV). }
      claim HqyV: qy :e V.
      { exact (ap1_Sigma U (fun _ : set => V) q HqUV). }
      claim HqxCond: ~(Rlt qx x) /\ Rlt qx x1.
      { exact (SepE2 R (fun t:set => ~(Rlt t x) /\ Rlt t x1) qx HqxU). }
      claim HqyCond: ~(Rlt qy y) /\ Rlt qy y1.
      { exact (SepE2 R (fun t:set => ~(Rlt t y) /\ Rlt t y1) qy HqyV). }
      claim HnotRlt_qx_x: ~(Rlt qx x).
      { exact (andEL (~(Rlt qx x)) (Rlt qx x1) HqxCond). }
      claim HnotRlt_qy_y: ~(Rlt qy y).
      { exact (andEL (~(Rlt qy y)) (Rlt qy y1) HqyCond). }
      claim Hnotlt_qx_x: ~ (qx < x).
      { assume Hlt: qx < x.
        apply HnotRlt_qx_x.
        exact (RltI qx x HqxR HxR Hlt). }
      claim Hqeq: q = p.
      { apply (SNoLt_trichotomy_or_impred qx x HqxS HxS (q = p)).
        - assume Hqxlt: qx < x.
          prove q = p.
          apply FalseE.
          apply Hnotlt_qx_x.
          exact Hqxlt.
        - assume HqxEq: qx = x.
          prove q = p.
          set f := affine_line_R2_param_by_x a b c.
          claim Hpx: apply_fun f x = p.
          { claim Happ1p: apply_fun (projection1 R R) p = x.
            { rewrite (projection1_apply R R p HpRR).
              reflexivity. }
            rewrite <- Happ1p.
            exact (affine_line_R2_param_by_x_after_projection1_on_line a b c p HaR HbR HcR Hbne HpL). }
          claim Hqpx: apply_fun f qx = q.
          { claim Happ1q: apply_fun (projection1 R R) q = qx.
            { rewrite (projection1_apply R R q HqRR).
              reflexivity. }
            rewrite <- Happ1q.
            exact (affine_line_R2_param_by_x_after_projection1_on_line a b c q HaR HbR HcR Hbne HqL). }
          rewrite <- Hqpx.
          rewrite <- Hpx.
          rewrite HqxEq.
          reflexivity.
        - assume Hxlt: x < qx.
          prove q = p.
          apply FalseE.
          set f := affine_line_R2_param_by_x a b c.
          set yx := div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b.
          set yq := div_SNo (add_SNo c (minus_SNo (mul_SNo a qx))) b.
          claim Hyxdef: yx = div_SNo (add_SNo c (minus_SNo (mul_SNo a x))) b.
          { reflexivity. }
          claim Hyqdef: yq = div_SNo (add_SNo c (minus_SNo (mul_SNo a qx))) b.
          { reflexivity. }
          claim Hpx: apply_fun f x = p.
          { claim Happ1p: apply_fun (projection1 R R) p = x.
            { rewrite (projection1_apply R R p HpRR).
              reflexivity. }
            rewrite <- Happ1p.
            exact (affine_line_R2_param_by_x_after_projection1_on_line a b c p HaR HbR HcR Hbne HpL). }
          claim Hqpx: apply_fun f qx = q.
          { claim Happ1q: apply_fun (projection1 R R) q = qx.
            { rewrite (projection1_apply R R q HqRR).
              reflexivity. }
            rewrite <- Happ1q.
            exact (affine_line_R2_param_by_x_after_projection1_on_line a b c q HaR HbR HcR Hbne HqL). }
          claim Hpeta: p = (x,y).
          { exact (setprod_eta R R p HpRR). }
          claim Hqeta: q = (qx,qy).
          { exact (setprod_eta R R q HqRR). }
          claim HpairP: (x,yx) = (x,y).
          { claim Hfx: apply_fun f x = (x,yx).
            { rewrite (affine_line_R2_param_by_x_apply a b c x HxR).
              rewrite <- Hyxdef.
              reflexivity. }
            rewrite <- Hpeta.
            rewrite <- Hfx.
            exact Hpx. }
          claim HyxEq: yx = y.
          { exact (andER (x = x) (yx = y) (tuple_eq_coords x yx x y HpairP)). }
          claim HpairQ: (qx,yq) = (qx,qy).
          { claim Hfq: apply_fun f qx = (qx,yq).
            { rewrite (affine_line_R2_param_by_x_apply a b c qx HqxR).
              rewrite <- Hyqdef.
              reflexivity. }
            rewrite <- Hqeta.
            rewrite <- Hfq.
            exact Hqpx. }
          claim HyqEq: yq = qy.
          { exact (andER (qx = qx) (yq = qy) (tuple_eq_coords qx yq qx qy HpairQ)). }
          claim HRlt_x_qx: Rlt x qx.
          { exact (RltI x qx HxR HqxR Hxlt). }
          claim HRlt_yq_yx: Rlt yq yx.
          { exact (affine_line_R2_param_by_x_y_decreases_same_sign a b c x qx
                    HaR HbR HcR Hbne Hsign HxR HqxR HRlt_x_qx). }
          claim Hbad: Rlt qy y.
          { rewrite <- HyqEq.
            rewrite <- HyxEq.
            exact HRlt_yq_yx. }
          apply HnotRlt_qy_y.
          exact Hbad. }
      rewrite Hqeq.
      exact (SingI p). }
  witness (rectangle_set U V).
  apply andI.
  - exact HWopen.
  - exact HsingEq.
Qed.

(** Helper for ex16_8_lines_in_lower_limit_products: projection1 into a discrete codomain is continuous on the same_sign affine line **)
Theorem projection1_continuous_on_affine_line_same_sign : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  b <> 0 -> same_sign_nonzero_R a b ->
  continuous_map (affine_line_R2 a b c)
    (subspace_topology (setprod R R)
      (product_topology R R_lower_limit_topology R R_lower_limit_topology)
      (affine_line_R2 a b c))
    R (discrete_topology R) (projection1 R R).
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hbne: b <> 0.
assume Hsign: same_sign_nonzero_R a b.
set g := projection1 R R.
prove continuous_map (affine_line_R2 a b c)
  (subspace_topology (setprod R R)
    (product_topology R R_lower_limit_topology R R_lower_limit_topology)
    (affine_line_R2 a b c))
  R (discrete_topology R) g.
claim HTll: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HTprod: topology_on (setprod R R)
  (product_topology R R_lower_limit_topology R R_lower_limit_topology).
{ exact (product_topology_is_topology R R_lower_limit_topology R R_lower_limit_topology HTll HTll). }
claim HLsub: affine_line_R2 a b c c= setprod R R.
{ exact (affine_line_R2_subset_R2 a b c). }
claim HTL: topology_on (affine_line_R2 a b c)
  (subspace_topology (setprod R R)
    (product_topology R R_lower_limit_topology R R_lower_limit_topology)
    (affine_line_R2 a b c)).
{ exact (subspace_topology_is_topology (setprod R R)
          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
          (affine_line_R2 a b c) HTprod HLsub). }
claim HTd: topology_on R (discrete_topology R).
{ exact (discrete_topology_on R). }
claim Hfun: function_on g (affine_line_R2 a b c) R.
{ let p. assume HpL: p :e affine_line_R2 a b c.
  prove apply_fun g p :e R.
  claim HpRR: p :e setprod R R.
  { exact (HLsub p HpL). }
  claim Happ: apply_fun g p = p 0.
  { exact (projection1_apply R R p HpRR). }
  rewrite Happ.
  exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
prove topology_on (affine_line_R2 a b c)
    (subspace_topology (setprod R R)
      (product_topology R R_lower_limit_topology R R_lower_limit_topology)
      (affine_line_R2 a b c))
  /\ topology_on R (discrete_topology R)
  /\ function_on g (affine_line_R2 a b c) R
  /\ forall V:set, V :e discrete_topology R ->
       preimage_of (affine_line_R2 a b c) g V :e
         (subspace_topology (setprod R R)
           (product_topology R R_lower_limit_topology R R_lower_limit_topology)
           (affine_line_R2 a b c)).
apply andI.
- apply andI.
  * apply andI.
    + exact HTL.
    + exact HTd.
  * exact Hfun.
- let V. assume HV: V :e discrete_topology R.
  prove preimage_of (affine_line_R2 a b c) g V :e
    (subspace_topology (setprod R R)
      (product_topology R R_lower_limit_topology R R_lower_limit_topology)
      (affine_line_R2 a b c)).
  set S := preimage_of (affine_line_R2 a b c) g V.
  set Fam := {{p0}|p0 :e S}.
  claim HFamSub: Fam c=
    (subspace_topology (setprod R R)
      (product_topology R R_lower_limit_topology R R_lower_limit_topology)
      (affine_line_R2 a b c)).
  { let U. assume HU: U :e Fam.
    prove U :e
      (subspace_topology (setprod R R)
        (product_topology R R_lower_limit_topology R R_lower_limit_topology)
        (affine_line_R2 a b c)).
    claim Hex: exists p0 :e S, U = {p0}.
    { exact (ReplE S (fun p0:set => {p0}) U HU). }
    apply Hex.
    let p0. assume Hp0pair.
    claim Hp0S: p0 :e S.
    { exact (andEL (p0 :e S) (U = {p0}) Hp0pair). }
    claim HUeq: U = {p0}.
    { exact (andER (p0 :e S) (U = {p0}) Hp0pair). }
    rewrite HUeq.
    claim Hp0L: p0 :e affine_line_R2 a b c.
    { exact (SepE1 (affine_line_R2 a b c) (fun u:set => apply_fun g u :e V) p0 Hp0S). }
    exact (affine_line_R2_singleton_open_same_sign a b c p0 HaR HbR HcR Hbne Hsign Hp0L). }
  claim HUnionOpen: Union Fam :e
    (subspace_topology (setprod R R)
      (product_topology R R_lower_limit_topology R R_lower_limit_topology)
      (affine_line_R2 a b c)).
  { exact (topology_union_closed (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
              (product_topology R R_lower_limit_topology R R_lower_limit_topology)
              (affine_line_R2 a b c))
            Fam
            HTL
            HFamSub). }
  claim HUnionEq: Union Fam = S.
  { apply set_ext.
    - let x. assume Hx: x :e Union Fam.
      prove x :e S.
      claim HexU: exists U:set, x :e U /\ U :e Fam.
      { exact (UnionE Fam x Hx). }
      apply HexU.
      let U. assume HUconj.
      claim HxU: x :e U.
      { exact (andEL (x :e U) (U :e Fam) HUconj). }
      claim HUfam: U :e Fam.
      { exact (andER (x :e U) (U :e Fam) HUconj). }
      claim Hex: exists p0 :e S, U = {p0}.
      { exact (ReplE S (fun p0:set => {p0}) U HUfam). }
      apply Hex.
      let p0. assume Hp0pair.
      claim Hp0S: p0 :e S.
      { exact (andEL (p0 :e S) (U = {p0}) Hp0pair). }
      claim HUeq: U = {p0}.
      { exact (andER (p0 :e S) (U = {p0}) Hp0pair). }
      claim HxU2: x :e {p0}.
      { rewrite <- HUeq.
        exact HxU. }
      claim Hxeq: x = p0.
      { exact (SingE p0 x HxU2). }
      rewrite Hxeq.
      exact Hp0S.
    - let x. assume Hx: x :e S.
      prove x :e Union Fam.
      claim HsingFam: {x} :e Fam.
      { exact (ReplI S (fun p0:set => {p0}) x Hx). }
      exact (UnionI Fam x {x} (SingI x) HsingFam). }
  rewrite <- HUnionEq.
  exact HUnionOpen.
Qed.

(** from §16 Exercise 8: topology on a line in R_l×R and R_l×R_l is familiar **)
(** LATEX VERSION: For a straight line L in the plane, the subspace topology from R_l×R and from R_l×R_l is a familiar topology on L. **)
Theorem ex16_8_lines_in_lower_limit_products : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  ~ (a = 0 /\ b = 0) ->
  ( (b = 0 ->
      exists f:set,
        homeomorphism R R_standard_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f)
    /\ (b <> 0 ->
      exists f:set,
        homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f) )
  /\ ( (b <> 0 /\ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R (discrete_topology R) (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f)
     /\ ( (b = 0 \/ ~ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f).
prove forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  ~ (a = 0 /\ b = 0) ->
  ( (b = 0 ->
      exists f:set,
        homeomorphism R R_standard_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f)
    /\ (b <> 0 ->
      exists f:set,
        homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f) )
  /\ ( (b <> 0 /\ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R (discrete_topology R) (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f)
     /\ ( (b = 0 \/ ~ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f).
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume Hnotboth: ~ (a = 0 /\ b = 0).
prove ( (b = 0 ->
      exists f:set,
        homeomorphism R R_standard_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f)
    /\ (b <> 0 ->
      exists f:set,
        homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
          (subspace_topology (setprod R R)
             (product_topology R R_lower_limit_topology R R_standard_topology)
             (affine_line_R2 a b c)) f) )
  /\ ( (b <> 0 /\ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R (discrete_topology R) (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f)
     /\ ( (b = 0 \/ ~ same_sign_nonzero_R a b) ->
        exists f:set,
          homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
            (subspace_topology (setprod R R)
               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
               (affine_line_R2 a b c)) f).
apply andI.
  - apply andI.
		  + apply andI.
		    * assume Hb0: b = 0.
		      claim Ha0: a <> 0.
		      { prove ~ (a = 0).
		        assume Ha0eq: a = 0.
		        prove False.
		        apply Hnotboth.
		        apply andI.
		        - exact Ha0eq.
		        - exact Hb0. }
		      set x0 := div_SNo c a.
		      claim HeqLine: affine_line_R2 a b c = setprod {x0} R.
		      { exact (affine_line_R2_b0_eq_slice a b c HaR HbR HcR Hb0 Ha0). }
			      witness (affine_line_R2_param_by_y a b c).
			      rewrite HeqLine.
			      claim HTll: topology_on R R_lower_limit_topology.
			      { exact R_lower_limit_topology_is_topology. }
			      claim HTstd: topology_on R R_standard_topology.
			      { exact R_standard_topology_is_topology. }
			      claim Hx0R: x0 :e R.
			      { claim HdefR: R = real.
			        { reflexivity. }
			        claim HaReal: a :e real.
			        { rewrite <- HdefR. exact HaR. }
			        claim HcReal: c :e real.
			        { rewrite <- HdefR. exact HcR. }
			        claim Hx0Real: x0 :e real.
			        { exact (real_div_SNo c HcReal a HaReal). }
			        rewrite HdefR.
			        exact Hx0Real. }
			      prove continuous_map R R_standard_topology (setprod {x0} R)
			        (subspace_topology (setprod R R)
			           (product_topology R R_lower_limit_topology R R_standard_topology)
			           (setprod {x0} R))
			        (affine_line_R2_param_by_y a b c)
		      /\ exists g:set,
		           continuous_map (setprod {x0} R)
		             (subspace_topology (setprod R R)
		               (product_topology R R_lower_limit_topology R R_standard_topology)
		               (setprod {x0} R))
		             R R_standard_topology g
		           /\ (forall x:set, x :e R -> apply_fun g (apply_fun (affine_line_R2_param_by_y a b c) x) = x)
		           /\ (forall y:set, y :e setprod {x0} R -> apply_fun (affine_line_R2_param_by_y a b c) (apply_fun g y) = y).
			      apply andI.
			      - set f := affine_line_R2_param_by_y a b c.
			        claim HcontProd: continuous_map R R_standard_topology EuclidPlane
			          (product_topology R R_lower_limit_topology R R_standard_topology) f.
			        { exact (affine_line_R2_param_by_y_continuous_in_product a b c
			                  R_lower_limit_topology R_standard_topology HTll HTstd HaR HcR). }
			        claim HsliceSub: (setprod {x0} R) c= EuclidPlane.
			        { let p. assume Hp: p :e setprod {x0} R.
			          claim HSingSub: {x0} c= R.
			          { exact (singleton_subset x0 R Hx0R). }
			          exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p Hp). }
			        claim Himg: forall y:set, y :e R -> apply_fun f y :e setprod {x0} R.
			        { let y. assume HyR: y :e R.
			          rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
				          exact (tuple_2_setprod_by_pair_Sigma {x0} R x0 y (SingI x0) HyR). }
			        exact (continuous_map_range_restrict R R_standard_topology EuclidPlane
			                  (product_topology R R_lower_limit_topology R R_standard_topology)
			                  f (setprod {x0} R) HcontProd HsliceSub Himg).
			      - witness (projection2 R R).
			        apply andI.
			        + apply andI.
			          * exact (projection2_continuous_on_vertical_slice x0
			                    R_lower_limit_topology R_standard_topology HTll HTstd Hx0R).
			          * let y. assume HyR: y :e R.
			            exact (projection2_after_affine_line_R2_param_by_y a b c y HaR HcR HyR).
			        + let p. assume Hp: p :e setprod {x0} R.
			          exact (affine_line_R2_param_by_y_after_projection2_on_slice a b c p HaR HcR Hp).
		    * assume Hbne: b <> 0.
		      witness (affine_line_R2_param_by_x a b c).
		      prove continuous_map R R_lower_limit_topology (affine_line_R2 a b c)
		        (subspace_topology (setprod R R)
		           (product_topology R R_lower_limit_topology R R_standard_topology)
		           (affine_line_R2 a b c))
		        (affine_line_R2_param_by_x a b c)
		      /\ exists g:set,
		           continuous_map (affine_line_R2 a b c)
		             (subspace_topology (setprod R R)
		               (product_topology R R_lower_limit_topology R R_standard_topology)
		               (affine_line_R2 a b c))
		             R R_lower_limit_topology g
		           /\ (forall x:set, x :e R -> apply_fun g (apply_fun (affine_line_R2_param_by_x a b c) x) = x)
			           /\ (forall y:set, y :e affine_line_R2 a b c -> apply_fun (affine_line_R2_param_by_x a b c) (apply_fun g y) = y).
			      apply andI.
			      - admit. (** FAIL **)
			      - witness (projection1 R R).
				        apply andI.
				        + apply andI.
				          * claim HTll: topology_on R R_lower_limit_topology.
			            { exact R_lower_limit_topology_is_topology. }
			            claim HTstd: topology_on R R_standard_topology.
			            { exact R_standard_topology_is_topology. }
			            claim HTprod: topology_on (setprod R R)
			              (product_topology R R_lower_limit_topology R R_standard_topology).
			            { exact (product_topology_is_topology R R_lower_limit_topology R R_standard_topology HTll HTstd). }
			            claim Hproj1Cont:
			              continuous_map (setprod R R)
			                (product_topology R R_lower_limit_topology R R_standard_topology)
			                R R_lower_limit_topology (projection1 R R).
			            { exact (projection1_continuous_in_product R R_lower_limit_topology R R_standard_topology HTll HTstd). }
			            claim Hsub: affine_line_R2 a b c c= setprod R R.
			            { exact (affine_line_R2_subset_R2 a b c). }
			            exact (continuous_on_subspace_rule (setprod R R)
			              (product_topology R R_lower_limit_topology R R_standard_topology)
			              R R_lower_limit_topology (projection1 R R) (affine_line_R2 a b c)
			              HTprod HTll Hsub Hproj1Cont).
			          * let x. assume HxR: x :e R.
			            exact (projection1_after_affine_line_R2_param_by_x a b c x HaR HbR HcR HxR).
			        + let p. assume Hp: p :e affine_line_R2 a b c.
			          exact (affine_line_R2_param_by_x_after_projection1_on_line a b c p HaR HbR HcR Hbne Hp).
		  + assume Hneg: b <> 0 /\ same_sign_nonzero_R a b.
		    witness (affine_line_R2_param_by_x a b c).
		    claim Hbne: b <> 0.
		    { apply Hneg.
		      assume Hbne0 Hsign.
		      exact Hbne0. }
		    claim Hsign: same_sign_nonzero_R a b.
		    { apply Hneg.
		      assume Hbne0 Hsign0.
		      exact Hsign0. }
		    set f := affine_line_R2_param_by_x a b c.
	    prove continuous_map R (discrete_topology R) (affine_line_R2 a b c)
	      (subspace_topology (setprod R R)
	         (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	         (affine_line_R2 a b c)) f
	    /\ exists g:set,
	         continuous_map (affine_line_R2 a b c)
	           (subspace_topology (setprod R R)
	             (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	             (affine_line_R2 a b c))
	           R (discrete_topology R) g
	         /\ (forall x:set, x :e R -> apply_fun g (apply_fun f x) = x)
	         /\ (forall y:set, y :e affine_line_R2 a b c -> apply_fun f (apply_fun g y) = y).
	    apply andI.
	    - (** continuity of f from a discrete domain **)
	      claim HTll: topology_on R R_lower_limit_topology.
	      { exact R_lower_limit_topology_is_topology. }
	      claim HTprod: topology_on (setprod R R)
	        (product_topology R R_lower_limit_topology R R_lower_limit_topology).
	      { exact (product_topology_is_topology R R_lower_limit_topology R R_lower_limit_topology HTll HTll). }
	      claim Hsub: affine_line_R2 a b c c= setprod R R.
	      { exact (affine_line_R2_subset_R2 a b c). }
	      claim HTcod: topology_on (affine_line_R2 a b c)
	        (subspace_topology (setprod R R)
	          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	          (affine_line_R2 a b c)).
	      { exact (subspace_topology_is_topology (setprod R R)
	        (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	        (affine_line_R2 a b c) HTprod Hsub). }
		      claim Hfun: function_on f R (affine_line_R2 a b c).
		      { let x. assume HxR: x :e R.
		        exact (affine_line_R2_param_by_x_in_line a b c x HaR HbR HcR HxR Hbne). }
		      prove continuous_map R (discrete_topology R) (affine_line_R2 a b c)
		        (subspace_topology (setprod R R)
		          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		          (affine_line_R2 a b c)) f.
		      claim HTd: topology_on R (discrete_topology R).
		      { exact (discrete_topology_on R). }
		      prove topology_on R (discrete_topology R) /\ topology_on (affine_line_R2 a b c)
		        (subspace_topology (setprod R R)
		          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		          (affine_line_R2 a b c)) /\ function_on f R (affine_line_R2 a b c) /\
		        forall V:set, V :e (subspace_topology (setprod R R)
		          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		          (affine_line_R2 a b c)) -> preimage_of R f V :e discrete_topology R.
		      apply andI.
		      - prove (topology_on R (discrete_topology R) /\ topology_on (affine_line_R2 a b c)
		          (subspace_topology (setprod R R)
		            (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		            (affine_line_R2 a b c))) /\ function_on f R (affine_line_R2 a b c).
		        apply andI.
		        * apply andI.
		          + exact HTd.
		          + exact HTcod.
		        * exact Hfun.
		      - let V. assume HV: V :e (subspace_topology (setprod R R)
		          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		          (affine_line_R2 a b c)).
		        prove preimage_of R f V :e discrete_topology R.
		        claim HsubV: preimage_of R f V c= R.
		        { let x. assume Hx: x :e preimage_of R f V.
		          exact (SepE1 R (fun u:set => apply_fun f u :e V) x Hx). }
		        exact (discrete_open_all R (preimage_of R f V) HsubV).
			    - witness (projection1 R R).
			      apply andI.
			      + apply andI.
				        * exact (projection1_continuous_on_affine_line_same_sign a b c HaR HbR HcR Hbne Hsign).
			        * let x. assume HxR: x :e R.
			          exact (projection1_after_affine_line_R2_param_by_x a b c x HaR HbR HcR HxR).
			      + let p. assume Hp: p :e affine_line_R2 a b c.
			        exact (affine_line_R2_param_by_x_after_projection1_on_line a b c p HaR HbR HcR Hbne Hp).
  - assume Hcase: b = 0 \/ ~ same_sign_nonzero_R a b.
	  claim Hb0case: b = 0 ->
	    exists f:set,
	      homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
	        (subspace_topology (setprod R R)
	           (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	           (affine_line_R2 a b c)) f.
		  { assume Hb0: b = 0.
		    claim Ha0: a <> 0.
	    { prove ~ (a = 0).
	      assume Ha0eq: a = 0.
	      prove False.
	      apply Hnotboth.
	      apply andI.
	      - exact Ha0eq.
	      - exact Hb0. }
	    set x0 := div_SNo c a.
	    claim HeqLine: affine_line_R2 a b c = setprod {x0} R.
	    { exact (affine_line_R2_b0_eq_slice a b c HaR HbR HcR Hb0 Ha0). }
		    witness (affine_line_R2_param_by_y a b c).
		    rewrite HeqLine.
		    claim HTll: topology_on R R_lower_limit_topology.
		    { exact R_lower_limit_topology_is_topology. }
		    claim Hx0R: x0 :e R.
		    { claim HdefR: R = real.
		      { reflexivity. }
		      claim HaReal: a :e real.
		      { rewrite <- HdefR. exact HaR. }
		      claim HcReal: c :e real.
		      { rewrite <- HdefR. exact HcR. }
		      claim Hx0Real: x0 :e real.
		      { exact (real_div_SNo c HcReal a HaReal). }
		      rewrite HdefR.
		      exact Hx0Real. }
		    prove continuous_map R R_lower_limit_topology (setprod {x0} R)
		      (subspace_topology (setprod R R)
		         (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		         (setprod {x0} R))
		      (affine_line_R2_param_by_y a b c)
	    /\ exists g:set,
	         continuous_map (setprod {x0} R)
	           (subspace_topology (setprod R R)
	             (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	             (setprod {x0} R))
	           R R_lower_limit_topology g
	         /\ (forall x:set, x :e R -> apply_fun g (apply_fun (affine_line_R2_param_by_y a b c) x) = x)
	         /\ (forall y:set, y :e setprod {x0} R -> apply_fun (affine_line_R2_param_by_y a b c) (apply_fun g y) = y).
		    apply andI.
		    - set f := affine_line_R2_param_by_y a b c.
		      claim HcontProd: continuous_map R R_lower_limit_topology EuclidPlane
		        (product_topology R R_lower_limit_topology R R_lower_limit_topology) f.
		      { exact (affine_line_R2_param_by_y_continuous_in_product a b c
		                R_lower_limit_topology R_lower_limit_topology HTll HTll HaR HcR). }
		      claim HsliceSub: (setprod {x0} R) c= EuclidPlane.
		      { let p. assume Hp: p :e setprod {x0} R.
		        claim HSingSub: {x0} c= R.
		        { exact (singleton_subset x0 R Hx0R). }
		        exact (setprod_Subq {x0} R R R HSingSub (Subq_ref R) p Hp). }
		      claim Himg: forall y:set, y :e R -> apply_fun f y :e setprod {x0} R.
		      { let y. assume HyR: y :e R.
		        rewrite (affine_line_R2_param_by_y_apply a b c y HyR).
		        exact (tuple_2_setprod_by_pair_Sigma {x0} R x0 y (SingI x0) HyR). }
		      exact (continuous_map_range_restrict R R_lower_limit_topology EuclidPlane
		                (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		                f (setprod {x0} R) HcontProd HsliceSub Himg).
		    - witness (projection2 R R).
		      apply andI.
		      + apply andI.
		        * exact (projection2_continuous_on_vertical_slice x0
		                  R_lower_limit_topology R_lower_limit_topology HTll HTll Hx0R).
		        * let y. assume HyR: y :e R.
		          exact (projection2_after_affine_line_R2_param_by_y a b c y HaR HcR HyR).
		      + let p. assume Hp: p :e setprod {x0} R.
		        exact (affine_line_R2_param_by_y_after_projection2_on_slice a b c p HaR HcR Hp). }
	  claim Hnotsigncase: ~ same_sign_nonzero_R a b ->
	    exists f:set,
	      homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
	        (subspace_topology (setprod R R)
	           (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	           (affine_line_R2 a b c)) f.
	  { assume Hnotsign: ~ same_sign_nonzero_R a b.
	    apply (xm (b = 0)).
	    - assume Hb0: b = 0.
	      exact (Hb0case Hb0).
	    - assume Hbne: b <> 0.
	      witness (affine_line_R2_param_by_x a b c).
		      prove continuous_map R R_lower_limit_topology (affine_line_R2 a b c)
		        (subspace_topology (setprod R R)
		           (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		           (affine_line_R2 a b c))
		        (affine_line_R2_param_by_x a b c)
		      /\ exists g:set,
		           continuous_map (affine_line_R2 a b c)
		             (subspace_topology (setprod R R)
		               (product_topology R R_lower_limit_topology R R_lower_limit_topology)
		               (affine_line_R2 a b c))
		             R R_lower_limit_topology g
		           /\ (forall x:set, x :e R -> apply_fun g (apply_fun (affine_line_R2_param_by_x a b c) x) = x)
		           /\ (forall y:set, y :e affine_line_R2 a b c -> apply_fun (affine_line_R2_param_by_x a b c) (apply_fun g y) = y).
		      apply andI.
				      - set f := affine_line_R2_param_by_x a b c.
				        claim HTll: topology_on R R_lower_limit_topology.
				        { exact R_lower_limit_topology_is_topology. }
				        claim HcontProd: continuous_map R R_lower_limit_topology (setprod R R)
				          (product_topology R R_lower_limit_topology R R_lower_limit_topology) f.
				        { admit. (** FAIL **) }
				        claim Hsub: affine_line_R2 a b c c= setprod R R.
				        { exact (affine_line_R2_subset_R2 a b c). }
				        claim Himg: forall x:set, x :e R -> apply_fun f x :e affine_line_R2 a b c.
				        { let x. assume HxR: x :e R.
			          exact (affine_line_R2_param_by_x_in_line a b c x HaR HbR HcR HxR Hbne). }
			        exact (continuous_map_range_restrict R R_lower_limit_topology (setprod R R)
			          (product_topology R R_lower_limit_topology R R_lower_limit_topology)
			          f (affine_line_R2 a b c) HcontProd Hsub Himg).
		      - witness (projection1 R R).
		        apply andI.
		        + apply andI.
		          * claim HTll: topology_on R R_lower_limit_topology.
	            { exact R_lower_limit_topology_is_topology. }
	            claim HTprod: topology_on (setprod R R)
	              (product_topology R R_lower_limit_topology R R_lower_limit_topology).
	            { exact (product_topology_is_topology R R_lower_limit_topology R R_lower_limit_topology HTll HTll). }
	            claim Hproj1Cont:
	              continuous_map (setprod R R)
	                (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	                R R_lower_limit_topology (projection1 R R).
	            { exact (projection1_continuous_in_product R R_lower_limit_topology R R_lower_limit_topology HTll HTll). }
	            claim Hsub: affine_line_R2 a b c c= setprod R R.
	            { exact (affine_line_R2_subset_R2 a b c). }
	            exact (continuous_on_subspace_rule (setprod R R)
	              (product_topology R R_lower_limit_topology R R_lower_limit_topology)
	              R R_lower_limit_topology (projection1 R R) (affine_line_R2 a b c)
	              HTprod HTll Hsub Hproj1Cont).
	          * let x. assume HxR: x :e R.
	            exact (projection1_after_affine_line_R2_param_by_x a b c x HaR HbR HcR HxR).
	        + let p. assume Hp: p :e affine_line_R2 a b c.
	          exact (affine_line_R2_param_by_x_after_projection1_on_line a b c p HaR HbR HcR Hbne Hp).
	  }
	  exact (Hcase
	    (exists f:set,
	      homeomorphism R R_lower_limit_topology (affine_line_R2 a b c)
	        (subspace_topology (setprod R R)
           (product_topology R R_lower_limit_topology R R_lower_limit_topology)
           (affine_line_R2 a b c)) f)
    Hb0case
    Hnotsigncase).
Qed.

(** helper: homeomorphisms are injective **)
(** LATEX VERSION: A homeomorphism is injective (as it has a two-sided inverse). **)
Theorem homeomorphism_injective : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f ->
  forall x1 x2:set, x1 :e X -> x2 :e X -> apply_fun f x1 = apply_fun f x2 -> x1 = x2.
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
let x1 x2.
assume Hx1X: x1 :e X.
assume Hx2X: x2 :e X.
assume Heq: apply_fun f x1 = apply_fun f x2.
prove x1 = x2.
claim Hexg:
  exists g:set, continuous_map Y Ty X Tx g /\
    (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
    (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
{ exact (andER (continuous_map X Tx Y Ty f)
               (exists g:set, continuous_map Y Ty X Tx g /\
                 (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
                 (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
               Hhom). }
apply Hexg.
let g. assume Hgprop.
claim Hginv: forall x:set, x :e X -> apply_fun g (apply_fun f x) = x.
{ exact (andER (continuous_map Y Ty X Tx g)
               (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x)
               (andEL (continuous_map Y Ty X Tx g /\
                      (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x))
                     (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y)
                     Hgprop)). }
rewrite <- (Hginv x1 Hx1X).
rewrite <- (Hginv x2 Hx2X).
rewrite Heq.
reflexivity.
Qed.

(** from §18: continuous maps on subspaces **) 
(** LATEX VERSION: Restricting a continuous map to a subspace remains continuous. **)
Theorem continuous_on_subspace : forall X Tx Y Ty f A:set,
  topology_on X Tx -> A c= X ->
  continuous_map X Tx Y Ty f ->
  continuous_map A (subspace_topology X Tx A) Y Ty f.
let X Tx Y Ty f A.
assume HTx: topology_on X Tx.
assume HA: A c= X.
assume Hf: continuous_map X Tx Y Ty f.
prove continuous_map A (subspace_topology X Tx A) Y Ty f.
(** Strategy: f continuous on X means f⁻¹(V) open in X for each V open in Y; for subspace topology on A, show f⁻¹(V) is open in subspace_topology by taking U = f⁻¹(V) in the representation (U :/\: A). **)
(** Extract components from Hf - but we already have HTx as a hypothesis, so we mainly need the others **)
(** Hf: topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\ (forall V...) **)
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on X Tx) (topology_on Y Ty)
          (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
            (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                   (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                   Hf))). }
claim Hfun: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
          (andEL (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
                 (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                 Hf)). }
claim Hf_preimg: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf). }
(** Build continuous_map A (subspace_topology X Tx A) Y Ty f **)
claim HTsubspace: topology_on A (subspace_topology X Tx A).
{ exact (subspace_topology_is_topology X Tx A HTx HA). }
claim Hfun_A: function_on f A Y.
{ prove forall x:set, x :e A -> apply_fun f x :e Y.
  let x. assume HxA: x :e A.
  claim HxX: x :e X.
  { exact (HA x HxA). }
  exact (Hfun x HxX). }
(** Show preimages are open in subspace topology **)
claim Hpreimg_subspace: forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A.
{ let V. assume HV: V :e Ty.
  prove preimage_of A f V :e subspace_topology X Tx A.
  (** preimage_of A f V = {x :e A | apply_fun f x :e V} = preimage_of X f V ∩ A **)
  set U := preimage_of X f V.
  claim HU_open: U :e Tx.
  { exact (Hf_preimg V HV). }
  (** Show preimage_of A f V = U ∩ A **)
  claim Hpreimg_eq: preimage_of A f V = U :/\: A.
  { apply set_ext.
    - let x. assume Hx: x :e preimage_of A f V.
      prove x :e U :/\: A.
      claim HxA: x :e A.
      { exact (SepE1 A (fun y => apply_fun f y :e V) x Hx). }
      claim Hfx_V: apply_fun f x :e V.
      { exact (SepE2 A (fun y => apply_fun f y :e V) x Hx). }
      claim HxX: x :e X.
      { exact (HA x HxA). }
      claim HxU: x :e U.
      { exact (SepI X (fun y => apply_fun f y :e V) x HxX Hfx_V). }
      exact (binintersectI U A x HxU HxA).
    - let x. assume Hx: x :e U :/\: A.
      prove x :e preimage_of A f V.
      claim HxU: x :e U.
      { exact (binintersectE1 U A x Hx). }
      claim HxA: x :e A.
      { exact (binintersectE2 U A x Hx). }
      claim Hfx_V: apply_fun f x :e V.
      { exact (SepE2 X (fun y => apply_fun f y :e V) x HxU). }
      exact (SepI A (fun y => apply_fun f y :e V) x HxA Hfx_V). }
  (** Now show preimage_of A f V is in subspace_topology **)
  prove preimage_of A f V :e {W :e Power A | exists Z :e Tx, W = Z :/\: A}.
  claim HpAV_PowerA: preimage_of A f V :e Power A.
  { apply PowerI.
    let x. assume Hx: x :e preimage_of A f V.
    exact (SepE1 A (fun y => apply_fun f y :e V) x Hx). }
  claim Hexists: exists Z :e Tx, preimage_of A f V = Z :/\: A.
  { witness U.
    apply andI.
    - exact HU_open.
    - exact Hpreimg_eq. }
  exact (SepI (Power A) (fun W => exists Z :e Tx, W = Z :/\: A) (preimage_of A f V) HpAV_PowerA Hexists). }
(** Build the full conjunction for continuous_map **)
(** Need: topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty /\ function_on f A Y /\ (forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A); this is left-associative: (((A /\ B) /\ C) /\ D). **)
claim Hpart1: topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty.
{ apply andI.
  - exact HTsubspace.
  - exact HTy. }
claim Hpart2: (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty) /\ function_on f A Y.
{ apply andI.
  - exact Hpart1.
  - exact Hfun_A. }
prove (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty /\ function_on f A Y) /\
      (forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A).
apply andI.
- exact Hpart2.
- exact Hpreimg_subspace.
Qed.

(** from §18: inverse of homeomorphism is continuous **)
(** LATEX VERSION: The inverse of a homeomorphism is continuous. **)
Theorem homeomorphism_inverse_continuous : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f ->
  exists g:set, continuous_map Y Ty X Tx g /\
    (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
    (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
prove exists g:set, continuous_map Y Ty X Tx g /\
  (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
  (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
(** By definition of homeomorphism, the continuous inverse g exists. **)
exact (andER (continuous_map X Tx Y Ty f)
             (exists g:set, continuous_map Y Ty X Tx g /\
                (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
                (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
             Hhom).
Qed.

(** Helper: function_on for a pasted total functional map **)
Theorem function_union_on_disjoint_total_functional : forall A B Y f g:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  total_function_on f A Y ->
  total_function_on g B Y ->
  functional_graph f ->
  functional_graph g ->
  function_on (f :\/: g) (A :\/: B) Y.
let A B Y f g.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Htotf: total_function_on f A Y.
assume Htotg: total_function_on g B Y.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
claim Hrf: graph_range_subset f Y.
{ exact (graph_range_subset_from_total_functional A Y f Hdomf Htotf Hfunf). }
claim Hrg: graph_range_subset g Y.
{ exact (graph_range_subset_from_total_functional B Y g Hdomg Htotg Hfung). }
claim Hrfg: graph_range_subset (f :\/: g) Y.
{ exact (graph_range_subset_binunion f g Y Hrf Hrg). }
claim Htotfg: forall x:set, x :e (A :\/: B) -> exists y:set, y :e Y /\ (x,y) :e (f :\/: g).
{ let x. assume Hx: x :e (A :\/: B).
  apply (binunionE A B x Hx).
  - assume HxA: x :e A.
    apply (total_function_on_totality f A Y Htotf x HxA).
    let y. assume Hy: y :e Y /\ (x,y) :e f.
    witness y.
    apply andI.
    + exact (andEL (y :e Y) ((x,y) :e f) Hy).
    + exact (binunionI1 f g (x,y) (andER (y :e Y) ((x,y) :e f) Hy)).
  - assume HxB: x :e B.
    apply (total_function_on_totality g B Y Htotg x HxB).
    let y. assume Hy: y :e Y /\ (x,y) :e g.
    witness y.
    apply andI.
    + exact (andEL (y :e Y) ((x,y) :e g) Hy).
    + exact (binunionI2 f g (x,y) (andER (y :e Y) ((x,y) :e g) Hy)). }
exact (function_on_from_totality_and_range (A :\/: B) Y (f :\/: g) Htotfg Hrfg).
Qed.

(** Helper: total_function_on for a pasted total functional map **)
Theorem total_function_union_on_disjoint_total_functional : forall A B Y f g:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  total_function_on f A Y ->
  total_function_on g B Y ->
  functional_graph f ->
  functional_graph g ->
  total_function_on (f :\/: g) (A :\/: B) Y.
let A B Y f g.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Htotf: total_function_on f A Y.
assume Htotg: total_function_on g B Y.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
prove function_on (f :\/: g) (A :\/: B) Y /\
  forall x:set, x :e (A :\/: B) -> exists y:set, y :e Y /\ (x,y) :e (f :\/: g).
apply andI.
- exact (function_union_on_disjoint_total_functional A B Y f g
           Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung).
- let x. assume Hx: x :e (A :\/: B).
  prove exists y:set, y :e Y /\ (x,y) :e (f :\/: g).
  apply (binunionE A B x Hx).
  * assume HxA: x :e A.
    apply (total_function_on_totality f A Y Htotf x HxA).
    let y. assume Hy: y :e Y /\ (x,y) :e f.
    witness y.
    apply andI.
    { exact (andEL (y :e Y) ((x,y) :e f) Hy). }
    { exact (binunionI1 f g (x,y) (andER (y :e Y) ((x,y) :e f) Hy)). }
  * assume HxB: x :e B.
    apply (total_function_on_totality g B Y Htotg x HxB).
    let y. assume Hy: y :e Y /\ (x,y) :e g.
    witness y.
    apply andI.
    { exact (andEL (y :e Y) ((x,y) :e g) Hy). }
    { exact (binunionI2 f g (x,y) (andER (y :e Y) ((x,y) :e g) Hy)). }
Qed.

(** Helper: union of functional graphs with disjoint domains is functional **)
Theorem functional_graph_union_disjoint_domains : forall A B f g:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  functional_graph f ->
  functional_graph g ->
  functional_graph (f :\/: g).
let A B f g.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
let x y1 y2.
assume H1: (x,y1) :e (f :\/: g).
assume H2: (x,y2) :e (f :\/: g).
apply (binunionE f g (x,y1) H1).
- assume H1f: (x,y1) :e f.
  apply (binunionE f g (x,y2) H2).
  + assume H2f: (x,y2) :e f.
    exact (Hfunf x y1 y2 H1f H2f).
  + assume H2g: (x,y2) :e g.
    claim HxA: x :e A.
    { exact (Hdomf x y1 H1f). }
    claim HxB: x :e B.
    { exact (Hdomg x y2 H2g). }
    claim HxAB: x :e A :/\: B.
    { exact (binintersectI A B x HxA HxB). }
    claim HxE: x :e Empty.
    { rewrite <- Hdisj.
      exact HxAB. }
    apply FalseE.
    exact ((EmptyE x) HxE).
- assume H1g: (x,y1) :e g.
  apply (binunionE f g (x,y2) H2).
  + assume H2f: (x,y2) :e f.
    claim HxB: x :e B.
    { exact (Hdomg x y1 H1g). }
    claim HxA: x :e A.
    { exact (Hdomf x y2 H2f). }
    claim HxAB: x :e A :/\: B.
    { exact (binintersectI A B x HxA HxB). }
    claim HxE: x :e Empty.
    { rewrite <- Hdisj.
      exact HxAB. }
    apply FalseE.
    exact ((EmptyE x) HxE).
  + assume H2g: (x,y2) :e g.
    exact (Hfung x y1 y2 H1g H2g).
Qed.

(** Helper: apply_fun on a pasted total functional map, left side **)
Theorem apply_fun_union_left : forall A B Y f g x:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  total_function_on f A Y ->
  total_function_on g B Y ->
  functional_graph f ->
  functional_graph g ->
  x :e A ->
  apply_fun (f :\/: g) x = apply_fun f x.
let A B Y f g x.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Htotf: total_function_on f A Y.
assume Htotg: total_function_on g B Y.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
assume HxA: x :e A.
claim Hpairf: (x, apply_fun f x) :e f.
{ exact (total_function_on_apply_fun_in_graph f A Y x Htotf HxA). }
claim HpairU: (x, apply_fun f x) :e (f :\/: g).
{ exact (binunionI1 f g (x, apply_fun f x) Hpairf). }
claim HfunU: functional_graph (f :\/: g).
{ exact (functional_graph_union_disjoint_domains A B f g Hdisj Hdomf Hdomg Hfunf Hfung). }
exact (functional_graph_apply_fun_eq (f :\/: g) x (apply_fun f x) HfunU HpairU).
Qed.

(** Helper: apply_fun on a pasted total functional map, right side **)
Theorem apply_fun_union_right : forall A B Y f g x:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  total_function_on f A Y ->
  total_function_on g B Y ->
  functional_graph f ->
  functional_graph g ->
  x :e B ->
  apply_fun (f :\/: g) x = apply_fun g x.
let A B Y f g x.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Htotf: total_function_on f A Y.
assume Htotg: total_function_on g B Y.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
assume HxB: x :e B.
claim Hpairg: (x, apply_fun g x) :e g.
{ exact (total_function_on_apply_fun_in_graph g B Y x Htotg HxB). }
claim HpairU: (x, apply_fun g x) :e (f :\/: g).
{ exact (binunionI2 f g (x, apply_fun g x) Hpairg). }
claim HfunU: functional_graph (f :\/: g).
{ exact (functional_graph_union_disjoint_domains A B f g Hdisj Hdomf Hdomg Hfunf Hfung). }
exact (functional_graph_apply_fun_eq (f :\/: g) x (apply_fun g x) HfunU HpairU).
Qed.

(** Helper: preimage decomposition for pasted total functional maps **)
Theorem preimage_of_union_functions_total : forall A B Y f g V:set,
  A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  total_function_on f A Y ->
  total_function_on g B Y ->
  functional_graph f ->
  functional_graph g ->
  preimage_of (A :\/: B) (f :\/: g) V =
    (preimage_of A f V) :\/: (preimage_of B g V).
let A B Y f g V.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Htotf: total_function_on f A Y.
assume Htotg: total_function_on g B Y.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
apply set_ext.
- let x. assume Hx: x :e preimage_of (A :\/: B) (f :\/: g) V.
  prove x :e (preimage_of A f V) :\/: (preimage_of B g V).
  claim HxAB: x :e (A :\/: B).
  { exact (SepE1 (A :\/: B) (fun x0:set => apply_fun (f :\/: g) x0 :e V) x Hx). }
  claim HfxV: apply_fun (f :\/: g) x :e V.
  { exact (SepE2 (A :\/: B) (fun x0:set => apply_fun (f :\/: g) x0 :e V) x Hx). }
  apply (binunionE A B x HxAB).
  * assume HxA: x :e A.
    claim Happ: apply_fun (f :\/: g) x = apply_fun f x.
    { exact (apply_fun_union_left A B Y f g x Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung HxA). }
    claim Hfx: apply_fun f x :e V.
    { rewrite <- Happ.
      exact HfxV. }
    claim HxPre: x :e preimage_of A f V.
    { exact (SepI A (fun x0:set => apply_fun f x0 :e V) x HxA Hfx). }
    exact (binunionI1 (preimage_of A f V) (preimage_of B g V) x HxPre).
  * assume HxB: x :e B.
    claim Happ: apply_fun (f :\/: g) x = apply_fun g x.
    { exact (apply_fun_union_right A B Y f g x Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung HxB). }
    claim Hgx: apply_fun g x :e V.
    { rewrite <- Happ.
      exact HfxV. }
    claim HxPre: x :e preimage_of B g V.
    { exact (SepI B (fun x0:set => apply_fun g x0 :e V) x HxB Hgx). }
    exact (binunionI2 (preimage_of A f V) (preimage_of B g V) x HxPre).
- let x. assume Hx: x :e (preimage_of A f V) :\/: (preimage_of B g V).
  prove x :e preimage_of (A :\/: B) (f :\/: g) V.
  apply (binunionE (preimage_of A f V) (preimage_of B g V) x Hx).
  * assume HxPreA: x :e preimage_of A f V.
    claim HxA: x :e A.
    { exact (SepE1 A (fun x0:set => apply_fun f x0 :e V) x HxPreA). }
    claim HfxV: apply_fun f x :e V.
    { exact (SepE2 A (fun x0:set => apply_fun f x0 :e V) x HxPreA). }
    claim HxAB: x :e A :\/: B.
    { exact (binunionI1 A B x HxA). }
    claim Happ: apply_fun (f :\/: g) x = apply_fun f x.
    { exact (apply_fun_union_left A B Y f g x Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung HxA). }
    claim HfgV: apply_fun (f :\/: g) x :e V.
    { rewrite Happ.
      exact HfxV. }
    exact (SepI (A :\/: B) (fun x0:set => apply_fun (f :\/: g) x0 :e V) x HxAB HfgV).
  * assume HxPreB: x :e preimage_of B g V.
    claim HxB: x :e B.
    { exact (SepE1 B (fun x0:set => apply_fun g x0 :e V) x HxPreB). }
    claim HgxV: apply_fun g x :e V.
    { exact (SepE2 B (fun x0:set => apply_fun g x0 :e V) x HxPreB). }
    claim HxAB: x :e A :\/: B.
    { exact (binunionI2 A B x HxB). }
    claim Happ: apply_fun (f :\/: g) x = apply_fun g x.
    { exact (apply_fun_union_right A B Y f g x Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung HxB). }
    claim HfgV: apply_fun (f :\/: g) x :e V.
    { rewrite Happ.
      exact HgxV. }
    exact (SepI (A :\/: B) (fun x0:set => apply_fun (f :\/: g) x0 :e V) x HxAB HfgV).
Qed.

(** Helper: unions of open subsets of disjoint open subspaces are open in the union subspace **)
Theorem subspace_union_of_opens : forall X Tx A B U V:set,
  topology_on X Tx -> A :e Tx -> B :e Tx -> A :/\: B = Empty ->
  U :e subspace_topology X Tx A ->
  V :e subspace_topology X Tx B ->
  (U :\/: V) :e subspace_topology X Tx (A :\/: B).
let X Tx A B U V.
assume HTx: topology_on X Tx.
assume HA: A :e Tx.
assume HB: B :e Tx.
assume Hdisj: A :/\: B = Empty.
assume HU: U :e subspace_topology X Tx A.
assume HV: V :e subspace_topology X Tx B.
prove (U :\/: V) :e subspace_topology X Tx (A :\/: B).
(** Unpack U open in subspace A **)
claim HUpowA: U :e Power A.
{ exact (SepE1 (Power A) (fun U0:set => exists W :e Tx, U0 = W :/\: A) U HU). }
claim HUsubA: U c= A.
{ exact (PowerE A U HUpowA). }
claim HexWU: exists W :e Tx, U = W :/\: A.
{ exact (SepE2 (Power A) (fun U0:set => exists W :e Tx, U0 = W :/\: A) U HU). }
apply HexWU.
let WU. assume HWUpair.
claim HWUinTx: WU :e Tx.
{ exact (andEL (WU :e Tx) (U = WU :/\: A) HWUpair). }
claim HUeq: U = WU :/\: A.
{ exact (andER (WU :e Tx) (U = WU :/\: A) HWUpair). }
claim HUAinTx: WU :/\: A :e Tx.
{ exact (topology_binintersect_closed X Tx WU A HTx HWUinTx HA). }
claim HUinTx: U :e Tx.
{ rewrite HUeq. exact HUAinTx. }

(** Unpack V open in subspace B **)
claim HVpowB: V :e Power B.
{ exact (SepE1 (Power B) (fun V0:set => exists W :e Tx, V0 = W :/\: B) V HV). }
claim HVsubB: V c= B.
{ exact (PowerE B V HVpowB). }
claim HexWV: exists W :e Tx, V = W :/\: B.
{ exact (SepE2 (Power B) (fun V0:set => exists W :e Tx, V0 = W :/\: B) V HV). }
apply HexWV.
let WV. assume HWVpair.
claim HWVinTx: WV :e Tx.
{ exact (andEL (WV :e Tx) (V = WV :/\: B) HWVpair). }
claim HVeql: V = WV :/\: B.
{ exact (andER (WV :e Tx) (V = WV :/\: B) HWVpair). }
claim HVBinTx: WV :/\: B :e Tx.
{ exact (topology_binintersect_closed X Tx WV B HTx HWVinTx HB). }
claim HVinTx: V :e Tx.
{ rewrite HVeql. exact HVBinTx. }

(** Hence U∪V is open in X, and it lies in A∪B **)
claim HUVinTx: (U :\/: V) :e Tx.
{ exact (topology_binunion_closed X Tx U V HTx HUinTx HVinTx). }
claim HAsubAB: A c= A :\/: B.
{ exact (binunion_Subq_1 A B). }
claim HBsubAB: B c= A :\/: B.
{ exact (binunion_Subq_2 A B). }
claim HUsubAB: U c= A :\/: B.
{ let x. assume Hx: x :e U.
  prove x :e A :\/: B.
  exact (HAsubAB x (HUsubA x Hx)). }
claim HVsubAB: V c= A :\/: B.
{ let x. assume Hx: x :e V.
  prove x :e A :\/: B.
  exact (HBsubAB x (HVsubB x Hx)). }
claim HUVsubAB: (U :\/: V) c= A :\/: B.
{ exact (binunion_Subq_min U V (A :\/: B) HUsubAB HVsubAB). }
claim HUVpowAB: (U :\/: V) :e Power (A :\/: B).
{ exact (PowerI (A :\/: B) (U :\/: V) HUVsubAB). }

(** Apply subspace_topology definition on A∪B, using witness W = U∪V **)
claim HPred: exists W :e Tx, (U :\/: V) = W :/\: (A :\/: B).
{ witness (U :\/: V).
  apply andI.
  + exact HUVinTx.
  + prove (U :\/: V) = (U :\/: V) :/\: (A :\/: B).
    claim Heq: (U :\/: V) :/\: (A :\/: B) = (U :\/: V).
    { exact (binintersect_Subq_eq_1 (U :\/: V) (A :\/: B) HUVsubAB). }
    rewrite Heq.
    reflexivity. }
exact (SepI (Power (A :\/: B))
            (fun U0:set => exists W :e Tx, U0 = W :/\: (A :\/: B))
            (U :\/: V) HUVpowAB HPred).
Qed.

(** Helper: pasting lemma variant for total functional maps **)
Theorem pasting_lemma_total_functional : forall X A B Y Tx Ty f g:set,
  topology_on X Tx ->
  A :e Tx -> B :e Tx -> A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  functional_graph f ->
  functional_graph g ->
  continuous_map_total A (subspace_topology X Tx A) Y Ty f ->
  continuous_map_total B (subspace_topology X Tx B) Y Ty g ->
  continuous_map_total (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g).
let X A B Y Tx Ty f g.
assume HTx: topology_on X Tx.
assume HA: A :e Tx.
assume HB: B :e Tx.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
assume Hf: continuous_map_total A (subspace_topology X Tx A) Y Ty f.
assume Hg: continuous_map_total B (subspace_topology X Tx B) Y Ty g.
prove continuous_map_total (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g).

(** Extract components from Hf **)
claim Hf_left: (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty) /\ total_function_on f A Y.
{ exact (andEL ((topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty) /\ total_function_on f A Y)
               (forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A) Hf). }
claim Hpreimg_f: forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A.
{ exact (andER ((topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty) /\ total_function_on f A Y)
               (forall V:set, V :e Ty -> preimage_of A f V :e subspace_topology X Tx A) Hf). }
claim Hf_tops: topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty.
{ exact (andEL (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty)
               (total_function_on f A Y) Hf_left). }
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on A (subspace_topology X Tx A)) (topology_on Y Ty) Hf_tops). }
claim Htotf: total_function_on f A Y.
{ exact (andER (topology_on A (subspace_topology X Tx A) /\ topology_on Y Ty)
               (total_function_on f A Y) Hf_left). }

(** Extract components from Hg **)
claim Hg_left: (topology_on B (subspace_topology X Tx B) /\ topology_on Y Ty) /\ total_function_on g B Y.
{ exact (andEL ((topology_on B (subspace_topology X Tx B) /\ topology_on Y Ty) /\ total_function_on g B Y)
               (forall V:set, V :e Ty -> preimage_of B g V :e subspace_topology X Tx B) Hg). }
claim Hpreimg_g: forall V:set, V :e Ty -> preimage_of B g V :e subspace_topology X Tx B.
{ exact (andER ((topology_on B (subspace_topology X Tx B) /\ topology_on Y Ty) /\ total_function_on g B Y)
               (forall V:set, V :e Ty -> preimage_of B g V :e subspace_topology X Tx B) Hg). }
claim Htotg: total_function_on g B Y.
{ exact (andER (topology_on B (subspace_topology X Tx B) /\ topology_on Y Ty)
               (total_function_on g B Y) Hg_left). }

(** Build the topology on A ∪ B **)
claim HAB_sub: A :\/: B c= X.
{ apply binunion_Subq_min.
  - exact (topology_elem_subset X Tx A HTx HA).
  - exact (topology_elem_subset X Tx B HTx HB). }
claim HTsub: topology_on (A :\/: B) (subspace_topology X Tx (A :\/: B)).
{ exact (subspace_topology_is_topology X Tx (A :\/: B) HTx HAB_sub). }

(** Totality of the pasted map **)
claim Htotfg: total_function_on (f :\/: g) (A :\/: B) Y.
{ exact (total_function_union_on_disjoint_total_functional A B Y f g
           Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung). }

(** Preimage openness for the pasted map **)
claim Hpreimg_fg: forall V:set, V :e Ty ->
  preimage_of (A :\/: B) (f :\/: g) V :e subspace_topology X Tx (A :\/: B).
{ let V. assume HV: V :e Ty.
  claim Heq: preimage_of (A :\/: B) (f :\/: g) V =
    (preimage_of A f V) :\/: (preimage_of B g V).
  { exact (preimage_of_union_functions_total A B Y f g V
           Hdisj Hdomf Hdomg Htotf Htotg Hfunf Hfung). }
  claim HfV: preimage_of A f V :e subspace_topology X Tx A.
  { exact (Hpreimg_f V HV). }
  claim HgV: preimage_of B g V :e subspace_topology X Tx B.
  { exact (Hpreimg_g V HV). }
  claim Hunion: (preimage_of A f V :\/: preimage_of B g V) :e subspace_topology X Tx (A :\/: B).
  { exact (subspace_union_of_opens X Tx A B (preimage_of A f V) (preimage_of B g V)
           HTx HA HB Hdisj HfV HgV). }
  prove preimage_of (A :\/: B) (f :\/: g) V :e subspace_topology X Tx (A :\/: B).
  rewrite Heq.
  exact Hunion. }

(** Assemble the proof **)
prove ((topology_on (A :\/: B) (subspace_topology X Tx (A :\/: B)) /\ topology_on Y Ty) /\
      total_function_on (f :\/: g) (A :\/: B) Y) /\
      (forall V:set, V :e Ty ->
        preimage_of (A :\/: B) (f :\/: g) V :e subspace_topology X Tx (A :\/: B)).
apply andI.
- apply andI.
  * apply andI.
    { exact HTsub. }
    { exact HTy. }
  * exact Htotfg.
- exact Hpreimg_fg.
Qed.

(** Helper: pasting lemma variant gives continuity in the weaker sense **)
Theorem pasting_lemma_total_functional_imp : forall X A B Y Tx Ty f g:set,
  topology_on X Tx ->
  A :e Tx -> B :e Tx -> A :/\: B = Empty ->
  graph_domain_subset f A ->
  graph_domain_subset g B ->
  functional_graph f ->
  functional_graph g ->
  continuous_map_total A (subspace_topology X Tx A) Y Ty f ->
  continuous_map_total B (subspace_topology X Tx B) Y Ty g ->
  continuous_map (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g).
let X A B Y Tx Ty f g.
assume HTx: topology_on X Tx.
assume HA: A :e Tx.
assume HB: B :e Tx.
assume Hdisj: A :/\: B = Empty.
assume Hdomf: graph_domain_subset f A.
assume Hdomg: graph_domain_subset g B.
assume Hfunf: functional_graph f.
assume Hfung: functional_graph g.
assume Hf: continuous_map_total A (subspace_topology X Tx A) Y Ty f.
assume Hg: continuous_map_total B (subspace_topology X Tx B) Y Ty g.
prove continuous_map (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g).
claim Htot: continuous_map_total (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g).
{ exact (pasting_lemma_total_functional X A B Y Tx Ty f g
         HTx HA HB Hdisj Hdomf Hdomg Hfunf Hfung Hf Hg). }
exact (continuous_map_total_imp (A :\/: B) (subspace_topology X Tx (A :\/: B)) Y Ty (f :\/: g) Htot).
Qed.

(** from §18 Theorem 18.3: pasting lemma **)
(** LATEX VERSION: Let X=A∪B, where A and B are closed in X. Let f:A→Y and g:B→Y be continuous. If f=g on A∩B, then the combined map h:X→Y defined by h|A=f and h|B=g is continuous. **)
Theorem pasting_lemma : forall X A B Y Tx Ty f g:set,
  topology_on X Tx ->
  closed_in X Tx A ->
  closed_in X Tx B ->
  A :\/: B = X ->
  continuous_map A (subspace_topology X Tx A) Y Ty f ->
  continuous_map B (subspace_topology X Tx B) Y Ty g ->
  (forall x:set, x :e (A :/\: B) -> apply_fun f x = apply_fun g x) ->
  exists h:set,
    continuous_map X Tx Y Ty h /\
    ((forall x:set, x :e A -> apply_fun h x = apply_fun f x) /\
     (forall x:set, x :e B -> apply_fun h x = apply_fun g x)).
let X A B Y Tx Ty f g.
assume HTx: topology_on X Tx.
assume HclA: closed_in X Tx A.
assume HclB: closed_in X Tx B.
assume HABeq: A :\/: B = X.
assume Hf: continuous_map A (subspace_topology X Tx A) Y Ty f.
assume Hg: continuous_map B (subspace_topology X Tx B) Y Ty g.
assume Hagree: forall x:set, x :e (A :/\: B) -> apply_fun f x = apply_fun g x.

(** Define the pasted graph using a piecewise rule on membership in A **)
set h := graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0).
witness h.
prove continuous_map X Tx Y Ty h /\
  ((forall x:set, x :e A -> apply_fun h x = apply_fun f x) /\
   (forall x:set, x :e B -> apply_fun h x = apply_fun g x)).

apply andI.
- (** continuity of h **)
  claim HTy: topology_on Y Ty.
  { exact (continuous_map_topology_cod A (subspace_topology X Tx A) Y Ty f Hf). }

  claim Hfunf: function_on f A Y.
  { exact (continuous_map_function_on A (subspace_topology X Tx A) Y Ty f Hf). }
  claim Hfung: function_on g B Y.
  { exact (continuous_map_function_on B (subspace_topology X Tx B) Y Ty g Hg). }

  prove continuous_map X Tx Y Ty h.
  prove topology_on X Tx /\ topology_on Y Ty /\ function_on h X Y /\
        forall V:set, V :e Ty -> preimage_of X h V :e Tx.
  apply andI.
  + (** (topology_on X Tx /\ topology_on Y Ty) /\ function_on h X Y **)
    apply andI.
    * apply andI.
      { exact HTx. }
      { exact HTy. }
    * (** function_on h X Y **)
      let x. assume HxX: x :e X.
      prove apply_fun h x :e Y.
      claim Happ: apply_fun h x = if x :e A then apply_fun f x else apply_fun g x.
      { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
        reflexivity. }
      rewrite Happ.
      apply (xm (x :e A)).
      + assume HxA: x :e A.
         rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
         exact (Hfunf x HxA).
      + assume HxNotA: x /:e A.
         claim HxAB: x :e A :\/: B.
         { rewrite HABeq. exact HxX. }
         apply (binunionE A B x HxAB).
         + assume HxA: x :e A.
             apply FalseE.
             exact (HxNotA HxA).
         + assume HxB: x :e B.
             rewrite (If_i_0 (x :e A) (apply_fun f x) (apply_fun g x) HxNotA).
             exact (Hfung x HxB).

  + (** preimage condition **)
    let V. assume HV: V :e Ty.
    (** preimages in the subspace topologies **)
    claim HpreA: preimage_of A f V :e subspace_topology X Tx A.
    { exact (continuous_map_preimage A (subspace_topology X Tx A) Y Ty f Hf V HV). }
    claim HpreB: preimage_of B g V :e subspace_topology X Tx B.
    { exact (continuous_map_preimage B (subspace_topology X Tx B) Y Ty g Hg V HV). }

    (** choose open sets U0,W0 in X representing these subspace opens **)
    claim HexU0: exists U0 :e Tx, preimage_of A f V = U0 :/\: A.
    { exact (SepE2 (Power A) (fun U:set => exists U0 :e Tx, U = U0 :/\: A) (preimage_of A f V) HpreA). }
    apply HexU0.
    let U0. assume HU0pair.
    claim HU0: U0 :e Tx.
    { exact (andEL (U0 :e Tx) (preimage_of A f V = U0 :/\: A) HU0pair). }
    claim HpreAeq: preimage_of A f V = U0 :/\: A.
    { exact (andER (U0 :e Tx) (preimage_of A f V = U0 :/\: A) HU0pair). }

    claim HexW0: exists W0 :e Tx, preimage_of B g V = W0 :/\: B.
    { exact (SepE2 (Power B) (fun U:set => exists W0 :e Tx, U = W0 :/\: B) (preimage_of B g V) HpreB). }
    apply HexW0.
    let W0. assume HW0pair.
    claim HW0: W0 :e Tx.
    { exact (andEL (W0 :e Tx) (preimage_of B g V = W0 :/\: B) HW0pair). }
    claim HpreBeq: preimage_of B g V = W0 :/\: B.
    { exact (andER (W0 :e Tx) (preimage_of B g V = W0 :/\: B) HW0pair). }

    (** complements are open since A and B are closed **)
    claim HcompAin: open_in X Tx (X :\: A).
    { exact (open_of_closed_complement X Tx A HclA). }
    claim HcompA: (X :\: A) :e Tx.
    { exact (open_in_elem X Tx (X :\: A) HcompAin). }
    claim HcompBin: open_in X Tx (X :\: B).
    { exact (open_of_closed_complement X Tx B HclB). }
    claim HcompB: (X :\: B) :e Tx.
    { exact (open_in_elem X Tx (X :\: B) HcompBin). }

    (** define the open sets U = U0 ∪ (X\\A) and W = W0 ∪ (X\\B) **)
    set U := U0 :\/: (X :\: A).
    set W := W0 :\/: (X :\: B).
    claim HUopen: U :e Tx.
    { exact (topology_binunion_closed X Tx U0 (X :\: A) HTx HU0 HcompA). }
    claim HWopen: W :e Tx.
    { exact (topology_binunion_closed X Tx W0 (X :\: B) HTx HW0 HcompB). }

    (** main set equality: h^{-1}(V) = U ∩ W **)
    claim Heq: preimage_of X h V = U :/\: W.
    { apply set_ext.
      - let x. assume Hx: x :e preimage_of X h V.
        prove x :e U :/\: W.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => apply_fun h x0 :e V) x Hx). }
        claim HhxV: apply_fun h x :e V.
        { exact (SepE2 X (fun x0:set => apply_fun h x0 :e V) x Hx). }
        (** show x ∈ U **)
        claim HxU: x :e U.
        { apply (xm (x :e A)).
          + assume HxA: x :e A.
             claim Happ: apply_fun h x = apply_fun f x.
             { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
               rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
               reflexivity. }
             claim HfxV: apply_fun f x :e V.
             { rewrite <- Happ. exact HhxV. }
             claim HxPreA: x :e preimage_of A f V.
             { exact (SepI A (fun x0:set => apply_fun f x0 :e V) x HxA HfxV). }
             claim HxU0A: x :e U0 :/\: A.
             { rewrite <- HpreAeq. exact HxPreA. }
             claim HxU0: x :e U0.
             { exact (binintersectE1 U0 A x HxU0A). }
             exact (binunionI1 U0 (X :\: A) x HxU0).
          + assume HxNotA: x /:e A.
             claim HxXA: x :e (X :\: A).
             { exact (setminusI X A x HxX HxNotA). }
             exact (binunionI2 U0 (X :\: A) x HxXA). }
        (** show x ∈ W **)
        claim HxW: x :e W.
        { apply (xm (x :e B)).
          + assume HxB: x :e B.
             claim HgV: apply_fun g x :e V.
             { apply (xm (x :e A)).
               + assume HxA: x :e A.
                   claim HxAB: x :e A :/\: B.
                   { exact (binintersectI A B x HxA HxB). }
                   claim Heqfg: apply_fun f x = apply_fun g x.
                   { exact (Hagree x HxAB). }
                   claim Happ: apply_fun h x = apply_fun f x.
                   { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
                     rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
                     reflexivity. }
                   claim HfxV: apply_fun f x :e V.
                   { rewrite <- Happ. exact HhxV. }
                   rewrite <- Heqfg.
                   exact HfxV.
               + assume HxNotA: x /:e A.
                   claim Happ: apply_fun h x = apply_fun g x.
                   { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
                     rewrite (If_i_0 (x :e A) (apply_fun f x) (apply_fun g x) HxNotA).
                     reflexivity. }
                   rewrite <- Happ.
                   exact HhxV. }
             claim HxPreB: x :e preimage_of B g V.
             { exact (SepI B (fun x0:set => apply_fun g x0 :e V) x HxB HgV). }
             claim HxW0B: x :e W0 :/\: B.
             { rewrite <- HpreBeq. exact HxPreB. }
             claim HxW0: x :e W0.
             { exact (binintersectE1 W0 B x HxW0B). }
             exact (binunionI1 W0 (X :\: B) x HxW0).
          + assume HxNotB: x /:e B.
             claim HxXB: x :e (X :\: B).
             { exact (setminusI X B x HxX HxNotB). }
             exact (binunionI2 W0 (X :\: B) x HxXB). }
        exact (binintersectI U W x HxU HxW).
      - let x. assume Hx: x :e U :/\: W.
        prove x :e preimage_of X h V.
        claim HxU: x :e U.
        { exact (binintersectE1 U W x Hx). }
        claim HxW: x :e W.
        { exact (binintersectE2 U W x Hx). }
        (** show x ∈ X and apply_fun h x ∈ V **)
        apply (xm (x :e A)).
        + assume HxA: x :e A.
           claim HxX: x :e X.
           { claim HA_sub: A c= X.
             { rewrite <- HABeq. exact (binunion_Subq_1 A B). }
             exact (HA_sub x HxA). }
           claim HxU0: x :e U0.
           { apply (binunionE U0 (X :\: A) x HxU).
             + assume HxU0: x :e U0.
                 exact HxU0.
             + assume HxXA: x :e (X :\: A).
                 claim HnotA: x /:e A.
                 { exact (setminusE2 X A x HxXA). }
                 apply FalseE.
                 exact (HnotA HxA). }
             claim HxPreA: x :e preimage_of A f V.
             { claim HxU0A: x :e U0 :/\: A.
               { exact (binintersectI U0 A x HxU0 HxA). }
             rewrite HpreAeq.
             exact HxU0A. }
           claim HfxV: apply_fun f x :e V.
           { exact (SepE2 A (fun x0:set => apply_fun f x0 :e V) x HxPreA). }
           claim Happ: apply_fun h x = apply_fun f x.
           { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
             rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
             reflexivity. }
           prove x :e preimage_of X h V.
           claim HhxV': apply_fun h x :e V.
           { rewrite Happ.
             exact HfxV. }
           exact (SepI X (fun x0:set => apply_fun h x0 :e V) x HxX HhxV').
        + assume HxNotA: x /:e A.
           (** x ∈ X follows from x ∈ U (second disjunct forces x∈X) **)
           claim HxX: x :e X.
           { apply (binunionE U0 (X :\: A) x HxU).
             + assume HxU0: x :e U0.
                 claim HU0sub: U0 c= X.
                 { exact (topology_elem_subset X Tx U0 HTx HU0). }
                 exact (HU0sub x HxU0).
             + assume HxXA: x :e (X :\: A).
                 exact (setminusE1 X A x HxXA). }
           (** from cover: x ∈ B **)
           claim HxAB: x :e A :\/: B.
           { rewrite HABeq. exact HxX. }
           claim HxB: x :e B.
           { apply (binunionE A B x HxAB).
             + assume HxA: x :e A.
                 apply FalseE.
                 exact (HxNotA HxA).
             + assume HxB: x :e B.
                 exact HxB. }
           (** x ∈ W forces x ∈ W0 (since x ∈ B) **)
           claim HxW0: x :e W0.
           { apply (binunionE W0 (X :\: B) x HxW).
             + assume HxW0: x :e W0.
                 exact HxW0.
             + assume HxXB: x :e (X :\: B).
                 claim HnotB: x /:e B.
                 { exact (setminusE2 X B x HxXB). }
                 apply FalseE.
                 exact (HnotB HxB). }
             claim HxPreB: x :e preimage_of B g V.
             { claim HxW0B: x :e W0 :/\: B.
               { exact (binintersectI W0 B x HxW0 HxB). }
             rewrite HpreBeq.
             exact HxW0B. }
           claim HgV: apply_fun g x :e V.
           { exact (SepE2 B (fun x0:set => apply_fun g x0 :e V) x HxPreB). }
           claim Happ: apply_fun h x = apply_fun g x.
           { rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
             rewrite (If_i_0 (x :e A) (apply_fun f x) (apply_fun g x) HxNotA).
             reflexivity. }
           prove x :e preimage_of X h V.
           claim HhxV': apply_fun h x :e V.
           { rewrite Happ.
             exact HgV. }
           exact (SepI X (fun x0:set => apply_fun h x0 :e V) x HxX HhxV'). }

    prove preimage_of X h V :e Tx.
    rewrite Heq.
    exact (topology_binintersect_closed X Tx U W HTx HUopen HWopen).

- (** h agrees with f on A and with g on B **)
  apply andI.
  + let x. assume HxA: x :e A.
    (** x ∈ X from cover **)
    claim HxAB: x :e A :\/: B.
    { exact (binunionI1 A B x HxA). }
    claim HxX: x :e X.
    { rewrite <- HABeq. exact HxAB. }
    rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
    rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
    reflexivity.
  + let x. assume HxB: x :e B.
    (** x ∈ X from cover **)
    claim HxAB: x :e A :\/: B.
    { exact (binunionI2 A B x HxB). }
    claim HxX: x :e X.
    { rewrite <- HABeq. exact HxAB. }
    apply (xm (x :e A)).
    * assume HxA: x :e A.
      claim HxABi: x :e A :/\: B.
      { exact (binintersectI A B x HxA HxB). }
      claim Heqfg: apply_fun f x = apply_fun g x.
      { exact (Hagree x HxABi). }
      rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
      rewrite (If_i_1 (x :e A) (apply_fun f x) (apply_fun g x) HxA).
      rewrite Heqfg.
      reflexivity.
    * assume HxNotA: x /:e A.
      rewrite (apply_fun_graph X (fun x0:set => if x0 :e A then apply_fun f x0 else apply_fun g x0) x HxX).
      rewrite (If_i_0 (x :e A) (apply_fun f x) (apply_fun g x) HxNotA).
      reflexivity.
Qed.

(** from §18 Theorem 18.4: maps into products **) 
(** LATEX VERSION: A map into a product is continuous iff its coordinate functions are continuous. **)
Definition pair_map : set -> set -> set -> set := fun A f g =>
  {(a, (apply_fun f a, apply_fun g a)) | a :e A}.

(** Helper: apply_fun for pair_map **)
Theorem pair_map_apply : forall A X Y f g a:set,
  a :e A ->
  apply_fun (pair_map A f g) a = (apply_fun f a, apply_fun g a).
let A X Y f g a.
assume Ha: a :e A.
prove apply_fun (pair_map A f g) a = (apply_fun f a, apply_fun g a).
prove Eps_i (fun z => (a,z) :e pair_map A f g) = (apply_fun f a, apply_fun g a).
claim H1: (a, (apply_fun f a, apply_fun g a)) :e pair_map A f g.
{ exact (ReplI A (fun a0:set => (a0, (apply_fun f a0, apply_fun g a0))) a Ha). }
claim H2: (a, Eps_i (fun z => (a,z) :e pair_map A f g)) :e pair_map A f g.
{ exact (Eps_i_ax (fun z => (a,z) :e pair_map A f g) (apply_fun f a, apply_fun g a) H1). }
apply (ReplE_impred A (fun a0:set => (a0, (apply_fun f a0, apply_fun g a0)))
                     (a, Eps_i (fun z => (a,z) :e pair_map A f g)) H2).
let a0.
assume Ha0: a0 :e A.
assume Heq: (a, Eps_i (fun z => (a,z) :e pair_map A f g)) = (a0, (apply_fun f a0, apply_fun g a0)).
claim Ha_eq: a = a0.
{ rewrite <- (tuple_2_0_eq a (Eps_i (fun z => (a,z) :e pair_map A f g))).
  rewrite <- (tuple_2_0_eq a0 (apply_fun f a0, apply_fun g a0)).
  rewrite Heq.
  reflexivity. }
claim Hz_eq: Eps_i (fun z => (a,z) :e pair_map A f g) = (apply_fun f a0, apply_fun g a0).
{ rewrite <- (tuple_2_1_eq a (Eps_i (fun z => (a,z) :e pair_map A f g))) at 1.
  rewrite <- (tuple_2_1_eq a0 (apply_fun f a0, apply_fun g a0)) at 1.
  rewrite Heq.
  reflexivity. }
rewrite Hz_eq.
rewrite Ha_eq.
reflexivity.
Qed.

(** helper: pair_map yields an element of function_space **)
(** LATEX VERSION: If f:A→X and g:A→Y, then (f,g):A→X×Y lies in function_space A (X×Y). **)
Theorem pair_map_in_function_space : forall A X Y f g:set,
  function_on f A X ->
  function_on g A Y ->
  pair_map A f g :e function_space A (setprod X Y).
let A X Y f g.
assume Hf: function_on f A X.
assume Hg: function_on g A Y.
prove pair_map A f g :e function_space A (setprod X Y).
prove pair_map A f g :e {h :e Power (setprod A (setprod X Y))|function_on h A (setprod X Y)}.
apply SepI.
- prove pair_map A f g :e Power (setprod A (setprod X Y)).
  apply PowerI.
  let z. assume Hz: z :e pair_map A f g.
  prove z :e setprod A (setprod X Y).
  apply (ReplE_impred A (fun a0:set => (a0, (apply_fun f a0, apply_fun g a0))) z Hz).
  let a0.
  assume Ha0: a0 :e A.
  assume Heq: z = (a0, (apply_fun f a0, apply_fun g a0)).
  rewrite Heq.
  claim Hxy: (apply_fun f a0, apply_fun g a0) :e setprod X Y.
  { exact (tuple_2_setprod_by_pair_Sigma X Y (apply_fun f a0) (apply_fun g a0)
          (Hf a0 Ha0) (Hg a0 Ha0)). }
  exact (tuple_2_setprod_by_pair_Sigma A (setprod X Y) a0 (apply_fun f a0, apply_fun g a0) Ha0 Hxy).
- prove function_on (pair_map A f g) A (setprod X Y).
  let a. assume Ha: a :e A.
  prove apply_fun (pair_map A f g) a :e setprod X Y.
  rewrite (pair_map_apply A X Y f g a Ha).
  exact (tuple_2_setprod_by_pair_Sigma X Y (apply_fun f a) (apply_fun g a)
        (Hf a Ha) (Hg a Ha)).
Qed.

Theorem preimage_pair_map_rectangle : forall A X Y f g U V:set,
  preimage_of A (pair_map A f g) (rectangle_set U V) =
    (preimage_of A f U) :/\: (preimage_of A g V).
let A X Y f g U V.
apply set_ext.
- let a. assume Ha: a :e preimage_of A (pair_map A f g) (rectangle_set U V).
  prove a :e (preimage_of A f U) :/\: (preimage_of A g V).
  claim HaA: a :e A.
  { exact (SepE1 A (fun a0:set => apply_fun (pair_map A f g) a0 :e rectangle_set U V) a Ha). }
  claim Himg: apply_fun (pair_map A f g) a :e rectangle_set U V.
  { exact (SepE2 A (fun a0:set => apply_fun (pair_map A f g) a0 :e rectangle_set U V) a Ha). }
  claim Happ: apply_fun (pair_map A f g) a = (apply_fun f a, apply_fun g a).
  { exact (pair_map_apply A X Y f g a HaA). }
  claim HpairIn: (apply_fun f a, apply_fun g a) :e rectangle_set U V.
  { rewrite <- Happ.
    exact Himg. }
  claim Hfst: (apply_fun f a, apply_fun g a) 0 :e U.
  { exact (ap0_Sigma U (fun _ : set => V) (apply_fun f a, apply_fun g a) HpairIn). }
  claim Hsnd: (apply_fun f a, apply_fun g a) 1 :e V.
  { exact (ap1_Sigma U (fun _ : set => V) (apply_fun f a, apply_fun g a) HpairIn). }
  claim HfaU: apply_fun f a :e U.
  { rewrite <- (tuple_2_0_eq (apply_fun f a) (apply_fun g a)).
    exact Hfst. }
  claim HgaV: apply_fun g a :e V.
  { rewrite <- (tuple_2_1_eq (apply_fun f a) (apply_fun g a)).
    exact Hsnd. }
  apply binintersectI.
  + exact (SepI A (fun a0:set => apply_fun f a0 :e U) a HaA HfaU).
  + exact (SepI A (fun a0:set => apply_fun g a0 :e V) a HaA HgaV).
- let a. assume Ha: a :e (preimage_of A f U) :/\: (preimage_of A g V).
  prove a :e preimage_of A (pair_map A f g) (rectangle_set U V).
  claim Haf: a :e preimage_of A f U.
  { exact (binintersectE1 (preimage_of A f U) (preimage_of A g V) a Ha). }
  claim Hag: a :e preimage_of A g V.
  { exact (binintersectE2 (preimage_of A f U) (preimage_of A g V) a Ha). }
  claim HaA: a :e A.
  { exact (SepE1 A (fun a0:set => apply_fun f a0 :e U) a Haf). }
  claim HfaU: apply_fun f a :e U.
  { exact (SepE2 A (fun a0:set => apply_fun f a0 :e U) a Haf). }
  claim HgaV: apply_fun g a :e V.
  { exact (SepE2 A (fun a0:set => apply_fun g a0 :e V) a Hag). }
  claim HpairIn: (apply_fun f a, apply_fun g a) :e rectangle_set U V.
  { exact (tuple_2_rectangle_set U V (apply_fun f a) (apply_fun g a) HfaU HgaV). }
  claim Happ: apply_fun (pair_map A f g) a = (apply_fun f a, apply_fun g a).
  { exact (pair_map_apply A X Y f g a HaA). }
  claim Himg: apply_fun (pair_map A f g) a :e rectangle_set U V.
  { rewrite Happ.
    exact HpairIn. }
  exact (SepI A (fun a0:set => apply_fun (pair_map A f g) a0 :e rectangle_set U V) a HaA Himg).
Qed.

Theorem maps_into_products_axiom : forall A Ta X Tx Y Ty f g:set,
  continuous_map A Ta X Tx f ->
  continuous_map A Ta Y Ty g ->
  continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) (pair_map A f g).
let A Ta X Tx Y Ty f g.
assume Hf: continuous_map A Ta X Tx f.
assume Hg: continuous_map A Ta Y Ty g.
claim Hf_mid: (topology_on A Ta /\ topology_on X Tx) /\ function_on f A X.
{ exact (andEL ((topology_on A Ta /\ topology_on X Tx) /\ function_on f A X)
               (forall V:set, V :e Tx -> preimage_of A f V :e Ta)
               Hf). }
claim Hfun_f: function_on f A X.
{ exact (andER (topology_on A Ta /\ topology_on X Tx) (function_on f A X) Hf_mid). }
claim HtopAX: topology_on A Ta /\ topology_on X Tx.
{ exact (andEL (topology_on A Ta /\ topology_on X Tx) (function_on f A X) Hf_mid). }
claim HTa: topology_on A Ta.
{ exact (andEL (topology_on A Ta) (topology_on X Tx) HtopAX). }
claim HTx: topology_on X Tx.
{ exact (andER (topology_on A Ta) (topology_on X Tx) HtopAX). }
claim Hf_pre: forall U:set, U :e Tx -> preimage_of A f U :e Ta.
{ exact (andER ((topology_on A Ta /\ topology_on X Tx) /\ function_on f A X)
               (forall V:set, V :e Tx -> preimage_of A f V :e Ta)
               Hf). }

claim Hg_mid: (topology_on A Ta /\ topology_on Y Ty) /\ function_on g A Y.
{ exact (andEL ((topology_on A Ta /\ topology_on Y Ty) /\ function_on g A Y)
               (forall V:set, V :e Ty -> preimage_of A g V :e Ta)
               Hg). }
claim Hfun_g: function_on g A Y.
{ exact (andER (topology_on A Ta /\ topology_on Y Ty) (function_on g A Y) Hg_mid). }
claim HtopAY: topology_on A Ta /\ topology_on Y Ty.
{ exact (andEL (topology_on A Ta /\ topology_on Y Ty) (function_on g A Y) Hg_mid). }
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on A Ta) (topology_on Y Ty) HtopAY). }
claim Hg_pre: forall V:set, V :e Ty -> preimage_of A g V :e Ta.
{ exact (andER ((topology_on A Ta /\ topology_on Y Ty) /\ function_on g A Y)
               (forall V:set, V :e Ty -> preimage_of A g V :e Ta)
               Hg). }

claim HTprod: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
{ exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }

prove continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) (pair_map A f g).
prove topology_on A Ta /\ topology_on (setprod X Y) (product_topology X Tx Y Ty) /\
  function_on (pair_map A f g) A (setprod X Y) /\
  forall W:set, W :e product_topology X Tx Y Ty -> preimage_of A (pair_map A f g) W :e Ta.
apply andI.
- apply andI.
  + apply andI.
    * exact HTa.
    * exact HTprod.
  + (** function_on **)
    let a. assume HaA: a :e A.
    prove apply_fun (pair_map A f g) a :e setprod X Y.
	    claim Happ: apply_fun (pair_map A f g) a = (apply_fun f a, apply_fun g a).
	    { exact (pair_map_apply A X Y f g a HaA). }
	    rewrite Happ.
	    exact (tuple_2_setprod_by_pair_Sigma X Y (apply_fun f a) (apply_fun g a) (Hfun_f a HaA) (Hfun_g a HaA)).
- let W. assume HW: W :e product_topology X Tx Y Ty.
  prove preimage_of A (pair_map A f g) W :e Ta.
  claim HWopen: open_in (setprod X Y) (product_topology X Tx Y Ty) W.
  { exact (andI (topology_on (setprod X Y) (product_topology X Tx Y Ty)) (W :e product_topology X Tx Y Ty) HTprod HW). }
  apply (open_sets_as_unions_of_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis W HWopen).
  let Fam. assume HFamPair.
  claim HFamPow: Fam :e Power (product_subbasis X Tx Y Ty).
  { exact (andEL (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = W) HFamPair). }
  claim HUnionEq: Union Fam = W.
  { exact (andER (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = W) HFamPair). }
  claim HFamSub: Fam c= product_subbasis X Tx Y Ty.
  { exact (PowerE (product_subbasis X Tx Y Ty) Fam HFamPow). }
  set PreFam := {preimage_of A (pair_map A f g) b|b :e Fam}.
  claim HpreEq1: preimage_of A (pair_map A f g) W = preimage_of A (pair_map A f g) (Union Fam).
  { rewrite <- HUnionEq.
    reflexivity. }
  claim HpreEq2: preimage_of A (pair_map A f g) (Union Fam) = Union PreFam.
  { rewrite (preimage_of_Union A (pair_map A f g) Fam).
    reflexivity. }
  rewrite HpreEq1.
  rewrite HpreEq2.
  claim HPreFamSub: PreFam c= Ta.
  { let P. assume HP: P :e PreFam.
    apply (ReplE_impred Fam (fun b:set => preimage_of A (pair_map A f g) b) P HP).
    let b. assume HbFam: b :e Fam.
    assume HPeq: P = preimage_of A (pair_map A f g) b.
    claim HbSub: b :e product_subbasis X Tx Y Ty.
    { exact (HFamSub b HbFam). }
    claim HexU: exists U :e Tx, b :e {rectangle_set U V|V :e Ty}.
    { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbSub). }
    apply HexU.
    let U. assume HUconj: U :e Tx /\ b :e {rectangle_set U V|V :e Ty}.
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim HbRepl: b :e {rectangle_set U V|V :e Ty}.
    { exact (andER (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUconj). }
    claim HexV: exists V :e Ty, b = rectangle_set U V.
    { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b HbRepl). }
    apply HexV.
    let V. assume HVconj: V :e Ty /\ b = rectangle_set U V.
    claim HV: V :e Ty.
    { exact (andEL (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim Hbeq: b = rectangle_set U V.
    { exact (andER (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim HpreRect: preimage_of A (pair_map A f g) b =
      (preimage_of A f U) :/\: (preimage_of A g V).
    { rewrite Hbeq.
      exact (preimage_pair_map_rectangle A X Y f g U V). }
    rewrite HPeq.
    rewrite HpreRect.
    exact (topology_binintersect_closed A Ta (preimage_of A f U) (preimage_of A g V) HTa (Hf_pre U HU) (Hg_pre V HV)). }
  claim HPreFamPow: PreFam :e Power Ta.
  { apply PowerI.
    exact HPreFamSub. }
  exact (topology_union_axiom A Ta HTa PreFam HPreFamPow).
Qed.

Theorem maps_into_products : forall A Ta X Tx Y Ty f g:set,
  continuous_map A Ta X Tx f ->
  continuous_map A Ta Y Ty g ->
  continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) (pair_map A f g).
let A Ta X Tx Y Ty f g.
assume Hf: continuous_map A Ta X Tx f.
assume Hg: continuous_map A Ta Y Ty g.
prove continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) (pair_map A f g).
exact (maps_into_products_axiom A Ta X Tx Y Ty f g Hf Hg).
Qed.

(** from §19 Definition: product projections and universal property **) 
(** LATEX VERSION: Projection maps from a product space; universal property characterizes the product topology. **)
Definition projection_map1 : set -> set -> set := fun X Y => projection1 X Y.
Definition projection_map2 : set -> set -> set := fun X Y => projection2 X Y.

(** Helper: preimage of a rectangle via projection compositions **)
Theorem preimage_of_rectangle_via_projections : forall A X Y h U V:set,
  function_on h A (setprod X Y) ->
  U c= X -> V c= Y ->
  preimage_of A h (rectangle_set U V) =
    (preimage_of A (compose_fun A h (projection_map1 X Y)) U) :/\:
    (preimage_of A (compose_fun A h (projection_map2 X Y)) V).
let A X Y h U V.
assume Hh: function_on h A (setprod X Y).
assume HU: U c= X.
assume HV: V c= Y.
apply set_ext.
- let a. assume Ha: a :e preimage_of A h (rectangle_set U V).
  prove a :e (preimage_of A (compose_fun A h (projection_map1 X Y)) U) :/\:
            (preimage_of A (compose_fun A h (projection_map2 X Y)) V).
  claim HaA: a :e A.
  { exact (SepE1 A (fun a0:set => apply_fun h a0 :e rectangle_set U V) a Ha). }
  claim Himg: apply_fun h a :e rectangle_set U V.
  { exact (SepE2 A (fun a0:set => apply_fun h a0 :e rectangle_set U V) a Ha). }
  claim HpXY: apply_fun h a :e setprod X Y.
  { exact (Hh a HaA). }
  claim Hp0U: (apply_fun h a) 0 :e U.
  { exact (ap0_Sigma U (fun _ : set => V) (apply_fun h a) Himg). }
  claim Hp1V: (apply_fun h a) 1 :e V.
  { exact (ap1_Sigma U (fun _ : set => V) (apply_fun h a) Himg). }
  claim Happ1: apply_fun (projection_map1 X Y) (apply_fun h a) = (apply_fun h a) 0.
  { exact (projection1_apply X Y (apply_fun h a) HpXY). }
  claim Happ2: apply_fun (projection_map2 X Y) (apply_fun h a) = (apply_fun h a) 1.
  { exact (projection2_apply X Y (apply_fun h a) HpXY). }
  claim Hc1: apply_fun (compose_fun A h (projection_map1 X Y)) a :e U.
  { claim Hcomp: apply_fun (compose_fun A h (projection_map1 X Y)) a =
      apply_fun (projection_map1 X Y) (apply_fun h a).
    { exact (compose_fun_apply A h (projection_map1 X Y) a HaA). }
    rewrite Hcomp.
    rewrite Happ1.
    exact Hp0U. }
  claim Hc2: apply_fun (compose_fun A h (projection_map2 X Y)) a :e V.
  { claim Hcomp: apply_fun (compose_fun A h (projection_map2 X Y)) a =
      apply_fun (projection_map2 X Y) (apply_fun h a).
    { exact (compose_fun_apply A h (projection_map2 X Y) a HaA). }
    rewrite Hcomp.
    rewrite Happ2.
    exact Hp1V. }
  apply binintersectI.
  * exact (SepI A (fun a0:set => apply_fun (compose_fun A h (projection_map1 X Y)) a0 :e U) a HaA Hc1).
  * exact (SepI A (fun a0:set => apply_fun (compose_fun A h (projection_map2 X Y)) a0 :e V) a HaA Hc2).
- let a. assume Ha: a :e (preimage_of A (compose_fun A h (projection_map1 X Y)) U) :/\:
                     (preimage_of A (compose_fun A h (projection_map2 X Y)) V).
  prove a :e preimage_of A h (rectangle_set U V).
  claim Ha1: a :e preimage_of A (compose_fun A h (projection_map1 X Y)) U.
  { exact (binintersectE1 (preimage_of A (compose_fun A h (projection_map1 X Y)) U)
                          (preimage_of A (compose_fun A h (projection_map2 X Y)) V) a Ha). }
  claim Ha2: a :e preimage_of A (compose_fun A h (projection_map2 X Y)) V.
  { exact (binintersectE2 (preimage_of A (compose_fun A h (projection_map1 X Y)) U)
                          (preimage_of A (compose_fun A h (projection_map2 X Y)) V) a Ha). }
  claim HaA: a :e A.
  { exact (SepE1 A (fun a0:set => apply_fun (compose_fun A h (projection_map1 X Y)) a0 :e U) a Ha1). }
  claim HpXY: apply_fun h a :e setprod X Y.
  { exact (Hh a HaA). }
  claim Hc1: apply_fun (compose_fun A h (projection_map1 X Y)) a :e U.
  { exact (SepE2 A (fun a0:set => apply_fun (compose_fun A h (projection_map1 X Y)) a0 :e U) a Ha1). }
  claim Hc2: apply_fun (compose_fun A h (projection_map2 X Y)) a :e V.
  { exact (SepE2 A (fun a0:set => apply_fun (compose_fun A h (projection_map2 X Y)) a0 :e V) a Ha2). }
  claim Hcomp1: apply_fun (compose_fun A h (projection_map1 X Y)) a =
      apply_fun (projection_map1 X Y) (apply_fun h a).
  { exact (compose_fun_apply A h (projection_map1 X Y) a HaA). }
  claim Hcomp2: apply_fun (compose_fun A h (projection_map2 X Y)) a =
      apply_fun (projection_map2 X Y) (apply_fun h a).
  { exact (compose_fun_apply A h (projection_map2 X Y) a HaA). }
  claim Happ1: apply_fun (projection_map1 X Y) (apply_fun h a) = (apply_fun h a) 0.
  { exact (projection1_apply X Y (apply_fun h a) HpXY). }
  claim Happ2: apply_fun (projection_map2 X Y) (apply_fun h a) = (apply_fun h a) 1.
  { exact (projection2_apply X Y (apply_fun h a) HpXY). }
  claim Hp0U: (apply_fun h a) 0 :e U.
  { rewrite <- Happ1.
    rewrite <- Hcomp1.
    exact Hc1. }
  claim Hp1V: (apply_fun h a) 1 :e V.
  { rewrite <- Happ2.
    rewrite <- Hcomp2.
    exact Hc2. }
  claim Heta: apply_fun h a = ((apply_fun h a) 0, (apply_fun h a) 1).
  { exact (setprod_eta X Y (apply_fun h a) HpXY). }
	  claim HpUV: apply_fun h a :e setprod U V.
	  { rewrite Heta.
	    exact (tuple_2_setprod_by_pair_Sigma U V ((apply_fun h a) 0) ((apply_fun h a) 1) Hp0U Hp1V). }
  prove a :e preimage_of A h (rectangle_set U V).
  exact (SepI A (fun a0:set => apply_fun h a0 :e rectangle_set U V) a HaA HpUV).
Qed.

(** Helper: projection maps are continuous **)
Theorem projection_maps_continuous : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
apply andI.
- (** projection_map1 **)
  prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y).
  prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\ topology_on X Tx /\
    function_on (projection_map1 X Y) (setprod X Y) X /\
    forall V:set, V :e Tx -> preimage_of (setprod X Y) (projection_map1 X Y) V :e product_topology X Tx Y Ty.
  apply andI.
  - apply andI.
    + apply andI.
      * exact (product_topology_is_topology X Tx Y Ty HTx HTy).
      * exact HTx.
    + (** function_on **)
      let p. assume Hp: p :e setprod X Y.
      prove apply_fun (projection_map1 X Y) p :e X.
      claim Happ: apply_fun (projection_map1 X Y) p = p 0.
      { exact (projection1_apply X Y p Hp). }
      rewrite Happ.
      exact (ap0_Sigma X (fun _ : set => Y) p Hp).
  - let V. assume HV: V :e Tx.
    prove preimage_of (setprod X Y) (projection_map1 X Y) V :e product_topology X Tx Y Ty.
    claim HVsub: V c= X.
    { exact (topology_elem_subset X Tx V HTx HV). }
    claim HpreEq: preimage_of (setprod X Y) (projection_map1 X Y) V = rectangle_set V Y.
    { exact (preimage_projection1_rectangle X Y V HVsub). }
    rewrite HpreEq.
    claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
    { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
    claim HYTy: Y :e Ty.
    { exact (topology_has_X Y Ty HTy). }
    claim HRsub: rectangle_set V Y :e product_subbasis X Tx Y Ty.
    { claim HRfam: rectangle_set V Y :e {rectangle_set V V0|V0 :e Ty}.
      { exact (ReplI Ty (fun V0:set => rectangle_set V V0) Y HYTy). }
      exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) V (rectangle_set V Y) HV HRfam). }
    exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis (rectangle_set V Y) HRsub).
- (** projection_map2 **)
  prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
  prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\ topology_on Y Ty /\
    function_on (projection_map2 X Y) (setprod X Y) Y /\
    forall V:set, V :e Ty -> preimage_of (setprod X Y) (projection_map2 X Y) V :e product_topology X Tx Y Ty.
  apply andI.
  - apply andI.
    + apply andI.
      * exact (product_topology_is_topology X Tx Y Ty HTx HTy).
      * exact HTy.
    + (** function_on **)
      let p. assume Hp: p :e setprod X Y.
      prove apply_fun (projection_map2 X Y) p :e Y.
      claim Happ: apply_fun (projection_map2 X Y) p = p 1.
      { exact (projection2_apply X Y p Hp). }
      rewrite Happ.
      exact (ap1_Sigma X (fun _ : set => Y) p Hp).
  - let V. assume HV: V :e Ty.
    prove preimage_of (setprod X Y) (projection_map2 X Y) V :e product_topology X Tx Y Ty.
    claim HVsub: V c= Y.
    { exact (topology_elem_subset Y Ty V HTy HV). }
    claim HpreEq: preimage_of (setprod X Y) (projection_map2 X Y) V = rectangle_set X V.
    { exact (preimage_projection2_rectangle X Y V HVsub). }
    rewrite HpreEq.
    claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
    { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
    claim HXTx: X :e Tx.
    { exact (topology_has_X X Tx HTx). }
    claim HRsub: rectangle_set X V :e product_subbasis X Tx Y Ty.
    { claim HRfam: rectangle_set X V :e {rectangle_set X V0|V0 :e Ty}.
      { exact (ReplI Ty (fun V0:set => rectangle_set X V0) V HV). }
      exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) X (rectangle_set X V) HXTx HRfam). }
    exact (generated_topology_contains_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis (rectangle_set X V) HRsub).
Qed.

(** Helper: maps into products, converse direction using projections **)
(** LATEX VERSION: If h : A -> X×Y is continuous, then each coordinate projection composed with h is continuous. **)
Theorem maps_into_products_converse : forall A Ta X Tx Y Ty h:set,
  topology_on X Tx -> topology_on Y Ty ->
  continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h ->
  continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)) /\
  continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)).
let A Ta X Tx Y Ty h.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hh: continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h.
prove continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)) /\
  continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)).
claim Hproj: continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
{ exact (projection_maps_continuous X Tx Y Ty HTx HTy). }
apply andI.
- claim Hpr1: continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y).
  { exact (andEL (continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y))
                 (continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y))
                 Hproj). }
  exact (composition_continuous A Ta (setprod X Y) (product_topology X Tx Y Ty) X Tx h (projection_map1 X Y)
         Hh Hpr1).
- claim Hpr2: continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
  { exact (andER (continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y))
                 (continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y))
                 Hproj). }
  exact (composition_continuous A Ta (setprod X Y) (product_topology X Tx Y Ty) Y Ty h (projection_map2 X Y)
         Hh Hpr2).
Qed.

(** Helper: maps into products from continuity of coordinates **)
(** LATEX VERSION: If h maps A into X×Y and the coordinate compositions are continuous, then h is continuous. **)
Theorem maps_into_products_coords_imp : forall A Ta X Tx Y Ty h:set,
  topology_on X Tx -> topology_on Y Ty ->
  function_on h A (setprod X Y) ->
  continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)) ->
  continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)) ->
  continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h.
let A Ta X Tx Y Ty h.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hfunh: function_on h A (setprod X Y).
assume Hc1: continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)).
assume Hc2: continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)).
prove continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h.

set h1 := compose_fun A h (projection_map1 X Y).
set h2 := compose_fun A h (projection_map2 X Y).

(** Extract topology on A and preimage properties from Hc1 and Hc2 **)
claim Hc1_left: (topology_on A Ta /\ topology_on X Tx) /\ function_on h1 A X.
{ exact (andEL ((topology_on A Ta /\ topology_on X Tx) /\ function_on h1 A X)
               (forall U:set, U :e Tx -> preimage_of A h1 U :e Ta) Hc1). }
claim HTaX: topology_on A Ta /\ topology_on X Tx.
{ exact (andEL (topology_on A Ta /\ topology_on X Tx) (function_on h1 A X) Hc1_left). }
claim HTa: topology_on A Ta.
{ exact (andEL (topology_on A Ta) (topology_on X Tx) HTaX). }
claim Hpre1: forall U:set, U :e Tx -> preimage_of A h1 U :e Ta.
{ exact (andER ((topology_on A Ta /\ topology_on X Tx) /\ function_on h1 A X)
               (forall U:set, U :e Tx -> preimage_of A h1 U :e Ta) Hc1). }

claim Hc2_left: (topology_on A Ta /\ topology_on Y Ty) /\ function_on h2 A Y.
{ exact (andEL ((topology_on A Ta /\ topology_on Y Ty) /\ function_on h2 A Y)
               (forall V:set, V :e Ty -> preimage_of A h2 V :e Ta) Hc2). }
claim Hpre2: forall V:set, V :e Ty -> preimage_of A h2 V :e Ta.
{ exact (andER ((topology_on A Ta /\ topology_on Y Ty) /\ function_on h2 A Y)
               (forall V:set, V :e Ty -> preimage_of A h2 V :e Ta) Hc2). }

(** Topology on the product **)
claim HTprod: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }

prove ((topology_on A Ta /\ topology_on (setprod X Y) (product_topology X Tx Y Ty)) /\ function_on h A (setprod X Y)) /\
  (forall W:set, W :e product_topology X Tx Y Ty -> preimage_of A h W :e Ta).
apply andI.
- apply andI.
  * apply andI.
    { exact HTa. }
    { exact HTprod. }
  * exact Hfunh.
- let W. assume HW: W :e product_topology X Tx Y Ty.
  prove preimage_of A h W :e Ta.
  claim HBasis: basis_on (setprod X Y) (product_subbasis X Tx Y Ty).
  { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
  claim HWopen: open_in (setprod X Y) (product_topology X Tx Y Ty) W.
  { exact (andI (topology_on (setprod X Y) (product_topology X Tx Y Ty))
                (W :e product_topology X Tx Y Ty) HTprod HW). }
  apply (open_sets_as_unions_of_basis (setprod X Y) (product_subbasis X Tx Y Ty) HBasis W HWopen).
  let Fam. assume HFamPair.
  claim HFamPow: Fam :e Power (product_subbasis X Tx Y Ty).
  { exact (andEL (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = W) HFamPair). }
  claim HUnionEq: Union Fam = W.
  { exact (andER (Fam :e Power (product_subbasis X Tx Y Ty)) (Union Fam = W) HFamPair). }
  claim HFamSub: Fam c= product_subbasis X Tx Y Ty.
  { exact (PowerE (product_subbasis X Tx Y Ty) Fam HFamPow). }
  set PreFam := {preimage_of A h b|b :e Fam}.
  claim HpreEq1: preimage_of A h W = preimage_of A h (Union Fam).
  { rewrite <- HUnionEq.
    reflexivity. }
  claim HpreEq2: preimage_of A h (Union Fam) = Union PreFam.
  { rewrite (preimage_of_Union A h Fam).
    reflexivity. }
  claim HPreFamSub: PreFam c= Ta.
  { let P. assume HP: P :e PreFam.
    apply (ReplE_impred Fam (fun b:set => preimage_of A h b) P HP (P :e Ta)).
    let b. assume HbFam: b :e Fam.
    assume HPeq: P = preimage_of A h b.
    claim HbB: b :e product_subbasis X Tx Y Ty.
    { exact (HFamSub b HbFam). }
    apply (famunionE Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b HbB).
    let U. assume HUconj: U :e Tx /\ b :e {rectangle_set U V0|V0 :e Ty}.
    claim HUinTx: U :e Tx.
    { exact (andEL (U :e Tx) (b :e {rectangle_set U V0|V0 :e Ty}) HUconj). }
    claim HbRepl: b :e {rectangle_set U V0|V0 :e Ty}.
    { exact (andER (U :e Tx) (b :e {rectangle_set U V0|V0 :e Ty}) HUconj). }
    claim HexV: exists V :e Ty, b = rectangle_set U V.
    { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b HbRepl). }
    apply HexV.
    let V. assume HVconj: V :e Ty /\ b = rectangle_set U V.
    claim HVinTy: V :e Ty.
    { exact (andEL (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim Hbeq: b = rectangle_set U V.
    { exact (andER (V :e Ty) (b = rectangle_set U V) HVconj). }
    claim HUsubX: U c= X.
    { exact (topology_elem_subset X Tx U HTx HUinTx). }
    claim HVsubY: V c= Y.
    { exact (topology_elem_subset Y Ty V HTy HVinTy). }
    claim HpreRect: preimage_of A h (rectangle_set U V) =
      (preimage_of A h1 U) :/\: (preimage_of A h2 V).
    { exact (preimage_of_rectangle_via_projections A X Y h U V Hfunh HUsubX HVsubY). }
    claim HpreU: preimage_of A h1 U :e Ta.
    { exact (Hpre1 U HUinTx). }
    claim HpreV: preimage_of A h2 V :e Ta.
    { exact (Hpre2 V HVinTy). }
    claim Hcap: (preimage_of A h1 U) :/\: (preimage_of A h2 V) :e Ta.
    { exact (topology_binintersect_closed A Ta (preimage_of A h1 U) (preimage_of A h2 V) HTa HpreU HpreV). }
    claim HpreB: preimage_of A h b :e Ta.
    { rewrite Hbeq.
      rewrite HpreRect.
      exact Hcap. }
    rewrite HPeq.
    exact HpreB. }
  claim HPreFamPow: PreFam :e Power Ta.
  { apply PowerI.
    exact HPreFamSub. }
  claim HUnionPre: Union PreFam :e Ta.
  { exact (topology_union_axiom A Ta HTa PreFam HPreFamPow). }
  rewrite HpreEq1.
  rewrite HpreEq2.
  exact HUnionPre.
Qed.

(** Helper: maps into products iff coordinates are continuous **)
(** LATEX VERSION: A map h : A -> X×Y is continuous iff each projection composed with h is continuous. **)
Theorem maps_into_products_iff_coords : forall A Ta X Tx Y Ty h:set,
  topology_on X Tx -> topology_on Y Ty ->
  function_on h A (setprod X Y) ->
  (continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h <->
   (continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)) /\
    continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)))).
let A Ta X Tx Y Ty h.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hfunh: function_on h A (setprod X Y).
apply iffI.
- assume Hh: continuous_map A Ta (setprod X Y) (product_topology X Tx Y Ty) h.
  exact (maps_into_products_converse A Ta X Tx Y Ty h HTx HTy Hh).
- assume Hcoords: continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)) /\
                  continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)).
  claim Hc1: continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)).
  { exact (andEL (continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)))
                 (continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)))
                 Hcoords). }
  claim Hc2: continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)).
  { exact (andER (continuous_map A Ta X Tx (compose_fun A h (projection_map1 X Y)))
                 (continuous_map A Ta Y Ty (compose_fun A h (projection_map2 X Y)))
                 Hcoords). }
  exact (maps_into_products_coords_imp A Ta X Tx Y Ty h HTx HTy Hfunh Hc1 Hc2).
Qed.

(** Helper: universal property of products - maps into products **)
(** LATEX VERSION: Projections from a product are continuous. **)
Theorem projections_are_continuous : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
exact (projection_maps_continuous X Tx Y Ty HTx HTy).
Qed.

(** from §19: product topology is coarsest making projections continuous **) 
(** LATEX VERSION: The product topology is the coarsest topology on X×Y making the projections continuous. **)
Theorem product_topology_universal : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  exists Tprod:set, topology_on (setprod X Y) Tprod /\
    continuous_map (setprod X Y) Tprod X Tx (projection_map1 X Y) /\
    continuous_map (setprod X Y) Tprod Y Ty (projection_map2 X Y).
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove exists Tprod:set, topology_on (setprod X Y) Tprod /\
    continuous_map (setprod X Y) Tprod X Tx (projection_map1 X Y) /\
    continuous_map (setprod X Y) Tprod Y Ty (projection_map2 X Y).
(** Witness the product topology **)
witness (product_topology X Tx Y Ty).
(** Goal is: A /\ B /\ C which is left-associative: (A /\ B) /\ C **)
apply andI.
- (** First part: topology_on (setprod X Y) (product_topology X Tx Y Ty) /\ continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y). **)
  apply andI.
  + (** product_topology is a topology **)
    exact (product_topology_is_topology X Tx Y Ty HTx HTy).
  + (** first projection is continuous **)
    exact (andEL (continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y))
                 (continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y))
                 (projections_are_continuous X Tx Y Ty HTx HTy)).
- (** second projection is continuous **)
  exact (andER (continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y))
               (continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y))
               (projections_are_continuous X Tx Y Ty HTx HTy)).
Qed.

(** Helper: rectangle as intersection of strips **)
Theorem rectangle_set_as_intersection : forall X Y U V:set,
  U c= X -> V c= Y ->
  rectangle_set U V = (rectangle_set U Y) :/\: (rectangle_set X V).
let X Y U V.
assume HU: U c= X.
assume HV: V c= Y.
prove rectangle_set U V = (rectangle_set U Y) :/\: (rectangle_set X V).
prove setprod U V = (setprod U Y) :/\: (setprod X V).
claim Hinter: setprod U Y :/\: setprod X V = setprod (U :/\: X) (Y :/\: V).
{ exact (setprod_intersection U Y X V). }
rewrite Hinter.
claim HUcap: U :/\: X = U.
{ exact (binintersect_Subq_eq_1 U X HU). }
claim HYcap: Y :/\: V = V.
{ rewrite (binintersect_com Y V).
  exact (binintersect_Subq_eq_1 V Y HV). }
rewrite HUcap.
rewrite HYcap.
reflexivity.
Qed.

(** Helper: coarsest property of product topology **)
(** LATEX VERSION: Any topology on X×Y making the projections continuous contains the product topology. **)
Theorem product_topology_coarsest : forall X Tx Y Ty Tprod:set,
  topology_on X Tx -> topology_on Y Ty ->
  topology_on (setprod X Y) Tprod ->
  continuous_map (setprod X Y) Tprod X Tx (projection_map1 X Y) ->
  continuous_map (setprod X Y) Tprod Y Ty (projection_map2 X Y) ->
  coarser_than (product_topology X Tx Y Ty) Tprod.
let X Tx Y Ty Tprod.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume HTprod: topology_on (setprod X Y) Tprod.
assume Hc1: continuous_map (setprod X Y) Tprod X Tx (projection_map1 X Y).
assume Hc2: continuous_map (setprod X Y) Tprod Y Ty (projection_map2 X Y).
prove coarser_than (product_topology X Tx Y Ty) Tprod.
prove product_topology X Tx Y Ty c= Tprod.
set B := product_subbasis X Tx Y Ty.
claim HBasis: basis_on (setprod X Y) B.
{ exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
claim Hc1_pre: forall U:set, U :e Tx -> preimage_of (setprod X Y) (projection_map1 X Y) U :e Tprod.
{ exact (andER ((topology_on (setprod X Y) Tprod /\ topology_on X Tx) /\ function_on (projection_map1 X Y) (setprod X Y) X)
               (forall U:set, U :e Tx -> preimage_of (setprod X Y) (projection_map1 X Y) U :e Tprod)
               Hc1). }
claim Hc2_pre: forall V:set, V :e Ty -> preimage_of (setprod X Y) (projection_map2 X Y) V :e Tprod.
{ exact (andER ((topology_on (setprod X Y) Tprod /\ topology_on Y Ty) /\ function_on (projection_map2 X Y) (setprod X Y) Y)
               (forall V:set, V :e Ty -> preimage_of (setprod X Y) (projection_map2 X Y) V :e Tprod)
               Hc2). }
claim HallB: forall b :e B, b :e Tprod.
{ let b. assume HbB: b :e B.
  apply (famunionE Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b HbB).
  let U. assume HUconj: U :e Tx /\ b :e {rectangle_set U V0|V0 :e Ty}.
  claim HUinTx: U :e Tx.
  { exact (andEL (U :e Tx) (b :e {rectangle_set U V0|V0 :e Ty}) HUconj). }
  claim HbRepl: b :e {rectangle_set U V0|V0 :e Ty}.
  { exact (andER (U :e Tx) (b :e {rectangle_set U V0|V0 :e Ty}) HUconj). }
  claim HUsubX: U c= X.
  { exact (topology_elem_subset X Tx U HTx HUinTx). }
  claim HexV: exists V :e Ty, b = rectangle_set U V.
  { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b HbRepl). }
  apply HexV.
  let V. assume HVconj: V :e Ty /\ b = rectangle_set U V.
  claim HVinTy: V :e Ty.
  { exact (andEL (V :e Ty) (b = rectangle_set U V) HVconj). }
  claim Hbeq: b = rectangle_set U V.
  { exact (andER (V :e Ty) (b = rectangle_set U V) HVconj). }
  claim HVsubY: V c= Y.
  { exact (topology_elem_subset Y Ty V HTy HVinTy). }
  claim Hpre1eq: preimage_of (setprod X Y) (projection_map1 X Y) U = rectangle_set U Y.
  { exact (preimage_projection1_rectangle X Y U HUsubX). }
  claim Hpre2eq: preimage_of (setprod X Y) (projection_map2 X Y) V = rectangle_set X V.
  { exact (preimage_projection2_rectangle X Y V HVsubY). }
  claim Hstrip1: rectangle_set U Y :e Tprod.
  { rewrite <- Hpre1eq.
    exact (Hc1_pre U HUinTx). }
  claim Hstrip2: rectangle_set X V :e Tprod.
  { rewrite <- Hpre2eq.
    exact (Hc2_pre V HVinTy). }
  claim HrectEq: rectangle_set U V = (rectangle_set U Y) :/\: (rectangle_set X V).
  { exact (rectangle_set_as_intersection X Y U V HUsubX HVsubY). }
  claim Hcap: (rectangle_set U Y) :/\: (rectangle_set X V) :e Tprod.
  { exact (topology_binintersect_closed (setprod X Y) Tprod (rectangle_set U Y) (rectangle_set X V)
           HTprod Hstrip1 Hstrip2). }
  rewrite Hbeq.
  rewrite HrectEq.
  exact Hcap. }
claim Hfiner: finer_than Tprod (generated_topology (setprod X Y) B).
{ exact (generated_topology_finer_weak (setprod X Y) B Tprod HTprod HallB). }
exact Hfiner.
Qed.

(** from §20 Definition: metric and metric topology **) 
(** LATEX VERSION: Definition of a metric d on X and the induced metric topology generated by open balls. **)
(** FIXED: Triangle inequality uses add_SNo, not :/\:; encoded as ~(Rlt (d(x,y)+d(y,z)) d(x,z)), relying on add_SNo and the intended interpretation of ~Rlt as <=. **)
(** SUSPICIOUS DEFINITION: Triangle inequality encoded by ~Rlt (d(x,y)+d(y,z)) d(x,z) relies on Rlt totality and intended equivalence between ~Rlt and <=. **)
Definition metric_on : set -> set -> prop := fun X d =>
  function_on d (setprod X X) R /\
  (forall x y:set, x :e X -> y :e X ->
     apply_fun d (x,y) = apply_fun d (y,x)) /\
  (forall x:set, x :e X -> apply_fun d (x,x) = 0) /\
  (forall x y:set, x :e X -> y :e X ->
     ~(Rlt (apply_fun d (x,y)) 0)
     /\ (apply_fun d (x,y) = 0 -> x = y)) /\
  (forall x y z:set, x :e X -> y :e X -> z :e X ->
     ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
           (apply_fun d (x,z)))).

(** Helper: metric_on plus totality of the graph on X×X **)
(** LATEX VERSION: In addition to the metric axioms, we often require the distance function to be defined on all pairs in X×X as a total function. **)
Definition metric_on_total : set -> set -> prop := fun X d =>
  metric_on X d /\ total_function_on d (setprod X X) R.

(** Helper: extract function_on from metric_on **)
Theorem metric_on_function_on : forall X d:set,
  metric_on X d -> function_on d (setprod X X) R.
let X d.
assume Hm: metric_on X d.
apply Hm.
assume Hcore Htri.
apply Hcore.
assume Hcore2 Hposdef.
apply Hcore2.
assume Hab Hrefl.
apply Hab.
assume Hf Hsym.
exact Hf.
Qed.

(** helper: Euclidean metric as a graph on EuclidPlane **)
(** LATEX VERSION: The Euclidean metric d on R^2 is given by d(p,q)=distance_R2 p q. **)
Definition EuclidPlane_metric : set :=
  graph (setprod EuclidPlane EuclidPlane) (fun pq:set => distance_R2 (pq 0) (pq 1)).

(** helper: evaluate EuclidPlane_metric on a pair **)
Theorem EuclidPlane_metric_apply : forall p q:set,
  p :e EuclidPlane -> q :e EuclidPlane ->
  apply_fun EuclidPlane_metric (p,q) = distance_R2 p q.
let p q.
assume Hp: p :e EuclidPlane.
assume Hq: q :e EuclidPlane.
prove apply_fun EuclidPlane_metric (p,q) = distance_R2 p q.
claim Hpq: (p,q) :e (setprod EuclidPlane EuclidPlane).
{ exact (tuple_2_setprod_by_pair_Sigma EuclidPlane EuclidPlane p q Hp Hq). }
rewrite (apply_fun_graph (setprod EuclidPlane EuclidPlane)
         (fun pq0:set => distance_R2 (pq0 0) (pq0 1))
         (p,q) Hpq).
rewrite (tuple_2_0_eq p q).
rewrite (tuple_2_1_eq p q).
reflexivity.
Qed.

(** helper: EuclidPlane_metric satisfies the metric axioms on EuclidPlane **)
Theorem EuclidPlane_metric_is_metric_on : metric_on EuclidPlane EuclidPlane_metric.
prove metric_on EuclidPlane EuclidPlane_metric.
prove function_on EuclidPlane_metric (setprod EuclidPlane EuclidPlane) R /\
  (forall x y:set, x :e EuclidPlane -> y :e EuclidPlane ->
     apply_fun EuclidPlane_metric (x,y) = apply_fun EuclidPlane_metric (y,x)) /\
  (forall x:set, x :e EuclidPlane -> apply_fun EuclidPlane_metric (x,x) = 0) /\
  (forall x y:set, x :e EuclidPlane -> y :e EuclidPlane ->
     ~(Rlt (apply_fun EuclidPlane_metric (x,y)) 0)
     /\ (apply_fun EuclidPlane_metric (x,y) = 0 -> x = y)) /\
  (forall x y z:set, x :e EuclidPlane -> y :e EuclidPlane -> z :e EuclidPlane ->
     ~(Rlt (add_SNo (apply_fun EuclidPlane_metric (x,y)) (apply_fun EuclidPlane_metric (y,z)))
           (apply_fun EuclidPlane_metric (x,z)))).
apply andI.
- (** function_on + symmetry + reflexive + positive-definite **)
  apply andI.
  + (** (function_on /\ symmetry) /\ reflexive (left-associated) **)
    apply andI.
    * (** function_on /\ symmetry **)
      apply andI.
      - (** function_on EuclidPlane_metric (EuclidPlane×EuclidPlane) R **)
         let pq. assume Hpq: pq :e (setprod EuclidPlane EuclidPlane).
         prove apply_fun EuclidPlane_metric pq :e R.
         rewrite (apply_fun_graph (setprod EuclidPlane EuclidPlane)
                  (fun pq0:set => distance_R2 (pq0 0) (pq0 1))
                  pq Hpq).
         claim Hp: (pq 0) :e EuclidPlane.
         { exact (ap0_Sigma EuclidPlane (fun _ : set => EuclidPlane) pq Hpq). }
         claim Hq: (pq 1) :e EuclidPlane.
         { exact (ap1_Sigma EuclidPlane (fun _ : set => EuclidPlane) pq Hpq). }
         exact (distance_R2_in_R (pq 0) (pq 1) Hp Hq).
      - (** symmetry **)
         let x y.
         assume Hx: x :e EuclidPlane.
         assume Hy: y :e EuclidPlane.
         rewrite (EuclidPlane_metric_apply x y Hx Hy).
         rewrite (EuclidPlane_metric_apply y x Hy Hx).
         exact (distance_R2_sym x y Hx Hy).
    * (** reflexive **)
      let x.
      assume Hx: x :e EuclidPlane.
      rewrite (EuclidPlane_metric_apply x x Hx Hx).
      exact (distance_R2_refl_0 x Hx).
  + (** positive-definite **)
    let x y.
    assume Hx: x :e EuclidPlane.
    assume Hy: y :e EuclidPlane.
    prove ~(Rlt (apply_fun EuclidPlane_metric (x,y)) 0)
      /\ (apply_fun EuclidPlane_metric (x,y) = 0 -> x = y).
    apply andI.
    * (** nonnegativity: not (Rlt d 0) **)
      prove ~(Rlt (apply_fun EuclidPlane_metric (x,y)) 0).
      assume Hlt: Rlt (apply_fun EuclidPlane_metric (x,y)) 0.
      prove False.
      claim Hlt2: Rlt (distance_R2 x y) 0.
      { rewrite <- (EuclidPlane_metric_apply x y Hx Hy).
        exact Hlt. }
      claim HdR: distance_R2 x y :e R.
      { exact (distance_R2_in_R x y Hx Hy). }
      claim HdS: SNo (distance_R2 x y).
      { exact (real_SNo (distance_R2 x y) HdR). }
      claim Hdlt0: (distance_R2 x y) < 0.
      { exact (RltE_lt (distance_R2 x y) 0 Hlt2). }
      claim Hdle0: (distance_R2 x y) <= 0.
      { exact (SNoLtLe (distance_R2 x y) 0 Hdlt0). }
      claim H0led: 0 <= distance_R2 x y.
      { exact (distance_R2_nonneg x y Hx Hy). }
      claim Hdeq0: distance_R2 x y = 0.
      { exact (SNoLe_antisym (distance_R2 x y) 0 HdS SNo_0 Hdle0 H0led). }
      claim Hbad: 0 < 0.
      { rewrite <- Hdeq0 at 1.
        exact Hdlt0. }
      exact ((SNoLt_irref 0) Hbad).
    * (** d(x,y)=0 implies x=y **)
      assume Hd0: apply_fun EuclidPlane_metric (x,y) = 0.
      claim Hd02: distance_R2 x y = 0.
      { rewrite <- (EuclidPlane_metric_apply x y Hx Hy).
        exact Hd0. }
      exact (distance_R2_eq0 x y Hx Hy Hd02).
- (** triangle inequality **)
  let x y z.
  assume Hx: x :e EuclidPlane.
  assume Hy: y :e EuclidPlane.
  assume Hz: z :e EuclidPlane.
  prove ~(Rlt (add_SNo (apply_fun EuclidPlane_metric (x,y)) (apply_fun EuclidPlane_metric (y,z)))
             (apply_fun EuclidPlane_metric (x,z))).
  rewrite (EuclidPlane_metric_apply x y Hx Hy).
  rewrite (EuclidPlane_metric_apply y z Hy Hz).
  rewrite (EuclidPlane_metric_apply x z Hx Hz).
  claim Htri: Rle (distance_R2 x z) (add_SNo (distance_R2 x y) (distance_R2 y z)).
  { exact (distance_R2_triangle_Rle x y z Hx Hy Hz). }
  exact (RleE_nlt (distance_R2 x z) (add_SNo (distance_R2 x y) (distance_R2 y z)) Htri).
Qed.

(** helper: EuclidPlane_metric is total as a function on EuclidPlane×EuclidPlane **)
Theorem EuclidPlane_metric_is_metric_on_total : metric_on_total EuclidPlane EuclidPlane_metric.
prove metric_on_total EuclidPlane EuclidPlane_metric.
prove metric_on EuclidPlane EuclidPlane_metric /\
  total_function_on EuclidPlane_metric (setprod EuclidPlane EuclidPlane) R.
apply andI.
- exact EuclidPlane_metric_is_metric_on.
- (** total_function_on EuclidPlane_metric (EuclidPlane×EuclidPlane) R **)
  prove total_function_on EuclidPlane_metric (setprod EuclidPlane EuclidPlane) R.
  prove function_on EuclidPlane_metric (setprod EuclidPlane EuclidPlane) R /\
    forall pq:set, pq :e (setprod EuclidPlane EuclidPlane) ->
      exists y:set, y :e R /\ (pq,y) :e EuclidPlane_metric.
  apply andI.
  + exact (metric_on_function_on EuclidPlane EuclidPlane_metric EuclidPlane_metric_is_metric_on).
  + let pq. assume Hpq: pq :e (setprod EuclidPlane EuclidPlane).
    prove exists y:set, y :e R /\ (pq,y) :e EuclidPlane_metric.
    witness (distance_R2 (pq 0) (pq 1)).
    apply andI.
    * (** y :e R **)
      claim Hp: (pq 0) :e EuclidPlane.
      { exact (ap0_Sigma EuclidPlane (fun _ : set => EuclidPlane) pq Hpq). }
      claim Hq: (pq 1) :e EuclidPlane.
      { exact (ap1_Sigma EuclidPlane (fun _ : set => EuclidPlane) pq Hpq). }
      exact (distance_R2_in_R (pq 0) (pq 1) Hp Hq).
    * (** (pq,y) :e EuclidPlane_metric **)
      exact (ReplI (setprod EuclidPlane EuclidPlane)
                   (fun pq0:set => (pq0, distance_R2 (pq0 0) (pq0 1)))
                   pq Hpq).
Qed.

(** Helper: symmetry of a metric **)
Theorem metric_on_symmetric : forall X d x y:set,
  metric_on X d -> x :e X -> y :e X ->
  apply_fun d (x,y) = apply_fun d (y,x).
let X d x y.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
claim Hsym: forall x0 y0:set, x0 :e X -> y0 :e X ->
  apply_fun d (x0,y0) = apply_fun d (y0,x0).
{ apply Hm.
  assume Hcore Htri.
  apply Hcore.
  assume Hcore2 Hposdef.
  apply Hcore2.
  assume Hab Hrefl.
  apply Hab.
  assume Hf Hsym.
  exact Hsym. }
exact (Hsym x y Hx Hy).
Qed.

(** Helper: reflexive axiom for a metric **)
Theorem metric_on_diag_zero : forall X d x:set,
  metric_on X d -> x :e X -> apply_fun d (x,x) = 0.
let X d x.
assume Hm: metric_on X d.
assume Hx: x :e X.
claim Hrefl: forall x0:set, x0 :e X -> apply_fun d (x0,x0) = 0.
{ apply Hm.
  assume Hcore Htri.
  apply Hcore.
  assume Hcore2 Hposdef.
  apply Hcore2.
  assume Hab Hrefl.
  exact Hrefl. }
exact (Hrefl x Hx).
Qed.

(** Helper: nonnegativity of a metric **)
Theorem metric_on_nonneg : forall X d x y:set,
  metric_on X d -> x :e X -> y :e X ->
  ~(Rlt (apply_fun d (x,y)) 0).
let X d x y.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
claim Hpos: forall x0 y0:set, x0 :e X -> y0 :e X ->
  ~(Rlt (apply_fun d (x0,y0)) 0) /\ (apply_fun d (x0,y0) = 0 -> x0 = y0).
{ apply Hm.
  assume Hcore Htri.
  apply Hcore.
  assume Hcore2 Hposdef.
  exact Hposdef. }
exact (andEL (~(Rlt (apply_fun d (x,y)) 0)) (apply_fun d (x,y) = 0 -> x = y) (Hpos x y Hx Hy)).
Qed.

(** Helper: zero distance implies equality **)
Theorem metric_on_zero_eq : forall X d x y:set,
  metric_on X d -> x :e X -> y :e X ->
  apply_fun d (x,y) = 0 -> x = y.
let X d x y.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
assume H0: apply_fun d (x,y) = 0.
claim Hpos: forall x0 y0:set, x0 :e X -> y0 :e X ->
  ~(Rlt (apply_fun d (x0,y0)) 0) /\ (apply_fun d (x0,y0) = 0 -> x0 = y0).
{ apply Hm.
  assume Hcore Htri.
  apply Hcore.
  assume Hcore2 Hposdef.
  exact Hposdef. }
claim Himp: apply_fun d (x,y) = 0 -> x = y.
{ exact (andER (~(Rlt (apply_fun d (x,y)) 0)) (apply_fun d (x,y) = 0 -> x = y) (Hpos x y Hx Hy)). }
exact (Himp H0).
Qed.

(** Helper: strict positivity away from the diagonal **)
(** LATEX VERSION: In a metric space, if x≠y then 0<d(x,y). **)
Theorem metric_on_pos_of_neq : forall X d x y:set,
  metric_on X d -> x :e X -> y :e X -> ~(x = y) ->
  Rlt 0 (apply_fun d (x,y)).
let X d x y.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
assume Hneq: ~(x = y).
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxyIn: (x,y) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
claim HdR: apply_fun d (x,y) :e R.
{ exact (Hfun (x,y) HxyIn). }
claim HdS: SNo (apply_fun d (x,y)).
{ exact (real_SNo (apply_fun d (x,y)) HdR). }
apply (SNoLt_trichotomy_or_impred (apply_fun d (x,y)) 0 HdS SNo_0 (Rlt 0 (apply_fun d (x,y)))).
- assume Hlt: apply_fun d (x,y) < 0.
  prove Rlt 0 (apply_fun d (x,y)).
  apply FalseE.
  claim Hbad: Rlt (apply_fun d (x,y)) 0.
  { exact (RltI (apply_fun d (x,y)) 0 HdR real_0 Hlt). }
  exact ((metric_on_nonneg X d x y Hm Hx Hy) Hbad).
- assume Heq0: apply_fun d (x,y) = 0.
  prove Rlt 0 (apply_fun d (x,y)).
  apply FalseE.
  claim Hxy: x = y.
  { exact (metric_on_zero_eq X d x y Hm Hx Hy Heq0). }
  exact (Hneq Hxy).
- assume H0lt: 0 < apply_fun d (x,y).
  exact (RltI 0 (apply_fun d (x,y)) real_0 HdR H0lt).
Qed.

(** helper: family of negated distances from a point to a set **)
(** LATEX VERSION: For x and A, consider the set {-d(x,a) | a in A} for use in inf and sup constructions. **)
Definition metric_neg_dists : set -> set -> set -> set -> set := fun X d x A =>
  {minus_SNo (apply_fun d (x,a))|a :e A}.

(** helper: negated distances are real numbers **)
Theorem metric_neg_dists_in_R : forall X d x A:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  forall t:set, t :e metric_neg_dists X d x A -> t :e R.
let X d x A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
let t. assume Ht: t :e metric_neg_dists X d x A.
prove t :e R.
apply (ReplE_impred A (fun a0:set => minus_SNo (apply_fun d (x,a0))) t Ht (t :e R)).
let a. assume HaA: a :e A.
assume Hteq: t = minus_SNo (apply_fun d (x,a)).
claim HaX: a :e X.
{ exact (HAsub a HaA). }
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxaIn: (x,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x a HxX HaX). }
claim HdR: apply_fun d (x,a) :e R.
{ exact (Hfun (x,a) HxaIn). }
rewrite Hteq.
exact (real_minus_SNo (apply_fun d (x,a)) HdR).
Qed.

(** helper: negated distances are bounded above by 0 **)
Theorem metric_neg_dists_le_0 : forall X d x A:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  forall t:set, t :e metric_neg_dists X d x A -> Rle t 0.
let X d x A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
let t. assume Ht: t :e metric_neg_dists X d x A.
prove Rle t 0.
apply (ReplE_impred A (fun a0:set => minus_SNo (apply_fun d (x,a0))) t Ht (Rle t 0)).
let a. assume HaA: a :e A.
assume Hteq: t = minus_SNo (apply_fun d (x,a)).
claim HaX: a :e X.
{ exact (HAsub a HaA). }
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxaIn: (x,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x a HxX HaX). }
claim HdR: apply_fun d (x,a) :e R.
{ exact (Hfun (x,a) HxaIn). }
claim Hnlt: ~(Rlt (apply_fun d (x,a)) 0).
{ exact (metric_on_nonneg X d x a Hm HxX HaX). }
rewrite Hteq.
exact (Rle_minus_nonneg (apply_fun d (x,a)) HdR Hnlt).
Qed.

(** Helper: triangle inequality (raw) **)
Theorem metric_on_triangle : forall X d x y z:set,
  metric_on X d -> x :e X -> y :e X -> z :e X ->
  ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
        (apply_fun d (x,z))).
let X d x y z.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
assume Hz: z :e X.
apply Hm.
assume Hcore Htri.
exact (Htri x y z Hx Hy Hz).
Qed.

Theorem metric_on_total_imp_metric_on : forall X d:set,
  metric_on_total X d -> metric_on X d.
let X d. assume H.
exact (andEL (metric_on X d) (total_function_on d (setprod X X) R) H).
Qed.

Theorem metric_on_total_total_function : forall X d:set,
  metric_on_total X d -> total_function_on d (setprod X X) R.
let X d. assume H.
exact (andER (metric_on X d) (total_function_on d (setprod X X) R) H).
Qed.

(** helper: triangle inequality in Rle form **)
Theorem metric_triangle_Rle : forall X d x y z:set,
  metric_on X d -> x :e X -> y :e X -> z :e X ->
  Rle (apply_fun d (x,z)) (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))).
let X d x y z.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hy: y :e X.
assume Hz: z :e X.
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }

claim HxyIn: (x,y) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
claim HyzIn: (y,z) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X y z Hy Hz). }
claim HxzIn: (x,z) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x z Hx Hz). }

claim HdxyR: apply_fun d (x,y) :e R.
{ exact (Hfun (x,y) HxyIn). }
claim HdyzR: apply_fun d (y,z) :e R.
{ exact (Hfun (y,z) HyzIn). }
claim HdxzR: apply_fun d (x,z) :e R.
{ exact (Hfun (x,z) HxzIn). }
claim HsumR: add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)) :e R.
{ exact (real_add_SNo (apply_fun d (x,y)) HdxyR (apply_fun d (y,z)) HdyzR). }
exact (RleI (apply_fun d (x,z)) (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))) HdxzR HsumR
            (metric_on_triangle X d x y z Hm Hx Hy Hz)).
Qed.

(** from §20 Definition: open ball **)
(** LATEX VERSION: Open ball centered at x with radius r in metric d. **)
(** FIXED: Previous version quantified the radius and made the set equal to X; open_ball now takes the radius r as a parameter and uses {y :e X | d(x,y) < r}. **)
Definition open_ball : set -> set -> set -> set -> set := fun X d x r =>
  {y :e X|Rlt (apply_fun d (x,y)) r}.

(** Helper: elimination and introduction rules for open_ball **)
Theorem open_ballE1 : forall X d x r y:set,
  y :e open_ball X d x r -> y :e X.
let X d x r y.
assume Hy: y :e open_ball X d x r.
exact (SepE1 X (fun y0:set => Rlt (apply_fun d (x,y0)) r) y Hy).
Qed.

Theorem open_ballE2 : forall X d x r y:set,
  y :e open_ball X d x r -> Rlt (apply_fun d (x,y)) r.
let X d x r y.
assume Hy: y :e open_ball X d x r.
exact (SepE2 X (fun y0:set => Rlt (apply_fun d (x,y0)) r) y Hy).
Qed.

Theorem open_ballI : forall X d x r y:set,
  y :e X -> Rlt (apply_fun d (x,y)) r -> y :e open_ball X d x r.
let X d x r y.
assume HyX: y :e X.
assume Hlt: Rlt (apply_fun d (x,y)) r.
exact (SepI X (fun y0:set => Rlt (apply_fun d (x,y0)) r) y HyX Hlt).
Qed.

(** helper: Euclidean open balls are circular regions (via distance_R2) **)
(** LATEX VERSION: For Euclidean metric d(p,q)=distance_R2 p q, the open ball B_d(c,r) equals {p∈R^2 | distance_R2(p,c) < r}. **)
Theorem open_ball_EuclidPlane_metric_eq : forall c r:set,
  c :e EuclidPlane ->
  open_ball EuclidPlane EuclidPlane_metric c r
    = {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
let c r.
assume Hc: c :e EuclidPlane.
apply set_ext.
- let p. assume Hp: p :e open_ball EuclidPlane EuclidPlane_metric c r.
  prove p :e {p0 :e EuclidPlane|Rlt (distance_R2 p0 c) r}.
  claim HpE: p :e EuclidPlane.
  { exact (open_ballE1 EuclidPlane EuclidPlane_metric c r p Hp). }
  claim Hlt: Rlt (apply_fun EuclidPlane_metric (c,p)) r.
  { exact (open_ballE2 EuclidPlane EuclidPlane_metric c r p Hp). }
  claim Hcp: apply_fun EuclidPlane_metric (c,p) = distance_R2 c p.
  { exact (EuclidPlane_metric_apply c p Hc HpE). }
  claim Hsym: distance_R2 c p = distance_R2 p c.
  { exact (distance_R2_sym c p Hc HpE). }
  claim Hltcp: Rlt (distance_R2 c p) r.
  { rewrite <- Hcp. exact Hlt. }
  claim Hltpc: Rlt (distance_R2 p c) r.
  { rewrite <- Hsym. exact Hltcp. }
  exact (SepI EuclidPlane (fun p0:set => Rlt (distance_R2 p0 c) r) p HpE Hltpc).
- let p. assume Hp: p :e {p0 :e EuclidPlane|Rlt (distance_R2 p0 c) r}.
  prove p :e open_ball EuclidPlane EuclidPlane_metric c r.
  claim HpE: p :e EuclidPlane.
  { exact (SepE1 EuclidPlane (fun p0:set => Rlt (distance_R2 p0 c) r) p Hp). }
  claim Hltpc: Rlt (distance_R2 p c) r.
  { exact (SepE2 EuclidPlane (fun p0:set => Rlt (distance_R2 p0 c) r) p Hp). }
  claim Hsym: distance_R2 p c = distance_R2 c p.
  { exact (distance_R2_sym p c HpE Hc). }
  claim Hltcp: Rlt (distance_R2 c p) r.
  { rewrite <- Hsym. exact Hltpc. }
  claim Hcp: apply_fun EuclidPlane_metric (c,p) = distance_R2 c p.
  { exact (EuclidPlane_metric_apply c p Hc HpE). }
  claim Hlt: Rlt (apply_fun EuclidPlane_metric (c,p)) r.
  { rewrite Hcp. exact Hltcp. }
  exact (open_ballI EuclidPlane EuclidPlane_metric c r p HpE Hlt).
Qed.

(** Helper: open balls are subsets of X **)
Theorem open_ball_subset_X : forall X d x r:set, open_ball X d x r c= X.
let X d x r.
let y. assume Hy: y :e open_ball X d x r.
exact (open_ballE1 X d x r y Hy).
Qed.

(** Helper: open balls are elements of Power X **)
Theorem open_ball_in_Power : forall X d x r:set, open_ball X d x r :e Power X.
let X d x r.
apply PowerI.
exact (open_ball_subset_X X d x r).
Qed.

(** Helper: the center belongs to any open ball with positive radius **)
Theorem center_in_open_ball : forall X d x r:set,
  metric_on X d -> x :e X -> Rlt 0 r -> x :e open_ball X d x r.
let X d x r.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hr: Rlt 0 r.
claim Hdxx0: apply_fun d (x,x) = 0.
{ exact (metric_on_diag_zero X d x Hm Hx). }
claim Hpred: Rlt (apply_fun d (x,x)) r.
{ rewrite Hdxx0. exact Hr. }
exact (SepI X (fun y0:set => Rlt (apply_fun d (x,y0)) r) x Hx Hpred).
Qed.

(** Helper: any open ball with positive radius is nonempty **)
Theorem open_ball_nonempty : forall X d x r:set,
  metric_on X d -> x :e X -> Rlt 0 r -> open_ball X d x r <> Empty.
let X d x r.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hr: Rlt 0 r.
assume Hempty: open_ball X d x r = Empty.
claim Hxin: x :e open_ball X d x r.
{ exact (center_in_open_ball X d x r Hm Hx Hr). }
claim HxinEmpty: x :e Empty.
{ rewrite <- Hempty. exact Hxin. }
exact (EmptyE x HxinEmpty).
Qed.

(** Helper: for any positive real d, some eps_N is smaller than d **)
Theorem exists_eps_lt_pos : forall d:set, d :e R -> Rlt 0 d -> exists N :e omega, eps_ N < d.
let d.
assume HdR: d :e R.
assume Hdpos: Rlt 0 d.
claim HdS: SNo d.
{ exact (real_SNo d HdR). }
claim H0ltd: 0 < d.
{ exact (RltE_lt 0 d Hdpos). }
set invd := recip_SNo_pos d.
claim HinvdDef: invd = recip_SNo_pos d.
{ reflexivity. }
claim HinvdR: invd :e R.
{ rewrite HinvdDef.
  exact (real_recip_SNo_pos d HdR H0ltd). }
claim HinvdS: SNo invd.
{ exact (real_SNo invd HinvdR). }
claim Hinvdpos: 0 < invd.
{ exact (recip_SNo_pos_is_pos d HdS H0ltd). }
apply (real_E invd HinvdR (exists N :e omega, eps_ N < d)).
assume HinvS: SNo invd.
assume Hlev.
assume HinS.
assume Hlow.
assume Hup.
assume Huniq.
assume Happrox.
claim HexNlt: exists N :e omega, mul_SNo (eps_ N) invd < 1.
{ exact (SNoS_ordsucc_omega_bdd_eps_pos invd HinS Hinvdpos Hup). }
apply HexNlt.
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
claim HmulLt: mul_SNo (eps_ N) invd < 1.
{ exact (andER (N :e omega) (mul_SNo (eps_ N) invd < 1) HNpair). }
witness N.
apply andI.
- exact HNomega.
- claim HepsS: SNo (eps_ N).
  { exact (SNo_eps_ N HNomega). }
  claim HepsLtDiv: eps_ N < div_SNo 1 invd.
  { exact (div_SNo_pos_LtR 1 invd (eps_ N) SNo_1 HinvS HepsS Hinvdpos HmulLt). }
  claim HdivEq: div_SNo 1 invd = d.
  { claim Hposcase: recip_SNo invd = recip_SNo_pos invd.
    { exact (recip_SNo_poscase invd Hinvdpos). }
    claim HrecipInv: recip_SNo_pos invd = d.
    { rewrite HinvdDef.
      exact (recip_SNo_pos_invol d HdS H0ltd). }
    claim HdivDef: div_SNo 1 invd = mul_SNo 1 (recip_SNo invd).
    { reflexivity. }
    rewrite HdivDef.
    rewrite Hposcase.
    rewrite HrecipInv.
    exact (mul_SNo_oneL d HdS). }
  rewrite <- HdivEq.
  exact HepsLtDiv.
Qed.

(** Helper: choose a single eps below two positive reals **)
(** LATEX VERSION: Given two positive real numbers, there is a positive eps radius smaller than both. **)
Theorem exists_eps_lt_two_pos : forall a b:set,
  a :e R -> b :e R ->
  Rlt 0 a -> Rlt 0 b ->
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Ha0: Rlt 0 a.
assume Hb0: Rlt 0 b.
claim Hex1: exists N1 :e omega, eps_ N1 < a.
{ exact (exists_eps_lt_pos a HaR Ha0). }
apply Hex1.
let N1. assume HN1pair.
claim HN1o: N1 :e omega.
{ exact (andEL (N1 :e omega) (eps_ N1 < a) HN1pair). }
claim Heps1lt_a: eps_ N1 < a.
{ exact (andER (N1 :e omega) (eps_ N1 < a) HN1pair). }
claim Heps1R: eps_ N1 :e R.
{ exact (SNoS_omega_real (eps_ N1) (SNo_eps_SNoS_omega N1 HN1o)). }
claim Heps1Rlt: Rlt (eps_ N1) a.
{ exact (RltI (eps_ N1) a Heps1R HaR Heps1lt_a). }

claim Hex2: exists N2 :e omega, eps_ N2 < b.
{ exact (exists_eps_lt_pos b HbR Hb0). }
apply Hex2.
let N2. assume HN2pair.
claim HN2o: N2 :e omega.
{ exact (andEL (N2 :e omega) (eps_ N2 < b) HN2pair). }
claim Heps2lt_b: eps_ N2 < b.
{ exact (andER (N2 :e omega) (eps_ N2 < b) HN2pair). }
claim Heps2R: eps_ N2 :e R.
{ exact (SNoS_omega_real (eps_ N2) (SNo_eps_SNoS_omega N2 HN2o)). }
claim Heps2Rlt: Rlt (eps_ N2) b.
{ exact (RltI (eps_ N2) b Heps2R HbR Heps2lt_b). }

(** choose an index N above both N1 and N2 by trichotomy, then take eps_N **)
claim Hord1: ordinal N1.
{ exact (nat_p_ordinal N1 (omega_nat_p N1 HN1o)). }
claim Hord2: ordinal N2.
{ exact (nat_p_ordinal N2 (omega_nat_p N2 HN2o)). }
apply (ordinal_trichotomy_or_impred N1 N2 Hord1 Hord2
  (exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b)).
- assume H12: N1 :e N2.
  set N := ordsucc N2.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N2 HN2o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3S: SNo r3.
  { exact (SNo_eps_ N HNo). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI1 N2 N1 H12). }
  claim HN2in: N2 :e N.
  { exact (ordsuccI2 N2). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt2: r3 < eps_ N2.
  { exact (SNo_eps_decr N HNo N2 HN2in). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  claim HepsNlt2Rlt: Rlt r3 (eps_ N2).
  { exact (RltI r3 (eps_ N2) Hr3R Heps2R HepsNlt2). }
  witness r3.
  apply andI.
  - apply andI.
    + apply andI.
      * exact Hr3R.
      * exact Hr3pos.
    + exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - exact (Rlt_tra r3 (eps_ N2) b HepsNlt2Rlt Heps2Rlt).
- assume Heq: N1 = N2.
  set N := ordsucc N1.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N1 HN1o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI2 N1). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  witness r3.
  apply andI.
  - apply andI.
    + apply andI.
      * exact Hr3R.
      * exact Hr3pos.
    + exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - claim Heps1Rltb: Rlt (eps_ N1) b.
    { prove Rlt (eps_ N1) b.
      rewrite Heq at 1.
      exact Heps2Rlt. }
    exact (Rlt_tra r3 (eps_ N1) b HepsNlt1Rlt Heps1Rltb).
- assume H21: N2 :e N1.
  set N := ordsucc N1.
  claim HNo: N :e omega.
  { exact (omega_ordsucc N1 HN1o). }
  set r3 := eps_ N.
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 (SNo_eps_SNoS_omega N HNo)). }
  claim Hr3posS: 0 < r3.
  { exact (SNo_eps_pos N HNo). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R Hr3posS). }
  claim HN1in: N1 :e N.
  { exact (ordsuccI2 N1). }
  claim HN2in: N2 :e N.
  { exact (ordsuccI1 N1 N2 H21). }
  claim HepsNlt1: r3 < eps_ N1.
  { exact (SNo_eps_decr N HNo N1 HN1in). }
  claim HepsNlt2: r3 < eps_ N2.
  { exact (SNo_eps_decr N HNo N2 HN2in). }
  claim HepsNlt1Rlt: Rlt r3 (eps_ N1).
  { exact (RltI r3 (eps_ N1) Hr3R Heps1R HepsNlt1). }
  claim HepsNlt2Rlt: Rlt r3 (eps_ N2).
  { exact (RltI r3 (eps_ N2) Hr3R Heps2R HepsNlt2). }
  witness r3.
  apply andI.
  - apply andI.
    + apply andI.
      * exact Hr3R.
      * exact Hr3pos.
    + exact (Rlt_tra r3 (eps_ N1) a HepsNlt1Rlt Heps1Rlt).
  - exact (Rlt_tra r3 (eps_ N2) b HepsNlt2Rlt Heps2Rlt).
Qed.

(** Helper: choose a single eps below four positive reals **)
(** LATEX VERSION: Given finitely many positive reals, there is a positive eps radius smaller than all of them. **)
Theorem exists_eps_lt_four_pos : forall a b c d:set,
  a :e R -> b :e R -> c :e R -> d :e R ->
  Rlt 0 a -> Rlt 0 b -> Rlt 0 c -> Rlt 0 d ->
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 a /\ Rlt r3 b /\ Rlt r3 c /\ Rlt r3 d.
let a b c d.
assume HaR HbR HcR HdR.
assume Ha0 Hb0 Hc0 Hd0.
claim Hexab: exists r:set, r :e R /\ Rlt 0 r /\ Rlt r a /\ Rlt r b.
{ exact (exists_eps_lt_two_pos a b HaR HbR Ha0 Hb0). }
apply Hexab.
let r12. assume Hr12.
claim Hr12b: Rlt r12 b.
{ exact (andER ((r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a) (Rlt r12 b) Hr12). }
claim Hr12left: (r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a.
{ exact (andEL ((r12 :e R /\ Rlt 0 r12) /\ Rlt r12 a) (Rlt r12 b) Hr12). }
claim Hr12a: Rlt r12 a.
{ exact (andER (r12 :e R /\ Rlt 0 r12) (Rlt r12 a) Hr12left). }
claim Hr12pair: r12 :e R /\ Rlt 0 r12.
{ exact (andEL (r12 :e R /\ Rlt 0 r12) (Rlt r12 a) Hr12left). }
claim Hr12R: r12 :e R.
{ exact (andEL (r12 :e R) (Rlt 0 r12) Hr12pair). }
claim Hr12pos: Rlt 0 r12.
{ exact (andER (r12 :e R) (Rlt 0 r12) Hr12pair). }

claim Hexcd: exists r:set, r :e R /\ Rlt 0 r /\ Rlt r c /\ Rlt r d.
{ exact (exists_eps_lt_two_pos c d HcR HdR Hc0 Hd0). }
apply Hexcd.
let r34. assume Hr34.
claim Hr34d: Rlt r34 d.
{ exact (andER ((r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c) (Rlt r34 d) Hr34). }
claim Hr34left: (r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c.
{ exact (andEL ((r34 :e R /\ Rlt 0 r34) /\ Rlt r34 c) (Rlt r34 d) Hr34). }
claim Hr34c: Rlt r34 c.
{ exact (andER (r34 :e R /\ Rlt 0 r34) (Rlt r34 c) Hr34left). }
claim Hr34pair: r34 :e R /\ Rlt 0 r34.
{ exact (andEL (r34 :e R /\ Rlt 0 r34) (Rlt r34 c) Hr34left). }
claim Hr34R: r34 :e R.
{ exact (andEL (r34 :e R) (Rlt 0 r34) Hr34pair). }
claim Hr34pos: Rlt 0 r34.
{ exact (andER (r34 :e R) (Rlt 0 r34) Hr34pair). }

claim Hex: exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 r12 /\ Rlt r3 r34.
{ exact (exists_eps_lt_two_pos r12 r34 Hr12R Hr34R Hr12pos Hr34pos). }
apply Hex.
let r3. assume Hr3.
claim Hr3lt34: Rlt r3 r34.
{ exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12) (Rlt r3 r34) Hr3). }
claim Hr3left: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12.
{ exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 r12) (Rlt r3 r34) Hr3). }
claim Hr3lt12: Rlt r3 r12.
{ exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 r12) Hr3left). }
claim Hr3pair: r3 :e R /\ Rlt 0 r3.
{ exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 r12) Hr3left). }
claim Hr3R: r3 :e R.
{ exact (andEL (r3 :e R) (Rlt 0 r3) Hr3pair). }
claim Hr3pos: Rlt 0 r3.
{ exact (andER (r3 :e R) (Rlt 0 r3) Hr3pair). }
witness r3.
apply andI.
{ apply andI.
  { apply andI.
    { apply andI.
      { apply andI.
        { exact Hr3R. }
        { exact Hr3pos. } }
      { exact (Rlt_tra r3 r12 a Hr3lt12 Hr12a). } }
    { exact (Rlt_tra r3 r12 b Hr3lt12 Hr12b). } }
  { exact (Rlt_tra r3 r34 c Hr3lt34 Hr34c). } }
{ exact (Rlt_tra r3 r34 d Hr3lt34 Hr34d). }
Qed.

(** Helper: if a <= b and b < c then a < c **)
Theorem Rle_Rlt_tra : forall a b c:set, Rle a b -> Rlt b c -> Rlt a c.
let a b c.
assume Hab: Rle a b.
assume Hbc: Rlt b c.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HcR: c :e R.
{ exact (RltE_right b c Hbc). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
apply (SNoLt_trichotomy_or_impred a b HaS HbS (Rlt a c)).
- assume Hablt: a < b.
  claim HabRlt: Rlt a b.
  { exact (RltI a b HaR HbR Hablt). }
  exact (Rlt_tra a b c HabRlt Hbc).
- assume Habeq: a = b.
  rewrite Habeq.
  exact Hbc.
- assume Hbalt: b < a.
  claim HbaRlt: Rlt b a.
  { exact (RltI b a HbR HaR Hbalt). }
  claim Hnlt: ~(Rlt b a).
  { exact (RleE_nlt a b Hab). }
  claim Hfalse: False.
  { exact (Hnlt HbaRlt). }
apply FalseE.
exact Hfalse.
Qed.

(** Helper: if a < b and b <= c then a < c **)
Theorem Rlt_Rle_tra : forall a b c:set, Rlt a b -> Rle b c -> Rlt a c.
let a b c.
assume Hab: Rlt a b.
assume Hbc: Rle b c.
claim HaR: a :e R.
{ exact (RltE_left a b Hab). }
claim HbR: b :e R.
{ exact (RltE_right a b Hab). }
claim HcR: c :e R.
{ exact (RleE_right b c Hbc). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
apply (SNoLt_trichotomy_or_impred b c HbS HcS (Rlt a c)).
- assume Hbltc: b < c.
  claim HbcRlt: Rlt b c.
  { exact (RltI b c HbR HcR Hbltc). }
  exact (Rlt_tra a b c Hab HbcRlt).
- assume Hbeq: b = c.
  rewrite <- Hbeq.
  exact Hab.
- assume Hcltb: c < b.
  claim HcbRlt: Rlt c b.
  { exact (RltI c b HcR HbR Hcltb). }
  claim Hnlt: ~(Rlt c b).
  { exact (RleE_nlt b c Hbc). }
  exact (FalseE (Hnlt HcbRlt) (Rlt a c)).
Qed.

(** Helper: refinement of two open balls around a common point **)
(** LATEX VERSION: If x lies in two open balls, then some smaller ball around x is contained in their intersection. **)
Theorem open_ball_refine_intersection : forall X d c1 c2 x r1 r2:set,
  metric_on X d ->
  c1 :e X -> c2 :e X -> x :e X ->
  r1 :e R -> r2 :e R ->
  Rlt 0 r1 -> Rlt 0 r2 ->
  x :e open_ball X d c1 r1 ->
  x :e open_ball X d c2 r2 ->
  exists r3:set, r3 :e R /\ Rlt 0 r3 /\
    open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2).
let X d c1 c2 x r1 r2.
assume Hm: metric_on X d.
assume Hc1: c1 :e X.
assume Hc2: c2 :e X.
assume HxX: x :e X.
assume Hr1R: r1 :e R.
assume Hr2R: r2 :e R.
assume Hr1pos: Rlt 0 r1.
assume Hr2pos: Rlt 0 r2.
assume HxB1: x :e open_ball X d c1 r1.
assume HxB2: x :e open_ball X d c2 r2.

claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }

claim Hc1xIn: (c1,x) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X c1 x Hc1 HxX). }
claim Hc2xIn: (c2,x) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X c2 x Hc2 HxX). }

set dx1 := apply_fun d (c1,x).
set dx2 := apply_fun d (c2,x).
claim Hdx1R: dx1 :e R.
{ exact (Hfun (c1,x) Hc1xIn). }
claim Hdx2R: dx2 :e R.
{ exact (Hfun (c2,x) Hc2xIn). }
claim Hdx1S: SNo dx1.
{ exact (real_SNo dx1 Hdx1R). }
claim Hdx2S: SNo dx2.
{ exact (real_SNo dx2 Hdx2R). }
claim Hr1S: SNo r1.
{ exact (real_SNo r1 Hr1R). }
claim Hr2S: SNo r2.
{ exact (real_SNo r2 Hr2R). }

claim Hdx1lt_r1: dx1 < r1.
{ exact (RltE_lt dx1 r1 (open_ballE2 X d c1 r1 x HxB1)). }
claim Hdx2lt_r2: dx2 < r2.
{ exact (RltE_lt dx2 r2 (open_ballE2 X d c2 r2 x HxB2)). }

set mdx1 := minus_SNo dx1.
set mdx2 := minus_SNo dx2.
claim Hmdx1Def: mdx1 = minus_SNo dx1.
{ reflexivity. }
claim Hmdx2Def: mdx2 = minus_SNo dx2.
{ reflexivity. }
claim Hmdx1R: mdx1 :e R.
{ exact (real_minus_SNo dx1 Hdx1R). }
claim Hmdx2R: mdx2 :e R.
{ exact (real_minus_SNo dx2 Hdx2R). }
claim Hmdx1S: SNo mdx1.
{ exact (real_SNo mdx1 Hmdx1R). }
claim Hmdx2S: SNo mdx2.
{ exact (real_SNo mdx2 Hmdx2R). }

set delta1 := add_SNo r1 mdx1.
set delta2 := add_SNo r2 mdx2.
claim Hdelta1Def: delta1 = add_SNo r1 mdx1.
{ reflexivity. }
claim Hdelta2Def: delta2 = add_SNo r2 mdx2.
{ reflexivity. }
claim Hdelta1R: delta1 :e R.
{ exact (real_add_SNo r1 Hr1R mdx1 Hmdx1R). }
claim Hdelta2R: delta2 :e R.
{ exact (real_add_SNo r2 Hr2R mdx2 Hmdx2R). }
claim Hdelta1S: SNo delta1.
{ exact (real_SNo delta1 Hdelta1R). }
claim Hdelta2S: SNo delta2.
{ exact (real_SNo delta2 Hdelta2R). }

claim H0lt_delta1: 0 < delta1.
{ rewrite Hdelta1Def.
  rewrite Hmdx1Def.
  claim H0plus: add_SNo 0 dx1 < r1.
  { rewrite (add_SNo_0L dx1 Hdx1S).
    exact Hdx1lt_r1. }
  exact (add_SNo_minus_Lt2b r1 dx1 0 Hr1S Hdx1S SNo_0 H0plus). }
claim H0lt_delta2: 0 < delta2.
{ rewrite Hdelta2Def.
  rewrite Hmdx2Def.
  claim H0plus: add_SNo 0 dx2 < r2.
  { rewrite (add_SNo_0L dx2 Hdx2S).
    exact Hdx2lt_r2. }
  exact (add_SNo_minus_Lt2b r2 dx2 0 Hr2S Hdx2S SNo_0 H0plus). }

claim Hdelta1pos: Rlt 0 delta1.
{ exact (RltI 0 delta1 real_0 Hdelta1R H0lt_delta1). }
claim Hdelta2pos: Rlt 0 delta2.
{ exact (RltI 0 delta2 real_0 Hdelta2R H0lt_delta2). }

apply (SNoLt_trichotomy_or_impred delta1 delta2 Hdelta1S Hdelta2S
  (exists r3:set, r3 :e R /\ Rlt 0 r3 /\
    open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2))).
- assume Hdelta1lt: delta1 < delta2.
  claim HexN: exists N :e omega, eps_ N < delta1.
  { exact (exists_eps_lt_pos delta1 Hdelta1R Hdelta1pos). }
  apply HexN.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < delta1) HNpair). }
  claim HepsLt1: eps_ N < delta1.
  { exact (andER (N :e omega) (eps_ N < delta1) HNpair). }
  set r3 := eps_ N.
  claim Hr3S: SNo r3.
  { exact (SNo_eps_ N HNomega). }
  claim Hr3InS: r3 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega N HNomega). }
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 Hr3InS). }
  claim H0lt_r3: 0 < r3.
  { exact (SNo_eps_pos N HNomega). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R H0lt_r3). }
  claim Hr3lt1: r3 < delta1.
  { exact HepsLt1. }
  claim Hr3lt2: r3 < delta2.
  { exact (SNoLt_tra r3 delta1 delta2 Hr3S Hdelta1S Hdelta2S Hr3lt1 Hdelta1lt). }
  witness r3.
  apply andI.
  - apply andI.
    + exact Hr3R.
    + exact Hr3pos.
  - let y. assume Hy: y :e open_ball X d x r3.
    claim HyX: y :e X.
    { exact (open_ballE1 X d x r3 y Hy). }
    claim HxyIn: (x,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
    claim Hc1yIn: (c1,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c1 y Hc1 HyX). }
    claim Hc2yIn: (c2,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c2 y Hc2 HyX). }
    set dxy := apply_fun d (x,y).
    set dc1y := apply_fun d (c1,y).
    set dc2y := apply_fun d (c2,y).
    claim HdxyR: dxy :e R.
    { exact (Hfun (x,y) HxyIn). }
    claim Hdc1yR: dc1y :e R.
    { exact (Hfun (c1,y) Hc1yIn). }
    claim Hdc2yR: dc2y :e R.
    { exact (Hfun (c2,y) Hc2yIn). }
    claim HdxyS: SNo dxy.
    { exact (real_SNo dxy HdxyR). }
    claim Hdc1yS: SNo dc1y.
    { exact (real_SNo dc1y Hdc1yR). }
    claim Hdc2yS: SNo dc2y.
    { exact (real_SNo dc2y Hdc2yR). }
    claim HdxyLtR3: dxy < r3.
    { exact (RltE_lt dxy r3 (open_ballE2 X d x r3 y Hy)). }
    claim Hsum1R: add_SNo dx1 dxy :e R.
    { exact (real_add_SNo dx1 Hdx1R dxy HdxyR). }
    claim Hsum2R: add_SNo dx2 dxy :e R.
    { exact (real_add_SNo dx2 Hdx2R dxy HdxyR). }
    claim Hsum1S: SNo (add_SNo dx1 dxy).
    { exact (real_SNo (add_SNo dx1 dxy) Hsum1R). }
    claim Hsum2S: SNo (add_SNo dx2 dxy).
    { exact (real_SNo (add_SNo dx2 dxy) Hsum2R). }
    claim Hdx1r3R: add_SNo dx1 r3 :e R.
    { exact (real_add_SNo dx1 Hdx1R r3 Hr3R). }
    claim Hdx2r3R: add_SNo dx2 r3 :e R.
    { exact (real_add_SNo dx2 Hdx2R r3 Hr3R). }
    claim Hdx1r3S: SNo (add_SNo dx1 r3).
    { exact (real_SNo (add_SNo dx1 r3) Hdx1r3R). }
    claim Hdx2r3S: SNo (add_SNo dx2 r3).
    { exact (real_SNo (add_SNo dx2 r3) Hdx2r3R). }
    claim Hdx1delta1R: add_SNo dx1 delta1 :e R.
    { exact (real_add_SNo dx1 Hdx1R delta1 Hdelta1R). }
    claim Hdx2delta2R: add_SNo dx2 delta2 :e R.
    { exact (real_add_SNo dx2 Hdx2R delta2 Hdelta2R). }
    claim Hdx1delta1S: SNo (add_SNo dx1 delta1).
    { exact (real_SNo (add_SNo dx1 delta1) Hdx1delta1R). }
    claim Hdx2delta2S: SNo (add_SNo dx2 delta2).
    { exact (real_SNo (add_SNo dx2 delta2) Hdx2delta2R). }
    claim Hdx1r3lt: add_SNo dx1 r3 < r1.
    { claim Hdx1r3lt': add_SNo dx1 r3 < add_SNo dx1 delta1.
      { exact (add_SNo_Lt2 dx1 r3 delta1 Hdx1S Hr3S Hdelta1S Hr3lt1). }
      claim Heq: add_SNo dx1 delta1 = r1.
      { claim Hcom: add_SNo dx1 delta1 = add_SNo delta1 dx1.
        { exact (add_SNo_com dx1 delta1 Hdx1S Hdelta1S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r1 dx1 Hr1S Hdx1S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx1r3lt'. }
    claim Hdx2r3lt: add_SNo dx2 r3 < r2.
    { claim Hdx2r3lt': add_SNo dx2 r3 < add_SNo dx2 delta2.
      { exact (add_SNo_Lt2 dx2 r3 delta2 Hdx2S Hr3S Hdelta2S Hr3lt2). }
      claim Heq: add_SNo dx2 delta2 = r2.
      { claim Hcom: add_SNo dx2 delta2 = add_SNo delta2 dx2.
        { exact (add_SNo_com dx2 delta2 Hdx2S Hdelta2S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r2 dx2 Hr2S Hdx2S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx2r3lt'. }
    claim Hsum1lt: add_SNo dx1 dxy < r1.
    { claim Hlt1: add_SNo dx1 dxy < add_SNo dx1 r3.
      { exact (add_SNo_Lt2 dx1 dxy r3 Hdx1S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx1 dxy) (add_SNo dx1 r3) r1
             Hsum1S Hdx1r3S Hr1S Hlt1 Hdx1r3lt). }
    claim Hsum2lt: add_SNo dx2 dxy < r2.
    { claim Hlt1: add_SNo dx2 dxy < add_SNo dx2 r3.
      { exact (add_SNo_Lt2 dx2 dxy r3 Hdx2S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx2 dxy) (add_SNo dx2 r3) r2
             Hsum2S Hdx2r3S Hr2S Hlt1 Hdx2r3lt). }
    claim Htri1: Rle dc1y (add_SNo dx1 dxy).
    { exact (metric_triangle_Rle X d c1 x y Hm Hc1 HxX HyX). }
    claim Htri2: Rle dc2y (add_SNo dx2 dxy).
    { exact (metric_triangle_Rle X d c2 x y Hm Hc2 HxX HyX). }
    claim Hsum1Rlt: Rlt (add_SNo dx1 dxy) r1.
    { exact (RltI (add_SNo dx1 dxy) r1 Hsum1R Hr1R Hsum1lt). }
    claim Hsum2Rlt: Rlt (add_SNo dx2 dxy) r2.
    { exact (RltI (add_SNo dx2 dxy) r2 Hsum2R Hr2R Hsum2lt). }
    claim Hdc1yRlt: Rlt dc1y r1.
    { exact (Rle_Rlt_tra dc1y (add_SNo dx1 dxy) r1 Htri1 Hsum1Rlt). }
    claim Hdc2yRlt: Rlt dc2y r2.
    { exact (Rle_Rlt_tra dc2y (add_SNo dx2 dxy) r2 Htri2 Hsum2Rlt). }
    claim HyB1: y :e open_ball X d c1 r1.
    { exact (open_ballI X d c1 r1 y HyX Hdc1yRlt). }
    claim HyB2: y :e open_ball X d c2 r2.
    { exact (open_ballI X d c2 r2 y HyX Hdc2yRlt). }
    apply binintersectI.
    + exact HyB1.
    + exact HyB2.
- assume Hdeltaeq: delta1 = delta2.
  claim HexN: exists N :e omega, eps_ N < delta2.
  { exact (exists_eps_lt_pos delta2 Hdelta2R Hdelta2pos). }
  apply HexN.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < delta2) HNpair). }
  claim HepsLt2: eps_ N < delta2.
  { exact (andER (N :e omega) (eps_ N < delta2) HNpair). }
  set r3 := eps_ N.
  claim Hr3S: SNo r3.
  { exact (SNo_eps_ N HNomega). }
  claim Hr3InS: r3 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega N HNomega). }
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 Hr3InS). }
  claim H0lt_r3: 0 < r3.
  { exact (SNo_eps_pos N HNomega). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R H0lt_r3). }
  claim Hr3lt2: r3 < delta2.
  { exact HepsLt2. }
  claim Hr3lt1: r3 < delta1.
  { rewrite Hdeltaeq.
    exact Hr3lt2. }
  witness r3.
  apply andI.
  - apply andI.
    + exact Hr3R.
    + exact Hr3pos.
  - let y. assume Hy: y :e open_ball X d x r3.
    claim HyX: y :e X.
    { exact (open_ballE1 X d x r3 y Hy). }
    claim HxyIn: (x,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
    claim Hc1yIn: (c1,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c1 y Hc1 HyX). }
    claim Hc2yIn: (c2,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c2 y Hc2 HyX). }
    set dxy := apply_fun d (x,y).
    set dc1y := apply_fun d (c1,y).
    set dc2y := apply_fun d (c2,y).
    claim HdxyR: dxy :e R.
    { exact (Hfun (x,y) HxyIn). }
    claim Hdc1yR: dc1y :e R.
    { exact (Hfun (c1,y) Hc1yIn). }
    claim Hdc2yR: dc2y :e R.
    { exact (Hfun (c2,y) Hc2yIn). }
    claim HdxyS: SNo dxy.
    { exact (real_SNo dxy HdxyR). }
    claim Hdc1yS: SNo dc1y.
    { exact (real_SNo dc1y Hdc1yR). }
    claim Hdc2yS: SNo dc2y.
    { exact (real_SNo dc2y Hdc2yR). }
    claim HdxyLtR3: dxy < r3.
    { exact (RltE_lt dxy r3 (open_ballE2 X d x r3 y Hy)). }
    claim Hsum1R: add_SNo dx1 dxy :e R.
    { exact (real_add_SNo dx1 Hdx1R dxy HdxyR). }
    claim Hsum2R: add_SNo dx2 dxy :e R.
    { exact (real_add_SNo dx2 Hdx2R dxy HdxyR). }
    claim Hsum1S: SNo (add_SNo dx1 dxy).
    { exact (real_SNo (add_SNo dx1 dxy) Hsum1R). }
    claim Hsum2S: SNo (add_SNo dx2 dxy).
    { exact (real_SNo (add_SNo dx2 dxy) Hsum2R). }
    claim Hdx1r3R: add_SNo dx1 r3 :e R.
    { exact (real_add_SNo dx1 Hdx1R r3 Hr3R). }
    claim Hdx2r3R: add_SNo dx2 r3 :e R.
    { exact (real_add_SNo dx2 Hdx2R r3 Hr3R). }
    claim Hdx1r3S: SNo (add_SNo dx1 r3).
    { exact (real_SNo (add_SNo dx1 r3) Hdx1r3R). }
    claim Hdx2r3S: SNo (add_SNo dx2 r3).
    { exact (real_SNo (add_SNo dx2 r3) Hdx2r3R). }
    claim Hdx1r3lt: add_SNo dx1 r3 < r1.
    { claim Hdx1r3lt': add_SNo dx1 r3 < add_SNo dx1 delta1.
      { exact (add_SNo_Lt2 dx1 r3 delta1 Hdx1S Hr3S Hdelta1S Hr3lt1). }
      claim Heq: add_SNo dx1 delta1 = r1.
      { claim Hcom: add_SNo dx1 delta1 = add_SNo delta1 dx1.
        { exact (add_SNo_com dx1 delta1 Hdx1S Hdelta1S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r1 dx1 Hr1S Hdx1S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx1r3lt'. }
    claim Hdx2r3lt: add_SNo dx2 r3 < r2.
    { claim Hdx2r3lt': add_SNo dx2 r3 < add_SNo dx2 delta2.
      { exact (add_SNo_Lt2 dx2 r3 delta2 Hdx2S Hr3S Hdelta2S Hr3lt2). }
      claim Heq: add_SNo dx2 delta2 = r2.
      { claim Hcom: add_SNo dx2 delta2 = add_SNo delta2 dx2.
        { exact (add_SNo_com dx2 delta2 Hdx2S Hdelta2S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r2 dx2 Hr2S Hdx2S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx2r3lt'. }
    claim Hsum1lt: add_SNo dx1 dxy < r1.
    { claim Hlt1: add_SNo dx1 dxy < add_SNo dx1 r3.
      { exact (add_SNo_Lt2 dx1 dxy r3 Hdx1S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx1 dxy) (add_SNo dx1 r3) r1
             Hsum1S Hdx1r3S Hr1S Hlt1 Hdx1r3lt). }
    claim Hsum2lt: add_SNo dx2 dxy < r2.
    { claim Hlt1: add_SNo dx2 dxy < add_SNo dx2 r3.
      { exact (add_SNo_Lt2 dx2 dxy r3 Hdx2S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx2 dxy) (add_SNo dx2 r3) r2
             Hsum2S Hdx2r3S Hr2S Hlt1 Hdx2r3lt). }
    claim Htri1: Rle dc1y (add_SNo dx1 dxy).
    { exact (metric_triangle_Rle X d c1 x y Hm Hc1 HxX HyX). }
    claim Htri2: Rle dc2y (add_SNo dx2 dxy).
    { exact (metric_triangle_Rle X d c2 x y Hm Hc2 HxX HyX). }
    claim Hsum1Rlt: Rlt (add_SNo dx1 dxy) r1.
    { exact (RltI (add_SNo dx1 dxy) r1 Hsum1R Hr1R Hsum1lt). }
    claim Hsum2Rlt: Rlt (add_SNo dx2 dxy) r2.
    { exact (RltI (add_SNo dx2 dxy) r2 Hsum2R Hr2R Hsum2lt). }
    claim Hdc1yRlt: Rlt dc1y r1.
    { exact (Rle_Rlt_tra dc1y (add_SNo dx1 dxy) r1 Htri1 Hsum1Rlt). }
    claim Hdc2yRlt: Rlt dc2y r2.
    { exact (Rle_Rlt_tra dc2y (add_SNo dx2 dxy) r2 Htri2 Hsum2Rlt). }
    claim HyB1: y :e open_ball X d c1 r1.
    { exact (open_ballI X d c1 r1 y HyX Hdc1yRlt). }
    claim HyB2: y :e open_ball X d c2 r2.
    { exact (open_ballI X d c2 r2 y HyX Hdc2yRlt). }
    apply binintersectI.
    + exact HyB1.
    + exact HyB2.
- assume Hdelta2lt: delta2 < delta1.
  claim HexN: exists N :e omega, eps_ N < delta2.
  { exact (exists_eps_lt_pos delta2 Hdelta2R Hdelta2pos). }
  apply HexN.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < delta2) HNpair). }
  claim HepsLt2: eps_ N < delta2.
  { exact (andER (N :e omega) (eps_ N < delta2) HNpair). }
  set r3 := eps_ N.
  claim Hr3S: SNo r3.
  { exact (SNo_eps_ N HNomega). }
  claim Hr3InS: r3 :e SNoS_ omega.
  { exact (SNo_eps_SNoS_omega N HNomega). }
  claim Hr3R: r3 :e R.
  { exact (SNoS_omega_real r3 Hr3InS). }
  claim H0lt_r3: 0 < r3.
  { exact (SNo_eps_pos N HNomega). }
  claim Hr3pos: Rlt 0 r3.
  { exact (RltI 0 r3 real_0 Hr3R H0lt_r3). }
  claim Hr3lt2: r3 < delta2.
  { exact HepsLt2. }
  claim Hr3lt1: r3 < delta1.
  { exact (SNoLt_tra r3 delta2 delta1 Hr3S Hdelta2S Hdelta1S Hr3lt2 Hdelta2lt). }
  witness r3.
  apply andI.
  - apply andI.
    + exact Hr3R.
    + exact Hr3pos.
  - let y. assume Hy: y :e open_ball X d x r3.
    claim HyX: y :e X.
    { exact (open_ballE1 X d x r3 y Hy). }
    claim HxyIn: (x,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
    claim Hc1yIn: (c1,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c1 y Hc1 HyX). }
    claim Hc2yIn: (c2,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X c2 y Hc2 HyX). }
    set dxy := apply_fun d (x,y).
    set dc1y := apply_fun d (c1,y).
    set dc2y := apply_fun d (c2,y).
    claim HdxyR: dxy :e R.
    { exact (Hfun (x,y) HxyIn). }
    claim Hdc1yR: dc1y :e R.
    { exact (Hfun (c1,y) Hc1yIn). }
    claim Hdc2yR: dc2y :e R.
    { exact (Hfun (c2,y) Hc2yIn). }
    claim HdxyS: SNo dxy.
    { exact (real_SNo dxy HdxyR). }
    claim Hdc1yS: SNo dc1y.
    { exact (real_SNo dc1y Hdc1yR). }
    claim Hdc2yS: SNo dc2y.
    { exact (real_SNo dc2y Hdc2yR). }
    claim HdxyLtR3: dxy < r3.
    { exact (RltE_lt dxy r3 (open_ballE2 X d x r3 y Hy)). }
    claim Hsum1R: add_SNo dx1 dxy :e R.
    { exact (real_add_SNo dx1 Hdx1R dxy HdxyR). }
    claim Hsum2R: add_SNo dx2 dxy :e R.
    { exact (real_add_SNo dx2 Hdx2R dxy HdxyR). }
    claim Hsum1S: SNo (add_SNo dx1 dxy).
    { exact (real_SNo (add_SNo dx1 dxy) Hsum1R). }
    claim Hsum2S: SNo (add_SNo dx2 dxy).
    { exact (real_SNo (add_SNo dx2 dxy) Hsum2R). }
    claim Hdx1r3R: add_SNo dx1 r3 :e R.
    { exact (real_add_SNo dx1 Hdx1R r3 Hr3R). }
    claim Hdx2r3R: add_SNo dx2 r3 :e R.
    { exact (real_add_SNo dx2 Hdx2R r3 Hr3R). }
    claim Hdx1r3S: SNo (add_SNo dx1 r3).
    { exact (real_SNo (add_SNo dx1 r3) Hdx1r3R). }
    claim Hdx2r3S: SNo (add_SNo dx2 r3).
    { exact (real_SNo (add_SNo dx2 r3) Hdx2r3R). }
    claim Hdx1r3lt: add_SNo dx1 r3 < r1.
    { claim Hdx1r3lt': add_SNo dx1 r3 < add_SNo dx1 delta1.
      { exact (add_SNo_Lt2 dx1 r3 delta1 Hdx1S Hr3S Hdelta1S Hr3lt1). }
      claim Heq: add_SNo dx1 delta1 = r1.
      { claim Hcom: add_SNo dx1 delta1 = add_SNo delta1 dx1.
        { exact (add_SNo_com dx1 delta1 Hdx1S Hdelta1S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r1 dx1 Hr1S Hdx1S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx1r3lt'. }
    claim Hdx2r3lt: add_SNo dx2 r3 < r2.
    { claim Hdx2r3lt': add_SNo dx2 r3 < add_SNo dx2 delta2.
      { exact (add_SNo_Lt2 dx2 r3 delta2 Hdx2S Hr3S Hdelta2S Hr3lt2). }
      claim Heq: add_SNo dx2 delta2 = r2.
      { claim Hcom: add_SNo dx2 delta2 = add_SNo delta2 dx2.
        { exact (add_SNo_com dx2 delta2 Hdx2S Hdelta2S). }
        rewrite Hcom.
        rewrite (add_SNo_minus_R2' r2 dx2 Hr2S Hdx2S).
        reflexivity. }
      rewrite <- Heq.
      exact Hdx2r3lt'. }
    claim Hsum1lt: add_SNo dx1 dxy < r1.
    { claim Hlt1: add_SNo dx1 dxy < add_SNo dx1 r3.
      { exact (add_SNo_Lt2 dx1 dxy r3 Hdx1S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx1 dxy) (add_SNo dx1 r3) r1
             Hsum1S Hdx1r3S Hr1S Hlt1 Hdx1r3lt). }
    claim Hsum2lt: add_SNo dx2 dxy < r2.
    { claim Hlt1: add_SNo dx2 dxy < add_SNo dx2 r3.
      { exact (add_SNo_Lt2 dx2 dxy r3 Hdx2S HdxyS Hr3S HdxyLtR3). }
      exact (SNoLt_tra (add_SNo dx2 dxy) (add_SNo dx2 r3) r2
             Hsum2S Hdx2r3S Hr2S Hlt1 Hdx2r3lt). }
    claim Htri1: Rle dc1y (add_SNo dx1 dxy).
    { exact (metric_triangle_Rle X d c1 x y Hm Hc1 HxX HyX). }
    claim Htri2: Rle dc2y (add_SNo dx2 dxy).
    { exact (metric_triangle_Rle X d c2 x y Hm Hc2 HxX HyX). }
    claim Hsum1Rlt: Rlt (add_SNo dx1 dxy) r1.
    { exact (RltI (add_SNo dx1 dxy) r1 Hsum1R Hr1R Hsum1lt). }
    claim Hsum2Rlt: Rlt (add_SNo dx2 dxy) r2.
    { exact (RltI (add_SNo dx2 dxy) r2 Hsum2R Hr2R Hsum2lt). }
    claim Hdc1yRlt: Rlt dc1y r1.
    { exact (Rle_Rlt_tra dc1y (add_SNo dx1 dxy) r1 Htri1 Hsum1Rlt). }
    claim Hdc2yRlt: Rlt dc2y r2.
    { exact (Rle_Rlt_tra dc2y (add_SNo dx2 dxy) r2 Htri2 Hsum2Rlt). }
    claim HyB1: y :e open_ball X d c1 r1.
    { exact (open_ballI X d c1 r1 y HyX Hdc1yRlt). }
    claim HyB2: y :e open_ball X d c2 r2.
    { exact (open_ballI X d c2 r2 y HyX Hdc2yRlt). }
    apply binintersectI.
    + exact HyB1.
    + exact HyB2.
Qed.

(** Helper: if x lies in an open ball, then some ball around x lies inside it **)
(** LATEX VERSION: If x in B_r(c), then exists s>0 with B_s(x) subset B_r(c). **)
Theorem open_ball_refine_center : forall X d c x r:set,
  metric_on X d ->
  c :e X -> x :e X ->
  r :e R -> Rlt 0 r ->
  x :e open_ball X d c r ->
  exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r.
let X d c x r.
assume Hm: metric_on X d.
assume Hc: c :e X.
assume HxX: x :e X.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
assume Hxin: x :e open_ball X d c r.
claim Hcenter: x :e open_ball X d x r.
{ exact (center_in_open_ball X d x r Hm HxX Hrpos). }
claim Hex: exists s:set, s :e R /\ Rlt 0 s /\
  open_ball X d x s c= (open_ball X d c r) :/\: (open_ball X d x r).
{ exact (open_ball_refine_intersection X d c x x r r Hm Hc HxX HxX HrR HrR Hrpos Hrpos Hxin Hcenter). }
apply Hex.
let s. assume Hs.
claim Hs1: s :e R /\ Rlt 0 s.
{ exact (andEL (s :e R /\ Rlt 0 s)
               (open_ball X d x s c= (open_ball X d c r) :/\: (open_ball X d x r))
               Hs). }
claim HsR: s :e R.
{ exact (andEL (s :e R) (Rlt 0 s) Hs1). }
claim Hspos: Rlt 0 s.
{ exact (andER (s :e R) (Rlt 0 s) Hs1). }
claim Hsubcap: open_ball X d x s c= (open_ball X d c r) :/\: (open_ball X d x r).
{ exact (andER (s :e R /\ Rlt 0 s)
               (open_ball X d x s c= (open_ball X d c r) :/\: (open_ball X d x r))
               Hs). }
claim Hsub: open_ball X d x s c= open_ball X d c r.
{ exact (Subq_tra (open_ball X d x s) ((open_ball X d c r) :/\: (open_ball X d x r)) (open_ball X d c r)
         Hsubcap (binintersect_Subq_1 (open_ball X d c r) (open_ball X d x r))). }
witness s.
apply andI.
- apply andI.
  + exact HsR.
  + exact Hspos.
- exact Hsub.
Qed.

(** from §20: metric topology induced by a metric **)
(** LATEX VERSION: If d is a metric on X, the collection of all epsilon balls B_d(x,eps) forms a basis for a topology on X, called the metric topology induced by d. **)
Definition metric_topology : set -> set -> set := fun X d =>
  generated_topology X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})).

(** from §20: open balls form a basis **)
(** LATEX VERSION: In a metric space, open balls form a basis for the metric topology. **)
Theorem open_balls_form_basis : forall X d:set,
  metric_on X d -> basis_on X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})).
let X d.
assume Hd: metric_on X d.
prove basis_on X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})).
set B := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
prove (B c= Power X /\ (forall x :e X, exists b :e B, x :e b)) /\
  (forall b1 :e B, forall b2 :e B, forall x:set,
     x :e b1 -> x :e b2 ->
     exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2).
apply andI.
- (** B c= Power X and cover property **)
  apply andI.
  + (** B c= Power X **)
    let b. assume Hb: b :e B.
    prove b :e Power X.
    apply (famunionE_impred X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) b Hb (b :e Power X)).
    let x0. assume Hx0: x0 :e X.
    assume HbIn: b :e {open_ball X d x0 r|r :e R, Rlt 0 r}.
    apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x0 r0) b HbIn (b :e Power X)).
    let r0. assume Hr0R: r0 :e R.
    assume Hr0pos: Rlt 0 r0.
    assume Hbeq: b = open_ball X d x0 r0.
    rewrite Hbeq.
    exact (open_ball_in_Power X d x0 r0).
	  + (** cover property **)
	    let x. assume Hx: x :e X.
	    prove exists b :e B, x :e b.
	    witness (open_ball X d x 1).
	    apply andI.
	    - (** b :e B **)
	      claim HballIn: open_ball X d x 1 :e {open_ball X d x r|r :e R, Rlt 0 r}.
	      { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x r0) 1 real_1 Rlt_0_1). }
	      exact (famunionI X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) x (open_ball X d x 1) Hx HballIn).
	    - (** x :e b **)
	      exact (center_in_open_ball X d x 1 Hd Hx Rlt_0_1).
- (** refinement property for intersections around a point **)
  let b1. assume Hb1: b1 :e B.
  let b2. assume Hb2: b2 :e B.
  let x. assume Hxb1: x :e b1.
  assume Hxb2: x :e b2.
  prove exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2.
  (** destruct b1 and b2 as open balls; the remaining metric refinement is admitted **)
  apply (famunionE_impred X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) b1 Hb1
         (exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)).
  let c1. assume Hc1: c1 :e X.
  assume Hb1In: b1 :e {open_ball X d c1 r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c1 r0) b1 Hb1In
         (exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)).
  let r1. assume Hr1R: r1 :e R.
  assume Hr1pos: Rlt 0 r1.
  assume Hb1eq: b1 = open_ball X d c1 r1.
  apply (famunionE_impred X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) b2 Hb2
         (exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)).
  let c2. assume Hc2: c2 :e X.
  assume Hb2In: b2 :e {open_ball X d c2 r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c2 r0) b2 Hb2In
         (exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)).
  let r2. assume Hr2R: r2 :e R.
  assume Hr2pos: Rlt 0 r2.
  assume Hb2eq: b2 = open_ball X d c2 r2.
  claim Hxball1: x :e open_ball X d c1 r1.
  { rewrite <- Hb1eq. exact Hxb1. }
  claim Hxball2: x :e open_ball X d c2 r2.
  { rewrite <- Hb2eq. exact Hxb2. }
  claim HxX: x :e X.
  { exact (SepE1 X (fun y0:set => Rlt (apply_fun d (c1,y0)) r1) x Hxball1). }
  claim Hexr3: exists r3:set, r3 :e R /\ Rlt 0 r3 /\
    open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2).
  { exact (open_ball_refine_intersection X d c1 c2 x r1 r2 Hd Hc1 Hc2 HxX
            Hr1R Hr2R Hr1pos Hr2pos Hxball1 Hxball2). }
  apply Hexr3.
  let r3. assume Hr3: r3 :e R /\ Rlt 0 r3 /\ open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2).
  claim Hr3left: r3 :e R /\ Rlt 0 r3.
  { exact (andEL (r3 :e R /\ Rlt 0 r3)
                 (open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2))
                 Hr3). }
  claim Hr3R: r3 :e R.
  { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3left). }
  claim Hr3pos: Rlt 0 r3.
  { exact (andER (r3 :e R) (Rlt 0 r3) Hr3left). }
  claim Hr3sub: open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2).
  { exact (andER (r3 :e R /\ Rlt 0 r3)
                 (open_ball X d x r3 c= (open_ball X d c1 r1) :/\: (open_ball X d c2 r2))
                 Hr3). }
  witness (open_ball X d x r3).
  prove open_ball X d x r3 :e B /\ (x :e open_ball X d x r3 /\ open_ball X d x r3 c= b1 :/\: b2).
  apply andI.
  - (** open_ball X d x r3 :e B **)
    claim HballIn: open_ball X d x r3 :e {open_ball X d x r|r :e R, Rlt 0 r}.
    { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x r0) r3 Hr3R Hr3pos). }
    exact (famunionI X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) x (open_ball X d x r3)
           HxX HballIn).
  - apply andI.
    + (** x :e open_ball X d x r3 **)
      exact (center_in_open_ball X d x r3 Hd HxX Hr3pos).
    + (** subset **)
      rewrite Hb1eq.
      rewrite Hb2eq.
      exact Hr3sub.
Qed.

Theorem metric_topology_is_topology : forall X d:set,
  metric_on X d -> topology_on X (metric_topology X d).
let X d.
assume Hd: metric_on X d.
prove topology_on X (metric_topology X d).
exact (lemma_topology_from_basis X
         (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r}))
         (open_balls_form_basis X d Hd)).
Qed.

(** from §20: metric-induced topology equals generated topology of balls **)
(** LATEX VERSION: The topology induced by a metric is the topology generated by the family of open balls. **)
Theorem metric_topology_generated_by_balls : forall X d:set,
  metric_on X d ->
  generated_topology X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})) = metric_topology X d.
let X d.
assume Hd: metric_on X d.
prove generated_topology X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})) = metric_topology X d.
(** By definition, metric_topology X d = generated_topology X (famunion X (fun x => {open_ball X d x r|r :e R, Rlt 0 r})) **)
reflexivity.
Qed.

(** helper: EuclidPlane_metric open balls are circular regions **)
(** LATEX VERSION: For Euclidean metric on R^2, every metric open ball is a circular region (and conversely). **)
Theorem open_ball_EuclidPlane_metric_in_circular_regions : forall c r:set,
  c :e EuclidPlane -> r :e R -> Rlt 0 r ->
  open_ball EuclidPlane EuclidPlane_metric c r :e circular_regions.
let c r.
assume Hc: c :e EuclidPlane.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
rewrite (open_ball_EuclidPlane_metric_eq c r Hc).
exact (circular_regionI c r Hc Hrpos).
Qed.

(** helper: the family of EuclidPlane_metric open balls equals circular_regions **)
(** LATEX VERSION: {B_d(c,r) | c∈R^2, r>0} = {U⊂R^2 | ∃c,r>0, U={p|d(p,c)<r}}. **)
Theorem EuclidPlane_metric_open_balls_family_eq_circular_regions :
  famunion EuclidPlane (fun c:set => {open_ball EuclidPlane EuclidPlane_metric c r|r :e R, Rlt 0 r})
    = circular_regions.
apply set_ext.
- let U. assume HU: U :e famunion EuclidPlane (fun c:set => {open_ball EuclidPlane EuclidPlane_metric c r|r :e R, Rlt 0 r}).
  prove U :e circular_regions.
  apply (famunionE_impred EuclidPlane (fun c0:set => {open_ball EuclidPlane EuclidPlane_metric c0 r|r :e R, Rlt 0 r})
         U HU (U :e circular_regions)).
  let c. assume Hc: c :e EuclidPlane.
  assume HUIn: U :e {open_ball EuclidPlane EuclidPlane_metric c r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball EuclidPlane EuclidPlane_metric c r0)
         U HUIn (U :e circular_regions)).
  let r. assume HrR: r :e R.
  assume Hrpos: Rlt 0 r.
  assume HUeq: U = open_ball EuclidPlane EuclidPlane_metric c r.
  rewrite HUeq.
  exact (open_ball_EuclidPlane_metric_in_circular_regions c r Hc HrR Hrpos).
- let U. assume HU: U :e circular_regions.
  prove U :e famunion EuclidPlane (fun c0:set => {open_ball EuclidPlane EuclidPlane_metric c0 r|r :e R, Rlt 0 r}).
  claim HUdesc:
    exists c:set, exists r:set,
      c :e EuclidPlane /\ Rlt 0 r /\
      U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
  { exact (SepE2 (Power EuclidPlane)
          (fun U0:set =>
            exists c0:set, exists r0:set,
              c0 :e EuclidPlane /\ Rlt 0 r0 /\
              U0 = {p :e EuclidPlane|Rlt (distance_R2 p c0) r0})
          U HU). }
  apply HUdesc.
  let c. assume HrEx:
    exists r:set, c :e EuclidPlane /\ Rlt 0 r /\ U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
  apply HrEx.
  let r. assume Hcore:
    c :e EuclidPlane /\ Rlt 0 r /\ U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
  claim Hcr: c :e EuclidPlane /\ Rlt 0 r.
  { exact (andEL (c :e EuclidPlane /\ Rlt 0 r) (U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}) Hcore). }
  claim HUeq0: U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}.
  { exact (andER (c :e EuclidPlane /\ Rlt 0 r) (U = {p :e EuclidPlane|Rlt (distance_R2 p c) r}) Hcore). }
  claim Hc: c :e EuclidPlane.
  { exact (andEL (c :e EuclidPlane) (Rlt 0 r) Hcr). }
  claim Hrpos: Rlt 0 r.
  { exact (andER (c :e EuclidPlane) (Rlt 0 r) Hcr). }
  claim HrR: r :e R.
  { exact (RltE_right 0 r Hrpos). }
  claim HUeqBall: U = open_ball EuclidPlane EuclidPlane_metric c r.
  { rewrite HUeq0.
    rewrite <- (open_ball_EuclidPlane_metric_eq c r Hc).
    reflexivity. }
  claim HballIn: open_ball EuclidPlane EuclidPlane_metric c r :e {open_ball EuclidPlane EuclidPlane_metric c rr|rr :e R, Rlt 0 rr}.
  { exact (ReplSepI R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball EuclidPlane EuclidPlane_metric c rr) r HrR Hrpos). }
  claim HUIn: U :e {open_ball EuclidPlane EuclidPlane_metric c rr|rr :e R, Rlt 0 rr}.
  { rewrite HUeqBall. exact HballIn. }
  exact (famunionI EuclidPlane (fun c0:set => {open_ball EuclidPlane EuclidPlane_metric c0 rr|rr :e R, Rlt 0 rr})
         c U Hc HUIn).
Qed.

(** helper: Euclidean metric topology equals the topology generated by circular regions **)
(** LATEX VERSION: The metric topology induced by Euclidean distance on R^2 equals the topology generated by circular regions. **)
Theorem metric_topology_EuclidPlane_metric_eq_generated_circular_regions :
  metric_topology EuclidPlane EuclidPlane_metric = generated_topology EuclidPlane circular_regions.
prove metric_topology EuclidPlane EuclidPlane_metric = generated_topology EuclidPlane circular_regions.
rewrite <- (metric_topology_generated_by_balls EuclidPlane EuclidPlane_metric EuclidPlane_metric_is_metric_on).
rewrite (EuclidPlane_metric_open_balls_family_eq_circular_regions).
reflexivity.
Qed.

(** helper: Euclidean metric topology also equals topology generated by rectangular regions **)
(** LATEX VERSION: Combining circular-vs-rectangular equivalence with the Euclidean metric description. **)
Theorem metric_topology_EuclidPlane_metric_eq_generated_rectangular_regions :
  metric_topology EuclidPlane EuclidPlane_metric = generated_topology EuclidPlane rectangular_regions.
prove metric_topology EuclidPlane EuclidPlane_metric = generated_topology EuclidPlane rectangular_regions.
rewrite (metric_topology_EuclidPlane_metric_eq_generated_circular_regions).
exact (circular_rectangular_same_topology_plane).
Qed.

(** helper: Euclidean metric topology is contained in the standard topology on R^2 **)
(** LATEX VERSION: The metric topology induced by the Euclidean metric is no finer than the standard topology on ℝ². **)
Theorem metric_topology_EuclidPlane_metric_sub_R2_standard_topology :
  metric_topology EuclidPlane EuclidPlane_metric c= R2_standard_topology.
prove metric_topology EuclidPlane EuclidPlane_metric c= R2_standard_topology.
rewrite (metric_topology_EuclidPlane_metric_eq_generated_rectangular_regions).
exact generated_topology_rectangular_regions_sub_R2_standard_topology.
Qed.

(** helper: Euclidean metric topology equals the standard topology on R^2 **)
(** LATEX VERSION: The topology induced by the Euclidean metric on ℝ² coincides with the standard product topology on ℝ². **)
Theorem metric_topology_EuclidPlane_metric_eq_R2_standard_topology :
  metric_topology EuclidPlane EuclidPlane_metric = R2_standard_topology.
prove metric_topology EuclidPlane EuclidPlane_metric = R2_standard_topology.
rewrite (metric_topology_EuclidPlane_metric_eq_generated_rectangular_regions).
exact generated_topology_rectangular_regions_eq_R2_standard_topology.
Qed.

(** Helper: open balls are open in the metric topology **)
Theorem open_ball_open_in_metric_topology : forall X d x r:set,
  metric_on X d -> x :e X -> Rlt 0 r ->
  open_in X (metric_topology X d) (open_ball X d x r).
let X d x r.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hr: Rlt 0 r.
set B := famunion X (fun x0 => {open_ball X d x0 rr|rr :e R, Rlt 0 rr}).
claim HBasis: basis_on X B.
{ exact (open_balls_form_basis X d Hm). }
claim Hball_in_rfam: open_ball X d x r :e {open_ball X d x rr|rr :e R, Rlt 0 rr}.
{ claim HrR: r :e R.
  { exact (RltE_right 0 r Hr). }
  exact (ReplSepI R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball X d x rr) r HrR Hr). }
claim Hball_in_B: open_ball X d x r :e B.
{ exact (famunionI X (fun x0 => {open_ball X d x0 rr|rr :e R, Rlt 0 rr}) x (open_ball X d x r) Hx Hball_in_rfam). }
claim HT: topology_on X (metric_topology X d).
{ exact (metric_topology_is_topology X d Hm). }
prove topology_on X (metric_topology X d) /\ open_ball X d x r :e metric_topology X d.
apply andI.
- exact HT.
- prove open_ball X d x r :e metric_topology X d.
  prove open_ball X d x r :e generated_topology X B.
  exact (generated_topology_contains_basis X B HBasis (open_ball X d x r) Hball_in_B).
Qed.

(** Helper: open balls are elements of the metric topology **)
Theorem open_ball_in_metric_topology : forall X d x r:set,
  metric_on X d -> x :e X -> Rlt 0 r ->
  open_ball X d x r :e metric_topology X d.
let X d x r.
assume Hm: metric_on X d.
assume Hx: x :e X.
assume Hr: Rlt 0 r.
exact (open_in_elem X (metric_topology X d) (open_ball X d x r)
        (open_ball_open_in_metric_topology X d x r Hm Hx Hr)).
Qed.

(** helper: metric spaces are Hausdorff in the metric topology **)
(** LATEX VERSION: Metric spaces are Hausdorff: distinct points have disjoint open balls. **)
Theorem metric_topology_Hausdorff : forall X d:set,
  metric_on X d ->
  Hausdorff_space X (metric_topology X d).
let X d.
assume Hm: metric_on X d.
prove Hausdorff_space X (metric_topology X d).
prove topology_on X (metric_topology X d) /\
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e metric_topology X d /\ V :e metric_topology X d /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact (metric_topology_is_topology X d Hm).
- let x1 x2.
  assume Hx1X: x1 :e X.
  assume Hx2X: x2 :e X.
  assume Hneq: x1 <> x2.
  prove exists U V:set,
    U :e metric_topology X d /\ V :e metric_topology X d /\
    x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  claim Hdistpos: Rlt 0 (apply_fun d (x1,x2)).
  { exact (metric_on_pos_of_neq X d x1 x2 Hm Hx1X Hx2X Hneq). }
  claim Hfun: function_on d (setprod X X) R.
  { exact (metric_on_function_on X d Hm). }
  claim Hx1x2In: (x1,x2) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x1 x2 Hx1X Hx2X). }
  claim HdistR: apply_fun d (x1,x2) :e R.
  { exact (Hfun (x1,x2) Hx1x2In). }
  claim HexN: exists N :e omega, eps_ N < apply_fun d (x1,x2).
  { exact (exists_eps_lt_pos (apply_fun d (x1,x2)) HdistR Hdistpos). }
  apply HexN.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < apply_fun d (x1,x2)) HNpair). }
  claim HepsNlt: eps_ N < apply_fun d (x1,x2).
  { exact (andER (N :e omega) (eps_ N < apply_fun d (x1,x2)) HNpair). }
  claim HsuccOmega: ordsucc N :e omega.
  { exact (omega_ordsucc N HNomega). }
  set r := eps_ (ordsucc N).
  claim Hrdef: r = eps_ (ordsucc N).
  { reflexivity. }
  claim HrR: r :e R.
  { rewrite Hrdef.
    exact (SNoS_omega_real (eps_ (ordsucc N)) (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
  claim Hrpos: Rlt 0 r.
  { exact (RltI 0 r real_0 HrR (SNo_eps_pos (ordsucc N) HsuccOmega)). }
  set U := open_ball X d x1 r.
  set V := open_ball X d x2 r.
  claim HUopen: U :e metric_topology X d.
  { exact (open_ball_in_metric_topology X d x1 r Hm Hx1X Hrpos). }
  claim HVopen: V :e metric_topology X d.
  { exact (open_ball_in_metric_topology X d x2 r Hm Hx2X Hrpos). }
  claim Hx1U: x1 :e U.
  { exact (center_in_open_ball X d x1 r Hm Hx1X Hrpos). }
  claim Hx2V: x2 :e V.
  { exact (center_in_open_ball X d x2 r Hm Hx2X Hrpos). }
  claim HUVdisj: U :/\: V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e U :/\: V.
    prove z :e Empty.
    apply FalseE.
    claim HzU: z :e U.
    { exact (binintersectE1 U V z Hz). }
    claim HzV: z :e V.
    { exact (binintersectE2 U V z Hz). }
    claim HzX: z :e X.
    { exact (open_ballE1 X d x1 r z HzU). }
    claim Hxz1: Rlt (apply_fun d (x1,z)) r.
    { exact (open_ballE2 X d x1 r z HzU). }
    claim Hxz2raw: Rlt (apply_fun d (x2,z)) r.
    { exact (open_ballE2 X d x2 r z HzV). }
    claim Hsym: apply_fun d (z,x2) = apply_fun d (x2,z).
    { exact (metric_on_symmetric X d z x2 Hm HzX Hx2X). }
    claim Hxz2: Rlt (apply_fun d (z,x2)) r.
    { rewrite Hsym.
      exact Hxz2raw. }
    claim Hx1zIn: (x1,z) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x1 z Hx1X HzX). }
    claim Hzx2In: (z,x2) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X z x2 HzX Hx2X). }
    claim Hd1R: apply_fun d (x1,z) :e R.
    { exact (Hfun (x1,z) Hx1zIn). }
    claim Hd2R: apply_fun d (z,x2) :e R.
    { exact (Hfun (z,x2) Hzx2In). }
    claim HrS: SNo r.
    { exact (real_SNo r HrR). }
    claim Hd1S: SNo (apply_fun d (x1,z)).
    { exact (real_SNo (apply_fun d (x1,z)) Hd1R). }
    claim Hd2S: SNo (apply_fun d (z,x2)).
    { exact (real_SNo (apply_fun d (z,x2)) Hd2R). }
    claim Hd1lt: apply_fun d (x1,z) < r.
    { exact (RltE_lt (apply_fun d (x1,z)) r Hxz1). }
    claim Hd2lt: apply_fun d (z,x2) < r.
    { exact (RltE_lt (apply_fun d (z,x2)) r Hxz2). }
    claim Hsumlt: add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2)) < add_SNo r r.
    { exact (add_SNo_Lt3 (apply_fun d (x1,z)) (apply_fun d (z,x2)) r r Hd1S Hd2S HrS HrS Hd1lt Hd2lt). }
    claim HsumR: add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2)) :e R.
    { exact (real_add_SNo (apply_fun d (x1,z)) Hd1R (apply_fun d (z,x2)) Hd2R). }
    claim HrrR: add_SNo r r :e R.
    { exact (real_add_SNo r HrR r HrR). }
    claim HsumRlt_rr: Rlt (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2))) (add_SNo r r).
    { exact (RltI (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2)))
                  (add_SNo r r)
                  HsumR
                  HrrR
                  Hsumlt). }
    claim HNnat: nat_p N.
    { exact (omega_nat_p N HNomega). }
    claim HrrEq: add_SNo r r = eps_ N.
    { rewrite (eps_ordsucc_half_add N HNnat).
      reflexivity. }
    claim HepsNR: eps_ N :e R.
    { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
    claim Hrrlt: Rlt (add_SNo r r) (apply_fun d (x1,x2)).
    { rewrite HrrEq.
      exact (RltI (eps_ N) (apply_fun d (x1,x2)) HepsNR HdistR HepsNlt). }
    claim HsumRlt_dist: Rlt (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2))) (apply_fun d (x1,x2)).
    { exact (Rlt_tra (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2)))
                     (add_SNo r r)
                     (apply_fun d (x1,x2))
                     HsumRlt_rr
                     Hrrlt). }
    claim Htri: Rle (apply_fun d (x1,x2)) (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2))).
    { exact (metric_triangle_Rle X d x1 z x2 Hm Hx1X HzX Hx2X). }
    exact ((RleE_nlt (apply_fun d (x1,x2))
                     (add_SNo (apply_fun d (x1,z)) (apply_fun d (z,x2)))
                     Htri)
           HsumRlt_dist). }
  witness U.
  witness V.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        { exact HUopen. }
        { exact HVopen. }
      * exact Hx1U.
    + exact Hx2V.
  - exact HUVdisj.
Qed.

(** from §21: epsilon-delta continuity in metric spaces **) 
(** LATEX VERSION: A map between metric spaces is continuous exactly when it satisfies the epsilon-delta condition. **)
Theorem metric_epsilon_delta_continuity : forall X dX Y dY f:set,
  metric_on X dX -> metric_on Y dY -> function_on f X Y ->
  (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f <->
  (forall x0:set, x0 :e X ->
     forall eps:set, eps :e R /\ Rlt 0 eps ->
       exists delta:set, delta :e R /\ Rlt 0 delta /\
         (forall x:set, x :e X ->
            Rlt (apply_fun dX (x,x0)) delta ->
            Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))).
let X dX Y dY f.
assume HdX: metric_on X dX.
assume HdY: metric_on Y dY.
assume Hf: function_on f X Y.
prove continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f <->
     (forall x0:set, x0 :e X ->
       forall eps:set, eps :e R /\ Rlt 0 eps ->
(** FIXED: Removed extra parentheses around pair argument to dY metric, now apply_fun dY (apply_fun f x, apply_fun f x0), consistent with dX usage. **)
		       exists delta:set, delta :e R /\ Rlt 0 delta /\
				         (forall x:set, x :e X ->
				            Rlt (apply_fun dX (x,x0)) delta ->
				            Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps)).
apply iffI.
- assume Hcont: continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
  let x0. assume Hx0: x0 :e X.
  let eps. assume Heps: eps :e R /\ Rlt 0 eps.
  (** Goal: produce delta from openness of preimage of the eps-ball around f(x0). **)
  claim HepsR: eps :e R.
  { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
  claim Hepspos: Rlt 0 eps.
  { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
  claim Hfx0Y: apply_fun f x0 :e Y.
  { exact (Hf x0 Hx0). }
  set V := open_ball Y dY (apply_fun f x0) eps.
  claim HVtop: V :e metric_topology Y dY.
  { exact (open_ball_in_metric_topology Y dY (apply_fun f x0) eps HdY Hfx0Y Hepspos). }
  set U := preimage_of X f V.
  claim HUtop: U :e metric_topology X dX.
  { exact (continuous_map_preimage X (metric_topology X dX) Y (metric_topology Y dY) f Hcont V HVtop). }
  set Bx := famunion X (fun x0:set => {open_ball X dX x0 r|r :e R, Rlt 0 r}).
  claim HUgen: U :e generated_topology X Bx.
  { exact HUtop. }
  claim Hx0ball: apply_fun f x0 :e V.
  { exact (center_in_open_ball Y dY (apply_fun f x0) eps HdY Hfx0Y Hepspos). }
  claim Hx0U: x0 :e U.
  { exact (SepI X (fun x:set => apply_fun f x :e V) x0 Hx0 Hx0ball). }
  claim HUlocal: forall z :e U, exists b :e Bx, z :e b /\ b c= U.
  { exact (SepE2 (Power X)
                 (fun U0 : set => forall x0 :e U0, exists b :e Bx, x0 :e b /\ b c= U0)
                 U HUgen). }
  apply (HUlocal x0 Hx0U).
  let b. assume Hbpair.
  claim HbBx: b :e Bx.
  { exact (andEL (b :e Bx) (x0 :e b /\ b c= U) Hbpair). }
  claim Hbprop: x0 :e b /\ b c= U.
  { exact (andER (b :e Bx) (x0 :e b /\ b c= U) Hbpair). }
  claim Hx0b: x0 :e b.
  { exact (andEL (x0 :e b) (b c= U) Hbprop). }
  claim HbsubU: b c= U.
  { exact (andER (x0 :e b) (b c= U) Hbprop). }
  (** destruct b as an open ball, then refine to a ball centered at x0 **)
  apply (famunionE_impred X (fun x0:set => {open_ball X dX x0 r|r :e R, Rlt 0 r}) b HbBx
         (exists delta:set, delta :e R /\ Rlt 0 delta /\
           (forall x:set, x :e X ->
              Rlt (apply_fun dX (x,x0)) delta ->
              Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))).
  let c. assume HcX: c :e X.
  assume HbIn: b :e {open_ball X dX c r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X dX c r0) b HbIn
         (exists delta:set, delta :e R /\ Rlt 0 delta /\
           (forall x:set, x :e X ->
              Rlt (apply_fun dX (x,x0)) delta ->
              Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))).
  let r. assume HrR: r :e R.
  assume Hrpos: Rlt 0 r.
  assume Hbeq: b = open_ball X dX c r.
  claim Hx0inBall: x0 :e open_ball X dX c r.
  { rewrite <- Hbeq. exact Hx0b. }
  claim Hexdelta: exists delta:set, delta :e R /\ Rlt 0 delta /\ open_ball X dX x0 delta c= open_ball X dX c r.
  { exact (open_ball_refine_center X dX c x0 r HdX HcX Hx0 HrR Hrpos Hx0inBall). }
  apply Hexdelta.
  let delta. assume Hdelta.
  claim Hdelta12: delta :e R /\ Rlt 0 delta.
  { exact (andEL (delta :e R /\ Rlt 0 delta)
                 (open_ball X dX x0 delta c= open_ball X dX c r)
                 Hdelta). }
  claim HdeltaR: delta :e R.
  { exact (andEL (delta :e R) (Rlt 0 delta) Hdelta12). }
  claim Hdeltapos: Rlt 0 delta.
  { exact (andER (delta :e R) (Rlt 0 delta) Hdelta12). }
  claim Hballsub: open_ball X dX x0 delta c= open_ball X dX c r.
  { exact (andER (delta :e R /\ Rlt 0 delta)
                 (open_ball X dX x0 delta c= open_ball X dX c r)
                 Hdelta). }
  claim HballsubU: open_ball X dX x0 delta c= U.
  { claim Hsubb: open_ball X dX x0 delta c= b.
    { rewrite Hbeq.
      exact Hballsub. }
    exact (Subq_tra (open_ball X dX x0 delta) b U Hsubb HbsubU). }
  witness delta.
  apply andI.
  - apply andI.
    + exact HdeltaR.
    + exact Hdeltapos.
  - let x. assume HxX: x :e X.
    assume Hdx: Rlt (apply_fun dX (x,x0)) delta.
    claim Hsym: apply_fun dX (x0,x) = apply_fun dX (x,x0).
    { exact (metric_on_symmetric X dX x0 x HdX Hx0 HxX). }
    claim Hdx': Rlt (apply_fun dX (x0,x)) delta.
    { rewrite Hsym. exact Hdx. }
    claim HxinBall: x :e open_ball X dX x0 delta.
    { exact (open_ballI X dX x0 delta x HxX Hdx'). }
    claim HxinU: x :e U.
    { exact (HballsubU x HxinBall). }
    claim HfxV: apply_fun f x :e V.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) x HxinU). }
    claim HfxY: apply_fun f x :e Y.
    { exact (Hf x HxX). }
    claim HsymY: apply_fun dY (apply_fun f x, apply_fun f x0) = apply_fun dY (apply_fun f x0, apply_fun f x).
    { exact (metric_on_symmetric Y dY (apply_fun f x) (apply_fun f x0) HdY HfxY Hfx0Y). }
    rewrite HsymY.
    exact (open_ballE2 Y dY (apply_fun f x0) eps (apply_fun f x) HfxV).
- assume Hed: forall x0:set, x0 :e X ->
    forall eps:set, eps :e R /\ Rlt 0 eps ->
      exists delta:set, delta :e R /\ Rlt 0 delta /\
        (forall x:set, x :e X ->
          Rlt (apply_fun dX (x,x0)) delta ->
          Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
  (** Goal: show continuity by checking preimages of open balls. **)
  set Bx := famunion X (fun x0:set => {open_ball X dX x0 r|r :e R, Rlt 0 r}).
  set By := famunion Y (fun y0:set => {open_ball Y dY y0 r|r :e R, Rlt 0 r}).
  claim HTx: topology_on X (metric_topology X dX).
  { exact (metric_topology_is_topology X dX HdX). }
  claim HTy: topology_on Y (metric_topology Y dY).
  { exact (metric_topology_is_topology Y dY HdY). }
  prove continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
  prove ((topology_on X (metric_topology X dX) /\ topology_on Y (metric_topology Y dY)) /\
         function_on f X Y) /\
        (forall V:set, V :e metric_topology Y dY -> preimage_of X f V :e metric_topology X dX).
  apply andI.
  - apply andI.
    + apply andI.
      * exact HTx.
      * exact HTy.
    + exact Hf.
  - let V. assume HV: V :e metric_topology Y dY.
    prove preimage_of X f V :e metric_topology X dX.
    set U := preimage_of X f V.
    prove U :e generated_topology X Bx.
    (** unpack V as element of generated_topology Y By **)
    claim HVgen: V :e generated_topology Y By.
    { exact HV. }
    claim HVinPow: V :e Power Y.
    { exact (SepE1 (Power Y)
                   (fun V0 : set => forall y0 :e V0, exists b :e By, y0 :e b /\ b c= V0)
                   V HVgen). }
    claim HVsubY: V c= Y.
    { exact (PowerE Y V HVinPow). }
    claim HVlocal: forall y0 :e V, exists b :e By, y0 :e b /\ b c= V.
    { exact (SepE2 (Power Y)
                   (fun V0 : set => forall y0 :e V0, exists b :e By, y0 :e b /\ b c= V0)
                   V HVgen). }
    (** show U belongs to Power X **)
    claim HUsubX: U c= X.
    { let x0. assume Hx0U: x0 :e U.
      exact (SepE1 X (fun x:set => apply_fun f x :e V) x0 Hx0U). }
    claim HUinPow: U :e Power X.
    { exact (PowerI X U HUsubX). }
    (** show the defining local-basis predicate for U **)
    claim HUprop: forall x0 :e U, exists b :e Bx, x0 :e b /\ b c= U.
    { let x0. assume Hx0U: x0 :e U.
      claim Hx0X: x0 :e X.
      { exact (SepE1 X (fun x:set => apply_fun f x :e V) x0 Hx0U). }
      claim Hfx0V: apply_fun f x0 :e V.
      { exact (SepE2 X (fun x:set => apply_fun f x :e V) x0 Hx0U). }
      claim Hfx0Y: apply_fun f x0 :e Y.
      { exact (HVsubY (apply_fun f x0) Hfx0V). }
      apply (HVlocal (apply_fun f x0) Hfx0V).
      let bY. assume HbYpair.
      claim HbYBy: bY :e By.
      { exact (andEL (bY :e By) (apply_fun f x0 :e bY /\ bY c= V) HbYpair). }
      claim HbYprop: apply_fun f x0 :e bY /\ bY c= V.
      { exact (andER (bY :e By) (apply_fun f x0 :e bY /\ bY c= V) HbYpair). }
      claim Hfx0bY: apply_fun f x0 :e bY.
      { exact (andEL (apply_fun f x0 :e bY) (bY c= V) HbYprop). }
      claim HbYsubV: bY c= V.
      { exact (andER (apply_fun f x0 :e bY) (bY c= V) HbYprop). }
      (** destruct bY as an open ball around some center **)
      apply (famunionE_impred Y (fun y0:set => {open_ball Y dY y0 r|r :e R, Rlt 0 r}) bY HbYBy
             (exists b :e Bx, x0 :e b /\ b c= U)).
      let c. assume HcY: c :e Y.
      assume HbYIn: bY :e {open_ball Y dY c r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball Y dY c r0) bY HbYIn
             (exists b :e Bx, x0 :e b /\ b c= U)).
      let r. assume HrR: r :e R.
      assume Hrpos: Rlt 0 r.
      assume HbYeq: bY = open_ball Y dY c r.
      claim Hfx0inBall: apply_fun f x0 :e open_ball Y dY c r.
      { rewrite <- HbYeq. exact Hfx0bY. }
      claim Hexeps0: exists eps0:set, eps0 :e R /\ Rlt 0 eps0 /\ open_ball Y dY (apply_fun f x0) eps0 c= open_ball Y dY c r.
      { exact (open_ball_refine_center Y dY c (apply_fun f x0) r HdY HcY Hfx0Y HrR Hrpos Hfx0inBall). }
      apply Hexeps0.
      let eps0. assume Heps0.
      claim Heps0_12: eps0 :e R /\ Rlt 0 eps0.
      { exact (andEL (eps0 :e R /\ Rlt 0 eps0)
                     (open_ball Y dY (apply_fun f x0) eps0 c= open_ball Y dY c r)
                     Heps0). }
      claim Heps0R: eps0 :e R.
      { exact (andEL (eps0 :e R) (Rlt 0 eps0) Heps0_12). }
      claim Heps0pos: Rlt 0 eps0.
      { exact (andER (eps0 :e R) (Rlt 0 eps0) Heps0_12). }
      claim HballYsub: open_ball Y dY (apply_fun f x0) eps0 c= open_ball Y dY c r.
      { exact (andER (eps0 :e R /\ Rlt 0 eps0)
                     (open_ball Y dY (apply_fun f x0) eps0 c= open_ball Y dY c r)
                     Heps0). }
      claim HballYsubV: open_ball Y dY (apply_fun f x0) eps0 c= V.
      { claim HsubbY: open_ball Y dY (apply_fun f x0) eps0 c= bY.
        { rewrite HbYeq.
          exact HballYsub. }
        exact (Subq_tra (open_ball Y dY (apply_fun f x0) eps0) bY V HsubbY HbYsubV). }
      (** apply epsilon-delta hypothesis at x0 with eps0 **)
      apply (Hed x0 Hx0X eps0 (andI (eps0 :e R) (Rlt 0 eps0) Heps0R Heps0pos)).
      let delta. assume Hdelta.
      claim Hdelta12: delta :e R /\ Rlt 0 delta.
      { exact (andEL (delta :e R /\ Rlt 0 delta)
                     (forall x:set, x :e X ->
                       Rlt (apply_fun dX (x,x0)) delta ->
                       Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps0)
                     Hdelta). }
      claim HdeltaR: delta :e R.
      { exact (andEL (delta :e R) (Rlt 0 delta) Hdelta12). }
      claim Hdeltapos: Rlt 0 delta.
      { exact (andER (delta :e R) (Rlt 0 delta) Hdelta12). }
      claim HdeltaImp: forall x:set, x :e X ->
        Rlt (apply_fun dX (x,x0)) delta ->
        Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps0.
      { exact (andER (delta :e R /\ Rlt 0 delta)
                     (forall x:set, x :e X ->
                       Rlt (apply_fun dX (x,x0)) delta ->
                       Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps0)
                     Hdelta). }
      (** choose b = open_ball centered at x0 with radius delta **)
      witness (open_ball X dX x0 delta).
      apply andI.
      - (** membership in Bx **)
        claim HballIn: open_ball X dX x0 delta :e {open_ball X dX x0 r|r :e R, Rlt 0 r}.
        { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X dX x0 r0) delta HdeltaR Hdeltapos). }
        exact (famunionI X (fun x1:set => {open_ball X dX x1 r|r :e R, Rlt 0 r}) x0 (open_ball X dX x0 delta) Hx0X HballIn).
      - apply andI.
        + (** x0 in its delta-ball **)
          exact (center_in_open_ball X dX x0 delta HdX Hx0X Hdeltapos).
        + (** delta-ball subset U **)
          let x. assume Hxin: x :e open_ball X dX x0 delta.
          claim HxX: x :e X.
          { exact (open_ballE1 X dX x0 delta x Hxin). }
          claim HsymX: apply_fun dX (x,x0) = apply_fun dX (x0,x).
          { exact (metric_on_symmetric X dX x x0 HdX HxX Hx0X). }
          claim Hdx0x: Rlt (apply_fun dX (x0,x)) delta.
          { exact (open_ballE2 X dX x0 delta x Hxin). }
          claim Hdx: Rlt (apply_fun dX (x,x0)) delta.
          { rewrite HsymX. exact Hdx0x. }
          claim HfyY: apply_fun f x :e Y.
          { exact (Hf x HxX). }
          claim Hdy: Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps0.
          { exact (HdeltaImp x HxX Hdx). }
          claim HsymY: apply_fun dY (apply_fun f x0, apply_fun f x) = apply_fun dY (apply_fun f x, apply_fun f x0).
          { exact (metric_on_symmetric Y dY (apply_fun f x0) (apply_fun f x) HdY Hfx0Y HfyY). }
          claim Hdy': Rlt (apply_fun dY (apply_fun f x0, apply_fun f x)) eps0.
          { rewrite HsymY. exact Hdy. }
          claim HfxBall: apply_fun f x :e open_ball Y dY (apply_fun f x0) eps0.
          { exact (open_ballI Y dY (apply_fun f x0) eps0 (apply_fun f x) HfyY Hdy'). }
          claim HfxV: apply_fun f x :e V.
          { exact (HballYsubV (apply_fun f x) HfxBall). }
          exact (SepI X (fun x1:set => apply_fun f x1 :e V) x HxX HfxV).
    }
    exact (SepI (Power X)
                (fun U0:set => forall x0 :e U0, exists b :e Bx, x0 :e b /\ b c= U0)
                U HUinPow HUprop).
Qed.

(** from §17: convergent sequences **)
(** LATEX VERSION: A sequence x1,x2,... in X converges to x if for each neighborhood U of x there is N such that x_n is in U for all n >= N. **)
(** sequences as functions from omega **)
Definition sequence_in : set -> set -> prop := fun seq A => function_on seq omega A.

(** from §17: convergent sequences **)
(** LATEX VERSION: A sequence is a function from the positive integers (modeled here by omega) into the space. **)
Definition sequence_on : set -> set -> prop := fun seq A => function_on seq omega A.

(** helper: apply_fun for a graph under definitional equality **)
Theorem apply_fun_of_graph_eq : forall f A:set, forall g:set->set, forall a:set,
  f = graph A g -> a :e A -> apply_fun f a = g a.
let f A g a.
assume Hf: f = graph A g.
assume Ha: a :e A.
rewrite Hf.
exact (apply_fun_graph A g a Ha).
Qed.

(** from §17: definition of convergence of a sequence **)
(** LATEX VERSION: The neighborhood definition of convergence: eventually the sequence lies in every neighborhood of the limit point. **)
Definition converges_to : set -> set -> set -> set -> prop :=
  fun X Tx seq x =>
    topology_on X Tx /\ sequence_on seq X /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.

(** Helper: extract topology_on from converges_to **)
Theorem converges_to_topology : forall X Tx seq x:set,
  converges_to X Tx seq x -> topology_on X Tx.
let X Tx seq x.
assume H: converges_to X Tx seq x.
claim H123: (topology_on X Tx /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
               (forall U:set, U :e Tx -> x :e U ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
               H). }
claim H12: topology_on X Tx /\ sequence_on seq X.
{ exact (andEL (topology_on X Tx /\ sequence_on seq X) (x :e X) H123). }
exact (andEL (topology_on X Tx) (sequence_on seq X) H12).
Qed.

(** Helper: extract sequence_on from converges_to **)
Theorem converges_to_sequence_on : forall X Tx seq x:set,
  converges_to X Tx seq x -> sequence_on seq X.
let X Tx seq x.
assume H: converges_to X Tx seq x.
claim H123: (topology_on X Tx /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
               (forall U:set, U :e Tx -> x :e U ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
               H). }
claim H12: topology_on X Tx /\ sequence_on seq X.
{ exact (andEL (topology_on X Tx /\ sequence_on seq X) (x :e X) H123). }
exact (andER (topology_on X Tx) (sequence_on seq X) H12).
Qed.

(** Helper: extract x in X from converges_to **)
Theorem converges_to_point_in_X : forall X Tx seq x:set,
  converges_to X Tx seq x -> x :e X.
let X Tx seq x.
assume H: converges_to X Tx seq x.
claim H123: (topology_on X Tx /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
               (forall U:set, U :e Tx -> x :e U ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
               H). }
exact (andER (topology_on X Tx /\ sequence_on seq X) (x :e X) H123).
Qed.

(** Helper: extract neighborhood condition from converges_to **)
Theorem converges_to_neighborhoods : forall X Tx seq x:set,
  converges_to X Tx seq x ->
  forall U:set, U :e Tx -> x :e U ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
let X Tx seq x.
assume H: converges_to X Tx seq x.
exact (andER ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
             (forall U:set, U :e Tx -> x :e U ->
               exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
             H).
Qed.
(** from §18: sequences and continuous functions **)
(** LATEX VERSION: If f is a function and (x_n) a sequence, then (f(x_n)) is the composed sequence. **)
(** map a sequence seq by a function f, giving the composed sequence n -> f(seq(n)) **)
Definition map_sequence : set -> set -> set := fun f seq => compose_fun omega seq f.

(** from §18: image of a set under a function **)
(** LATEX VERSION: The image f(U) consists of all points f(x) with x in U. **)
(** image of a set U under a function f **)
Definition image_of : set -> set -> set := fun f U => Repl U (fun x => apply_fun f x).

(** from §21: sequences of functions **)
(** LATEX VERSION: For a sequence of functions f_n and a point x, the value is f_n(x). **)
Definition function_sequence_value : set -> set -> set -> set :=
  fun f_seq n x => apply_fun (apply_fun f_seq n) x.

(** Helper: image is monotone under inclusion **)
(** LATEX VERSION: If U subset V then f(U) subset f(V). **)
Theorem image_of_mono : forall f U V:set,
  U c= V ->
  image_of f U c= image_of f V.
let f U V.
assume HUV: U c= V.
let y. assume Hy: y :e image_of f U.
prove y :e image_of f V.
apply (ReplE_impred U (fun x:set => apply_fun f x) y Hy).
let x. assume HxU: x :e U.
assume Hyx: y = apply_fun f x.
claim HxV: x :e V.
{ exact (HUV x HxU). }
rewrite Hyx.
exact (ReplI V (fun x0:set => apply_fun f x0) x HxV).
Qed.

(** Helper: image under a function_on map stays in the codomain **)
(** LATEX VERSION: If f maps X to Y and U subset X then f(U) subset Y. **)
Theorem image_of_sub_codomain : forall f X Y U:set,
  function_on f X Y ->
  U c= X ->
  image_of f U c= Y.
let f X Y U.
assume Hfun: function_on f X Y.
assume HUX: U c= X.
let y. assume Hy: y :e image_of f U.
prove y :e Y.
apply (ReplE_impred U (fun x:set => apply_fun f x) y Hy).
let x. assume HxU: x :e U.
assume Hyx: y = apply_fun f x.
claim HxX: x :e X.
{ exact (HUX x HxU). }
claim HfxY: apply_fun f x :e Y.
{ exact (Hfun x HxX). }
rewrite Hyx.
exact HfxY.
Qed.

(** Helper: image of Empty **)
(** LATEX VERSION: f(Empty) = Empty. **)
Theorem image_of_Empty : forall f:set,
  image_of f Empty = Empty.
let f.
apply set_ext.
- let y. assume Hy: y :e image_of f Empty.
  apply (ReplE_impred Empty (fun x:set => apply_fun f x) y Hy).
  let x. assume HxE: x :e Empty.
  assume Hyx: y = apply_fun f x.
  apply FalseE.
  exact ((EmptyE x) HxE).
- let y. assume Hy: y :e Empty.
  apply FalseE.
  exact ((EmptyE y) Hy).
Qed.

(** Helper: image of binary union **)
(** LATEX VERSION: f(U union V) = f(U) union f(V). **)
Theorem image_of_binunion : forall f U V:set,
  image_of f (U :\/: V) = (image_of f U) :\/: (image_of f V).
let f U V.
apply set_ext.
- let y. assume Hy: y :e image_of f (U :\/: V).
  prove y :e (image_of f U) :\/: (image_of f V).
  apply (ReplE_impred (U :\/: V) (fun x:set => apply_fun f x) y Hy).
  let x. assume HxUV: x :e U :\/: V.
  assume Hyx: y = apply_fun f x.
  apply (binunionE U V x HxUV).
  * assume HxU: x :e U.
    rewrite Hyx.
    apply binunionI1.
    exact (ReplI U (fun x0:set => apply_fun f x0) x HxU).
  * assume HxV: x :e V.
    rewrite Hyx.
    apply binunionI2.
    exact (ReplI V (fun x0:set => apply_fun f x0) x HxV).
- let y. assume Hy: y :e (image_of f U) :\/: (image_of f V).
  prove y :e image_of f (U :\/: V).
  apply (binunionE (image_of f U) (image_of f V) y Hy).
	  * assume HyU: y :e image_of f U.
	    apply (ReplE_impred U (fun x:set => apply_fun f x) y HyU).
	    let x. assume HxU: x :e U.
	    assume Hyx: y = apply_fun f x.
	    rewrite Hyx.
	    exact (ReplI (U :\/: V) (fun x0:set => apply_fun f x0) x (binunionI1 U V x HxU)).
	  * assume HyV: y :e image_of f V.
	    apply (ReplE_impred V (fun x:set => apply_fun f x) y HyV).
	    let x. assume HxV: x :e V.
	    assume Hyx: y = apply_fun f x.
	    rewrite Hyx.
	    exact (ReplI (U :\/: V) (fun x0:set => apply_fun f x0) x (binunionI2 U V x HxV)).
Qed.

(** Helper: image of union of a family **)
(** LATEX VERSION: f(Union Fam) equals Union of images f(U) for U in Fam. **)
Theorem image_of_Union : forall f Fam:set,
  image_of f (Union Fam) = Union {image_of f U|U :e Fam}.
let f Fam.
apply set_ext.
- let y. assume Hy: y :e image_of f (Union Fam).
  prove y :e Union {image_of f U|U :e Fam}.
  apply (ReplE_impred (Union Fam) (fun x:set => apply_fun f x) y Hy).
  let x. assume HxU: x :e Union Fam.
  assume Hyx: y = apply_fun f x.
  apply (UnionE_impred Fam x HxU).
  let U. assume HxUin: x :e U.
  assume HUFam: U :e Fam.
  claim HyImU: y :e image_of f U.
  { rewrite Hyx.
    exact (ReplI U (fun x0:set => apply_fun f x0) x HxUin). }
  exact (UnionI {image_of f U0|U0 :e Fam} y (image_of f U) HyImU
                (ReplI Fam (fun U0:set => image_of f U0) U HUFam)).
- let y. assume Hy: y :e Union {image_of f U|U :e Fam}.
  prove y :e image_of f (Union Fam).
  apply (UnionE_impred {image_of f U|U :e Fam} y Hy).
  let W. assume HyW: y :e W.
  assume HW: W :e {image_of f U|U :e Fam}.
  apply (ReplE_impred Fam (fun U0:set => image_of f U0) W HW).
  let U. assume HUFam: U :e Fam.
  assume HWU: W = image_of f U.
  claim HyImU: y :e image_of f U.
  { rewrite <- HWU.
    exact HyW. }
  apply (ReplE_impred U (fun x:set => apply_fun f x) y HyImU).
  let x. assume HxU: x :e U.
  assume Hyx: y = apply_fun f x.
  rewrite Hyx.
  exact (ReplI (Union Fam) (fun x0:set => apply_fun f x0) x (UnionI Fam x U HxU HUFam)).
Qed.

(** Helper: image of a set under composition **)
(** LATEX VERSION: If U subset X then (g o f)(U) equals g(f(U)). **)
Theorem image_of_compose_fun : forall X f g U:set,
  U c= X ->
  image_of (compose_fun X f g) U = image_of g (image_of f U).
let X f g U.
assume HUX: U c= X.
apply set_ext.
- let y. assume Hy: y :e image_of (compose_fun X f g) U.
  prove y :e image_of g (image_of f U).
  apply (ReplE_impred U (fun x:set => apply_fun (compose_fun X f g) x) y Hy).
  let x. assume HxU: x :e U.
  assume Hyx: y = apply_fun (compose_fun X f g) x.
  claim HxX: x :e X.
  { exact (HUX x HxU). }
  claim Hcomp: apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
  { exact (compose_fun_apply X f g x HxX). }
  claim Hycomp: y = apply_fun g (apply_fun f x).
  { rewrite Hyx.
    rewrite Hcomp.
    reflexivity. }
  claim HfxIm: apply_fun f x :e image_of f U.
  { exact (ReplI U (fun x0:set => apply_fun f x0) x HxU). }
  rewrite Hycomp.
  exact (ReplI (image_of f U) (fun u:set => apply_fun g u) (apply_fun f x) HfxIm).
- let y. assume Hy: y :e image_of g (image_of f U).
  prove y :e image_of (compose_fun X f g) U.
  apply (ReplE_impred (image_of f U) (fun u:set => apply_fun g u) y Hy).
  let u. assume Hu: u :e image_of f U.
  assume Hyu: y = apply_fun g u.
  apply (ReplE_impred U (fun x:set => apply_fun f x) u Hu).
  let x. assume HxU: x :e U.
  assume Hux: u = apply_fun f x.
  claim HxX: x :e X.
  { exact (HUX x HxU). }
  claim Hcomp: apply_fun (compose_fun X f g) x = apply_fun g (apply_fun f x).
  { exact (compose_fun_apply X f g x HxX). }
  claim Hycomp: y = apply_fun (compose_fun X f g) x.
  { rewrite Hyu.
    rewrite Hux.
    rewrite <- Hcomp.
    reflexivity. }
  rewrite Hycomp.
  exact (ReplI U (fun x0:set => apply_fun (compose_fun X f g) x0) x HxU).
Qed.

(** from §21: convergence in metric spaces **)
(** LATEX VERSION: In a metric space, a sequence converges to x if for every eps>0 there exists N such that d(x_n,x) < eps for all n >= N. **)
(** FIXED: Removed extra parentheses around pair argument to d metric. **)
Definition sequence_converges_metric : set -> set -> set -> set -> prop :=
  fun X d seq x =>
    metric_on X d /\ sequence_on seq X /\ x :e X /\
    forall eps:set, eps :e R /\ Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n ->
          Rlt (apply_fun d (apply_fun seq n, x)) eps.

(** Helper: extract metric_on from sequence_converges_metric **)
Theorem sequence_converges_metric_metric_on : forall X d seq x:set,
  sequence_converges_metric X d seq x -> metric_on X d.
let X d seq x.
assume H: sequence_converges_metric X d seq x.
claim H123: (metric_on X d /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((metric_on X d /\ sequence_on seq X) /\ x :e X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq n, x)) eps)
               H). }
claim H12: metric_on X d /\ sequence_on seq X.
{ exact (andEL (metric_on X d /\ sequence_on seq X) (x :e X) H123). }
exact (andEL (metric_on X d) (sequence_on seq X) H12).
Qed.

(** Helper: extract sequence_on from sequence_converges_metric **)
Theorem sequence_converges_metric_sequence_on : forall X d seq x:set,
  sequence_converges_metric X d seq x -> sequence_on seq X.
let X d seq x.
assume H: sequence_converges_metric X d seq x.
claim H123: (metric_on X d /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((metric_on X d /\ sequence_on seq X) /\ x :e X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq n, x)) eps)
               H). }
claim H12: metric_on X d /\ sequence_on seq X.
{ exact (andEL (metric_on X d /\ sequence_on seq X) (x :e X) H123). }
exact (andER (metric_on X d) (sequence_on seq X) H12).
Qed.

(** Helper: extract x in X from sequence_converges_metric **)
Theorem sequence_converges_metric_point_in_X : forall X d seq x:set,
  sequence_converges_metric X d seq x -> x :e X.
let X d seq x.
assume H: sequence_converges_metric X d seq x.
claim H123: (metric_on X d /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((metric_on X d /\ sequence_on seq X) /\ x :e X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq n, x)) eps)
               H). }
exact (andER (metric_on X d /\ sequence_on seq X) (x :e X) H123).
Qed.

(** Helper: extract the eps condition from sequence_converges_metric **)
Theorem sequence_converges_metric_eps : forall X d seq x:set,
  sequence_converges_metric X d seq x ->
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n ->
        Rlt (apply_fun d (apply_fun seq n, x)) eps.
let X d seq x.
assume H: sequence_converges_metric X d seq x.
exact (andER ((metric_on X d /\ sequence_on seq X) /\ x :e X)
             (forall eps:set, eps :e R /\ Rlt 0 eps ->
               exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n ->
                   Rlt (apply_fun d (apply_fun seq n, x)) eps)
             H).
Qed.

(** from §21: uniqueness of limits in metric spaces **) 
(** LATEX VERSION: In a metric space, a convergent sequence has at most one limit. **)
(** helper: function evaluation as graph lookup **) 
Theorem metric_limits_unique : forall X d seq x y:set,
  metric_on X d ->
  sequence_on seq X ->
  sequence_converges_metric X d seq x ->
  sequence_converges_metric X d seq y ->
  x = y.
let X d seq x y.
assume Hd: metric_on X d.
assume Hseq: sequence_on seq X.
assume Hx: sequence_converges_metric X d seq x.
assume Hy: sequence_converges_metric X d seq y.
prove x = y.
apply xm (x = y).
- exact (fun H => H).
- assume Hneq: ~(x = y).
  prove False.
  claim HxX: x :e X.
  { exact (sequence_converges_metric_point_in_X X d seq x Hx). }
  claim HyX: y :e X.
  { exact (sequence_converges_metric_point_in_X X d seq y Hy). }
  claim Hfun: function_on d (setprod X X) R.
  { exact (metric_on_function_on X d Hd). }
  claim HxyIn: (x,y) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
  claim HdxyR: apply_fun d (x,y) :e R.
  { exact (Hfun (x,y) HxyIn). }
  claim HdxyS: SNo (apply_fun d (x,y)).
  { exact (real_SNo (apply_fun d (x,y)) HdxyR). }
  claim HdxyNe0: ~(apply_fun d (x,y) = 0).
  { assume H0: apply_fun d (x,y) = 0.
    apply Hneq.
    exact (metric_on_zero_eq X d x y Hd HxX HyX H0). }
  claim HdxyPos: Rlt 0 (apply_fun d (x,y)).
  { apply (SNoLt_trichotomy_or_impred 0 (apply_fun d (x,y)) SNo_0 HdxyS
           (Rlt 0 (apply_fun d (x,y)))).
    - assume H0lt: 0 < apply_fun d (x,y).
      exact (RltI 0 (apply_fun d (x,y)) real_0 HdxyR H0lt).
    - assume Heq: 0 = apply_fun d (x,y).
      prove False.
      claim H0eq: apply_fun d (x,y) = 0.
      { rewrite <- Heq. reflexivity. }
      exact (HdxyNe0 H0eq).
    - assume Hlt0: apply_fun d (x,y) < 0.
      prove False.
      claim HltR: Rlt (apply_fun d (x,y)) 0.
      { exact (RltI (apply_fun d (x,y)) 0 HdxyR real_0 Hlt0). }
      exact ((metric_on_nonneg X d x y Hd HxX HyX) HltR). }
  claim HexN: exists N :e omega, eps_ N < apply_fun d (x,y).
  { exact (exists_eps_lt_pos (apply_fun d (x,y)) HdxyR HdxyPos). }
  apply HexN.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < apply_fun d (x,y)) HNpair). }
  claim HepsNlt: eps_ N < apply_fun d (x,y).
  { exact (andER (N :e omega) (eps_ N < apply_fun d (x,y)) HNpair). }
  claim HNnat: nat_p N.
  { exact (omega_nat_p N HNomega). }
  claim HsuccOmega: ordsucc N :e omega.
  { exact (omega_ordsucc N HNomega). }
  claim HepsR: eps_ (ordsucc N) :e R.
  { exact (SNoS_omega_real (eps_ (ordsucc N))
           (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
  claim HepsS: SNo (eps_ (ordsucc N)).
  { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
  claim H0lt_eps: 0 < eps_ (ordsucc N).
  { exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
  claim HepsPos: Rlt 0 (eps_ (ordsucc N)).
  { exact (RltI 0 (eps_ (ordsucc N)) real_0 HepsR H0lt_eps). }
  claim HexNx: exists Nx:set, Nx :e omega /\
    forall n:set, n :e omega -> Nx c= n ->
      Rlt (apply_fun d (apply_fun seq n, x)) (eps_ (ordsucc N)).
  { exact (sequence_converges_metric_eps X d seq x Hx (eps_ (ordsucc N))
           (andI (eps_ (ordsucc N) :e R) (Rlt 0 (eps_ (ordsucc N))) HepsR HepsPos)). }
  claim HexNy: exists Ny:set, Ny :e omega /\
    forall n:set, n :e omega -> Ny c= n ->
      Rlt (apply_fun d (apply_fun seq n, y)) (eps_ (ordsucc N)).
  { exact (sequence_converges_metric_eps X d seq y Hy (eps_ (ordsucc N))
           (andI (eps_ (ordsucc N) :e R) (Rlt 0 (eps_ (ordsucc N))) HepsR HepsPos)). }
  apply HexNx.
  let Nx. assume HNxpair.
  apply HexNy.
  let Ny. assume HNypair.
  claim HNxomega: Nx :e omega.
  { exact (andEL (Nx :e omega)
                 (forall n:set, n :e omega -> Nx c= n ->
                   Rlt (apply_fun d (apply_fun seq n, x)) (eps_ (ordsucc N)))
                 HNxpair). }
  claim HNxprop: forall n:set, n :e omega -> Nx c= n ->
    Rlt (apply_fun d (apply_fun seq n, x)) (eps_ (ordsucc N)).
  { exact (andER (Nx :e omega)
                 (forall n:set, n :e omega -> Nx c= n ->
                   Rlt (apply_fun d (apply_fun seq n, x)) (eps_ (ordsucc N)))
                 HNxpair). }
  claim HNyomega: Ny :e omega.
  { exact (andEL (Ny :e omega)
                 (forall n:set, n :e omega -> Ny c= n ->
                   Rlt (apply_fun d (apply_fun seq n, y)) (eps_ (ordsucc N)))
                 HNypair). }
  claim HNyprop: forall n:set, n :e omega -> Ny c= n ->
    Rlt (apply_fun d (apply_fun seq n, y)) (eps_ (ordsucc N)).
  { exact (andER (Ny :e omega)
                 (forall n:set, n :e omega -> Ny c= n ->
                   Rlt (apply_fun d (apply_fun seq n, y)) (eps_ (ordsucc N)))
                 HNypair). }
  set n0 := Nx :\/: Ny.
  claim Hn0omega: n0 :e omega.
  { exact (omega_binunion Nx Ny HNxomega HNyomega). }
  claim HNxsub: Nx c= n0.
  { exact (binunion_Subq_1 Nx Ny). }
  claim HNysub: Ny c= n0.
  { exact (binunion_Subq_2 Nx Ny). }
  claim Hdx0: Rlt (apply_fun d (apply_fun seq n0, x)) (eps_ (ordsucc N)).
  { exact (HNxprop n0 Hn0omega HNxsub). }
  claim Hdy0: Rlt (apply_fun d (apply_fun seq n0, y)) (eps_ (ordsucc N)).
  { exact (HNyprop n0 Hn0omega HNysub). }
  claim Hseqfun: function_on seq omega X.
  { exact Hseq. }
  claim Hseqn0X: apply_fun seq n0 :e X.
  { exact (Hseqfun n0 Hn0omega). }
  claim HsymX: apply_fun d (x, apply_fun seq n0) = apply_fun d (apply_fun seq n0, x).
  { exact (metric_on_symmetric X d x (apply_fun seq n0) Hd HxX Hseqn0X). }
  claim Hdx: Rlt (apply_fun d (x, apply_fun seq n0)) (eps_ (ordsucc N)).
  { rewrite HsymX. exact Hdx0. }
  set a := apply_fun d (x, apply_fun seq n0).
  set b := apply_fun d (apply_fun seq n0, y).
  claim Hxn0In: (x, apply_fun seq n0) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x (apply_fun seq n0) HxX Hseqn0X). }
  claim Hn0yIn: (apply_fun seq n0, y) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq n0) y Hseqn0X HyX). }
  claim HaR: a :e R.
  { exact (Hfun (x, apply_fun seq n0) Hxn0In). }
  claim HbR: b :e R.
  { exact (Hfun (apply_fun seq n0, y) Hn0yIn). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim Haxlt: a < eps_ (ordsucc N).
  { exact (RltE_lt a (eps_ (ordsucc N)) Hdx). }
  claim Hbylt: b < eps_ (ordsucc N).
  { exact (RltE_lt b (eps_ (ordsucc N)) Hdy0). }
  claim Hstep1: add_SNo a b < add_SNo a (eps_ (ordsucc N)).
  { exact (add_SNo_Lt2 a b (eps_ (ordsucc N)) HaS HbS HepsS Hbylt). }
  claim Hstep2raw: add_SNo (eps_ (ordsucc N)) a < add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)).
  { exact (add_SNo_Lt2 (eps_ (ordsucc N)) a (eps_ (ordsucc N)) HepsS HaS HepsS Haxlt). }
  claim Hcom: add_SNo (eps_ (ordsucc N)) a = add_SNo a (eps_ (ordsucc N)).
  { exact (add_SNo_com (eps_ (ordsucc N)) a HepsS HaS). }
  claim Hstep2: add_SNo a (eps_ (ordsucc N)) < add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)).
  { rewrite <- Hcom at 1.
    exact Hstep2raw. }
  claim Hsumlt_eps2: add_SNo a b < add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)).
  { exact (SNoLt_tra (add_SNo a b) (add_SNo a (eps_ (ordsucc N)))
           (add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)))
           (SNo_add_SNo a b HaS HbS)
           (SNo_add_SNo a (eps_ (ordsucc N)) HaS HepsS)
           (SNo_add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)) HepsS HepsS)
           Hstep1 Hstep2). }
  claim HepsHalf: add_SNo (eps_ (ordsucc N)) (eps_ (ordsucc N)) = eps_ N.
  { exact (eps_ordsucc_half_add N HNnat). }
  claim HsumS: SNo (add_SNo a b).
  { exact (SNo_add_SNo a b HaS HbS). }
  claim HepsNR: eps_ N :e R.
  { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
  claim HepsNS: SNo (eps_ N).
  { exact (real_SNo (eps_ N) HepsNR). }
  claim Hsumlt_epsN: add_SNo a b < eps_ N.
  { rewrite <- HepsHalf.
    exact Hsumlt_eps2. }
  claim Hsumlt_dxy: add_SNo a b < apply_fun d (x,y).
  { exact (SNoLt_tra (add_SNo a b) (eps_ N) (apply_fun d (x,y))
           HsumS HepsNS HdxyS Hsumlt_epsN HepsNlt). }
  claim HsumR: add_SNo a b :e R.
  { exact (real_add_SNo a HaR b HbR). }
  claim HsumltR: Rlt (add_SNo a b) (apply_fun d (x,y)).
  { exact (RltI (add_SNo a b) (apply_fun d (x,y)) HsumR HdxyR Hsumlt_dxy). }
  claim Htri: ~(Rlt (add_SNo a b) (apply_fun d (x,y))).
  { exact (metric_on_triangle X d x (apply_fun seq n0) y Hd HxX Hseqn0X HyX). }
  exact (Htri HsumltR).
Qed.

(** from §21: uniform convergence of sequences of functions **)
(** LATEX VERSION: A sequence of functions f_n:X->Y converges uniformly to f if for each eps>0 there exists N such that d_Y(f_n(x),f(x)) < eps for all n>=N and all x in X. **)
(** uniform convergence of function sequences between metric spaces **)
Definition uniform_convergence_functions :
  set -> set -> set -> set -> set -> set -> prop :=
  fun X dX Y dY f_seq f =>
    metric_on X dX /\ metric_on Y dY /\
    function_on f_seq omega (function_space X Y) /\ function_on f X Y /\
    (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y) /\
(** FIXED: Removed extra parentheses around pair argument to dY metric. **)
    forall eps:set, eps :e R /\ Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n ->
          forall x:set, x :e X ->
            Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps.

(** Helper: extract metric_on X dX from uniform_convergence_functions **)
Theorem uniform_convergence_functions_metric_on_X : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f -> metric_on X dX.
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
claim HABCDE: ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y) /\
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)).
{ exact (andEL ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                  function_on f X Y) /\
                 (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     forall x:set, x :e X ->
                       Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
               H). }
claim HABCD: (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
              function_on f X Y).
{ exact (andEL (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y)
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)
               HABCDE). }
claim HAB: metric_on X dX /\ metric_on Y dY.
{ exact (andEL (metric_on X dX /\ metric_on Y dY)
               (function_on f_seq omega (function_space X Y))
               (andEL (metric_on X dX /\ metric_on Y dY /\ function_on f_seq omega (function_space X Y))
                      (function_on f X Y)
                      HABCD)). }
exact (andEL (metric_on X dX) (metric_on Y dY) HAB).
Qed.

(** Helper: extract metric_on Y dY from uniform_convergence_functions **)
Theorem uniform_convergence_functions_metric_on_Y : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f -> metric_on Y dY.
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
claim HABCDE: ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y) /\
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)).
{ exact (andEL ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                  function_on f X Y) /\
                 (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     forall x:set, x :e X ->
                       Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
               H). }
claim HABCD: (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
              function_on f X Y).
{ exact (andEL (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y)
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)
               HABCDE). }
claim HAB: metric_on X dX /\ metric_on Y dY.
{ exact (andEL (metric_on X dX /\ metric_on Y dY)
               (function_on f_seq omega (function_space X Y))
               (andEL (metric_on X dX /\ metric_on Y dY /\ function_on f_seq omega (function_space X Y))
                      (function_on f X Y)
                      HABCD)). }
exact (andER (metric_on X dX) (metric_on Y dY) HAB).
Qed.

(** Helper: extract function_on f_seq omega (function_space X Y) from uniform_convergence_functions **)
Theorem uniform_convergence_functions_fseq : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f ->
  function_on f_seq omega (function_space X Y).
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
claim HABCDE: ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y) /\
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)).
{ exact (andEL ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                  function_on f X Y) /\
                 (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     forall x:set, x :e X ->
                       Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
               H). }
claim HABCD: (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
              function_on f X Y).
{ exact (andEL (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y)
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)
               HABCDE). }
exact (andER (metric_on X dX /\ metric_on Y dY)
             (function_on f_seq omega (function_space X Y))
             (andEL (metric_on X dX /\ metric_on Y dY /\ function_on f_seq omega (function_space X Y))
                    (function_on f X Y)
                    HABCD)).
Qed.

(** Helper: extract function_on f X Y from uniform_convergence_functions **)
Theorem uniform_convergence_functions_f : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f -> function_on f X Y.
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
claim HABCDE: ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y) /\
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)).
{ exact (andEL ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                  function_on f X Y) /\
                 (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     forall x:set, x :e X ->
                       Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
               H). }
claim HABCD: (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
              function_on f X Y).
{ exact (andEL (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y)
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)
               HABCDE). }
exact (andER ((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y))
             (function_on f X Y)
             HABCD).
Qed.

(** Helper: extract pointwise function_on for f_seq n from uniform_convergence_functions **)
Theorem uniform_convergence_functions_pointwise : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f ->
  forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y.
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
claim HABCDE: ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                function_on f X Y) /\
               (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)).
{ exact (andEL ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
                  function_on f X Y) /\
                 (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n ->
                     forall x:set, x :e X ->
                       Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
               H). }
exact (andER (((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
              function_on f X Y)
             (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y)
             HABCDE).
Qed.

(** Helper: extract the eps condition from uniform_convergence_functions **)
Theorem uniform_convergence_functions_eps : forall X dX Y dY f_seq f:set,
  uniform_convergence_functions X dX Y dY f_seq f ->
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n ->
        forall x:set, x :e X ->
          Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps.
let X dX Y dY f_seq f.
assume H: uniform_convergence_functions X dX Y dY f_seq f.
exact (andER ((((metric_on X dX /\ metric_on Y dY) /\ function_on f_seq omega (function_space X Y)) /\
               function_on f X Y) /\
              (forall n:set, n :e omega -> function_on (apply_fun f_seq n) X Y))
             (forall eps:set, eps :e R /\ Rlt 0 eps ->
               exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n ->
                   forall x:set, x :e X ->
                     Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eps)
             H).
Qed.

(** helper: transitivity of Rle **) 
Theorem Rle_tra : forall a b c:set, Rle a b -> Rle b c -> Rle a c.
let a b c.
assume Hab: Rle a b.
assume Hbc: Rle b c.
apply (RleI a c (RleE_left a b Hab) (RleE_right b c Hbc)).
assume Hca: Rlt c a.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HcR: c :e R.
{ exact (RltE_left c a Hca). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim Hncb: ~(Rlt c b).
{ exact (RleE_nlt b c Hbc). }
apply (SNoLt_trichotomy_or_impred c b HcS HbS False).
- assume Hcltb: c < b.
  prove False.
  claim Hcb: Rlt c b.
  { exact (RltI c b HcR HbR Hcltb). }
  exact (Hncb Hcb).
- assume Hceq: c = b.
  prove False.
  claim Hba: Rlt b a.
  { rewrite <- Hceq. exact Hca. }
  exact ((RleE_nlt a b Hab) Hba).
- assume Hbltc: b < c.
  prove False.
  claim HcaS: c < a.
  { exact (RltE_lt c a Hca). }
  claim Hbalt: b < a.
  { exact (SNoLt_tra b c a HbS HcS HaS Hbltc HcaS). }
  claim Hba: Rlt b a.
  { exact (RltI b a HbR HaR Hbalt). }
  exact ((RleE_nlt a b Hab) Hba).
Qed.

(** helper: monotonicity of add_SNo in Rle form (right argument) **) 
Theorem Rle_add_SNo_2 : forall x y z:set,
  x :e R -> y :e R -> z :e R ->
  Rle y z -> Rle (add_SNo x y) (add_SNo x z).
let x y z.
assume HxR: x :e R.
assume HyR: y :e R.
assume HzR: z :e R.
assume Hyz: Rle y z.
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HzS: SNo z.
{ exact (real_SNo z HzR). }
claim HxyR: add_SNo x y :e R.
{ exact (real_add_SNo x HxR y HyR). }
claim HxzR: add_SNo x z :e R.
{ exact (real_add_SNo x HxR z HzR). }
apply (RleI (add_SNo x y) (add_SNo x z) HxyR HxzR).
assume Hlt: Rlt (add_SNo x z) (add_SNo x y).
claim HltS: add_SNo x z < add_SNo x y.
{ exact (RltE_lt (add_SNo x z) (add_SNo x y) Hlt). }
claim Hzly: z < y.
{ exact (add_SNo_Lt2_cancel x z y HxS HzS HyS HltS). }
claim Hzy: Rlt z y.
{ exact (RltI z y HzR HyR Hzly). }
exact ((RleE_nlt y z Hyz) Hzy).
Qed.

(** from §21: uniform limit theorem placeholder **) 
(** LATEX VERSION: Uniform limit of continuous functions between metric spaces is continuous. **)
Theorem uniform_limit_of_continuous_is_continuous :
  forall X dX Y dY f_seq f:set,
    metric_on X dX -> metric_on Y dY ->
    function_on f_seq omega (function_space X Y) ->
    (forall n:set, n :e omega -> continuous_map X (metric_topology X dX) Y (metric_topology Y dY) (apply_fun f_seq n)) ->
    uniform_convergence_functions X dX Y dY f_seq f ->
    continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
let X dX Y dY f_seq f.
assume HdX: metric_on X dX.
assume HdY: metric_on Y dY.
assume Hfseq: function_on f_seq omega (function_space X Y).
assume Hcont: forall n:set, n :e omega -> continuous_map X (metric_topology X dX) Y (metric_topology Y dY) (apply_fun f_seq n).
assume Hunif: uniform_convergence_functions X dX Y dY f_seq f.
prove continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
claim Hf: function_on f X Y.
{ exact (uniform_convergence_functions_f X dX Y dY f_seq f Hunif). }
claim Hed: forall x0:set, x0 :e X ->
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists delta:set, delta :e R /\ Rlt 0 delta /\
      (forall x:set, x :e X ->
        Rlt (apply_fun dX (x,x0)) delta ->
        Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
{ let x0. assume Hx0X: x0 :e X.
  let eps. assume Heps: eps :e R /\ Rlt 0 eps.
  claim HepsR: eps :e R.
  { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
  claim Hepspos: Rlt 0 eps.
  { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
  (** choose N0 with eps_ N0 < eps and set eta := eps_ (ordsucc (ordsucc N0)) **)
  claim HexN0: exists N0 :e omega, eps_ N0 < eps.
  { exact (exists_eps_lt_pos eps HepsR Hepspos). }
  apply HexN0.
  let N0. assume HN0pair.
  claim HN0omega: N0 :e omega.
  { exact (andEL (N0 :e omega) (eps_ N0 < eps) HN0pair). }
  claim HepsN0lt: eps_ N0 < eps.
  { exact (andER (N0 :e omega) (eps_ N0 < eps) HN0pair). }
  claim HN0nat: nat_p N0.
  { exact (omega_nat_p N0 HN0omega). }
  claim Hsucc0: ordsucc N0 :e omega.
  { exact (omega_ordsucc N0 HN0omega). }
  claim Hsucc1: ordsucc (ordsucc N0) :e omega.
  { exact (omega_ordsucc (ordsucc N0) Hsucc0). }
  set eta := eps_ (ordsucc (ordsucc N0)).
  claim HetaR: eta :e R.
  { exact (SNoS_omega_real eta (SNo_eps_SNoS_omega (ordsucc (ordsucc N0)) Hsucc1)). }
  claim HetaS: SNo eta.
  { exact (SNo_eps_ (ordsucc (ordsucc N0)) Hsucc1). }
  claim H0lt_eta: 0 < eta.
  { exact (SNo_eps_pos (ordsucc (ordsucc N0)) Hsucc1). }
  claim HetaPos: Rlt 0 eta.
  { exact (RltI 0 eta real_0 HetaR H0lt_eta). }
  (** uniform convergence bound with eps = eta **)
  claim HexNu: exists Nu:set, Nu :e omega /\
    forall n:set, n :e omega -> Nu c= n ->
      forall x:set, x :e X ->
        Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eta.
  { exact (uniform_convergence_functions_eps X dX Y dY f_seq f Hunif eta (andI (eta :e R) (Rlt 0 eta) HetaR HetaPos)). }
  apply HexNu.
  let Nu. assume HNupair.
  claim HNuomega: Nu :e omega.
  { exact (andEL (Nu :e omega)
                 (forall n:set, n :e omega -> Nu c= n ->
                   forall x:set, x :e X ->
                     Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eta)
                 HNupair). }
  claim HNuprop: forall n:set, n :e omega -> Nu c= n ->
    forall x:set, x :e X ->
      Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eta.
  { exact (andER (Nu :e omega)
                 (forall n:set, n :e omega -> Nu c= n ->
                   forall x:set, x :e X ->
                     Rlt (apply_fun dY (apply_fun (apply_fun f_seq n) x, apply_fun f x)) eta)
                 HNupair). }
  (** choose fn := f_seq(Nu), use its continuity at x0 with eps = eta **)
  set fn := apply_fun f_seq Nu.
  claim Hfncont: continuous_map X (metric_topology X dX) Y (metric_topology Y dY) fn.
  { exact (Hcont Nu HNuomega). }
  claim Hfn: function_on fn X Y.
  { exact (continuous_map_function_on X (metric_topology X dX) Y (metric_topology Y dY) fn Hfncont). }
  claim Hedfn: forall x1:set, x1 :e X ->
     forall eps1:set, eps1 :e R /\ Rlt 0 eps1 ->
       exists delta1:set, delta1 :e R /\ Rlt 0 delta1 /\
         (forall x2:set, x2 :e X ->
            Rlt (apply_fun dX (x2,x1)) delta1 ->
            Rlt (apply_fun dY (apply_fun fn x2, apply_fun fn x1)) eps1).
  { exact (iffEL
            (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) fn)
            (forall x1:set, x1 :e X ->
              forall eps1:set, eps1 :e R /\ Rlt 0 eps1 ->
                exists delta1:set, delta1 :e R /\ Rlt 0 delta1 /\
                  (forall x2:set, x2 :e X ->
                    Rlt (apply_fun dX (x2,x1)) delta1 ->
                    Rlt (apply_fun dY (apply_fun fn x2, apply_fun fn x1)) eps1))
            (metric_epsilon_delta_continuity X dX Y dY fn HdX HdY Hfn)
            Hfncont). }
  apply (Hedfn x0 Hx0X eta (andI (eta :e R) (Rlt 0 eta) HetaR HetaPos)).
  let delta. assume Hdelta.
  claim Hdelta12: delta :e R /\ Rlt 0 delta.
  { exact (andEL (delta :e R /\ Rlt 0 delta)
                 (forall x2:set, x2 :e X ->
                   Rlt (apply_fun dX (x2,x0)) delta ->
                   Rlt (apply_fun dY (apply_fun fn x2, apply_fun fn x0)) eta)
                 Hdelta). }
  claim HdeltaImp: forall x2:set, x2 :e X ->
    Rlt (apply_fun dX (x2,x0)) delta ->
    Rlt (apply_fun dY (apply_fun fn x2, apply_fun fn x0)) eta.
  { exact (andER (delta :e R /\ Rlt 0 delta)
                 (forall x2:set, x2 :e X ->
                   Rlt (apply_fun dX (x2,x0)) delta ->
                   Rlt (apply_fun dY (apply_fun fn x2, apply_fun fn x0)) eta)
                 Hdelta). }
  witness delta.
  apply andI.
  - exact Hdelta12.
  - let x. assume HxX: x :e X.
    assume Hdx: Rlt (apply_fun dX (x,x0)) delta.
    (** shorthand points in Y **)
    claim HfxY: apply_fun f x :e Y.
    { exact (Hf x HxX). }
    claim Hfx0Y: apply_fun f x0 :e Y.
    { exact (Hf x0 Hx0X). }
    claim HfnxY: apply_fun fn x :e Y.
    { exact (Hfn x HxX). }
    claim Hfnx0Y: apply_fun fn x0 :e Y.
    { exact (Hfn x0 Hx0X). }
    (** bounds from uniform convergence at n=Nu **)
    claim HNuSub: Nu c= Nu.
    { let u. assume Hu: u :e Nu.
      exact Hu. }
    claim Huc1: Rlt (apply_fun dY (apply_fun fn x, apply_fun f x)) eta.
    { exact (HNuprop Nu HNuomega HNuSub x HxX). }
    claim Huc2: Rlt (apply_fun dY (apply_fun fn x0, apply_fun f x0)) eta.
    { exact (HNuprop Nu HNuomega HNuSub x0 Hx0X). }
    (** rewrite these bounds using symmetry to align directions **)
    claim Hsym1: apply_fun dY (apply_fun f x, apply_fun fn x) =
      apply_fun dY (apply_fun fn x, apply_fun f x).
    { exact (metric_on_symmetric Y dY (apply_fun f x) (apply_fun fn x) HdY HfxY HfnxY). }
    claim Hsym2: apply_fun dY (apply_fun fn x0, apply_fun f x0) =
      apply_fun dY (apply_fun f x0, apply_fun fn x0).
    { exact (metric_on_symmetric Y dY (apply_fun fn x0) (apply_fun f x0) HdY Hfnx0Y Hfx0Y). }
    claim Hp: Rlt (apply_fun dY (apply_fun f x, apply_fun fn x)) eta.
    { rewrite Hsym1. exact Huc1. }
    claim Hr: Rlt (apply_fun dY (apply_fun fn x0, apply_fun f x0)) eta.
    { exact Huc2. }
    claim Hq: Rlt (apply_fun dY (apply_fun fn x, apply_fun fn x0)) eta.
    { exact (HdeltaImp x HxX Hdx). }
    (** triangle inequality: d(fx,fx0) <= p + (q + r) **)
    set p := apply_fun dY (apply_fun f x, apply_fun fn x).
    set q := apply_fun dY (apply_fun fn x, apply_fun fn x0).
    set r := apply_fun dY (apply_fun fn x0, apply_fun f x0).
    claim HpR: p :e R.
    { exact ((metric_on_function_on Y dY HdY) (apply_fun f x, apply_fun fn x)
             (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun f x) (apply_fun fn x) HfxY HfnxY)). }
    claim HqR: q :e R.
    { exact ((metric_on_function_on Y dY HdY) (apply_fun fn x, apply_fun fn x0)
             (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn x) (apply_fun fn x0) HfnxY Hfnx0Y)). }
    claim HrR: r :e R.
    { exact ((metric_on_function_on Y dY HdY) (apply_fun fn x0, apply_fun f x0)
             (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn x0) (apply_fun f x0) Hfnx0Y Hfx0Y)). }
    claim Hpdlt: p < eta.
    { exact (RltE_lt p eta Hp). }
    claim Hqdlt: q < eta.
    { exact (RltE_lt q eta Hq). }
    claim Hrdlt: r < eta.
    { exact (RltE_lt r eta Hr). }
    claim HpS: SNo p.
    { exact (real_SNo p HpR). }
    claim HqS: SNo q.
    { exact (real_SNo q HqR). }
    claim HrS: SNo r.
    { exact (real_SNo r HrR). }
    claim Hsumqr_lt: add_SNo q r < add_SNo eta eta.
    { claim Ht1: add_SNo q r < add_SNo q eta.
      { exact (add_SNo_Lt2 q r eta HqS HrS HetaS Hrdlt). }
      claim Ht2: add_SNo q eta < add_SNo eta eta.
      { exact (add_SNo_Lt1 q eta eta HqS HetaS HetaS Hqdlt). }
      exact (SNoLt_tra (add_SNo q r) (add_SNo q eta) (add_SNo eta eta)
              (SNo_add_SNo q r HqS HrS)
              (SNo_add_SNo q eta HqS HetaS)
              (SNo_add_SNo eta eta HetaS HetaS)
              Ht1 Ht2). }
    claim Hsum_pqr_lt: add_SNo p (add_SNo q r) < add_SNo eta (add_SNo eta eta).
    { claim Ht1: add_SNo p (add_SNo q r) < add_SNo p (add_SNo eta eta).
      { exact (add_SNo_Lt2 p (add_SNo q r) (add_SNo eta eta)
               HpS (SNo_add_SNo q r HqS HrS) (SNo_add_SNo eta eta HetaS HetaS) Hsumqr_lt). }
      claim Ht2: add_SNo p (add_SNo eta eta) < add_SNo eta (add_SNo eta eta).
      { exact (add_SNo_Lt1 p (add_SNo eta eta) eta
               HpS (SNo_add_SNo eta eta HetaS HetaS) HetaS Hpdlt). }
      exact (SNoLt_tra (add_SNo p (add_SNo q r))
              (add_SNo p (add_SNo eta eta))
              (add_SNo eta (add_SNo eta eta))
              (SNo_add_SNo p (add_SNo q r) HpS (SNo_add_SNo q r HqS HrS))
              (SNo_add_SNo p (add_SNo eta eta) HpS (SNo_add_SNo eta eta HetaS HetaS))
              (SNo_add_SNo eta (add_SNo eta eta) HetaS (SNo_add_SNo eta eta HetaS HetaS))
              Ht1 Ht2). }
    (** show add_SNo eta (add_SNo eta eta) < eps via 4 eta = eps_N0 < eps **)
    claim Heta2eq: add_SNo eta eta = eps_ (ordsucc N0).
    { exact (eps_ordsucc_half_add (ordsucc N0) (omega_nat_p (ordsucc N0) Hsucc0)). }
    claim Heta4eq: add_SNo (add_SNo eta eta) (add_SNo eta eta) = eps_ N0.
    { rewrite Heta2eq.
      exact (eps_ordsucc_half_add N0 HN0nat). }
    claim Heta3lt_eta4: add_SNo (add_SNo eta eta) eta < add_SNo (add_SNo eta eta) (add_SNo eta eta).
    { claim Heta_lt_2eta: eta < add_SNo eta eta.
      { claim H0lt: 0 < eta.
        { exact H0lt_eta. }
        claim H0ltR: Rlt 0 eta.
        { exact HetaPos. }
        claim H0ltS: 0 < eta.
        { exact H0lt. }
        claim H0lt2: add_SNo 0 eta < add_SNo eta eta.
        { exact (add_SNo_Lt1 0 eta eta SNo_0 HetaS HetaS H0ltS). }
        rewrite <- (add_SNo_0L eta HetaS) at 1.
        exact H0lt2. }
      exact (add_SNo_Lt2 (add_SNo eta eta) eta (add_SNo eta eta)
             (SNo_add_SNo eta eta HetaS HetaS) HetaS (SNo_add_SNo eta eta HetaS HetaS) Heta_lt_2eta). }
    claim Heta3lt_epsN0: add_SNo (add_SNo eta eta) eta < eps_ N0.
    { rewrite <- Heta4eq.
      exact Heta3lt_eta4. }
    claim HepsN0R: eps_ N0 :e R.
    { exact (SNoS_omega_real (eps_ N0) (SNo_eps_SNoS_omega N0 HN0omega)). }
    claim HepsN0S: SNo (eps_ N0).
    { exact (real_SNo (eps_ N0) HepsN0R). }
    claim Heta3S: SNo (add_SNo (add_SNo eta eta) eta).
    { exact (SNo_add_SNo (add_SNo eta eta) eta (SNo_add_SNo eta eta HetaS HetaS) HetaS). }
    claim Heta3lt_eps: add_SNo (add_SNo eta eta) eta < eps.
    { exact (SNoLt_tra (add_SNo (add_SNo eta eta) eta) (eps_ N0) eps
             Heta3S HepsN0S (real_SNo eps HepsR) Heta3lt_epsN0 HepsN0lt). }
    claim Hsumlt_eps: add_SNo p (add_SNo q r) < eps.
    { claim Hmid: add_SNo eta (add_SNo eta eta) < eps.
      { rewrite (add_SNo_assoc eta eta eta HetaS HetaS HetaS).
        exact Heta3lt_eps. }
      exact (SNoLt_tra (add_SNo p (add_SNo q r))
              (add_SNo eta (add_SNo eta eta))
              eps
              (SNo_add_SNo p (add_SNo q r) HpS (SNo_add_SNo q r HqS HrS))
              (SNo_add_SNo eta (add_SNo eta eta) HetaS (SNo_add_SNo eta eta HetaS HetaS))
              (real_SNo eps HepsR)
              Hsum_pqr_lt Hmid). }
    claim HsumR: add_SNo p (add_SNo q r) :e R.
    { exact (real_add_SNo p HpR (add_SNo q r) (real_add_SNo q HqR r HrR)). }
    claim HsumRlt: Rlt (add_SNo p (add_SNo q r)) eps.
    { exact (RltI (add_SNo p (add_SNo q r)) eps HsumR HepsR Hsumlt_eps). }
    (** Rle bound for the metric distance **)
    claim Htri1: Rle (apply_fun dY (apply_fun f x, apply_fun f x0))
                 (add_SNo p (apply_fun dY (apply_fun fn x, apply_fun f x0))).
    { exact (metric_triangle_Rle Y dY (apply_fun f x) (apply_fun fn x) (apply_fun f x0)
             HdY HfxY HfnxY Hfx0Y). }
    claim Htri2: Rle (apply_fun dY (apply_fun fn x, apply_fun f x0))
                 (add_SNo q r).
    { exact (metric_triangle_Rle Y dY (apply_fun fn x) (apply_fun fn x0) (apply_fun f x0)
             HdY HfnxY Hfnx0Y Hfx0Y). }
    claim Hadd: Rle (add_SNo p (apply_fun dY (apply_fun fn x, apply_fun f x0)))
                  (add_SNo p (add_SNo q r)).
    { exact (Rle_add_SNo_2 p
             (apply_fun dY (apply_fun fn x, apply_fun f x0))
             (add_SNo q r)
             HpR
             ((metric_on_function_on Y dY HdY) (apply_fun fn x, apply_fun f x0)
              (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn x) (apply_fun f x0) HfnxY Hfx0Y))
             (real_add_SNo q HqR r HrR)
             Htri2). }
    claim Htri3: Rle (apply_fun dY (apply_fun f x, apply_fun f x0))
                 (add_SNo p (add_SNo q r)).
    { exact (Rle_tra (apply_fun dY (apply_fun f x, apply_fun f x0))
             (add_SNo p (apply_fun dY (apply_fun fn x, apply_fun f x0)))
             (add_SNo p (add_SNo q r))
             Htri1 Hadd). }
    exact (Rle_Rlt_tra
            (apply_fun dY (apply_fun f x, apply_fun f x0))
            (add_SNo p (add_SNo q r))
            eps
            Htri3 HsumRlt).
}
exact (iffER
        (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f)
        (forall x0:set, x0 :e X ->
          forall eps:set, eps :e R /\ Rlt 0 eps ->
            exists delta:set, delta :e R /\ Rlt 0 delta /\
              (forall x:set, x :e X ->
                Rlt (apply_fun dX (x,x0)) delta ->
                Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))
        (metric_epsilon_delta_continuity X dX Y dY f HdX HdY Hf)
        Hed).
Qed.

(** from §21: convergence of sequences in metric spaces **) 
(** LATEX VERSION: Immediate restatement of convergence (placeholder). **)
Theorem sequence_convergence_metric : forall X d seq x:set,
  sequence_converges_metric X d seq x -> sequence_converges_metric X d seq x.
let X d seq x.
assume H: sequence_converges_metric X d seq x.
prove sequence_converges_metric X d seq x.
exact H.
Qed.

(** from §21: continuity via sequences in metric spaces **)
(** LATEX VERSION: Continuity between metric spaces is equivalent to preserving limits of convergent sequences. **)
(** FIXED: Composed sequence f∘seq is a function graph {(n, apply_fun f (apply_fun seq n))|n :e omega}, not a Cartesian-product set. **)
Theorem continuity_via_sequences_metric : forall X dX Y dY f:set,
  metric_on X dX -> metric_on Y dY -> function_on f X Y ->
  (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f <->
    forall seq x:set,
      sequence_converges_metric X dX seq x ->
      sequence_converges_metric Y dY
        ({(n, apply_fun f (apply_fun seq n))|n :e omega})
        (apply_fun f x)).
let X dX Y dY f.
assume HdX: metric_on X dX.
assume HdY: metric_on Y dY.
assume Hf: function_on f X Y.
prove continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f <->
    forall seq x:set,
      sequence_converges_metric X dX seq x ->
      sequence_converges_metric Y dY
        ({(n, apply_fun f (apply_fun seq n))|n :e omega})
        (apply_fun f x).
apply iffI.
- assume Hcont: continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
  let seq x.
  assume Hseq: sequence_converges_metric X dX seq x.
  prove sequence_converges_metric Y dY ({(n, apply_fun f (apply_fun seq n))|n :e omega}) (apply_fun f x).
  set seqY := {(n, apply_fun f (apply_fun seq n))|n :e omega}.
  claim Hseqon: sequence_on seq X.
  { exact (sequence_converges_metric_sequence_on X dX seq x Hseq). }
  claim HxX: x :e X.
  { exact (sequence_converges_metric_point_in_X X dX seq x Hseq). }
  claim HfxY: apply_fun f x :e Y.
  { exact (Hf x HxX). }
  claim HseqYfun: function_on seqY omega Y.
  { let n. assume Hnomega: n :e omega.
    claim Hseqfun: function_on seq omega X.
    { exact Hseqon. }
    claim HseqnX: apply_fun seq n :e X.
    { exact (Hseqfun n Hnomega). }
    claim HfseqnY: apply_fun f (apply_fun seq n) :e Y.
    { exact (Hf (apply_fun seq n) HseqnX). }
    claim Hfunc: functional_graph seqY.
    { exact (functional_graph_graph omega (fun n0:set => apply_fun f (apply_fun seq n0))). }
    claim HpairIn: (n, apply_fun f (apply_fun seq n)) :e seqY.
    { exact (ReplI omega (fun n0:set => (n0, apply_fun f (apply_fun seq n0))) n Hnomega). }
    claim Happ: apply_fun seqY n = apply_fun f (apply_fun seq n).
    { exact (functional_graph_apply_fun_eq seqY n (apply_fun f (apply_fun seq n)) Hfunc HpairIn). }
    rewrite Happ.
    exact HfseqnY. }
  claim HseqYon: sequence_on seqY Y.
  { exact HseqYfun. }
  prove sequence_converges_metric Y dY seqY (apply_fun f x).
  prove (metric_on Y dY /\ sequence_on seqY Y) /\ (apply_fun f x :e Y) /\
    forall eps:set, eps :e R /\ Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n ->
          Rlt (apply_fun dY (apply_fun seqY n, apply_fun f x)) eps.
  apply andI.
  - apply andI.
    + apply andI.
      * exact HdY.
      * exact HseqYon.
    + exact HfxY.
  - let eps. assume Heps: eps :e R /\ Rlt 0 eps.
    claim Hedcont: forall x0:set, x0 :e X ->
      forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
        exists delta:set, delta :e R /\ Rlt 0 delta /\
          (forall x1:set, x1 :e X ->
            Rlt (apply_fun dX (x1,x0)) delta ->
            Rlt (apply_fun dY (apply_fun f x1, apply_fun f x0)) eps0).
    { exact (iffEL
              (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f)
              (forall x0:set, x0 :e X ->
                forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
                  exists delta:set, delta :e R /\ Rlt 0 delta /\
                    (forall x1:set, x1 :e X ->
                      Rlt (apply_fun dX (x1,x0)) delta ->
                      Rlt (apply_fun dY (apply_fun f x1, apply_fun f x0)) eps0))
              (metric_epsilon_delta_continuity X dX Y dY f HdX HdY Hf)
              Hcont). }
    apply (Hedcont x HxX eps Heps).
    let delta. assume Hdelta.
    claim Hdelta12: delta :e R /\ Rlt 0 delta.
    { exact (andEL (delta :e R /\ Rlt 0 delta)
                   (forall x1:set, x1 :e X ->
                     Rlt (apply_fun dX (x1,x)) delta ->
                     Rlt (apply_fun dY (apply_fun f x1, apply_fun f x)) eps)
                   Hdelta). }
    claim HdeltaImp: forall x1:set, x1 :e X ->
      Rlt (apply_fun dX (x1,x)) delta ->
      Rlt (apply_fun dY (apply_fun f x1, apply_fun f x)) eps.
    { exact (andER (delta :e R /\ Rlt 0 delta)
                   (forall x1:set, x1 :e X ->
                     Rlt (apply_fun dX (x1,x)) delta ->
                     Rlt (apply_fun dY (apply_fun f x1, apply_fun f x)) eps)
                   Hdelta). }
    apply (sequence_converges_metric_eps X dX seq x Hseq delta Hdelta12).
    let N. assume HNpair.
    witness N.
    apply andI.
    - exact (andEL (N :e omega)
                   (forall n:set, n :e omega -> N c= n -> Rlt (apply_fun dX (apply_fun seq n, x)) delta)
                   HNpair).
    - let n. assume Hnomega: n :e omega.
      assume HNsubn: N c= n.
      claim HNprop: forall n0:set, n0 :e omega -> N c= n0 -> Rlt (apply_fun dX (apply_fun seq n0, x)) delta.
      { exact (andER (N :e omega)
                     (forall n0:set, n0 :e omega -> N c= n0 -> Rlt (apply_fun dX (apply_fun seq n0, x)) delta)
                     HNpair). }
      claim Hdx: Rlt (apply_fun dX (apply_fun seq n, x)) delta.
      { exact (HNprop n Hnomega HNsubn). }
      claim Hseqfun: function_on seq omega X.
      { exact Hseqon. }
      claim HseqnX: apply_fun seq n :e X.
      { exact (Hseqfun n Hnomega). }
      claim Hdy: Rlt (apply_fun dY (apply_fun f (apply_fun seq n), apply_fun f x)) eps.
      { exact (HdeltaImp (apply_fun seq n) HseqnX Hdx). }
      claim Hfunc: functional_graph seqY.
      { exact (functional_graph_graph omega (fun n0:set => apply_fun f (apply_fun seq n0))). }
      claim HpairIn: (n, apply_fun f (apply_fun seq n)) :e seqY.
      { exact (ReplI omega (fun n0:set => (n0, apply_fun f (apply_fun seq n0))) n Hnomega). }
      claim Happ: apply_fun seqY n = apply_fun f (apply_fun seq n).
      { exact (functional_graph_apply_fun_eq seqY n (apply_fun f (apply_fun seq n)) Hfunc HpairIn). }
      rewrite Happ.
      exact Hdy.
- assume Hseqcont: forall seq x:set,
    sequence_converges_metric X dX seq x ->
    sequence_converges_metric Y dY ({(n, apply_fun f (apply_fun seq n))|n :e omega}) (apply_fun f x).
  prove continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f.
  claim Hed: forall x0:set, x0 :e X ->
    forall eps:set, eps :e R /\ Rlt 0 eps ->
      exists delta:set, delta :e R /\ Rlt 0 delta /\
        (forall x:set, x :e X ->
          Rlt (apply_fun dX (x,x0)) delta ->
          Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
  { let x0. assume Hx0X: x0 :e X.
    let eps. assume Heps: eps :e R /\ Rlt 0 eps.
    apply dneg.
    assume Hno: ~(exists delta:set, delta :e R /\ Rlt 0 delta /\
      (forall x:set, x :e X ->
        Rlt (apply_fun dX (x,x0)) delta ->
        Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps)).
    prove False.
    claim HepsR: eps :e R.
    { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
    claim Hepspos: Rlt 0 eps.
    { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
    claim Hbad: forall delta:set, delta :e R /\ Rlt 0 delta ->
      exists x:set, x :e X /\ Rlt (apply_fun dX (x,x0)) delta /\
        ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
    { let delta. assume Hdelta: delta :e R /\ Rlt 0 delta.
      apply dneg.
      assume Hnobad: ~(exists x:set, x :e X /\ Rlt (apply_fun dX (x,x0)) delta /\
        ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps)).
      prove False.
      apply Hno.
      witness delta.
      apply andI.
      - exact Hdelta.
      - let x. assume HxX: x :e X.
        assume Hdx: Rlt (apply_fun dX (x,x0)) delta.
        apply dneg.
        assume HnRlt: ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
        prove False.
        apply Hnobad.
        witness x.
        apply andI.
        - apply andI.
          + exact HxX.
          + exact Hdx.
        - exact HnRlt. }
    set g := fun n:set =>
      Eps_i (fun x:set =>
        x :e X /\
        Rlt (apply_fun dX (x,x0)) (eps_ n) /\
        ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps)).
    set seq := {(n, g n)|n :e omega}.
    claim Hseqfun: function_on seq omega X.
    { claim HgAll: forall n:set, n :e omega -> g n :e X.
      { let n. assume Hnomega: n :e omega.
        claim Hgnreal: eps_ n :e R.
        { exact (SNoS_omega_real (eps_ n) (SNo_eps_SNoS_omega n Hnomega)). }
        claim HgnposS: 0 < eps_ n.
        { exact (SNo_eps_pos n Hnomega). }
        claim Hgnpos: Rlt 0 (eps_ n).
        { exact (RltI 0 (eps_ n) real_0 Hgnreal HgnposS). }
        claim Hexbad: exists x:set, x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ n) /\
          ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
        { exact (Hbad (eps_ n) (andI (eps_ n :e R) (Rlt 0 (eps_ n)) Hgnreal Hgnpos)). }
        claim Hgprop: g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n) /\
          ~(Rlt (apply_fun dY (apply_fun f (g n), apply_fun f x0)) eps).
        { exact (Eps_i_ex
                  (fun x:set => x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ n) /\
                    ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))
                  Hexbad). }
        claim Hg12: g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n).
        { exact (andEL
                  (g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n))
                  (~(Rlt (apply_fun dY (apply_fun f (g n), apply_fun f x0)) eps))
                  Hgprop). }
        exact (andEL (g n :e X) (Rlt (apply_fun dX (g n,x0)) (eps_ n)) Hg12). }
      claim Hrng: graph_range_subset seq X.
      { exact (graph_range_subset_graph omega X (fun n0:set => g n0) HgAll). }
      let n. assume Hnomega: n :e omega.
      claim HpairIn: (n, g n) :e seq.
      { exact (ReplI omega (fun n0:set => (n0, g n0)) n Hnomega). }
      claim HpairApp: (n, apply_fun seq n) :e seq.
      { exact (Eps_i_ax (fun y0:set => (n,y0) :e seq) (g n) HpairIn). }
      exact (Hrng n (apply_fun seq n) HpairApp). }
	    claim Hseqconv: sequence_converges_metric X dX seq x0.
	    { prove (metric_on X dX /\ sequence_on seq X) /\ x0 :e X /\
	        forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
	          exists N:set, N :e omega /\
	            forall n:set, n :e omega -> N c= n ->
	              Rlt (apply_fun dX (apply_fun seq n, x0)) eps0.
	      apply andI.
	      - apply andI.
	        + apply andI.
	          * exact HdX.
	          * exact Hseqfun.
	        + exact Hx0X.
	      - let eps0. assume Heps0: eps0 :e R /\ Rlt 0 eps0.
	        claim Heps0R: eps0 :e R.
	        { exact (andEL (eps0 :e R) (Rlt 0 eps0) Heps0). }
	        claim Heps0pos: Rlt 0 eps0.
	        { exact (andER (eps0 :e R) (Rlt 0 eps0) Heps0). }
	        claim HexN: exists N :e omega, eps_ N < eps0.
	        { exact (exists_eps_lt_pos eps0 Heps0R Heps0pos). }
	        apply HexN.
	        let N. assume HNpair.
	        claim HNomega: N :e omega.
	        { exact (andEL (N :e omega) (eps_ N < eps0) HNpair). }
	        claim HepsNlt: eps_ N < eps0.
	        { exact (andER (N :e omega) (eps_ N < eps0) HNpair). }
	        claim HepsNR: eps_ N :e R.
	        { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
	        claim HepsNltR: Rlt (eps_ N) eps0.
	        { exact (RltI (eps_ N) eps0 HepsNR Heps0R HepsNlt). }
	        witness N.
	        apply andI.
	        + exact HNomega.
	        + let n. assume Hnomega: n :e omega.
	          assume HNsubn: N c= n.
	          claim HepsnR: eps_ n :e R.
	          { exact (SNoS_omega_real (eps_ n) (SNo_eps_SNoS_omega n Hnomega)). }
	          claim HordN: ordinal N.
	          { exact (nat_p_ordinal N (omega_nat_p N HNomega)). }
	          claim Hordn: ordinal n.
	          { exact (nat_p_ordinal n (omega_nat_p n Hnomega)). }
	          claim Hnot_nInN: ~(n :e N).
	          { assume HninN: n :e N.
	            claim Hnn: n :e n.
	            { exact (HNsubn n HninN). }
	            exact ((In_irref n) Hnn). }
	          claim Hfunc: functional_graph seq.
	          { exact (functional_graph_graph omega (fun n0:set => g n0)). }
	          claim HpairIn: (n, g n) :e seq.
	          { exact (ReplI omega (fun n0:set => (n0, g n0)) n Hnomega). }
	          claim Happ: apply_fun seq n = g n.
	          { exact (functional_graph_apply_fun_eq seq n (g n) Hfunc HpairIn). }
	          claim HgnposS: 0 < eps_ n.
	          { exact (SNo_eps_pos n Hnomega). }
	          claim Hgnpos: Rlt 0 (eps_ n).
	          { exact (RltI 0 (eps_ n) real_0 HepsnR HgnposS). }
	          claim Hexbad: exists x:set, x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ n) /\
	            ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
	          { exact (Hbad (eps_ n) (andI (eps_ n :e R) (Rlt 0 (eps_ n)) HepsnR Hgnpos)). }
	          claim Hgprop: g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n) /\
	            ~(Rlt (apply_fun dY (apply_fun f (g n), apply_fun f x0)) eps).
	          { exact (Eps_i_ex
	                    (fun x:set => x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ n) /\
	                      ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))
	                    Hexbad). }
	          claim Hg12: g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n).
	          { exact (andEL
	                    (g n :e X /\ Rlt (apply_fun dX (g n,x0)) (eps_ n))
	                    (~(Rlt (apply_fun dY (apply_fun f (g n), apply_fun f x0)) eps))
	                    Hgprop). }
	          claim Hdxlt_epsn: Rlt (apply_fun dX (g n, x0)) (eps_ n).
	          { exact (andER (g n :e X) (Rlt (apply_fun dX (g n,x0)) (eps_ n)) Hg12). }
	          claim Hdxlt_epsn2: Rlt (apply_fun dX (apply_fun seq n, x0)) (eps_ n).
	          { rewrite Happ. exact Hdxlt_epsn. }
          claim Hepsnlt_eps0: Rlt (eps_ n) eps0.
          { apply (ordinal_trichotomy_or_impred N n HordN Hordn (Rlt (eps_ n) eps0)).
            - assume HNin: N :e n.
              claim Hepsnlt_epsN: eps_ n < eps_ N.
              { exact (SNo_eps_decr n Hnomega N HNin). }
              claim Hepsnlt_epsNR: Rlt (eps_ n) (eps_ N).
              { exact (RltI (eps_ n) (eps_ N) HepsnR HepsNR Hepsnlt_epsN). }
              exact (Rlt_tra (eps_ n) (eps_ N) eps0 Hepsnlt_epsNR HepsNltR).
            - assume Heq: N = n.
              rewrite <- Heq.
              exact HepsNltR.
            - assume HninN: n :e N.
              apply FalseE.
              prove False.
              exact (Hnot_nInN HninN). }
	          exact (Rlt_tra (apply_fun dX (apply_fun seq n, x0)) (eps_ n) eps0 Hdxlt_epsn2 Hepsnlt_eps0). }
    set seqY := {(n, apply_fun f (apply_fun seq n))|n :e omega}.
    claim Himgconv: sequence_converges_metric Y dY seqY (apply_fun f x0).
    { exact (Hseqcont seq x0 Hseqconv). }
    claim HexNimg: exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n ->
        Rlt (apply_fun dY (apply_fun seqY n, apply_fun f x0)) eps.
    { exact (sequence_converges_metric_eps Y dY seqY (apply_fun f x0) Himgconv eps Heps). }
    apply HexNimg.
    let N. assume HNpair.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega)
                   (forall n:set, n :e omega -> N c= n ->
                     Rlt (apply_fun dY (apply_fun seqY n, apply_fun f x0)) eps)
                   HNpair). }
    claim HNprop: forall n:set, n :e omega -> N c= n ->
      Rlt (apply_fun dY (apply_fun seqY n, apply_fun f x0)) eps.
    { exact (andER (N :e omega)
                   (forall n:set, n :e omega -> N c= n ->
                     Rlt (apply_fun dY (apply_fun seqY n, apply_fun f x0)) eps)
                   HNpair). }
    claim HNsubN: N c= N.
    { exact (Subq_ref N). }
    claim Hdylt: Rlt (apply_fun dY (apply_fun seqY N, apply_fun f x0)) eps.
    { exact (HNprop N HNomega HNsubN). }
    claim HfuncY: functional_graph seqY.
    { exact (functional_graph_graph omega (fun n0:set => apply_fun f (apply_fun seq n0))). }
    claim HpairY: (N, apply_fun f (apply_fun seq N)) :e seqY.
    { exact (ReplI omega (fun n0:set => (n0, apply_fun f (apply_fun seq n0))) N HNomega). }
    claim HappY: apply_fun seqY N = apply_fun f (apply_fun seq N).
    { exact (functional_graph_apply_fun_eq seqY N (apply_fun f (apply_fun seq N)) HfuncY HpairY). }
    claim HfuncX: functional_graph seq.
    { exact (functional_graph_graph omega (fun n0:set => g n0)). }
    claim HpairX: (N, g N) :e seq.
    { exact (ReplI omega (fun n0:set => (n0, g n0)) N HNomega). }
    claim HappX: apply_fun seq N = g N.
    { exact (functional_graph_apply_fun_eq seq N (g N) HfuncX HpairX). }
    claim Hgnreal: eps_ N :e R.
    { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
    claim HgnposS: 0 < eps_ N.
    { exact (SNo_eps_pos N HNomega). }
    claim Hgnpos: Rlt 0 (eps_ N).
    { exact (RltI 0 (eps_ N) real_0 Hgnreal HgnposS). }
    claim Hexbad: exists x:set, x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ N) /\
      ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps).
    { exact (Hbad (eps_ N) (andI (eps_ N :e R) (Rlt 0 (eps_ N)) Hgnreal Hgnpos)). }
    claim Hgprop: g N :e X /\ Rlt (apply_fun dX (g N,x0)) (eps_ N) /\
      ~(Rlt (apply_fun dY (apply_fun f (g N), apply_fun f x0)) eps).
    { exact (Eps_i_ex
              (fun x:set => x :e X /\ Rlt (apply_fun dX (x,x0)) (eps_ N) /\
                ~(Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))
              Hexbad). }
    claim Hnot: ~(Rlt (apply_fun dY (apply_fun f (g N), apply_fun f x0)) eps).
    { exact (andER
              (g N :e X /\ Rlt (apply_fun dX (g N,x0)) (eps_ N))
              (~(Rlt (apply_fun dY (apply_fun f (g N), apply_fun f x0)) eps))
              Hgprop). }
    claim Hdylt2: Rlt (apply_fun dY (apply_fun f (g N), apply_fun f x0)) eps.
    { claim HeqY: apply_fun seqY N = apply_fun f (g N).
      { rewrite HappY.
        rewrite HappX.
        reflexivity. }
      rewrite <- HeqY at 1.
      exact Hdylt. }
    exact (Hnot Hdylt2). }
  exact (iffER
          (continuous_map X (metric_topology X dX) Y (metric_topology Y dY) f)
          (forall x0:set, x0 :e X ->
            forall eps:set, eps :e R /\ Rlt 0 eps ->
              exists delta:set, delta :e R /\ Rlt 0 delta /\
                (forall x:set, x :e X ->
                  Rlt (apply_fun dX (x,x0)) delta ->
                  Rlt (apply_fun dY (apply_fun f x, apply_fun f x0)) eps))
          (metric_epsilon_delta_continuity X dX Y dY f HdX HdY Hf)
          Hed).
Qed.

(** from §22 Definition: quotient map and quotient topology **) 
(** LATEX VERSION: Quotient topology on Y makes a surjective map f:X→Y continuous iff preimages of opens in Y are open in X. **)
Definition quotient_topology : set -> set -> set -> set -> set :=
  fun X Tx Y f => {V :e Power Y|{x :e X|apply_fun f x :e V} :e Tx}.

Definition quotient_map : set -> set -> set -> set -> prop := fun X Tx Y f =>
  topology_on X Tx /\
  function_on f X Y /\
  (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y).

Theorem quotient_topology_is_topology : forall X Tx Y f:set,
  topology_on X Tx -> quotient_map X Tx Y f ->
  topology_on Y (quotient_topology X Tx Y f).
let X Tx Y f.
assume HTx: topology_on X Tx.
assume Hf: quotient_map X Tx Y f.
prove topology_on Y (quotient_topology X Tx Y f).
set Q := quotient_topology X Tx Y f.
set pre := fun V:set => preimage_of X f V.
prove Q c= Power Y
  /\ Empty :e Q
  /\ Y :e Q
  /\ (forall UFam :e Power Q, Union UFam :e Q)
  /\ (forall U :e Q, forall V :e Q, U :/\: V :e Q).
apply andI.
- apply andI.
  - apply andI.
    - apply andI.
      - (** Q subset Power Y **)
        let V. assume HV: V :e Q.
        exact (SepE1 (Power Y) (fun V0:set => pre V0 :e Tx) V HV).
      - (** Empty in Q **)
        prove Empty :e Q.
        claim HpreE: pre Empty :e Tx.
        { set Epre := pre Empty.
          claim HEsub: Epre c= Empty.
          { let x. assume Hx: x :e Epre.
            prove x :e Empty.
            claim Hxprop: apply_fun f x :e Empty.
            { exact (SepE2 X (fun x0 => apply_fun f x0 :e Empty) x Hx). }
            exact (EmptyE (apply_fun f x) Hxprop (x :e Empty)). }
          claim HEeq: Epre = Empty.
          { exact (Empty_Subq_eq Epre HEsub). }
          rewrite HEeq.
          exact (topology_has_empty X Tx HTx). }
        claim Hpow: Empty :e Power Y.
        { exact (Empty_In_Power Y). }
        exact (SepI (Power Y) (fun V0:set => pre V0 :e Tx) Empty Hpow HpreE).
    - (** Y in Q **)
      prove Y :e Q.
      claim Hf_on: function_on f X Y.
      { exact (andER (topology_on X Tx) (function_on f X Y)
          (andEL (topology_on X Tx /\ function_on f X Y)
            (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y) Hf)). }
      claim HpreY: pre Y :e Tx.
      { set Ypre := pre Y.
        claim HYsub: Ypre c= X.
        { let x. assume Hx: x :e Ypre.
          exact (SepE1 X (fun x0 => apply_fun f x0 :e Y) x Hx). }
        claim HXsub: X c= Ypre.
        { let x. assume Hx: x :e X.
          prove x :e Ypre.
	          claim HfxY: apply_fun f x :e Y.
	          { exact (Hf_on x Hx). }
	          exact (SepI X (fun x0 => apply_fun f x0 :e Y) x Hx HfxY). }
        claim HYeq: Ypre = X.
        { apply set_ext.
          - exact HYsub.
          - exact HXsub. }
        rewrite HYeq.
        exact (topology_has_X X Tx HTx). }
      claim Hpow: Y :e Power Y.
      { apply PowerI.
        exact (fun x Hx => Hx). }
      exact (SepI (Power Y) (fun V0:set => pre V0 :e Tx) Y Hpow HpreY).
  - (** Union closure **)
    let UFam. assume HUFam: UFam :e Power Q.
    prove Union UFam :e Q.
    claim HUFamSub: UFam c= Q.
    { exact (PowerE Q UFam HUFam). }
    (** show Union UFam in Power Y **)
    claim HUnionPow: Union UFam :e Power Y.
    { apply PowerI.
      let y. assume Hy: y :e Union UFam.
      prove y :e Y.
      apply (UnionE_impred UFam y Hy).
      let V. assume HyV. assume HVUF.
      claim HVQ: V :e Q.
      { exact (HUFamSub V HVUF). }
      claim HVPow: V :e Power Y.
      { exact (SepE1 (Power Y) (fun V0:set => pre V0 :e Tx) V HVQ). }
      exact (PowerE Y V HVPow y HyV). }
    (** show preimage of Union UFam is open in Tx **)
    claim HpreU: pre (Union UFam) :e Tx.
    { set PUFam := {pre V|V :e UFam}.
      claim HPUFamPow: PUFam :e Power Tx.
      { apply PowerI.
        let W. assume HW: W :e PUFam.
        prove W :e Tx.
        apply (ReplE UFam (fun V:set => pre V) W HW).
        let V. assume HVconj.
        claim HVUF: V :e UFam.
        { exact (andEL (V :e UFam) (W = pre V) HVconj). }
        claim HWeq: W = pre V.
        { exact (andER (V :e UFam) (W = pre V) HVconj). }
        claim HVQ: V :e Q.
        { exact (HUFamSub V HVUF). }
        claim HpreV: pre V :e Tx.
        { exact (SepE2 (Power Y) (fun V0:set => pre V0 :e Tx) V HVQ). }
        rewrite HWeq.
        exact HpreV. }
      (** pre(Union UFam) = Union PUFam **)
      claim Heq: pre (Union UFam) = Union PUFam.
      { apply set_ext.
        - let x. assume Hx: x :e pre (Union UFam).
          prove x :e Union PUFam.
          claim HxX: x :e X.
          { exact (SepE1 X (fun x0 => apply_fun f x0 :e Union UFam) x Hx). }
	          claim HxU: apply_fun f x :e Union UFam.
	          { exact (SepE2 X (fun x0 => apply_fun f x0 :e Union UFam) x Hx). }
	          apply (UnionE_impred UFam (apply_fun f x) HxU).
	          let V. assume HfxV. assume HVUF.
	          claim HxpreV: x :e pre V.
	          { exact (SepI X (fun x0 => apply_fun f x0 :e V) x HxX HfxV). }
	          claim HpreVin: pre V :e PUFam.
	          { exact (ReplI UFam (fun V0:set => pre V0) V HVUF). }
	          exact (UnionI PUFam x (pre V) HxpreV HpreVin).
	        - let x. assume Hx: x :e Union PUFam.
	          prove x :e pre (Union UFam).
	          apply (UnionE_impred PUFam x Hx).
	          let W. assume HxW. assume HWPU.
	          apply (ReplE UFam (fun V:set => pre V) W HWPU).
	          let V. assume HVconj.
	          claim HVUF: V :e UFam.
	          { exact (andEL (V :e UFam) (W = pre V) HVconj). }
          claim HWeq: W = pre V.
          { exact (andER (V :e UFam) (W = pre V) HVconj). }
          claim HxpreV: x :e pre V.
          { rewrite <- HWeq.
            exact HxW. }
          claim HfxV: apply_fun f x :e V.
          { exact (SepE2 X (fun x0 => apply_fun f x0 :e V) x HxpreV). }
	          claim HfxU: apply_fun f x :e Union UFam.
	          { exact (UnionI UFam (apply_fun f x) V HfxV HVUF). }
          claim HxX: x :e X.
          { exact (SepE1 X (fun x0 => apply_fun f x0 :e V) x HxpreV). }
          exact (SepI X (fun x0 => apply_fun f x0 :e Union UFam) x HxX HfxU). }
      rewrite Heq.
      exact (topology_union_axiom X Tx HTx PUFam HPUFamPow). }
    exact (SepI (Power Y) (fun V0:set => pre V0 :e Tx) (Union UFam) HUnionPow HpreU).
- (** binary intersection closure **)
  let U. assume HU: U :e Q.
  let V. assume HV: V :e Q.
  prove U :/\: V :e Q.
  claim HUPow: U :e Power Y.
  { exact (SepE1 (Power Y) (fun V0:set => pre V0 :e Tx) U HU). }
  claim HVPow: V :e Power Y.
  { exact (SepE1 (Power Y) (fun V0:set => pre V0 :e Tx) V HV). }
  claim HpreU: pre U :e Tx.
  { exact (SepE2 (Power Y) (fun V0:set => pre V0 :e Tx) U HU). }
  claim HpreV: pre V :e Tx.
  { exact (SepE2 (Power Y) (fun V0:set => pre V0 :e Tx) V HV). }
  claim HUVPow: U :/\: V :e Power Y.
  { apply PowerI.
    let y. assume Hy: y :e U :/\: V.
    prove y :e Y.
    claim HyU: y :e U.
    { exact (binintersectE1 U V y Hy). }
    exact (PowerE Y U HUPow y HyU). }
  (** pre(U∩V) = pre(U) ∩ pre(V) **)
  claim Heq: pre (U :/\: V) = pre U :/\: pre V.
  { apply set_ext.
    - let x. assume Hx: x :e pre (U :/\: V).
      prove x :e pre U :/\: pre V.
      claim HxX: x :e X.
      { exact (SepE1 X (fun x0 => apply_fun f x0 :e U :/\: V) x Hx). }
      claim Hfx: apply_fun f x :e U :/\: V.
      { exact (SepE2 X (fun x0 => apply_fun f x0 :e U :/\: V) x Hx). }
      claim HfxU: apply_fun f x :e U.
      { exact (binintersectE1 U V (apply_fun f x) Hfx). }
      claim HfxV: apply_fun f x :e V.
      { exact (binintersectE2 U V (apply_fun f x) Hfx). }
      exact (binintersectI (pre U) (pre V) x
              (SepI X (fun x0 => apply_fun f x0 :e U) x HxX HfxU)
              (SepI X (fun x0 => apply_fun f x0 :e V) x HxX HfxV)).
    - let x. assume Hx: x :e pre U :/\: pre V.
      prove x :e pre (U :/\: V).
      claim HxpreU: x :e pre U.
      { exact (binintersectE1 (pre U) (pre V) x Hx). }
      claim HxpreV: x :e pre V.
      { exact (binintersectE2 (pre U) (pre V) x Hx). }
      claim HxX: x :e X.
      { exact (SepE1 X (fun x0 => apply_fun f x0 :e U) x HxpreU). }
      claim HfxU: apply_fun f x :e U.
      { exact (SepE2 X (fun x0 => apply_fun f x0 :e U) x HxpreU). }
      claim HfxV: apply_fun f x :e V.
      { exact (SepE2 X (fun x0 => apply_fun f x0 :e V) x HxpreV). }
      claim HfxUV: apply_fun f x :e U :/\: V.
      { exact (binintersectI U V (apply_fun f x) HfxU HfxV). }
      exact (SepI X (fun x0 => apply_fun f x0 :e U :/\: V) x HxX HfxUV). }
  claim HpreUV: pre (U :/\: V) :e Tx.
  { rewrite Heq.
    exact (topology_binintersect_closed X Tx (pre U) (pre V) HTx HpreU HpreV). }
  exact (SepI (Power Y) (fun V0:set => pre V0 :e Tx) (U :/\: V) HUVPow HpreUV).
Qed.

(** from §22: universal property of quotient maps **) 
(** LATEX VERSION: Universal property: a quotient map f is continuous into any topology Ty on Y coarser than the quotient topology. **)
Theorem quotient_universal_property : forall X Tx Y Ty f:set,
  quotient_map X Tx Y f -> topology_on Y Ty -> Ty c= quotient_topology X Tx Y f ->
  continuous_map X Tx Y Ty f.
let X Tx Y Ty f.
assume Hf: quotient_map X Tx Y f.
assume HTy: topology_on Y Ty.
assume Hsub: Ty c= quotient_topology X Tx Y f.
prove continuous_map X Tx Y Ty f.
prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\ forall V:set, V :e Ty -> preimage_of X f V :e Tx.
claim Htopfun : topology_on X Tx /\ function_on f X Y.
{ exact (andEL (topology_on X Tx /\ function_on f X Y)
        (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y) Hf). }
claim HTx : topology_on X Tx.
{ exact (andEL (topology_on X Tx) (function_on f X Y) Htopfun). }
claim Hf_on : function_on f X Y.
{ exact (andER (topology_on X Tx) (function_on f X Y) Htopfun). }
apply andI.
- apply andI.
  - apply andI.
    + exact HTx.
    + exact HTy.
  - exact Hf_on.
- let V. assume HV: V :e Ty.
  prove preimage_of X f V :e Tx.
  claim HVQ: V :e quotient_topology X Tx Y f.
  { exact (Hsub V HV). }
  exact (SepE2 (Power Y) (fun V0:set => preimage_of X f V0 :e Tx) V HVQ).
Qed.

(** from §23 Definition: separation of a space **) 
(** LATEX VERSION: A separation of X is a pair of disjoint nonempty open sets whose union is X. **)
Definition separation_of : set -> set -> set -> prop := fun X U V =>
  U :e Power X /\ V :e Power X /\ U :/\: V = Empty /\ U <> Empty /\ V <> Empty /\ U :\/: V = X.

(** Helper: a proper nonempty subset yields a separation by its complement **)
Theorem separation_of_complement : forall X U:set,
  U c= X -> U <> Empty -> U <> X ->
  separation_of X U (X :\: U).
let X U.
assume HUsub: U c= X.
assume HUne: U <> Empty.
assume HUnX: U <> X.
prove separation_of X U (X :\: U).
claim HUpow: U :e Power X.
{ exact (PowerI X U HUsub). }
claim HcompSubX: X :\: U c= X.
{ exact (setminus_Subq X U). }
claim HcompPower: (X :\: U) :e Power X.
{ exact (PowerI X (X :\: U) HcompSubX). }
claim Hdisjoint: U :/\: (X :\: U) = Empty.
{ apply Empty_eq.
  let x. assume Hx: x :e U :/\: (X :\: U).
  apply (binintersectE U (X :\: U) x Hx).
  assume HxU: x :e U.
  assume HxComp: x :e X :\: U.
  apply (setminusE X U x HxComp).
  assume _. assume HxNotU: x /:e U.
  exact (HxNotU HxU). }
claim HcompNe: (X :\: U) <> Empty.
{ assume Heq: X :\: U = Empty.
  claim HUeqX: U = X.
  { apply set_ext.
    - exact HUsub.
    - let x. assume HxX: x :e X.
      apply (xm (x :e U)).
      + assume HxU. exact HxU.
      + assume HxNotU.
        claim Hxcomp: x :e X :\: U.
        { exact (setminusI X U x HxX HxNotU). }
        claim HxEmpty: x :e Empty.
        { rewrite <- Heq. exact Hxcomp. }
        prove x :e U.
        exact (FalseE (EmptyE x HxEmpty) (x :e U)). }
  exact (HUnX HUeqX). }
claim Hunion: U :\/: (X :\: U) = X.
{ apply set_ext.
  - let x. assume Hx: x :e U :\/: (X :\: U).
    apply (binunionE U (X :\: U) x Hx).
    + assume HxU. exact (HUsub x HxU).
    + assume HxComp. exact (setminusE1 X U x HxComp).
  - let x. assume HxX: x :e X.
    apply (xm (x :e U)).
    + assume HxU. exact (binunionI1 U (X :\: U) x HxU).
    + assume HxNotU. exact (binunionI2 U (X :\: U) x (setminusI X U x HxX HxNotU)). }
prove U :e Power X /\ (X :\: U) :e Power X /\ U :/\: (X :\: U) = Empty /\ U <> Empty /\ (X :\: U) <> Empty /\ U :\/: (X :\: U) = X.
(** `separation_of` is left-associative; build the conjunction tree explicitly. **)
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      { apply andI.
        - exact HUpow.
        - exact HcompPower. }
      { exact Hdisjoint. }
    * exact HUne.
  + exact HcompNe.
- exact Hunion.
Qed.

(** from §23 Definition: connected space **) 
(** LATEX VERSION: X with topology Tx is connected if it admits no separation. **)
Definition connected_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).

(** Helper: extract topology_on from connected_space **)
Theorem connected_space_topology : forall X Tx:set,
  connected_space X Tx -> topology_on X Tx.
let X Tx.
assume H: connected_space X Tx.
exact (andEL (topology_on X Tx)
             (~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V))
             H).
Qed.

(** Helper: extract no-separation property from connected_space **)
Theorem connected_space_no_separation : forall X Tx:set,
  connected_space X Tx -> ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
let X Tx.
assume H: connected_space X Tx.
exact (andER (topology_on X Tx)
             (~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V))
             H).
Qed.

(** Helper: homeomorphisms preserve connectedness **)
Theorem homeomorphism_preserves_connected : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f ->
  connected_space X Tx ->
  connected_space Y Ty.
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
assume HX: connected_space X Tx.
prove connected_space Y Ty.
prove topology_on Y Ty /\ ~(exists U V:set, U :e Ty /\ V :e Ty /\ separation_of Y U V).
apply andI.
- exact (homeomorphism_topology_right X Tx Y Ty f Hhom).
  - assume HsepY: exists U V:set, U :e Ty /\ V :e Ty /\ separation_of Y U V.
    prove False.
    claim HnoSepX: ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
  { exact (connected_space_no_separation X Tx HX). }
  claim Hcontf: continuous_map X Tx Y Ty f.
  { exact (andEL (continuous_map X Tx Y Ty f)
                 (exists g:set, continuous_map Y Ty X Tx g /\
                   (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
                   (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
                 Hhom). }
  claim Habc: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
  { exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
                 (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                 Hcontf). }
  claim Hfunf: function_on f X Y.
  { exact (andER (topology_on X Tx /\ topology_on Y Ty)
                 (function_on f X Y)
                 Habc). }
  claim Hpreimg: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  { exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
                 (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
                 Hcontf). }
  claim Hexg:
    exists g:set, continuous_map Y Ty X Tx g /\
      (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
      (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
  { exact (andER (continuous_map X Tx Y Ty f)
                 (exists g:set, continuous_map Y Ty X Tx g /\
                   (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
                   (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y))
                 Hhom). }
  apply Hexg.
  let g. assume Hgprop.
  claim Hfg: forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y.
  { exact (andER (continuous_map Y Ty X Tx g /\
                   (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x))
                 (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y)
                 Hgprop). }
  claim Habg:
    continuous_map Y Ty X Tx g /\
      (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x).
  { exact (andEL (continuous_map Y Ty X Tx g /\
                   (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x))
                 (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y)
                 Hgprop). }
  claim Hcontg: continuous_map Y Ty X Tx g.
  { exact (andEL (continuous_map Y Ty X Tx g)
                 (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x)
                 Habg). }
  claim Habcg: (topology_on Y Ty /\ topology_on X Tx) /\ function_on g Y X.
  { exact (andEL ((topology_on Y Ty /\ topology_on X Tx) /\ function_on g Y X)
                 (forall V:set, V :e Tx -> preimage_of Y g V :e Ty)
                 Hcontg). }
  claim Hfung: function_on g Y X.
  { exact (andER (topology_on Y Ty /\ topology_on X Tx)
                 (function_on g Y X)
                 Habcg). }
  apply HsepY.
  let U. assume HexV: exists V:set, U :e Ty /\ V :e Ty /\ separation_of Y U V.
  apply HexV.
  let V. assume HUV: U :e Ty /\ V :e Ty /\ separation_of Y U V.
  set U0 := preimage_of X f U.
  set V0 := preimage_of X f V.
  claim HUVop: U :e Ty /\ V :e Ty.
  { exact (andEL (U :e Ty /\ V :e Ty) (separation_of Y U V) HUV). }
  claim HU_Ty: U :e Ty.
  { exact (andEL (U :e Ty) (V :e Ty) HUVop). }
  claim HV_Ty: V :e Ty.
  { exact (andER (U :e Ty) (V :e Ty) HUVop). }
  claim HsepYUV: separation_of Y U V.
  { exact (andER (U :e Ty /\ V :e Ty) (separation_of Y U V) HUV). }
  claim HU0Tx: U0 :e Tx.
  { exact (Hpreimg U HU_Ty). }
  claim HV0Tx: V0 :e Tx.
  { exact (Hpreimg V HV_Ty). }
  claim HsepXUV: separation_of X U0 V0.
  { prove U0 :e Power X /\ V0 :e Power X /\ U0 :/\: V0 = Empty /\ U0 <> Empty /\ V0 <> Empty /\ U0 :\/: V0 = X.
    claim HsepY0:
      (((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty.
    { exact (andEL ((((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                   (U :\/: V = Y)
                   HsepYUV). }
    claim HcoverY: U :\/: V = Y.
    { exact (andER ((((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                   (U :\/: V = Y)
                   HsepYUV). }
    claim HsepY1: ((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty.
    { exact (andEL (((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty)
                   (V <> Empty)
                   HsepY0). }
    claim HVne: V <> Empty.
    { exact (andER (((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty) /\ U <> Empty)
                   (V <> Empty)
                   HsepY0). }
    claim HsepY2: (U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty.
    { exact (andEL ((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty)
                   (U <> Empty)
                   HsepY1). }
    claim HUne: U <> Empty.
    { exact (andER ((U :e Power Y /\ V :e Power Y) /\ U :/\: V = Empty)
                   (U <> Empty)
                   HsepY1). }
    claim HUVpow: U :e Power Y /\ V :e Power Y.
    { exact (andEL (U :e Power Y /\ V :e Power Y)
                   (U :/\: V = Empty)
                   HsepY2). }
    claim HdisjY: U :/\: V = Empty.
    { exact (andER (U :e Power Y /\ V :e Power Y)
                   (U :/\: V = Empty)
                   HsepY2). }
    claim HUpow: U :e Power Y.
    { exact (andEL (U :e Power Y) (V :e Power Y) HUVpow). }
    claim HVpow: V :e Power Y.
    { exact (andER (U :e Power Y) (V :e Power Y) HUVpow). }
    claim HU0subX: U0 c= X.
    { let x. assume Hx: x :e U0.
      exact (SepE1 X (fun x0:set => apply_fun f x0 :e U) x Hx). }
    claim HV0subX: V0 c= X.
    { let x. assume Hx: x :e V0.
      exact (SepE1 X (fun x0:set => apply_fun f x0 :e V) x Hx). }
    claim HU0Pow: U0 :e Power X.
    { exact (PowerI X U0 HU0subX). }
    claim HV0Pow: V0 :e Power X.
    { exact (PowerI X V0 HV0subX). }
    claim Hdisj: U0 :/\: V0 = Empty.
    { rewrite <- (preimage_of_binintersect X f U V).
      rewrite HdisjY.
      exact (preimage_of_Empty X f). }
    claim HU0ne: U0 <> Empty.
    { apply (nonempty_has_element U HUne).
      let y. assume HyU: y :e U.
      claim HUsubY: U c= Y.
      { exact (PowerE Y U HUpow). }
      claim HyY: y :e Y.
      { exact (HUsubY y HyU). }
      claim HgyX: apply_fun g y :e X.
      { exact (Hfung y HyY). }
      claim HfgyU: apply_fun f (apply_fun g y) :e U.
      { rewrite (Hfg y HyY).
        exact HyU. }
      claim HgyPreU: apply_fun g y :e U0.
      { exact (SepI X (fun x0:set => apply_fun f x0 :e U) (apply_fun g y) HgyX HfgyU). }
      exact (elem_implies_nonempty U0 (apply_fun g y) HgyPreU). }
    claim HV0ne: V0 <> Empty.
    { apply (nonempty_has_element V HVne).
      let y. assume HyV: y :e V.
      claim HVsubY: V c= Y.
      { exact (PowerE Y V HVpow). }
      claim HyY: y :e Y.
      { exact (HVsubY y HyV). }
      claim HgyX: apply_fun g y :e X.
      { exact (Hfung y HyY). }
      claim HfgyV: apply_fun f (apply_fun g y) :e V.
      { rewrite (Hfg y HyY).
        exact HyV. }
      claim HgyPreV: apply_fun g y :e V0.
      { exact (SepI X (fun x0:set => apply_fun f x0 :e V) (apply_fun g y) HgyX HfgyV). }
      exact (elem_implies_nonempty V0 (apply_fun g y) HgyPreV). }
    claim Hunion: U0 :\/: V0 = X.
    { rewrite <- (preimage_of_binunion X f U V).
      rewrite HcoverY.
      exact (preimage_of_whole X Y f Hfunf). }
    prove (((((U0 :e Power X /\ V0 :e Power X) /\ U0 :/\: V0 = Empty) /\ U0 <> Empty) /\ V0 <> Empty) /\ U0 :\/: V0 = X).
    apply andI.
    * apply andI.
      { apply andI.
        - apply andI.
          + apply andI.
            { exact HU0Pow. }
            { exact HV0Pow. }
          + exact Hdisj.
        - exact HU0ne. }
      { exact HV0ne. }
    * exact Hunion. }
  apply HnoSepX.
  witness U0.
  witness V0.
  prove U0 :e Tx /\ V0 :e Tx /\ separation_of X U0 V0.
  apply andI.
  - apply andI.
    + exact HU0Tx.
    + exact HV0Tx.
  - exact HsepXUV.
Qed.

(** Helper theorems for connected_iff_no_nontrivial_clopen **)
Theorem clopen_gives_separation : forall X Tx A:set,
  topology_on X Tx -> A <> Empty -> A <> X ->
  open_in X Tx A -> closed_in X Tx A ->
  exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
let X Tx A.
assume HTx: topology_on X Tx.
assume HAne: A <> Empty.
assume HAneX: A <> X.
assume HAopen: open_in X Tx A.
assume HAclosed: closed_in X Tx A.
claim HATx: A :e Tx.
{ exact (andER (topology_on X Tx) (A :e Tx) HAopen). }
claim HcompOpen: open_in X Tx (X :\: A).
{ exact (open_of_closed_complement X Tx A HAclosed). }
claim HcompTx: X :\: A :e Tx.
{ exact (andER (topology_on X Tx) ((X :\: A) :e Tx) HcompOpen). }
witness A.
witness (X :\: A).
apply andI.
- apply andI.
  + exact HATx.
  + exact HcompTx.
- prove separation_of X A (X :\: A).
    prove A :e Power X /\ (X :\: A) :e Power X /\ A :/\: (X :\: A) = Empty /\ A <> Empty /\ (X :\: A) <> Empty /\ A :\/: (X :\: A) = X.
    claim HAsubX: A c= X.
    { exact (open_in_subset X Tx A HAopen). }
    claim HApower: A :e Power X.
    { exact (PowerI X A HAsubX). }
    claim HcompSubX: X :\: A c= X.
    { exact (setminus_Subq X A). }
    claim HcompPower: (X :\: A) :e Power X.
    { exact (PowerI X (X :\: A) HcompSubX). }
    claim Hdisjoint: A :/\: (X :\: A) = Empty.
    { apply Empty_eq.
      let x. assume Hx: x :e A :/\: (X :\: A).
      apply (binintersectE A (X :\: A) x Hx).
      assume HxA: x :e A.
      assume HxComp: x :e X :\: A.
      apply (setminusE X A x HxComp).
      assume _. assume HxNotA: x /:e A.
      exact (HxNotA HxA). }
    claim HcompNe: (X :\: A) <> Empty.
    { assume Heq: X :\: A = Empty.
      claim HAeqX: A = X.
      { apply set_ext.
        - exact HAsubX.
        - let x. assume HxX: x :e X.
          apply (xm (x :e A)).
          + assume HxA. exact HxA.
          + assume HxNotA.
            claim Hxcomp: x :e X :\: A.
            { exact (setminusI X A x HxX HxNotA). }
            claim HxEmpty: x :e Empty.
            { rewrite <- Heq. exact Hxcomp. }
            prove x :e A.
            exact (FalseE (EmptyE x HxEmpty) (x :e A)). }
      exact (HAneX HAeqX). }
    claim Hunion: A :\/: (X :\: A) = X.
    { apply set_ext.
      - let x. assume Hx: x :e A :\/: (X :\: A).
        apply (binunionE A (X :\: A) x Hx).
        + assume HxA. exact (HAsubX x HxA).
        + assume HxComp. exact (setminusE1 X A x HxComp).
      - let x. assume HxX: x :e X.
        apply (xm (x :e A)).
        + assume HxA. exact (binunionI1 A (X :\: A) x HxA).
        + assume HxNotA. exact (binunionI2 A (X :\: A) x (setminusI X A x HxX HxNotA)). }
    prove (((((A :e Power X /\ (X :\: A) :e Power X) /\ A :/\: (X :\: A) = Empty) /\ A <> Empty) /\ (X :\: A) <> Empty) /\ A :\/: (X :\: A) = X).
    apply andI.
    * apply andI.
      { apply andI.
        - apply andI.
          + apply andI.
            { exact HApower. }
            { exact HcompPower. }
          + exact Hdisjoint.
        - exact HAne. }
      { exact HcompNe. }
    * exact Hunion.
Qed.

Theorem separation_gives_clopen : forall X Tx U V:set,
  topology_on X Tx ->
  U :e Tx -> V :e Tx -> separation_of X U V ->
  exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A.
let X Tx U V.
assume HTx: topology_on X Tx.
assume HU: U :e Tx.
assume HV: V :e Tx.
assume Hsep: separation_of X U V.
witness U.
prove U <> Empty /\ U <> X /\ open_in X Tx U /\ closed_in X Tx U.
claim H1: (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty.
{ exact (andEL ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
               (U :\/: V = X) Hsep). }
claim H2: ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty.
{ exact (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
               (V <> Empty) H1). }
claim HUne: U <> Empty.
{ exact (andER (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)) (U <> Empty) H2). }
claim Hunion: U :\/: V = X.
{ exact (andER ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
               (U :\/: V = X) Hsep). }
claim HUneX: U <> X.
{ assume Heq: U = X.
  claim HVempty: V = Empty.
  { apply Empty_eq.
    let x. assume Hx: x :e V.
    claim HxX: x :e X.
    { rewrite <- Hunion. exact (binunionI2 U V x Hx). }
    claim HxU: x :e U.
    { rewrite Heq. exact HxX. }
    claim Hxdisj: x :e U :/\: V.
    { exact (binintersectI U V x HxU Hx). }
    claim Hdisj: U :/\: V = Empty.
    { exact (andER (U :e Power X /\ V :e Power X) (U :/\: V = Empty)
                   (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)
                          (U <> Empty) H2)). }
    claim Hfalse: x :e Empty.
    { rewrite <- Hdisj. exact Hxdisj. }
    exact (EmptyE x Hfalse). }
  claim HVne: V <> Empty.
  { exact (andER ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)) (V <> Empty) H1). }
  exact (HVne HVempty). }
claim HUopen: open_in X Tx U.
{ exact (andI (topology_on X Tx) (U :e Tx) HTx HU). }
claim Hdisj: U :/\: V = Empty.
{ exact (andER (U :e Power X /\ V :e Power X) (U :/\: V = Empty)
               (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)
                      (U <> Empty) H2)). }
claim HUpower: U :e Power X.
{ exact (andEL (U :e Power X) (V :e Power X)
               (andEL (U :e Power X /\ V :e Power X) (U :/\: V = Empty)
                      (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) (U <> Empty) H2))). }
claim HUsubX: U c= X.
{ exact (PowerE X U HUpower). }
claim Heq_comp: U = X :\: V.
{ apply set_ext.
  - let x. assume Hx: x :e U.
    prove x :e X :\: V.
    claim HxX: x :e X.
    { exact (HUsubX x Hx). }
    claim HxnotV: x /:e V.
    { assume HxV: x :e V.
      claim Hxdisj: x :e U :/\: V.
      { exact (binintersectI U V x Hx HxV). }
      claim Hfalse: x :e Empty.
      { rewrite <- Hdisj. exact Hxdisj. }
      exact (EmptyE x Hfalse). }
    exact (setminusI X V x HxX HxnotV).
  - let x. assume Hx: x :e X :\: V.
    prove x :e U.
    claim HxX: x :e X.
    { exact (setminusE1 X V x Hx). }
    claim HxnotV: x /:e V.
    { exact (setminusE2 X V x Hx). }
    claim HxUnion: x :e U :\/: V.
    { rewrite Hunion. exact HxX. }
    apply (binunionE U V x HxUnion).
    + assume HxU. exact HxU.
    + assume HxV. exact (FalseE (HxnotV HxV) (x :e U)). }
claim HUclosed: closed_in X Tx U.
{ prove topology_on X Tx /\ (U c= X /\ exists W :e Tx, U = X :\: W).
  apply andI.
  - exact HTx.
  - apply andI.
    + exact HUsubX.
    + witness V.
      apply andI.
      * exact HV.
      * exact Heq_comp. }
apply andI.
- apply andI.
  + apply andI.
    * exact HUne.
    * exact HUneX.
  + exact HUopen.
- exact HUclosed.
Qed.

(** from §23: no nontrivial clopen sets characterization **)
(** LATEX VERSION: A space is connected iff it has no nontrivial clopen subsets. **)
Theorem connected_iff_no_nontrivial_clopen : forall X Tx:set,
  topology_on X Tx ->
  (connected_space X Tx <->
  ~(exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A)).
let X Tx.
assume HTx: topology_on X Tx.
prove connected_space X Tx <-> ~(exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A).
apply iffI.
- (** Forward: connected implies no nontrivial clopen **)
  assume Hconn: connected_space X Tx.
  prove ~(exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A).
  assume Hclopen: exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A.
  (** Extract no-separation from connectedness **)
  claim Hnosep: ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
  { exact (andER (topology_on X Tx)
                 (~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V))
                 Hconn). }
  (** Clopen exists, so by axiom we get separation **)
  apply Hclopen.
  let A. assume HA.
  (** Left-associative: (((A <> Empty /\ A <> X) /\ open_in X Tx A) /\ closed_in X Tx A) **)
  claim HAne: A <> Empty.
  { exact (andEL (A <> Empty) (A <> X)
                 (andEL (A <> Empty /\ A <> X) (open_in X Tx A)
                        (andEL ((A <> Empty /\ A <> X) /\ open_in X Tx A) (closed_in X Tx A) HA))). }
  claim HAnX: A <> X.
  { exact (andER (A <> Empty) (A <> X)
                 (andEL (A <> Empty /\ A <> X) (open_in X Tx A)
                        (andEL ((A <> Empty /\ A <> X) /\ open_in X Tx A) (closed_in X Tx A) HA))). }
  claim HAopen: open_in X Tx A.
  { exact (andER (A <> Empty /\ A <> X) (open_in X Tx A)
                 (andEL ((A <> Empty /\ A <> X) /\ open_in X Tx A) (closed_in X Tx A) HA)). }
  claim HAclosed: closed_in X Tx A.
  { exact (andER ((A <> Empty /\ A <> X) /\ open_in X Tx A) (closed_in X Tx A) HA). }
  (** Apply axiom to get separation **)
  claim Hsepexists: exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
  { exact (clopen_gives_separation X Tx A HTx HAne HAnX HAopen HAclosed). }
  (** Contradiction **)
  apply Hnosep.
  exact Hsepexists.
- (** Backward: no nontrivial clopen implies connected **)
  assume Hno_clopen: ~(exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A).
  prove connected_space X Tx.
  prove topology_on X Tx /\ ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
  apply andI.
  + exact HTx.
  + prove ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
    assume Hsep: exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
    apply Hsep.
    let U. assume HsepV: exists V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
    apply HsepV.
    let V. assume HUV.
    (** Left-associative: ((U :e Tx /\ V :e Tx) /\ separation_of X U V) **)
    claim HU: U :e Tx.
    { exact (andEL (U :e Tx) (V :e Tx)
                   (andEL (U :e Tx /\ V :e Tx) (separation_of X U V) HUV)). }
    claim HV: V :e Tx.
    { exact (andER (U :e Tx) (V :e Tx)
                   (andEL (U :e Tx /\ V :e Tx) (separation_of X U V) HUV)). }
    claim Hsepof: separation_of X U V.
    { exact (andER (U :e Tx /\ V :e Tx) (separation_of X U V) HUV). }
    (** Apply axiom to get clopen from separation **)
    claim Hclopenexists: exists A:set, A <> Empty /\ A <> X /\ open_in X Tx A /\ closed_in X Tx A.
    { exact (separation_gives_clopen X Tx U V HTx HU HV Hsepof). }
    (** Contradiction **)
    apply Hno_clopen.
    exact Hclopenexists.
Qed.

(** from §23 Lemma 23.1: separations in subspaces via limit points **)
(** LATEX VERSION: If Y is a subspace of X, a separation of Y is a pair of disjoint nonempty sets A,B whose union is Y, neither containing a limit point of the other. **)
Theorem separation_subspace_limit_points : forall X Tx Y A B:set,
  topology_on X Tx -> Y c= X ->
  (((A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y) /\ separation_of Y A B)
  <->
  (separation_of Y A B
    /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b)
    /\ ~(exists a:set, a :e A /\ limit_point_of X Tx B a))).
let X Tx Y A B.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
prove (((A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y) /\ separation_of Y A B)
  <->
  (separation_of Y A B
    /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b)
    /\ ~(exists a:set, a :e A /\ limit_point_of X Tx B a))).
apply iffI.
- (** -> direction: openness in subspace implies no cross-limit-points **)
  assume Hleft.
  claim HABsub: A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y.
  { exact (andEL (A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y) (separation_of Y A B) Hleft). }
  claim HAinTy: A :e subspace_topology X Tx Y.
  { exact (andEL (A :e subspace_topology X Tx Y) (B :e subspace_topology X Tx Y) HABsub). }
  claim HBinTy: B :e subspace_topology X Tx Y.
  { exact (andER (A :e subspace_topology X Tx Y) (B :e subspace_topology X Tx Y) HABsub). }
  claim Hsep: separation_of Y A B.
  { exact (andER (A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y) (separation_of Y A B) Hleft). }
  prove separation_of Y A B
    /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b)
    /\ ~(exists a:set, a :e A /\ limit_point_of X Tx B a).
  apply andI.
  + apply andI.
    - exact Hsep.
    - (** no b in B is a limit point of A **)
      prove ~(exists b:set, b :e B /\ limit_point_of X Tx A b).
      assume Hex: exists b:set, b :e B /\ limit_point_of X Tx A b.
      prove False.
      apply Hex.
      let b. assume Hbconj.
      claim HbB: b :e B.
      { exact (andEL (b :e B) (limit_point_of X Tx A b) Hbconj). }
      claim HLP: limit_point_of X Tx A b.
      { exact (andER (b :e B) (limit_point_of X Tx A b) Hbconj). }
      (** Extract B = V ∩ Y for some V open in X **)
      claim HexV: exists V :e Tx, B = V :/\: Y.
      { exact (subspace_topologyE X Tx Y B HBinTy). }
      apply HexV.
      let V. assume HVpair.
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (B = V :/\: Y) HVpair). }
      claim HBeq: B = V :/\: Y.
      { exact (andER (V :e Tx) (B = V :/\: Y) HVpair). }
      (** Use separation_of to get A,B ⊆ Y and A∩B=∅ **)
      claim Hpart1: ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty).
      { exact (andEL ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty)
                     (A :\/: B = Y) Hsep). }
      claim HAux: (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty).
      { exact (andEL (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty)
                     (B <> Empty) Hpart1). }
      claim Hpowdisj: (A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty.
      { exact (andEL ((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) (A <> Empty) HAux). }
      claim Hpow: A :e Power Y /\ B :e Power Y.
      { exact (andEL (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
      claim Hdisj: A :/\: B = Empty.
      { exact (andER (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
      claim HApowY: A :e Power Y.
      { exact (andEL (A :e Power Y) (B :e Power Y) Hpow). }
      claim HBpowY: B :e Power Y.
      { exact (andER (A :e Power Y) (B :e Power Y) Hpow). }
      claim HAsubY: A c= Y.
      { exact (PowerE Y A HApowY). }
      claim HBsubY: B c= Y.
      { exact (PowerE Y B HBpowY). }
      (** b ∈ V **)
      claim HbVY: b :e V :/\: Y.
      { rewrite <- HBeq. exact HbB. }
      claim HbV: b :e V.
      { exact (binintersectE1 V Y b HbVY). }
      (** Apply limit point condition to neighborhood V **)
      claim HLPp: topology_on X Tx /\ b :e X.
      { exact (andEL (topology_on X Tx /\ b :e X) (forall U:set, U :e Tx -> b :e U -> exists y:set, y :e A /\ y <> b /\ y :e U) HLP). }
      claim HLPcond: forall U:set, U :e Tx -> b :e U -> exists y:set, y :e A /\ y <> b /\ y :e U.
      { exact (andER (topology_on X Tx /\ b :e X) (forall U:set, U :e Tx -> b :e U -> exists y:set, y :e A /\ y <> b /\ y :e U) HLP). }
      claim Hexy: exists y:set, y :e A /\ y <> b /\ y :e V.
      { exact (HLPcond V HVTx HbV). }
      apply Hexy.
      let y. assume Hyconj.
      claim HyAB: y :e A /\ y <> b.
      { exact (andEL (y :e A /\ y <> b) (y :e V) Hyconj). }
      claim HyA: y :e A.
      { exact (andEL (y :e A) (y <> b) HyAB). }
      claim HyV: y :e V.
      { exact (andER (y :e A /\ y <> b) (y :e V) Hyconj). }
      claim HyY: y :e Y.
      { exact (HAsubY y HyA). }
      claim HyB: y :e B.
      { rewrite HBeq. exact (binintersectI V Y y HyV HyY). }
      claim HyAB2: y :e A :/\: B.
      { exact (binintersectI A B y HyA HyB). }
      claim HyE: y :e Empty.
      { rewrite <- Hdisj. exact HyAB2. }
      exact (EmptyE y HyE).
  + (** no a in A is a limit point of B (symmetric) **)
    prove ~(exists a:set, a :e A /\ limit_point_of X Tx B a).
    assume Hex: exists a:set, a :e A /\ limit_point_of X Tx B a.
    prove False.
    apply Hex.
    let a. assume Haconj.
    claim HaA: a :e A.
    { exact (andEL (a :e A) (limit_point_of X Tx B a) Haconj). }
    claim HLP: limit_point_of X Tx B a.
    { exact (andER (a :e A) (limit_point_of X Tx B a) Haconj). }
      (** Extract A = U ∩ Y for some U open in X **)
      claim HexU: exists U :e Tx, A = U :/\: Y.
      { exact (subspace_topologyE X Tx Y A HAinTy). }
      apply HexU.
      let U. assume HUpair.
      claim HUTx: U :e Tx.
      { exact (andEL (U :e Tx) (A = U :/\: Y) HUpair). }
      claim HAeq: A = U :/\: Y.
      { exact (andER (U :e Tx) (A = U :/\: Y) HUpair). }
      (** Use separation_of to get A,B ⊆ Y and A∩B=∅ **)
      claim Hpart1: ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty).
      { exact (andEL ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty)
                     (A :\/: B = Y) Hsep). }
      claim HAux: (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty).
      { exact (andEL (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty)
                     (B <> Empty) Hpart1). }
      claim Hpowdisj: (A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty.
      { exact (andEL ((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) (A <> Empty) HAux). }
      claim Hpow: A :e Power Y /\ B :e Power Y.
      { exact (andEL (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
      claim Hdisj: A :/\: B = Empty.
      { exact (andER (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
      claim HApowY: A :e Power Y.
      { exact (andEL (A :e Power Y) (B :e Power Y) Hpow). }
      claim HBpowY: B :e Power Y.
      { exact (andER (A :e Power Y) (B :e Power Y) Hpow). }
      claim HAsubY: A c= Y.
      { exact (PowerE Y A HApowY). }
      claim HBsubY: B c= Y.
      { exact (PowerE Y B HBpowY). }
      (** a ∈ U **)
      claim HaUY: a :e U :/\: Y.
      { rewrite <- HAeq. exact HaA. }
      claim HaU: a :e U.
      { exact (binintersectE1 U Y a HaUY). }
      (** Apply limit point condition to neighborhood U **)
      claim HLPcond: forall V0:set, V0 :e Tx -> a :e V0 -> exists y:set, y :e B /\ y <> a /\ y :e V0.
      { exact (andER (topology_on X Tx /\ a :e X) (forall V0:set, V0 :e Tx -> a :e V0 -> exists y:set, y :e B /\ y <> a /\ y :e V0) HLP). }
      claim Hexy: exists y:set, y :e B /\ y <> a /\ y :e U.
      { exact (HLPcond U HUTx HaU). }
      apply Hexy.
      let y. assume Hyconj.
      claim HyBA: y :e B /\ y <> a.
      { exact (andEL (y :e B /\ y <> a) (y :e U) Hyconj). }
      claim HyB: y :e B.
      { exact (andEL (y :e B) (y <> a) HyBA). }
      claim HyU: y :e U.
      { exact (andER (y :e B /\ y <> a) (y :e U) Hyconj). }
      claim HyY: y :e Y.
      { exact (HBsubY y HyB). }
      claim HyA2: y :e A.
      { rewrite HAeq. exact (binintersectI U Y y HyU HyY). }
      claim HyAB2: y :e A :/\: B.
      { exact (binintersectI A B y HyA2 HyB). }
      claim HyE: y :e Empty.
      { rewrite <- Hdisj. exact HyAB2. }
      exact (EmptyE y HyE).
- (** <- direction: no cross-limit-points implies openness in subspace **)
  assume Hright.
  claim Htmp: separation_of Y A B /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b).
  { exact (andEL (separation_of Y A B /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b))
                 (~(exists a:set, a :e A /\ limit_point_of X Tx B a)) Hright). }
  claim Hsep: separation_of Y A B.
  { exact (andEL (separation_of Y A B) (~(exists b:set, b :e B /\ limit_point_of X Tx A b)) Htmp). }
  claim HnoB: ~(exists b:set, b :e B /\ limit_point_of X Tx A b).
  { exact (andER (separation_of Y A B) (~(exists b:set, b :e B /\ limit_point_of X Tx A b)) Htmp). }
  claim HnoA: ~(exists a:set, a :e A /\ limit_point_of X Tx B a).
  { exact (andER (separation_of Y A B /\ ~(exists b:set, b :e B /\ limit_point_of X Tx A b))
                 (~(exists a:set, a :e A /\ limit_point_of X Tx B a)) Hright). }
  (** Extract basic separation facts **)
  claim Hpart1: ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty).
  { exact (andEL ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty)
                 (A :\/: B = Y) Hsep). }
  claim Hunion: A :\/: B = Y.
  { exact (andER ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty)
                 (A :\/: B = Y) Hsep). }
  claim HAux: (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty).
  { exact (andEL (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty)
                 (B <> Empty) Hpart1). }
  claim Hpowdisj: (A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty.
  { exact (andEL ((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) (A <> Empty) HAux). }
  claim Hpow: A :e Power Y /\ B :e Power Y.
  { exact (andEL (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
  claim Hdisj: A :/\: B = Empty.
  { exact (andER (A :e Power Y /\ B :e Power Y) (A :/\: B = Empty) Hpowdisj). }
  claim HApowY: A :e Power Y.
  { exact (andEL (A :e Power Y) (B :e Power Y) Hpow). }
  claim HBpowY: B :e Power Y.
  { exact (andER (A :e Power Y) (B :e Power Y) Hpow). }
  claim HAsubY: A c= Y.
  { exact (PowerE Y A HApowY). }
  claim HBsubY: B c= Y.
  { exact (PowerE Y B HBpowY). }
  (** Topology on Y **)
  claim HtopY: topology_on Y (subspace_topology X Tx Y).
  { exact (subspace_topology_is_topology X Tx Y HTx HY). }
  (** Prove A and B are open in the subspace by local openness (ex13_1). **)
  claim HAopen_in: open_in Y (subspace_topology X Tx Y) A.
  { apply (ex13_1_local_open_subset Y (subspace_topology X Tx Y) A HtopY).
    let x. assume HxA: x :e A.
    prove exists U :e subspace_topology X Tx Y, x :e U /\ U c= A.
    (** x is not a limit point of B (otherwise contradict HnoA) **)
    claim HnotLP: ~(limit_point_of X Tx B x).
    { assume HLP.
      apply HnoA.
      witness x.
      apply andI.
      - exact HxA.
      - exact HLP. }
    claim HxY: x :e Y.
    { exact (HAsubY x HxA). }
    claim HxX: x :e X.
    { exact (HY x HxY). }
    (** Not being a limit point yields an open neighborhood W with no B-point in it. **)
    claim HnotForall: ~(forall W:set, W :e Tx -> x :e W -> exists y:set, y :e B /\ y <> x /\ y :e W).
    { assume Hforall.
      apply HnotLP.
      prove topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e B /\ y <> x /\ y :e U.
      apply andI.
      - apply andI.
        + exact HTx.
        + exact HxX.
      - exact Hforall. }
    claim HexW: exists W:set, ~(W :e Tx -> x :e W -> exists y:set, y :e B /\ y <> x /\ y :e W).
    { exact (not_all_ex_demorgan_i (fun W:set => W :e Tx -> x :e W -> exists y:set, y :e B /\ y <> x /\ y :e W) HnotForall). }
    apply HexW.
    let W. assume HnImp.
    (** Derive W ∈ Tx **)
    claim HWTx: W :e Tx.
    { apply (xm (W :e Tx)).
      - assume HW. exact HW.
      - assume HnotW.
        apply FalseE.
        apply HnImp.
        assume HW0: W :e Tx.
        assume HxW0: x :e W.
        apply FalseE.
        exact (HnotW HW0). }
    (** Derive x ∈ W **)
    claim HxW: x :e W.
    { apply (xm (x :e W)).
      - assume Hx. exact Hx.
      - assume Hnotx.
        apply FalseE.
        apply HnImp.
        assume HW0: W :e Tx.
        assume HxW0: x :e W.
        apply FalseE.
        exact (Hnotx HxW0). }
    (** Hence no y ∈ B with y ≠ x in W. **)
    claim HnoY: ~(exists y:set, y :e B /\ y <> x /\ y :e W).
    { assume Hexy.
      apply HnImp.
      assume HW0: W :e Tx.
      assume HxW0: x :e W.
      exact Hexy. }
    (** Neighborhood in subspace: U = W ∩ Y **)
    set U := W :/\: Y.
    witness U.
	    (** Bounded-exists goal is U∈Ty ∧ (x∈U ∧ U⊆A) **)
	    apply andI.
	    - (** U ∈ subspace topology with witness W **)
	      prove U :e subspace_topology X Tx Y.
	      exact (subspace_topologyI X Tx Y W HWTx).
	    - (** x ∈ U ∧ U ⊆ A **)
	      apply andI.
	      + exact (binintersectI W Y x HxW HxY).
      + (** U ⊆ A since U ⊆ Y and disjoint from B, and A ∪ B = Y **)
        prove U c= A.
        let t. assume Ht: t :e U.
        prove t :e A.
        claim HtY: t :e Y.
        { exact (binintersectE2 W Y t Ht). }
        (** show t ∉ B using HnoY **)
        claim HtnotB: t /:e B.
        { assume HtB: t :e B.
          apply HnoY.
          witness t.
          prove (t :e B /\ t <> x) /\ t :e W.
          apply andI.
          - apply andI.
            + exact HtB.
            + (** t <> x since x ∈ A and A ∩ B = ∅ **)
              assume Heq: t = x.
              claim HxB: x :e B.
              { rewrite <- Heq. exact HtB. }
              claim HxAB: x :e A :/\: B.
              { exact (binintersectI A B x HxA HxB). }
              claim HxE: x :e Empty.
              { rewrite <- Hdisj. exact HxAB. }
              exact (EmptyE x HxE).
          - (** t ∈ W **)
            exact (binintersectE1 W Y t Ht). }
        (** From t ∈ Y, get t ∈ A ∪ B, then eliminate the B case. **)
        claim HtAB: t :e A :\/: B.
        { rewrite Hunion. exact HtY. }
        apply (binunionE A B t HtAB).
        * assume HtA. exact HtA.
        * assume HtB.
          apply FalseE.
          exact (HtnotB HtB). }
  claim HATy: A :e subspace_topology X Tx Y.
  { exact (andER (topology_on Y (subspace_topology X Tx Y)) (A :e subspace_topology X Tx Y) HAopen_in). }
  claim HBopen_in: open_in Y (subspace_topology X Tx Y) B.
  { apply (ex13_1_local_open_subset Y (subspace_topology X Tx Y) B HtopY).
    let x. assume HxB: x :e B.
    prove exists U :e subspace_topology X Tx Y, x :e U /\ U c= B.
    claim HnotLP: ~(limit_point_of X Tx A x).
    { assume HLP.
      apply HnoB.
      witness x.
      apply andI.
      - exact HxB.
      - exact HLP. }
    claim HxY: x :e Y.
    { exact (HBsubY x HxB). }
    claim HxX: x :e X.
    { exact (HY x HxY). }
    claim HnotForall: ~(forall W:set, W :e Tx -> x :e W -> exists y:set, y :e A /\ y <> x /\ y :e W).
    { assume Hforall.
      apply HnotLP.
      prove topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
      apply andI.
      - apply andI.
        + exact HTx.
        + exact HxX.
      - exact Hforall. }
    claim HexW: exists W:set, ~(W :e Tx -> x :e W -> exists y:set, y :e A /\ y <> x /\ y :e W).
    { exact (not_all_ex_demorgan_i (fun W:set => W :e Tx -> x :e W -> exists y:set, y :e A /\ y <> x /\ y :e W) HnotForall). }
    apply HexW.
    let W. assume HnImp.
    claim HWTx: W :e Tx.
    { apply (xm (W :e Tx)).
      - assume HW. exact HW.
      - assume HnotW.
        apply FalseE.
        apply HnImp.
        assume HW0: W :e Tx.
        assume HxW0: x :e W.
        apply FalseE.
        exact (HnotW HW0). }
    claim HxW: x :e W.
    { apply (xm (x :e W)).
      - assume Hx. exact Hx.
      - assume Hnotx.
        apply FalseE.
        apply HnImp.
        assume HW0: W :e Tx.
        assume HxW0: x :e W.
        apply FalseE.
        exact (Hnotx HxW0). }
    claim HnoY: ~(exists y:set, y :e A /\ y <> x /\ y :e W).
    { assume Hexy.
      apply HnImp.
      assume HW0: W :e Tx.
      assume HxW0: x :e W.
      exact Hexy. }
    set U := W :/\: Y.
    witness U.
	    (** Bounded-exists goal is U∈Ty ∧ (x∈U ∧ U⊆B) **)
	    apply andI.
	    - (** U ∈ subspace topology **)
	      prove U :e subspace_topology X Tx Y.
	      exact (subspace_topologyI X Tx Y W HWTx).
	    - (** x ∈ U ∧ U ⊆ B **)
	      apply andI.
	      + exact (binintersectI W Y x HxW HxY).
      + prove U c= B.
        let t. assume Ht: t :e U.
        prove t :e B.
        claim HtY: t :e Y.
        { exact (binintersectE2 W Y t Ht). }
        claim HtnotA: t /:e A.
        { assume HtA: t :e A.
          apply HnoY.
          witness t.
          prove (t :e A /\ t <> x) /\ t :e W.
          apply andI.
          - apply andI.
            + exact HtA.
            + assume Heq: t = x.
              claim HxA: x :e A.
              { rewrite <- Heq. exact HtA. }
              claim HxAB: x :e A :/\: B.
              { exact (binintersectI A B x HxA HxB). }
              claim HxE: x :e Empty.
              { rewrite <- Hdisj. exact HxAB. }
              exact (EmptyE x HxE).
          - exact (binintersectE1 W Y t Ht). }
        claim HtAB: t :e A :\/: B.
        { rewrite Hunion. exact HtY. }
        apply (binunionE A B t HtAB).
        * assume HtA.
          apply FalseE.
          exact (HtnotA HtA).
        * assume HtB. exact HtB. }
  claim HBTy: B :e subspace_topology X Tx Y.
  { exact (andER (topology_on Y (subspace_topology X Tx Y)) (B :e subspace_topology X Tx Y) HBopen_in). }
  prove (A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y) /\ separation_of Y A B.
  apply andI.
  + apply andI.
    * exact HATy.
    * exact HBTy.
  + exact Hsep.
Qed.

(** from §23 Lemma 23.2: connected subspace lies in one side of a separation **)
(** LATEX VERSION: If C and D form a separation of X and Y is a connected subspace of X, then Y lies entirely within either C or D. **)
Theorem connected_subset_in_separation_side : forall X Tx C D Y:set,
  topology_on X Tx -> Y c= X ->
  connected_space Y (subspace_topology X Tx Y) ->
  C :e Tx -> D :e Tx -> separation_of X C D ->
  Y c= C \/ Y c= D.
let X Tx C D Y.
assume HTx: topology_on X Tx.
assume HYX: Y c= X.
assume HY: connected_space Y (subspace_topology X Tx Y).
assume HC: C :e Tx.
assume HD: D :e Tx.
assume Hsep: separation_of X C D.
prove Y c= C \/ Y c= D.
(** Proof by contradiction: if Y meets both C and D, then (C∩Y) and (D∩Y) separate Y. **)
apply (xm (Y c= C)).
- assume HYC: Y c= C.
  apply orIL.
  exact HYC.
- assume HnotYcC: ~(Y c= C).
  apply (xm (Y c= D)).
  + assume HYD: Y c= D.
    apply orIR.
    exact HYD.
  + assume HnotYcD: ~(Y c= D).
    (** Get yD in Y∩D from not(Y⊆C) and C∪D=X **)
    claim HexYnotC: exists y:set, y :e Y /\ y /:e C.
    { claim Hex: exists y:set, ~(y :e Y -> y :e C).
      { exact (not_all_ex_demorgan_i (fun y:set => y :e Y -> y :e C) HnotYcC). }
      apply Hex.
      let y. assume Hnotimp.
      (** From ~(P -> Q), derive P and ~Q by contradiction. **)
      claim HyY: y :e Y.
      { apply (xm (y :e Y)).
        - assume HyY. exact HyY.
        - assume HyNotY.
          apply FalseE.
          apply Hnotimp.
          assume HyY: y :e Y.
          apply FalseE.
          exact (HyNotY HyY). }
      claim HyNotC: y /:e C.
      { assume HyC: y :e C.
        apply Hnotimp.
        assume _: y :e Y.
        exact HyC. }
      witness y.
      apply andI.
      - exact HyY.
      - exact HyNotC. }
    apply HexYnotC.
    let yD. assume HyDpair.
    claim HyDY: yD :e Y.
    { exact (andEL (yD :e Y) (yD /:e C) HyDpair). }
    claim HyDnotC: yD /:e C.
    { exact (andER (yD :e Y) (yD /:e C) HyDpair). }
    (** Extract union C∪D=X and C,D subset X from separation_of **)
    claim Hsep_left: ((((C :e Power X /\ D :e Power X) /\ C :/\: D = Empty) /\ C <> Empty) /\ D <> Empty).
    { exact (andEL ((((C :e Power X /\ D :e Power X) /\ C :/\: D = Empty) /\ C <> Empty) /\ D <> Empty)
                   (C :\/: D = X) Hsep). }
    claim Hsep_pow_disj: (C :e Power X /\ D :e Power X) /\ C :/\: D = Empty.
    { exact (andEL ((C :e Power X /\ D :e Power X) /\ C :/\: D = Empty)
                   (C <> Empty)
                   (andEL (((C :e Power X /\ D :e Power X) /\ C :/\: D = Empty) /\ C <> Empty)
                          (D <> Empty) Hsep_left)). }
    claim HCpow: C :e Power X.
    { exact (andEL (C :e Power X) (D :e Power X)
                   (andEL (C :e Power X /\ D :e Power X) (C :/\: D = Empty) Hsep_pow_disj)). }
    claim HDpow: D :e Power X.
    { exact (andER (C :e Power X) (D :e Power X)
                   (andEL (C :e Power X /\ D :e Power X) (C :/\: D = Empty) Hsep_pow_disj)). }
    claim HCsubX: C c= X.
    { exact (PowerE X C HCpow). }
    claim HDsubX: D c= X.
    { exact (PowerE X D HDpow). }
    claim HunionCD: C :\/: D = X.
    { exact (andER ((((C :e Power X /\ D :e Power X) /\ C :/\: D = Empty) /\ C <> Empty) /\ D <> Empty)
                   (C :\/: D = X) Hsep). }
    claim HyDX: yD :e X.
    { exact (HYX yD HyDY). }
    claim HyDinCD: yD :e C :\/: D.
    { rewrite HunionCD. exact HyDX. }
    claim HyDinD: yD :e D.
    { apply (binunionE C D yD HyDinCD).
      - assume HyDC: yD :e C.
        apply FalseE.
        exact (HyDnotC HyDC).
      - assume HyDD: yD :e D.
        exact HyDD. }

    (** Get yC in Y∩C from not(Y⊆D) and C∪D=X **)
    claim HexYnotD: exists y:set, y :e Y /\ y /:e D.
    { claim Hex: exists y:set, ~(y :e Y -> y :e D).
      { exact (not_all_ex_demorgan_i (fun y:set => y :e Y -> y :e D) HnotYcD). }
      apply Hex.
      let y. assume Hnotimp.
      claim HyY: y :e Y.
      { apply (xm (y :e Y)).
        - assume HyY. exact HyY.
        - assume HyNotY.
          apply FalseE.
          apply Hnotimp.
          assume HyY: y :e Y.
          apply FalseE.
          exact (HyNotY HyY). }
      claim HyNotD: y /:e D.
      { assume HyD: y :e D.
        apply Hnotimp.
        assume _: y :e Y.
        exact HyD. }
      witness y.
      apply andI.
      - exact HyY.
      - exact HyNotD. }
    apply HexYnotD.
    let yC. assume HyCpair.
    claim HyCY: yC :e Y.
    { exact (andEL (yC :e Y) (yC /:e D) HyCpair). }
    claim HyCnotD: yC /:e D.
    { exact (andER (yC :e Y) (yC /:e D) HyCpair). }
    claim HyCX: yC :e X.
    { exact (HYX yC HyCY). }
    claim HyCinCD: yC :e C :\/: D.
    { rewrite HunionCD. exact HyCX. }
    claim HyCinC: yC :e C.
    { apply (binunionE C D yC HyCinCD).
      - assume HyCC: yC :e C.
        exact HyCC.
      - assume HyCD: yC :e D.
        apply FalseE.
        exact (HyCnotD HyCD). }

    (** Define A = C∩Y and B = D∩Y; show they are open in the subspace topology and form a separation of Y **)
    set A := C :/\: Y.
    set B := D :/\: Y.
    claim HAYsub: A c= Y.
    { exact (binintersect_Subq_2 C Y). }
    claim HBYsub: B c= Y.
    { exact (binintersect_Subq_2 D Y). }
    claim HAopenY: open_in Y (subspace_topology X Tx Y) A.
    { apply (iffER (open_in Y (subspace_topology X Tx Y) A)
                   (exists V :e Tx, A = V :/\: Y)
                   (open_in_subspace_iff X Tx Y A HTx HYX HAYsub)).
      witness C.
      apply andI.
      - exact HC.
      - prove A = C :/\: Y.
        reflexivity. }
    claim HBopenY: open_in Y (subspace_topology X Tx Y) B.
    { apply (iffER (open_in Y (subspace_topology X Tx Y) B)
                   (exists V :e Tx, B = V :/\: Y)
                   (open_in_subspace_iff X Tx Y B HTx HYX HBYsub)).
      witness D.
      apply andI.
      - exact HD.
      - prove B = D :/\: Y.
        reflexivity. }
    claim HAinSub: A :e subspace_topology X Tx Y.
    { exact (andER (topology_on Y (subspace_topology X Tx Y)) (A :e subspace_topology X Tx Y) HAopenY). }
    claim HBinSub: B :e subspace_topology X Tx Y.
    { exact (andER (topology_on Y (subspace_topology X Tx Y)) (B :e subspace_topology X Tx Y) HBopenY). }
    (** separation_of Y A B **)
    claim HsepAB: separation_of Y A B.
    { prove A :e Power Y /\ B :e Power Y /\ A :/\: B = Empty /\ A <> Empty /\ B <> Empty /\ A :\/: B = Y.
      apply andI.
      - prove ((((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty) /\ B <> Empty).
        apply andI.
        + prove (((A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty) /\ A <> Empty).
          apply andI.
          - prove (A :e Power Y /\ B :e Power Y) /\ A :/\: B = Empty.
            apply andI.
            + prove A :e Power Y /\ B :e Power Y.
              apply andI.
              - exact (PowerI Y A HAYsub).
              - exact (PowerI Y B HBYsub).
            + prove A :/\: B = Empty.
              apply Empty_eq.
              let t. assume Ht: t :e A :/\: B.
              apply (binintersectE A B t Ht).
              assume HtA: t :e A.
              assume HtB: t :e B.
              (** t in C and D, so t in C∩D, contradiction **)
              claim HtC: t :e C.
              { exact (binintersectE1 C Y t HtA). }
              claim HtD: t :e D.
              { exact (binintersectE1 D Y t HtB). }
              claim HtCD: t :e C :/\: D.
              { exact (binintersectI C D t HtC HtD). }
              claim HCDdisj: C :/\: D = Empty.
              { exact (andER (C :e Power X /\ D :e Power X) (C :/\: D = Empty) Hsep_pow_disj). }
              claim Hfalse: t :e Empty.
              { rewrite <- HCDdisj. exact HtCD. }
              exact (EmptyE t Hfalse).
          - (** A <> Empty using yC **)
            assume Heq: A = Empty.
            claim HyCA: yC :e A.
            { exact (binintersectI C Y yC HyCinC HyCY). }
            claim HyCEmpty: yC :e Empty.
            { rewrite <- Heq. exact HyCA. }
            exact (EmptyE yC HyCEmpty).
        + (** B <> Empty using yD **)
          assume Heq: B = Empty.
          claim HyDB: yD :e B.
          { exact (binintersectI D Y yD HyDinD HyDY). }
          claim HyDEmpty: yD :e Empty.
          { rewrite <- Heq. exact HyDB. }
          exact (EmptyE yD HyDEmpty).
      - prove A :\/: B = Y.
        apply set_ext.
        + let t. assume Ht: t :e A :\/: B.
          prove t :e Y.
          apply (binunionE A B t Ht).
          - assume HtA: t :e A.
            exact (binintersectE2 C Y t HtA).
          - assume HtB: t :e B.
            exact (binintersectE2 D Y t HtB).
        + let t. assume HtY: t :e Y.
          prove t :e A :\/: B.
          claim HtX: t :e X.
          { exact (HYX t HtY). }
          claim HtCD: t :e C :\/: D.
          { rewrite HunionCD. exact HtX. }
          apply (binunionE C D t HtCD).
          - assume HtC: t :e C.
            apply binunionI1.
            exact (binintersectI C Y t HtC HtY).
          - assume HtD: t :e D.
            apply binunionI2.
            exact (binintersectI D Y t HtD HtY). }
    (** Contradiction with connectedness of Y **)
    claim HnosepY: ~(exists U V:set,
      U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\ separation_of Y U V).
    { exact (andER (topology_on Y (subspace_topology X Tx Y))
                   (~(exists U V:set, U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\ separation_of Y U V))
                   HY). }
    apply FalseE.
    apply HnosepY.
    witness A.
    witness B.
    prove A :e subspace_topology X Tx Y /\ B :e subspace_topology X Tx Y /\ separation_of Y A B.
    apply andI.
    - apply andI.
      + exact HAinSub.
      + exact HBinSub.
    - exact HsepAB.
Qed.

(** from §23 Theorem 23.3: union of connected sets with common point is connected **)
(** LATEX VERSION: If each Aα is connected and the Aα have a point in common, then their union is connected. **)
Theorem union_connected_common_point : forall X Tx F:set,
  topology_on X Tx ->
  (forall C:set, C :e F -> C c= X) ->
  (forall C:set, C :e F -> connected_space C (subspace_topology X Tx C)) ->
  (exists x:set, forall C:set, C :e F -> x :e C) ->
  connected_space (Union F) (subspace_topology X Tx (Union F)).
let X Tx F.
assume HTx: topology_on X Tx.
assume HFsub: forall C:set, C :e F -> C c= X.
assume HF: forall C:set, C :e F -> connected_space C (subspace_topology X Tx C).
assume Hcommon: exists x:set, forall C:set, C :e F -> x :e C.
prove connected_space (Union F) (subspace_topology X Tx (Union F)).
prove topology_on (Union F) (subspace_topology X Tx (Union F)) /\
  ~(exists U V:set, U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F) /\ separation_of (Union F) U V).
(** Precompute Union(F) ⊆ X so we can use subspace topology lemmas. **)
claim HFpow: F c= Power X.
{ let C. assume HC: C :e F.
  prove C :e Power X.
  exact (PowerI X C (HFsub C HC)). }
claim HUnionSubX: Union F c= X.
{ exact (Union_Power X F HFpow). }
claim HtopUnion: topology_on (Union F) (subspace_topology X Tx (Union F)).
{ exact (subspace_topology_is_topology X Tx (Union F) HTx HUnionSubX). }
apply andI.
- exact HtopUnion.
- prove ~(exists U V:set, U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F) /\ separation_of (Union F) U V).
  assume HsepExists: exists U V:set, U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F) /\ separation_of (Union F) U V.
  prove False.
  (** Choose the common point x0. **)
  apply Hcommon.
  let x0. assume Hx0All: forall C:set, C :e F -> x0 :e C.
  (** Unpack the supposed separation. **)
  apply HsepExists.
  let U. assume HexV: exists V:set, U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F) /\ separation_of (Union F) U V.
  apply HexV.
  let V. assume HUVsep.
  claim HUVopen: U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F).
  { exact (andEL (U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F))
                 (separation_of (Union F) U V) HUVsep). }
  claim HUopen: U :e subspace_topology X Tx (Union F).
  { exact (andEL (U :e subspace_topology X Tx (Union F)) (V :e subspace_topology X Tx (Union F)) HUVopen). }
  claim HVopen: V :e subspace_topology X Tx (Union F).
  { exact (andER (U :e subspace_topology X Tx (Union F)) (V :e subspace_topology X Tx (Union F)) HUVopen). }
  claim Hsep: separation_of (Union F) U V.
  { exact (andER (U :e subspace_topology X Tx (Union F) /\ V :e subspace_topology X Tx (Union F))
                 (separation_of (Union F) U V) HUVsep). }
  (** Extract useful facts from separation_of. **)
  claim Hpart1: ((((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = Union F) Hsep). }
  claim Hunion: U :\/: V = Union F.
  { exact (andER ((((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = Union F) Hsep). }
  claim HAux: (((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty).
  { exact (andEL (((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hpart1). }
  claim HVne: V <> Empty.
  { exact (andER (((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hpart1). }
  claim Hpowdisj: (U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty)
                 (U <> Empty) HAux). }
  claim HUne: U <> Empty.
  { exact (andER ((U :e Power (Union F) /\ V :e Power (Union F)) /\ U :/\: V = Empty)
                 (U <> Empty) HAux). }
  claim Hpow: U :e Power (Union F) /\ V :e Power (Union F).
  { exact (andEL (U :e Power (Union F) /\ V :e Power (Union F)) (U :/\: V = Empty) Hpowdisj). }
  claim Hdisj: U :/\: V = Empty.
  { exact (andER (U :e Power (Union F) /\ V :e Power (Union F)) (U :/\: V = Empty) Hpowdisj). }
  claim HUpow: U :e Power (Union F).
  { exact (andEL (U :e Power (Union F)) (V :e Power (Union F)) Hpow). }
  claim HVpow: V :e Power (Union F).
  { exact (andER (U :e Power (Union F)) (V :e Power (Union F)) Hpow). }
  claim HUsub: U c= Union F.
  { exact (PowerE (Union F) U HUpow). }
  claim HVsub: V c= Union F.
  { exact (PowerE (Union F) V HVpow). }
  (** Get some point v0 in V, hence in Union(F), hence in some member C0 of F. **)
  claim Hexv0: exists v0:set, v0 :e V.
  { exact (nonempty_has_element V HVne). }
  apply Hexv0.
  let v0. assume Hv0V: v0 :e V.
  claim Hv0Union: v0 :e Union F.
  { exact (HVsub v0 Hv0V). }
  apply (UnionE_impred F v0 Hv0Union).
  let C0. assume Hv0C0: v0 :e C0. assume HC0F: C0 :e F.
  claim Hx0C0: x0 :e C0.
  { exact (Hx0All C0 HC0F). }
  claim Hx0Union: x0 :e Union F.
  { exact (UnionI F x0 C0 Hx0C0 HC0F). }
  (** Now x0 is in U or V, by U ∪ V = Union(F). **)
  claim Hx0UV: x0 :e U :\/: V.
  { rewrite Hunion. exact Hx0Union. }
  apply (binunionE U V x0 Hx0UV).
  - (** Case: x0 ∈ U **)
    assume Hx0U: x0 :e U.
    (** Show Union(F) ⊆ U by showing each C ∈ F is contained in U. **)
    claim HUnionSubU: Union F c= U.
    { let y. assume HyUnion: y :e Union F.
      prove y :e U.
      apply (UnionE_impred F y HyUnion (y :e U)).
      let C. assume HyC: y :e C. assume HC: C :e F.
      (** C ⊆ Union(F) **)
      claim HCsubUnion: C c= Union F.
      { let z. assume Hz: z :e C.
        exact (UnionI F z C Hz HC). }
      (** Connectedness of C as a subspace of Union(F) **)
      claim HeqTop: subspace_topology (Union F) (subspace_topology X Tx (Union F)) C =
                    subspace_topology X Tx C.
      { exact (ex16_1_subspace_transitive X Tx (Union F) C HTx HUnionSubX HCsubUnion). }
      claim HCconn: connected_space C (subspace_topology (Union F) (subspace_topology X Tx (Union F)) C).
      { rewrite HeqTop. exact (HF C HC). }
      claim HCside: C c= U \/ C c= V.
      { exact (connected_subset_in_separation_side (Union F) (subspace_topology X Tx (Union F)) U V C
                HtopUnion HCsubUnion HCconn HUopen HVopen Hsep). }
      apply HCside.
      + assume HCsubU: C c= U.
        exact (HCsubU y HyC).
      + assume HCsubV: C c= V.
        (** Contradiction with disjointness, since x0 ∈ C and x0 ∈ U. **)
        claim Hx0C: x0 :e C.
        { exact (Hx0All C HC). }
        claim Hx0V: x0 :e V.
        { exact (HCsubV x0 Hx0C). }
        claim Hx0UV2: x0 :e U :/\: V.
        { exact (binintersectI U V x0 Hx0U Hx0V). }
        claim Hx0E: x0 :e Empty.
        { rewrite <- Hdisj. exact Hx0UV2. }
        apply FalseE.
        exact (EmptyE x0 Hx0E). }
    (** If Union(F) ⊆ U, then V ⊆ U; but U∩V=∅, so V=∅, contradicting V≠∅. **)
    claim HVsubU: V c= U.
    { let y. assume HyV: y :e V.
      exact (HUnionSubU y (HVsub y HyV)). }
    claim HVsubEmpty: V c= Empty.
    { let y. assume HyV: y :e V.
      prove y :e Empty.
      claim HyU: y :e U.
      { exact (HVsubU y HyV). }
      claim HyUV: y :e U :/\: V.
      { exact (binintersectI U V y HyU HyV). }
      rewrite <- Hdisj.
      exact HyUV. }
    claim HVEmpty: V = Empty.
    { exact (Empty_Subq_eq V HVsubEmpty). }
    exact (HVne HVEmpty).
  - (** Case: x0 ∈ V (symmetric) **)
    assume Hx0V: x0 :e V.
    claim HUnionSubV: Union F c= V.
    { let y. assume HyUnion: y :e Union F.
      prove y :e V.
      apply (UnionE_impred F y HyUnion (y :e V)).
      let C. assume HyC: y :e C. assume HC: C :e F.
      claim HCsubUnion: C c= Union F.
      { let z. assume Hz: z :e C.
        exact (UnionI F z C Hz HC). }
      claim HeqTop: subspace_topology (Union F) (subspace_topology X Tx (Union F)) C =
                    subspace_topology X Tx C.
      { exact (ex16_1_subspace_transitive X Tx (Union F) C HTx HUnionSubX HCsubUnion). }
      claim HCconn: connected_space C (subspace_topology (Union F) (subspace_topology X Tx (Union F)) C).
      { rewrite HeqTop. exact (HF C HC). }
      claim HCside: C c= U \/ C c= V.
      { exact (connected_subset_in_separation_side (Union F) (subspace_topology X Tx (Union F)) U V C
                HtopUnion HCsubUnion HCconn HUopen HVopen Hsep). }
      apply HCside.
      + assume HCsubU: C c= U.
        claim Hx0C: x0 :e C.
        { exact (Hx0All C HC). }
        claim Hx0U: x0 :e U.
        { exact (HCsubU x0 Hx0C). }
        claim Hx0UV2: x0 :e U :/\: V.
        { exact (binintersectI U V x0 Hx0U Hx0V). }
        claim Hx0E: x0 :e Empty.
        { rewrite <- Hdisj. exact Hx0UV2. }
        apply FalseE.
        exact (EmptyE x0 Hx0E).
      + assume HCsubV: C c= V.
        exact (HCsubV y HyC). }
    claim HUne: U <> Empty.
    { exact HUne. }
    claim HUsubV: U c= V.
    { let y. assume HyU: y :e U.
      (** U ⊆ Union(F) by HUsub, and Union(F) ⊆ V by HUnionSubV **)
      exact (HUnionSubV y (HUsub y HyU)). }
    claim HUsubEmpty: U c= Empty.
    { let y. assume HyU: y :e U.
      prove y :e Empty.
      claim HyV: y :e V.
      { exact (HUsubV y HyU). }
      claim HyUV: y :e U :/\: V.
      { exact (binintersectI U V y HyU HyV). }
      rewrite <- Hdisj.
      exact HyUV. }
    claim HUEmpty: U = Empty.
    { exact (Empty_Subq_eq U HUsubEmpty). }
    exact (HUne HUEmpty).
Qed.

(** from §23 Theorem 23.4: adjoining limit points preserves connectedness **)
(** LATEX VERSION: If A is connected and A ⊂ B ⊂ cl(A), then B is connected. **)
Theorem connected_with_limit_points : forall X Tx A B:set,
  topology_on X Tx -> A c= X -> B c= X ->
  connected_space A (subspace_topology X Tx A) ->
  A c= B -> B c= closure_of X Tx A ->
  connected_space B (subspace_topology X Tx B).
let X Tx A B.
assume HTx: topology_on X Tx.
assume HAX: A c= X.
assume HBX: B c= X.
assume HA: connected_space A (subspace_topology X Tx A).
assume HAB: A c= B.
assume HBcl: B c= closure_of X Tx A.
prove connected_space B (subspace_topology X Tx B).
prove topology_on B (subspace_topology X Tx B) /\
  ~(exists U V:set, U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B /\ separation_of B U V).
claim HtopB: topology_on B (subspace_topology X Tx B).
{ exact (subspace_topology_is_topology X Tx B HTx HBX). }
apply andI.
- exact HtopB.
- prove ~(exists U V:set, U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B /\ separation_of B U V).
  assume HsepExists: exists U V:set, U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B /\ separation_of B U V.
  prove False.
  apply HsepExists.
  let U. assume HexV: exists V:set, U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B /\ separation_of B U V.
  apply HexV.
  let V. assume HUVsep.
  claim HUVopen: U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B.
  { exact (andEL (U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B) (separation_of B U V) HUVsep). }
  claim HUopen: U :e subspace_topology X Tx B.
  { exact (andEL (U :e subspace_topology X Tx B) (V :e subspace_topology X Tx B) HUVopen). }
  claim HVopen: V :e subspace_topology X Tx B.
  { exact (andER (U :e subspace_topology X Tx B) (V :e subspace_topology X Tx B) HUVopen). }
  claim Hsep: separation_of B U V.
  { exact (andER (U :e subspace_topology X Tx B /\ V :e subspace_topology X Tx B) (separation_of B U V) HUVsep). }
  (** Parts of the separation **)
  claim Hpart1: ((((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = B) Hsep). }
  claim HAux: (((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) /\ U <> Empty).
  { exact (andEL (((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hpart1). }
  claim HVne: V <> Empty.
  { exact (andER (((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hpart1). }
  claim HUne: U <> Empty.
  { exact (andER ((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) (U <> Empty) HAux). }
  claim Hpowdisj: (U :e Power B /\ V :e Power B) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power B /\ V :e Power B) /\ U :/\: V = Empty) (U <> Empty) HAux). }
  claim Hpow: U :e Power B /\ V :e Power B.
  { exact (andEL (U :e Power B /\ V :e Power B) (U :/\: V = Empty) Hpowdisj). }
  claim Hdisj: U :/\: V = Empty.
  { exact (andER (U :e Power B /\ V :e Power B) (U :/\: V = Empty) Hpowdisj). }
  claim HUpow: U :e Power B.
  { exact (andEL (U :e Power B) (V :e Power B) Hpow). }
  claim HVpow: V :e Power B.
  { exact (andER (U :e Power B) (V :e Power B) Hpow). }
  claim HUsubB: U c= B.
  { exact (PowerE B U HUpow). }
  claim HVsubB: V c= B.
  { exact (PowerE B V HVpow). }
  (** Connectedness of A as a subspace of B (rewrite via subspace transitivity). **)
  claim HeqTopA: subspace_topology B (subspace_topology X Tx B) A = subspace_topology X Tx A.
  { exact (ex16_1_subspace_transitive X Tx B A HTx HBX HAB). }
  claim HAconnB: connected_space A (subspace_topology B (subspace_topology X Tx B) A).
  { rewrite HeqTopA. exact HA. }
  (** Apply Lemma 23.2 inside the space B. **)
  claim HA_side: A c= U \/ A c= V.
  { exact (connected_subset_in_separation_side B (subspace_topology X Tx B) U V A
            HtopB HAB HAconnB HUopen HVopen Hsep). }
  apply HA_side.
  - (** Case A ⊆ U: then V must be empty using B ⊆ cl(A). **)
    assume HAU: A c= U.
    (** Pick v ∈ V. **)
    claim Hexv: exists v:set, v :e V.
    { exact (nonempty_has_element V HVne). }
    apply Hexv.
    let v. assume HvV: v :e V.
    claim HvB: v :e B.
    { exact (HVsubB v HvV). }
    claim Hvcl: v :e closure_of X Tx A.
    { exact (HBcl v HvB). }
    (** V open in the subspace, so V = W ∩ B for some W open in X. **)
    claim HexW: exists W :e Tx, V = W :/\: B.
    { exact (SepE2 (Power B) (fun V0:set => exists W :e Tx, V0 = W :/\: B) V HVopen). }
    apply HexW.
    let W. assume HWpair.
    claim HWopen: W :e Tx.
    { exact (andEL (W :e Tx) (V = W :/\: B) HWpair). }
    claim HVeql: V = W :/\: B.
    { exact (andER (W :e Tx) (V = W :/\: B) HWpair). }
    claim HvWB: v :e W :/\: B.
    { rewrite <- HVeql. exact HvV. }
    claim HvW: v :e W.
    { exact (binintersectE1 W B v HvWB). }
    (** Use closure definition: W ∩ A ≠ ∅ **)
    claim Hclcond: forall U0:set, U0 :e Tx -> v :e U0 -> U0 :/\: A <> Empty.
    { exact (SepE2 X (fun x0 => forall U0:set, U0 :e Tx -> x0 :e U0 -> U0 :/\: A <> Empty) v Hvcl). }
    claim HWAnE: W :/\: A <> Empty.
    { exact (Hclcond W HWopen HvW). }
    (** Choose a ∈ W ∩ A. **)
    apply (nonempty_has_element (W :/\: A) HWAnE).
    let a. assume HaWA: a :e W :/\: A.
    claim HaW: a :e W.
    { exact (binintersectE1 W A a HaWA). }
    claim HaA: a :e A.
    { exact (binintersectE2 W A a HaWA). }
    claim HaB: a :e B.
    { exact (HAB a HaA). }
    claim HaWB: a :e W :/\: B.
    { exact (binintersectI W B a HaW HaB). }
    claim HaV: a :e V.
    { rewrite HVeql. exact HaWB. }
    claim HaU: a :e U.
    { exact (HAU a HaA). }
    claim HaUV: a :e U :/\: V.
    { exact (binintersectI U V a HaU HaV). }
    claim HaE: a :e Empty.
    { rewrite <- Hdisj. exact HaUV. }
    exact (EmptyE a HaE).
  - (** Case A ⊆ V: symmetric, U must be empty. **)
    assume HAV: A c= V.
    claim Hexu: exists u:set, u :e U.
    { exact (nonempty_has_element U HUne). }
    apply Hexu.
    let u. assume HuU: u :e U.
    claim HuB: u :e B.
    { exact (HUsubB u HuU). }
    claim Hucl: u :e closure_of X Tx A.
    { exact (HBcl u HuB). }
    claim HexW: exists W :e Tx, U = W :/\: B.
    { exact (SepE2 (Power B) (fun U0:set => exists W :e Tx, U0 = W :/\: B) U HUopen). }
    apply HexW.
    let W. assume HWpair.
    claim HWopen: W :e Tx.
    { exact (andEL (W :e Tx) (U = W :/\: B) HWpair). }
    claim HUeql: U = W :/\: B.
    { exact (andER (W :e Tx) (U = W :/\: B) HWpair). }
    claim HuWB: u :e W :/\: B.
    { rewrite <- HUeql. exact HuU. }
    claim HuW: u :e W.
    { exact (binintersectE1 W B u HuWB). }
    claim Hclcond: forall U0:set, U0 :e Tx -> u :e U0 -> U0 :/\: A <> Empty.
    { exact (SepE2 X (fun x0 => forall U0:set, U0 :e Tx -> x0 :e U0 -> U0 :/\: A <> Empty) u Hucl). }
    claim HWAnE: W :/\: A <> Empty.
    { exact (Hclcond W HWopen HuW). }
    apply (nonempty_has_element (W :/\: A) HWAnE).
    let a. assume HaWA: a :e W :/\: A.
    claim HaW: a :e W.
    { exact (binintersectE1 W A a HaWA). }
    claim HaA: a :e A.
    { exact (binintersectE2 W A a HaWA). }
    claim HaB: a :e B.
    { exact (HAB a HaA). }
    claim HaWB: a :e W :/\: B.
    { exact (binintersectI W B a HaW HaB). }
    claim HaU: a :e U.
    { rewrite HUeql. exact HaWB. }
    claim HaV: a :e V.
    { exact (HAV a HaA). }
    claim HaUV: a :e U :/\: V.
    { exact (binintersectI U V a HaU HaV). }
    claim HaE: a :e Empty.
    { rewrite <- Hdisj. exact HaUV. }
    exact (EmptyE a HaE).
Qed.

(** from §23 Theorem 23.5: image of a connected space is connected **)
(** LATEX VERSION: If f:X→Y is continuous and X is connected, then f(X) is connected (as a subspace of Y). **)
Theorem continuous_image_connected : forall X Tx Y Ty f:set,
  connected_space X Tx ->
  continuous_map X Tx Y Ty f ->
  connected_space (image_of f X) (subspace_topology Y Ty (image_of f X)).
let X Tx Y Ty f.
assume HX: connected_space X Tx.
assume Hf: continuous_map X Tx Y Ty f.
prove connected_space (image_of f X) (subspace_topology Y Ty (image_of f X)).
set Im := image_of f X.
set Tim := subspace_topology Y Ty Im.
claim HtopX: topology_on X Tx.
{ exact (connected_space_topology X Tx HX). }
claim HnoSepX: ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
{ exact (connected_space_no_separation X Tx HX). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hf). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hf). }
claim HImsubY: Im c= Y.
{ exact (image_of_sub_codomain f X Y X Hfun (Subq_ref X)). }
claim HtopIm: topology_on Im Tim.
{ exact (subspace_topology_is_topology Y Ty Im HTy HImsubY). }
prove topology_on Im Tim /\ ~(exists U V:set, U :e Tim /\ V :e Tim /\ separation_of Im U V).
apply andI.
- exact HtopIm.
- assume HsepIm: exists U V:set, U :e Tim /\ V :e Tim /\ separation_of Im U V.
  prove False.
  apply HsepIm.
  let U. assume HexV: exists V:set, U :e Tim /\ V :e Tim /\ separation_of Im U V.
  apply HexV.
  let V. assume HUV: U :e Tim /\ V :e Tim /\ separation_of Im U V.
  claim HUV0: U :e Tim /\ V :e Tim.
  { exact (andEL (U :e Tim /\ V :e Tim) (separation_of Im U V) HUV). }
  claim HUin: U :e Tim.
  { exact (andEL (U :e Tim) (V :e Tim) HUV0). }
  claim HVin: V :e Tim.
  { exact (andER (U :e Tim) (V :e Tim) HUV0). }
  claim HsepUV: separation_of Im U V.
  { exact (andER (U :e Tim /\ V :e Tim) (separation_of Im U V) HUV). }
  claim HUrep: exists U0 :e Ty, U = U0 :/\: Im.
  { exact (SepE2 (Power Im) (fun W:set => exists U0 :e Ty, W = U0 :/\: Im) U HUin). }
  claim HVrep: exists V0 :e Ty, V = V0 :/\: Im.
  { exact (SepE2 (Power Im) (fun W:set => exists V0 :e Ty, W = V0 :/\: Im) V HVin). }
  apply HUrep.
  let U0. assume HU0pair.
  claim HU0: U0 :e Ty.
  { exact (andEL (U0 :e Ty) (U = U0 :/\: Im) HU0pair). }
  claim HUeq: U = U0 :/\: Im.
  { exact (andER (U0 :e Ty) (U = U0 :/\: Im) HU0pair). }
  apply HVrep.
  let V0. assume HV0pair.
  claim HV0: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (V = V0 :/\: Im) HV0pair). }
  claim HVeql: V = V0 :/\: Im.
  { exact (andER (V0 :e Ty) (V = V0 :/\: Im) HV0pair). }
  set preU := preimage_of X f U0.
  set preV := preimage_of X f V0.
  claim HpreU: preU :e Tx.
  { exact (continuous_map_preimage X Tx Y Ty f Hf U0 HU0). }
  claim HpreV: preV :e Tx.
  { exact (continuous_map_preimage X Tx Y Ty f Hf V0 HV0). }
  claim HsepX: separation_of X preU preV.
  { (** extract separation data on Im **)
    claim HsepL1: ((((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
    { exact (andEL ((((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                   (U :\/: V = Im) HsepUV). }
    claim Hunion: U :\/: V = Im.
    { exact (andER ((((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                   (U :\/: V = Im) HsepUV). }
    claim HsepL2: (((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty).
    { exact (andEL (((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty)
                   (V <> Empty) HsepL1). }
    claim HVne: V <> Empty.
    { exact (andER (((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty) /\ U <> Empty)
                   (V <> Empty) HsepL1). }
    claim HsepL3: (U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty.
    { exact (andEL ((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty)
                   (U <> Empty) HsepL2). }
    claim HUne: U <> Empty.
    { exact (andER ((U :e Power Im /\ V :e Power Im) /\ U :/\: V = Empty)
                   (U <> Empty) HsepL2). }
    claim Hpow: U :e Power Im /\ V :e Power Im.
    { exact (andEL (U :e Power Im /\ V :e Power Im) (U :/\: V = Empty) HsepL3). }
    claim Hdisj: U :/\: V = Empty.
    { exact (andER (U :e Power Im /\ V :e Power Im) (U :/\: V = Empty) HsepL3). }
    claim HU0pow: U :e Power Im.
    { exact (andEL (U :e Power Im) (V :e Power Im) Hpow). }
    claim HV0pow: V :e Power Im.
    { exact (andER (U :e Power Im) (V :e Power Im) Hpow). }
    (** show preU and preV form a separation of X **)
    claim HpreUsubX: preU c= X.
    { let x. assume Hx: x :e preU.
      exact (SepE1 X (fun x0:set => apply_fun f x0 :e U0) x Hx). }
    claim HpreVsubX: preV c= X.
    { let x. assume Hx: x :e preV.
      exact (SepE1 X (fun x0:set => apply_fun f x0 :e V0) x Hx). }
    claim HpreUPow: preU :e Power X.
    { exact (PowerI X preU HpreUsubX). }
    claim HpreVPow: preV :e Power X.
    { exact (PowerI X preV HpreVsubX). }
    claim HdisjPre: preU :/\: preV = Empty.
    { apply Empty_eq.
      let x. assume Hx: x :e preU :/\: preV.
      apply (binintersectE preU preV x Hx).
      assume HxU: x :e preU.
      assume HxV: x :e preV.
      claim HxX: x :e X.
      { exact (SepE1 X (fun x0:set => apply_fun f x0 :e U0) x HxU). }
      claim HfxU0: apply_fun f x :e U0.
      { exact (SepE2 X (fun x0:set => apply_fun f x0 :e U0) x HxU). }
      claim HfxV0: apply_fun f x :e V0.
      { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V0) x HxV). }
      claim HfxIm: apply_fun f x :e Im.
      { exact (ReplI X (fun x0:set => apply_fun f x0) x HxX). }
      claim HfxU: apply_fun f x :e U.
      { rewrite HUeq.
        exact (binintersectI U0 Im (apply_fun f x) HfxU0 HfxIm). }
      claim HfxV: apply_fun f x :e V.
      { rewrite HVeql.
        exact (binintersectI V0 Im (apply_fun f x) HfxV0 HfxIm). }
      claim HfxUV: apply_fun f x :e U :/\: V.
      { exact (binintersectI U V (apply_fun f x) HfxU HfxV). }
      claim HfxE: apply_fun f x :e Empty.
      { rewrite <- Hdisj. exact HfxUV. }
      exact (EmptyE (apply_fun f x) HfxE). }
    claim HpreUne: preU <> Empty.
    { apply (nonempty_has_element U HUne).
      let y. assume HyU: y :e U.
      claim HUsubIm: U c= Im.
      { exact (PowerE Im U HU0pow). }
      claim HyIm: y :e Im.
      { exact (HUsubIm y HyU). }
      apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm).
      let x. assume HxX: x :e X.
      assume Hyx: y = apply_fun f x.
      claim HyU0Im: y :e U0 :/\: Im.
      { rewrite <- HUeq. exact HyU. }
      claim HyU0: y :e U0.
      { exact (binintersectE1 U0 Im y HyU0Im). }
      claim HfxU0: apply_fun f x :e U0.
      { rewrite <- Hyx. exact HyU0. }
      claim HxPreU: x :e preU.
      { exact (SepI X (fun x0:set => apply_fun f x0 :e U0) x HxX HfxU0). }
      exact (elem_implies_nonempty preU x HxPreU). }
    claim HpreVne: preV <> Empty.
    { apply (nonempty_has_element V HVne).
      let y. assume HyV: y :e V.
      claim HVsubIm: V c= Im.
      { exact (PowerE Im V HV0pow). }
      claim HyIm: y :e Im.
      { exact (HVsubIm y HyV). }
      apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm).
      let x. assume HxX: x :e X.
      assume Hyx: y = apply_fun f x.
      claim HyV0Im: y :e V0 :/\: Im.
      { rewrite <- HVeql. exact HyV. }
      claim HyV0: y :e V0.
      { exact (binintersectE1 V0 Im y HyV0Im). }
      claim HfxV0: apply_fun f x :e V0.
      { rewrite <- Hyx. exact HyV0. }
      claim HxPreV: x :e preV.
      { exact (SepI X (fun x0:set => apply_fun f x0 :e V0) x HxX HfxV0). }
      exact (elem_implies_nonempty preV x HxPreV). }
    claim HunionPre: preU :\/: preV = X.
    { apply set_ext.
      - let x. assume Hx: x :e preU :\/: preV.
        apply (binunionE preU preV x Hx).
        + assume HxU: x :e preU.
          exact (SepE1 X (fun x0:set => apply_fun f x0 :e U0) x HxU).
        + assume HxV: x :e preV.
          exact (SepE1 X (fun x0:set => apply_fun f x0 :e V0) x HxV).
      - let x. assume HxX: x :e X.
        prove x :e preU :\/: preV.
        claim HfxIm: apply_fun f x :e Im.
        { exact (ReplI X (fun x0:set => apply_fun f x0) x HxX). }
        claim HfxUV: apply_fun f x :e U :\/: V.
        { rewrite Hunion. exact HfxIm. }
        apply (binunionE U V (apply_fun f x) HfxUV).
        + assume HfxU: apply_fun f x :e U.
          claim HfxU0Im: apply_fun f x :e U0 :/\: Im.
          { rewrite <- HUeq. exact HfxU. }
          claim HfxU0: apply_fun f x :e U0.
          { exact (binintersectE1 U0 Im (apply_fun f x) HfxU0Im). }
          exact (binunionI1 preU preV x (SepI X (fun x0:set => apply_fun f x0 :e U0) x HxX HfxU0)).
        + assume HfxV: apply_fun f x :e V.
          claim HfxV0Im: apply_fun f x :e V0 :/\: Im.
          { rewrite <- HVeql. exact HfxV. }
          claim HfxV0: apply_fun f x :e V0.
          { exact (binintersectE1 V0 Im (apply_fun f x) HfxV0Im). }
          exact (binunionI2 preU preV x (SepI X (fun x0:set => apply_fun f x0 :e V0) x HxX HfxV0)). }
    prove (((((preU :e Power X /\ preV :e Power X) /\ preU :/\: preV = Empty) /\ preU <> Empty) /\ preV <> Empty) /\ preU :\/: preV = X).
    apply andI.
    * apply andI.
      { apply andI.
        - apply andI.
          + apply andI.
            { exact HpreUPow. }
            { exact HpreVPow. }
          + exact HdisjPre.
        - exact HpreUne. }
      { exact HpreVne. }
    * exact HunionPre. }
  apply HnoSepX.
  witness preU. witness preV.
  prove preU :e Tx /\ preV :e Tx /\ separation_of X preU preV.
  apply andI.
  - apply andI.
    + exact HpreU.
    + exact HpreV.
  - exact HsepX.
Qed.

(** from §24 Definition (linear continuum): least upper bound property (upper bounds) **)
(** LATEX VERSION: (1) L has the least upper bound property. **)
Definition R_upper_bound : set -> set -> prop := fun A u =>
  u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.

(** from §24 Definition (linear continuum): least upper bound property (least upper bounds) **)
(** LATEX VERSION: (1) L has the least upper bound property. **)
Definition R_lub : set -> set -> prop := fun A l =>
  l :e R /\
  (forall a:set, a :e A -> a :e R -> Rle a l) /\
  (forall u:set, u :e R ->
     (forall a:set, a :e A -> a :e R -> Rle a u) ->
     Rle l u).

(** helper: extract l :e R from R_lub **)
Theorem R_lub_in_R : forall A l:set, R_lub A l -> l :e R.
let A l.
assume Hlub: R_lub A l.
(** R_lub A l parses as ((l :e R /\\ UB) /\\ MIN) because /\\ is left associative **)
claim Hcore: l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l).
{ exact (andEL (l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l))
               (forall u:set, u :e R ->
                 (forall a:set, a :e A -> a :e R -> Rle a u) ->
                 Rle l u)
               Hlub). }
exact (andEL (l :e R)
             (forall a:set, a :e A -> a :e R -> Rle a l)
             Hcore).
Qed.

(** helper: uniqueness of least upper bounds in R **)
Theorem R_lub_unique : forall A l1 l2:set, R_lub A l1 -> R_lub A l2 -> l1 = l2.
let A l1 l2.
assume H1: R_lub A l1.
assume H2: R_lub A l2.
claim H1core: l1 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l1.
{ exact (andEL (l1 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l1)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l1 u)
               H1). }
claim H1min: forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l1 u.
{ exact (andER (l1 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l1)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l1 u)
               H1). }
claim H1R: l1 :e R.
{ exact (andEL (l1 :e R) (forall a:set, a :e A -> a :e R -> Rle a l1) H1core). }
claim H1ub: forall a:set, a :e A -> a :e R -> Rle a l1.
{ exact (andER (l1 :e R) (forall a:set, a :e A -> a :e R -> Rle a l1) H1core). }

claim H2core: l2 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l2.
{ exact (andEL (l2 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l2)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l2 u)
               H2). }
claim H2min: forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l2 u.
{ exact (andER (l2 :e R /\ forall a:set, a :e A -> a :e R -> Rle a l2)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l2 u)
               H2). }
claim H2R: l2 :e R.
{ exact (andEL (l2 :e R) (forall a:set, a :e A -> a :e R -> Rle a l2) H2core). }
claim H2ub: forall a:set, a :e A -> a :e R -> Rle a l2.
{ exact (andER (l2 :e R) (forall a:set, a :e A -> a :e R -> Rle a l2) H2core). }

claim Hle12: Rle l1 l2.
{ exact (H1min l2 H2R H2ub). }
claim Hle21: Rle l2 l1.
{ exact (H2min l1 H1R H1ub). }
exact (Rle_antisym l1 l2 Hle12 Hle21).
Qed.

(** helper: 0 is the least upper bound of {0} **)
Theorem R_lub_Sing0 : R_lub {0} 0.
prove R_lub {0} 0.
prove (0 :e R /\
  (forall a:set, a :e {0} -> a :e R -> Rle a 0) /\
  (forall u:set, u :e R ->
     (forall a:set, a :e {0} -> a :e R -> Rle a u) ->
     Rle 0 u)).
apply andI.
- apply andI.
  + exact real_0.
  + let a.
    assume Ha0: a :e {0}.
    assume HaR: a :e R.
    claim HaEq: a = 0.
    { exact (SingE 0 a Ha0). }
    rewrite HaEq.
    exact (Rle_refl 0 real_0).
- let u.
  assume HuR: u :e R.
  assume Hub: forall a:set, a :e {0} -> a :e R -> Rle a u.
  claim H0u: Rle 0 u.
  { exact (Hub 0 (SingI 0) real_0). }
  exact H0u.
Qed.

(** helper: classical negation of implication **)
Theorem not_imp : forall A B:prop, ~(A -> B) -> A /\ ~B.
let A B.
assume H: ~(A -> B).
apply andI.
- apply dneg.
  assume HnA: ~A.
  apply H.
  assume a:A.
  apply FalseE.
  exact (HnA a).
- assume HB: B.
  apply H.
  assume _:A.
  exact HB.
Qed.

(** helper: existence of least upper bounds in R (used for uniform metric) **)
(** LATEX VERSION: The expression sup{...} is assumed to exist as a real number. **)
(** NOTE: We assume A is nonempty, matching the usual least upper bound property formulation. **)
Theorem R_lub_exists : forall A:set,
  (exists a0:set, a0 :e A) ->
  (forall a:set, a :e A -> a :e R) ->
  (exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u) ->
  exists l:set, R_lub A l.
let A.
assume HAnen: exists a0:set, a0 :e A.
assume HAinR: forall a:set, a :e A -> a :e R.
assume HubExists: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.

(** L: real points strictly below some element of A **)
set L := {x :e R | exists a :e A, Rlt x a}.

(** U: upper bounds of A in R (non-strict) **)
set U := {u :e R | forall a:set, a :e A -> a :e R -> Rle a u}.

(** Rplus: epsilon-slack upper bounds, to ensure there is no least element **)
set Rplus := {y :e R | exists u :e U, exists n :e omega, y = add_SNo u (eps_ n)}.

(** L c= real **)
claim HLsub: L c= real.
{ let x. assume HxL: x :e L.
  exact (SepE1 R (fun x0:set => exists a :e A, Rlt x0 a) x HxL). }

(** Rplus c= real **)
claim HRsub: Rplus c= real.
{ let y. assume Hy: y :e Rplus.
  exact (SepE1 R (fun y0:set => exists u :e U, exists n :e omega, y0 = add_SNo u (eps_ n)) y Hy). }

(** U is nonempty, extracted from the given upper bound witness **)
claim HU_nonempty: exists u0:set, u0 :e U.
{ apply HubExists.
  let u0. assume Hu0pack: u0 :e R /\ forall a:set, a :e A -> a :e R -> Rle a u0.
  witness u0.
  apply (SepI R (fun u:set => forall a:set, a :e A -> a :e R -> Rle a u) u0).
  - exact (andEL (u0 :e R) (forall a:set, a :e A -> a :e R -> Rle a u0) Hu0pack).
  - exact (andER (u0 :e R) (forall a:set, a :e A -> a :e R -> Rle a u0) Hu0pack). }

(** L is nonempty: pick a0 in A and use a0-1 < a0 **)
claim HLne: L <> 0.
{ apply HAnen.
  let a0. assume Ha0A: a0 :e A.
  claim Ha0R: a0 :e R.
  { exact (HAinR a0 Ha0A). }
  set x0 := add_SNo a0 (minus_SNo 1).
  claim Hx0R: x0 :e R.
  { exact (real_add_SNo a0 Ha0R (minus_SNo 1) (real_minus_SNo 1 real_1)). }
  claim Hx0S: SNo x0.
  { exact (real_SNo x0 Hx0R). }
  claim Hx0Def: x0 = add_SNo a0 (minus_SNo 1).
  { reflexivity. }
  claim Hx0lt_a0: x0 < a0.
  { claim Hx0eps: x0 < add_SNo x0 (eps_ 0).
    { exact (add_SNo_eps_Lt x0 Hx0S 0 (nat_p_omega 0 nat_0)). }
    claim Hx0plusEps: add_SNo x0 (eps_ 0) = a0.
    { rewrite (eps_0_1) at 1.
      rewrite Hx0Def at 1.
      exact (add_SNo_minus_R2' a0 1 (real_SNo a0 Ha0R) SNo_1). }
    rewrite <- Hx0plusEps at 2.
    exact Hx0eps. }
  claim Hx0lt: Rlt x0 a0.
  { exact (RltI x0 a0 Hx0R Ha0R Hx0lt_a0). }
  claim Hx0inL: x0 :e L.
  { apply (SepI R (fun x:set => exists a :e A, Rlt x a) x0 Hx0R).
    witness a0.
    apply andI.
    - exact Ha0A.
    - exact Hx0lt. }
  assume Hz: L = 0.
  claim Hx0notL: x0 /:e L.
  { rewrite Hz.
    exact (EmptyE x0). }
  exact (Hx0notL Hx0inL). }

(** Rplus is nonempty: take u0 in U and u0+eps_0 **)
claim HRne: Rplus <> 0.
{ apply HU_nonempty.
  let u0. assume Hu0U: u0 :e U.
  claim Hu0R: u0 :e R.
  { exact (SepE1 R (fun u:set => forall a:set, a :e A -> a :e R -> Rle a u) u0 Hu0U). }
  claim Heps0R: eps_ 0 :e R.
  { rewrite (eps_0_1).
    exact real_1. }
  set y0 := add_SNo u0 (eps_ 0).
  claim Hy0R: y0 :e R.
  { exact (real_add_SNo u0 Hu0R (eps_ 0) Heps0R). }
  claim Hy0in: y0 :e Rplus.
  { apply (SepI R (fun y:set => exists u :e U, exists n :e omega, y = add_SNo u (eps_ n)) y0 Hy0R).
    witness u0.
    apply andI.
    - exact Hu0U.
    - witness 0.
      apply andI.
      + exact (nat_p_omega 0 nat_0).
      + reflexivity. }
  assume H0: Rplus = 0.
  claim Hy0notR: y0 /:e Rplus.
  { rewrite H0.
    exact (EmptyE y0). }
  exact (Hy0notR Hy0in). }

(** No maximum in L, using rationals between w and its witness a in A **)
claim HLnoMax: forall w :e L, exists w' :e L, w < w'.
{ let w. assume HwL: w :e L.
  claim HwR: w :e R.
  { exact (SepE1 R (fun x:set => exists a :e A, Rlt x a) w HwL). }
  claim Hexa: exists a:set, a :e A /\ Rlt w a.
  { exact (SepE2 R (fun x:set => exists a :e A, Rlt x a) w HwL). }
  apply Hexa.
  let a. assume Hapack: a :e A /\ Rlt w a.
  claim HaA: a :e A.
  { exact (andEL (a :e A) (Rlt w a) Hapack). }
  claim Hwa: Rlt w a.
  { exact (andER (a :e A) (Rlt w a) Hapack). }
  claim HaR: a :e R.
  { exact (HAinR a HaA). }
  claim Hexq: exists q :e rational_numbers, Rlt w q /\ Rlt q a.
  { exact (rational_dense_between_reals w a HwR HaR Hwa). }
  apply Hexq.
  let q. assume Hqpack: q :e rational_numbers /\ (Rlt w q /\ Rlt q a).
  claim HqQ: q :e rational_numbers.
  { exact (andEL (q :e rational_numbers) (Rlt w q /\ Rlt q a) Hqpack). }
  claim Hqmid: Rlt w q /\ Rlt q a.
  { exact (andER (q :e rational_numbers) (Rlt w q /\ Rlt q a) Hqpack). }
  claim Hwq: Rlt w q.
  { exact (andEL (Rlt w q) (Rlt q a) Hqmid). }
  claim Hqa: Rlt q a.
  { exact (andER (Rlt w q) (Rlt q a) Hqmid). }
  claim HqR: q :e R.
  { exact (rational_numbers_in_R q HqQ). }
  witness q.
  apply andI.
  - apply (SepI R (fun x:set => exists a0 :e A, Rlt x a0) q HqR).
    witness a.
    apply andI.
    + exact HaA.
    + exact Hqa.
  - exact (RltE_lt w q Hwq). }

(** No minimum in Rplus, using eps_(ordsucc n) < eps_n **)
claim HRnoMin: forall z :e Rplus, exists z' :e Rplus, z' < z.
{ let z. assume HzR: z :e Rplus.
  claim HzR0: z :e R.
  { exact (SepE1 R (fun y:set => exists u :e U, exists n :e omega, y = add_SNo u (eps_ n)) z HzR). }
  claim Hex: exists u:set, u :e U /\ exists n:set, n :e omega /\ z = add_SNo u (eps_ n).
  { exact (SepE2 R (fun y:set => exists u :e U, exists n :e omega, y = add_SNo u (eps_ n)) z HzR). }
  apply Hex.
  let u. assume Hun.
  claim HuU: u :e U.
  { exact (andEL (u :e U) (exists n:set, n :e omega /\ z = add_SNo u (eps_ n)) Hun). }
  claim Hexn: exists n:set, n :e omega /\ z = add_SNo u (eps_ n).
  { exact (andER (u :e U) (exists n:set, n :e omega /\ z = add_SNo u (eps_ n)) Hun). }
  apply Hexn.
  let n. assume Hnpack: n :e omega /\ z = add_SNo u (eps_ n).
  claim HnO: n :e omega.
  { exact (andEL (n :e omega) (z = add_SNo u (eps_ n)) Hnpack). }
  claim Hzdef: z = add_SNo u (eps_ n).
  { exact (andER (n :e omega) (z = add_SNo u (eps_ n)) Hnpack). }
  set n1 := ordsucc n.
  claim Hn1O: n1 :e omega.
  { exact (omega_ordsucc n HnO). }
  claim HuR: u :e R.
  { exact (SepE1 R (fun u0:set => forall a:set, a :e A -> a :e R -> Rle a u0) u HuU). }
  claim HuS: SNo u.
  { exact (real_SNo u HuR). }
  claim HepsnS: SNo (eps_ n).
  { exact (SNo_eps_ n HnO). }
  claim Hepsn1S: SNo (eps_ n1).
  { exact (SNo_eps_ n1 Hn1O). }
  claim Hnin: n :e n1.
  { exact (ordsuccI2 n). }
  claim Hepsdec: eps_ n1 < eps_ n.
  { exact (SNo_eps_decr n1 Hn1O n Hnin). }
  set z1 := add_SNo u (eps_ n1).
  claim Hz1R: z1 :e R.
  { exact (real_add_SNo u HuR (eps_ n1) (SNoS_omega_real (eps_ n1) (SNo_eps_SNoS_omega n1 Hn1O))). }
  claim Hz1in: z1 :e Rplus.
  { apply (SepI R (fun y:set => exists u0 :e U, exists k :e omega, y = add_SNo u0 (eps_ k)) z1 Hz1R).
    witness u.
    apply andI.
    - exact HuU.
    - witness n1.
      apply andI.
      + exact Hn1O.
      + reflexivity. }
  witness z1.
  apply andI.
  - exact Hz1in.
  - rewrite Hzdef.
    exact (add_SNo_Lt2 u (eps_ n1) (eps_ n) HuS Hepsn1S HepsnS Hepsdec). }

(** SNoCutP L Rplus **)
claim HcutP: SNoCutP L Rplus.
{ prove (forall x :e L, SNo x) /\ (forall y :e Rplus, SNo y) /\ (forall x :e L, forall y :e Rplus, x < y).
  apply and3I.
  - let x. assume HxL: x :e L.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0:set => exists a :e A, Rlt x0 a) x HxL). }
    exact (real_SNo x HxR).
  - let y. assume HyR: y :e Rplus.
    claim HyRR: y :e R.
    { exact (SepE1 R (fun y0:set => exists u :e U, exists n :e omega, y0 = add_SNo u (eps_ n)) y HyR). }
    exact (real_SNo y HyRR).
  - let x. assume HxL: x :e L.
    let y. assume HyR: y :e Rplus.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0:set => exists a :e A, Rlt x0 a) x HxL). }
    claim HyRR: y :e R.
    { exact (SepE1 R (fun y0:set => exists u :e U, exists n :e omega, y0 = add_SNo u (eps_ n)) y HyR). }
    claim Hexa: exists a:set, a :e A /\ Rlt x a.
    { exact (SepE2 R (fun x0:set => exists a :e A, Rlt x0 a) x HxL). }
    apply Hexa.
    let a. assume Hapack: a :e A /\ Rlt x a.
    claim HaA: a :e A.
    { exact (andEL (a :e A) (Rlt x a) Hapack). }
    claim Hxa: Rlt x a.
    { exact (andER (a :e A) (Rlt x a) Hapack). }
    claim HaR: a :e R.
    { exact (HAinR a HaA). }
    claim Hexun: exists u:set, u :e U /\ exists n:set, n :e omega /\ y = add_SNo u (eps_ n).
    { exact (SepE2 R (fun y0:set => exists u :e U, exists n :e omega, y0 = add_SNo u (eps_ n)) y HyR). }
    apply Hexun.
    let u. assume Hun.
    claim HuU: u :e U.
    { exact (andEL (u :e U) (exists n:set, n :e omega /\ y = add_SNo u (eps_ n)) Hun). }
    claim Hexn: exists n:set, n :e omega /\ y = add_SNo u (eps_ n).
    { exact (andER (u :e U) (exists n:set, n :e omega /\ y = add_SNo u (eps_ n)) Hun). }
    apply Hexn.
    let n. assume Hnpack: n :e omega /\ y = add_SNo u (eps_ n).
    claim HnO: n :e omega.
    { exact (andEL (n :e omega) (y = add_SNo u (eps_ n)) Hnpack). }
    claim Hydef: y = add_SNo u (eps_ n).
    { exact (andER (n :e omega) (y = add_SNo u (eps_ n)) Hnpack). }
    claim HuR: u :e R.
    { exact (SepE1 R (fun u0:set => forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u0) u HuU). }
    claim HuS: SNo u.
    { exact (real_SNo u HuR). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HxS: SNo x.
    { exact (real_SNo x HxR). }
    claim HepsnS: SNo (eps_ n).
    { exact (SNo_eps_ n HnO). }
    claim Hxa_lt: x < a.
    { exact (RltE_lt x a Hxa). }
    (** show a <= u in SNo order by trichotomy; u<a contradicts u being an upper bound **)
    claim Hau_nlt: ~(Rlt u a).
    { exact (RleE_nlt a u ((SepE2 R (fun u0:set => forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u0) u HuU) a HaA HaR)). }
    claim Hxltu: x < u.
    { apply (SNoLt_trichotomy_or_impred u a HuS HaS (x < u)).
      - assume Hult: u < a.
        claim HultR: Rlt u a.
        { exact (RltI u a HuR HaR Hult). }
        exact (FalseE (Hau_nlt HultR) (x < u)).
      - assume Hueq: u = a.
        rewrite Hueq.
        exact Hxa_lt.
      - assume Halt: a < u.
        exact (SNoLt_tra x a u HxS HaS HuS Hxa_lt Halt). }
    claim Hultup: u < add_SNo u (eps_ n).
    { exact (add_SNo_eps_Lt u HuS n HnO). }
    rewrite Hydef.
    exact (SNoLt_tra x u (add_SNo u (eps_ n)) HxS HuS (real_SNo (add_SNo u (eps_ n))
      (real_add_SNo u HuR (eps_ n) (SNoS_omega_real (eps_ n) (SNo_eps_SNoS_omega n HnO))))
      Hxltu Hultup).
}

(** Define l as the cut between L and Rplus, and prove l is real (hence in R). **)
set l := SNoCut L Rplus.
claim HlR: l :e R.
{ exact (real_SNoCut L HLsub Rplus HRsub HcutP HLne HRne HLnoMax HRnoMin). }

(** Use SNoCutP consequences for l **)
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim Hbelow: forall x :e L, x < l.
{ exact (SNoCutP_SNoCut_L L Rplus HcutP). }
claim Habove: forall y :e Rplus, l < y.
{ exact (SNoCutP_SNoCut_R L Rplus HcutP). }

witness l.
prove R_lub A l.
(** unfold R_lub: ((l∈R /\\ UB) /\\ MIN) because /\\ is left associative **)
prove (l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l)) /\
      (forall u:set, u :e R ->
        (forall a:set, a :e A -> a :e R -> Rle a u) ->
        Rle l u).
apply andI.
- (** left: l∈R and UB property **)
  apply andI.
  + exact HlR.
  + let a. assume HaA: a :e A. assume HaR: a :e R.
    prove Rle a l.
    apply (RleI a l HaR HlR).
    assume Hlt: Rlt l a.
    claim HlinL: l :e L.
    { apply (SepI R (fun x:set => exists a0 :e A, Rlt x a0) l HlR).
      witness a.
      apply andI.
      - exact HaA.
      - exact Hlt. }
    claim Hll: l < l.
    { exact (Hbelow l HlinL). }
    exact ((SNoLt_irref l) Hll).
- (** right: minimality among upper bounds **)
  let u. assume HuR: u :e R.
  assume Hupper: forall a:set, a :e A -> a :e R -> Rle a u.
  prove Rle l u.
  apply (RleI l u HlR HuR).
  assume Hult: Rlt u l.
  (** d = l-u is positive **)
  set d := add_SNo l (minus_SNo u).
  claim HdR: d :e R.
  { exact (real_add_SNo l HlR (minus_SNo u) (real_minus_SNo u HuR)). }
  claim Hdpos: Rlt 0 d.
  { exact (Rlt_0_diff_of_lt u l Hult). }
  claim HexN: exists N :e omega, eps_ N < d.
  { exact (exists_eps_lt_pos d HdR Hdpos). }
  apply HexN.
  let N. assume HNpack.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (eps_ N < d) HNpack). }
  claim HepsNd: eps_ N < d.
  { exact (andER (N :e omega) (eps_ N < d) HNpack). }
  claim HuS: SNo u.
  { exact (real_SNo u HuR). }
  claim HdS: SNo d.
  { exact (real_SNo d HdR). }
  claim HepsNS: SNo (eps_ N).
  { exact (SNo_eps_ N HNomega). }
  (** build a point in Rplus: u+eps_N **)
  set y := add_SNo u (eps_ N).
  claim HepsNR: eps_ N :e R.
  { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
  claim HyR: y :e R.
  { exact (real_add_SNo u HuR (eps_ N) HepsNR). }
  claim HuU: u :e U.
  { exact (SepI R (fun u0:set => forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u0) u HuR Hupper). }
  claim Hyin: y :e Rplus.
  { apply (SepI R (fun y0:set => exists u0 :e U, exists n :e omega, y0 = add_SNo u0 (eps_ n)) y HyR).
    witness u.
    apply andI.
    - exact HuU.
    - witness N.
      apply andI.
      + exact HNomega.
      + reflexivity. }
  (** show y < l using eps_N < l-u **)
  claim Hyltuplusd: add_SNo u (eps_ N) < add_SNo u d.
  { exact (add_SNo_Lt2 u (eps_ N) d HuS HepsNS HdS HepsNd). }
  claim Hdcomm: d = add_SNo (minus_SNo u) l.
  { claim HmuS: SNo (minus_SNo u).
    { exact (SNo_minus_SNo u HuS). }
    exact (add_SNo_com l (minus_SNo u) HlS HmuS). }
  claim Huplusd: add_SNo u d = l.
  { claim HmuR: minus_SNo u :e R.
    { exact (real_minus_SNo u HuR). }
    claim HmuS: SNo (minus_SNo u).
    { exact (real_SNo (minus_SNo u) HmuR). }
    rewrite Hdcomm.
    exact (add_SNo_minus_L2' u l HuS HlS). }
  claim Hyltl: y < l.
  { rewrite <- Huplusd.
    exact Hyltuplusd. }
  claim Hlty: l < y.
  { exact (Habove y Hyin). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim Hbad: y < y.
  { exact (SNoLt_tra y l y HyS HlS HyS Hyltl Hlty). }
  exact ((SNoLt_irref y) Hbad).
Qed.

(** helper: lub approximation from below **)
(** LATEX VERSION: If l = sup A and eps>0, then some a in A satisfies l-eps < a. **)
Theorem R_lub_approx_from_below : forall A l eps:set,
  R_lub A l ->
  eps :e R -> Rlt 0 eps ->
  exists a:set, a :e A /\ a :e R /\ Rlt (add_SNo l (minus_SNo eps)) a.
let A l eps.
assume Hlub: R_lub A l.
assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
set u := add_SNo l (minus_SNo eps).
claim HlR: l :e R.
{ exact (R_lub_in_R A l Hlub). }
claim HuR: u :e R.
{ exact (real_add_SNo l HlR (minus_SNo eps) (real_minus_SNo eps HepsR)). }
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim HepsS: SNo eps.
{ exact (real_SNo eps HepsR). }
claim HepsPosS: 0 < eps.
{ exact (RltE_lt 0 eps HepsPos). }
claim HmepsR: minus_SNo eps :e R.
{ exact (real_minus_SNo eps HepsR). }
claim HmepsS: SNo (minus_SNo eps).
{ exact (real_SNo (minus_SNo eps) HmepsR). }
claim Hmepslt0: minus_SNo eps < 0.
{ rewrite <- minus_SNo_0.
  exact (minus_SNo_Lt_contra 0 eps SNo_0 HepsS HepsPosS). }
claim HuLtL: u < l.
{ claim HuDef: u = add_SNo l (minus_SNo eps).
  { reflexivity. }
  claim HuLtL0: add_SNo l (minus_SNo eps) < add_SNo l 0.
  { exact (add_SNo_Lt2 l (minus_SNo eps) 0 HlS HmepsS SNo_0 Hmepslt0). }
  rewrite HuDef at 1.
  rewrite <- (add_SNo_0R l HlS) at 2.
  exact HuLtL0. }
claim HuLtL_R: Rlt u l.
{ exact (RltI u l HuR HlR HuLtL). }
(** show u is not an upper bound of A **)
claim HnotAll: ~(forall a:set, a :e A -> a :e R -> Rle a u).
{ assume Hall: forall a:set, a :e A -> a :e R -> Rle a u.
  claim Hmin: forall u0:set, u0 :e R ->
    (forall a:set, a :e A -> a :e R -> Rle a u0) -> Rle l u0.
  { exact (andER (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                 (forall u0:set, u0 :e R ->
                   (forall a:set, a :e A -> a :e R -> Rle a u0) ->
                   Rle l u0)
                 Hlub). }
  claim Hle: Rle l u.
  { exact (Hmin u HuR Hall). }
  claim Hnlt: ~(Rlt u l).
  { exact (RleE_nlt l u Hle). }
  exact (Hnlt HuLtL_R). }
(** extract a witness a with not (a in A -> a in R -> a<=u) **)
apply (not_all_ex_demorgan_i (fun a:set => a :e A -> a :e R -> Rle a u) HnotAll).
let a. assume Hna: ~(a :e A -> a :e R -> Rle a u).
claim Hna1: a :e A /\ ~(a :e R -> Rle a u).
{ exact (not_imp (a :e A) (a :e R -> Rle a u) Hna). }
claim HaA: a :e A.
{ exact (andEL (a :e A) (~(a :e R -> Rle a u)) Hna1). }
claim Hna2: ~(a :e R -> Rle a u).
{ exact (andER (a :e A) (~(a :e R -> Rle a u)) Hna1). }
claim Hna3: a :e R /\ ~(Rle a u).
{ exact (not_imp (a :e R) (Rle a u) Hna2). }
claim HaR: a :e R.
{ exact (andEL (a :e R) (~(Rle a u)) Hna3). }
claim Hnle: ~(Rle a u).
{ exact (andER (a :e R) (~(Rle a u)) Hna3). }
claim HuLtA: Rlt u a.
{ apply (xm (Rlt u a) (Rlt u a)).
  - assume Hlt: Rlt u a.
    exact Hlt.
  - assume Hnlt: ~(Rlt u a).
    claim Hle: Rle a u.
    { exact (RleI a u HaR HuR Hnlt). }
    exact (FalseE (Hnle Hle) (Rlt u a)). }
witness a.
apply andI.
- apply andI.
  + exact HaA.
  + exact HaR.
- exact HuLtA.
Qed.

(** from §24 Corollary 24.2: the real line is connected **)
(** LATEX VERSION: Corollary 24.2: The real line R is connected (and so are intervals and rays in R). **)
(** LATEX VERSION: The real line with the standard topology is connected. **)
Theorem interval_connected : connected_space R R_standard_topology.
prove topology_on R R_standard_topology /\
  ~(exists U V:set, U :e R_standard_topology /\ V :e R_standard_topology /\ separation_of R U V).
apply andI.
- exact R_standard_topology_is_topology.
- assume Hsep: exists U V:set, U :e R_standard_topology /\ V :e R_standard_topology /\ separation_of R U V.
  (** Destructure the separation and record the basic consequences; the remaining order/completeness argument is deferred. **)
  apply Hsep.
  let U. assume HexV: exists V:set, U :e R_standard_topology /\ V :e R_standard_topology /\ separation_of R U V.
  apply HexV.
  let V. assume HUV: U :e R_standard_topology /\ V :e R_standard_topology /\ separation_of R U V.
  claim HUV0: U :e R_standard_topology /\ V :e R_standard_topology.
  { exact (andEL (U :e R_standard_topology /\ V :e R_standard_topology)
                 (separation_of R U V)
                 HUV). }
  claim HUopen: U :e R_standard_topology.
  { exact (andEL (U :e R_standard_topology) (V :e R_standard_topology) HUV0). }
  claim HVopen: V :e R_standard_topology.
  { exact (andER (U :e R_standard_topology) (V :e R_standard_topology) HUV0). }
  claim HsepUV: separation_of R U V.
  { exact (andER (U :e R_standard_topology /\ V :e R_standard_topology)
                 (separation_of R U V)
                 HUV). }
  (** Extract useful facts from separation_of; conjunction is left-associative. **)
  claim Hpart1: ((((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = R)
                 HsepUV). }
  claim Hunion: U :\/: V = R.
  { exact (andER ((((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = R)
                 HsepUV). }
  claim HAux: (((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty).
  { exact (andEL (((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty)
                 Hpart1). }
  claim HVne: V <> Empty.
  { exact (andER (((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty)
                 Hpart1). }
  claim Hpowdisj: (U :e Power R /\ V :e Power R) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty)
                 (U <> Empty)
                 HAux). }
  claim HUne: U <> Empty.
  { exact (andER ((U :e Power R /\ V :e Power R) /\ U :/\: V = Empty)
                 (U <> Empty)
                 HAux). }
  claim Hpow: U :e Power R /\ V :e Power R.
  { exact (andEL (U :e Power R /\ V :e Power R)
                 (U :/\: V = Empty)
                 Hpowdisj). }
  claim Hdisj: U :/\: V = Empty.
  { exact (andER (U :e Power R /\ V :e Power R)
                 (U :/\: V = Empty)
                 Hpowdisj). }
  claim HUpow: U :e Power R.
  { exact (andEL (U :e Power R) (V :e Power R) Hpow). }
  claim HVpow: V :e Power R.
  { exact (andER (U :e Power R) (V :e Power R) Hpow). }
  claim HUsub: U c= R.
  { exact (PowerE R U HUpow). }
  claim HVsub: V c= R.
  { exact (PowerE R V HVpow). }
  claim Hexu0: exists u0:set, u0 :e U.
  { exact (nonempty_has_element U HUne). }
  claim Hexv0: exists v0:set, v0 :e V.
  { exact (nonempty_has_element V HVne). }
  (** Use the classical lub argument (depends on `R_lub_exists`). **)
  apply Hexu0.
  let u0. assume Hu0U: u0 :e U.
  apply Hexv0.
  let v0. assume Hv0V: v0 :e V.
  claim Hu0R: u0 :e R.
  { exact (HUsub u0 Hu0U). }
  claim Hv0R: v0 :e R.
  { exact (HVsub v0 Hv0V). }
  claim Hu0S: SNo u0.
  { exact (real_SNo u0 Hu0R). }
  claim Hv0S: SNo v0.
  { exact (real_SNo v0 Hv0R). }
  prove False.
  apply (SNoLt_trichotomy_or_impred u0 v0 Hu0S Hv0S False).
  - assume Hu0ltv0: u0 < v0.
    (** define A = U ∩ (-∞,v0) **)
    set A := {u :e U|Rlt u v0}.
    claim Hu0Rltv0: Rlt u0 v0.
    { exact (RltI u0 v0 Hu0R Hv0R Hu0ltv0). }
    claim Hu0inA: u0 :e A.
    { exact (SepI U (fun u:set => Rlt u v0) u0 Hu0U Hu0Rltv0). }
    claim HAinR: forall a:set, a :e A -> a :e R.
    { let a. assume HaA: a :e A.
      claim HaU: a :e U.
      { exact (SepE1 U (fun u:set => Rlt u v0) a HaA). }
      exact (HUsub a HaU). }
    claim Hub_ex: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
    { witness v0.
      apply andI.
      - exact Hv0R.
      - let a. assume HaA: a :e A.
        assume _. (** a :e R **)
        claim Harlt: Rlt a v0.
        { exact (SepE2 U (fun u:set => Rlt u v0) a HaA). }
        exact (Rlt_implies_Rle a v0 Harlt). }
    claim HAnen: exists a0:set, a0 :e A.
    { witness u0. exact Hu0inA. }
    claim Hexlub: exists l:set, R_lub A l.
    { exact (R_lub_exists A HAnen HAinR Hub_ex). }
    apply Hexlub.
    let l. assume Hlub: R_lub A l.
    claim HlR: l :e R.
    { exact (R_lub_in_R A l Hlub). }
    claim HlS: SNo l.
    { exact (real_SNo l HlR). }
    (** upper bound clause: every a∈A satisfies a ≤ l **)
    claim Hlubcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    claim HubA: forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hlubcore). }
    (** minimality clause: l ≤ every upper bound **)
    claim Hmin: forall u:set, u :e R ->
       (forall a:set, a :e A -> a :e R -> Rle a u) ->
       Rle l u.
    { exact (andER (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    (** l ≤ v0, since v0 is an upper bound of A **)
    claim Hlubv0: Rle l v0.
    { apply (Hmin v0 Hv0R).
      let a. assume HaA: a :e A.
      assume _. (** a :e R **)
      claim Harlt: Rlt a v0.
      { exact (SepE2 U (fun u:set => Rlt u v0) a HaA). }
      exact (Rlt_implies_Rle a v0 Harlt). }
	    (** l ∈ U ∪ V since U ∪ V = R **)
	    claim HlUV: l :e U :\/: V.
	    { rewrite Hunion.
	      exact HlR. }
    apply (binunionE U V l HlUV).
	    + (** Case l ∈ U: derive a point u1∈A with l<u1, contradicting that l is an upper bound **)
	      assume HlU: l :e U.
      claim Hv0notU: v0 /:e U.
      { assume Hv0U: v0 :e U.
        claim Hv0UV: v0 :e U :/\: V.
        { exact (binintersectI U V v0 Hv0U Hv0V). }
        claim Hv0Empty: v0 :e Empty.
        { rewrite <- Hdisj.
          exact Hv0UV. }
        exact (EmptyE v0 Hv0Empty). }
      (** obtain an interval (c,d) around l contained in U **)
      claim Hexcd: exists c d:set,
        c :e R /\ d :e R /\
        l :e open_interval c d /\
        open_interval c d c= U /\
        Rlt c l /\ Rlt l d.
      { exact (R_standard_open_refine_interval U l HUopen HlU). }
      apply Hexcd.
      let c. assume Hexd.
      apply Hexd.
      let d. assume Hcdpack.
      (** destruct the returned conjunction (left-associative) **)
      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l).
      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hld: Rlt l d.
      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U).
      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U)
                     (Rlt c l)
                     Hcd1). }
      claim Hcl: Rlt c l.
      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U)
                     (Rlt c l)
                     Hcd1). }
	      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
	      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
	                     (open_interval c d c= U)
	                     Hcd2). }
	      claim HIntSubU: open_interval c d c= U.
	      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
	                     (open_interval c d c= U)
	                     Hcd2). }
      claim HcR: c :e R.
      { exact (andEL (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdR: d :e R.
      { exact (andER (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      claim Hrltd: l < d.
      { exact (RltE_lt l d Hld). }
      (** show l < v0 using l ≤ v0 and v0 ∉ U **)
      claim Hlneqv0: ~(l = v0).
      { assume Heq: l = v0.
        claim Hv0U': v0 :e U.
        { rewrite <- Heq.
          exact HlU. }
        exact (Hv0notU Hv0U'). }
      claim Hlv0: Rlt l v0.
      { apply (SNoLt_trichotomy_or_impred l v0 HlS Hv0S (Rlt l v0)).
        - assume Hlt: l < v0.
          exact (RltI l v0 HlR Hv0R Hlt).
        - assume Heq: l = v0.
          exact (FalseE (Hlneqv0 Heq) (Rlt l v0)).
        - assume Hgt: v0 < l.
          claim Hv0l: Rlt v0 l.
          { exact (RltI v0 l Hv0R HlR Hgt). }
          claim Hnlt: ~(Rlt v0 l).
          { exact (RleE_nlt l v0 Hlubv0). }
          exact (FalseE (Hnlt Hv0l) (Rlt l v0)). }
      (** define positive gaps d-l and v0-l **)
      set gap1 := add_SNo d (minus_SNo l).
      set gap2 := add_SNo v0 (minus_SNo l).
      claim Hgap1R: gap1 :e R.
      { exact (real_add_SNo d HdR (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap2R: gap2 :e R.
      { exact (real_add_SNo v0 Hv0R (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap1pos: Rlt 0 gap1.
      { exact (Rlt_0_diff_of_lt l d Hld). }
      claim Hgap2pos: Rlt 0 gap2.
      { exact (Rlt_0_diff_of_lt l v0 Hlv0). }
      (** choose r3 < gap1 and r3 < gap2 **)
	      apply (exists_eps_lt_two_pos_Euclid gap1 gap2 Hgap1R Hgap2R Hgap1pos Hgap2pos).
	      let r3. assume Hr3pack.
	      claim Hr3p1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1.
	      { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
	                     (Rlt r3 gap2)
	                     Hr3pack). }
	      claim Hr3ltgap2: Rlt r3 gap2.
	      { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
	                     (Rlt r3 gap2)
	                     Hr3pack). }
	      claim Hr3p0: r3 :e R /\ Rlt 0 r3.
	      { exact (andEL (r3 :e R /\ Rlt 0 r3)
	                     (Rlt r3 gap1)
	                     Hr3p1). }
	      claim Hr3ltgap1: Rlt r3 gap1.
	      { exact (andER (r3 :e R /\ Rlt 0 r3)
	                     (Rlt r3 gap1)
	                     Hr3p1). }
	      claim Hr3R: r3 :e R.
	      { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3p0). }
	      claim Hr3pos: Rlt 0 r3.
	      { exact (andER (r3 :e R) (Rlt 0 r3) Hr3p0). }
	      claim Hr3S: SNo r3.
	      { exact (real_SNo r3 Hr3R). }
	      claim Hr3posS: 0 < r3.
	      { exact (RltE_lt 0 r3 Hr3pos). }
	      (** set u1 = l + r3 **)
	      claim Hu1R: add_SNo l r3 :e R.
	      { exact (real_add_SNo l HlR r3 Hr3R). }
	      claim Hu1S: SNo (add_SNo l r3).
	      { exact (real_SNo (add_SNo l r3) Hu1R). }
	      (** l < u1 **)
	      claim Hl_lt_u1S: l < add_SNo l r3.
	      { claim Hl0: add_SNo l 0 = l.
	        { exact (add_SNo_0R l HlS). }
	        claim Hlt: add_SNo l 0 < add_SNo l r3.
	        { exact (add_SNo_Lt2 l 0 r3 HlS SNo_0 Hr3S Hr3posS). }
	        rewrite <- Hl0 at 1.
	        exact Hlt. }
	      claim Hl_lt_u1: Rlt l (add_SNo l r3).
	      { exact (RltI l (add_SNo l r3) HlR Hu1R Hl_lt_u1S). }
	      (** u1 < d from r3 < d-l **)
	      claim Hr3ltgap1S: r3 < gap1.
	      { exact (RltE_lt r3 gap1 Hr3ltgap1). }
	      claim Hgap1S: SNo gap1.
	      { exact (real_SNo gap1 Hgap1R). }
	      claim Hu1lt_dS': add_SNo r3 l < d.
	      { exact (add_SNo_minus_Lt2 d l r3 HdS HlS Hr3S Hr3ltgap1S). }
	      claim Hu1lt_dS: add_SNo l r3 < d.
	      { claim Hcom2: add_SNo r3 l = add_SNo l r3.
	        { exact (add_SNo_com r3 l Hr3S HlS). }
	        rewrite <- Hcom2.
	        exact Hu1lt_dS'. }
	      claim Hu1lt_d: Rlt (add_SNo l r3) d.
	      { exact (RltI (add_SNo l r3) d Hu1R HdR Hu1lt_dS). }
	      (** u1 < v0 from r3 < v0-l **)
	      claim Hr3ltgap2S: r3 < gap2.
	      { exact (RltE_lt r3 gap2 Hr3ltgap2). }
	      claim Hgap2S: SNo gap2.
	      { exact (real_SNo gap2 Hgap2R). }
	      claim Hu1lt_v0S': add_SNo r3 l < v0.
	      { exact (add_SNo_minus_Lt2 v0 l r3 Hv0S HlS Hr3S Hr3ltgap2S). }
	      claim Hu1lt_v0S: add_SNo l r3 < v0.
	      { claim Hcom3: add_SNo r3 l = add_SNo l r3.
	        { exact (add_SNo_com r3 l Hr3S HlS). }
	        rewrite <- Hcom3.
	        exact Hu1lt_v0S'. }
	      claim Hu1lt_v0: Rlt (add_SNo l r3) v0.
	      { exact (RltI (add_SNo l r3) v0 Hu1R Hv0R Hu1lt_v0S). }
	      (** u1 ∈ open_interval c d, hence u1 ∈ U **)
	      claim Hu1InInt: add_SNo l r3 :e open_interval c d.
	      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) (add_SNo l r3) Hu1R
	                   (andI (Rlt c (add_SNo l r3)) (Rlt (add_SNo l r3) d)
	                         (Rlt_tra c l (add_SNo l r3) Hcl Hl_lt_u1)
	                         Hu1lt_d)). }
	      claim Hu1U: add_SNo l r3 :e U.
	      { exact (HIntSubU (add_SNo l r3) Hu1InInt). }
	      claim Hu1A: add_SNo l r3 :e A.
	      { exact (SepI U (fun u:set => Rlt u v0) (add_SNo l r3) Hu1U Hu1lt_v0). }
	      (** contradiction with upper bound property HubA **)
	      claim Hu1le_l: Rle (add_SNo l r3) l.
	      { exact (HubA (add_SNo l r3) Hu1A Hu1R). }
	      claim Hnlt: ~(Rlt l (add_SNo l r3)).
	      { exact (RleE_nlt (add_SNo l r3) l Hu1le_l). }
	      exact (Hnlt Hl_lt_u1).
		    + (** Case l ∈ V: use openness of V and approximation-from-below to force a point in U∩V **)
		      assume HlV: l :e V.
		      (** get an interval (c,d) around l contained in V **)
		      claim Hexcd: exists c d:set,
		        c :e R /\ d :e R /\
		        l :e open_interval c d /\
		        open_interval c d c= V /\
		        Rlt c l /\ Rlt l d.
		      { exact (R_standard_open_refine_interval V l HVopen HlV). }
		      apply Hexcd.
		      let c. assume Hexd.
		      apply Hexd.
		      let d. assume Hcdpack.
		      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l).
		      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l)
		                     (Rlt l d)
		                     Hcdpack). }
		      claim Hld: Rlt l d.
		      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l)
		                     (Rlt l d)
		                     Hcdpack). }
		      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V).
		      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V)
		                     (Rlt c l)
		                     Hcd1). }
		      claim Hcl: Rlt c l.
		      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V)
		                     (Rlt c l)
		                     Hcd1). }
		      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
		      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
		                     (open_interval c d c= V)
		                     Hcd2). }
		      claim HIntSubV: open_interval c d c= V.
		      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
		                     (open_interval c d c= V)
		                     Hcd2). }
		      claim HcR: c :e R.
		      { exact (andEL (c :e R) (d :e R)
		                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
		      claim HdR: d :e R.
		      { exact (andER (c :e R) (d :e R)
		                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
		      claim HlS2: SNo l.
		      { exact HlS. }
		      claim HdS: SNo d.
		      { exact (real_SNo d HdR). }

		      (** pick eps0 < l-c **)
		      set gap := add_SNo l (minus_SNo c).
		      claim HgapR: gap :e R.
		      { exact (real_add_SNo l HlR (minus_SNo c) (real_minus_SNo c HcR)). }
		      claim HgapPos: Rlt 0 gap.
		      { exact (Rlt_0_diff_of_lt c l Hcl). }
		      claim Hexeps: exists Neps :e omega, eps_ Neps < gap.
		      { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
		      apply Hexeps.
		      let Neps. assume HNepspair.
		      claim HNepsO: Neps :e omega.
		      { exact (andEL (Neps :e omega) (eps_ Neps < gap) HNepspair). }
		      claim HepsltS: eps_ Neps < gap.
		      { exact (andER (Neps :e omega) (eps_ Neps < gap) HNepspair). }
		      claim HepsR: eps_ Neps :e R.
		      { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
		      claim HepsposS: 0 < eps_ Neps.
		      { exact (SNo_eps_pos Neps HNepsO). }
		      claim Hepspos: Rlt 0 (eps_ Neps).
		      { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }

		      (** show c < l - eps **)
		      claim HcS: SNo c.
		      { exact (real_SNo c HcR). }
		      claim HepsS: SNo (eps_ Neps).
		      { exact (real_SNo (eps_ Neps) HepsR). }
		      claim HgapS: SNo gap.
		      { exact (real_SNo gap HgapR). }
		      claim HepsltR: Rlt (eps_ Neps) gap.
		      { exact (RltI (eps_ Neps) gap HepsR HgapR HepsltS). }
		      claim HepsltgapS: eps_ Neps < gap.
		      { exact (RltE_lt (eps_ Neps) gap HepsltR). }
		      claim Hsumlt1: add_SNo (eps_ Neps) c < l.
		      { exact (add_SNo_minus_Lt2 l c (eps_ Neps) HlS2 HcS HepsS HepsltgapS). }
		      claim Hsumlt2: add_SNo c (eps_ Neps) < l.
		      { rewrite (add_SNo_com c (eps_ Neps) HcS HepsS).
		        exact Hsumlt1. }
		      claim Hclm: c < add_SNo l (minus_SNo (eps_ Neps)).
		      { exact (add_SNo_minus_Lt2b l (eps_ Neps) c HlS2 HepsS HcS Hsumlt2). }
		      claim HclmR: add_SNo l (minus_SNo (eps_ Neps)) :e R.
		      { exact (real_add_SNo l HlR (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
		      claim HclmRlt: Rlt c (add_SNo l (minus_SNo (eps_ Neps))).
		      { exact (RltI c (add_SNo l (minus_SNo (eps_ Neps))) HcR HclmR Hclm). }

		      (** get a∈A with l-eps < a **)
		      claim Hexa: exists a:set, a :e A /\ a :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
		      { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR Hepspos). }
		      apply Hexa.
		      let a. assume Haa.
		      claim Haa1: a :e A /\ a :e R.
		      { exact (andEL (a :e A /\ a :e R)
		                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
		                     Haa). }
		      claim HaA: a :e A.
		      { exact (andEL (a :e A) (a :e R) Haa1). }
		      claim HaR: a :e R.
		      { exact (andER (a :e A) (a :e R) Haa1). }
		      claim Hltlm: Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
		      { exact (andER (a :e A /\ a :e R)
		                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
		                     Haa). }
		      claim Hcalt: c < a.
		      { exact (RltE_lt c a (Rlt_tra c (add_SNo l (minus_SNo (eps_ Neps))) a HclmRlt Hltlm)). }
		      claim Hca: Rlt c a.
		      { exact (RltI c a HcR HaR Hcalt). }

		      (** show a < d using a ≤ l and l < d **)
		      claim Hlubcore: l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		      { exact (andEL (l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l)
		                     (forall u:set, u :e R ->
		                        (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u) ->
		                        Rle l u)
		                     Hlub). }
		      claim HubA2: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		      { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
		      claim Hale_l: Rle a l.
		      { exact (HubA2 a HaA HaR). }
		      claim Hnltla: ~(Rlt l a).
		      { exact (RleE_nlt a l Hale_l). }
		      claim Had: Rlt a d.
		      { apply (SNoLt_trichotomy_or_impred a l (real_SNo a HaR) HlS2 (Rlt a d)).
		        - assume Haltl: a < l.
		          claim HaltlR: Rlt a l.
		          { exact (RltI a l HaR HlR Haltl). }
		          exact (Rlt_tra a l d HaltlR Hld).
		        - assume Haeq: a = l.
		          rewrite Haeq.
		          exact Hld.
		        - assume Hlta: l < a.
		          claim HltaR: Rlt l a.
		          { exact (RltI l a HlR HaR Hlta). }
		          exact (FalseE (Hnltla HltaR) (Rlt a d)). }

		      (** now a ∈ V and a ∈ U, contradiction with disjointness **)
		      claim HaInInt: a :e open_interval c d.
		      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) a HaR (andI (Rlt c a) (Rlt a d) Hca Had)). }
		      claim HaV: a :e V.
		      { exact (HIntSubV a HaInInt). }
		      claim HaU: a :e U.
		      { exact (SepE1 U (fun u:set => Rlt u v0) a HaA). }
		      claim HaUV: a :e U :/\: V.
		      { exact (binintersectI U V a HaU HaV). }
		      claim HaEmpty: a :e Empty.
		      { rewrite <- Hdisj.
		        exact HaUV. }
		      exact (EmptyE a HaEmpty).
	  - assume Heq: u0 = v0.
	    claim Hu0V: u0 :e V.
	    { rewrite Heq at 1.
	      exact Hv0V. }
    claim Hu0UV: u0 :e U :/\: V.
    { exact (binintersectI U V u0 Hu0U Hu0V). }
    claim Hu0Empty: u0 :e Empty.
    { rewrite <- Hdisj.
      exact Hu0UV. }
    exact (EmptyE u0 Hu0Empty).
  - assume Hv0ltu0: v0 < u0.
    (** symmetric case: swap the roles of U and V **)
    set A := {v :e V|Rlt v u0}.
    claim Hv0Rltu0: Rlt v0 u0.
    { exact (RltI v0 u0 Hv0R Hu0R Hv0ltu0). }
    claim Hv0inA: v0 :e A.
    { exact (SepI V (fun v:set => Rlt v u0) v0 Hv0V Hv0Rltu0). }
    claim HAinR: forall a:set, a :e A -> a :e R.
    { let a. assume HaA: a :e A.
      claim HaV: a :e V.
      { exact (SepE1 V (fun v:set => Rlt v u0) a HaA). }
      exact (HVsub a HaV). }
    claim Hub_ex: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
    { witness u0.
      apply andI.
      - exact Hu0R.
      - let a. assume HaA: a :e A.
        assume _. (** a :e R **)
        claim Harlt: Rlt a u0.
        { exact (SepE2 V (fun v:set => Rlt v u0) a HaA). }
        exact (Rlt_implies_Rle a u0 Harlt). }
    claim HAnen: exists a0:set, a0 :e A.
    { witness v0. exact Hv0inA. }
    claim Hexlub: exists l:set, R_lub A l.
    { exact (R_lub_exists A HAnen HAinR Hub_ex). }
    apply Hexlub.
    let l. assume Hlub: R_lub A l.
    claim HlR: l :e R.
    { exact (R_lub_in_R A l Hlub). }
	    claim HlUV: l :e U :\/: V.
	    { rewrite Hunion.
	      exact HlR. }
	    apply (binunionE U V l HlUV).
		    + assume HlU: l :e U.
		      (** use openness of U around l and approximation-from-below to force a point in U∩V (symmetric to the previous branch) **)
		      (** get an interval (c,d) around l contained in U **)
		      claim Hexcd: exists c d:set,
		        c :e R /\ d :e R /\
		        l :e open_interval c d /\
		        open_interval c d c= U /\
		        Rlt c l /\ Rlt l d.
		      { exact (R_standard_open_refine_interval U l HUopen HlU). }
		      apply Hexcd.
		      let c. assume Hexd.
		      apply Hexd.
		      let d. assume Hcdpack.
		      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l).
		      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l)
		                     (Rlt l d)
		                     Hcdpack). }
		      claim Hld: Rlt l d.
		      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U) /\ Rlt c l)
		                     (Rlt l d)
		                     Hcdpack). }
		      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U).
		      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U)
		                     (Rlt c l)
		                     Hcd1). }
		      claim Hcl: Rlt c l.
		      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= U)
		                     (Rlt c l)
		                     Hcd1). }
		      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
		      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
		                     (open_interval c d c= U)
		                     Hcd2). }
		      claim HIntSubU: open_interval c d c= U.
		      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
		                     (open_interval c d c= U)
		                     Hcd2). }
		      claim HcR: c :e R.
		      { exact (andEL (c :e R) (d :e R)
		                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
		      claim HdR: d :e R.
		      { exact (andER (c :e R) (d :e R)
		                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
		      claim HlS2: SNo l.
		      { exact (real_SNo l HlR). }
		      claim HdS: SNo d.
		      { exact (real_SNo d HdR). }

		      (** pick eps0 < l-c **)
		      set gap := add_SNo l (minus_SNo c).
		      claim HgapR: gap :e R.
		      { exact (real_add_SNo l HlR (minus_SNo c) (real_minus_SNo c HcR)). }
		      claim HgapPos: Rlt 0 gap.
		      { exact (Rlt_0_diff_of_lt c l Hcl). }
		      claim Hexeps: exists Neps :e omega, eps_ Neps < gap.
		      { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
		      apply Hexeps.
		      let Neps. assume HNepspair.
		      claim HNepsO: Neps :e omega.
		      { exact (andEL (Neps :e omega) (eps_ Neps < gap) HNepspair). }
		      claim HepsltS: eps_ Neps < gap.
		      { exact (andER (Neps :e omega) (eps_ Neps < gap) HNepspair). }
		      claim HepsR: eps_ Neps :e R.
		      { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
		      claim HepsposS: 0 < eps_ Neps.
		      { exact (SNo_eps_pos Neps HNepsO). }
		      claim Hepspos: Rlt 0 (eps_ Neps).
		      { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }

		      (** show c < l - eps **)
		      claim HcS: SNo c.
		      { exact (real_SNo c HcR). }
		      claim HepsS: SNo (eps_ Neps).
		      { exact (real_SNo (eps_ Neps) HepsR). }
		      claim HepsltR: Rlt (eps_ Neps) gap.
		      { exact (RltI (eps_ Neps) gap HepsR HgapR HepsltS). }
		      claim HepsltgapS: eps_ Neps < gap.
		      { exact (RltE_lt (eps_ Neps) gap HepsltR). }
		      claim Hsumlt1: add_SNo (eps_ Neps) c < l.
		      { exact (add_SNo_minus_Lt2 l c (eps_ Neps) HlS2 HcS HepsS HepsltgapS). }
		      claim Hsumlt2: add_SNo c (eps_ Neps) < l.
		      { rewrite (add_SNo_com c (eps_ Neps) HcS HepsS).
		        exact Hsumlt1. }
		      claim Hclm: c < add_SNo l (minus_SNo (eps_ Neps)).
		      { exact (add_SNo_minus_Lt2b l (eps_ Neps) c HlS2 HepsS HcS Hsumlt2). }
		      claim HclmR: add_SNo l (minus_SNo (eps_ Neps)) :e R.
		      { exact (real_add_SNo l HlR (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
		      claim HclmRlt: Rlt c (add_SNo l (minus_SNo (eps_ Neps))).
		      { exact (RltI c (add_SNo l (minus_SNo (eps_ Neps))) HcR HclmR Hclm). }

		      (** get a∈A with l-eps < a **)
		      claim Hexa: exists a:set, a :e A /\ a :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
		      { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR Hepspos). }
		      apply Hexa.
		      let a. assume Haa.
		      claim Haa1: a :e A /\ a :e R.
		      { exact (andEL (a :e A /\ a :e R)
		                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
		                     Haa). }
		      claim HaA: a :e A.
		      { exact (andEL (a :e A) (a :e R) Haa1). }
		      claim HaR: a :e R.
		      { exact (andER (a :e A) (a :e R) Haa1). }
		      claim Hltlm: Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
		      { exact (andER (a :e A /\ a :e R)
		                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
		                     Haa). }
		      claim Hcalt: c < a.
		      { exact (RltE_lt c a (Rlt_tra c (add_SNo l (minus_SNo (eps_ Neps))) a HclmRlt Hltlm)). }
		      claim Hca: Rlt c a.
		      { exact (RltI c a HcR HaR Hcalt). }

		      (** show a < d using a ≤ l and l < d **)
		      claim Hlubcore: l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		      { exact (andEL (l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l)
		                     (forall u:set, u :e R ->
		                        (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u) ->
		                        Rle l u)
		                     Hlub). }
		      claim HubA2: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		      { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
		      claim Hale_l: Rle a l.
		      { exact (HubA2 a HaA HaR). }
		      claim Hnltla: ~(Rlt l a).
		      { exact (RleE_nlt a l Hale_l). }
		      claim Had: Rlt a d.
		      { apply (SNoLt_trichotomy_or_impred a l (real_SNo a HaR) HlS2 (Rlt a d)).
		        - assume Haltl: a < l.
		          claim HaltlR: Rlt a l.
		          { exact (RltI a l HaR HlR Haltl). }
		          exact (Rlt_tra a l d HaltlR Hld).
		        - assume Haeq: a = l.
		          rewrite Haeq.
		          exact Hld.
		        - assume Hlta: l < a.
		          claim HltaR: Rlt l a.
		          { exact (RltI l a HlR HaR Hlta). }
		          exact (FalseE (Hnltla HltaR) (Rlt a d)). }

		      (** now a ∈ U and a ∈ V, contradiction with disjointness **)
		      claim HaInInt: a :e open_interval c d.
		      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) a HaR (andI (Rlt c a) (Rlt a d) Hca Had)). }
		      claim HaU: a :e U.
		      { exact (HIntSubU a HaInInt). }
		      claim HaV: a :e V.
		      { exact (SepE1 V (fun v:set => Rlt v u0) a HaA). }
		      claim HaUV: a :e U :/\: V.
		      { exact (binintersectI U V a HaU HaV). }
		      claim HaEmpty: a :e Empty.
		      { rewrite <- Hdisj.
		        exact HaUV. }
		      exact (EmptyE a HaEmpty).
	    + assume HlV: l :e V.
	      (** use openness of V around l to get v1∈A above l, contradicting lub upper bound (symmetric to the previous branch) **)
	      (** obtain the upper bound clause from the lub **)
	      claim Hlubcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
	      { exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
	                     (forall u:set, u :e R ->
	                        (forall a:set, a :e A -> a :e R -> Rle a u) ->
	                        Rle l u)
	                     Hlub). }
	      claim HubA: forall a:set, a :e A -> a :e R -> Rle a l.
	      { exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hlubcore). }
	      claim Hmin: forall u:set, u :e R ->
	        (forall a:set, a :e A -> a :e R -> Rle a u) ->
	        Rle l u.
	      { exact (andER (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
	                     (forall u:set, u :e R ->
	                        (forall a:set, a :e A -> a :e R -> Rle a u) ->
	                        Rle l u)
	                     Hlub). }

	      (** u0 is an upper bound of A **)
	      claim Hub_u0: forall a:set, a :e A -> a :e R -> Rle a u0.
	      { let a. assume HaA: a :e A.
	        assume HaR: a :e R.
	        claim Harlt: Rlt a u0.
	        { exact (SepE2 V (fun v:set => Rlt v u0) a HaA). }
	        exact (Rlt_implies_Rle a u0 Harlt). }
	      claim Hle_l_u0: Rle l u0.
	      { exact (Hmin u0 Hu0R Hub_u0). }

	      (** u0 is not in V since u0 is in U and U ∩ V = Empty **)
	      claim Hu0notV: u0 /:e V.
	      { assume Hu0V: u0 :e V.
	        claim Hu0UV: u0 :e U :/\: V.
	        { exact (binintersectI U V u0 Hu0U Hu0V). }
	        claim Hu0Empty: u0 :e Empty.
	        { rewrite <- Hdisj.
	          exact Hu0UV. }
	        exact (EmptyE u0 Hu0Empty). }

	      (** derive strict l < u0 from l ≤ u0 and l ∈ V **)
	      claim HlS: SNo l.
	      { exact (real_SNo l HlR). }
	      claim Hlu0: Rlt l u0.
	      { apply (SNoLt_trichotomy_or_impred l u0 HlS Hu0S (Rlt l u0)).
	        - assume Hlt: l < u0.
	          exact (RltI l u0 HlR Hu0R Hlt).
	        - assume Heq: l = u0.
	          claim Hu0V: u0 :e V.
	          { rewrite <- Heq.
	            exact HlV. }
	          exact (FalseE (Hu0notV Hu0V) (Rlt l u0)).
	        - assume Hgt: u0 < l.
	          claim Hu0l: Rlt u0 l.
	          { exact (RltI u0 l Hu0R HlR Hgt). }
	          claim Hnlt: ~(Rlt u0 l).
	          { exact (RleE_nlt l u0 Hle_l_u0). }
	          exact (FalseE (Hnlt Hu0l) (Rlt l u0)). }

	      (** obtain an interval (c,d) around l contained in V **)
	      claim Hexcd: exists c d:set,
	        c :e R /\ d :e R /\
	        l :e open_interval c d /\
	        open_interval c d c= V /\
	        Rlt c l /\ Rlt l d.
	      { exact (R_standard_open_refine_interval V l HVopen HlV). }
	      apply Hexcd.
	      let c. assume Hexd.
	      apply Hexd.
	      let d. assume Hcdpack.
	      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l).
	      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l)
	                     (Rlt l d)
	                     Hcdpack). }
	      claim Hld: Rlt l d.
	      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V) /\ Rlt c l)
	                     (Rlt l d)
	                     Hcdpack). }
	      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V).
	      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V)
	                     (Rlt c l)
	                     Hcd1). }
	      claim Hcl: Rlt c l.
	      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= V)
	                     (Rlt c l)
	                     Hcd1). }
	      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
	      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
	                     (open_interval c d c= V)
	                     Hcd2). }
	      claim HIntSubV: open_interval c d c= V.
	      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
	                     (open_interval c d c= V)
	                     Hcd2). }
	      claim HcR: c :e R.
	      { exact (andEL (c :e R) (d :e R)
	                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
	      claim HdR: d :e R.
	      { exact (andER (c :e R) (d :e R)
	                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
	      claim HdS: SNo d.
	      { exact (real_SNo d HdR). }
	      claim Hrltd: l < d.
	      { exact (RltE_lt l d Hld). }

	      (** define positive gaps d-l and u0-l **)
	      set gap1 := add_SNo d (minus_SNo l).
	      set gap2 := add_SNo u0 (minus_SNo l).
	      claim Hgap1R: gap1 :e R.
	      { exact (real_add_SNo d HdR (minus_SNo l) (real_minus_SNo l HlR)). }
	      claim Hgap2R: gap2 :e R.
	      { exact (real_add_SNo u0 Hu0R (minus_SNo l) (real_minus_SNo l HlR)). }
	      claim Hgap1pos: Rlt 0 gap1.
	      { exact (Rlt_0_diff_of_lt l d Hld). }
	      claim Hgap2pos: Rlt 0 gap2.
	      { exact (Rlt_0_diff_of_lt l u0 Hlu0). }

	      (** choose r3 < gap1 and r3 < gap2 **)
	      apply (exists_eps_lt_two_pos_Euclid gap1 gap2 Hgap1R Hgap2R Hgap1pos Hgap2pos).
	      let r3. assume Hr3pack.
	      claim Hr3p1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1.
	      { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
	                     (Rlt r3 gap2)
	                     Hr3pack). }
	      claim Hr3ltgap2: Rlt r3 gap2.
	      { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
	                     (Rlt r3 gap2)
	                     Hr3pack). }
	      claim Hr3p0: r3 :e R /\ Rlt 0 r3.
	      { exact (andEL (r3 :e R /\ Rlt 0 r3)
	                     (Rlt r3 gap1)
	                     Hr3p1). }
	      claim Hr3ltgap1: Rlt r3 gap1.
	      { exact (andER (r3 :e R /\ Rlt 0 r3)
	                     (Rlt r3 gap1)
	                     Hr3p1). }
	      claim Hr3R: r3 :e R.
	      { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3p0). }
	      claim Hr3pos: Rlt 0 r3.
	      { exact (andER (r3 :e R) (Rlt 0 r3) Hr3p0). }
	      claim Hr3S: SNo r3.
	      { exact (real_SNo r3 Hr3R). }
	      claim Hr3posS: 0 < r3.
	      { exact (RltE_lt 0 r3 Hr3pos). }

	      (** set v1 = l + r3 **)
	      claim Hv1R: add_SNo l r3 :e R.
	      { exact (real_add_SNo l HlR r3 Hr3R). }
	      claim Hv1S: SNo (add_SNo l r3).
	      { exact (real_SNo (add_SNo l r3) Hv1R). }
	      (** l < v1 **)
	      claim Hl_lt_v1S: l < add_SNo l r3.
	      { claim Hl0: add_SNo l 0 = l.
	        { exact (add_SNo_0R l HlS). }
	        claim Hlt: add_SNo l 0 < add_SNo l r3.
	        { exact (add_SNo_Lt2 l 0 r3 HlS SNo_0 Hr3S Hr3posS). }
	        rewrite <- Hl0 at 1.
	        exact Hlt. }
	      claim Hl_lt_v1: Rlt l (add_SNo l r3).
	      { exact (RltI l (add_SNo l r3) HlR Hv1R Hl_lt_v1S). }

	      (** v1 < d and v1 < u0 from r3 < gap1 and r3 < gap2 **)
	      claim Hr3ltgap1S: r3 < gap1.
	      { exact (RltE_lt r3 gap1 Hr3ltgap1). }
	      claim Hgap1S: SNo gap1.
	      { exact (real_SNo gap1 Hgap1R). }
	      claim Hv1lt_dS': add_SNo r3 l < d.
	      { exact (add_SNo_minus_Lt2 d l r3 HdS HlS Hr3S Hr3ltgap1S). }
	      claim Hv1lt_dS: add_SNo l r3 < d.
	      { claim Hcom2: add_SNo r3 l = add_SNo l r3.
	        { exact (add_SNo_com r3 l Hr3S HlS). }
	        rewrite <- Hcom2.
	        exact Hv1lt_dS'. }
	      claim Hv1lt_d: Rlt (add_SNo l r3) d.
	      { exact (RltI (add_SNo l r3) d Hv1R HdR Hv1lt_dS). }

	      claim Hr3ltgap2S: r3 < gap2.
	      { exact (RltE_lt r3 gap2 Hr3ltgap2). }
	      claim Hgap2S: SNo gap2.
	      { exact (real_SNo gap2 Hgap2R). }
	      claim Hv1lt_u0S': add_SNo r3 l < u0.
	      { exact (add_SNo_minus_Lt2 u0 l r3 Hu0S HlS Hr3S Hr3ltgap2S). }
	      claim Hv1lt_u0S: add_SNo l r3 < u0.
	      { claim Hcom3: add_SNo r3 l = add_SNo l r3.
	        { exact (add_SNo_com r3 l Hr3S HlS). }
	        rewrite <- Hcom3.
	        exact Hv1lt_u0S'. }
	      claim Hv1lt_u0: Rlt (add_SNo l r3) u0.
	      { exact (RltI (add_SNo l r3) u0 Hv1R Hu0R Hv1lt_u0S). }

	      (** v1 ∈ V and hence v1 ∈ A **)
	      claim Hv1InInt: add_SNo l r3 :e open_interval c d.
	      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) (add_SNo l r3) Hv1R
	                   (andI (Rlt c (add_SNo l r3)) (Rlt (add_SNo l r3) d)
	                         (Rlt_tra c l (add_SNo l r3) Hcl Hl_lt_v1)
	                         Hv1lt_d)). }
	      claim Hv1V: add_SNo l r3 :e V.
	      { exact (HIntSubV (add_SNo l r3) Hv1InInt). }
	      claim Hv1A: add_SNo l r3 :e A.
	      { exact (SepI V (fun v:set => Rlt v u0) (add_SNo l r3) Hv1V Hv1lt_u0). }

	      (** contradiction with upper bound property HubA **)
	      claim Hv1le_l: Rle (add_SNo l r3) l.
	      { exact (HubA (add_SNo l r3) Hv1A Hv1R). }
	      claim Hnlt: ~(Rlt l (add_SNo l r3)).
	      { exact (RleE_nlt (add_SNo l r3) l Hv1le_l). }
	      exact (Hnlt Hl_lt_v1).
Qed.

(** from §24 Theorem 24.3: intermediate value theorem (order topology) **)
(** LATEX VERSION: If f:X→Y is continuous, X is connected, and r lies between f(a) and f(b), then ∃c∈X with f(c)=r. **)
Definition between_in_order : set -> set -> set -> set -> prop := fun Y u r v =>
  (order_rel Y u r /\ order_rel Y r v)
  \/ (order_rel Y v r /\ order_rel Y r u)
  \/ r = u
  \/ r = v.

(** Helper: introduction rule for between_in_order using u <= r <= v **)
Theorem between_in_orderI_left : forall Y u r v:set,
  order_rel Y u r ->
  order_rel Y r v ->
  between_in_order Y u r v.
let Y u r v.
assume Hur: order_rel Y u r.
assume Hrv: order_rel Y r v.
prove between_in_order Y u r v.
prove (order_rel Y u r /\ order_rel Y r v)
  \/ (order_rel Y v r /\ order_rel Y r u)
  \/ r = u
  \/ r = v.
apply orIL.
apply orIL.
apply orIL.
exact (andI (order_rel Y u r) (order_rel Y r v) Hur Hrv).
Qed.

(** Helper: introduction rule for between_in_order using v <= r <= u **)
Theorem between_in_orderI_right : forall Y u r v:set,
  order_rel Y v r ->
  order_rel Y r u ->
  between_in_order Y u r v.
let Y u r v.
assume Hvr: order_rel Y v r.
assume Hru: order_rel Y r u.
prove between_in_order Y u r v.
prove (order_rel Y u r /\ order_rel Y r v)
  \/ (order_rel Y v r /\ order_rel Y r u)
  \/ r = u
  \/ r = v.
apply orIL.
apply orIL.
apply orIR.
exact (andI (order_rel Y v r) (order_rel Y r u) Hvr Hru).
Qed.

(** Helper: introduction rule for between_in_order when r = u **)
Theorem between_in_orderI_eq_left : forall Y u v:set,
  between_in_order Y u u v.
let Y u v.
prove between_in_order Y u u v.
prove (order_rel Y u u /\ order_rel Y u v)
  \/ (order_rel Y v u /\ order_rel Y u u)
  \/ u = u
  \/ u = v.
apply orIL.
apply orIR.
reflexivity.
Qed.

(** Helper: introduction rule for between_in_order when r = v **)
Theorem between_in_orderI_eq_right : forall Y u v:set,
  between_in_order Y u v v.
let Y u v.
prove between_in_order Y u v v.
prove (order_rel Y u v /\ order_rel Y v v)
  \/ (order_rel Y v v /\ order_rel Y v u)
  \/ v = u
  \/ v = v.
apply orIR.
reflexivity.
Qed.

(** from §24 Theorem 24.3: intermediate value theorem (order topology) **)
(** LATEX VERSION: If f is continuous and X is connected, every value between f(a) and f(b) is attained. **)
(** LATEX VERSION: Intermediate value theorem, stated as a derived theorem wrapper. **)
Theorem intermediate_value_theorem : forall X Tx Y f a b r:set,
  connected_space X Tx ->
  simply_ordered_set Y ->
  continuous_map X Tx Y (order_topology Y) f ->
  a :e X -> b :e X -> r :e Y ->
  between_in_order Y (apply_fun f a) r (apply_fun f b) ->
  exists c:set, c :e X /\ apply_fun f c = r.
let X Tx Y f a b r.
assume Hconn: connected_space X Tx.
assume HsoY: simply_ordered_set Y.
assume Hcont: continuous_map X Tx Y (order_topology Y) f.
assume Ha: a :e X.
assume Hb: b :e X.
assume Hr: r :e Y.
assume Hbetw: between_in_order Y (apply_fun f a) r (apply_fun f b).
prove exists c:set, c :e X /\ apply_fun f c = r.
set Im := image_of f X.
set Tim := subspace_topology Y (order_topology Y) Im.
claim HImconn: connected_space Im Tim.
{ exact (continuous_image_connected X Tx Y (order_topology Y) f Hconn Hcont). }
(** If r equals one of the endpoint values then we can witness immediately; the strict-between case is left admitted **)
apply (Hbetw (exists c:set, c :e X /\ apply_fun f c = r)).
- assume Hcases1:
    ((order_rel Y (apply_fun f a) r /\ order_rel Y r (apply_fun f b))
      \/ (order_rel Y (apply_fun f b) r /\ order_rel Y r (apply_fun f a)))
    \/ r = apply_fun f a.
  apply (Hcases1 (exists c:set, c :e X /\ apply_fun f c = r)).
		  + assume Hstrict:
		      (order_rel Y (apply_fun f a) r /\ order_rel Y r (apply_fun f b))
		      \/ (order_rel Y (apply_fun f b) r /\ order_rel Y r (apply_fun f a)).
		    (** Reduce to showing r lies in the image Im = f(X); the connectedness argument is deferred. **)
		    claim HrIm: r :e Im.
		    { (** If r were not in Im, the two rays around r would separate Im in the subspace order topology. **)
		      apply (xm (r :e Im)).
		      - assume HrIm. exact HrIm.
		      - assume HrnotIm: r /:e Im.
		        (** Im is a subset of Y since f is continuous (hence function_on). **)
		        claim HXsubX: X c= X.
		        { let x. assume Hx: x :e X.
		          exact Hx. }
		        claim Hfun: function_on f X Y.
		        { exact (continuous_map_function_on X Tx Y (order_topology Y) f Hcont). }
		        claim HImsubY: Im c= Y.
		        { exact (image_of_sub_codomain f X Y X Hfun HXsubX). }
		        (** The ray sets in Y. **)
		        set Lray := open_ray_lower Y r.
		        set Uray := open_ray_upper Y r.
		        claim HLsub: open_rays_subbasis Y c= order_topology Y.
		        { exact (open_rays_subbasis_sub_order_topology Y HsoY). }
		        claim HLraySub: Lray :e open_rays_subbasis Y.
		        { exact (open_ray_lower_in_open_rays_subbasis Y r Hr). }
		        claim HUraySub: Uray :e open_rays_subbasis Y.
		        { exact (open_ray_upper_in_open_rays_subbasis Y r Hr). }
		        claim HLrayOpen: Lray :e order_topology Y.
		        { exact (HLsub Lray HLraySub). }
		        claim HUrayOpen: Uray :e order_topology Y.
		        { exact (HLsub Uray HUraySub). }
		        (** Define the induced open sets on Im. **)
		        set U := Lray :/\: Im.
		        set V := Uray :/\: Im.
		        claim HUinTim: U :e Tim.
		        { exact (subspace_topologyI Y (order_topology Y) Im Lray HLrayOpen). }
		        claim HVinTim: V :e Tim.
		        { exact (subspace_topologyI Y (order_topology Y) Im Uray HUrayOpen). }
		        (** Build a separation_of Im U V, using the strict-between assumption to show both sides are nonempty. **)
		        claim HsepUV: separation_of Im U V.
		        { (** U,V ⊆ Im **)
		          claim HUsubIm: U c= Im.
		          { exact (binintersect_Subq_2 Lray Im). }
		          claim HVsubIm: V c= Im.
		          { exact (binintersect_Subq_2 Uray Im). }
		          claim HUpowIm: U :e Power Im.
		          { exact (PowerI Im U HUsubIm). }
		          claim HVpowIm: V :e Power Im.
		          { exact (PowerI Im V HVsubIm). }
		          (** disjointness: if y<r and r<y then y<y, contradicting irreflexivity **)
		          claim Hdisj: U :/\: V = Empty.
		          { apply Empty_eq.
		            let y. assume Hy: y :e U :/\: V.
		            apply (binintersectE U V y Hy).
		            assume HyU: y :e U.
		            assume HyV: y :e V.
		            claim HyIm: y :e Im.
		            { exact (binintersectE2 Lray Im y HyU). }
		            claim HyY: y :e Y.
		            { exact (HImsubY y HyIm). }
		            claim HyL: y :e Lray.
		            { exact (binintersectE1 Lray Im y HyU). }
		            claim HyUray: y :e Uray.
		            { exact (binintersectE1 Uray Im y HyV). }
		            claim Hyr: order_rel Y y r.
		            { exact (SepE2 Y (fun x0:set => order_rel Y x0 r) y HyL). }
		            claim Hry: order_rel Y r y.
		            { exact (SepE2 Y (fun x0:set => order_rel Y r x0) y HyUray). }
		            claim Hyy: order_rel Y y y.
		            { exact (order_rel_trans Y y r y HsoY HyY Hr HyY Hyr Hry). }
		            apply FalseE.
		            exact ((order_rel_irref Y y) Hyy). }
		          (** Nonemptiness from the strict-between assumption. **)
		          claim HUne: U <> Empty.
		          { apply (Hstrict (U <> Empty)).
		            - assume Hlr: order_rel Y (apply_fun f a) r /\ order_rel Y r (apply_fun f b).
		              claim Hfar: order_rel Y (apply_fun f a) r.
		              { exact (andEL (order_rel Y (apply_fun f a) r)
		                             (order_rel Y r (apply_fun f b))
		                             Hlr). }
		              claim HfaIm: apply_fun f a :e Im.
		              { exact (ReplI X (fun x0:set => apply_fun f x0) a Ha). }
		              claim HfaY: apply_fun f a :e Y.
		              { exact (HImsubY (apply_fun f a) HfaIm). }
		              claim HfaL: apply_fun f a :e Lray.
		              { exact (SepI Y (fun x0:set => order_rel Y x0 r) (apply_fun f a) HfaY Hfar). }
		              claim HfaU: apply_fun f a :e U.
		              { exact (binintersectI Lray Im (apply_fun f a) HfaL HfaIm). }
		              exact (elem_implies_nonempty U (apply_fun f a) HfaU).
		            - assume Hrl: order_rel Y (apply_fun f b) r /\ order_rel Y r (apply_fun f a).
		              claim Hfbr: order_rel Y (apply_fun f b) r.
		              { exact (andEL (order_rel Y (apply_fun f b) r)
		                             (order_rel Y r (apply_fun f a))
		                             Hrl). }
		              claim HfbIm: apply_fun f b :e Im.
		              { exact (ReplI X (fun x0:set => apply_fun f x0) b Hb). }
		              claim HfbY: apply_fun f b :e Y.
		              { exact (HImsubY (apply_fun f b) HfbIm). }
		              claim HfbL: apply_fun f b :e Lray.
		              { exact (SepI Y (fun x0:set => order_rel Y x0 r) (apply_fun f b) HfbY Hfbr). }
		              claim HfbU: apply_fun f b :e U.
		              { exact (binintersectI Lray Im (apply_fun f b) HfbL HfbIm). }
		              exact (elem_implies_nonempty U (apply_fun f b) HfbU). }
		          claim HVne: V <> Empty.
		          { apply (Hstrict (V <> Empty)).
		            - assume Hlr: order_rel Y (apply_fun f a) r /\ order_rel Y r (apply_fun f b).
		              claim Hrfb: order_rel Y r (apply_fun f b).
		              { exact (andER (order_rel Y (apply_fun f a) r)
		                             (order_rel Y r (apply_fun f b))
		                             Hlr). }
		              claim HfbIm: apply_fun f b :e Im.
		              { exact (ReplI X (fun x0:set => apply_fun f x0) b Hb). }
		              claim HfbY: apply_fun f b :e Y.
		              { exact (HImsubY (apply_fun f b) HfbIm). }
		              claim HfbUray: apply_fun f b :e Uray.
		              { exact (SepI Y (fun x0:set => order_rel Y r x0) (apply_fun f b) HfbY Hrfb). }
		              claim HfbV: apply_fun f b :e V.
		              { exact (binintersectI Uray Im (apply_fun f b) HfbUray HfbIm). }
		              exact (elem_implies_nonempty V (apply_fun f b) HfbV).
		            - assume Hrl: order_rel Y (apply_fun f b) r /\ order_rel Y r (apply_fun f a).
		              claim Hrfa: order_rel Y r (apply_fun f a).
		              { exact (andER (order_rel Y (apply_fun f b) r)
		                             (order_rel Y r (apply_fun f a))
		                             Hrl). }
		              claim HfaIm: apply_fun f a :e Im.
		              { exact (ReplI X (fun x0:set => apply_fun f x0) a Ha). }
		              claim HfaY: apply_fun f a :e Y.
		              { exact (HImsubY (apply_fun f a) HfaIm). }
		              claim HfaUray: apply_fun f a :e Uray.
		              { exact (SepI Y (fun x0:set => order_rel Y r x0) (apply_fun f a) HfaY Hrfa). }
		              claim HfaV: apply_fun f a :e V.
		              { exact (binintersectI Uray Im (apply_fun f a) HfaUray HfaIm). }
		              exact (elem_implies_nonempty V (apply_fun f a) HfaV). }
		          (** union: every y∈Im lies on one side since r∉Im **)
		          claim Hunion: U :\/: V = Im.
		          { apply set_ext.
		            - let y. assume Hy: y :e U :\/: V.
		              prove y :e Im.
		              apply (binunionE U V y Hy).
		              + assume HyU: y :e U.
		                exact (binintersectE2 Lray Im y HyU).
		              + assume HyV: y :e V.
		                exact (binintersectE2 Uray Im y HyV).
		            - let y. assume HyIm: y :e Im.
		              prove y :e U :\/: V.
		              claim HyY: y :e Y.
		              { exact (HImsubY y HyIm). }
		              apply (order_rel_trichotomy_or_impred Y y r HsoY HyY Hr (y :e U :\/: V)).
		              + assume Hyr: order_rel Y y r.
		                apply (binunionI1 U V y).
		                claim HyL: y :e Lray.
		                { exact (SepI Y (fun x0:set => order_rel Y x0 r) y HyY Hyr). }
		                exact (binintersectI Lray Im y HyL HyIm).
		              + assume Heq: y = r.
		                apply FalseE.
		                claim HrIm0: r :e Im.
		                { rewrite <- Heq.
		                  exact HyIm. }
		                exact (HrnotIm HrIm0).
		              + assume Hry: order_rel Y r y.
		                apply (binunionI2 U V y).
		                claim HyUray: y :e Uray.
		                { exact (SepI Y (fun x0:set => order_rel Y r x0) y HyY Hry). }
		                exact (binintersectI Uray Im y HyUray HyIm). }
		          (** pack the separation_of conjunction **)
		          prove U :e Power Im /\ V :e Power Im /\ U :/\: V = Empty /\ U <> Empty /\ V <> Empty /\ U :\/: V = Im.
		          apply and6I.
		          - exact HUpowIm.
		          - exact HVpowIm.
		          - exact Hdisj.
		          - exact HUne.
		          - exact HVne.
		          - exact Hunion. }
		        (** contradiction with connectedness of Im **)
		        apply FalseE.
		        claim Hnosep: ~(exists U0 V0:set, U0 :e Tim /\ V0 :e Tim /\ separation_of Im U0 V0).
		        { exact (connected_space_no_separation Im Tim HImconn). }
		        apply Hnosep.
		        witness U.
		        witness V.
		        apply andI.
		        - apply andI.
		          + exact HUinTim.
		          + exact HVinTim.
		        - exact HsepUV. }
		    apply (ReplE_impred X (fun x0:set => apply_fun f x0) r HrIm
		           (exists c:set, c :e X /\ apply_fun f c = r)).
		    let c. assume HcX: c :e X.
		    assume Hreq: r = apply_fun f c.
		    witness c.
		    apply andI.
		    * exact HcX.
		    * symmetry.
		      exact Hreq.
		  + assume HrEqFa: r = apply_fun f a.
		    witness a.
		    apply andI.
		    * exact Ha.
    * rewrite <- HrEqFa.
      reflexivity.
- assume HrEqFb: r = apply_fun f b.
  witness b.
  apply andI.
  * exact Hb.
  * rewrite <- HrEqFb.
    reflexivity.
Qed.

(** from §24: connected subspaces of ℝ are intervals **) 
(** LATEX VERSION: A connected subset of the real line contains every point between any two of its points. **)
Theorem connected_subsets_real_are_intervals : forall A:set,
  A c= R ->
  connected_space A (subspace_topology R R_standard_topology A) ->
  forall x y z:set, x :e A -> y :e A -> z :e R ->
    (Rlt x z /\ Rlt z y \/ Rlt y z /\ Rlt z x) -> z :e A.
let A.
assume HA: A c= R.
assume Hconn: connected_space A (subspace_topology R R_standard_topology A).
let x y z.
assume Hx: x :e A.
assume Hy: y :e A.
assume Hz: z :e R.
assume Hbetw: Rlt x z /\ Rlt z y \/ Rlt y z /\ Rlt z x.
prove z :e A.
apply (xm (z :e A)).
- assume HzA: z :e A.
  exact HzA.
- assume HznotA: z /:e A.
  (** If z ∉ A, define U = A∩(-∞,z) and V = A∩(z,∞), show they separate A. **)
  set U := {t :e A|Rlt t z}.
  set V := {t :e A|Rlt z t}.
  (** Extract “no separations” from connectedness of A. **)
  claim Hnosep: ~(exists U0 V0:set,
      U0 :e subspace_topology R R_standard_topology A /\
      V0 :e subspace_topology R R_standard_topology A /\
      separation_of A U0 V0).
  { exact (connected_space_no_separation A (subspace_topology R R_standard_topology A) Hconn). }
  (** Show U and V are in the subspace topology on A. **)
  claim HUinTy: U :e subspace_topology R R_standard_topology A.
  { (** witness the open left ray in R **)
    set L := {t :e R|Rlt t z}.
    claim HLopen: L :e R_standard_topology.
    { exact (open_left_ray_in_R_standard_topology z Hz). }
    claim HUeq: U = L :/\: A.
    { apply set_ext.
      - let t. assume Ht: t :e U.
        prove t :e L :/\: A.
        claim HtA: t :e A.
        { exact (SepE1 A (fun t0:set => Rlt t0 z) t Ht). }
        claim HtR: t :e R.
        { exact (HA t HtA). }
        claim Htlt: Rlt t z.
        { exact (SepE2 A (fun t0:set => Rlt t0 z) t Ht). }
        claim HtL: t :e L.
        { exact (SepI R (fun t0:set => Rlt t0 z) t HtR Htlt). }
        exact (binintersectI L A t HtL HtA).
      - let t. assume Ht: t :e L :/\: A.
        prove t :e U.
        claim HtL: t :e L.
        { exact (binintersectE1 L A t Ht). }
        claim HtA: t :e A.
        { exact (binintersectE2 L A t Ht). }
        claim Htlt: Rlt t z.
        { exact (SepE2 R (fun t0:set => Rlt t0 z) t HtL). }
        exact (SepI A (fun t0:set => Rlt t0 z) t HtA Htlt). }
    (** Now package membership in the subspace topology. **)
    claim HUpow: U :e Power A.
    { apply PowerI.
      let t. assume Ht: t :e U.
      exact (SepE1 A (fun t0:set => Rlt t0 z) t Ht). }
    claim Hex: exists W :e R_standard_topology, U = W :/\: A.
    { witness L.
      apply andI.
      - exact HLopen.
      - exact HUeq. }
    exact (SepI (Power A) (fun U0:set => exists W :e R_standard_topology, U0 = W :/\: A) U HUpow Hex). }
  claim HVinTy: V :e subspace_topology R R_standard_topology A.
  { set Rray := {t :e R|Rlt z t}.
    claim HRopen: Rray :e R_standard_topology.
    { exact (open_ray_in_R_standard_topology z Hz). }
    claim HVeql: V = Rray :/\: A.
    { apply set_ext.
      - let t. assume Ht: t :e V.
        prove t :e Rray :/\: A.
        claim HtA: t :e A.
        { exact (SepE1 A (fun t0:set => Rlt z t0) t Ht). }
        claim HtR: t :e R.
        { exact (HA t HtA). }
        claim Htlt: Rlt z t.
        { exact (SepE2 A (fun t0:set => Rlt z t0) t Ht). }
        claim HtRray: t :e Rray.
        { exact (SepI R (fun t0:set => Rlt z t0) t HtR Htlt). }
        exact (binintersectI Rray A t HtRray HtA).
      - let t. assume Ht: t :e Rray :/\: A.
        prove t :e V.
        claim HtRray: t :e Rray.
        { exact (binintersectE1 Rray A t Ht). }
        claim HtA: t :e A.
        { exact (binintersectE2 Rray A t Ht). }
        claim Htlt: Rlt z t.
        { exact (SepE2 R (fun t0:set => Rlt z t0) t HtRray). }
        exact (SepI A (fun t0:set => Rlt z t0) t HtA Htlt). }
    claim HVpow: V :e Power A.
    { apply PowerI.
      let t. assume Ht: t :e V.
      exact (SepE1 A (fun t0:set => Rlt z t0) t Ht). }
    claim Hex: exists W :e R_standard_topology, V = W :/\: A.
    { witness Rray.
      apply andI.
      - exact HRopen.
      - exact HVeql. }
    exact (SepI (Power A) (fun U0:set => exists W :e R_standard_topology, U0 = W :/\: A) V HVpow Hex). }
  (** Build a separation_of A U V. **)
  claim HsepUV: separation_of A U V.
  { (** U,V ⊆ A **)
    claim HUsubA: U c= A.
    { let t. assume Ht: t :e U.
      exact (SepE1 A (fun t0:set => Rlt t0 z) t Ht). }
    claim HVsubA: V c= A.
    { let t. assume Ht: t :e V.
      exact (SepE1 A (fun t0:set => Rlt z t0) t Ht). }
    claim HUpowA: U :e Power A.
    { exact (PowerI A U HUsubA). }
    claim HVpowA: V :e Power A.
    { exact (PowerI A V HVsubA). }
    (** disjointness **)
    claim Hdisj: U :/\: V = Empty.
    { apply Empty_eq.
      let t. assume Ht: t :e U :/\: V.
      apply (binintersectE U V t Ht).
      assume HtU: t :e U.
      assume HtV: t :e V.
      claim HtA: t :e A.
      { exact (SepE1 A (fun t0:set => Rlt t0 z) t HtU). }
      claim HtR: t :e R.
      { exact (HA t HtA). }
      claim Hlt1: Rlt t z.
      { exact (SepE2 A (fun t0:set => Rlt t0 z) t HtU). }
      claim Hlt2: Rlt z t.
      { exact (SepE2 A (fun t0:set => Rlt z t0) t HtV). }
      claim Htt: Rlt t t.
      { exact (Rlt_tra t z t Hlt1 Hlt2). }
      apply FalseE.
      exact ((not_Rlt_refl t HtR) Htt). }
    (** Nonemptiness of U and V using x,y around z **)
    claim HUne: U <> Empty.
    { apply (xm (Rlt x z /\ Rlt z y)).
      - assume Hxzzy: Rlt x z /\ Rlt z y.
        claim Hxz: Rlt x z.
        { exact (andEL (Rlt x z) (Rlt z y) Hxzzy). }
        claim HxU: x :e U.
        { exact (SepI A (fun t0:set => Rlt t0 z) x Hx Hxz). }
        exact (elem_implies_nonempty U x HxU).
      - assume Hnot.
        (** then use the other disjunct from Hbetw **)
        claim Hyz: Rlt y z.
        { apply Hbetw.
          assume Hxzzy: Rlt x z /\ Rlt z y.
          apply FalseE.
          exact (Hnot Hxzzy).
          assume Hyzzx: Rlt y z /\ Rlt z x.
          exact (andEL (Rlt y z) (Rlt z x) Hyzzx). }
        claim HyU: y :e U.
        { exact (SepI A (fun t0:set => Rlt t0 z) y Hy Hyz). }
        exact (elem_implies_nonempty U y HyU). }
    claim HVne: V <> Empty.
    { apply (xm (Rlt x z /\ Rlt z y)).
      - assume Hxzzy: Rlt x z /\ Rlt z y.
        claim Hzy: Rlt z y.
        { exact (andER (Rlt x z) (Rlt z y) Hxzzy). }
        claim HyV: y :e V.
        { exact (SepI A (fun t0:set => Rlt z t0) y Hy Hzy). }
        exact (elem_implies_nonempty V y HyV).
      - assume Hnot.
        claim Hzx: Rlt z x.
        { apply Hbetw.
          assume Hxzzy: Rlt x z /\ Rlt z y.
          apply FalseE.
          exact (Hnot Hxzzy).
          assume Hyzzx: Rlt y z /\ Rlt z x.
          exact (andER (Rlt y z) (Rlt z x) Hyzzx). }
        claim HxV: x :e V.
        { exact (SepI A (fun t0:set => Rlt z t0) x Hx Hzx). }
        exact (elem_implies_nonempty V x HxV). }
    (** Union is all of A since z ∉ A and order is trichotomous. **)
    claim Hunion: U :\/: V = A.
    { apply set_ext.
      - let t. assume Ht: t :e U :\/: V.
        prove t :e A.
        apply (binunionE U V t Ht).
        + assume HtU. exact (SepE1 A (fun t0:set => Rlt t0 z) t HtU).
        + assume HtV. exact (SepE1 A (fun t0:set => Rlt z t0) t HtV).
      - let t. assume HtA: t :e A.
        prove t :e U :\/: V.
        claim HtR: t :e R.
        { exact (HA t HtA). }
        claim HtS: SNo t.
        { exact (real_SNo t HtR). }
        claim HzS: SNo z.
        { exact (real_SNo z Hz). }
        apply (SNoLt_trichotomy_or_impred t z HtS HzS (t :e U :\/: V)).
        + (** t < z -> t in U **)
          assume Hlt: t < z.
          claim Htlt: Rlt t z.
          { exact (RltI t z HtR Hz Hlt). }
          exact (binunionI1 U V t (SepI A (fun t0:set => Rlt t0 z) t HtA Htlt)).
        + (** t = z -> contradiction since z ∉ A **)
          assume Heq: t = z.
          claim HzA: z :e A.
          { rewrite <- Heq. exact HtA. }
          apply FalseE.
          exact (HznotA HzA).
        + (** z < t -> t in V **)
          assume Hlt: z < t.
          claim Hzt: Rlt z t.
          { exact (RltI z t Hz HtR Hlt). }
          exact (binunionI2 U V t (SepI A (fun t0:set => Rlt z t0) t HtA Hzt)). }
    (** Package separation_of A U V **)
    prove (((((U :e Power A /\ V :e Power A) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty) /\ U :\/: V = A).
    apply andI.
    - prove ((((U :e Power A /\ V :e Power A) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
      apply andI.
      + prove (((U :e Power A /\ V :e Power A) /\ U :/\: V = Empty) /\ U <> Empty).
        apply andI.
        * prove (U :e Power A /\ V :e Power A) /\ U :/\: V = Empty.
          apply andI.
          { apply andI.
            - exact HUpowA.
            - exact HVpowA. }
          { exact Hdisj. }
        * exact HUne.
      + exact HVne.
    - exact Hunion. }
  (** Contradict connectedness **)
  apply FalseE.
  apply Hnosep.
  witness U.
  witness V.
  (** goal is (U∈Ty ∧ V∈Ty) ∧ separation_of A U V **)
  apply andI.
  - apply andI.
    + exact HUinTy.
    + exact HVinTy.
  - exact HsepUV.
Qed.

(** Helper: image of x mapped to (x,y0) is setprod X {y0} **)
Theorem image_of_id_const_is_slice : forall X y0:set,
  image_of (pair_map X {(x,x)|x :e X} (const_fun X y0)) X = setprod X {y0}.
let X y0.
prove image_of (pair_map X {(x,x)|x :e X} (const_fun X y0)) X = setprod X {y0}.
apply set_ext.
- let p. assume Hp: p :e image_of (pair_map X {(x,x)|x :e X} (const_fun X y0)) X.
  prove p :e setprod X {y0}.
  (** unfold image_of **)
  set f := pair_map X {(x,x)|x :e X} (const_fun X y0).
  claim HpRepl: p :e Repl X (fun a => apply_fun f a).
  { exact Hp. }
  apply (ReplE_impred X (fun a:set => apply_fun f a) p HpRepl).
  let a. assume HaX: a :e X.
  assume Heq: p = apply_fun f a.
  rewrite Heq.
  claim Hfa: apply_fun f a = (apply_fun {(x,x)|x :e X} a, apply_fun (const_fun X y0) a).
  { exact (pair_map_apply X X {y0} {(x,x)|x :e X} (const_fun X y0) a HaX). }
  claim Hid: apply_fun {(x,x)|x :e X} a = a.
  { exact (identity_function_apply X a HaX). }
  claim Hc: apply_fun (const_fun X y0) a = y0.
  { exact (const_fun_apply X y0 a HaX). }
  rewrite Hfa.
  rewrite Hid.
  rewrite Hc.
  exact (tuple_2_setprod_by_pair_Sigma X {y0} a y0 HaX (SingI y0)).
- let p. assume Hp: p :e setprod X {y0}.
  prove p :e image_of (pair_map X {(x,x)|x :e X} (const_fun X y0)) X.
  set f := pair_map X {(x,x)|x :e X} (const_fun X y0).
  (** extract coordinates **)
  claim Hp0X: (p 0) :e X.
  { exact (ap0_Sigma X (fun _:set => {y0}) p Hp). }
  claim Hp1Sing: (p 1) :e {y0}.
  { exact (ap1_Sigma X (fun _:set => {y0}) p Hp). }
  claim Hp1eq: (p 1) = y0.
  { exact (singleton_elem (p 1) y0 Hp1Sing). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta X {y0} p Hp). }
  (** show p is in the image by choosing a = p0 **)
  prove p :e Repl X (fun a => apply_fun f a).
  claim Hfp0: apply_fun f (p 0) = (apply_fun {(x,x)|x :e X} (p 0), apply_fun (const_fun X y0) (p 0)).
  { exact (pair_map_apply X X {y0} {(x,x)|x :e X} (const_fun X y0) (p 0) Hp0X). }
  claim Hid0: apply_fun {(x,x)|x :e X} (p 0) = (p 0).
  { exact (identity_function_apply X (p 0) Hp0X). }
  claim Hc0: apply_fun (const_fun X y0) (p 0) = y0.
  { exact (const_fun_apply X y0 (p 0) Hp0X). }
	  claim Hfp0eq: apply_fun f (p 0) = (p 0, p 1).
	  { rewrite Hfp0.
	    rewrite Hid0.
	    rewrite Hc0.
	    rewrite Hp1eq.
	    reflexivity. }
  claim Hp_as_image: p = apply_fun f (p 0).
  { rewrite Heta at 1.
    rewrite Hfp0eq.
    reflexivity. }
  rewrite Hp_as_image.
  exact (ReplI X (fun a:set => apply_fun f a) (p 0) Hp0X).
Qed.

(** Helper: slice X times {y0} is connected when X is connected **)
Theorem slice_X_connected : forall X Tx Y Ty y0:set,
  connected_space X Tx -> topology_on Y Ty -> y0 :e Y ->
  connected_space (setprod X {y0})
    (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod X {y0})).
let X Tx Y Ty y0.
assume HX: connected_space X Tx.
assume HTy: topology_on Y Ty.
assume Hy0: y0 :e Y.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
              (~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V))
              HX). }
set idX := {(x,x)|x :e X}.
set c := const_fun X y0.
set f := pair_map X idX c.
claim Hid: continuous_map X Tx X Tx idX.
{ exact (identity_continuous X Tx HTx). }
claim Hc: continuous_map X Tx Y Ty c.
{ exact (const_fun_continuous X Tx Y Ty y0 HTx HTy Hy0). }
claim Hf: continuous_map X Tx (setprod X Y) (product_topology X Tx Y Ty) f.
{ exact (maps_into_products X Tx X Tx Y Ty idX c Hid Hc). }
claim Himg: connected_space (image_of f X)
  (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (image_of f X)).
{ exact (continuous_image_connected X Tx (setprod X Y) (product_topology X Tx Y Ty) f HX Hf). }
prove connected_space (setprod X {y0})
    (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod X {y0})).
rewrite <- (image_of_id_const_is_slice X y0).
exact Himg.
Qed.

(** Helper: image of y mapped to (x0,y) is setprod {x0} Y **)
Theorem image_of_const_id_is_slice : forall Y x0:set,
  image_of (pair_map Y (const_fun Y x0) {(y,y)|y :e Y}) Y = setprod {x0} Y.
let Y x0.
set idY := {(y,y)|y :e Y}.
prove image_of (pair_map Y (const_fun Y x0) idY) Y = setprod {x0} Y.
apply set_ext.
- let p. assume Hp: p :e image_of (pair_map Y (const_fun Y x0) idY) Y.
  prove p :e setprod {x0} Y.
  set f := pair_map Y (const_fun Y x0) idY.
  claim HpRepl: p :e Repl Y (fun a => apply_fun f a).
  { exact Hp. }
  apply (ReplE_impred Y (fun a:set => apply_fun f a) p HpRepl).
  let a. assume HaY: a :e Y.
  assume Heq: p = apply_fun f a.
  rewrite Heq.
  claim Hfa: apply_fun f a = (apply_fun (const_fun Y x0) a, apply_fun idY a).
  { exact (pair_map_apply Y {x0} Y (const_fun Y x0) idY a HaY). }
  claim Hc: apply_fun (const_fun Y x0) a = x0.
  { exact (const_fun_apply Y x0 a HaY). }
  claim Hid: apply_fun idY a = a.
  { exact (identity_function_apply Y a HaY). }
  rewrite Hfa.
  rewrite Hc.
  rewrite Hid.
  exact (tuple_2_setprod_by_pair_Sigma {x0} Y x0 a (SingI x0) HaY).
- let p. assume Hp: p :e setprod {x0} Y.
  prove p :e image_of (pair_map Y (const_fun Y x0) idY) Y.
  set f := pair_map Y (const_fun Y x0) idY.
  claim Hp0Sing: (p 0) :e {x0}.
  { exact (ap0_Sigma {x0} (fun _:set => Y) p Hp). }
  claim Hp1Y: (p 1) :e Y.
  { exact (ap1_Sigma {x0} (fun _:set => Y) p Hp). }
  claim Hp0eq: (p 0) = x0.
  { exact (singleton_elem (p 0) x0 Hp0Sing). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta {x0} Y p Hp). }
  prove p :e Repl Y (fun a => apply_fun f a).
  claim Hfp1: apply_fun f (p 1) = (apply_fun (const_fun Y x0) (p 1), apply_fun idY (p 1)).
  { exact (pair_map_apply Y {x0} Y (const_fun Y x0) idY (p 1) Hp1Y). }
  claim Hc1: apply_fun (const_fun Y x0) (p 1) = x0.
  { exact (const_fun_apply Y x0 (p 1) Hp1Y). }
  claim Hid1: apply_fun idY (p 1) = (p 1).
  { exact (identity_function_apply Y (p 1) Hp1Y). }
  claim Hfp1eq: apply_fun f (p 1) = (p 0, p 1).
  { rewrite Hfp1.
    rewrite Hc1.
    rewrite Hid1.
    rewrite <- Hp0eq at 1.
    reflexivity. }
  claim Hp_as_image: p = apply_fun f (p 1).
  { rewrite Heta at 1.
    rewrite <- Hfp1eq.
    reflexivity. }
  rewrite Hp_as_image.
  exact (ReplI Y (fun a:set => apply_fun f a) (p 1) Hp1Y).
Qed.

(** Helper: y maps to (x0,y) is a homeomorphism onto the slice {x0} times Y **)
Theorem homeomorphism_const_id_slice : forall X Tx Y Ty x0:set,
  topology_on X Tx -> topology_on Y Ty -> x0 :e X ->
  homeomorphism Y Ty (setprod {x0} Y)
    (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod {x0} Y))
    (pair_map Y (const_fun Y x0) {(y,y)|y :e Y}).
let X Tx Y Ty x0.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hx0X: x0 :e X.
set idY := {(y,y)|y :e Y}.
set c := const_fun Y x0.
set f := pair_map Y c idY.
set Slice := setprod {x0} Y.
set Tslice := subspace_topology (setprod X Y) (product_topology X Tx Y Ty) Slice.

claim HTprod: topology_on (setprod X Y) (product_topology X Tx Y Ty).
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }

claim Hc: continuous_map Y Ty X Tx c.
{ exact (const_fun_continuous Y Ty X Tx x0 HTy HTx Hx0X). }
claim Hid: continuous_map Y Ty Y Ty idY.
{ exact (identity_continuous Y Ty HTy). }
claim HfProd: continuous_map Y Ty (setprod X Y) (product_topology X Tx Y Ty) f.
{ exact (maps_into_products Y Ty X Tx Y Ty c idY Hc Hid). }

claim HSingSub: {x0} c= X.
{ exact (singleton_subset x0 X Hx0X). }
claim HSlicesub: Slice c= setprod X Y.
{ exact (setprod_Subq {x0} Y X Y HSingSub (Subq_ref Y)). }
claim Himg: forall y:set, y :e Y -> apply_fun f y :e Slice.
{ let y. assume HyY: y :e Y.
  prove apply_fun f y :e Slice.
  claim Happ: apply_fun f y = (apply_fun c y, apply_fun idY y).
  { exact (pair_map_apply Y X Y c idY y HyY). }
  claim Hcapp: apply_fun c y = x0.
  { exact (const_fun_apply Y x0 y HyY). }
  claim Hidapp: apply_fun idY y = y.
  { exact (identity_function_apply Y y HyY). }
  rewrite Happ.
  rewrite Hcapp.
  rewrite Hidapp.
  exact (tuple_2_setprod_by_pair_Sigma {x0} Y x0 y (SingI x0) HyY). }
claim Hf: continuous_map Y Ty Slice Tslice f.
{ exact (continuous_map_range_restrict Y Ty (setprod X Y) (product_topology X Tx Y Ty) f Slice
          HfProd HSlicesub Himg). }

claim HprojPair:
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y) /\
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
{ exact (projection_maps_continuous X Tx Y Ty HTx HTy). }
claim Hproj2:
  continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y).
{ exact (andER (continuous_map (setprod X Y) (product_topology X Tx Y Ty) X Tx (projection_map1 X Y))
               (continuous_map (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y))
               HprojPair). }
claim Hg:
  continuous_map Slice Tslice Y Ty (projection_map2 X Y).
{ exact (continuous_on_subspace (setprod X Y) (product_topology X Tx Y Ty) Y Ty (projection_map2 X Y) Slice
          HTprod HSlicesub Hproj2). }

prove continuous_map Y Ty Slice Tslice f /\
  exists g:set, continuous_map Slice Tslice Y Ty g /\
    (forall x:set, x :e Y -> apply_fun g (apply_fun f x) = x) /\
    (forall y:set, y :e Slice -> apply_fun f (apply_fun g y) = y).
apply andI.
- exact Hf.
- witness (projection_map2 X Y).
  apply andI.
  + apply andI.
    * exact Hg.
    * (** g after f is identity on Y **)
      let y. assume HyY: y :e Y.
      prove apply_fun (projection_map2 X Y) (apply_fun f y) = y.
      claim Happf: apply_fun f y = (apply_fun c y, apply_fun idY y).
      { exact (pair_map_apply Y X Y c idY y HyY). }
      claim Hcapp: apply_fun c y = x0.
      { exact (const_fun_apply Y x0 y HyY). }
      claim Hidapp: apply_fun idY y = y.
      { exact (identity_function_apply Y y HyY). }
      claim HxyXY: (x0,y) :e setprod X Y.
      { exact (tuple_2_setprod_by_pair_Sigma X Y x0 y Hx0X HyY). }
      rewrite Happf.
      rewrite Hcapp.
      rewrite Hidapp.
      claim Happ2: apply_fun (projection_map2 X Y) (x0,y) = (x0,y) 1.
      { exact (projection2_apply X Y (x0,y) HxyXY). }
      rewrite Happ2.
      exact (tuple_2_1_eq x0 y).
  + (** f after g is identity on Slice **)
    let p. assume HpSlice: p :e Slice.
    prove apply_fun f (apply_fun (projection_map2 X Y) p) = p.
    claim HpXY: p :e setprod X Y.
    { exact (HSlicesub p HpSlice). }
    claim Hp1Y: (p 1) :e Y.
    { exact (ap1_Sigma {x0} (fun _:set => Y) p HpSlice). }
    claim Happ2: apply_fun (projection_map2 X Y) p = p 1.
    { exact (projection2_apply X Y p HpXY). }
    rewrite Happ2.
    claim Happf: apply_fun f (p 1) = (apply_fun c (p 1), apply_fun idY (p 1)).
    { exact (pair_map_apply Y X Y c idY (p 1) Hp1Y). }
    claim Hcapp: apply_fun c (p 1) = x0.
    { exact (const_fun_apply Y x0 (p 1) Hp1Y). }
    claim Hidapp: apply_fun idY (p 1) = (p 1).
    { exact (identity_function_apply Y (p 1) Hp1Y). }
    rewrite Happf.
    rewrite Hcapp.
    rewrite Hidapp.
    claim Hp0Sing: (p 0) :e {x0}.
    { exact (ap0_Sigma {x0} (fun _:set => Y) p HpSlice). }
    claim Hp0eq: (p 0) = x0.
    { exact (singleton_elem (p 0) x0 Hp0Sing). }
    claim Heta: p = (p 0, p 1).
    { exact (setprod_eta {x0} Y p HpSlice). }
    claim HtupleEq: (p 0, p 1) = p.
    { rewrite <- Heta.
      reflexivity. }
    rewrite <- Hp0eq at 1.
    exact HtupleEq.
Qed.

(** Helper: slice {x0} times Y is connected when Y is connected **)
Theorem slice_Y_connected : forall X Tx Y Ty x0:set,
  connected_space Y Ty -> topology_on X Tx -> x0 :e X ->
  connected_space (setprod {x0} Y)
    (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod {x0} Y)).
let X Tx Y Ty x0.
assume HY: connected_space Y Ty.
assume HTx: topology_on X Tx.
assume Hx0: x0 :e X.
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty)
              (~(exists U V:set, U :e Ty /\ V :e Ty /\ separation_of Y U V))
              HY). }
set idY := {(y,y)|y :e Y}.
set c := const_fun Y x0.
set f := pair_map Y c idY.
claim Hc: continuous_map Y Ty X Tx c.
{ exact (const_fun_continuous Y Ty X Tx x0 HTy HTx Hx0). }
claim Hid: continuous_map Y Ty Y Ty idY.
{ exact (identity_continuous Y Ty HTy). }
claim Hf: continuous_map Y Ty (setprod X Y) (product_topology X Tx Y Ty) f.
{ exact (maps_into_products Y Ty X Tx Y Ty c idY Hc Hid). }
claim Himg: connected_space (image_of f Y)
  (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (image_of f Y)).
{ exact (continuous_image_connected Y Ty (setprod X Y) (product_topology X Tx Y Ty) f HY Hf). }
prove connected_space (setprod {x0} Y)
    (subspace_topology (setprod X Y) (product_topology X Tx Y Ty) (setprod {x0} Y)).
rewrite <- (image_of_const_id_is_slice Y x0).
exact Himg.
Qed.

(** from §23 Theorem 23.6: finite products of connected spaces are connected **) 
(** LATEX VERSION: The product of two connected spaces is connected in the product topology. **)
Theorem finite_product_connected : forall X Tx Y Ty:set,
  connected_space X Tx -> connected_space Y Ty ->
  connected_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HX: connected_space X Tx.
assume HY: connected_space Y Ty.
prove connected_space (setprod X Y) (product_topology X Tx Y Ty).
(** Helper: product with empty set is empty (left) **)
claim Hsetprod_empty_left: forall Y0:set, setprod Empty Y0 = Empty.
{ let Y0.
  apply set_ext.
  - let p. assume Hp: p :e setprod Empty Y0.
    prove p :e Empty.
    apply FalseE.
    claim Hp0: (p 0) :e Empty.
    { exact (ap0_Sigma Empty (fun _:set => Y0) p Hp). }
    exact (EmptyE (p 0) Hp0).
  - let p. assume Hp: p :e Empty.
    prove p :e setprod Empty Y0.
    apply FalseE.
    exact (EmptyE p Hp). }
(** Helper: product with empty set is empty (right) **)
claim Hsetprod_empty_right: forall X0:set, setprod X0 Empty = Empty.
{ let X0.
  apply set_ext.
  - let p. assume Hp: p :e setprod X0 Empty.
    prove p :e Empty.
    apply FalseE.
    claim Hp1: (p 1) :e Empty.
    { exact (ap1_Sigma X0 (fun _:set => Empty) p Hp). }
    exact (EmptyE (p 1) Hp1).
  - let p. assume Hp: p :e Empty.
    prove p :e setprod X0 Empty.
    apply FalseE.
    exact (EmptyE p Hp). }

(** Extract the topology parts **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
              (~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V))
              HX). }
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty)
              (~(exists U V:set, U :e Ty /\ V :e Ty /\ separation_of Y U V))
              HY). }

(** Case split on emptiness of X and Y **)
apply xm (X = Empty).
- assume HXEmpty: X = Empty.
  rewrite HXEmpty.
  rewrite (Hsetprod_empty_left Y).
  prove topology_on Empty (product_topology Empty Tx Y Ty) /\
    ~(exists U V:set,
      U :e product_topology Empty Tx Y Ty /\
      V :e product_topology Empty Tx Y Ty /\
      separation_of Empty U V).
  apply andI.
  - (** topology_on Empty (...) **)
    claim HTx0: topology_on Empty Tx.
    { rewrite <- HXEmpty. exact HTx. }
    prove topology_on Empty (product_topology Empty Tx Y Ty).
    rewrite <- (Hsetprod_empty_left Y) at 1.
    exact (product_topology_is_topology Empty Tx Y Ty HTx0 HTy).
  - (** no separation of Empty **)
    prove ~(exists U V:set,
      U :e product_topology Empty Tx Y Ty /\
      V :e product_topology Empty Tx Y Ty /\
      separation_of Empty U V).
    assume Hsep: exists U V:set,
      U :e product_topology Empty Tx Y Ty /\
      V :e product_topology Empty Tx Y Ty /\
      separation_of Empty U V.
    apply Hsep.
    let U. assume HexV: exists V:set,
      U :e product_topology Empty Tx Y Ty /\
      V :e product_topology Empty Tx Y Ty /\
      separation_of Empty U V.
    apply HexV.
    let V. assume HUVsep.
    claim HsepUV: separation_of Empty U V.
    { exact (andER (U :e product_topology Empty Tx Y Ty /\ V :e product_topology Empty Tx Y Ty)
                   (separation_of Empty U V) HUVsep). }
    claim Hpart1: ((((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
    { exact (andEL ((((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                   (U :\/: V = Empty) HsepUV). }
    claim Hpart2: ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty.
    { exact (andEL (((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty)
                   (V <> Empty) Hpart1). }
    claim HUne: U <> Empty.
    { exact (andER ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) (U <> Empty) Hpart2). }
    claim Hpow: (U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty.
    { exact (andEL ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) (U <> Empty) Hpart2). }
    claim HpowUV: U :e Power Empty /\ V :e Power Empty.
    { exact (andEL (U :e Power Empty /\ V :e Power Empty) (U :/\: V = Empty) Hpow). }
    claim HUsub: U c= Empty.
    { exact (PowerE Empty U (andEL (U :e Power Empty) (V :e Power Empty) HpowUV)). }
    claim HUeq: U = Empty.
    { exact (Empty_Subq_eq U HUsub). }
    exact (HUne HUeq).
- assume HXNonEmpty: X <> Empty.
  apply xm (Y = Empty).
  + assume HYEmpty: Y = Empty.
    rewrite HYEmpty.
    rewrite (Hsetprod_empty_right X).
    prove topology_on Empty (product_topology X Tx Empty Ty) /\
      ~(exists U V:set,
        U :e product_topology X Tx Empty Ty /\
        V :e product_topology X Tx Empty Ty /\
        separation_of Empty U V).
    apply andI.
    - (** topology_on Empty (...) **)
      claim HTy0: topology_on Empty Ty.
      { rewrite <- HYEmpty. exact HTy. }
      prove topology_on Empty (product_topology X Tx Empty Ty).
      rewrite <- (Hsetprod_empty_right X) at 1.
      exact (product_topology_is_topology X Tx Empty Ty HTx HTy0).
    - (** no separation of Empty **)
      prove ~(exists U V:set,
        U :e product_topology X Tx Empty Ty /\
        V :e product_topology X Tx Empty Ty /\
        separation_of Empty U V).
      assume Hsep: exists U V:set,
        U :e product_topology X Tx Empty Ty /\
        V :e product_topology X Tx Empty Ty /\
        separation_of Empty U V.
      apply Hsep.
      let U. assume HexV: exists V:set,
        U :e product_topology X Tx Empty Ty /\
        V :e product_topology X Tx Empty Ty /\
        separation_of Empty U V.
      apply HexV.
      let V. assume HUVsep.
      claim HsepUV: separation_of Empty U V.
      { exact (andER (U :e product_topology X Tx Empty Ty /\ V :e product_topology X Tx Empty Ty)
                     (separation_of Empty U V) HUVsep). }
      claim Hpart1: ((((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
      { exact (andEL ((((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                     (U :\/: V = Empty) HsepUV). }
      claim Hpart2: ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty.
      { exact (andEL (((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) /\ U <> Empty)
                     (V <> Empty) Hpart1). }
      claim HUne: U <> Empty.
      { exact (andER ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) (U <> Empty) Hpart2). }
      claim Hpow: (U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty.
      { exact (andEL ((U :e Power Empty /\ V :e Power Empty) /\ U :/\: V = Empty) (U <> Empty) Hpart2). }
      claim HpowUV: U :e Power Empty /\ V :e Power Empty.
      { exact (andEL (U :e Power Empty /\ V :e Power Empty) (U :/\: V = Empty) Hpow). }
      claim HUsub: U c= Empty.
      { exact (PowerE Empty U (andEL (U :e Power Empty) (V :e Power Empty) HpowUV)). }
      claim HUeq: U = Empty.
      { exact (Empty_Subq_eq U HUsub). }
      exact (HUne HUeq).
  + assume HYNonEmpty: Y <> Empty.
    (** Nonempty X and Y: union of connected slices with a common point **)
    apply (nonempty_has_element X HXNonEmpty).
    let x0. assume Hx0X: x0 :e X.
    apply (nonempty_has_element Y HYNonEmpty).
    let y0. assume Hy0Y: y0 :e Y.
    set Top := product_topology X Tx Y Ty.
    set Hhor := setprod X {y0}.
    set F := {setprod {x} Y :\/: Hhor|x :e X}.

    claim HTprod: topology_on (setprod X Y) Top.
    { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }

    (** Each member of F is a subset of X×Y **)
    claim HFsub: forall C:set, C :e F -> C c= setprod X Y.
    { let C. assume HC: C :e F.
      apply (ReplE_impred X (fun x:set => setprod {x} Y :\/: Hhor) C HC).
      let x. assume HxX: x :e X.
      assume HCeq: C = setprod {x} Y :\/: Hhor.
      rewrite HCeq.
      prove (setprod {x} Y :\/: Hhor) c= setprod X Y.
      let p. assume Hp: p :e setprod {x} Y :\/: Hhor.
      prove p :e setprod X Y.
      apply (binunionE' (setprod {x} Y) Hhor p (p :e setprod X Y)).
      - assume HpA: p :e setprod {x} Y.
        claim Hxsub: {x} c= X.
        { exact (singleton_subset x X HxX). }
        claim HYsub: Y c= Y.
        { exact (Subq_ref Y). }
        exact (setprod_Subq {x} Y X Y Hxsub HYsub p HpA).
      - assume HpB: p :e Hhor.
        claim HXsub: X c= X.
        { exact (Subq_ref X). }
        claim Hy0sub: {y0} c= Y.
        { exact (singleton_subset y0 Y Hy0Y). }
        exact (setprod_Subq X {y0} X Y HXsub Hy0sub p HpB).
      - exact Hp. }

    (** Each member of F is connected **)
    claim HFconn: forall C:set, C :e F ->
      connected_space C (subspace_topology (setprod X Y) Top C).
    { let C. assume HC: C :e F.
      apply (ReplE_impred X (fun x:set => setprod {x} Y :\/: Hhor) C HC).
      let x. assume HxX: x :e X.
      assume HCeq: C = setprod {x} Y :\/: Hhor.
      rewrite HCeq.
      set A := setprod {x} Y.
      set B := Hhor.
      claim HAconn: connected_space A (subspace_topology (setprod X Y) Top A).
      { exact (slice_Y_connected X Tx Y Ty x HY HTx HxX). }
      claim HBconn: connected_space B (subspace_topology (setprod X Y) Top B).
      { exact (slice_X_connected X Tx Y Ty y0 HX HTy Hy0Y). }
      claim HABsub: forall D:set, D :e {A,B} -> D c= setprod X Y.
      { let D. assume HD: D :e {A,B}.
        apply (UPairE D A B HD (D c= setprod X Y)).
        - assume HDa: D = A. rewrite HDa.
          claim Hxsub: {x} c= X.
          { exact (singleton_subset x X HxX). }
          claim HYsub: Y c= Y.
          { exact (Subq_ref Y). }
          exact (setprod_Subq {x} Y X Y Hxsub HYsub).
        - assume HDb: D = B. rewrite HDb.
          claim HXsub: X c= X.
          { exact (Subq_ref X). }
          claim Hy0sub: {y0} c= Y.
          { exact (singleton_subset y0 Y Hy0Y). }
          exact (setprod_Subq X {y0} X Y HXsub Hy0sub). }

      (** Use union_connected_common_point on {A,B} with common point (x,y0) **)
      claim HunionAB: connected_space (Union {A,B})
        (subspace_topology (setprod X Y) Top (Union {A,B})).
      { apply (union_connected_common_point (setprod X Y) Top {A,B} HTprod).
        - exact HABsub.
        - let D. assume HD: D :e {A,B}.
          apply (UPairE D A B HD (connected_space D (subspace_topology (setprod X Y) Top D))).
          + assume HDa: D = A. rewrite HDa. exact HAconn.
          + assume HDb: D = B. rewrite HDb. exact HBconn.
        - witness (x,y0).
          let D. assume HD: D :e {A,B}.
          apply (UPairE D A B HD ((x,y0) :e D)).
          + assume HDa: D = A.
            rewrite HDa.
            exact (tuple_2_setprod_by_pair_Sigma {x} Y x y0 (SingI x) Hy0Y).
          + assume HDb: D = B.
            rewrite HDb.
            exact (tuple_2_setprod_by_pair_Sigma X {y0} x y0 HxX (SingI y0)). }

      (** Rewrite Union {A,B} into A :\/: B **)
      rewrite (binunion_eq_Union_pair A B).
      exact HunionAB. }

    (** Common point for all members of F: (x0,y0) lies in the horizontal slice **)
    claim Hcommon: exists p:set, forall C:set, C :e F -> p :e C.
    { witness (x0,y0).
      let C. assume HC: C :e F.
      apply (ReplE_impred X (fun x:set => setprod {x} Y :\/: Hhor) C HC).
      let x. assume HxX: x :e X.
      assume HCeq: C = setprod {x} Y :\/: Hhor.
      rewrite HCeq.
      prove (x0,y0) :e setprod {x} Y :\/: Hhor.
      apply binunionI2.
      exact (tuple_2_setprod_by_pair_Sigma X {y0} x0 y0 Hx0X (SingI y0)). }

    (** Connectedness of the union Union F **)
    claim HconnUnion: connected_space (Union F)
      (subspace_topology (setprod X Y) Top (Union F)).
    { exact (union_connected_common_point (setprod X Y) Top F HTprod HFsub HFconn Hcommon). }

    (** Union F is all of X×Y **)
    claim HFpow: F c= Power (setprod X Y).
    { let C. assume HC: C :e F.
      prove C :e Power (setprod X Y).
      exact (PowerI (setprod X Y) C (HFsub C HC)). }
    claim HUnionSub: Union F c= setprod X Y.
    { exact (Union_Power (setprod X Y) F HFpow). }
    claim HSubUnion: setprod X Y c= Union F.
    { let p. assume Hp: p :e setprod X Y.
      claim Hp0X: (p 0) :e X.
      { exact (ap0_Sigma X (fun _:set => Y) p Hp). }
      claim Hp1Y: (p 1) :e Y.
      { exact (ap1_Sigma X (fun _:set => Y) p Hp). }
      set C0 := setprod {p 0} Y :\/: Hhor.
      claim HC0F: C0 :e F.
      { exact (ReplI X (fun x:set => setprod {x} Y :\/: Hhor) (p 0) Hp0X). }
      prove p :e Union F.
      apply (UnionI F p C0).
      - prove p :e C0.
        apply binunionI1.
      claim Heta: p = (p 0, p 1).
      { exact (setprod_eta X Y p Hp). }
      rewrite Heta at 1.
      exact (tuple_2_setprod_by_pair_Sigma {p 0} Y (p 0) (p 1) (SingI (p 0)) Hp1Y).
      - exact HC0F. }
    claim HUnionEq: Union F = setprod X Y.
    { apply set_ext.
      - exact HUnionSub.
      - exact HSubUnion. }

    (** Transfer connectedness from the union to X×Y, then collapse subspace topology **)
    claim HconnAmbientSub: connected_space (setprod X Y)
      (subspace_topology (setprod X Y) Top (setprod X Y)).
    { rewrite <- HUnionEq.
      exact HconnUnion. }
    claim Hsubeq: subspace_topology (setprod X Y) Top (setprod X Y) = Top.
    { exact (subspace_topology_whole (setprod X Y) Top HTprod). }
    rewrite <- Hsubeq.
    exact HconnAmbientSub.
Qed.

(** from §23 Example 6: R^ω in the box topology is not connected **) 
(** LATEX VERSION: Partition R^ω into bounded and unbounded sequences; each is open in the box topology using ∏(a_i-1,a_i+1). **)
Definition R_omega_space : set :=
  product_space omega (const_space_family omega R R_standard_topology).
Definition R_omega_box_topology : set :=
  box_topology omega (const_space_family omega R R_standard_topology).
Definition R_omega_product_topology : set :=
  product_topology_full omega (const_space_family omega R R_standard_topology).

(** from §23 Example 6: bounded sequences in R^omega **)
(** LATEX VERSION: A sequence is bounded if all coordinates lie in some interval (-M,M) for a single M. **)
Definition bounded_sequence_Romega : set -> prop := fun f =>
  exists M:set, M :e R /\ forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M.

(** from §23 Example 6: the set of bounded sequences **)
(** LATEX VERSION: Let B be the set of bounded sequences; it is used to separate R^omega in the box topology. **)
Definition bounded_sequences_Romega : set :=
  {f :e R_omega_space | bounded_sequence_Romega f}.

(** from §23 Example 6: unbounded sequences in R^omega **)
(** LATEX VERSION: A sequence is unbounded if for every M there is some coordinate outside (-M,M). **)
Definition unbounded_sequence_Romega : set -> prop := fun f =>
  forall M:set, M :e R -> exists n:set, n :e omega /\ ~(apply_fun f n :e open_interval (minus_SNo M) M).

(** from §23 Example 6: the set of unbounded sequences **)
(** LATEX VERSION: Let U be the set of unbounded sequences; it is used to separate R^omega in the box topology. **)
Definition unbounded_sequences_Romega : set :=
  {f :e R_omega_space | unbounded_sequence_Romega f}.

(** Helper: coordinates of a point in R_omega_space are real numbers **)
Theorem Romega_coord_in_R : forall f i:set,
  f :e R_omega_space ->
  i :e omega ->
  apply_fun f i :e R.
let f i.
assume Hf: f :e R_omega_space.
assume Hi: i :e omega.
prove apply_fun f i :e R.
set Xi := const_space_family omega R R_standard_topology.
claim Hfprop: total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
              forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j.
{ exact (SepE2 (Power (setprod omega (space_family_union omega Xi)))
               (fun f0:set => total_function_on f0 omega (space_family_union omega Xi) /\ functional_graph f0 /\
                 forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
               f
               Hf). }
claim Hcoords: forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j.
{ exact (andER (total_function_on f omega (space_family_union omega Xi) /\ functional_graph f)
               (forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j)
               Hfprop). }
claim Hfi: apply_fun f i :e space_family_set Xi i.
{ exact (Hcoords i Hi). }
claim HXi: apply_fun Xi i = (R, R_standard_topology).
{ exact (const_space_family_apply omega R R_standard_topology i Hi). }
claim Hset: space_family_set Xi i = R.
{ claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
  { reflexivity. }
  rewrite Hdef.
  rewrite HXi.
  exact (tuple_2_0_eq R R_standard_topology). }
 rewrite <- Hset.
 exact Hfi.
Qed.

(** Helper: bounded and unbounded sequence collections lie in Power R_omega_space **)
Theorem bounded_sequences_Romega_in_Power : bounded_sequences_Romega :e Power R_omega_space.
prove bounded_sequences_Romega :e Power R_omega_space.
apply PowerI.
let f. assume Hf: f :e bounded_sequences_Romega.
prove f :e R_omega_space.
exact (SepE1 R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hf).
Qed.

Theorem unbounded_sequences_Romega_in_Power : unbounded_sequences_Romega :e Power R_omega_space.
prove unbounded_sequences_Romega :e Power R_omega_space.
apply PowerI.
let f. assume Hf: f :e unbounded_sequences_Romega.
prove f :e R_omega_space.
exact (SepE1 R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hf).
Qed.

(** Helper: bounded/unbounded sets are intended to form a separation in the box topology **)
Theorem bounded_sequences_in_Romega_box_topology :
  bounded_sequences_Romega :e R_omega_box_topology.
prove bounded_sequences_Romega :e R_omega_box_topology.
set Xi := const_space_family omega R R_standard_topology.
set X := product_space omega Xi.
set B := box_basis omega Xi.
set TU := topology_family_union omega Xi.
prove bounded_sequences_Romega :e generated_topology X B.
claim Hpow: bounded_sequences_Romega :e Power X.
{ exact bounded_sequences_Romega_in_Power. }
claim Hcond: forall f :e bounded_sequences_Romega, exists b :e B, f :e b /\ b c= bounded_sequences_Romega.
{ let f. assume Hf: f :e bounded_sequences_Romega.
  claim HfX: f :e X.
  { exact (SepE1 R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hf). }
  claim Hb: bounded_sequence_Romega f.
  { exact (SepE2 R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hf). }
  apply Hb.
  let M. assume HMconj.
  claim HMR: M :e R.
  { exact (andEL (M :e R) (forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M) HMconj). }
  claim Hbnd: forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M.
  { exact (andER (M :e R) (forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M) HMconj). }

  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Hf0In: apply_fun f 0 :e open_interval (minus_SNo M) M.
  { exact (Hbnd 0 H0omega). }
  claim Hf0prop: Rlt (minus_SNo M) (apply_fun f 0) /\ Rlt (apply_fun f 0) M.
  { exact (SepE2 R (fun x0:set => Rlt (minus_SNo M) x0 /\ Rlt x0 M) (apply_fun f 0) Hf0In). }
  claim Hm0: Rlt (minus_SNo M) (apply_fun f 0).
  { exact (andEL (Rlt (minus_SNo M) (apply_fun f 0)) (Rlt (apply_fun f 0) M) Hf0prop). }
  claim H0m: Rlt (apply_fun f 0) M.
  { exact (andER (Rlt (minus_SNo M) (apply_fun f 0)) (Rlt (apply_fun f 0) M) Hf0prop). }
  claim HMlt: Rlt (minus_SNo M) M.
  { exact (Rlt_tra (minus_SNo M) (apply_fun f 0) M Hm0 H0m). }
  claim HopenI: open_interval (minus_SNo M) M :e R_standard_topology.
  { exact (open_interval_in_R_standard_topology (minus_SNo M) M HMlt). }

  claim HX0: apply_fun Xi 0 = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
  claim HT0: space_family_topology Xi 0 = R_standard_topology.
  { claim Hdef: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HX0.
    exact (tuple_2_1_eq R R_standard_topology). }
  claim HTfam: R_standard_topology :e {space_family_topology Xi i|i :e omega}.
  { apply ReplEq omega (fun i:set => space_family_topology Xi i) R_standard_topology.
    assume _ H2. apply H2.
    prove exists i :e omega, R_standard_topology = space_family_topology Xi i.
    witness 0.
    apply andI.
    - exact H0omega.
    - symmetry.
      exact HT0. }
  claim HintervalTU: open_interval (minus_SNo M) M :e TU.
  { exact (UnionI {space_family_topology Xi i|i :e omega}
                 (open_interval (minus_SNo M) M)
                 R_standard_topology
                 HopenI
                 HTfam). }

  set Um := const_fun omega (open_interval (minus_SNo M) M).
  set bM := {g :e X | forall i:set, i :e omega -> apply_fun g i :e apply_fun Um i}.

  witness bM.
  apply andI.
  - (** bM :e box_basis omega Xi **)
    prove bM :e B.
    claim HbMsub: bM c= X.
    { let g. assume Hg: g :e bM.
      prove g :e X.
      exact (SepE1 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun Um i) g Hg). }
    claim HbMpow: bM :e Power X.
    { exact (PowerI X bM HbMsub). }
    claim Htot: total_function_on Um omega TU.
    { exact (const_fun_total_function_on omega TU (open_interval (minus_SNo M) M) HintervalTU). }
    claim HUmgraph: functional_graph Um.
    { exact (functional_graph_const_fun omega (open_interval (minus_SNo M) M)). }
    claim HUmcoords: forall i:set, i :e omega -> apply_fun Um i :e space_family_topology Xi i.
    { let i. assume Hi: i :e omega.
      prove apply_fun Um i :e space_family_topology Xi i.
      claim Happ: apply_fun Um i = open_interval (minus_SNo M) M.
      { exact (const_fun_apply omega (open_interval (minus_SNo M) M) i Hi). }
      rewrite Happ.
      claim HXi: apply_fun Xi i = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology i Hi). }
      claim HTi: space_family_topology Xi i = R_standard_topology.
      { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_1_eq R R_standard_topology). }
      rewrite HTi.
      exact HopenI. }
    claim HexU: exists U:set, total_function_on U omega TU /\ functional_graph U /\
      (forall i:set, i :e omega -> apply_fun U i :e space_family_topology Xi i) /\
      bM = {f :e X | forall i:set, i :e omega -> apply_fun f i :e apply_fun U i}.
    { witness Um.
      apply andI.
      - apply andI.
        + apply andI.
          * exact Htot.
          * exact HUmgraph.
        + exact HUmcoords.
      - reflexivity. }
    exact (SepI (Power X)
                (fun B0:set => exists U:set, total_function_on U omega TU /\ functional_graph U /\
                  (forall i:set, i :e omega -> apply_fun U i :e space_family_topology Xi i) /\
                  B0 = {f :e X | forall i:set, i :e omega -> apply_fun f i :e apply_fun U i})
                bM
                HbMpow
                HexU).
  - apply andI.
    + (** f :e bM **)
      prove f :e bM.
      apply (SepI X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun Um i) f HfX).
      let i. assume Hi: i :e omega.
      prove apply_fun f i :e apply_fun Um i.
      claim Happ: apply_fun Um i = open_interval (minus_SNo M) M.
      { exact (const_fun_apply omega (open_interval (minus_SNo M) M) i Hi). }
      rewrite Happ.
      exact (Hbnd i Hi).
    + (** bM c= bounded_sequences_Romega **)
      let g. assume Hg: g :e bM.
      prove g :e bounded_sequences_Romega.
      claim HgX: g :e X.
      { exact (SepE1 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun Um i) g Hg). }
      claim Hgprop: forall i:set, i :e omega -> apply_fun g i :e apply_fun Um i.
      { exact (SepE2 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun Um i) g Hg). }
      claim Hbseqg: bounded_sequence_Romega g.
      { claim Hbndg: forall n:set, n :e omega -> apply_fun g n :e open_interval (minus_SNo M) M.
        { let n. assume HnO: n :e omega.
          claim Hgn: apply_fun g n :e apply_fun Um n.
          { exact (Hgprop n HnO). }
          claim Happ: apply_fun Um n = open_interval (minus_SNo M) M.
          { exact (const_fun_apply omega (open_interval (minus_SNo M) M) n HnO). }
          rewrite <- Happ.
          exact Hgn. }
        exact (fun P Hp => Hp M (andI (M :e R)
                                      (forall n:set, n :e omega -> apply_fun g n :e open_interval (minus_SNo M) M)
                                      HMR
                                      Hbndg)). }
      exact (SepI R_omega_space (fun h:set => bounded_sequence_Romega h) g HgX Hbseqg). }
exact (SepI (Power X)
            (fun U0:set => forall x :e U0, exists b :e B, x :e b /\ b c= U0)
            bounded_sequences_Romega
            Hpow
            Hcond).
Qed.

Theorem unbounded_sequences_in_Romega_box_topology :
  unbounded_sequences_Romega :e R_omega_box_topology.
prove unbounded_sequences_Romega :e R_omega_box_topology.
set Xi := const_space_family omega R R_standard_topology.
set X := product_space omega Xi.
set B := box_basis omega Xi.
set TU := topology_family_union omega Xi.
prove unbounded_sequences_Romega :e generated_topology X B.
claim Hpow: unbounded_sequences_Romega :e Power X.
{ exact unbounded_sequences_Romega_in_Power. }
claim Hcond: forall f :e unbounded_sequences_Romega, exists b :e B, f :e b /\ b c= unbounded_sequences_Romega.
{ let f. assume Hf: f :e unbounded_sequences_Romega.
  claim HfX: f :e X.
  { exact (SepE1 R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hf). }
  claim Huf: unbounded_sequence_Romega f.
  { exact (SepE2 R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hf). }

  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim HX0: apply_fun Xi 0 = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
  claim HT0: space_family_topology Xi 0 = R_standard_topology.
  { claim Hdef: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HX0.
    exact (tuple_2_1_eq R R_standard_topology). }
  claim HTfam: R_standard_topology :e {space_family_topology Xi i|i :e omega}.
  { apply ReplEq omega (fun i:set => space_family_topology Xi i) R_standard_topology.
    assume _ H2. apply H2.
    prove exists i :e omega, R_standard_topology = space_family_topology Xi i.
    witness 0.
    apply andI.
    - exact H0omega.
    - symmetry.
      exact HT0. }

  claim Hm1R : minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim Hm1S : SNo (minus_SNo 1).
  { exact (real_SNo (minus_SNo 1) Hm1R). }
  claim Hm1lt1 : minus_SNo 1 < 1.
  { exact (SNoLt_tra (minus_SNo 1) 0 1 Hm1S SNo_0 SNo_1 minus_1_lt_0 SNoLt_0_1). }

  set U := {(i, open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                              (add_SNo (apply_fun f i) 1)) | i :e omega}.
  set bU := {g :e X | forall i:set, i :e omega -> apply_fun g i :e apply_fun U i}.

  claim HUapply: forall i:set, i :e omega ->
    apply_fun U i = open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                 (add_SNo (apply_fun f i) 1).
  { let i. assume Hi: i :e omega.
    prove apply_fun U i = open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                     (add_SNo (apply_fun f i) 1).
    prove Eps_i (fun z => (i, z) :e U) =
      open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                    (add_SNo (apply_fun f i) 1).
    claim H1: (i, open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                               (add_SNo (apply_fun f i) 1)) :e U.
    { exact (ReplI omega (fun i0:set =>
              (i0, open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                 (add_SNo (apply_fun f i0) 1))) i Hi). }
    claim H2: (i, Eps_i (fun z => (i, z) :e U)) :e U.
    { exact (Eps_i_ax (fun z => (i, z) :e U)
                      (open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                     (add_SNo (apply_fun f i) 1))
                      H1). }
    apply (ReplE_impred omega (fun i0:set =>
              (i0, open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                 (add_SNo (apply_fun f i0) 1)))
              (i, Eps_i (fun z => (i, z) :e U)) H2).
    let i0.
    assume Hi0: i0 :e omega.
    assume Heq: (i, Eps_i (fun z => (i, z) :e U)) =
                (i0, open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                   (add_SNo (apply_fun f i0) 1)).
    claim Hi_eq: i = i0.
    { rewrite <- (tuple_2_0_eq i (Eps_i (fun z => (i, z) :e U))).
      rewrite <- (tuple_2_0_eq i0 (open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                                 (add_SNo (apply_fun f i0) 1))).
      rewrite Heq.
      reflexivity. }
    claim Hz_eq: Eps_i (fun z => (i, z) :e U) =
                 open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                               (add_SNo (apply_fun f i0) 1).
    { rewrite <- (tuple_2_1_eq i (Eps_i (fun z => (i, z) :e U))).
      rewrite <- (tuple_2_1_eq i0 (open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                                 (add_SNo (apply_fun f i0) 1))).
      rewrite Heq.
      reflexivity. }
    rewrite Hz_eq.
    rewrite <- Hi_eq.
    reflexivity. }

  witness bU.
  apply andI.
  - (** bU :e box_basis omega Xi **)
    prove bU :e B.
    claim HbUsub: bU c= X.
    { let g. assume Hg: g :e bU.
      prove g :e X.
      exact (SepE1 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun U i) g Hg). }
    claim HbUpow: bU :e Power X.
    { exact (PowerI X bU HbUsub). }
    claim HUfun: function_on U omega TU.
    { let i. assume Hi: i :e omega.
      prove apply_fun U i :e TU.
      claim HfRi: apply_fun f i :e R.
      { exact (Romega_coord_in_R f i HfX Hi). }
      claim HfSi: SNo (apply_fun f i).
      { exact (real_SNo (apply_fun f i) HfRi). }
      claim HaR: add_SNo (apply_fun f i) (minus_SNo 1) :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi (minus_SNo 1) Hm1R). }
      claim HbR: add_SNo (apply_fun f i) 1 :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi 1 real_1). }
      claim HaS: SNo (add_SNo (apply_fun f i) (minus_SNo 1)).
      { exact (real_SNo (add_SNo (apply_fun f i) (minus_SNo 1)) HaR). }
      claim HbS: SNo (add_SNo (apply_fun f i) 1).
      { exact (real_SNo (add_SNo (apply_fun f i) 1) HbR). }
      claim Hlt: add_SNo (apply_fun f i) (minus_SNo 1) < add_SNo (apply_fun f i) 1.
      { exact (add_SNo_Lt2 (apply_fun f i) (minus_SNo 1) 1 HfSi Hm1S SNo_1 Hm1lt1). }
      claim HRlt: Rlt (add_SNo (apply_fun f i) (minus_SNo 1)) (add_SNo (apply_fun f i) 1).
      { exact (RltI (add_SNo (apply_fun f i) (minus_SNo 1))
                    (add_SNo (apply_fun f i) 1)
                    HaR
                    HbR
                    Hlt). }
      claim HopenI: open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                  (add_SNo (apply_fun f i) 1) :e R_standard_topology.
      { exact (open_interval_in_R_standard_topology
                (add_SNo (apply_fun f i) (minus_SNo 1))
                (add_SNo (apply_fun f i) 1)
                HRlt). }
      claim HappUi: apply_fun U i =
        open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                      (add_SNo (apply_fun f i) 1).
      { exact (HUapply i Hi). }
      rewrite HappUi.
      exact (UnionI {space_family_topology Xi j|j :e omega}
                    (open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                   (add_SNo (apply_fun f i) 1))
                    R_standard_topology
                    HopenI
                    HTfam). }
    claim HUtot: total_function_on U omega TU.
    { claim Htot': forall i:set, i :e omega -> exists y:set, y :e TU /\ (i,y) :e U.
      { let i. assume Hi: i :e omega.
        witness (apply_fun U i).
        apply andI.
        - exact (HUfun i Hi).
        - claim H1: (i, open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                    (add_SNo (apply_fun f i) 1)) :e U.
          { exact (ReplI omega (fun i0:set =>
                    (i0, open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                                       (add_SNo (apply_fun f i0) 1))) i Hi). }
          exact (Eps_i_ax (fun z:set => (i,z) :e U)
                          (open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                         (add_SNo (apply_fun f i) 1))
                          H1). }
      exact (andI (function_on U omega TU)
                  (forall x:set, x :e omega -> exists y:set, y :e TU /\ (x,y) :e U)
                  HUfun
                  Htot'). }
    claim HUgraph: functional_graph U.
    { exact (functional_graph_graph omega (fun i0:set =>
              open_interval (add_SNo (apply_fun f i0) (minus_SNo 1))
                            (add_SNo (apply_fun f i0) 1))). }
    claim HUcoords: forall i:set, i :e omega -> apply_fun U i :e space_family_topology Xi i.
    { let i. assume Hi: i :e omega.
      prove apply_fun U i :e space_family_topology Xi i.
      claim HXi: apply_fun Xi i = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology i Hi). }
      claim HTi: space_family_topology Xi i = R_standard_topology.
      { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_1_eq R R_standard_topology). }
      rewrite HTi.
      claim HfRi: apply_fun f i :e R.
      { exact (Romega_coord_in_R f i HfX Hi). }
      claim HfSi: SNo (apply_fun f i).
      { exact (real_SNo (apply_fun f i) HfRi). }
      claim HaR: add_SNo (apply_fun f i) (minus_SNo 1) :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi (minus_SNo 1) Hm1R). }
      claim HbR: add_SNo (apply_fun f i) 1 :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi 1 real_1). }
      claim Hlt: add_SNo (apply_fun f i) (minus_SNo 1) < add_SNo (apply_fun f i) 1.
      { exact (add_SNo_Lt2 (apply_fun f i) (minus_SNo 1) 1 HfSi Hm1S SNo_1 Hm1lt1). }
      claim HRlt: Rlt (add_SNo (apply_fun f i) (minus_SNo 1)) (add_SNo (apply_fun f i) 1).
      { exact (RltI (add_SNo (apply_fun f i) (minus_SNo 1))
                    (add_SNo (apply_fun f i) 1)
                    HaR
                    HbR
                    Hlt). }
      claim HopenI: open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                  (add_SNo (apply_fun f i) 1) :e R_standard_topology.
      { exact (open_interval_in_R_standard_topology
                (add_SNo (apply_fun f i) (minus_SNo 1))
                (add_SNo (apply_fun f i) 1)
                HRlt). }
      claim HappUi: apply_fun U i =
        open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                      (add_SNo (apply_fun f i) 1).
      { exact (HUapply i Hi). }
	      rewrite HappUi.
	      exact HopenI. }
	    claim HexU: exists U0:set, total_function_on U0 omega TU /\ functional_graph U0 /\
	      (forall i:set, i :e omega -> apply_fun U0 i :e space_family_topology Xi i) /\
	      bU = {f0 :e X | forall i:set, i :e omega -> apply_fun f0 i :e apply_fun U0 i}.
	    { witness U.
	      apply andI.
	      - apply andI.
	        + apply andI.
	          * exact HUtot.
	          * exact HUgraph.
	        + exact HUcoords.
	      - reflexivity. }
	    exact (SepI (Power X)
	                (fun B0:set => exists U0:set, total_function_on U0 omega TU /\ functional_graph U0 /\
	                  (forall i:set, i :e omega -> apply_fun U0 i :e space_family_topology Xi i) /\
	                  B0 = {f0 :e X | forall i:set, i :e omega -> apply_fun f0 i :e apply_fun U0 i})
	                bU
	                HbUpow
	                HexU).
  - apply andI.
    + (** f :e bU **)
      prove f :e bU.
      apply (SepI X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun U i) f HfX).
      let i. assume Hi: i :e omega.
      prove apply_fun f i :e apply_fun U i.
      claim HfRi: apply_fun f i :e R.
      { exact (Romega_coord_in_R f i HfX Hi). }
      claim HfSi: SNo (apply_fun f i).
      { exact (real_SNo (apply_fun f i) HfRi). }
      claim HaR: add_SNo (apply_fun f i) (minus_SNo 1) :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi (minus_SNo 1) Hm1R). }
      claim HbR: add_SNo (apply_fun f i) 1 :e R.
      { exact (real_add_SNo (apply_fun f i) HfRi 1 real_1). }
      claim Hx0eq : add_SNo (apply_fun f i) 0 = apply_fun f i.
      { exact (add_SNo_0R (apply_fun f i) HfSi). }
      claim Haxlt0 : add_SNo (apply_fun f i) (minus_SNo 1) < add_SNo (apply_fun f i) 0.
      { exact (add_SNo_Lt2 (apply_fun f i) (minus_SNo 1) 0 HfSi Hm1S SNo_0 minus_1_lt_0). }
      claim Haxlt : add_SNo (apply_fun f i) (minus_SNo 1) < apply_fun f i.
      { rewrite <- Hx0eq at 2. exact Haxlt0. }
      claim Hxltb0 : add_SNo (apply_fun f i) 0 < add_SNo (apply_fun f i) 1.
      { exact (add_SNo_Lt2 (apply_fun f i) 0 1 HfSi SNo_0 SNo_1 SNoLt_0_1). }
      claim Hxltb : apply_fun f i < add_SNo (apply_fun f i) 1.
      { rewrite <- Hx0eq at 1. exact Hxltb0. }
      claim HaRltx : Rlt (add_SNo (apply_fun f i) (minus_SNo 1)) (apply_fun f i).
      { exact (RltI (add_SNo (apply_fun f i) (minus_SNo 1)) (apply_fun f i) HaR HfRi Haxlt). }
      claim HxRltb : Rlt (apply_fun f i) (add_SNo (apply_fun f i) 1).
      { exact (RltI (apply_fun f i) (add_SNo (apply_fun f i) 1) HfRi HbR Hxltb). }
      claim HxIn: apply_fun f i :e open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                                           (add_SNo (apply_fun f i) 1).
      { exact (SepI R (fun z : set => Rlt (add_SNo (apply_fun f i) (minus_SNo 1)) z /\ Rlt z (add_SNo (apply_fun f i) 1))
                    (apply_fun f i) HfRi (andI (Rlt (add_SNo (apply_fun f i) (minus_SNo 1)) (apply_fun f i))
                                               (Rlt (apply_fun f i) (add_SNo (apply_fun f i) 1))
                                               HaRltx
                                               HxRltb)). }
      claim HappUi: apply_fun U i =
        open_interval (add_SNo (apply_fun f i) (minus_SNo 1))
                      (add_SNo (apply_fun f i) 1).
      { exact (HUapply i Hi). }
      rewrite HappUi.
      exact HxIn.
    + (** bU c= unbounded_sequences_Romega **)
      let g. assume Hg: g :e bU.
      prove g :e unbounded_sequences_Romega.
      claim HgX: g :e X.
      { exact (SepE1 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun U i) g Hg). }
      claim Hgprop: forall i:set, i :e omega -> apply_fun g i :e apply_fun U i.
      { exact (SepE2 X (fun g0:set => forall i:set, i :e omega -> apply_fun g0 i :e apply_fun U i) g Hg). }
      apply (SepI R_omega_space (fun h:set => unbounded_sequence_Romega h) g HgX).
      prove unbounded_sequence_Romega g.
      let M. assume HM: M :e R.
      set K := add_SNo M 1.
      claim HKR: K :e R.
      { exact (real_add_SNo M HM 1 real_1). }
      claim Hexn: exists n:set, n :e omega /\ ~(apply_fun f n :e open_interval (minus_SNo K) K).
      { exact (Huf K HKR). }
      apply Hexn.
      let n. assume Hnconj.
      claim HnO: n :e omega.
      { exact (andEL (n :e omega) (~(apply_fun f n :e open_interval (minus_SNo K) K)) Hnconj). }
      claim Hfnot: ~(apply_fun f n :e open_interval (minus_SNo K) K).
      { exact (andER (n :e omega) (~(apply_fun f n :e open_interval (minus_SNo K) K)) Hnconj). }
      witness n.
      apply andI.
      - exact HnO.
      - prove ~(apply_fun g n :e open_interval (minus_SNo M) M).
        assume HgnIn: apply_fun g n :e open_interval (minus_SNo M) M.
        prove False.
        apply Hfnot.
        (** show apply_fun f n is in open_interval (minus_SNo K) K from HgnIn and box membership **)
        claim HfnR: apply_fun f n :e R.
        { exact (Romega_coord_in_R f n HfX HnO). }
        claim HgnR: apply_fun g n :e R.
        { exact (Romega_coord_in_R g n HgX HnO). }
        claim HfnS: SNo (apply_fun f n).
        { exact (real_SNo (apply_fun f n) HfnR). }
        claim HgnS: SNo (apply_fun g n).
        { exact (real_SNo (apply_fun g n) HgnR). }
        claim HM_S: SNo M.
        { exact (real_SNo M HM). }
        claim HK_S: SNo K.
        { exact (real_SNo K HKR). }

        claim HgnBox: apply_fun g n :e open_interval (add_SNo (apply_fun f n) (minus_SNo 1))
                                               (add_SNo (apply_fun f n) 1).
        { claim HgnU: apply_fun g n :e apply_fun U n.
          { exact (Hgprop n HnO). }
          claim HappUn: apply_fun U n =
            open_interval (add_SNo (apply_fun f n) (minus_SNo 1))
                          (add_SNo (apply_fun f n) 1).
          { exact (HUapply n HnO). }
          rewrite <- HappUn.
          exact HgnU. }

        claim HgnInProp: Rlt (minus_SNo M) (apply_fun g n) /\ Rlt (apply_fun g n) M.
        { exact (SepE2 R (fun z:set => Rlt (minus_SNo M) z /\ Rlt z M) (apply_fun g n) HgnIn). }
        claim Hgn_gt_mM: Rlt (minus_SNo M) (apply_fun g n).
        { exact (andEL (Rlt (minus_SNo M) (apply_fun g n)) (Rlt (apply_fun g n) M) HgnInProp). }
        claim Hgn_lt_M: Rlt (apply_fun g n) M.
        { exact (andER (Rlt (minus_SNo M) (apply_fun g n)) (Rlt (apply_fun g n) M) HgnInProp). }

        claim HgnBoxProp: Rlt (add_SNo (apply_fun f n) (minus_SNo 1)) (apply_fun g n)
                          /\ Rlt (apply_fun g n) (add_SNo (apply_fun f n) 1).
        { exact (SepE2 R (fun z:set => Rlt (add_SNo (apply_fun f n) (minus_SNo 1)) z /\ Rlt z (add_SNo (apply_fun f n) 1))
                     (apply_fun g n) HgnBox). }
        claim HxL_lt_y: Rlt (add_SNo (apply_fun f n) (minus_SNo 1)) (apply_fun g n).
        { exact (andEL (Rlt (add_SNo (apply_fun f n) (minus_SNo 1)) (apply_fun g n))
                       (Rlt (apply_fun g n) (add_SNo (apply_fun f n) 1))
                       HgnBoxProp). }
        claim Hy_lt_xR: Rlt (apply_fun g n) (add_SNo (apply_fun f n) 1).
        { exact (andER (Rlt (add_SNo (apply_fun f n) (minus_SNo 1)) (apply_fun g n))
                       (Rlt (apply_fun g n) (add_SNo (apply_fun f n) 1))
                       HgnBoxProp). }

        (** derive apply_fun f n < apply_fun g n + 1 **)
        claim HxL_lt_y_lt: add_SNo (apply_fun f n) (minus_SNo 1) < apply_fun g n.
        { exact (RltE_lt (add_SNo (apply_fun f n) (minus_SNo 1)) (apply_fun g n) HxL_lt_y). }
        claim HxL1_lt_y1: add_SNo (add_SNo (apply_fun f n) (minus_SNo 1)) 1 < add_SNo (apply_fun g n) 1.
        { exact (add_SNo_Lt1 (add_SNo (apply_fun f n) (minus_SNo 1)) 1 (apply_fun g n)
                             (SNo_add_SNo (apply_fun f n) (minus_SNo 1) HfnS Hm1S)
                             SNo_1
                             HgnS
                             HxL_lt_y_lt). }
        claim Hx_to_xL1: add_SNo (add_SNo (apply_fun f n) (minus_SNo 1)) 1 = apply_fun f n.
        { exact (add_SNo_minus_R2' (apply_fun f n) 1 HfnS SNo_1). }
        claim Hx_lt_y1_lt: apply_fun f n < add_SNo (apply_fun g n) 1.
        { rewrite <- Hx_to_xL1 at 1. exact HxL1_lt_y1. }
        claim Hy1R: add_SNo (apply_fun g n) 1 :e R.
        { exact (real_add_SNo (apply_fun g n) HgnR 1 real_1). }
        claim Hx_lt_y1: Rlt (apply_fun f n) (add_SNo (apply_fun g n) 1).
        { exact (RltI (apply_fun f n) (add_SNo (apply_fun g n) 1) HfnR Hy1R Hx_lt_y1_lt). }

        (** derive add_SNo (apply_fun g n) 1 < K **)
        claim Hy_lt_M_lt: apply_fun g n < M.
        { exact (RltE_lt (apply_fun g n) M Hgn_lt_M). }
        claim Hy1_lt_M1: add_SNo (apply_fun g n) 1 < add_SNo M 1.
        { exact (add_SNo_Lt1 (apply_fun g n) 1 M HgnS SNo_1 HM_S Hy_lt_M_lt). }
        claim Hy1_Rlt_K: Rlt (add_SNo (apply_fun g n) 1) K.
        { exact (RltI (add_SNo (apply_fun g n) 1) K Hy1R HKR Hy1_lt_M1). }

        (** combine for upper bound: apply_fun f n < K **)
        claim Hx_lt_K: Rlt (apply_fun f n) K.
        { exact (Rlt_tra (apply_fun f n) (add_SNo (apply_fun g n) 1) K Hx_lt_y1 Hy1_Rlt_K). }

        (** derive minus_SNo K < apply_fun f n **)
        claim Hy_gt_mM_lt: minus_SNo M < apply_fun g n.
        { exact (RltE_lt (minus_SNo M) (apply_fun g n) Hgn_gt_mM). }
        claim Hy_m1_lt_x: add_SNo (apply_fun g n) (minus_SNo 1) < apply_fun f n.
        { claim Hy_lt_xR_lt: apply_fun g n < add_SNo (apply_fun f n) 1.
          { exact (RltE_lt (apply_fun g n) (add_SNo (apply_fun f n) 1) Hy_lt_xR). }
          claim Hy_m1_lt_x0: add_SNo (apply_fun g n) (minus_SNo 1) < add_SNo (add_SNo (apply_fun f n) 1) (minus_SNo 1).
          { exact (add_SNo_Lt1 (apply_fun g n) (minus_SNo 1) (add_SNo (apply_fun f n) 1)
                               HgnS
                               Hm1S
                               (SNo_add_SNo (apply_fun f n) 1 HfnS SNo_1)
                               Hy_lt_xR_lt). }
          claim Hx1m1_eq: add_SNo (add_SNo (apply_fun f n) 1) (minus_SNo 1) = apply_fun f n.
          { exact (add_SNo_minus_R2 (apply_fun f n) 1 HfnS SNo_1). }
          rewrite <- Hx1m1_eq.
          exact Hy_m1_lt_x0. }

        claim HmM_m1_lt_y_m1: add_SNo (minus_SNo M) (minus_SNo 1) < add_SNo (apply_fun g n) (minus_SNo 1).
        { exact (add_SNo_Lt1 (minus_SNo M) (minus_SNo 1) (apply_fun g n)
                             (real_SNo (minus_SNo M) (real_minus_SNo M HM))
                             Hm1S
                             HgnS
                             Hy_gt_mM_lt). }

        claim HmM_m1_R: add_SNo (minus_SNo M) (minus_SNo 1) :e R.
        { exact (real_add_SNo (minus_SNo M) (real_minus_SNo M HM) (minus_SNo 1) Hm1R). }
        claim HKneg: minus_SNo K = add_SNo (minus_SNo M) (minus_SNo 1).
        { claim Hdist: minus_SNo (add_SNo M 1) = add_SNo (minus_SNo M) (minus_SNo 1).
          { exact (minus_add_SNo_distr M 1 (real_SNo M HM) SNo_1). }
          exact Hdist. }

        claim HmK_lt_x: Rlt (minus_SNo K) (apply_fun f n).
        { rewrite HKneg.
          claim Htmp: Rlt (add_SNo (minus_SNo M) (minus_SNo 1)) (apply_fun f n).
          { claim Hmid: Rlt (add_SNo (minus_SNo M) (minus_SNo 1)) (add_SNo (apply_fun g n) (minus_SNo 1)).
            { exact (RltI (add_SNo (minus_SNo M) (minus_SNo 1))
                          (add_SNo (apply_fun g n) (minus_SNo 1))
                          HmM_m1_R
                          (real_add_SNo (apply_fun g n) HgnR (minus_SNo 1) Hm1R)
                          HmM_m1_lt_y_m1). }
            claim Hmid2: Rlt (add_SNo (apply_fun g n) (minus_SNo 1)) (apply_fun f n).
            { exact (RltI (add_SNo (apply_fun g n) (minus_SNo 1)) (apply_fun f n)
                          (real_add_SNo (apply_fun g n) HgnR (minus_SNo 1) Hm1R)
                          HfnR
                          Hy_m1_lt_x). }
            exact (Rlt_tra (add_SNo (minus_SNo M) (minus_SNo 1))
                           (add_SNo (apply_fun g n) (minus_SNo 1))
                           (apply_fun f n)
                           Hmid
                           Hmid2). }
          exact Htmp. }

        (** package membership in open_interval (minus_SNo K) K **)
        exact (SepI R (fun z:set => Rlt (minus_SNo K) z /\ Rlt z K)
                     (apply_fun f n)
                     HfnR
                     (andI (Rlt (minus_SNo K) (apply_fun f n))
                           (Rlt (apply_fun f n) K)
                           HmK_lt_x
                           Hx_lt_K)).
  }
exact (SepI (Power X)
            (fun U0:set => forall x :e U0, exists b :e B, x :e b /\ b c= U0)
            unbounded_sequences_Romega
            Hpow
            Hcond).
Qed.

Theorem bounded_unbounded_disjoint_Romega :
  bounded_sequences_Romega :/\: unbounded_sequences_Romega = Empty.
prove bounded_sequences_Romega :/\: unbounded_sequences_Romega = Empty.
apply set_ext.
- let f. assume Hf: f :e bounded_sequences_Romega :/\: unbounded_sequences_Romega.
  prove f :e Empty.
  claim Hb: f :e bounded_sequences_Romega.
  { exact (binintersectE1 bounded_sequences_Romega unbounded_sequences_Romega f Hf). }
  claim Hu: f :e unbounded_sequences_Romega.
  { exact (binintersectE2 bounded_sequences_Romega unbounded_sequences_Romega f Hf). }
  claim Hbprop: bounded_sequence_Romega f.
  { exact (SepE2 R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hb). }
  claim Huprop: unbounded_sequence_Romega f.
  { exact (SepE2 R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hu). }
  apply Hbprop.
  let M. assume HMconj.
  claim HMR: M :e R.
  { exact (andEL (M :e R) (forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M) HMconj). }
  claim Hbnd: forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M.
  { exact (andER (M :e R) (forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M) HMconj). }
  claim Hexn: exists n :e omega, ~(apply_fun f n :e open_interval (minus_SNo M) M).
  { exact (Huprop M HMR). }
  apply Hexn.
  let n. assume Hnconj.
  claim HnO: n :e omega.
  { exact (andEL (n :e omega) (~(apply_fun f n :e open_interval (minus_SNo M) M)) Hnconj). }
  claim Hnnot: ~(apply_fun f n :e open_interval (minus_SNo M) M).
  { exact (andER (n :e omega) (~(apply_fun f n :e open_interval (minus_SNo M) M)) Hnconj). }
  claim Hfalse: False.
  { exact (Hnnot (Hbnd n HnO)). }
  exact (FalseE Hfalse (f :e Empty)).
- exact (Subq_Empty (bounded_sequences_Romega :/\: unbounded_sequences_Romega)).
Qed.

Theorem bounded_union_unbounded_Romega :
  bounded_sequences_Romega :\/: unbounded_sequences_Romega = R_omega_space.
prove bounded_sequences_Romega :\/: unbounded_sequences_Romega = R_omega_space.
apply set_ext.
- let f. assume Hf: f :e bounded_sequences_Romega :\/: unbounded_sequences_Romega.
  prove f :e R_omega_space.
  apply (binunionE bounded_sequences_Romega unbounded_sequences_Romega f Hf).
  - assume Hb: f :e bounded_sequences_Romega.
    exact (SepE1 R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hb).
  - assume Hu: f :e unbounded_sequences_Romega.
    exact (SepE1 R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hu).
- let f. assume Hf: f :e R_omega_space.
  prove f :e bounded_sequences_Romega :\/: unbounded_sequences_Romega.
  apply (xm (bounded_sequence_Romega f) (f :e bounded_sequences_Romega :\/: unbounded_sequences_Romega)).
  - assume Hbseq: bounded_sequence_Romega f.
    prove f :e bounded_sequences_Romega :\/: unbounded_sequences_Romega.
    apply binunionI1.
    exact (SepI R_omega_space (fun f0:set => bounded_sequence_Romega f0) f Hf Hbseq).
  - assume HnotBound: ~(bounded_sequence_Romega f).
    prove f :e bounded_sequences_Romega :\/: unbounded_sequences_Romega.
    apply binunionI2.
    prove f :e unbounded_sequences_Romega.
    apply (SepI R_omega_space (fun f0:set => unbounded_sequence_Romega f0) f Hf).
    prove unbounded_sequence_Romega f.
    let M. assume HM: M :e R.
    apply (xm (exists n:set, n :e omega /\ ~(apply_fun f n :e open_interval (minus_SNo M) M))).
    - assume Hex. exact Hex.
    - assume Hnone: ~(exists n:set, n :e omega /\ ~(apply_fun f n :e open_interval (minus_SNo M) M)).
      prove exists n:set, n :e omega /\ ~(apply_fun f n :e open_interval (minus_SNo M) M).
      apply FalseE.
      prove False.
      apply HnotBound.
      prove bounded_sequence_Romega f.
      claim HbndM: forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M.
      { let n. assume HnO: n :e omega.
        prove apply_fun f n :e open_interval (minus_SNo M) M.
        apply dneg.
        assume Hnnot: ~(apply_fun f n :e open_interval (minus_SNo M) M).
        prove False.
        apply Hnone.
        witness n.
        apply andI.
        - exact HnO.
        - exact Hnnot. }
      exact (fun P Hp => Hp M (andI (M :e R)
                                    (forall n:set, n :e omega -> apply_fun f n :e open_interval (minus_SNo M) M)
                                    HM
                                    HbndM)).
Qed.

(** Helper: both halves of the separation are nonempty **)
Theorem bounded_sequences_Romega_nonempty : bounded_sequences_Romega <> Empty.
prove bounded_sequences_Romega <> Empty.
assume Heq: bounded_sequences_Romega = Empty.
prove False.
set Xi := const_space_family omega R R_standard_topology.
set U := space_family_union omega Xi.
set f0 := const_fun omega 0.
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim HR0: 0 :e R.
{ exact real_0. }
claim HX0: apply_fun Xi 0 = (R, R_standard_topology).
{ exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
claim Hset0: space_family_set Xi 0 = R.
{ claim Hdef: space_family_set Xi 0 = (apply_fun Xi 0) 0.
  { reflexivity. }
  rewrite Hdef.
  rewrite HX0.
  exact (tuple_2_0_eq R R_standard_topology). }
claim HRfam: R :e {space_family_set Xi i|i :e omega}.
{ apply ReplEq omega (fun i:set => space_family_set Xi i) R.
  assume _ H2. apply H2.
  prove exists i :e omega, R = space_family_set Xi i.
  witness 0.
  apply andI.
  - exact H0omega.
  - prove R = space_family_set Xi 0.
    symmetry.
    exact Hset0. }
claim H0U: 0 :e U.
{ exact (UnionI {space_family_set Xi i|i :e omega} 0 R HR0 HRfam). }

(** show f0 :e R_omega_space **)
claim Hf0: f0 :e R_omega_space.
{ prove f0 :e product_space omega Xi.
  prove f0 :e {f :e Power (setprod omega (space_family_union omega Xi))|
     total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
     forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i}.
  set U0 := space_family_union omega Xi.
  claim Hsub: f0 c= setprod omega U0.
  { let p. assume Hp: p :e f0.
    prove p :e setprod omega U0.
    apply (ReplE_impred omega (fun a:set => (a,0)) p Hp (p :e setprod omega U0)).
    let a. assume HaO: a :e omega. assume Hpeq: p = (a,0).
    rewrite Hpeq.
    exact (tuple_2_setprod_by_pair_Sigma omega U0 a 0 HaO H0U). }
  claim Hpow: f0 :e Power (setprod omega U0).
  { exact (PowerI (setprod omega U0) f0 Hsub). }
  claim Htot: total_function_on f0 omega U0.
  { exact (const_fun_total_function_on omega U0 0 H0U). }
  claim Hgraph: functional_graph f0.
  { exact (functional_graph_const_fun omega 0). }
  claim Hcoords: forall i:set, i :e omega -> apply_fun f0 i :e space_family_set Xi i.
  { let i. assume Hi: i :e omega.
    prove apply_fun f0 i :e space_family_set Xi i.
    claim Happ: apply_fun f0 i = 0.
    { exact (const_fun_apply omega 0 i Hi). }
    rewrite Happ.
    claim HX: apply_fun Xi i = (R, R_standard_topology).
    { exact (const_space_family_apply omega R R_standard_topology i Hi). }
    claim Hset: space_family_set Xi i = R.
    { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
      { reflexivity. }
      rewrite Hdef.
      rewrite HX.
      exact (tuple_2_0_eq R R_standard_topology). }
    rewrite Hset.
    exact real_0. }
  claim Hprop: total_function_on f0 omega U0 /\ functional_graph f0 /\
               forall i:set, i :e omega -> apply_fun f0 i :e space_family_set Xi i.
  { apply andI.
    - apply andI.
      + exact Htot.
      + exact Hgraph.
    - exact Hcoords. }
  exact (SepI (Power (setprod omega U0))
              (fun f:set => total_function_on f omega U0 /\ functional_graph f /\
                            forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i)
              f0
              Hpow
              Hprop). }

(** show bounded_sequence_Romega f0 by the bound 1 **)
claim Hbseq: bounded_sequence_Romega f0.
{ claim Hbnd1: forall n:set, n :e omega -> apply_fun f0 n :e open_interval (minus_SNo 1) 1.
  { let n. assume HnO: n :e omega.
    prove apply_fun f0 n :e open_interval (minus_SNo 1) 1.
    claim Happ: apply_fun f0 n = 0.
    { exact (const_fun_apply omega 0 n HnO). }
    rewrite Happ.
    claim Hm1R: minus_SNo 1 :e R.
    { exact (real_minus_SNo 1 real_1). }
    claim Hm1lt0: Rlt (minus_SNo 1) 0.
    { exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0). }
    claim H0lt1: Rlt 0 1.
    { exact Rlt_0_1. }
    claim Hconj: Rlt (minus_SNo 1) 0 /\ Rlt 0 1.
    { apply andI.
      - exact Hm1lt0.
      - exact H0lt1. }
    exact (SepI R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) 0 real_0 Hconj). }
  exact (fun P Hp => Hp 1 (andI (1 :e R)
                                (forall n:set, n :e omega -> apply_fun f0 n :e open_interval (minus_SNo 1) 1)
                                real_1
                                Hbnd1)). }

claim Hf0B: f0 :e bounded_sequences_Romega.
{ exact (SepI R_omega_space (fun f:set => bounded_sequence_Romega f) f0 Hf0 Hbseq). }
claim Hf0E: f0 :e Empty.
{ rewrite <- Heq at 2.
  exact Hf0B. }
exact (EmptyE f0 Hf0E).
Qed.

Theorem unbounded_sequences_Romega_nonempty : unbounded_sequences_Romega <> Empty.
prove unbounded_sequences_Romega <> Empty.
assume Heq: unbounded_sequences_Romega = Empty.
prove False.
set Xi := const_space_family omega R R_standard_topology.
set U := space_family_union omega Xi.
set fid := {(i,i)|i :e omega}.

(** show fid :e R_omega_space **)
claim Hfid: fid :e R_omega_space.
{ prove fid :e product_space omega Xi.
  prove fid :e {f :e Power (setprod omega (space_family_union omega Xi))|
     total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
     forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i}.
  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim HX0: apply_fun Xi 0 = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
  claim Hset0: space_family_set Xi 0 = R.
  { claim Hdef: space_family_set Xi 0 = (apply_fun Xi 0) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HX0.
    exact (tuple_2_0_eq R R_standard_topology). }
  claim HRfam: R :e {space_family_set Xi i|i :e omega}.
  { apply ReplEq omega (fun i:set => space_family_set Xi i) R.
    assume _ H2. apply H2.
    prove exists i :e omega, R = space_family_set Xi i.
    witness 0.
    apply andI.
    - exact H0omega.
    - symmetry.
      exact Hset0. }
	  claim HomegaU: forall i:set, i :e omega -> i :e U.
	  { let i. assume Hi: i :e omega.
	    prove i :e U.
	    claim HiR: i :e R.
	    { claim HiSNoS: i :e SNoS_ omega.
	      { exact (omega_SNoS_omega i Hi). }
	      exact (SNoS_omega_real i HiSNoS). }
	    exact (UnionI {space_family_set Xi i0|i0 :e omega} i R HiR HRfam). }

  claim Hsub: fid c= setprod omega U.
  { let p. assume Hp: p :e fid.
    prove p :e setprod omega U.
    apply (ReplE_impred omega (fun i:set => (i,i)) p Hp (p :e setprod omega U)).
    let i. assume Hi: i :e omega. assume Hpeq: p = (i,i).
    rewrite Hpeq.
    exact (tuple_2_setprod_by_pair_Sigma omega U i i Hi (HomegaU i Hi)). }
  claim Hpow: fid :e Power (setprod omega U).
  { exact (PowerI (setprod omega U) fid Hsub). }

  claim Hfun: function_on fid omega U.
  { let i. assume Hi: i :e omega.
    prove apply_fun fid i :e U.
    claim Happ: apply_fun fid i = i.
    { exact (identity_function_apply omega i Hi). }
    rewrite Happ.
    exact (HomegaU i Hi). }
  claim Htot: total_function_on fid omega U.
  { claim Htot': forall i:set, i :e omega -> exists y:set, y :e U /\ (i,y) :e fid.
    { let i. assume Hi: i :e omega.
      witness i.
      apply andI.
      - exact (HomegaU i Hi).
      - exact (ReplI omega (fun i0:set => (i0,i0)) i Hi). }
    exact (andI (function_on fid omega U)
                (forall x:set, x :e omega -> exists y:set, y :e U /\ (x,y) :e fid)
                Hfun
                Htot'). }
  claim Hgraph: functional_graph fid.
  { exact (functional_graph_graph omega (fun i0:set => i0)). }
  claim Hcoords: forall i:set, i :e omega -> apply_fun fid i :e space_family_set Xi i.
  { let i. assume Hi: i :e omega.
    prove apply_fun fid i :e space_family_set Xi i.
    claim Happ: apply_fun fid i = i.
    { exact (identity_function_apply omega i Hi). }
    rewrite Happ.
    claim Hset: space_family_set Xi i = R.
    { claim HXi: apply_fun Xi i = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology i Hi). }
      claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
      { reflexivity. }
      rewrite Hdef.
      rewrite HXi.
      exact (tuple_2_0_eq R R_standard_topology). }
	    rewrite Hset.
	    claim HiSNoS: i :e SNoS_ omega.
	    { exact (omega_SNoS_omega i Hi). }
	    exact (SNoS_omega_real i HiSNoS). }

  claim Hprop: total_function_on fid omega U /\ functional_graph fid /\
               forall i:set, i :e omega -> apply_fun fid i :e space_family_set Xi i.
  { apply andI.
    - apply andI.
      + exact Htot.
      + exact Hgraph.
    - exact Hcoords. }
  exact (SepI (Power (setprod omega U))
              (fun f:set => total_function_on f omega U /\ functional_graph f /\
                            forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i)
              fid
              Hpow
              Hprop). }

(** show unbounded_sequence_Romega fid **)
claim Huseq: unbounded_sequence_Romega fid.
{ let M. assume HM: M :e R.
  claim HMS: SNo M.
  { exact (real_SNo M HM). }
  claim Hor: M < 0 \/ 0 <= M.
  { exact (SNoLtLe_or M 0 HMS SNo_0). }
  claim Hcase1: M < 0 ->
    exists n:set, n :e omega /\ ~(apply_fun fid n :e open_interval (minus_SNo M) M).
  { assume HMlt0: M < 0.
    witness 0.
    apply andI.
    - exact (nat_p_omega 0 nat_0).
    - prove ~(apply_fun fid 0 :e open_interval (minus_SNo M) M).
      assume Hin: apply_fun fid 0 :e open_interval (minus_SNo M) M.
      claim Happ: apply_fun fid 0 = 0.
      { exact (identity_function_apply omega 0 (nat_p_omega 0 nat_0)). }
      claim Hprop: Rlt (minus_SNo M) (apply_fun fid 0) /\ Rlt (apply_fun fid 0) M.
      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo M) x0 /\ Rlt x0 M) (apply_fun fid 0) Hin). }
      claim HRlt0M: Rlt 0 M.
      { rewrite <- Happ.
        exact (andER (Rlt (minus_SNo M) (apply_fun fid 0)) (Rlt (apply_fun fid 0) M) Hprop). }
      claim HRltM0: Rlt M 0.
      { exact (RltI M 0 HM real_0 HMlt0). }
      claim Hnot: ~(Rlt 0 M).
      { exact (not_Rlt_sym M 0 HRltM0). }
      exact (Hnot HRlt0M). }
  claim Hcase2: 0 <= M ->
    exists n:set, n :e omega /\ ~(apply_fun fid n :e open_interval (minus_SNo M) M).
  { assume HMnonneg: 0 <= M.
    claim Hexn0: exists n :e omega, n <= M /\ M < ordsucc n.
    { exact (nonneg_real_nat_interval M HM HMnonneg). }
    apply Hexn0.
    let n0. assume Hn0conj.
    claim Hn0: n0 :e omega.
    { exact (andEL (n0 :e omega) (n0 <= M /\ M < ordsucc n0) Hn0conj). }
    claim Hn0prop: n0 <= M /\ M < ordsucc n0.
    { exact (andER (n0 :e omega) (n0 <= M /\ M < ordsucc n0) Hn0conj). }
    claim HMltS: M < ordsucc n0.
    { exact (andER (n0 <= M) (M < ordsucc n0) Hn0prop). }
    set n := ordsucc n0.
    witness n.
    apply andI.
    - exact (omega_ordsucc n0 Hn0).
    - prove ~(apply_fun fid n :e open_interval (minus_SNo M) M).
      assume Hin: apply_fun fid n :e open_interval (minus_SNo M) M.
      claim Happ: apply_fun fid n = n.
      { exact (identity_function_apply omega n (omega_ordsucc n0 Hn0)). }
      claim HnR: n :e R.
      { claim HnO: n :e omega.
        { exact (omega_ordsucc n0 Hn0). }
        claim HnSNoS: n :e SNoS_ omega.
        { exact (omega_SNoS_omega n HnO). }
        exact (SNoS_omega_real n HnSNoS). }
      claim HRltMn: Rlt M n.
      { exact (RltI M n HM HnR HMltS). }
      claim HnotnM: ~(Rlt n M).
      { exact (not_Rlt_sym M n HRltMn). }
      claim Hprop: Rlt (minus_SNo M) (apply_fun fid n) /\ Rlt (apply_fun fid n) M.
      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo M) x0 /\ Rlt x0 M) (apply_fun fid n) Hin). }
      claim HRltnM: Rlt n M.
      { rewrite <- Happ.
        exact (andER (Rlt (minus_SNo M) (apply_fun fid n)) (Rlt (apply_fun fid n) M) Hprop). }
      exact (HnotnM HRltnM). }
  exact (Hor (exists n:set, n :e omega /\ ~(apply_fun fid n :e open_interval (minus_SNo M) M)) Hcase1 Hcase2).
}

claim HfidU: fid :e unbounded_sequences_Romega.
{ exact (SepI R_omega_space (fun f:set => unbounded_sequence_Romega f) fid Hfid Huseq). }
claim HeqE: Empty = unbounded_sequences_Romega.
{ symmetry. exact Heq. }
claim Hsubst: forall S T:set, S = T -> fid :e T -> fid :e S.
{ let S T.
  assume HeqST: S = T.
  assume HfidT: fid :e T.
  prove fid :e S.
  rewrite HeqST.
  exact HfidT. }
claim HfidE: fid :e Empty.
{ exact (Hsubst Empty unbounded_sequences_Romega HeqE HfidU). }
exact (EmptyE fid HfidE).
Qed.

Theorem R_omega_box_not_connected :
  ~ connected_space (product_space omega (const_space_family omega R R_standard_topology))
    (box_topology omega (const_space_family omega R R_standard_topology)).
prove ~ connected_space (product_space omega (const_space_family omega R R_standard_topology))
  (box_topology omega (const_space_family omega R R_standard_topology)).
assume Hconn: connected_space R_omega_space R_omega_box_topology.
prove False.
claim Hnosep: ~(exists U V:set, U :e R_omega_box_topology /\ V :e R_omega_box_topology /\ separation_of R_omega_space U V).
{ exact (andER (topology_on R_omega_space R_omega_box_topology)
               (~(exists U V:set, U :e R_omega_box_topology /\ V :e R_omega_box_topology /\ separation_of R_omega_space U V))
               Hconn). }
claim Hsep: exists U V:set, U :e R_omega_box_topology /\ V :e R_omega_box_topology /\ separation_of R_omega_space U V.
{ witness bounded_sequences_Romega.
  witness unbounded_sequences_Romega.
  apply andI.
  - apply andI.
    + exact bounded_sequences_in_Romega_box_topology.
    + exact unbounded_sequences_in_Romega_box_topology.
  - prove separation_of R_omega_space bounded_sequences_Romega unbounded_sequences_Romega.
    prove bounded_sequences_Romega :e Power R_omega_space /\
          unbounded_sequences_Romega :e Power R_omega_space /\
          bounded_sequences_Romega :/\: unbounded_sequences_Romega = Empty /\
          bounded_sequences_Romega <> Empty /\
          unbounded_sequences_Romega <> Empty /\
          bounded_sequences_Romega :\/: unbounded_sequences_Romega = R_omega_space.
    (** Conjunction is left-associative: (((((A /\ B) /\ C) /\ D) /\ E) /\ F) **)
    apply andI.
    - (** ((((A /\ B) /\ C) /\ D) /\ E) **)
      apply andI.
      + (** (((A /\ B) /\ C) /\ D) **)
        apply andI.
        * (** ((A /\ B) /\ C) **)
          apply andI.
          - (** (A /\ B) **)
            apply andI.
            + exact bounded_sequences_Romega_in_Power.
            + exact unbounded_sequences_Romega_in_Power.
          - exact bounded_unbounded_disjoint_Romega.
        * exact bounded_sequences_Romega_nonempty.
      + exact unbounded_sequences_Romega_nonempty.
    - exact bounded_union_unbounded_Romega.
}
exact (Hnosep Hsep).
Qed.

(** from §23 Example 7: R^ω in the product topology is connected **) 
(** LATEX VERSION: Let R^∞ be sequences eventually 0; it is connected as union of R^n; its closure is all of R^ω in product topology. **)
Definition Romega_tilde : set -> set := fun n =>
  {f :e R_omega_space | forall i:set, i :e omega -> n :e i -> apply_fun f i = 0}.

Definition Romega_infty : set := Union {Romega_tilde n|n :e omega}.

Theorem Romega_tilde_sub_Romega : forall n:set,
  Romega_tilde n c= R_omega_space.
let n.
let f. assume Hf: f :e Romega_tilde n.
prove f :e R_omega_space.
exact (SepE1 R_omega_space (fun f0:set => forall i:set, i :e omega -> n :e i -> apply_fun f0 i = 0) f Hf).
Qed.

Theorem Romega_infty_sub_Romega : Romega_infty c= R_omega_space.
let f. assume Hf: f :e Romega_infty.
prove f :e R_omega_space.
apply (UnionE_impred {Romega_tilde n|n :e omega} f Hf).
let Y. assume HfY: f :e Y. assume HY: Y :e {Romega_tilde n|n :e omega}.
apply (ReplE_impred omega (fun n:set => Romega_tilde n) Y HY (f :e R_omega_space)).
let n. assume Hn: n :e omega. assume HYeq: Y = Romega_tilde n.
claim HfY2: f :e Romega_tilde n.
{ rewrite <- HYeq.
  exact HfY. }
exact (Romega_tilde_sub_Romega n f HfY2).
Qed.

(** from §23 Example 7: the constant zero sequence in R^omega **)
(** LATEX VERSION: The constant zero sequence is an element of R^omega (the countable product of R). **)
Definition Romega_zero : set := const_fun omega 0.

Theorem Romega_zero_in_Romega_space : Romega_zero :e R_omega_space.
prove Romega_zero :e R_omega_space.
set Xi := const_space_family omega R R_standard_topology.
set U0 := space_family_union omega Xi.
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim HR0: 0 :e R.
{ exact real_0. }
claim HX0: apply_fun Xi 0 = (R, R_standard_topology).
{ exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
claim Hset0: space_family_set Xi 0 = R.
{ claim Hdef: space_family_set Xi 0 = (apply_fun Xi 0) 0.
  { reflexivity. }
  rewrite Hdef.
  rewrite HX0.
  exact (tuple_2_0_eq R R_standard_topology). }
claim HRfam: R :e {space_family_set Xi i|i :e omega}.
{ apply ReplEq omega (fun i:set => space_family_set Xi i) R.
  assume _ H2. apply H2.
  prove exists i :e omega, R = space_family_set Xi i.
  witness 0.
  apply andI.
  - exact H0omega.
  - prove R = space_family_set Xi 0.
    symmetry.
    exact Hset0. }
claim H0U0: 0 :e U0.
{ exact (UnionI {space_family_set Xi i|i :e omega} 0 R HR0 HRfam). }

prove Romega_zero :e product_space omega Xi.
prove Romega_zero :e {f :e Power (setprod omega (space_family_union omega Xi))|
   total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
   forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i}.
claim Hsub: Romega_zero c= setprod omega U0.
{ let p. assume Hp: p :e Romega_zero.
  prove p :e setprod omega U0.
  apply (ReplE_impred omega (fun a:set => (a,0)) p Hp (p :e setprod omega U0)).
  let a. assume HaO: a :e omega. assume Hpeq: p = (a,0).
  rewrite Hpeq.
  exact (tuple_2_setprod_by_pair_Sigma omega U0 a 0 HaO H0U0). }
claim Hpow: Romega_zero :e Power (setprod omega U0).
{ exact (PowerI (setprod omega U0) Romega_zero Hsub). }
claim Htot: total_function_on Romega_zero omega U0.
{ exact (const_fun_total_function_on omega U0 0 H0U0). }
claim Hgraph: functional_graph Romega_zero.
{ exact (functional_graph_const_fun omega 0). }
claim Hcoords: forall i:set, i :e omega -> apply_fun Romega_zero i :e space_family_set Xi i.
{ let i. assume Hi: i :e omega.
  prove apply_fun Romega_zero i :e space_family_set Xi i.
  claim Happ: apply_fun Romega_zero i = 0.
  { exact (const_fun_apply omega 0 i Hi). }
  rewrite Happ.
  claim HX: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hset: space_family_set Xi i = R.
  { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HX.
    exact (tuple_2_0_eq R R_standard_topology). }
  rewrite Hset.
  exact real_0. }
claim Hprop: total_function_on Romega_zero omega U0 /\ functional_graph Romega_zero /\
             forall i:set, i :e omega -> apply_fun Romega_zero i :e space_family_set Xi i.
{ apply andI.
  - apply andI.
    + exact Htot.
    + exact Hgraph.
  - exact Hcoords. }
exact (SepI (Power (setprod omega U0))
            (fun f:set => total_function_on f omega U0 /\ functional_graph f /\
                          forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i)
            Romega_zero
            Hpow
            Hprop).
Qed.

Theorem Romega_zero_in_Romega_tilde : forall n:set,
  n :e omega -> Romega_zero :e Romega_tilde n.
let n. assume HnO: n :e omega.
prove Romega_zero :e Romega_tilde n.
claim Hbase: Romega_zero :e R_omega_space.
{ exact Romega_zero_in_Romega_space. }
claim Hprop: forall i:set, i :e omega -> n :e i -> apply_fun Romega_zero i = 0.
{ let i. assume Hi: i :e omega.
  assume Hni: n :e i.
  prove apply_fun Romega_zero i = 0.
  exact (const_fun_apply omega 0 i Hi). }
exact (SepI R_omega_space
           (fun f0:set => forall i:set, i :e omega -> n :e i -> apply_fun f0 i = 0)
           Romega_zero
           Hbase
           Hprop).
Qed.

Theorem Romega_tilde_nonempty : forall n:set,
  n :e omega -> Romega_tilde n <> Empty.
let n. assume HnO: n :e omega.
prove Romega_tilde n <> Empty.
assume HEmpty: Romega_tilde n = Empty.
prove False.
claim H0in: Romega_zero :e Romega_tilde n.
{ exact (Romega_zero_in_Romega_tilde n HnO). }
claim H0E: Romega_zero :e Empty.
{ rewrite <- HEmpty.
  exact H0in. }
exact (EmptyE Romega_zero H0E).
Qed.

(** from §23 Example 7: product topology on R^omega is a topology **)
(** LATEX VERSION: The product topology on R to the omega is a topology on the product space R to the omega. **)
Theorem Romega_product_topology_is_topology : topology_on R_omega_space R_omega_product_topology.
prove topology_on R_omega_space R_omega_product_topology.
set Xi := const_space_family omega R R_standard_topology.
set X := product_space omega Xi.
set S := product_subbasis_full omega Xi.
set Tx := generated_topology_from_subbasis X S.

claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }

claim HcompTop: forall i:set, i :e omega -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume Hi: i :e omega.
  prove topology_on (space_family_set Xi i) (space_family_topology Xi i).
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hset: space_family_set Xi i = R.
  { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_0_eq R R_standard_topology). }
  claim HTi: space_family_topology Xi i = R_standard_topology.
  { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  rewrite Hset.
  rewrite HTi.
  exact R_standard_topology_is_topology_local. }

claim HSsub: S c= Power X.
{ let s. assume Hs: s :e S.
  prove s :e Power X.
  apply PowerI.
  let f. assume Hf: f :e s.
  prove f :e X.
  set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
  claim HsF: s :e (\/_ i :e omega, F i).
  { exact Hs. }
  apply (famunionE_impred omega F s HsF).
  let i. assume Hi: i :e omega. assume HsFi: s :e F i.
  apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi (f :e X)).
  let U0. assume HU0: U0 :e space_family_topology Xi i.
  assume Hseq: s = product_cylinder omega Xi i U0.
  claim HfCyl: f :e product_cylinder omega Xi i U0.
  { rewrite <- Hseq.
    exact Hf. }
  exact (SepE1 X
              (fun g0:set => i :e omega /\ U0 :e space_family_topology Xi i /\ apply_fun g0 i :e U0)
              f
              HfCyl). }

claim HUnionS: Union S = X.
{ apply set_ext.
  - let f. assume Hf: f :e Union S.
    prove f :e X.
    apply UnionE_impred S f Hf.
    let s. assume Hfs: f :e s. assume HsS: s :e S.
    claim HsPow: s :e Power X.
    { exact (HSsub s HsS). }
    exact (PowerE X s HsPow f Hfs).
  - let f. assume Hf: f :e X.
    prove f :e Union S.
    set i0 := 0.
    set U0 := space_family_set Xi i0.
    set s0 := product_cylinder omega Xi i0 U0.
    claim Hi0: i0 :e omega.
    { exact H0omega. }
    claim HTi0: topology_on (space_family_set Xi i0) (space_family_topology Xi i0).
    { exact (HcompTop i0 Hi0). }
    claim HU0top: U0 :e space_family_topology Xi i0.
    { exact (topology_has_X (space_family_set Xi i0) (space_family_topology Xi i0) HTi0). }
    claim Hs0S: s0 :e S.
    { set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
      claim Hs0Fi0: s0 :e F i0.
      { exact (ReplI (space_family_topology Xi i0)
                     (fun U:set => product_cylinder omega Xi i0 U)
                     U0
                     HU0top). }
      exact (famunionI omega F i0 s0 Hi0 Hs0Fi0). }
    prove f :e Union S.
    apply (UnionI S f s0).
    - prove f :e s0.
      prove f :e {g :e X | i0 :e omega /\ U0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e U0}.
      apply (SepI X
               (fun g0:set => i0 :e omega /\ U0 :e space_family_topology Xi i0 /\ apply_fun g0 i0 :e U0)
               f
               Hf).
      prove i0 :e omega /\ U0 :e space_family_topology Xi i0 /\ apply_fun f i0 :e U0.
      apply andI.
      + prove i0 :e omega /\ U0 :e space_family_topology Xi i0.
        apply andI.
        - exact Hi0.
        - exact HU0top.
	      + claim Hfprop: total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
	            forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i.
	          { exact (SepE2 (Power (setprod omega (space_family_union omega Xi)))
	                         (fun f0:set => total_function_on f0 omega (space_family_union omega Xi) /\ functional_graph f0 /\
	                           forall i:set, i :e omega -> apply_fun f0 i :e space_family_set Xi i)
	                         f
	                         Hf). }
	          claim Hcoords: forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i.
	          { exact (andER (total_function_on f omega (space_family_union omega Xi) /\ functional_graph f)
	                         (forall i:set, i :e omega -> apply_fun f i :e space_family_set Xi i)
	                         Hfprop). }
	          exact (Hcoords i0 Hi0).
    - exact Hs0S. }

claim HS: subbasis_on X S.
{ prove S c= Power X /\ Union S = X.
  apply andI.
  - exact HSsub.
  - exact HUnionS. }
claim HTx: topology_on X Tx.
{ exact (topology_from_subbasis_is_topology X S HS). }
claim HXe: X = R_omega_space.
{ reflexivity. }
claim HTXe: Tx = R_omega_product_topology.
{ reflexivity. }
rewrite <- HXe.
rewrite <- HTXe.
exact HTx.
Qed.

(** from §23: dense set meets every nonempty open set **)
(** LATEX VERSION: If A is dense in X and U is nonempty open, then U intersect A is nonempty. **)
Theorem dense_in_meets_nonempty_open : forall A X Tx U:set,
  topology_on X Tx ->
  closure_of X Tx A = X ->
  U :e Tx ->
  U <> Empty ->
  U :/\: A <> Empty.
let A X Tx U.
assume HTx: topology_on X Tx.
assume Hdense: closure_of X Tx A = X.
assume HU: U :e Tx.
assume HUne: U <> Empty.
claim Hexx: exists x:set, x :e U.
{ exact (nonempty_has_element U HUne). }
apply Hexx.
let x. assume HxU: x :e U.
claim HTsub: Tx c= Power X.
{ exact (topology_subset_axiom X Tx HTx). }
claim HUpow: U :e Power X.
{ exact (HTsub U HU). }
claim HxX: x :e X.
{ exact (PowerE X U HUpow x HxU). }
claim Hcl: x :e closure_of X Tx A.
{ rewrite Hdense.
  exact HxX. }
claim Hcliff: x :e closure_of X Tx A <-> (forall V :e Tx, x :e V -> V :/\: A <> Empty).
{ exact (closure_characterization X Tx A x HTx HxX). }
claim Hneigh: forall V :e Tx, x :e V -> V :/\: A <> Empty.
{ exact (iffEL (x :e closure_of X Tx A) (forall V :e Tx, x :e V -> V :/\: A <> Empty) Hcliff Hcl). }
exact (Hneigh U HU HxU).
Qed.

(** from §23: dense connected subset implies connected space **)
(** LATEX VERSION: If A is dense in X and A is connected in the subspace topology, then X is connected. **)
Theorem connected_space_if_dense_connected_subset : forall X Tx A:set,
  topology_on X Tx ->
  A c= X ->
  connected_space A (subspace_topology X Tx A) ->
  closure_of X Tx A = X ->
  connected_space X Tx.
let X Tx A.
assume HTx: topology_on X Tx.
assume HAsub: A c= X.
assume HAconn: connected_space A (subspace_topology X Tx A).
assume Hdense: closure_of X Tx A = X.
prove connected_space X Tx.
prove topology_on X Tx /\ ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
apply andI.
- exact HTx.
- prove ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
  assume Hsep: exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
  apply Hsep.
  let U. assume HexV: exists V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
  apply HexV.
  let V. assume HUVsep.
  claim HUV12: U :e Tx /\ V :e Tx.
  { exact (andEL (U :e Tx /\ V :e Tx) (separation_of X U V) HUVsep). }
  claim HU: U :e Tx.
  { exact (andEL (U :e Tx) (V :e Tx) HUV12). }
  claim HV: V :e Tx.
  { exact (andER (U :e Tx) (V :e Tx) HUV12). }
  claim HsepUV: separation_of X U V.
  { exact (andER (U :e Tx /\ V :e Tx) (separation_of X U V) HUVsep). }
  claim HsepL: ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = X)
                 HsepUV). }
  claim HUVdisj: (U :e Power X /\ V :e Power X) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)
                 (U <> Empty)
                 (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
                        (V <> Empty)
                        HsepL)). }
  claim HUVempty: U :/\: V = Empty.
  { exact (andER (U :e Power X /\ V :e Power X) (U :/\: V = Empty) HUVdisj). }
  claim HU0: U <> Empty.
  { exact (andER ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) (U <> Empty)
                 (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
                        (V <> Empty)
                        HsepL)). }
  claim HV0: V <> Empty.
  { exact (andER (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty)
                 HsepL). }
  claim Hside: A c= U \/ A c= V.
  { exact (connected_subset_in_separation_side X Tx U V A HTx HAsub HAconn HU HV HsepUV). }
  apply Hside.
  - assume HAU: A c= U.
    claim HVneA: V :/\: A <> Empty.
    { exact (dense_in_meets_nonempty_open A X Tx V HTx Hdense HV HV0). }
    claim HVAsubEmpty: V :/\: A c= Empty.
    { let x. assume Hx: x :e V :/\: A.
      prove x :e Empty.
      claim HxV: x :e V.
      { exact (binintersectE1 V A x Hx). }
      claim HxA: x :e A.
      { exact (binintersectE2 V A x Hx). }
      claim HxU: x :e U.
      { exact (HAU x HxA). }
      claim HxUV: x :e U :/\: V.
      { exact (binintersectI U V x HxU HxV). }
      claim HxE: x :e Empty.
      { rewrite <- HUVempty.
        exact HxUV. }
      exact HxE. }
    claim HVAEq: V :/\: A = Empty.
    { exact (Empty_Subq_eq (V :/\: A) HVAsubEmpty). }
    apply HVneA.
    exact HVAEq.
  - assume HAV: A c= V.
    claim HUneA: U :/\: A <> Empty.
    { exact (dense_in_meets_nonempty_open A X Tx U HTx Hdense HU HU0). }
    claim HUAsubEmpty: U :/\: A c= Empty.
    { let x. assume Hx: x :e U :/\: A.
      prove x :e Empty.
      claim HxU: x :e U.
      { exact (binintersectE1 U A x Hx). }
      claim HxA: x :e A.
      { exact (binintersectE2 U A x Hx). }
      claim HxV: x :e V.
      { exact (HAV x HxA). }
      claim HxUV: x :e U :/\: V.
      { exact (binintersectI U V x HxU HxV). }
      claim HxE: x :e Empty.
      { rewrite <- HUVempty.
        exact HxUV. }
      exact HxE. }
    claim HUAEq: U :/\: A = Empty.
    { exact (Empty_Subq_eq (U :/\: A) HUAsubEmpty). }
    apply HUneA.
    exact HUAEq.
Qed.

(** Example 7 connectedness theorems are stated later, after singleton and extension map infrastructure. **)

(** Helper: any omega indexed real map gives an element of R_omega_space **)
Theorem graph_omega_in_Romega_space : forall h:set->set,
  (forall i:set, i :e omega -> h i :e R) ->
  graph omega h :e R_omega_space.
let h.
assume HhR: forall i:set, i :e omega -> h i :e R.
prove graph omega h :e R_omega_space.
set Xi := const_space_family omega R R_standard_topology.
set U0 := space_family_union omega Xi.
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim HXi0: apply_fun Xi 0 = (R, R_standard_topology).
{ exact (const_space_family_apply omega R R_standard_topology 0 H0omega). }
claim Hset0: space_family_set Xi 0 = R.
{ claim Hdef: space_family_set Xi 0 = (apply_fun Xi 0) 0.
  { reflexivity. }
  rewrite Hdef.
  rewrite HXi0.
  exact (tuple_2_0_eq R R_standard_topology). }
claim HRfam: R :e {space_family_set Xi i|i :e omega}.
{ apply ReplEq omega (fun i:set => space_family_set Xi i) R.
  assume _ H2. apply H2.
  prove exists i :e omega, R = space_family_set Xi i.
  witness 0.
  apply andI.
  - exact H0omega.
  - prove R = space_family_set Xi 0.
    symmetry.
    exact Hset0. }
claim HRinU0: forall r:set, r :e R -> r :e U0.
{ let r. assume Hr: r :e R.
  exact (UnionI {space_family_set Xi i|i :e omega} r R Hr HRfam). }
claim Hsub: graph omega h c= setprod omega U0.
{ let p. assume Hp: p :e graph omega h.
  prove p :e setprod omega U0.
  apply (ReplE_impred omega (fun i:set => (i, h i)) p Hp (p :e setprod omega U0)).
  let i. assume Hi: i :e omega. assume Heq: p = (i, h i).
  rewrite Heq.
  claim HhiR: h i :e R.
  { exact (HhR i Hi). }
  claim HhiU0: h i :e U0.
  { exact (HRinU0 (h i) HhiR). }
  exact (tuple_2_setprod_by_pair_Sigma omega U0 i (h i) Hi HhiU0). }
claim Hpow: graph omega h :e Power (setprod omega U0).
{ exact (PowerI (setprod omega U0) (graph omega h) Hsub). }
claim Hfun: function_on (graph omega h) omega U0.
{ let i. assume Hi: i :e omega.
  prove apply_fun (graph omega h) i :e U0.
  claim Happ: apply_fun (graph omega h) i = h i.
  { exact (apply_fun_graph omega h i Hi). }
  rewrite Happ.
  exact (HRinU0 (h i) (HhR i Hi)). }
claim Hcoords: forall i:set, i :e omega -> apply_fun (graph omega h) i :e space_family_set Xi i.
{ let i. assume Hi: i :e omega.
  prove apply_fun (graph omega h) i :e space_family_set Xi i.
  claim Happ: apply_fun (graph omega h) i = h i.
  { exact (apply_fun_graph omega h i Hi). }
  rewrite Happ.
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hset: space_family_set Xi i = R.
  { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_0_eq R R_standard_topology). }
  rewrite Hset.
  exact (HhR i Hi). }
claim Htot: total_function_on (graph omega h) omega U0.
{ claim Htot': forall i:set, i :e omega -> exists y:set, y :e U0 /\ (i,y) :e graph omega h.
  { let i. assume Hi: i :e omega.
    witness (h i).
    apply andI.
    - exact (HRinU0 (h i) (HhR i Hi)).
    - exact (ReplI omega (fun a:set => (a, h a)) i Hi). }
  exact (andI (function_on (graph omega h) omega U0)
              (forall x:set, x :e omega -> exists y:set, y :e U0 /\ (x,y) :e graph omega h)
              Hfun
              Htot'). }
claim Hgraph: functional_graph (graph omega h).
{ exact (functional_graph_graph omega h). }
claim Hprop: total_function_on (graph omega h) omega U0 /\ functional_graph (graph omega h) /\
  forall i:set, i :e omega -> apply_fun (graph omega h) i :e space_family_set Xi i.
{ apply andI.
  - apply andI.
    + exact Htot.
    + exact Hgraph.
  - exact Hcoords. }
exact (SepI (Power (setprod omega U0))
            (fun f0:set => total_function_on f0 omega U0 /\ functional_graph f0 /\
              forall i:set, i :e omega -> apply_fun f0 i :e space_family_set Xi i)
            (graph omega h)
            Hpow
            Hprop).
Qed.

(** from §19: coordinate inclusions into infinite products **)
(** LATEX VERSION: One often considers the map r -> (r,0,0,...) into R^omega when working with product and box topologies. **)
(** Helper: a sequence supported at coordinate 0 **)
Definition Romega_singleton_seq : set -> set := fun r =>
  graph omega (fun i:set => If_i (0 :e i) 0 r).

(** Helper: singleton sequence is in the ambient product space **)
Theorem Romega_singleton_seq_in_Romega_space : forall r:set,
  r :e R -> Romega_singleton_seq r :e R_omega_space.
let r. assume Hr: r :e R.
prove Romega_singleton_seq r :e R_omega_space.
claim Hdef: Romega_singleton_seq r = graph omega (fun i:set => If_i (0 :e i) 0 r).
{ reflexivity. }
rewrite Hdef.
apply (graph_omega_in_Romega_space (fun i:set => If_i (0 :e i) 0 r)).
let i. assume Hi: i :e omega.
prove If_i (0 :e i) 0 r :e R.
apply (xm (0 :e i)).
- assume H0i: 0 :e i.
  rewrite (If_i_1 (0 :e i) 0 r H0i).
  exact real_0.
- assume Hn0i: ~(0 :e i).
  rewrite (If_i_0 (0 :e i) 0 r Hn0i).
  exact Hr.
Qed.

(** Helper: coordinate evaluation of the singleton sequence **)
(** LATEX VERSION: For the singleton sequence r ↦ (r,0,0,...), the i-th coordinate is If(0 in i) then 0 else r. **)
Theorem Romega_singleton_seq_apply : forall r i:set,
  r :e R ->
  i :e omega ->
  apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
let r i.
assume Hr: r :e R.
assume Hi: i :e omega.
prove apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
claim Hdef: Romega_singleton_seq r = graph omega (fun j:set => If_i (0 :e j) 0 r).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph omega (fun j:set => If_i (0 :e j) 0 r) i Hi).
Qed.

(** Helper: singleton sequence is in Romega_tilde 0 **)
Theorem Romega_singleton_seq_in_Romega_tilde0 : forall r:set,
  r :e R -> Romega_singleton_seq r :e Romega_tilde 0.
let r. assume Hr: r :e R.
prove Romega_singleton_seq r :e Romega_tilde 0.
claim HdefT: Romega_tilde 0 =
  {f :e R_omega_space | forall i:set, i :e omega -> 0 :e i -> apply_fun f i = 0}.
{ reflexivity. }
rewrite HdefT.
apply (SepI R_omega_space (fun f0:set => forall i:set, i :e omega -> 0 :e i -> apply_fun f0 i = 0)).
- exact (Romega_singleton_seq_in_Romega_space r Hr).
- let i. assume Hi: i :e omega.
  assume H0i: 0 :e i.
  prove apply_fun (Romega_singleton_seq r) i = 0.
  claim Happ: apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
  { claim Hdef: Romega_singleton_seq r = graph omega (fun j:set => If_i (0 :e j) 0 r).
    { reflexivity. }
    rewrite Hdef.
    exact (apply_fun_graph omega (fun j:set => If_i (0 :e j) 0 r) i Hi). }
  rewrite Happ.
  rewrite (If_i_1 (0 :e i) 0 r H0i).
  reflexivity.
Qed.

(** from §19: coordinate inclusion map into R^omega **)
(** LATEX VERSION: Define the inclusion r -> (r,0,0,...) as a function from R into the product space. **)
(** Helper: map r in R to the singleton sequence **)
Definition Romega_singleton_map : set := graph R Romega_singleton_seq.

(** Helper: apply_fun for Romega_singleton_map **)
Theorem Romega_singleton_map_apply : forall r:set,
  r :e R -> apply_fun Romega_singleton_map r = Romega_singleton_seq r.
let r. assume Hr: r :e R.
prove apply_fun Romega_singleton_map r = Romega_singleton_seq r.
claim Hdef: Romega_singleton_map = graph R Romega_singleton_seq.
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph R Romega_singleton_seq r Hr).
Qed.

(** Helper: singleton map is a function into the ambient product space **)
Theorem Romega_singleton_map_function_on :
  function_on Romega_singleton_map R R_omega_space.
prove function_on Romega_singleton_map R R_omega_space.
let r. assume Hr: r :e R.
prove apply_fun Romega_singleton_map r :e R_omega_space.
rewrite (Romega_singleton_map_apply r Hr).
exact (Romega_singleton_seq_in_Romega_space r Hr).
Qed.

(** Helper: singleton map is continuous into the product topology on R_omega_space **)
(** LATEX VERSION: The coordinate-inclusion map r ↦ (r,0,0,...) is continuous in the product topology. **)
Theorem Romega_singleton_map_continuous_prod :
  continuous_map R R_standard_topology R_omega_space R_omega_product_topology Romega_singleton_map.
prove continuous_map R R_standard_topology R_omega_space R_omega_product_topology Romega_singleton_map.
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on Romega_singleton_map R R_omega_space.
{ exact Romega_singleton_map_function_on. }
claim Hone: omega <> Empty.
{ claim H0o: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  exact (elem_implies_nonempty omega 0 H0o). }
claim Hcomp: forall i:set, i :e omega -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume Hi: i :e omega.
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hset: space_family_set Xi i = R.
  { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_0_eq R R_standard_topology). }
  claim Htop: space_family_topology Xi i = R_standard_topology.
  { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  rewrite Hset.
  rewrite Htop.
  exact R_standard_topology_is_topology. }
claim HS: subbasis_on R_omega_space S.
{ prove S c= Power R_omega_space /\ Union S = R_omega_space.
  apply andI.
  - let s. assume Hs: s :e S.
    prove s :e Power R_omega_space.
    apply PowerI.
    let f. assume Hf: f :e s.
    prove f :e R_omega_space.
    set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
    claim HsF: s :e (\/_ i :e omega, F i).
    { exact Hs. }
    apply (famunionE_impred omega F s HsF (f :e R_omega_space)).
    let i. assume Hi: i :e omega.
    assume HsFi: s :e F i.
    apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                        (f :e R_omega_space)).
    let U.
    assume HU: U :e space_family_topology Xi i.
    assume Hseq: s = product_cylinder omega Xi i U.
    claim HfCyl: f :e product_cylinder omega Xi i U.
    { rewrite <- Hseq.
      exact Hf. }
    claim Hfprod: f :e product_space omega Xi.
    { exact (SepE1 (product_space omega Xi)
                   (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                   f
                   HfCyl). }
    exact Hfprod.
  - (** Union S = R_omega_space **)
    apply set_ext.
    - let f. assume Hf: f :e Union S.
      prove f :e R_omega_space.
      claim HSsubPow: S c= Power R_omega_space.
      { let s. assume Hs: s :e S.
        prove s :e Power R_omega_space.
        apply PowerI.
        let g. assume Hg: g :e s.
        prove g :e R_omega_space.
        set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
        claim HsF: s :e (\/_ i :e omega, F i).
        { exact Hs. }
        apply (famunionE_impred omega F s HsF (g :e R_omega_space)).
        let i. assume Hi: i :e omega.
        assume HsFi: s :e F i.
        apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                            (g :e R_omega_space)).
        let U.
        assume HU: U :e space_family_topology Xi i.
        assume Hseq: s = product_cylinder omega Xi i U.
        claim HgCyl: g :e product_cylinder omega Xi i U.
        { rewrite <- Hseq.
          exact Hg. }
        exact (SepE1 (product_space omega Xi)
                     (fun h:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun h i :e U)
                     g
                     HgCyl). }
      apply (UnionE_impred S f Hf).
      let s. assume Hfs: f :e s. assume Hs: s :e S.
      claim HsPow: s :e Power R_omega_space.
      { exact (HSsubPow s Hs). }
      claim HsSub: s c= R_omega_space.
      { exact (PowerE R_omega_space s HsPow). }
      exact (HsSub f Hfs).
    - let f. assume Hf: f :e R_omega_space.
      prove f :e Union S.
      claim H0o: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      claim HXi0: apply_fun Xi 0 = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology 0 H0o). }
      claim Htop0: space_family_topology Xi 0 = R_standard_topology.
      { claim Hdef: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi0.
        exact (tuple_2_1_eq R R_standard_topology). }
      claim HRin: R :e space_family_topology Xi 0.
      { rewrite Htop0.
        exact (topology_has_X R R_standard_topology R_standard_topology_is_topology). }
      set s0 := product_cylinder omega Xi 0 R.
      claim Hs0S: s0 :e S.
      { set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
        claim Hs0F0: s0 :e F 0.
        { exact (ReplI (space_family_topology Xi 0) (fun U0:set => product_cylinder omega Xi 0 U0) R HRin). }
        exact (famunionI omega F 0 s0 H0o Hs0F0). }
      claim Hf0R: apply_fun f 0 :e R.
      { exact (Romega_coord_in_R f 0 Hf H0o). }
      claim HXdef: R_omega_space = product_space omega Xi.
      { reflexivity. }
      claim Hfprod: f :e product_space omega Xi.
      { rewrite <- HXdef.
        exact Hf. }
      claim Hfs0: f :e s0.
      { claim Hs0def: s0 = product_cylinder omega Xi 0 R.
        { reflexivity. }
        rewrite Hs0def.
        claim Hcyl_def: product_cylinder omega Xi 0 R =
          {g :e product_space omega Xi | 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R}.
        { reflexivity. }
        rewrite Hcyl_def.
        apply (SepI (product_space omega Xi)
                    (fun g:set => 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R)
                    f
                    Hfprod).
        apply andI.
        - apply andI.
          + exact H0o.
          + exact HRin.
        - exact Hf0R. }
      exact (UnionI S f s0 Hfs0 Hs0S).
}
claim Hpre: forall s:set, s :e S -> preimage_of R Romega_singleton_map s :e R_standard_topology.
{ let s. assume Hs: s :e S.
  set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
  claim HsF: s :e (\/_ i :e omega, F i).
  { exact Hs. }
  apply (famunionE_impred omega F s HsF (preimage_of R Romega_singleton_map s :e R_standard_topology)).
  let i. assume Hi: i :e omega.
  assume HsFi: s :e F i.
  apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                      (preimage_of R Romega_singleton_map s :e R_standard_topology)).
  let U. assume HUtop: U :e space_family_topology Xi i.
  assume Hseq: s = product_cylinder omega Xi i U.
  rewrite Hseq.
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Htopi: space_family_topology Xi i = R_standard_topology.
  { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  claim HUstd: U :e R_standard_topology.
  { rewrite <- Htopi.
    exact HUtop. }
  claim HUsubR: U c= R.
  { claim HtopSub: R_standard_topology c= Power R.
    { exact (topology_subset_axiom R R_standard_topology R_standard_topology_is_topology). }
    claim HUpow: U :e Power R.
    { exact (HtopSub U HUstd). }
    exact (PowerE R U HUpow). }
  apply (xm (0 :e i)).
  + assume H0i: 0 :e i.
    apply (xm (0 :e U)).
    - assume H0U: 0 :e U.
      claim Heq: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) = R.
      { apply set_ext.
        - let r. assume Hrpre: r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
          prove r :e R.
          claim Hrpre2: r :e {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
          { claim Hpre_def: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) =
              {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
            { reflexivity. }
            rewrite <- Hpre_def.
            exact Hrpre. }
          exact (SepE1 R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r Hrpre2).
        - let r. assume HrR: r :e R.
          prove r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
          claim Hpre_def: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) =
            {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r HrR).
          prove apply_fun Romega_singleton_map r :e product_cylinder omega Xi i U.
          claim Happmap: apply_fun Romega_singleton_map r = Romega_singleton_seq r.
          { exact (Romega_singleton_map_apply r HrR). }
          rewrite Happmap.
          claim HXdef: R_omega_space = product_space omega Xi.
          { reflexivity. }
          claim Hrseq: Romega_singleton_seq r :e product_space omega Xi.
          { rewrite <- HXdef.
            exact (Romega_singleton_seq_in_Romega_space r HrR). }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          rewrite Hcyl_def.
          apply (SepI (product_space omega Xi)
                      (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                      (Romega_singleton_seq r)
                      Hrseq).
          apply andI.
          + apply andI.
            * exact Hi.
            * exact HUtop.
          + claim Happi: apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
            { exact (Romega_singleton_seq_apply r i HrR Hi). }
            rewrite Happi.
            rewrite (If_i_1 (0 :e i) 0 r H0i).
            exact H0U. }
      rewrite Heq.
      exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
    - assume Hn0U: ~(0 :e U).
      claim Heq: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) = Empty.
      { apply set_ext.
        - let r. assume Hrpre: r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
          prove r :e Empty.
          apply FalseE.
          claim Hrpre2: r :e {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
          { claim Hpre_def: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) =
              {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
            { reflexivity. }
            rewrite <- Hpre_def.
            exact Hrpre. }
          claim HrR: r :e R.
          { exact (SepE1 R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r Hrpre2). }
          claim Hcond: apply_fun Romega_singleton_map r :e product_cylinder omega Xi i U.
          { exact (SepE2 R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r Hrpre2). }
          claim Happmap: apply_fun Romega_singleton_map r = Romega_singleton_seq r.
          { exact (Romega_singleton_map_apply r HrR). }
          claim Hcond2: Romega_singleton_seq r :e product_cylinder omega Xi i U.
          { rewrite <- Happmap.
            exact Hcond. }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          claim Hcond3: Romega_singleton_seq r :e
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { rewrite <- Hcyl_def.
            exact Hcond2. }
          claim Hprop: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (Romega_singleton_seq r) i :e U.
          { exact (SepE2 (product_space omega Xi)
                         (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                         (Romega_singleton_seq r)
                         Hcond3). }
          claim Hri: apply_fun (Romega_singleton_seq r) i :e U.
          { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                         (apply_fun (Romega_singleton_seq r) i :e U)
                         Hprop). }
          claim Happi: apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
          { exact (Romega_singleton_seq_apply r i HrR Hi). }
          claim HriIf: If_i (0 :e i) 0 r :e U.
          { rewrite <- Happi.
            exact Hri. }
          claim Hif1: If_i (0 :e i) 0 r = 0.
          { exact (If_i_1 (0 :e i) 0 r H0i). }
          claim H0U: 0 :e U.
          { rewrite <- Hif1.
            exact HriIf. }
          exact (Hn0U H0U).
        - let r. assume HrE: r :e Empty.
          prove r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
          apply FalseE.
          exact (EmptyE r HrE). }
      rewrite Heq.
      exact (topology_has_empty R R_standard_topology R_standard_topology_is_topology).
  + assume Hn0i: ~(0 :e i).
    claim Heq: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) = U.
    { apply set_ext.
      - let r. assume Hrpre: r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
        prove r :e U.
        claim Hrpre2: r :e {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
        { claim Hpre_def: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) =
            {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
          { reflexivity. }
          rewrite <- Hpre_def.
          exact Hrpre. }
        claim HrR: r :e R.
        { exact (SepE1 R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r Hrpre2). }
        claim Hcond: apply_fun Romega_singleton_map r :e product_cylinder omega Xi i U.
        { exact (SepE2 R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r Hrpre2). }
        claim Happmap: apply_fun Romega_singleton_map r = Romega_singleton_seq r.
        { exact (Romega_singleton_map_apply r HrR). }
        claim Hcond2: Romega_singleton_seq r :e product_cylinder omega Xi i U.
        { rewrite <- Happmap.
          exact Hcond. }
        claim Hcyl_def: product_cylinder omega Xi i U =
          {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
        { reflexivity. }
        claim Hcond3: Romega_singleton_seq r :e
          {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
        { rewrite <- Hcyl_def.
          exact Hcond2. }
        claim Hprop: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (Romega_singleton_seq r) i :e U.
        { exact (SepE2 (product_space omega Xi)
                       (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                       (Romega_singleton_seq r)
                       Hcond3). }
        claim Hri: apply_fun (Romega_singleton_seq r) i :e U.
        { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                       (apply_fun (Romega_singleton_seq r) i :e U)
                       Hprop). }
        claim Happi: apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
        { exact (Romega_singleton_seq_apply r i HrR Hi). }
        claim HriIf: If_i (0 :e i) 0 r :e U.
        { rewrite <- Happi.
          exact Hri. }
        claim Hif0: If_i (0 :e i) 0 r = r.
        { exact (If_i_0 (0 :e i) 0 r Hn0i). }
        rewrite <- Hif0.
        exact HriIf.
      - let r. assume HrU: r :e U.
        prove r :e preimage_of R Romega_singleton_map (product_cylinder omega Xi i U).
        claim HrR: r :e R.
        { exact (HUsubR r HrU). }
        claim Hpre_def: preimage_of R Romega_singleton_map (product_cylinder omega Xi i U) =
          {x0 :e R | apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U}.
        { reflexivity. }
        rewrite Hpre_def.
        apply (SepI R (fun x0:set => apply_fun Romega_singleton_map x0 :e product_cylinder omega Xi i U) r HrR).
        prove apply_fun Romega_singleton_map r :e product_cylinder omega Xi i U.
        claim Happmap: apply_fun Romega_singleton_map r = Romega_singleton_seq r.
        { exact (Romega_singleton_map_apply r HrR). }
        rewrite Happmap.
        claim HXdef: R_omega_space = product_space omega Xi.
        { reflexivity. }
        claim Hrseq: Romega_singleton_seq r :e product_space omega Xi.
        { rewrite <- HXdef.
          exact (Romega_singleton_seq_in_Romega_space r HrR). }
        claim Hcyl_def: product_cylinder omega Xi i U =
          {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
        { reflexivity. }
        rewrite Hcyl_def.
        apply (SepI (product_space omega Xi)
                    (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                    (Romega_singleton_seq r)
                    Hrseq).
        apply andI.
        + apply andI.
          * exact Hi.
          * exact HUtop.
        + claim Happi: apply_fun (Romega_singleton_seq r) i = If_i (0 :e i) 0 r.
          { exact (Romega_singleton_seq_apply r i HrR Hi). }
          rewrite Happi.
          rewrite (If_i_0 (0 :e i) 0 r Hn0i).
          exact HrU. }
    rewrite Heq.
    exact HUstd. }
claim HdefTy: R_omega_product_topology = generated_topology_from_subbasis R_omega_space S.
{ reflexivity. }
rewrite HdefTy.
exact (continuous_map_from_subbasis R R_standard_topology R_omega_space S Romega_singleton_map
        HtopR Hfun HS Hpre).
Qed.

(** Helper: image of the singleton map lies in Romega_tilde 0 **)
Theorem image_of_Romega_singleton_map_sub_Romega_tilde0 :
  image_of Romega_singleton_map R c= Romega_tilde 0.
let f. assume Hf: f :e image_of Romega_singleton_map R.
prove f :e Romega_tilde 0.
apply (ReplE_impred R (fun r0:set => apply_fun Romega_singleton_map r0) f Hf (f :e Romega_tilde 0)).
let r. assume Hr: r :e R. assume Hfeq: f = apply_fun Romega_singleton_map r.
rewrite Hfeq.
rewrite (Romega_singleton_map_apply r Hr).
exact (Romega_singleton_seq_in_Romega_tilde0 r Hr).
Qed.

(** Helper: extend an element of Romega_tilde k with one more real coordinate at ordsucc k **)
(** LATEX VERSION: Build an element of R^∞ by extending a sequence that is 0 past stage k with one more coordinate at k+1, keeping all later coordinates 0. **)
Definition Romega_extend_seq : set -> set -> set := fun k p =>
  graph omega (fun i:set =>
    If_i (ordsucc k :e i) 0
      (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i))).

(** Helper: coordinate evaluation for Romega_extend_seq **)
Theorem Romega_extend_seq_apply : forall k p i:set,
  i :e omega ->
  apply_fun (Romega_extend_seq k p) i
    = If_i (ordsucc k :e i) 0
        (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
let k p i.
assume Hi: i :e omega.
prove apply_fun (Romega_extend_seq k p) i
    = If_i (ordsucc k :e i) 0
        (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
claim Hdef: Romega_extend_seq k p =
  graph omega (fun j:set => If_i (ordsucc k :e j) 0 (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph omega
       (fun j:set => If_i (ordsucc k :e j) 0 (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j)))
       i Hi).
Qed.

(** Helper: extension lands in Romega_tilde (ordsucc k) **)
Theorem Romega_extend_seq_in_Romega_tilde_succ : forall k p:set,
  k :e omega ->
  p :e setprod (Romega_tilde k) R ->
  Romega_extend_seq k p :e Romega_tilde (ordsucc k).
let k p.
assume HkO: k :e omega.
assume Hp: p :e setprod (Romega_tilde k) R.
prove Romega_extend_seq k p :e Romega_tilde (ordsucc k).
set h := (fun i:set =>
    If_i (ordsucc k :e i) 0
      (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i))).
claim Hdef: Romega_extend_seq k p = graph omega h.
{ reflexivity. }
rewrite Hdef.
claim HdefT: Romega_tilde (ordsucc k) =
  {f :e R_omega_space | forall i:set, i :e omega -> ordsucc k :e i -> apply_fun f i = 0}.
{ reflexivity. }
rewrite HdefT.
apply (SepI R_omega_space (fun f0:set => forall i:set, i :e omega -> ordsucc k :e i -> apply_fun f0 i = 0)).
- (** graph omega h is in the ambient product space **)
  apply (graph_omega_in_Romega_space h).
  let i. assume Hi: i :e omega.
  prove h i :e R.
  claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
  { reflexivity. }
  rewrite Hhi.
  apply (xm (ordsucc k :e i)).
  + assume Hki: ordsucc k :e i.
    rewrite (If_i_1 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) Hki).
    exact real_0.
  + assume Hnki: ~(ordsucc k :e i).
    rewrite (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) Hnki).
    apply (xm (i = ordsucc k)).
    * assume Hieq.
      rewrite (If_i_1 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hieq).
      (** second coordinate of p lies in R **)
      claim Hp1: p 1 :e R.
      { claim Hp1raw: p 1 :e (fun _ : set => R) (p 0).
        { exact (ap1_Sigma (Romega_tilde k) (fun _ : set => R) p Hp). }
        exact Hp1raw. }
      exact Hp1.
    * assume Hineq.
      rewrite (If_i_0 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hineq).
      (** first coordinate of p lies in Romega_tilde k, hence in R_omega_space **)
      claim Hp0: p 0 :e Romega_tilde k.
      { exact (ap0_Sigma (Romega_tilde k) (fun _ : set => R) p Hp). }
      claim Hp0X: p 0 :e R_omega_space.
      { exact (Romega_tilde_sub_Romega k (p 0) Hp0). }
      exact (Romega_coord_in_R (p 0) i Hp0X Hi).
- (** verify the defining property of Romega_tilde (ordsucc k) **)
  let i. assume Hi: i :e omega.
  assume Hki: ordsucc k :e i.
  prove apply_fun (graph omega h) i = 0.
  claim Happ: apply_fun (graph omega h) i = h i.
  { exact (apply_fun_graph omega h i Hi). }
  rewrite Happ.
  claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
  { reflexivity. }
  rewrite Hhi.
  rewrite (If_i_1 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) Hki).
  reflexivity.
Qed.

(** Helper: map extending Romega_tilde k by one coordinate **)
(** LATEX VERSION: The extension map takes (f,r) with f ∈ R~(k) and r ∈ R and returns the extended sequence in R~(k+1). **)
Definition Romega_extend_map : set -> set := fun k =>
  graph (setprod (Romega_tilde k) R) (fun p:set => Romega_extend_seq k p).

(** Helper: apply_fun for Romega_extend_map **)
Theorem Romega_extend_map_apply : forall k p:set,
  k :e omega ->
  p :e setprod (Romega_tilde k) R ->
  apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
let k p.
assume HkO: k :e omega.
assume Hp: p :e setprod (Romega_tilde k) R.
prove apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
claim Hdef: Romega_extend_map k = graph (setprod (Romega_tilde k) R) (fun q:set => Romega_extend_seq k q).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph (setprod (Romega_tilde k) R) (fun q:set => Romega_extend_seq k q) p Hp).
Qed.

(** Helper: extension map is a function into the ambient product space **)
Theorem Romega_extend_map_function_on : forall k:set,
  k :e omega ->
  function_on (Romega_extend_map k) (setprod (Romega_tilde k) R) R_omega_space.
let k. assume HkO: k :e omega.
prove function_on (Romega_extend_map k) (setprod (Romega_tilde k) R) R_omega_space.
let p. assume Hp: p :e setprod (Romega_tilde k) R.
prove apply_fun (Romega_extend_map k) p :e R_omega_space.
rewrite (Romega_extend_map_apply k p HkO Hp).
claim Htilde: Romega_extend_seq k p :e Romega_tilde (ordsucc k).
{ exact (Romega_extend_seq_in_Romega_tilde_succ k p HkO Hp). }
exact (Romega_tilde_sub_Romega (ordsucc k) (Romega_extend_seq k p) Htilde).
Qed.

(** Helper: extension map is a function into Romega_tilde (ordsucc k) **)
(** LATEX VERSION: The extension map lands in R~(k+1). **)
Theorem Romega_extend_map_function_on_tilde_succ : forall k:set,
  k :e omega ->
  function_on (Romega_extend_map k) (setprod (Romega_tilde k) R) (Romega_tilde (ordsucc k)).
let k. assume HkO: k :e omega.
prove function_on (Romega_extend_map k) (setprod (Romega_tilde k) R) (Romega_tilde (ordsucc k)).
let p. assume Hp: p :e setprod (Romega_tilde k) R.
prove apply_fun (Romega_extend_map k) p :e Romega_tilde (ordsucc k).
rewrite (Romega_extend_map_apply k p HkO Hp).
exact (Romega_extend_seq_in_Romega_tilde_succ k p HkO Hp).
Qed.

(** Helper: image of the extension map lies in Romega_tilde (ordsucc k) **)
Theorem image_of_Romega_extend_map_sub_Romega_tilde_succ : forall k:set,
  k :e omega ->
  image_of (Romega_extend_map k) (setprod (Romega_tilde k) R) c= Romega_tilde (ordsucc k).
let k. assume HkO: k :e omega.
let f. assume Hf: f :e image_of (Romega_extend_map k) (setprod (Romega_tilde k) R).
prove f :e Romega_tilde (ordsucc k).
apply (ReplE_impred (setprod (Romega_tilde k) R) (fun p0:set => apply_fun (Romega_extend_map k) p0) f Hf
       (f :e Romega_tilde (ordsucc k))).
let p. assume Hp: p :e setprod (Romega_tilde k) R.
assume Hfeq: f = apply_fun (Romega_extend_map k) p.
rewrite Hfeq.
rewrite (Romega_extend_map_apply k p HkO Hp).
exact (Romega_extend_seq_in_Romega_tilde_succ k p HkO Hp).
Qed.

(** Helper: extension map is continuous into the ambient product topology on R^omega **)
(** LATEX VERSION: The extension map is continuous for the product topology on R^omega. **)
Theorem Romega_extend_map_continuous_in_Romega_product : forall k:set,
  k :e omega ->
  continuous_map
    (setprod (Romega_tilde k) R)
    (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                      R R_standard_topology)
    R_omega_space
    R_omega_product_topology
    (Romega_extend_map k).
let k.
assume HkO: k :e omega.
set Dom := setprod (Romega_tilde k) R.
set Tx0 := subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k).
set Tdom := product_topology (Romega_tilde k) Tx0 R R_standard_topology.
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.

claim HtopRomega: topology_on R_omega_space R_omega_product_topology.
{ exact Romega_product_topology_is_topology. }
claim HtopTildek: topology_on (Romega_tilde k) Tx0.
{ exact (subspace_topology_is_topology R_omega_space R_omega_product_topology (Romega_tilde k)
         HtopRomega
         (Romega_tilde_sub_Romega k)). }
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology. }
claim HtopDom: topology_on Dom Tdom.
{ exact (product_topology_is_topology (Romega_tilde k) Tx0 R R_standard_topology HtopTildek HtopR). }
claim Hfun: function_on (Romega_extend_map k) Dom R_omega_space.
{ exact (Romega_extend_map_function_on k HkO). }

(** Prove the product-cylinder subbasis is a subbasis on R_omega_space. **)
claim Hone: omega <> Empty.
{ claim H0o: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  exact (elem_implies_nonempty omega 0 H0o). }
claim Hcomp: forall i:set, i :e omega -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume Hi: i :e omega.
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hset: space_family_set Xi i = R.
  { claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_0_eq R R_standard_topology). }
  claim Htop: space_family_topology Xi i = R_standard_topology.
  { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
    { reflexivity. }
    rewrite Hdef.
    rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  rewrite Hset.
  rewrite Htop.
  exact R_standard_topology_is_topology. }
claim HS: subbasis_on R_omega_space S.
{ claim HSsubPow: S c= Power R_omega_space.
  { let s. assume Hs: s :e S.
    prove s :e Power R_omega_space.
    apply PowerI.
    let f. assume Hf: f :e s.
    prove f :e R_omega_space.
    set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
    claim HsF: s :e (\/_ i :e omega, F i).
    { exact Hs. }
    apply (famunionE_impred omega F s HsF (f :e R_omega_space)).
    let i. assume Hi: i :e omega.
    assume HsFi: s :e F i.
    apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                        (f :e R_omega_space)).
    let U.
    assume HU: U :e space_family_topology Xi i.
    assume Hseq: s = product_cylinder omega Xi i U.
    claim HfCyl: f :e product_cylinder omega Xi i U.
    { rewrite <- Hseq. exact Hf. }
    claim Hfprod: f :e product_space omega Xi.
    { exact (SepE1 (product_space omega Xi)
                   (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                   f
                   HfCyl). }
    exact Hfprod. }

  claim HSUnion: Union S = R_omega_space.
  { apply set_ext.
    - let f. assume HfU: f :e Union S.
      prove f :e R_omega_space.
      apply (UnionE_impred S f HfU).
      let s. assume Hfs: f :e s. assume HsS: s :e S.
      claim HsPow: s :e Power R_omega_space.
      { exact (HSsubPow s HsS). }
      exact (PowerE R_omega_space s HsPow f Hfs).
    - let f. assume HfX: f :e R_omega_space.
      prove f :e Union S.
      (** Use cylinder at coordinate 0 with U = R. **)
      set s0 := product_cylinder omega Xi 0 R.
      claim H0o: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      claim HRin: R :e space_family_topology Xi 0.
      { claim HXi0: apply_fun Xi 0 = (R, R_standard_topology).
        { exact (const_space_family_apply omega R R_standard_topology 0 H0o). }
        claim Htop0: space_family_topology Xi 0 = R_standard_topology.
        { claim Hdef: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
          { reflexivity. }
          rewrite Hdef.
          rewrite HXi0.
          exact (tuple_2_1_eq R R_standard_topology). }
        rewrite Htop0.
        exact (topology_has_X R R_standard_topology R_standard_topology_is_topology). }
      claim Hf0R: apply_fun f 0 :e R.
      { exact (Romega_coord_in_R f 0 HfX H0o). }
      claim HXdef: R_omega_space = product_space omega Xi.
      { reflexivity. }
      claim Hfprod: f :e product_space omega Xi.
      { rewrite <- HXdef. exact HfX. }
      claim Hfs0: f :e s0.
      { claim Hcyl_def: s0 =
          {g :e product_space omega Xi | 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R}.
        { reflexivity. }
        rewrite Hcyl_def.
        apply (SepI (product_space omega Xi)
                    (fun g:set => 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R)
                    f
                    Hfprod).
        apply andI.
        - apply andI.
          + exact H0o.
          + exact HRin.
        - exact Hf0R. }
      claim Hs0In: s0 :e {product_cylinder omega Xi 0 U0|U0 :e space_family_topology Xi 0}.
      { exact (ReplI (space_family_topology Xi 0) (fun U0:set => product_cylinder omega Xi 0 U0) R HRin). }
      claim Hs0S: s0 :e S.
      { exact (famunionI omega (fun j:set => {product_cylinder omega Xi j U0|U0 :e space_family_topology Xi j})
                         0 s0 H0o Hs0In). }
      exact (UnionI S f s0 Hfs0 Hs0S). }

  exact (andI (S c= Power R_omega_space) (Union S = R_omega_space) HSsubPow HSUnion).
}

(** Preimages of subbasis cylinders are open in the domain product topology. **)
claim Hpre: forall s:set, s :e S -> preimage_of Dom (Romega_extend_map k) s :e Tdom.
{ let s. assume Hs: s :e S.
  set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
  claim HsF: s :e (\/_ i :e omega, F i).
  { exact Hs. }
  apply (famunionE_impred omega F s HsF (preimage_of Dom (Romega_extend_map k) s :e Tdom)).
  let i. assume Hi: i :e omega.
  assume HsFi: s :e F i.
  apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                      (preimage_of Dom (Romega_extend_map k) s :e Tdom)).
  let U. assume HUtop: U :e space_family_topology Xi i.
  assume Hseq: s = product_cylinder omega Xi i U.
  rewrite Hseq.
  claim HXi: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Htopi: space_family_topology Xi i = R_standard_topology.
  { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
    { reflexivity. }
    rewrite Hdef. rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  claim HUstd: U :e R_standard_topology.
  { rewrite <- Htopi. exact HUtop. }
  claim HUsubR: U c= R.
  { claim HtopSub: R_standard_topology c= Power R.
    { exact (topology_subset_axiom R R_standard_topology R_standard_topology_is_topology). }
    claim HUpow: U :e Power R.
    { exact (HtopSub U HUstd). }
    exact (PowerE R U HUpow). }

  apply (xm (ordsucc k :e i)).
  - assume HkLt: ordsucc k :e i.
    apply (xm (0 :e U)).
    + assume H0U: 0 :e U.
      claim Heq: preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U) = Dom.
      { apply set_ext.
        - let p. assume HpPre: p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          prove p :e Dom.
          exact (SepE1 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpPre).
        - let p. assume Hp: p :e Dom.
          prove p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          claim Hpre_def: preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U) =
            {p0 :e Dom | apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p Hp).
          (** show the image lies in the cylinder: coordinate i is 0 since ordsucc k :e i **)
          claim Himg: apply_fun (Romega_extend_map k) p :e R_omega_space.
          { exact (Romega_extend_map_function_on k HkO p Hp). }
          claim HXdef: R_omega_space = product_space omega Xi.
          { reflexivity. }
          claim HimgProd: apply_fun (Romega_extend_map k) p :e product_space omega Xi.
          { rewrite <- HXdef. exact Himg. }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          rewrite Hcyl_def.
          apply (SepI (product_space omega Xi)
                      (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                      (apply_fun (Romega_extend_map k) p)
                      HimgProd).
          apply andI.
          + apply andI.
            * exact Hi.
            * exact HUtop.
          + (** compute coordinate i **)
            claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
            { rewrite (Romega_extend_map_apply k p HkO Hp). reflexivity. }
            rewrite Happmap.
            set h := (fun j:set =>
              If_i (ordsucc k :e j) 0
                (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
            claim HdefSeq: Romega_extend_seq k p = graph omega h.
            { reflexivity. }
            rewrite HdefSeq.
            claim Happi: apply_fun (graph omega h) i = h i.
            { exact (apply_fun_graph omega h i Hi). }
            rewrite Happi.
            claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
            { reflexivity. }
            rewrite Hhi.
            rewrite (If_i_1 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HkLt).
            exact H0U. }
      rewrite Heq.
      exact (topology_has_X Dom Tdom HtopDom).
    + assume Hn0U: ~(0 :e U).
      claim Heq: preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U) = Empty.
      { apply set_ext.
        - let p. assume HpPre: p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          prove p :e Empty.
          claim HpDom: p :e Dom.
          { exact (SepE1 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpPre). }
          claim Hcond: apply_fun (Romega_extend_map k) p :e product_cylinder omega Xi i U.
          { exact (SepE2 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpPre). }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          claim Hcond2: apply_fun (Romega_extend_map k) p :e
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { rewrite <- Hcyl_def. exact Hcond. }
          claim Hprop: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (SepE2 (product_space omega Xi)
                         (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                         (apply_fun (Romega_extend_map k) p)
                         Hcond2). }
          claim HUi: apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                         (apply_fun (apply_fun (Romega_extend_map k) p) i :e U)
                         Hprop). }
          claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
          { rewrite (Romega_extend_map_apply k p HkO HpDom). reflexivity. }
          claim HUiSeq: apply_fun (Romega_extend_seq k p) i :e U.
          { rewrite <- Happmap. exact HUi. }
          set h := (fun j:set =>
            If_i (ordsucc k :e j) 0
              (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
          claim HdefSeq: Romega_extend_seq k p = graph omega h.
          { reflexivity. }
          claim HUiGraph: apply_fun (graph omega h) i :e U.
          { rewrite <- HdefSeq. exact HUiSeq. }
          claim Happi: apply_fun (graph omega h) i = h i.
          { exact (apply_fun_graph omega h i Hi). }
          claim HH: h i :e U.
          { rewrite <- Happi. exact HUiGraph. }
          claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
          { reflexivity. }
          claim H0inU: 0 :e U.
          { rewrite <- (If_i_1 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HkLt).
            rewrite <- Hhi.
            exact HH. }
          apply FalseE.
          exact (Hn0U H0inU).
        - let p. assume Hp: p :e Empty.
          prove p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          apply FalseE.
          exact (EmptyE p Hp). }
      rewrite Heq.
      exact (topology_has_empty Dom Tdom HtopDom).

  - assume HnKlt: ~(ordsucc k :e i).
    apply (xm (i = ordsucc k)).
    + assume Hieq: i = ordsucc k.
      (** Reduce to continuity of projection2 and preimage of U. **)
      claim Hproj2Cont:
        continuous_map Dom Tdom R R_standard_topology (projection2 (Romega_tilde k) R).
      { exact (projection2_continuous_in_product (Romega_tilde k) Tx0 R R_standard_topology HtopTildek HtopR). }
      claim HpreProj: preimage_of Dom (projection2 (Romega_tilde k) R) U :e Tdom.
      { exact (continuous_map_preimage Dom Tdom R R_standard_topology (projection2 (Romega_tilde k) R) Hproj2Cont U HUstd). }
      claim Heq: preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U) =
        preimage_of Dom (projection2 (Romega_tilde k) R) U.
      { apply set_ext.
        - let p. assume HpPre: p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          prove p :e preimage_of Dom (projection2 (Romega_tilde k) R) U.
          claim HpDom: p :e Dom.
          { exact (SepE1 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpPre). }
          claim Hcond: apply_fun (Romega_extend_map k) p :e product_cylinder omega Xi i U.
          { exact (SepE2 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpPre). }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          claim Hcond2: apply_fun (Romega_extend_map k) p :e
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { rewrite <- Hcyl_def. exact Hcond. }
          claim Hprop: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (SepE2 (product_space omega Xi)
                         (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                         (apply_fun (Romega_extend_map k) p)
                         Hcond2). }
          claim HUi: apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                         (apply_fun (apply_fun (Romega_extend_map k) p) i :e U)
                         Hprop). }
          claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
          { rewrite (Romega_extend_map_apply k p HkO HpDom). reflexivity. }
          claim HUiSeq: apply_fun (Romega_extend_seq k p) i :e U.
          { rewrite <- Happmap. exact HUi. }
          set h := (fun j:set =>
            If_i (ordsucc k :e j) 0
              (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
          claim HdefSeq: Romega_extend_seq k p = graph omega h.
          { reflexivity. }
          claim HUiGraph: apply_fun (graph omega h) i :e U.
          { rewrite <- HdefSeq. exact HUiSeq. }
          claim Happi: apply_fun (graph omega h) i = h i.
          { exact (apply_fun_graph omega h i Hi). }
          claim HH: h i :e U.
          { rewrite <- Happi. exact HUiGraph. }
          claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
          { reflexivity. }
          claim Hp1U: p 1 :e U.
          { claim Hexpr: If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) :e U.
            { rewrite <- Hhi. exact HH. }
            claim Hexpr2: If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i) :e U.
            { rewrite <- (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HnKlt).
              exact Hexpr. }
            rewrite <- (If_i_1 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hieq).
            exact Hexpr2. }
          claim Hpre_def: preimage_of Dom (projection2 (Romega_tilde k) R) U =
            {p0 :e Dom | apply_fun (projection2 (Romega_tilde k) R) p0 :e U}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI Dom (fun p0:set => apply_fun (projection2 (Romega_tilde k) R) p0 :e U) p HpDom).
          claim Happ2: apply_fun (projection2 (Romega_tilde k) R) p = p 1.
          { exact (projection2_apply (Romega_tilde k) R p HpDom). }
          rewrite Happ2.
          exact Hp1U.
        - let p. assume HpPre: p :e preimage_of Dom (projection2 (Romega_tilde k) R) U.
          prove p :e preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U).
          claim HpDom: p :e Dom.
          { exact (SepE1 Dom (fun p0:set => apply_fun (projection2 (Romega_tilde k) R) p0 :e U) p HpPre). }
          claim HpU: apply_fun (projection2 (Romega_tilde k) R) p :e U.
          { exact (SepE2 Dom (fun p0:set => apply_fun (projection2 (Romega_tilde k) R) p0 :e U) p HpPre). }
          claim Happ2: apply_fun (projection2 (Romega_tilde k) R) p = p 1.
          { exact (projection2_apply (Romega_tilde k) R p HpDom). }
          claim Hp1U: p 1 :e U.
          { rewrite <- Happ2. exact HpU. }
          claim Hpre_def: preimage_of Dom (Romega_extend_map k) (product_cylinder omega Xi i U) =
            {p0 :e Dom | apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e product_cylinder omega Xi i U) p HpDom).
          (** show image is in cylinder at coordinate i = ordsucc k **)
          claim Himg: apply_fun (Romega_extend_map k) p :e R_omega_space.
          { exact (Romega_extend_map_function_on k HkO p HpDom). }
          claim HXdef: R_omega_space = product_space omega Xi.
          { reflexivity. }
          claim HimgProd: apply_fun (Romega_extend_map k) p :e product_space omega Xi.
          { rewrite <- HXdef. exact Himg. }
          claim Hcyl_def: product_cylinder omega Xi i U =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          rewrite Hcyl_def.
          apply (SepI (product_space omega Xi)
                      (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                      (apply_fun (Romega_extend_map k) p)
                      HimgProd).
          apply andI.
          + apply andI.
            * exact Hi.
            * exact HUtop.
          + (** compute coordinate i **)
            claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
            { rewrite (Romega_extend_map_apply k p HkO HpDom). reflexivity. }
            rewrite Happmap.
            set h := (fun j:set =>
              If_i (ordsucc k :e j) 0
                (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
            claim HdefSeq: Romega_extend_seq k p = graph omega h.
            { reflexivity. }
            rewrite HdefSeq.
            claim Happi: apply_fun (graph omega h) i = h i.
            { exact (apply_fun_graph omega h i Hi). }
            rewrite Happi.
            claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
            { reflexivity. }
            rewrite Hhi.
            rewrite (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HnKlt).
            rewrite (If_i_1 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hieq).
            exact Hp1U. }
      rewrite Heq.
      exact HpreProj.

    + assume Hineq: ~(i = ordsucc k).
      (** Depend only on the first coordinate: use continuity of projection1. **)
      set Cyl := product_cylinder omega Xi i U.
      claim HCylOpen: Cyl :e R_omega_product_topology.
      { claim HdefTy: R_omega_product_topology = generated_topology_from_subbasis R_omega_space S.
        { reflexivity. }
        rewrite HdefTy.
        exact (subbasis_elem_open_in_generated_from_subbasis R_omega_space S Cyl HS
              (famunionI omega (fun j:set => {product_cylinder omega Xi j U0|U0 :e space_family_topology Xi j})
                         i Cyl Hi
                         (ReplI (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) U HUtop))). }
      set A := Cyl :/\: Romega_tilde k.
      claim HAopen: A :e Tx0.
      { exact (subspace_topologyI R_omega_space R_omega_product_topology (Romega_tilde k) Cyl HCylOpen). }
      claim HAsub: A c= Romega_tilde k.
      { exact (binintersect_Subq_2 Cyl (Romega_tilde k)). }
      claim Hproj1Cont:
        continuous_map Dom Tdom (Romega_tilde k) Tx0 (projection1 (Romega_tilde k) R).
      { exact (projection1_continuous_in_product (Romega_tilde k) Tx0 R R_standard_topology HtopTildek HtopR). }
      claim HpreProj: preimage_of Dom (projection1 (Romega_tilde k) R) A :e Tdom.
      { exact (continuous_map_preimage Dom Tdom (Romega_tilde k) Tx0 (projection1 (Romega_tilde k) R) Hproj1Cont A HAopen). }
      claim Heq: preimage_of Dom (Romega_extend_map k) Cyl = preimage_of Dom (projection1 (Romega_tilde k) R) A.
      { apply set_ext.
        - let p. assume HpPre: p :e preimage_of Dom (Romega_extend_map k) Cyl.
          prove p :e preimage_of Dom (projection1 (Romega_tilde k) R) A.
          claim HpDom: p :e Dom.
          { exact (SepE1 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e Cyl) p HpPre). }
          claim Hcond: apply_fun (Romega_extend_map k) p :e Cyl.
          { exact (SepE2 Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e Cyl) p HpPre). }
          claim Hcyl_def: Cyl =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          claim Hcond2: apply_fun (Romega_extend_map k) p :e
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { rewrite <- Hcyl_def. exact Hcond. }
          claim Hprop: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (SepE2 (product_space omega Xi)
                         (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                         (apply_fun (Romega_extend_map k) p)
                         Hcond2). }
          claim HUi: apply_fun (apply_fun (Romega_extend_map k) p) i :e U.
          { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                         (apply_fun (apply_fun (Romega_extend_map k) p) i :e U)
                         Hprop). }
          claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
          { rewrite (Romega_extend_map_apply k p HkO HpDom). reflexivity. }
          claim HUiSeq: apply_fun (Romega_extend_seq k p) i :e U.
          { rewrite <- Happmap. exact HUi. }
          set h := (fun j:set =>
            If_i (ordsucc k :e j) 0
              (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
          claim HdefSeq: Romega_extend_seq k p = graph omega h.
          { reflexivity. }
          claim HUiGraph: apply_fun (graph omega h) i :e U.
          { rewrite <- HdefSeq. exact HUiSeq. }
          claim Happi: apply_fun (graph omega h) i = h i.
          { exact (apply_fun_graph omega h i Hi). }
          claim HH: h i :e U.
          { rewrite <- Happi. exact HUiGraph. }
          claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
          { reflexivity. }
          claim Hp0iU: apply_fun (p 0) i :e U.
          { rewrite <- (If_i_0 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hineq).
            rewrite <- (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HnKlt).
            rewrite <- Hhi.
            exact HH. }
          (** now HUi is (apply_fun (p 0) i) :e U, hence p 0 is in cylinder, so in A **)
          claim Hp0: apply_fun (projection1 (Romega_tilde k) R) p = p 0.
          { exact (projection1_apply (Romega_tilde k) R p HpDom). }
          claim Hp0In: p 0 :e A.
          { claim Hp0Tilde: p 0 :e Romega_tilde k.
            { exact (ap0_Sigma (Romega_tilde k) (fun _ : set => R) p HpDom). }
            claim Hp0Cyl: p 0 :e Cyl.
            { claim HXdef: R_omega_space = product_space omega Xi.
              { reflexivity. }
              claim Hp0Romega: p 0 :e R_omega_space.
              { exact (Romega_tilde_sub_Romega k (p 0) Hp0Tilde). }
              claim Hp0Prod: p 0 :e product_space omega Xi.
              { rewrite <- HXdef. exact Hp0Romega. }
              rewrite Hcyl_def.
              apply (SepI (product_space omega Xi)
                          (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                          (p 0)
                          Hp0Prod).
              apply andI.
              + apply andI.
                * exact Hi.
                * exact HUtop.
              + exact Hp0iU. }
            exact (binintersectI Cyl (Romega_tilde k) (p 0) Hp0Cyl Hp0Tilde). }
          claim Hpre_def: preimage_of Dom (projection1 (Romega_tilde k) R) A =
            {p0 :e Dom | apply_fun (projection1 (Romega_tilde k) R) p0 :e A}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI Dom (fun p0:set => apply_fun (projection1 (Romega_tilde k) R) p0 :e A) p HpDom).
          rewrite Hp0.
          exact Hp0In.
        - let p. assume HpPre: p :e preimage_of Dom (projection1 (Romega_tilde k) R) A.
          prove p :e preimage_of Dom (Romega_extend_map k) Cyl.
          claim HpDom: p :e Dom.
          { exact (SepE1 Dom (fun p0:set => apply_fun (projection1 (Romega_tilde k) R) p0 :e A) p HpPre). }
          claim HpA: apply_fun (projection1 (Romega_tilde k) R) p :e A.
          { exact (SepE2 Dom (fun p0:set => apply_fun (projection1 (Romega_tilde k) R) p0 :e A) p HpPre). }
          claim Hp0: apply_fun (projection1 (Romega_tilde k) R) p = p 0.
          { exact (projection1_apply (Romega_tilde k) R p HpDom). }
          claim Hp0A: p 0 :e A.
          { rewrite <- Hp0. exact HpA. }
          claim Hp0Cyl: p 0 :e Cyl.
          { exact (binintersectE1 Cyl (Romega_tilde k) (p 0) Hp0A). }
          claim Hcyl_def: Cyl =
            {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
          { reflexivity. }
          claim Hprop0: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (p 0) i :e U.
          { claim Hp0Cyl2: p 0 :e {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
            { rewrite <- Hcyl_def. exact Hp0Cyl. }
            exact (SepE2 (product_space omega Xi)
                         (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                         (p 0)
                         Hp0Cyl2). }
          claim HUi0: apply_fun (p 0) i :e U.
          { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                         (apply_fun (p 0) i :e U)
                         Hprop0). }
          claim Hpre_def: preimage_of Dom (Romega_extend_map k) Cyl =
            {p0 :e Dom | apply_fun (Romega_extend_map k) p0 :e Cyl}.
          { reflexivity. }
          rewrite Hpre_def.
          apply (SepI Dom (fun p0:set => apply_fun (Romega_extend_map k) p0 :e Cyl) p HpDom).
          (** show image is in cylinder **)
          claim Himg: apply_fun (Romega_extend_map k) p :e R_omega_space.
          { exact (Romega_extend_map_function_on k HkO p HpDom). }
          claim HXdef: R_omega_space = product_space omega Xi.
          { reflexivity. }
          claim HimgProd: apply_fun (Romega_extend_map k) p :e product_space omega Xi.
          { rewrite <- HXdef. exact Himg. }
          rewrite Hcyl_def.
          apply (SepI (product_space omega Xi)
                      (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                      (apply_fun (Romega_extend_map k) p)
                      HimgProd).
          apply andI.
          + apply andI.
            * exact Hi.
            * exact HUtop.
          + claim Happmap: apply_fun (Romega_extend_map k) p = Romega_extend_seq k p.
            { rewrite (Romega_extend_map_apply k p HkO HpDom). reflexivity. }
            rewrite Happmap.
            set h := (fun j:set =>
              If_i (ordsucc k :e j) 0
                (If_i (j = ordsucc k) (p 1) (apply_fun (p 0) j))).
            claim HdefSeq: Romega_extend_seq k p = graph omega h.
            { reflexivity. }
            rewrite HdefSeq.
            claim Happi: apply_fun (graph omega h) i = h i.
            { exact (apply_fun_graph omega h i Hi). }
            rewrite Happi.
            claim Hhi: h i = If_i (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)).
            { reflexivity. }
            rewrite Hhi.
            rewrite (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) HnKlt).
            rewrite (If_i_0 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hineq).
            exact HUi0. }
      rewrite Heq.
      exact HpreProj.
}

claim HdefTy: R_omega_product_topology = generated_topology_from_subbasis R_omega_space S.
{ reflexivity. }
rewrite HdefTy.
exact (continuous_map_from_subbasis Dom Tdom R_omega_space S (Romega_extend_map k)
        HtopDom Hfun HS Hpre).
Qed.

(** Helper: extension map is continuous into the subspace Romega_tilde (ordsucc k) **)
(** LATEX VERSION: The extension map is continuous into R~(k+1) with the subspace topology. **)
Theorem Romega_extend_map_continuous_to_Romega_tilde_succ : forall k:set,
  k :e omega ->
  continuous_map
    (setprod (Romega_tilde k) R)
    (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                      R R_standard_topology)
    (Romega_tilde (ordsucc k))
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
    (Romega_extend_map k).
let k.
assume HkO: k :e omega.
set Dom := setprod (Romega_tilde k) R.
claim Hcont: continuous_map Dom
  (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                    R R_standard_topology)
  R_omega_space
  R_omega_product_topology
  (Romega_extend_map k).
{ exact (Romega_extend_map_continuous_in_Romega_product k HkO). }
claim Hsub: Romega_tilde (ordsucc k) c= R_omega_space.
{ exact (Romega_tilde_sub_Romega (ordsucc k)). }
claim Himg: forall p:set, p :e Dom -> apply_fun (Romega_extend_map k) p :e Romega_tilde (ordsucc k).
{ let p. assume Hp: p :e Dom.
  rewrite (Romega_extend_map_apply k p HkO Hp).
  exact (Romega_extend_seq_in_Romega_tilde_succ k p HkO Hp). }
exact (continuous_map_range_restrict Dom
  (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                    R R_standard_topology)
  R_omega_space
  R_omega_product_topology
  (Romega_extend_map k)
  (Romega_tilde (ordsucc k))
  Hcont Hsub Himg).
Qed.

(** Helper: restrict a sequence by zeroing all coordinates beyond stage k **)
(** LATEX VERSION: From a sequence in R^omega, form the truncated sequence that is 0 for all indices i with k in i. **)
Definition Romega_restrict_seq : set -> set -> set := fun k f =>
  graph omega (fun i:set => If_i (k :e i) 0 (apply_fun f i)).

(** Helper: coordinate evaluation for Romega_restrict_seq **)
Theorem Romega_restrict_seq_apply : forall k f i:set,
  k :e omega ->
  f :e R_omega_space ->
  i :e omega ->
  apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
let k f i.
assume HkO: k :e omega.
assume Hf: f :e R_omega_space.
assume Hi: i :e omega.
prove apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
claim Hdef: Romega_restrict_seq k f = graph omega (fun j:set => If_i (k :e j) 0 (apply_fun f j)).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph omega (fun j:set => If_i (k :e j) 0 (apply_fun f j)) i Hi).
Qed.

(** Helper: restriction lands in Romega_tilde k **)
Theorem Romega_restrict_seq_in_Romega_tilde : forall k f:set,
  k :e omega ->
  f :e R_omega_space ->
  Romega_restrict_seq k f :e Romega_tilde k.
let k f.
assume HkO: k :e omega.
assume Hf: f :e R_omega_space.
prove Romega_restrict_seq k f :e Romega_tilde k.
set h := (fun i:set => If_i (k :e i) 0 (apply_fun f i)).
claim Hdef: Romega_restrict_seq k f = graph omega h.
{ reflexivity. }
rewrite Hdef.
claim HdefT: Romega_tilde k =
  {g :e R_omega_space | forall i:set, i :e omega -> k :e i -> apply_fun g i = 0}.
{ reflexivity. }
rewrite HdefT.
apply (SepI R_omega_space (fun g0:set => forall i:set, i :e omega -> k :e i -> apply_fun g0 i = 0)).
- (** graph omega h is in the ambient product space **)
  apply (graph_omega_in_Romega_space h).
  let i. assume Hi: i :e omega.
  prove h i :e R.
  claim Hhi: h i = If_i (k :e i) 0 (apply_fun f i).
  { reflexivity. }
  rewrite Hhi.
  apply (xm (k :e i)).
  + assume Hki: k :e i.
    rewrite (If_i_1 (k :e i) 0 (apply_fun f i) Hki).
    exact real_0.
  + assume Hnki: ~(k :e i).
    rewrite (If_i_0 (k :e i) 0 (apply_fun f i) Hnki).
    exact (Romega_coord_in_R f i Hf Hi).
- (** verify the defining property of Romega_tilde k **)
  let i. assume Hi: i :e omega.
  assume Hki: k :e i.
  prove apply_fun (graph omega h) i = 0.
  claim Happ: apply_fun (graph omega h) i = h i.
  { exact (apply_fun_graph omega h i Hi). }
  rewrite Happ.
  claim Hhi: h i = If_i (k :e i) 0 (apply_fun f i).
  { reflexivity. }
  rewrite Hhi.
  rewrite (If_i_1 (k :e i) 0 (apply_fun f i) Hki).
  reflexivity.
Qed.

(** Helper: coordinate projection map on R^omega **)
(** LATEX VERSION: The i-th coordinate map pi_i : R^omega -> R is continuous in the product topology. **)
Definition Romega_coord_map : set -> set := fun i =>
  graph R_omega_space (fun f:set => apply_fun f i).

(** Helper: apply_fun for Romega_coord_map **)
Theorem Romega_coord_map_apply : forall i f:set,
  i :e omega ->
  f :e R_omega_space ->
  apply_fun (Romega_coord_map i) f = apply_fun f i.
let i f.
assume Hi: i :e omega.
assume Hf: f :e R_omega_space.
prove apply_fun (Romega_coord_map i) f = apply_fun f i.
claim Hdef: Romega_coord_map i = graph R_omega_space (fun g:set => apply_fun g i).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph R_omega_space (fun g:set => apply_fun g i) f Hf).
Qed.

(** Helper: coordinate map is a function into R **)
Theorem Romega_coord_map_function_on : forall i:set,
  i :e omega ->
  function_on (Romega_coord_map i) R_omega_space R.
let i.
assume Hi: i :e omega.
prove function_on (Romega_coord_map i) R_omega_space R.
let f. assume Hf: f :e R_omega_space.
prove apply_fun (Romega_coord_map i) f :e R.
rewrite (Romega_coord_map_apply i f Hi Hf).
exact (Romega_coord_in_R f i Hf Hi).
Qed.

(** Helper: product-cylinder family is a subbasis on R^omega **)
Theorem Romega_product_subbasis_on :
  subbasis_on R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)).
prove subbasis_on R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)).
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
claim HXdef: R_omega_space = product_space omega Xi.
{ reflexivity. }
prove S c= Power R_omega_space /\ Union S = R_omega_space.
apply andI.
- (** S c= Power R_omega_space **)
  let s. assume Hs: s :e S.
  prove s :e Power R_omega_space.
  apply PowerI.
  let f. assume Hf: f :e s.
  prove f :e R_omega_space.
  set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
  claim HsF: s :e (\/_ i :e omega, F i).
  { exact Hs. }
  apply (famunionE_impred omega F s HsF (f :e R_omega_space)).
  let i. assume Hi: i :e omega.
  assume HsFi: s :e F i.
  apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                      (f :e R_omega_space)).
  let U.
  assume HUtop: U :e space_family_topology Xi i.
  assume Hseq: s = product_cylinder omega Xi i U.
  claim HfCyl: f :e product_cylinder omega Xi i U.
  { rewrite <- Hseq. exact Hf. }
  claim Hfprod: f :e product_space omega Xi.
  { exact (SepE1 (product_space omega Xi)
                 (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                 f
                 HfCyl). }
  rewrite HXdef.
  exact Hfprod.
- (** Union S = R_omega_space **)
  apply set_ext.
  * let f. assume HfU: f :e Union S.
    prove f :e R_omega_space.
    apply (UnionE_impred S f HfU (f :e R_omega_space)).
    let s. assume Hfs: f :e s. assume Hs: s :e S.
    set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
    claim HsF: s :e (\/_ i :e omega, F i).
    { exact Hs. }
    apply (famunionE_impred omega F s HsF (f :e R_omega_space)).
    let i. assume Hi: i :e omega.
    assume HsFi: s :e F i.
    apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                        (f :e R_omega_space)).
    let U.
    assume HUtop: U :e space_family_topology Xi i.
    assume Hseq: s = product_cylinder omega Xi i U.
    claim HfCyl: f :e product_cylinder omega Xi i U.
    { rewrite <- Hseq. exact Hfs. }
    claim Hfprod: f :e product_space omega Xi.
    { exact (SepE1 (product_space omega Xi)
                   (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                   f
                   HfCyl). }
    rewrite HXdef.
    exact Hfprod.
  * let f. assume HfX: f :e R_omega_space.
    prove f :e Union S.
    set s0 := product_cylinder omega Xi 0 R.
    claim H0o: 0 :e omega.
    { exact (nat_p_omega 0 nat_0). }
    claim HRin: R :e space_family_topology Xi 0.
    { claim HXi0: apply_fun Xi 0 = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology 0 H0o). }
      claim Htop0: space_family_topology Xi 0 = R_standard_topology.
      { claim Hdef: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
        { reflexivity. }
        rewrite Hdef. rewrite HXi0.
        exact (tuple_2_1_eq R R_standard_topology). }
      rewrite Htop0.
      exact (topology_has_X R R_standard_topology R_standard_topology_is_topology_local). }
    claim Hf0R: apply_fun f 0 :e R.
    { exact (Romega_coord_in_R f 0 HfX H0o). }
    claim Hfprod: f :e product_space omega Xi.
    { rewrite <- HXdef. exact HfX. }
    claim Hfs0: f :e s0.
    { claim Hcyl_def: s0 =
        {g :e product_space omega Xi | 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R}.
      { reflexivity. }
      rewrite Hcyl_def.
      apply (SepI (product_space omega Xi)
                  (fun g:set => 0 :e omega /\ R :e space_family_topology Xi 0 /\ apply_fun g 0 :e R)
                  f
                  Hfprod).
      apply andI.
      - apply andI.
        + exact H0o.
        + exact HRin.
      - exact Hf0R. }
    claim Hs0In: s0 :e {product_cylinder omega Xi 0 U0|U0 :e space_family_topology Xi 0}.
    { exact (ReplI (space_family_topology Xi 0) (fun U0:set => product_cylinder omega Xi 0 U0) R HRin). }
    claim Hs0S: s0 :e S.
    { exact (famunionI omega (fun j:set => {product_cylinder omega Xi j U0|U0 :e space_family_topology Xi j})
                       0 s0 H0o Hs0In). }
    exact (UnionI S f s0 Hfs0 Hs0S).
Qed.

(** Helper: coordinate map is continuous in the product topology on R^omega **)
Theorem Romega_coord_map_continuous_in_Romega_product : forall i:set,
  i :e omega ->
  continuous_map R_omega_space R_omega_product_topology R R_standard_topology (Romega_coord_map i).
let i.
assume Hi: i :e omega.
prove continuous_map R_omega_space R_omega_product_topology R R_standard_topology (Romega_coord_map i).
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
claim HXdef: R_omega_space = product_space omega Xi.
{ reflexivity. }
claim HtopX: topology_on R_omega_space R_omega_product_topology.
{ exact Romega_product_topology_is_topology. }
claim HtopR: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim Hfun: function_on (Romega_coord_map i) R_omega_space R.
{ exact (Romega_coord_map_function_on i Hi). }

prove topology_on R_omega_space R_omega_product_topology /\ topology_on R R_standard_topology /\
  function_on (Romega_coord_map i) R_omega_space R /\
  forall U:set, U :e R_standard_topology -> preimage_of R_omega_space (Romega_coord_map i) U :e R_omega_product_topology.
apply andI.
- apply andI.
  * apply andI.
    + exact HtopX.
    + exact HtopR.
  * exact Hfun.
- let U. assume HU: U :e R_standard_topology.
  prove preimage_of R_omega_space (Romega_coord_map i) U :e R_omega_product_topology.
  set Cyl := product_cylinder omega Xi i U.
  claim HIne: omega <> Empty.
  { claim H0o: 0 :e omega.
    { exact (nat_p_omega 0 nat_0). }
    exact (elem_implies_nonempty omega 0 H0o). }
  claim HcompTop: forall j:set, j :e omega -> topology_on (space_family_set Xi j) (space_family_topology Xi j).
  { let j. assume Hj: j :e omega.
    claim HXi: apply_fun Xi j = (R, R_standard_topology).
    { exact (const_space_family_apply omega R R_standard_topology j Hj). }
    claim Hset: space_family_set Xi j = R.
    { claim Hdef: space_family_set Xi j = (apply_fun Xi j) 0.
      { reflexivity. }
      rewrite Hdef. rewrite HXi.
      exact (tuple_2_0_eq R R_standard_topology). }
    claim Htop: space_family_topology Xi j = R_standard_topology.
    { claim Hdef: space_family_topology Xi j = (apply_fun Xi j) 1.
      { reflexivity. }
      rewrite Hdef. rewrite HXi.
      exact (tuple_2_1_eq R R_standard_topology). }
    rewrite Hset. rewrite Htop.
    exact R_standard_topology_is_topology_local. }
  claim HS: subbasis_on R_omega_space S.
  { exact Romega_product_subbasis_on. }
  claim HUtop: U :e space_family_topology Xi i.
  { claim HXi0: apply_fun Xi i = (R, R_standard_topology).
    { exact (const_space_family_apply omega R R_standard_topology i Hi). }
    claim Htopi: space_family_topology Xi i = R_standard_topology.
    { claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
      { reflexivity. }
      rewrite Hdef. rewrite HXi0.
      exact (tuple_2_1_eq R R_standard_topology). }
    rewrite Htopi.
    exact HU. }
  claim HCylS: Cyl :e S.
  { claim HCylRepl: Cyl :e {product_cylinder omega Xi i U0|U0 :e space_family_topology Xi i}.
    { exact (ReplI (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) U HUtop). }
    exact (famunionI omega (fun j:set => {product_cylinder omega Xi j U0|U0 :e space_family_topology Xi j})
                     i Cyl Hi HCylRepl). }
  claim HeqPre: preimage_of R_omega_space (Romega_coord_map i) U = Cyl.
  { apply set_ext.
    - let f. assume HfPre: f :e preimage_of R_omega_space (Romega_coord_map i) U.
      prove f :e Cyl.
      claim HfX: f :e R_omega_space.
      { exact (SepE1 R_omega_space (fun x0:set => apply_fun (Romega_coord_map i) x0 :e U) f HfPre). }
      claim HfiU: apply_fun (Romega_coord_map i) f :e U.
      { exact (SepE2 R_omega_space (fun x0:set => apply_fun (Romega_coord_map i) x0 :e U) f HfPre). }
      claim Happ: apply_fun (Romega_coord_map i) f = apply_fun f i.
      { exact (Romega_coord_map_apply i f Hi HfX). }
      claim Hfprod: f :e product_space omega Xi.
      { rewrite <- HXdef. exact HfX. }
      claim HfiU2: apply_fun f i :e U.
      { rewrite <- Happ. exact HfiU. }
      prove f :e {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
      apply (SepI (product_space omega Xi)
                  (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                  f
                  Hfprod).
      apply andI.
      - apply andI.
        + exact Hi.
        + exact HUtop.
      - exact HfiU2.
    - let f. assume HfCyl: f :e Cyl.
      prove f :e preimage_of R_omega_space (Romega_coord_map i) U.
      claim Hfprod: f :e product_space omega Xi.
      { exact (SepE1 (product_space omega Xi)
                     (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                     f
                     HfCyl). }
      claim HfX: f :e R_omega_space.
      { rewrite HXdef. exact Hfprod. }
      claim Hcond: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun f i :e U.
      { exact (SepE2 (product_space omega Xi)
                     (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                     f
                     HfCyl). }
      claim HfiU: apply_fun f i :e U.
      { exact (andER (i :e omega /\ U :e space_family_topology Xi i) (apply_fun f i :e U) Hcond). }
      claim Happ: apply_fun (Romega_coord_map i) f = apply_fun f i.
      { exact (Romega_coord_map_apply i f Hi HfX). }
      claim Hpre_def: preimage_of R_omega_space (Romega_coord_map i) U =
        {x :e R_omega_space | apply_fun (Romega_coord_map i) x :e U}.
      { reflexivity. }
      rewrite Hpre_def.
      apply (SepI R_omega_space (fun x0:set => apply_fun (Romega_coord_map i) x0 :e U) f HfX).
      rewrite Happ.
      exact HfiU. }
  rewrite HeqPre.
  exact (subbasis_elem_open_in_generated_from_subbasis R_omega_space S Cyl HS HCylS).
Qed.

(** Helper: restrict-map on R^omega **)
(** LATEX VERSION: The truncation map f -> f|_k (with zeros beyond k) is continuous in the product topology. **)
Definition Romega_restrict_map : set -> set := fun k =>
  graph R_omega_space (fun f:set => Romega_restrict_seq k f).

(** Helper: apply_fun for Romega_restrict_map **)
Theorem Romega_restrict_map_apply : forall k f:set,
  k :e omega ->
  f :e R_omega_space ->
  apply_fun (Romega_restrict_map k) f = Romega_restrict_seq k f.
let k f.
assume HkO: k :e omega.
assume Hf: f :e R_omega_space.
prove apply_fun (Romega_restrict_map k) f = Romega_restrict_seq k f.
claim Hdef: Romega_restrict_map k = graph R_omega_space (fun g:set => Romega_restrict_seq k g).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph R_omega_space (fun g:set => Romega_restrict_seq k g) f Hf).
Qed.

(** Helper: restrict-map is a function into the ambient product space **)
Theorem Romega_restrict_map_function_on : forall k:set,
  k :e omega ->
  function_on (Romega_restrict_map k) R_omega_space R_omega_space.
let k.
assume HkO: k :e omega.
prove function_on (Romega_restrict_map k) R_omega_space R_omega_space.
let f. assume Hf: f :e R_omega_space.
prove apply_fun (Romega_restrict_map k) f :e R_omega_space.
rewrite (Romega_restrict_map_apply k f HkO Hf).
claim Htilde: Romega_restrict_seq k f :e Romega_tilde k.
{ exact (Romega_restrict_seq_in_Romega_tilde k f HkO Hf). }
exact (Romega_tilde_sub_Romega k (Romega_restrict_seq k f) Htilde).
Qed.

(** Helper: restrict-map is continuous in the product topology on R^omega **)
Theorem Romega_restrict_map_continuous_in_Romega_product : forall k:set,
  k :e omega ->
  continuous_map R_omega_space R_omega_product_topology R_omega_space R_omega_product_topology (Romega_restrict_map k).
let k.
assume HkO: k :e omega.
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
claim HXdef: R_omega_space = product_space omega Xi.
{ reflexivity. }
claim HtopX: topology_on R_omega_space R_omega_product_topology.
{ exact Romega_product_topology_is_topology. }
claim Hfun: function_on (Romega_restrict_map k) R_omega_space R_omega_space.
{ exact (Romega_restrict_map_function_on k HkO). }
claim HIne: omega <> Empty.
{ claim H0o: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  exact (elem_implies_nonempty omega 0 H0o). }
claim HcompTop: forall j:set, j :e omega -> topology_on (space_family_set Xi j) (space_family_topology Xi j).
{ let j. assume Hj: j :e omega.
  claim HXi: apply_fun Xi j = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology j Hj). }
  claim Hset: space_family_set Xi j = R.
  { claim Hdef: space_family_set Xi j = (apply_fun Xi j) 0.
    { reflexivity. }
    rewrite Hdef. rewrite HXi.
    exact (tuple_2_0_eq R R_standard_topology). }
  claim Htop: space_family_topology Xi j = R_standard_topology.
  { claim Hdef: space_family_topology Xi j = (apply_fun Xi j) 1.
    { reflexivity. }
    rewrite Hdef. rewrite HXi.
    exact (tuple_2_1_eq R R_standard_topology). }
  rewrite Hset. rewrite Htop.
  exact R_standard_topology_is_topology_local. }
claim HS: subbasis_on R_omega_space S.
{ exact Romega_product_subbasis_on. }

apply (continuous_map_from_subbasis R_omega_space R_omega_product_topology R_omega_space S (Romega_restrict_map k)
       HtopX Hfun HS).
let s. assume Hs: s :e S.
prove preimage_of R_omega_space (Romega_restrict_map k) s :e R_omega_product_topology.
set F := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
claim HsF: s :e (\/_ i :e omega, F i).
{ exact Hs. }
apply (famunionE_impred omega F s HsF (preimage_of R_omega_space (Romega_restrict_map k) s :e R_omega_product_topology)).
let i. assume Hi: i :e omega.
assume HsFi: s :e F i.
apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi
                    (preimage_of R_omega_space (Romega_restrict_map k) s :e R_omega_product_topology)).
let U. assume HUtop: U :e space_family_topology Xi i.
assume Hseq: s = product_cylinder omega Xi i U.
rewrite Hseq.
claim Htopi: space_family_topology Xi i = R_standard_topology.
{ claim HXi0: apply_fun Xi i = (R, R_standard_topology).
  { exact (const_space_family_apply omega R R_standard_topology i Hi). }
  claim Hdef: space_family_topology Xi i = (apply_fun Xi i) 1.
  { reflexivity. }
  rewrite Hdef. rewrite HXi0.
  exact (tuple_2_1_eq R R_standard_topology). }
claim HUstd: U :e R_standard_topology.
{ rewrite <- Htopi. exact HUtop. }

apply (xm (k :e i)).
- assume Hki: k :e i.
  apply (xm (0 :e U)).
  * assume H0U: 0 :e U.
    claim Heq: preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U) = R_omega_space.
    { apply set_ext.
      - let f. assume HfPre: f :e preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U).
        exact (SepE1 R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e product_cylinder omega Xi i U) f HfPre).
      - let f. assume HfX: f :e R_omega_space.
        prove f :e preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U).
        claim Hpre_def: preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U) =
          {x :e R_omega_space | apply_fun (Romega_restrict_map k) x :e product_cylinder omega Xi i U}.
        { reflexivity. }
        rewrite Hpre_def.
        apply (SepI R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e product_cylinder omega Xi i U) f HfX).
        rewrite (Romega_restrict_map_apply k f HkO HfX).
        claim Hfprod: f :e product_space omega Xi.
        { rewrite <- HXdef. exact HfX. }
        claim HimgTilde: Romega_restrict_seq k f :e Romega_tilde k.
        { exact (Romega_restrict_seq_in_Romega_tilde k f HkO HfX). }
        claim Himg: Romega_restrict_seq k f :e product_space omega Xi.
        { rewrite <- HXdef.
          exact (Romega_tilde_sub_Romega k (Romega_restrict_seq k f) HimgTilde). }
        prove Romega_restrict_seq k f :e product_cylinder omega Xi i U.
        claim Hcyl_def: product_cylinder omega Xi i U =
          {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
        { reflexivity. }
        rewrite Hcyl_def.
        apply (SepI (product_space omega Xi)
                    (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                    (Romega_restrict_seq k f)
                    Himg).
        apply andI.
        - apply andI.
          + exact Hi.
          + exact HUtop.
        - claim Happ: apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
          { exact (Romega_restrict_seq_apply k f i HkO HfX Hi). }
          rewrite Happ.
          rewrite (If_i_1 (k :e i) 0 (apply_fun f i) Hki).
          exact H0U. }
    rewrite Heq.
    exact (topology_has_X R_omega_space R_omega_product_topology HtopX).
  * assume Hn0U: ~(0 :e U).
    claim Heq: preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U) = Empty.
    { apply set_ext.
      - let f. assume HfPre: f :e preimage_of R_omega_space (Romega_restrict_map k) (product_cylinder omega Xi i U).
        prove f :e Empty.
        claim HfX: f :e R_omega_space.
        { exact (SepE1 R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e product_cylinder omega Xi i U) f HfPre). }
        claim Himg: apply_fun (Romega_restrict_map k) f :e product_cylinder omega Xi i U.
        { exact (SepE2 R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e product_cylinder omega Xi i U) f HfPre). }
        claim Himg2: Romega_restrict_seq k f :e product_cylinder omega Xi i U.
        { rewrite <- (Romega_restrict_map_apply k f HkO HfX).
          exact Himg. }
        claim Hcond: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (Romega_restrict_seq k f) i :e U.
        { exact (SepE2 (product_space omega Xi)
                       (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                       (Romega_restrict_seq k f)
                       Himg2). }
        claim HUi: apply_fun (Romega_restrict_seq k f) i :e U.
        { exact (andER (i :e omega /\ U :e space_family_topology Xi i) (apply_fun (Romega_restrict_seq k f) i :e U) Hcond). }
        claim Happ: apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
        { exact (Romega_restrict_seq_apply k f i HkO HfX Hi). }
        apply FalseE.
        claim Htmp: If_i (k :e i) 0 (apply_fun f i) :e U.
        { rewrite <- Happ. exact HUi. }
        claim H0U2: 0 :e U.
        { rewrite <- (If_i_1 (k :e i) 0 (apply_fun f i) Hki).
          exact Htmp. }
        exact (Hn0U H0U2).
      - let f. assume HfE: f :e Empty.
        apply FalseE.
        exact (EmptyE f HfE). }
    rewrite Heq.
    claim HTx: topology_on R_omega_space R_omega_product_topology.
    { exact HtopX. }
    exact (topology_has_empty R_omega_space R_omega_product_topology HTx).
- assume Hnki: ~(k :e i).
  set Cyl := product_cylinder omega Xi i U.
  claim Heq: preimage_of R_omega_space (Romega_restrict_map k) Cyl = Cyl.
  { apply set_ext.
    - let f. assume HfPre: f :e preimage_of R_omega_space (Romega_restrict_map k) Cyl.
      prove f :e Cyl.
      claim HfX: f :e R_omega_space.
      { exact (SepE1 R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e Cyl) f HfPre). }
      claim Himg: apply_fun (Romega_restrict_map k) f :e Cyl.
      { exact (SepE2 R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e Cyl) f HfPre). }
      claim Himg2: Romega_restrict_seq k f :e Cyl.
      { rewrite <- (Romega_restrict_map_apply k f HkO HfX).
        exact Himg. }
      claim Hcond: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun (Romega_restrict_seq k f) i :e U.
      { exact (SepE2 (product_space omega Xi)
                     (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                     (Romega_restrict_seq k f)
                     Himg2). }
      claim HUi: apply_fun (Romega_restrict_seq k f) i :e U.
      { exact (andER (i :e omega /\ U :e space_family_topology Xi i) (apply_fun (Romega_restrict_seq k f) i :e U) Hcond). }
      claim Happ: apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
      { exact (Romega_restrict_seq_apply k f i HkO HfX Hi). }
      claim Htmp: If_i (k :e i) 0 (apply_fun f i) :e U.
      { rewrite <- Happ. exact HUi. }
      claim HUi2: apply_fun f i :e U.
      { rewrite <- (If_i_0 (k :e i) 0 (apply_fun f i) Hnki).
        exact Htmp. }
      claim Hfprod: f :e product_space omega Xi.
      { rewrite <- HXdef. exact HfX. }
      claim Hcyl_def: Cyl =
        {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
      { reflexivity. }
      rewrite Hcyl_def.
      apply (SepI (product_space omega Xi)
                  (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                  f
                  Hfprod).
      apply andI.
      * apply andI.
        + exact Hi.
        + exact HUtop.
      * exact HUi2.
    - let f. assume HfCyl: f :e Cyl.
      prove f :e preimage_of R_omega_space (Romega_restrict_map k) Cyl.
      claim Hfprod: f :e product_space omega Xi.
      { exact (SepE1 (product_space omega Xi)
                     (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                     f
                     HfCyl). }
      claim HfX: f :e R_omega_space.
      { rewrite HXdef. exact Hfprod. }
      claim HUi: apply_fun f i :e U.
      { claim Hcond: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun f i :e U.
        { exact (SepE2 (product_space omega Xi)
                       (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                       f
                       HfCyl). }
        exact (andER (i :e omega /\ U :e space_family_topology Xi i) (apply_fun f i :e U) Hcond). }
      claim Hpre_def: preimage_of R_omega_space (Romega_restrict_map k) Cyl =
        {x :e R_omega_space | apply_fun (Romega_restrict_map k) x :e Cyl}.
      { reflexivity. }
      rewrite Hpre_def.
      apply (SepI R_omega_space (fun x0:set => apply_fun (Romega_restrict_map k) x0 :e Cyl) f HfX).
      rewrite (Romega_restrict_map_apply k f HkO HfX).
      claim Himg: Romega_restrict_seq k f :e product_space omega Xi.
      { claim HimgTilde: Romega_restrict_seq k f :e Romega_tilde k.
        { exact (Romega_restrict_seq_in_Romega_tilde k f HkO HfX). }
        rewrite <- HXdef.
        exact (Romega_tilde_sub_Romega k (Romega_restrict_seq k f) HimgTilde). }
      claim Hcyl_def2: Cyl =
        {g :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
      { reflexivity. }
      rewrite Hcyl_def2.
      apply (SepI (product_space omega Xi)
                  (fun g:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun g i :e U)
                  (Romega_restrict_seq k f)
                  Himg).
      apply andI.
      * apply andI.
        + exact Hi.
        + exact HUtop.
      * claim Happ: apply_fun (Romega_restrict_seq k f) i = If_i (k :e i) 0 (apply_fun f i).
        { exact (Romega_restrict_seq_apply k f i HkO HfX Hi). }
        rewrite Happ.
        rewrite (If_i_0 (k :e i) 0 (apply_fun f i) Hnki).
        exact HUi. }
  rewrite Heq.
  claim HCylS: Cyl :e S.
  { claim HCylRepl: Cyl :e {product_cylinder omega Xi i U0|U0 :e space_family_topology Xi i}.
    { exact (ReplI (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) U HUtop). }
    exact (famunionI omega (fun j:set => {product_cylinder omega Xi j U0|U0 :e space_family_topology Xi j})
                     i Cyl Hi HCylRepl). }
  exact (subbasis_elem_open_in_generated_from_subbasis R_omega_space S Cyl HS HCylS).
Qed.

(** Helper: split map for Romega_tilde (ordsucc k) into Romega_tilde k x R **)
(** LATEX VERSION: Identify R~(k+1) with R~(k)×R by taking the truncated sequence and the new coordinate at k+1. **)
Definition Romega_split_map : set -> set := fun k =>
  graph (Romega_tilde (ordsucc k))
        (fun f:set => (Romega_restrict_seq k f, apply_fun f (ordsucc k))).

(** Helper: apply_fun for Romega_split_map **)
Theorem Romega_split_map_apply : forall k f:set,
  k :e omega ->
  f :e Romega_tilde (ordsucc k) ->
  apply_fun (Romega_split_map k) f
    = (Romega_restrict_seq k f, apply_fun f (ordsucc k)).
let k f.
assume HkO: k :e omega.
assume Hf: f :e Romega_tilde (ordsucc k).
prove apply_fun (Romega_split_map k) f = (Romega_restrict_seq k f, apply_fun f (ordsucc k)).
claim Hdef: Romega_split_map k =
  graph (Romega_tilde (ordsucc k))
        (fun g:set => (Romega_restrict_seq k g, apply_fun g (ordsucc k))).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph (Romega_tilde (ordsucc k))
       (fun g:set => (Romega_restrict_seq k g, apply_fun g (ordsucc k)))
       f Hf).
Qed.

(** Helper: split map is a function into Romega_tilde k × R **)
(** LATEX VERSION: The splitting map lands in R~(k)×R. **)
Theorem Romega_split_map_function_on : forall k:set,
  k :e omega ->
  function_on (Romega_split_map k) (Romega_tilde (ordsucc k)) (setprod (Romega_tilde k) R).
let k.
assume HkO: k :e omega.
prove function_on (Romega_split_map k) (Romega_tilde (ordsucc k)) (setprod (Romega_tilde k) R).
let f. assume Hf: f :e Romega_tilde (ordsucc k).
prove apply_fun (Romega_split_map k) f :e setprod (Romega_tilde k) R.
rewrite (Romega_split_map_apply k f HkO Hf).
claim HfRomega: f :e R_omega_space.
{ exact (Romega_tilde_sub_Romega (ordsucc k) f Hf). }
claim Hkf: Romega_restrict_seq k f :e Romega_tilde k.
{ exact (Romega_restrict_seq_in_Romega_tilde k f HkO HfRomega). }
claim HsuccO: ordsucc k :e omega.
{ exact (omega_ordsucc k HkO). }
claim Hfcoord: apply_fun f (ordsucc k) :e R.
{ exact (Romega_coord_in_R f (ordsucc k) HfRomega HsuccO). }
exact (tuple_2_setprod_by_pair_Sigma (Romega_tilde k) R (Romega_restrict_seq k f) (apply_fun f (ordsucc k)) Hkf Hfcoord).
Qed.

(** Helper: split map is continuous **)
(** LATEX VERSION: The identification R~(k+1) ≅ R~(k)×R is a homeomorphism; in particular the split map is continuous. **)
Theorem Romega_split_map_continuous : forall k:set,
  k :e omega ->
  continuous_map
    (Romega_tilde (ordsucc k))
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
    (setprod (Romega_tilde k) R)
    (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                      R R_standard_topology)
    (Romega_split_map k).
let k.
assume HkO: k :e omega.
set A := Romega_tilde (ordsucc k).
set Ta := subspace_topology R_omega_space R_omega_product_topology A.
set X := Romega_tilde k.
set Tx := subspace_topology R_omega_space R_omega_product_topology X.

claim HtopRomega: topology_on R_omega_space R_omega_product_topology.
{ exact Romega_product_topology_is_topology. }
claim HA_sub: A c= R_omega_space.
{ exact (Romega_tilde_sub_Romega (ordsucc k)). }
claim HX_sub: X c= R_omega_space.
{ exact (Romega_tilde_sub_Romega k). }
claim HsuccO: ordsucc k :e omega.
{ exact (omega_ordsucc k HkO). }

(** First coordinate: restriction map into Romega_tilde k **)
claim HcontRestrProd: continuous_map R_omega_space R_omega_product_topology R_omega_space R_omega_product_topology (Romega_restrict_map k).
{ exact (Romega_restrict_map_continuous_in_Romega_product k HkO). }
claim HcontRestrA: continuous_map A Ta R_omega_space R_omega_product_topology (Romega_restrict_map k).
{ exact (continuous_on_subspace R_omega_space R_omega_product_topology R_omega_space R_omega_product_topology (Romega_restrict_map k)
         A HtopRomega HA_sub HcontRestrProd). }
claim HimgRestr: forall f:set, f :e A -> apply_fun (Romega_restrict_map k) f :e X.
{ let f. assume HfA: f :e A.
  claim HfX: f :e R_omega_space.
  { exact (HA_sub f HfA). }
  rewrite (Romega_restrict_map_apply k f HkO HfX).
  exact (Romega_restrict_seq_in_Romega_tilde k f HkO HfX). }
claim HcontRestrToX: continuous_map A Ta X Tx (Romega_restrict_map k).
{ exact (continuous_map_range_restrict A Ta R_omega_space R_omega_product_topology (Romega_restrict_map k) X
         HcontRestrA HX_sub HimgRestr). }

(** Second coordinate: evaluation at ordsucc k **)
claim HcontCoordProd: continuous_map R_omega_space R_omega_product_topology R R_standard_topology (Romega_coord_map (ordsucc k)).
{ exact (Romega_coord_map_continuous_in_Romega_product (ordsucc k) HsuccO). }
claim HcontCoordA: continuous_map A Ta R R_standard_topology (Romega_coord_map (ordsucc k)).
{ exact (continuous_on_subspace R_omega_space R_omega_product_topology R R_standard_topology (Romega_coord_map (ordsucc k))
         A HtopRomega HA_sub HcontCoordProd). }

(** Assemble the pair map **)
claim HpairCont: continuous_map A Ta (setprod X R) (product_topology X Tx R R_standard_topology)
  (pair_map A (Romega_restrict_map k) (Romega_coord_map (ordsucc k))).
{ exact (maps_into_products_axiom A Ta X Tx R R_standard_topology (Romega_restrict_map k) (Romega_coord_map (ordsucc k))
         HcontRestrToX HcontCoordA). }

(** Identify the pair map with the splitting map **)
claim Heq: pair_map A (Romega_restrict_map k) (Romega_coord_map (ordsucc k)) = Romega_split_map k.
{ apply set_ext.
  - let p. assume Hp: p :e pair_map A (Romega_restrict_map k) (Romega_coord_map (ordsucc k)).
    prove p :e Romega_split_map k.
    apply (ReplE_impred A
            (fun a0:set => (a0, (apply_fun (Romega_restrict_map k) a0, apply_fun (Romega_coord_map (ordsucc k)) a0)))
            p Hp (p :e Romega_split_map k)).
    let a.
    assume Ha: a :e A.
    assume Heqp: p = (a, (apply_fun (Romega_restrict_map k) a, apply_fun (Romega_coord_map (ordsucc k)) a)).
    claim HaX: a :e R_omega_space.
    { exact (HA_sub a Ha). }
    claim Hra: apply_fun (Romega_restrict_map k) a = Romega_restrict_seq k a.
    { exact (Romega_restrict_map_apply k a HkO HaX). }
    claim Hca: apply_fun (Romega_coord_map (ordsucc k)) a = apply_fun a (ordsucc k).
    { exact (Romega_coord_map_apply (ordsucc k) a HsuccO HaX). }
    rewrite Heqp.
    rewrite Hra.
    rewrite Hca.
    exact (ReplI A
            (fun f0:set => (f0, (Romega_restrict_seq k f0, apply_fun f0 (ordsucc k))))
            a Ha).
  - let p. assume Hp: p :e Romega_split_map k.
    prove p :e pair_map A (Romega_restrict_map k) (Romega_coord_map (ordsucc k)).
    claim Hdef: Romega_split_map k = graph A (fun f0:set => (Romega_restrict_seq k f0, apply_fun f0 (ordsucc k))).
    { reflexivity. }
    claim Hp2: p :e graph A (fun f0:set => (Romega_restrict_seq k f0, apply_fun f0 (ordsucc k))).
    { rewrite <- Hdef. exact Hp. }
    apply (ReplE_impred A
            (fun f0:set => (f0, (Romega_restrict_seq k f0, apply_fun f0 (ordsucc k))))
            p Hp2 (p :e pair_map A (Romega_restrict_map k) (Romega_coord_map (ordsucc k)))).
    let a.
    assume Ha: a :e A.
    assume Heqp: p = (a, (Romega_restrict_seq k a, apply_fun a (ordsucc k))).
    claim HaX: a :e R_omega_space.
    { exact (HA_sub a Ha). }
    claim Hra: apply_fun (Romega_restrict_map k) a = Romega_restrict_seq k a.
    { exact (Romega_restrict_map_apply k a HkO HaX). }
    claim Hca: apply_fun (Romega_coord_map (ordsucc k)) a = apply_fun a (ordsucc k).
    { exact (Romega_coord_map_apply (ordsucc k) a HsuccO HaX). }
    rewrite Heqp.
    rewrite <- Hra.
    rewrite <- Hca.
    exact (ReplI A
            (fun a0:set => (a0, (apply_fun (Romega_restrict_map k) a0, apply_fun (Romega_coord_map (ordsucc k)) a0)))
            a Ha). }

rewrite <- Heq.
exact HpairCont.
Qed.

(** Helper: extensionality in R_omega_space by coordinates **)
Theorem R_omega_space_ext : forall f g:set,
  f :e R_omega_space ->
  g :e R_omega_space ->
  (forall i:set, i :e omega -> apply_fun f i = apply_fun g i) ->
  f = g.
let f g.
assume HfX: f :e R_omega_space.
assume HgX: g :e R_omega_space.
assume Hcoord: forall i:set, i :e omega -> apply_fun f i = apply_fun g i.
prove f = g.
apply set_ext.
- (** f c= g **)
  let p. assume Hp: p :e f.
  prove p :e g.
  set Xi := const_space_family omega R R_standard_topology.
  set Y := space_family_union omega Xi.
  claim HfPow: f :e Power (setprod omega Y).
  { exact (SepE1 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           f
           HfX). }
  claim HgPow: g :e Power (setprod omega Y).
  { exact (SepE1 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           g
           HgX). }
  claim Hfsub: f c= setprod omega Y.
  { exact (PowerE (setprod omega Y) f HfPow). }
  claim Hgsub: g c= setprod omega Y.
  { exact (PowerE (setprod omega Y) g HgPow). }
  claim HpProd: p :e setprod omega Y.
  { exact (Hfsub p Hp). }
  claim Hpeq: p = (p 0, p 1).
  { exact (setprod_eta omega Y p HpProd). }
  set i := p 0.
  set y := p 1.
  claim Hip: i :e omega.
  { exact (ap0_Sigma omega (fun _ : set => Y) p HpProd). }
  claim Hfprop: (total_function_on f omega Y /\ functional_graph f) /\
                forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j.
  { exact (SepE2 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           f
           HfX). }
  claim Hgprop: (total_function_on g omega Y /\ functional_graph g) /\
                forall j:set, j :e omega -> apply_fun g j :e space_family_set Xi j.
  { exact (SepE2 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           g
           HgX). }
  claim HfAB: total_function_on f omega Y /\ functional_graph f.
  { exact (andEL (total_function_on f omega Y /\ functional_graph f)
                 (forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j)
                 Hfprop). }
  claim HgAB: total_function_on g omega Y /\ functional_graph g.
  { exact (andEL (total_function_on g omega Y /\ functional_graph g)
                 (forall j:set, j :e omega -> apply_fun g j :e space_family_set Xi j)
                 Hgprop). }
  claim Htotg: total_function_on g omega Y.
  { exact (andEL (total_function_on g omega Y) (functional_graph g) HgAB). }
  claim Hfunf: functional_graph f.
  { exact (andER (total_function_on f omega Y) (functional_graph f) HfAB). }
  claim Hiyf: (i,y) :e f.
  { rewrite <- Hpeq.
    exact Hp. }
  claim Happfy: apply_fun f i = y.
  { exact (functional_graph_apply_fun_eq f i y Hfunf Hiyf). }
  claim Happgi: apply_fun g i = y.
  { rewrite <- (Hcoord i Hip).
    exact Happfy. }
  claim Hexg: exists y0:set, (i,y0) :e g.
  { claim Hex0: exists y0:set, y0 :e Y /\ (i,y0) :e g.
    { exact (total_function_on_totality g omega Y Htotg i Hip). }
    apply Hex0.
    let y0. assume Hy0.
    witness y0.
    exact (andER (y0 :e Y) ((i,y0) :e g) Hy0). }
  claim Hpairg: (i, apply_fun g i) :e g.
  { exact (apply_fun_in_graph_of_ex g i Hexg). }
  claim Hiyg: (i,y) :e g.
  { rewrite <- Happgi.
    exact Hpairg. }
  rewrite Hpeq.
  exact Hiyg.
- (** g c= f **)
  let p. assume Hp: p :e g.
  prove p :e f.
  set Xi := const_space_family omega R R_standard_topology.
  set Y := space_family_union omega Xi.
  claim HfPow: f :e Power (setprod omega Y).
  { exact (SepE1 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           f
           HfX). }
  claim HgPow: g :e Power (setprod omega Y).
  { exact (SepE1 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           g
           HgX). }
  claim Hfsub: f c= setprod omega Y.
  { exact (PowerE (setprod omega Y) f HfPow). }
  claim Hgsub: g c= setprod omega Y.
  { exact (PowerE (setprod omega Y) g HgPow). }
  claim HpProd: p :e setprod omega Y.
  { exact (Hgsub p Hp). }
  claim Hpeq: p = (p 0, p 1).
  { exact (setprod_eta omega Y p HpProd). }
  set i := p 0.
  set y := p 1.
  claim Hip: i :e omega.
  { exact (ap0_Sigma omega (fun _ : set => Y) p HpProd). }
  claim Hfprop: (total_function_on f omega Y /\ functional_graph f) /\
                forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j.
  { exact (SepE2 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           f
           HfX). }
  claim Hgprop: (total_function_on g omega Y /\ functional_graph g) /\
                forall j:set, j :e omega -> apply_fun g j :e space_family_set Xi j.
  { exact (SepE2 (Power (setprod omega Y))
           (fun f0:set =>
             total_function_on f0 omega Y /\ functional_graph f0 /\
             forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi j)
           g
           HgX). }
  claim HfAB: total_function_on f omega Y /\ functional_graph f.
  { exact (andEL (total_function_on f omega Y /\ functional_graph f)
                 (forall j:set, j :e omega -> apply_fun f j :e space_family_set Xi j)
                 Hfprop). }
  claim HgAB: total_function_on g omega Y /\ functional_graph g.
  { exact (andEL (total_function_on g omega Y /\ functional_graph g)
                 (forall j:set, j :e omega -> apply_fun g j :e space_family_set Xi j)
                 Hgprop). }
  claim Htotf: total_function_on f omega Y.
  { exact (andEL (total_function_on f omega Y) (functional_graph f) HfAB). }
  claim Hfung: functional_graph g.
  { exact (andER (total_function_on g omega Y) (functional_graph g) HgAB). }
  claim Hiyg: (i,y) :e g.
  { rewrite <- Hpeq.
    exact Hp. }
  claim Happgy: apply_fun g i = y.
  { exact (functional_graph_apply_fun_eq g i y Hfung Hiyg). }
  claim Happfi: apply_fun f i = y.
  { rewrite (Hcoord i Hip).
    exact Happgy. }
  claim Hexf: exists y0:set, (i,y0) :e f.
  { claim Hex0: exists y0:set, y0 :e Y /\ (i,y0) :e f.
    { exact (total_function_on_totality f omega Y Htotf i Hip). }
    apply Hex0.
    let y0. assume Hy0.
    witness y0.
    exact (andER (y0 :e Y) ((i,y0) :e f) Hy0). }
  claim Hpairf: (i, apply_fun f i) :e f.
  { exact (apply_fun_in_graph_of_ex f i Hexf). }
  claim Hiyf: (i,y) :e f.
  { rewrite <- Happfi.
    exact Hpairf. }
  rewrite Hpeq.
  exact Hiyf.
Qed.

(** Helper: extension identifies Romega_tilde (ordsucc k) with a product **)
Theorem Romega_tilde_succ_homeomorphism : forall k:set,
  k :e omega ->
  homeomorphism
    (setprod (Romega_tilde k) R)
    (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                      R R_standard_topology)
    (Romega_tilde (ordsucc k))
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
    (Romega_extend_map k).
let k.
assume HkO: k :e omega.
prove homeomorphism
  (setprod (Romega_tilde k) R)
  (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                    R R_standard_topology)
  (Romega_tilde (ordsucc k))
  (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
  (Romega_extend_map k).
(** Strategy: use `Romega_split_map k` as the inverse of `Romega_extend_map k`. **)
prove continuous_map
  (setprod (Romega_tilde k) R)
  (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                    R R_standard_topology)
  (Romega_tilde (ordsucc k))
  (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
  (Romega_extend_map k)
  /\
  exists g:set,
    continuous_map
      (Romega_tilde (ordsucc k))
      (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
      (setprod (Romega_tilde k) R)
      (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                        R R_standard_topology)
      g
    /\
    (forall x:set, x :e setprod (Romega_tilde k) R -> apply_fun g (apply_fun (Romega_extend_map k) x) = x)
    /\
    (forall y:set, y :e Romega_tilde (ordsucc k) -> apply_fun (Romega_extend_map k) (apply_fun g y) = y).
apply andI.
- (** continuity of the extension map **)
  exact (Romega_extend_map_continuous_to_Romega_tilde_succ k HkO).
- (** inverse package **)
  witness (Romega_split_map k).
  apply andI.
  + (** (continuous_map ...) /\ (forall x ...) **)
    apply andI.
    * (** continuity of the splitting map **)
      prove
        topology_on (Romega_tilde (ordsucc k))
          (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
        /\
        topology_on (setprod (Romega_tilde k) R)
          (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                            R R_standard_topology)
        /\
        function_on (Romega_split_map k) (Romega_tilde (ordsucc k)) (setprod (Romega_tilde k) R)
        /\
        (forall V:set,
          V :e product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                                R R_standard_topology ->
          preimage_of (Romega_tilde (ordsucc k)) (Romega_split_map k) V :e
            subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k))).
      apply andI.
      - (** (topology_on Dom /\ topology_on Cod) /\ function_on **)
        apply andI.
        + (** topology_on Dom /\ topology_on Cod **)
          apply andI.
          * (** topology_on Dom **)
            claim HtopRomega: topology_on R_omega_space R_omega_product_topology.
            { exact Romega_product_topology_is_topology. }
            exact (subspace_topology_is_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k))
                     HtopRomega
                     (Romega_tilde_sub_Romega (ordsucc k))).
          * (** topology_on Cod **)
            claim HtopRomega: topology_on R_omega_space R_omega_product_topology.
            { exact Romega_product_topology_is_topology. }
            claim HtopTildek: topology_on (Romega_tilde k)
              (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k)).
            { exact (subspace_topology_is_topology R_omega_space R_omega_product_topology (Romega_tilde k)
                     HtopRomega
                     (Romega_tilde_sub_Romega k)). }
            claim HtopR: topology_on R R_standard_topology.
            { exact R_standard_topology_is_topology. }
            exact (product_topology_is_topology
                     (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                     R R_standard_topology
                     HtopTildek HtopR).
        + (** function_on **)
          exact (Romega_split_map_function_on k HkO).
      - (** preimage condition **)
        let V. assume HV: V :e product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
                                              R R_standard_topology.
	        exact (continuous_map_preimage (Romega_tilde (ordsucc k))
	                (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde (ordsucc k)))
	                (setprod (Romega_tilde k) R)
	                (product_topology (Romega_tilde k) (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde k))
	                                  R R_standard_topology)
	                (Romega_split_map k)
	                (Romega_split_map_continuous k HkO)
	                V HV).
	    * (** split after extend is identity on the product domain **)
	      let x. assume Hx: x :e setprod (Romega_tilde k) R.
	      prove apply_fun (Romega_split_map k) (apply_fun (Romega_extend_map k) x) = x.
	      set x0 := x 0.
	      set x1 := x 1.
	      claim Heta: x = (x0,x1).
	      { exact (setprod_eta (Romega_tilde k) R x Hx). }
	      rewrite Heta at 2.
	      claim Himg: apply_fun (Romega_extend_map k) x :e Romega_tilde (ordsucc k).
	      { exact (Romega_extend_map_function_on_tilde_succ k HkO x Hx). }
	      rewrite (Romega_split_map_apply k (apply_fun (Romega_extend_map k) x) HkO Himg).
	      claim Hx0def: x0 = x 0.
	      { reflexivity. }
	      claim Hx1def: x1 = x 1.
	      { reflexivity. }
	      claim Hx0tilde: x0 :e Romega_tilde k.
	      { rewrite Hx0def.
	        exact (ap0_Sigma (Romega_tilde k) (fun _ : set => R) x Hx). }
	      claim Hx0X: x0 :e R_omega_space.
	      { exact (Romega_tilde_sub_Romega k x0 Hx0tilde). }
	      claim HextX: apply_fun (Romega_extend_map k) x :e R_omega_space.
	      { exact (Romega_extend_map_function_on k HkO x Hx). }
	      claim HrestTilde: Romega_restrict_seq k (apply_fun (Romega_extend_map k) x) :e Romega_tilde k.
	      { exact (Romega_restrict_seq_in_Romega_tilde k (apply_fun (Romega_extend_map k) x) HkO HextX). }
	      claim HrestX: Romega_restrict_seq k (apply_fun (Romega_extend_map k) x) :e R_omega_space.
	      { exact (Romega_tilde_sub_Romega k (Romega_restrict_seq k (apply_fun (Romega_extend_map k) x)) HrestTilde). }
	      claim HrestEq: Romega_restrict_seq k (apply_fun (Romega_extend_map k) x) = x0.
	      { apply (R_omega_space_ext (Romega_restrict_seq k (apply_fun (Romega_extend_map k) x)) x0 HrestX Hx0X).
	        let i. assume Hi: i :e omega.
	        prove apply_fun (Romega_restrict_seq k (apply_fun (Romega_extend_map k) x)) i = apply_fun x0 i.
	        rewrite (Romega_restrict_seq_apply k (apply_fun (Romega_extend_map k) x) i HkO HextX Hi).
	        apply (xm (k :e i)).
	        + assume Hki: k :e i.
	          rewrite (If_i_1 (k :e i) 0 (apply_fun (apply_fun (Romega_extend_map k) x) i) Hki).
	          claim Hx0prop: forall j:set, j :e omega -> k :e j -> apply_fun x0 j = 0.
	          { claim HdefT: Romega_tilde k =
	              {f0 :e R_omega_space | forall j:set, j :e omega -> k :e j -> apply_fun f0 j = 0}.
	            { reflexivity. }
	            claim Hx0tilde2: x0 :e {f0 :e R_omega_space | forall j:set, j :e omega -> k :e j -> apply_fun f0 j = 0}.
	            { rewrite <- HdefT.
	              exact Hx0tilde. }
	            exact (SepE2 R_omega_space (fun f0:set => forall j:set, j :e omega -> k :e j -> apply_fun f0 j = 0)
	                      x0 Hx0tilde2). }
	          rewrite (Hx0prop i Hi Hki).
	          reflexivity.
	        + assume Hnki: ~(k :e i).
	          rewrite (If_i_0 (k :e i) 0 (apply_fun (apply_fun (Romega_extend_map k) x) i) Hnki).
	          claim HnEq: ~(i = ordsucc k).
	          { assume Heq: i = ordsucc k.
	            prove False.
	            apply Hnki.
	            rewrite Heq.
	            exact (ordsuccI2 k). }
	          claim HnSuccIn: ~(ordsucc k :e i).
	          { assume Hsi: ordsucc k :e i.
	            prove False.
	            apply Hnki.
	            claim Hordi: ordinal i.
	            { exact (ordinal_Hered omega omega_ordinal i Hi). }
	            claim HTi: TransSet i.
	            { exact (ordinal_TransSet i Hordi). }
	            claim Hsub: ordsucc k c= i.
	            { exact (HTi (ordsucc k) Hsi). }
	            exact (Hsub k (ordsuccI2 k)). }
	          rewrite (Romega_extend_map_apply k x HkO Hx).
	          rewrite (Romega_extend_seq_apply k x i Hi).
	          rewrite (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (x 1) (apply_fun (x 0) i)) HnSuccIn).
	          rewrite (If_i_0 (i = ordsucc k) (x 1) (apply_fun (x 0) i) HnEq).
	          rewrite Hx0def.
	          reflexivity. }
	      claim HcoordEq: apply_fun (apply_fun (Romega_extend_map k) x) (ordsucc k) = x1.
	      { rewrite (Romega_extend_map_apply k x HkO Hx).
	        claim HsuccO: ordsucc k :e omega.
	        { exact (omega_ordsucc k HkO). }
	        rewrite (Romega_extend_seq_apply k x (ordsucc k) HsuccO).
	        claim Hnself: ~(ordsucc k :e ordsucc k).
	        { exact (In_irref (ordsucc k)). }
	        rewrite (If_i_0 (ordsucc k :e ordsucc k) 0 (If_i (ordsucc k = ordsucc k) (x 1) (apply_fun (x 0) (ordsucc k))) Hnself).
	        claim Heq: ordsucc k = ordsucc k.
	        { reflexivity. }
	        rewrite (If_i_1 (ordsucc k = ordsucc k) (x 1) (apply_fun (x 0) (ordsucc k)) Heq).
	        rewrite Hx1def.
	        reflexivity. }
	      rewrite HrestEq.
	      rewrite HcoordEq.
	      reflexivity.
	  + (** extend after split is identity on Romega_tilde (ordsucc k) **)
	    let y. assume Hy: y :e Romega_tilde (ordsucc k).
	    prove apply_fun (Romega_extend_map k) (apply_fun (Romega_split_map k) y) = y.
	    claim Himg: apply_fun (Romega_split_map k) y :e setprod (Romega_tilde k) R.
	    { exact (Romega_split_map_function_on k HkO y Hy). }
	    rewrite (Romega_extend_map_apply k (apply_fun (Romega_split_map k) y) HkO Himg).
	    set p := apply_fun (Romega_split_map k) y.
	    claim Hpdef: p = (Romega_restrict_seq k y, apply_fun y (ordsucc k)).
	    { rewrite (Romega_split_map_apply k y HkO Hy).
	      reflexivity. }
	    claim HyX: y :e R_omega_space.
	    { exact (Romega_tilde_sub_Romega (ordsucc k) y Hy). }
	    claim HsuccO: ordsucc k :e omega.
	    { exact (omega_ordsucc k HkO). }
	    claim HordSucc: ordinal (ordsucc k).
	    { exact (ordinal_Hered omega omega_ordinal (ordsucc k) HsuccO). }
	    claim HpX: Romega_extend_seq k p :e R_omega_space.
	    { claim Hptilde: Romega_extend_seq k p :e Romega_tilde (ordsucc k).
	      { claim HpEq: p = apply_fun (Romega_split_map k) y.
	        { reflexivity. }
	        rewrite HpEq.
	        exact (Romega_extend_seq_in_Romega_tilde_succ k (apply_fun (Romega_split_map k) y) HkO Himg). }
	      exact (Romega_tilde_sub_Romega (ordsucc k) (Romega_extend_seq k p) Hptilde). }
	    apply (R_omega_space_ext (Romega_extend_seq k p) y HpX HyX).
	    let i. assume Hi: i :e omega.
	    prove apply_fun (Romega_extend_seq k p) i = apply_fun y i.
	    claim Hordi: ordinal i.
	    { exact (ordinal_Hered omega omega_ordinal i Hi). }
	    apply (ordinal_trichotomy_or_impred (ordsucc k) i HordSucc Hordi (apply_fun (Romega_extend_seq k p) i = apply_fun y i)).
	    - assume Hsi: ordsucc k :e i.
	      rewrite (Romega_extend_seq_apply k p i Hi).
	      rewrite (If_i_1 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) Hsi).
	      claim Hyprop: forall j:set, j :e omega -> ordsucc k :e j -> apply_fun y j = 0.
	      { claim HdefT: Romega_tilde (ordsucc k) =
	          {f0 :e R_omega_space | forall j:set, j :e omega -> ordsucc k :e j -> apply_fun f0 j = 0}.
	        { reflexivity. }
	        claim Hy2: y :e {f0 :e R_omega_space | forall j:set, j :e omega -> ordsucc k :e j -> apply_fun f0 j = 0}.
	        { rewrite <- HdefT.
	          exact Hy. }
	        exact (SepE2 R_omega_space (fun f0:set => forall j:set, j :e omega -> ordsucc k :e j -> apply_fun f0 j = 0)
	                  y Hy2). }
	      rewrite (Hyprop i Hi Hsi).
	      reflexivity.
	    - assume Heq: ordsucc k = i.
	      rewrite <- Heq.
	      rewrite (Romega_extend_seq_apply k p (ordsucc k) HsuccO).
	      claim Hnself: ~(ordsucc k :e ordsucc k).
	      { exact (In_irref (ordsucc k)). }
	      rewrite (If_i_0 (ordsucc k :e ordsucc k) 0
	              (If_i (ordsucc k = ordsucc k) (p 1) (apply_fun (p 0) (ordsucc k))) Hnself).
	      claim Heqkk: ordsucc k = ordsucc k.
	      { reflexivity. }
	      rewrite (If_i_1 (ordsucc k = ordsucc k) (p 1) (apply_fun (p 0) (ordsucc k)) Heqkk).
	      rewrite Hpdef.
	      rewrite (tuple_2_1_eq (Romega_restrict_seq k y) (apply_fun y (ordsucc k))).
	      reflexivity.
	    - assume His: i :e ordsucc k.
	      rewrite (Romega_extend_seq_apply k p i Hi).
	      claim Hnsi: ~(ordsucc k :e i).
	      { assume Hsi: ordsucc k :e i.
	        exact (In_no2cycle i (ordsucc k) His Hsi). }
	      rewrite (If_i_0 (ordsucc k :e i) 0 (If_i (i = ordsucc k) (p 1) (apply_fun (p 0) i)) Hnsi).
	      claim Hneq: ~(i = ordsucc k).
	      { assume Heq: i = ordsucc k.
		        prove False.
		        claim Hself: ordsucc k :e ordsucc k.
		        { rewrite <- Heq at 1.
		          exact His. }
		        exact (In_irref (ordsucc k) Hself). }
	      rewrite (If_i_0 (i = ordsucc k) (p 1) (apply_fun (p 0) i) Hneq).
	      rewrite Hpdef.
	      rewrite (tuple_2_0_eq (Romega_restrict_seq k y) (apply_fun y (ordsucc k))).
	      rewrite (Romega_restrict_seq_apply k y i HkO HyX Hi).
	      claim Hnki: ~(k :e i).
	      { apply (ordsuccE k i His).
	        - assume Hik: i :e k.
	          prove ~(k :e i).
	          assume Hki: k :e i.
	          exact (In_no2cycle i k Hik Hki).
	        - assume Hieq: i = k.
	          prove ~(k :e i).
		          assume Hki: k :e i.
		          claim Hkk: k :e k.
		          { rewrite <- Hieq at 2.
		            exact Hki. }
		          exact (In_irref k Hkk). }
	      rewrite (If_i_0 (k :e i) 0 (apply_fun y i) Hnki).
	      reflexivity.
Qed.

(** Helper: every finite subset of omega is bounded by some n in omega **)
Theorem finite_subset_of_omega_bounded : forall F:set,
  F c= omega -> finite F -> exists n :e omega, forall m :e F, m :e n.
let F.
assume HFsub: F c= omega.
assume HFfin: finite F.
prove exists n :e omega, forall m :e F, m :e n.
claim Hp0: (Empty c= omega -> exists n :e omega, forall m :e Empty, m :e n).
{ assume Hsub0: Empty c= omega.
  prove exists n :e omega, forall m :e Empty, m :e n.
  witness 0.
  apply andI.
  - exact (nat_p_omega 0 nat_0).
  - let m. assume Hm: m :e Empty.
    apply FalseE.
    exact (EmptyE m Hm). }
claim Hpstep: forall A y, finite A -> y /:e A ->
  (A c= omega -> exists n :e omega, forall m :e A, m :e n) ->
  (A :\/: {y} c= omega -> exists n0 :e omega, forall m:set, m :e A :\/: {y} -> m :e n0).
{ let A y.
  assume HAfin: finite A.
  assume HyA: y /:e A.
  assume HpA: (A c= omega -> exists n :e omega, forall m :e A, m :e n).
  assume HsubAy: A :\/: {y} c= omega.
  claim HsubA: A c= omega.
  { exact (Subq_tra A (A :\/: {y}) omega (binunion_Subq_1 A {y}) HsubAy). }
  claim Hexn: exists n :e omega, forall m :e A, m :e n.
  { exact (HpA HsubA). }
  apply Hexn.
  let n.
  assume Hnand.
  claim Hn: n :e omega.
  { exact (andEL (n :e omega) (forall m :e A, m :e n) Hnand). }
  claim Hnprop: forall m :e A, m :e n.
  { exact (andER (n :e omega) (forall m :e A, m :e n) Hnand). }
  prove exists n0 :e omega, forall m:set, m :e A :\/: {y} -> m :e n0.
  claim Hy_in_union: y :e A :\/: {y}.
  { apply binunionI2. exact (SingI y). }
  claim Hy_omega: y :e omega.
  { exact (HsubAy y Hy_in_union). }
  claim Hysucc_omega: ordsucc y :e omega.
  { exact (omega_ordsucc y Hy_omega). }
  claim Hn_union_omega: n :\/: ordsucc y :e omega.
  { exact (omega_binunion n (ordsucc y) Hn Hysucc_omega). }
  set n0 := ordsucc (n :\/: ordsucc y).
  claim Hn0_omega: n0 :e omega.
  { exact (omega_ordsucc (n :\/: ordsucc y) Hn_union_omega). }
  witness n0.
  apply andI.
  - exact Hn0_omega.
  - let m. assume Hm: m :e A :\/: {y}.
    prove m :e n0.
    apply (binunionE A {y} m Hm).
    + assume HmA: m :e A.
      claim Hmn: m :e n.
      { exact (Hnprop m HmA). }
      claim HmnU: m :e n :\/: ordsucc y.
      { exact (binunionI1 n (ordsucc y) m Hmn). }
      exact (ordsuccI1 (n :\/: ordsucc y) m HmnU).
    + assume HmY: m :e {y}.
      claim Hmy: m = y.
      { exact (SingE y m HmY). }
      rewrite Hmy.
      claim Hy_in_succ: y :e ordsucc y.
      { exact (ordsuccI2 y). }
      claim Hy_in_U: y :e n :\/: ordsucc y.
      { exact (binunionI2 n (ordsucc y) y Hy_in_succ). }
      exact (ordsuccI1 (n :\/: ordsucc y) y Hy_in_U). }
claim HpF: (F c= omega -> exists n :e omega, forall m :e F, m :e n).
{ exact (finite_ind (fun A => A c= omega -> exists n :e omega, forall m :e A, m :e n)
                    Hp0 Hpstep F HFfin). }
exact (HpF HFsub).
Qed.

(** Helper: basis neighborhoods in the product topology meet Romega_infty **)
(** LATEX VERSION: Any basic open neighborhood in the product topology contains a point of R^infty by truncating outside finitely many constrained coordinates. **)
Theorem Romega_infty_meets_product_basis : forall b x:set,
  b :e basis_of_subbasis R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)) ->
  x :e b ->
  b :/\: Romega_infty <> Empty.
let b x.
assume Hb: b :e basis_of_subbasis R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)).
assume Hxb: x :e b.
prove b :/\: Romega_infty <> Empty.
set X := R_omega_space.
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
set B := basis_of_subbasis X S.
claim HbB: b :e B.
{ exact Hb. }
(** Unpack basis_of_subbasis membership. **)
claim Hbfin: b :e finite_intersections_of X S.
{ exact (SepE1 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b HbB). }
claim Hbne: b <> Empty.
{ exact (SepE2 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b HbB). }
(** Choose finite subcollection F of S with b = intersection_of_family X F. **)
apply (ReplE_impred (finite_subcollections S) (fun F0:set => intersection_of_family X F0) b Hbfin (b :/\: Romega_infty <> Empty)).
let F.
assume HF: F :e finite_subcollections S.
assume Hbeq: b = intersection_of_family X F.
rewrite Hbeq at 1.
(** Extract basic properties of F. **)
claim HFpow: F :e Power S.
{ exact (SepE1 (Power S) (fun F0:set => finite F0) F HF). }
claim HFsubS: F c= S.
{ exact (PowerE S F HFpow). }
claim HFfin: finite F.
{ exact (SepE2 (Power S) (fun F0:set => finite F0) F HF). }
(** x lies in the intersection, hence in X and in every s in F. **)
claim HxInt: x :e intersection_of_family X F.
{ rewrite <- Hbeq.
  exact Hxb. }
claim HxX: x :e X.
{ exact (SepE1 X (fun x0:set => forall U:set, U :e F -> x0 :e U) x HxInt). }
claim HxAll: forall s:set, s :e F -> x :e s.
{ exact (SepE2 X (fun x0:set => forall U:set, U :e F -> x0 :e U) x HxInt). }

(** Pick for each s :e F a coordinate index in omega witnessing s :e S. **)
set CylFam := fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}.
set pick_i := fun s:set => Eps_i (fun i:set => i :e omega /\ s :e CylFam i).

claim Hpick_omega: forall s:set, s :e F -> pick_i s :e omega.
{ let s. assume HsF: s :e F.
  prove pick_i s :e omega.
  claim HsS: s :e S.
  { exact (HFsubS s HsF). }
  claim Hex: exists i:set, i :e omega /\ s :e CylFam i.
  { exact (famunionE omega (fun i:set => CylFam i) s HsS). }
  claim Hpick: pick_i s :e omega /\ s :e CylFam (pick_i s).
  { exact (Eps_i_ex (fun i:set => i :e omega /\ s :e CylFam i) Hex). }
  exact (andEL (pick_i s :e omega) (s :e CylFam (pick_i s)) Hpick). }

claim Hpick_in: forall s:set, s :e F -> s :e CylFam (pick_i s).
{ let s. assume HsF: s :e F.
  prove s :e CylFam (pick_i s).
  claim HsS: s :e S.
  { exact (HFsubS s HsF). }
  claim Hex: exists i:set, i :e omega /\ s :e CylFam i.
  { exact (famunionE omega (fun i:set => CylFam i) s HsS). }
  claim Hpick: pick_i s :e omega /\ s :e CylFam (pick_i s).
  { exact (Eps_i_ex (fun i:set => i :e omega /\ s :e CylFam i) Hex). }
  exact (andER (pick_i s :e omega) (s :e CylFam (pick_i s)) Hpick). }

(** The set of picked indices is finite and contained in omega. **)
set J := {pick_i s|s :e F}.
claim HJfin: finite J.
{ exact (Repl_finite (fun s:set => pick_i s) F HFfin). }
claim HJsub: J c= omega.
{ let j. assume Hj: j :e J.
  prove j :e omega.
  apply (ReplE_impred F (fun s:set => pick_i s) j Hj (j :e omega)).
  let s. assume HsF: s :e F.
  assume Hjeq: j = pick_i s.
  rewrite Hjeq.
  exact (Hpick_omega s HsF). }

(** Choose n bounding all picked indices. **)
claim Hexn: exists n :e omega, forall m :e J, m :e n.
{ exact (finite_subset_of_omega_bounded J HJsub HJfin). }
apply Hexn.
let n.
assume Hnand.
claim HnO: n :e omega.
{ exact (andEL (n :e omega) (forall m :e J, m :e n) Hnand). }
claim Hnprop: forall m :e J, m :e n.
{ exact (andER (n :e omega) (forall m :e J, m :e n) Hnand). }

(** Define a truncation of x: keep x on indices in n, and 0 beyond n. **)
set h := fun i:set => If_i (n :e i) 0 (apply_fun x i).
set f := graph omega h.

claim HhR: forall i:set, i :e omega -> h i :e R.
{ let i. assume Hi: i :e omega.
  prove h i :e R.
  claim Hhdef: h i = If_i (n :e i) 0 (apply_fun x i).
  { reflexivity. }
  apply (xm (n :e i)).
  - assume Hni: n :e i.
    rewrite Hhdef.
    rewrite (If_i_1 (n :e i) 0 (apply_fun x i) Hni).
    exact real_0.
  - assume Hnni: ~(n :e i).
    rewrite Hhdef.
    rewrite (If_i_0 (n :e i) 0 (apply_fun x i) Hnni).
    exact (Romega_coord_in_R x i HxX Hi). }

claim HfX: f :e X.
{ exact (graph_omega_in_Romega_space h HhR). }

(** f is eventually zero from index n onward, hence lies in Romega_infty. **)
claim Hftilde: f :e Romega_tilde n.
{ prove f :e Romega_tilde n.
  prove f :e {f0 :e X | forall i:set, i :e omega -> n :e i -> apply_fun f0 i = 0}.
  apply (SepI X (fun f0:set => forall i:set, i :e omega -> n :e i -> apply_fun f0 i = 0) f HfX).
  let i. assume Hi: i :e omega. assume Hni: n :e i.
  prove apply_fun f i = 0.
  claim Happ: apply_fun f i = h i.
  { exact (apply_fun_graph omega h i Hi). }
  rewrite Happ.
  claim Hhdef: h i = If_i (n :e i) 0 (apply_fun x i).
  { reflexivity. }
  rewrite Hhdef.
  rewrite (If_i_1 (n :e i) 0 (apply_fun x i) Hni).
  reflexivity. }
claim HfA: f :e Romega_infty.
{ prove f :e Romega_infty.
  set Y := Romega_tilde n.
  claim HYn: Y :e {Romega_tilde k|k :e omega}.
  { exact (ReplI omega (fun k:set => Romega_tilde k) n HnO). }
  exact (UnionI {Romega_tilde k|k :e omega} f Y Hftilde HYn). }

(** Show f lies in the intersection_of_family X F, hence in b. **)
claim HfInt: f :e intersection_of_family X F.
{ prove f :e intersection_of_family X F.
  prove f :e {x0 :e X|forall U:set, U :e F -> x0 :e U}.
  apply (SepI X (fun x0:set => forall U:set, U :e F -> x0 :e U) f HfX).
  let s. assume HsF: s :e F.
  prove f :e s.
  (** Expand s as a product_cylinder at coordinate pick_i s. **)
  claim HsCyl: s :e CylFam (pick_i s).
  { exact (Hpick_in s HsF). }
  apply (ReplE_impred (space_family_topology Xi (pick_i s))
          (fun U:set => product_cylinder omega Xi (pick_i s) U)
          s
          HsCyl
          (f :e s)).
  let U.
  assume HU: U :e space_family_topology Xi (pick_i s).
  assume Hseq: s = product_cylinder omega Xi (pick_i s) U.
  rewrite Hseq.
  (** Extract that x satisfies this cylinder, hence x(pick_i s) :e U. **)
  claim Hxs: x :e s.
  { exact (HxAll s HsF). }
  claim HxCyl: x :e product_cylinder omega Xi (pick_i s) U.
  { rewrite <- Hseq.
    exact Hxs. }
  claim Hxcylprop: (pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s)) /\ apply_fun x (pick_i s) :e U.
  { exact (SepE2 (product_space omega Xi)
                 (fun f0:set => (pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s)) /\ apply_fun f0 (pick_i s) :e U)
                 x
                 HxCyl). }
  claim HxUi: apply_fun x (pick_i s) :e U.
  { exact (andER (pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s))
                 (apply_fun x (pick_i s) :e U)
                 Hxcylprop). }
  (** Show apply_fun f (pick_i s) equals apply_fun x (pick_i s). **)
  claim Hidx: pick_i s :e omega.
  { exact (Hpick_omega s HsF). }
  claim HidxJ: pick_i s :e J.
  { exact (ReplI F (fun s0:set => pick_i s0) s HsF). }
  claim Hidxn: pick_i s :e n.
  { exact (Hnprop (pick_i s) HidxJ). }
  claim Hnot_nin: ~(n :e pick_i s).
  { assume Hnin: n :e pick_i s.
    exact (In_no2cycle (pick_i s) n Hidxn Hnin). }
  (** Conclude f is in the cylinder by the defining Sep predicate. **)
  prove f :e product_cylinder omega Xi (pick_i s) U.
  prove f :e {f0 :e product_space omega Xi | pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s) /\ apply_fun f0 (pick_i s) :e U}.
  claim HfProd: f :e product_space omega Xi.
  { exact HfX. }
  claim Hpropf: pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s) /\ apply_fun f (pick_i s) :e U.
  { apply andI.
    - apply andI.
      + exact Hidx.
      + exact HU.
    - prove apply_fun f (pick_i s) :e U.
      claim Happf: apply_fun f (pick_i s) = h (pick_i s).
      { exact (apply_fun_graph omega h (pick_i s) Hidx). }
      rewrite Happf.
      claim Hhdef: h (pick_i s) = If_i (n :e pick_i s) 0 (apply_fun x (pick_i s)).
      { reflexivity. }
      rewrite Hhdef.
      claim Hif: If_i (n :e pick_i s) 0 (apply_fun x (pick_i s)) = apply_fun x (pick_i s).
      { exact (If_i_0 (n :e pick_i s) 0 (apply_fun x (pick_i s)) Hnot_nin). }
      rewrite Hif.
      exact HxUi. }
  exact (SepI (product_space omega Xi)
        (fun f0:set => pick_i s :e omega /\ U :e space_family_topology Xi (pick_i s) /\ apply_fun f0 (pick_i s) :e U)
        f
        HfProd
        Hpropf). }

(** Conclude the intersection b meets Romega_infty by exhibiting f. **)
assume Hempty: (intersection_of_family X F) :/\: Romega_infty = Empty.
prove False.
claim HfB: f :e intersection_of_family X F.
{ exact HfInt. }
claim HfBA: f :e (intersection_of_family X F) :/\: Romega_infty.
{ exact (binintersectI (intersection_of_family X F) Romega_infty f HfB HfA). }
claim HfE: f :e Empty.
{ claim HsubE: (intersection_of_family X F) :/\: Romega_infty c= Empty.
  { rewrite Hempty.
    exact (Subq_ref Empty). }
  exact (HsubE f HfBA). }
exact (EmptyE f HfE).
Qed.

(** Helper: basis neighborhoods in the product topology meet Romega_tilde 0 via singleton sequences **)
(** LATEX VERSION: Any basic open neighborhood of a point with all nonzero coordinates 0 contains a singleton sequence (r,0,0,...). **)
Theorem Romega_tilde0_meets_product_basis : forall b x:set,
  b :e basis_of_subbasis R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)) ->
  x :e Romega_tilde 0 ->
  x :e b ->
  b :/\: image_of Romega_singleton_map R <> Empty.
let b x.
assume Hb: b :e basis_of_subbasis R_omega_space (product_subbasis_full omega (const_space_family omega R R_standard_topology)).
assume Hx0: x :e Romega_tilde 0.
assume Hxb: x :e b.
prove b :/\: image_of Romega_singleton_map R <> Empty.
set X := R_omega_space.
set Xi := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi.
set B := basis_of_subbasis X S.
claim HbB: b :e B.
{ exact Hb. }
(** Unpack basis_of_subbasis membership. **)
claim Hbfin: b :e finite_intersections_of X S.
{ exact (SepE1 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b HbB). }
apply (ReplE_impred (finite_subcollections S) (fun F0:set => intersection_of_family X F0) b Hbfin
        (b :/\: image_of Romega_singleton_map R <> Empty)).
let F.
assume HF: F :e finite_subcollections S.
assume Hbeq: b = intersection_of_family X F.
rewrite Hbeq at 1.
(** Extract basic properties of F. **)
claim HFpow: F :e Power S.
{ exact (SepE1 (Power S) (fun F0:set => finite F0) F HF). }
claim HFsubS: F c= S.
{ exact (PowerE S F HFpow). }
(** x lies in the intersection, hence in X and in every s in F. **)
claim HxInt: x :e intersection_of_family X F.
{ rewrite <- Hbeq.
  exact Hxb. }
claim HxX: x :e X.
{ exact (SepE1 X (fun x0 : set => forall U:set, U :e F -> x0 :e U) x HxInt). }
claim HxAll: forall s:set, s :e F -> x :e s.
{ exact (SepE2 X (fun x0 : set => forall U:set, U :e F -> x0 :e U) x HxInt). }
(** Extract the defining property of x :e Romega_tilde 0. **)
claim Hx0prop: forall i:set, i :e omega -> 0 :e i -> apply_fun x i = 0.
{ exact (SepE2 X (fun f0:set => forall i:set, i :e omega -> 0 :e i -> apply_fun f0 i = 0) x Hx0). }
(** Define r to be the 0th coordinate of x. **)
set r := apply_fun x 0.
claim H0o: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim HrR: r :e R.
{ exact (Romega_coord_in_R x 0 HxX H0o). }
set f := apply_fun Romega_singleton_map r.
claim HfX: f :e X.
{ rewrite (Romega_singleton_map_apply r HrR).
  exact (Romega_singleton_seq_in_Romega_space r HrR). }
claim HfImg: f :e image_of Romega_singleton_map R.
{ claim Hfeq: f = apply_fun Romega_singleton_map r.
  { reflexivity. }
  rewrite Hfeq.
  exact (ReplI R (fun a:set => apply_fun Romega_singleton_map a) r HrR). }
(** Show f :e intersection_of_family X F by showing f is in every s in F. **)
claim HfInt: f :e intersection_of_family X F.
{ prove f :e intersection_of_family X F.
  prove f :e {x0 :e X|forall U:set, U :e F -> x0 :e U}.
  apply (SepI X (fun x0:set => forall U:set, U :e F -> x0 :e U) f HfX).
  let s. assume HsF: s :e F.
  prove f :e s.
  claim HsS: s :e S.
  { exact (HFsubS s HsF). }
  set CylFam := (fun i:set => {product_cylinder omega Xi i U|U :e space_family_topology Xi i}).
  claim HsCyl: s :e (\/_ i :e omega, CylFam i).
  { exact HsS. }
  apply (famunionE_impred omega CylFam s HsCyl (f :e s)).
  let i. assume Hi: i :e omega.
  assume HsFi: s :e CylFam i.
  apply (ReplE_impred (space_family_topology Xi i) (fun U0:set => product_cylinder omega Xi i U0) s HsFi (f :e s)).
  let U.
  assume HU: U :e space_family_topology Xi i.
  assume Hseq: s = product_cylinder omega Xi i U.
  rewrite Hseq.
  prove f :e product_cylinder omega Xi i U.
  prove f :e {f0 :e product_space omega Xi | i :e omega /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U}.
  claim HfProd: f :e product_space omega Xi.
  { exact HfX. }
  claim Hpropf: i :e omega /\ U :e space_family_topology Xi i /\ apply_fun f i :e U.
  { apply andI.
    - apply andI.
      + exact Hi.
      + exact HU.
    - prove apply_fun f i :e U.
      (** Use that x is in this cylinder, and x :e Romega_tilde 0, to show the singleton sequence matches x at i. **)
      claim Hxs: x :e s.
      { exact (HxAll s HsF). }
      claim HxCyl: x :e product_cylinder omega Xi i U.
      { rewrite <- Hseq.
        exact Hxs. }
      claim Hxcylprop: (i :e omega /\ U :e space_family_topology Xi i) /\ apply_fun x i :e U.
      { exact (SepE2 (product_space omega Xi)
                     (fun f0:set => (i :e omega /\ U :e space_family_topology Xi i) /\ apply_fun f0 i :e U)
                     x
                     HxCyl). }
      claim HxUi: apply_fun x i :e U.
      { exact (andER (i :e omega /\ U :e space_family_topology Xi i)
                     (apply_fun x i :e U)
                     Hxcylprop). }
      (** Rewrite apply_fun f i using the singleton map. **)
      rewrite (Romega_singleton_map_apply r HrR).
      rewrite (Romega_singleton_seq_apply r i HrR Hi).
      claim Hnat: nat_p i.
      { exact (omega_nat_p i Hi). }
      (** Case split on i = 0 or i = ordsucc k. **)
      apply (nat_inv i Hnat).
      - assume Hieq0: i = 0.
        rewrite Hieq0.
        claim Hnot0in0: ~(0 :e 0).
        { assume H0in0: 0 :e 0.
          prove False.
          exact (EmptyE 0 H0in0). }
        rewrite (If_i_0 (0 :e 0) 0 r Hnot0in0).
        claim HxUi0: apply_fun x 0 :e U.
        { rewrite <- Hieq0.
          exact HxUi. }
        claim Hreq: r = apply_fun x 0.
        { reflexivity. }
        rewrite Hreq.
        exact HxUi0.
      - assume Hexk: exists k:set, nat_p k /\ i = ordsucc k.
        apply Hexk.
        let k. assume Hkconj: nat_p k /\ i = ordsucc k.
        claim HkNat: nat_p k.
        { exact (andEL (nat_p k) (i = ordsucc k) Hkconj). }
        claim Hieq: i = ordsucc k.
        { exact (andER (nat_p k) (i = ordsucc k) Hkconj). }
        claim H0in: 0 :e i.
        { rewrite Hieq.
          exact (nat_0_in_ordsucc k HkNat). }
        rewrite (If_i_1 (0 :e i) 0 r H0in).
        claim Hxcoord0: apply_fun x i = 0.
        { exact (Hx0prop i Hi H0in). }
        rewrite <- Hxcoord0.
        exact HxUi.
  }
  exact (SepI (product_space omega Xi)
              (fun f0:set => i :e omega /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
              f
              HfProd
              Hpropf).
}
(** Conclude the intersection is nonempty by exhibiting f. **)
assume Hempty: (intersection_of_family X F) :/\: image_of Romega_singleton_map R = Empty.
prove False.
claim HfBA: f :e (intersection_of_family X F) :/\: image_of Romega_singleton_map R.
{ exact (binintersectI (intersection_of_family X F) (image_of Romega_singleton_map R) f HfInt HfImg). }
claim HfE: f :e Empty.
{ claim HsubE: (intersection_of_family X F) :/\: image_of Romega_singleton_map R c= Empty.
  { rewrite Hempty.
    exact (Subq_ref Empty). }
  exact (HsubE f HfBA). }
exact (EmptyE f HfE).
Qed.

(** Helper: singleton sequences are dense in Romega_tilde 0 (in the product topology) **)
(** LATEX VERSION: Any basic neighborhood of a point in R^0~ meets the set of singleton sequences. **)
Theorem Romega_tilde0_singletons_dense_in_subspace :
  closure_of (Romega_tilde 0)
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde 0))
    (image_of Romega_singleton_map R) =
  Romega_tilde 0.
prove closure_of (Romega_tilde 0)
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde 0))
    (image_of Romega_singleton_map R) =
  Romega_tilde 0.
set X := R_omega_space.
set Tx := R_omega_product_topology.
set Y := Romega_tilde 0.
set A := image_of Romega_singleton_map R.
claim HTx: topology_on X Tx.
{ exact Romega_product_topology_is_topology. }
claim HYsub: Y c= X.
{ exact (Romega_tilde_sub_Romega 0). }
claim HAsubY: A c= Y.
{ exact image_of_Romega_singleton_map_sub_Romega_tilde0. }
(** closure in subspace = ambient closure intersect subspace **)
claim HclEq: closure_of Y (subspace_topology X Tx Y) A = (closure_of X Tx A) :/\: Y.
{ exact (closure_in_subspace X Tx Y A HTx HYsub HAsubY). }
rewrite HclEq.
apply set_ext.
- let z. assume Hz: z :e (closure_of X Tx A) :/\: Y.
  exact (binintersectE2 (closure_of X Tx A) Y z Hz).
- let y. assume Hy: y :e Y.
  prove y :e (closure_of X Tx A) :/\: Y.
  apply binintersectI.
  + (** Show y :e closure_of X Tx A by the neighborhood characterization using a product basis element **)
    prove y :e closure_of X Tx A.
    (** Use defining Sep condition for closure_of X Tx A **)
    claim HyCond: forall U:set, U :e Tx -> y :e U -> U :/\: A <> Empty.
    { let U. assume HU: U :e Tx.
      assume HyU: y :e U.
      prove U :/\: A <> Empty.
      set S := product_subbasis_full omega (const_space_family omega R R_standard_topology).
      set B := basis_of_subbasis X S.
      claim HUl: forall z :e U, exists b0 :e B, z :e b0 /\ b0 c= U.
      { exact (SepE2 (Power X)
                    (fun U0:set => forall z :e U0, exists b0 :e B, z :e b0 /\ b0 c= U0)
                    U
                    HU). }
      apply (HUl y HyU).
      let b0. assume Hb0pair.
      claim Hb0B: b0 :e B.
      { exact (andEL (b0 :e B) (y :e b0 /\ b0 c= U) Hb0pair). }
      claim Hyb0sub: y :e b0 /\ b0 c= U.
      { exact (andER (b0 :e B) (y :e b0 /\ b0 c= U) Hb0pair). }
      claim Hyb0: y :e b0.
      { exact (andEL (y :e b0) (b0 c= U) Hyb0sub). }
      claim Hb0subU: b0 c= U.
      { exact (andER (y :e b0) (b0 c= U) Hyb0sub). }
      claim Hb0neA: b0 :/\: A <> Empty.
      { exact (Romega_tilde0_meets_product_basis b0 y Hb0B Hy Hyb0). }
      (** If b0 ∩ A is nonempty and b0 ⊆ U then U ∩ A is nonempty. **)
      assume HUAempty: U :/\: A = Empty.
      claim Hb0A_sub: b0 :/\: A c= U :/\: A.
      { let z. assume Hz: z :e b0 :/\: A.
        claim Hzb0: z :e b0.
        { exact (binintersectE1 b0 A z Hz). }
        claim HzA: z :e A.
        { exact (binintersectE2 b0 A z Hz). }
        claim HzU0: z :e U.
        { exact (Hb0subU z Hzb0). }
        exact (binintersectI U A z HzU0 HzA). }
      claim Hb0A_empty: b0 :/\: A = Empty.
      { apply Empty_Subq_eq.
        claim HUAE: U :/\: A c= Empty.
        { rewrite HUAempty.
          exact (Subq_ref Empty). }
        exact (Subq_tra (b0 :/\: A) (U :/\: A) Empty Hb0A_sub HUAE). }
      exact (Hb0neA Hb0A_empty). }
    exact (SepI X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) y (HYsub y Hy) HyCond).
  + exact Hy.
Qed.

(** Helper: Romega_tilde 0 is connected as closure of a connected subset **)
(** LATEX VERSION: The image of R under the singleton map is connected and dense in R^0~, so R^0~ is connected. **)
Theorem Romega_tilde0_connected :
  connected_space (Romega_tilde 0)
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde 0)).
prove connected_space (Romega_tilde 0)
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde 0)).
set X := R_omega_space.
set Tx := R_omega_product_topology.
set Y := Romega_tilde 0.
set Ty := subspace_topology X Tx Y.
set A := image_of Romega_singleton_map R.
claim HTx: topology_on X Tx.
{ exact Romega_product_topology_is_topology. }
claim HYsub: Y c= X.
{ exact (Romega_tilde_sub_Romega 0). }
claim HTy: topology_on Y Ty.
{ exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
claim HAsubY: A c= Y.
{ exact image_of_Romega_singleton_map_sub_Romega_tilde0. }
claim HAconnX: connected_space A (subspace_topology X Tx A).
{ claim HRconn: connected_space R R_standard_topology.
  { exact interval_connected. }
  claim Hcont: continuous_map R R_standard_topology X Tx Romega_singleton_map.
  { exact Romega_singleton_map_continuous_prod. }
  exact (continuous_image_connected R R_standard_topology X Tx Romega_singleton_map HRconn Hcont). }
claim HsubEq: subspace_topology Y Ty A = subspace_topology X Tx A.
{ exact (ex16_1_subspace_transitive X Tx Y A HTx HYsub HAsubY). }
claim HAconn: connected_space A (subspace_topology Y Ty A).
{ rewrite HsubEq.
  exact HAconnX. }
claim Hdense: closure_of Y Ty A = Y.
{ exact Romega_tilde0_singletons_dense_in_subspace. }
exact (connected_space_if_dense_connected_subset Y Ty A HTy HAsubY HAconn Hdense).
Qed.

(** from §23 Example 7: each Romega_tilde n is connected in the product topology **) 
(** LATEX VERSION: Each R^n is connected, hence the subspace of sequences supported on {0,...,n} is connected. **)
Theorem Romega_tilde_connected : forall n:set,
  n :e omega ->
  connected_space (Romega_tilde n)
    (subspace_topology R_omega_space R_omega_product_topology (Romega_tilde n)).
let n. assume HnO: n :e omega.
set X := R_omega_space.
set Tx := R_omega_product_topology.
prove connected_space (Romega_tilde n) (subspace_topology X Tx (Romega_tilde n)).
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnO). }
(** Induction on n. Romega_tilde n corresponds to sequences supported on {0,...,n}. **)
apply (nat_ind (fun k:set => connected_space (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k)))).
- (** Base: k = 0. **)
  exact Romega_tilde0_connected.
- (** Step: k -> ordsucc k. **)
  let k. assume HkNat: nat_p k.
  assume IHk: connected_space (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k)).
  prove connected_space (Romega_tilde (ordsucc k)) (subspace_topology X Tx (Romega_tilde (ordsucc k))).
  claim HkO: k :e omega.
  { exact (nat_p_omega k HkNat). }
  claim HRconn: connected_space R R_standard_topology.
  { exact interval_connected. }
  claim Hprod:
    connected_space (setprod (Romega_tilde k) R)
      (product_topology (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k)) R R_standard_topology).
  { exact (finite_product_connected (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k))
                                   R R_standard_topology IHk HRconn). }
  claim Hhom:
    homeomorphism
      (setprod (Romega_tilde k) R)
      (product_topology (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k)) R R_standard_topology)
      (Romega_tilde (ordsucc k))
      (subspace_topology X Tx (Romega_tilde (ordsucc k)))
      (Romega_extend_map k).
  { exact (Romega_tilde_succ_homeomorphism k HkO). }
  exact (homeomorphism_preserves_connected
          (setprod (Romega_tilde k) R)
          (product_topology (Romega_tilde k) (subspace_topology X Tx (Romega_tilde k)) R R_standard_topology)
          (Romega_tilde (ordsucc k))
          (subspace_topology X Tx (Romega_tilde (ordsucc k)))
          (Romega_extend_map k)
          Hhom
          Hprod).
- exact HnNat.
Qed.

(** from §23 Example 7: Romega_infty is connected as a union of connected sets with a common point **) 
(** LATEX VERSION: R^infty is the union of the connected subspaces R^n and they share the zero sequence. **)
Theorem Romega_infty_connected :
  connected_space Romega_infty
    (subspace_topology R_omega_space R_omega_product_topology Romega_infty).
prove connected_space Romega_infty (subspace_topology R_omega_space R_omega_product_topology Romega_infty).
set X := R_omega_space.
set Tx := R_omega_product_topology.
set F := {Romega_tilde n|n :e omega}.
claim HTx: topology_on X Tx.
{ exact Romega_product_topology_is_topology. }
claim HFsub: forall C:set, C :e F -> C c= X.
{ let C. assume HC: C :e F.
  prove C c= X.
  apply (ReplE_impred omega (fun n:set => Romega_tilde n) C HC (C c= X)).
  let n. assume Hn: n :e omega. assume HCeq: C = Romega_tilde n.
  rewrite HCeq.
  exact (Romega_tilde_sub_Romega n). }
claim HFconn: forall C:set, C :e F -> connected_space C (subspace_topology X Tx C).
{ let C. assume HC: C :e F.
  prove connected_space C (subspace_topology X Tx C).
  apply (ReplE_impred omega (fun n:set => Romega_tilde n) C HC (connected_space C (subspace_topology X Tx C))).
  let n. assume Hn: n :e omega. assume HCeq: C = Romega_tilde n.
  rewrite HCeq.
  exact (Romega_tilde_connected n Hn). }
claim Hcommon: exists x:set, forall C:set, C :e F -> x :e C.
{ witness Romega_zero.
  let C. assume HC: C :e F.
  prove Romega_zero :e C.
  apply (ReplE_impred omega (fun n:set => Romega_tilde n) C HC (Romega_zero :e C)).
  let n. assume Hn: n :e omega. assume HCeq: C = Romega_tilde n.
  rewrite HCeq.
  exact (Romega_zero_in_Romega_tilde n Hn). }
claim HconnUnion: connected_space (Union F) (subspace_topology X Tx (Union F)).
{ exact (union_connected_common_point X Tx F HTx HFsub HFconn Hcommon). }
claim HUnionEq: Union F = Romega_infty.
{ reflexivity. }
rewrite HUnionEq.
rewrite HUnionEq at 1.
exact HconnUnion.
Qed.

(** from §23 Example 7: Romega_infty is dense in the product topology **) 
(** LATEX VERSION: Every basic open set in the product topology meets R^infty by modifying only finitely many coordinates. **)
Theorem Romega_infty_dense :
  closure_of R_omega_space R_omega_product_topology Romega_infty = R_omega_space.
prove closure_of R_omega_space R_omega_product_topology Romega_infty = R_omega_space.
apply set_ext.
- exact (closure_in_space R_omega_space R_omega_product_topology Romega_infty Romega_product_topology_is_topology).
- let x. assume Hx: x :e R_omega_space.
  prove x :e closure_of R_omega_space R_omega_product_topology Romega_infty.
  (** Use the defining Sep condition for closure_of. **)
  claim Hcond: forall U:set, U :e R_omega_product_topology -> x :e U -> U :/\: Romega_infty <> Empty.
  { let U. assume HU: U :e R_omega_product_topology.
    assume HxU: x :e U.
    prove U :/\: Romega_infty <> Empty.
    (** Reduce to a basis element b inside U containing x. **)
    set S := product_subbasis_full omega (const_space_family omega R R_standard_topology).
    set B := basis_of_subbasis R_omega_space S.
    claim HUpow: U :e Power R_omega_space.
    { exact (SepE1 (Power R_omega_space)
                  (fun U0:set => forall y :e U0, exists b0 :e B, y :e b0 /\ b0 c= U0)
                  U
                  HU). }
    claim HUl: forall y :e U, exists b0 :e B, y :e b0 /\ b0 c= U.
    { exact (SepE2 (Power R_omega_space)
                  (fun U0:set => forall y :e U0, exists b0 :e B, y :e b0 /\ b0 c= U0)
                  U
                  HU). }
    apply (HUl x HxU).
    let b0. assume Hb0pair.
    claim Hb0B: b0 :e B.
    { exact (andEL (b0 :e B) (x :e b0 /\ b0 c= U) Hb0pair). }
    claim Hb0xu: x :e b0 /\ b0 c= U.
    { exact (andER (b0 :e B) (x :e b0 /\ b0 c= U) Hb0pair). }
    claim Hxb0: x :e b0.
    { exact (andEL (x :e b0) (b0 c= U) Hb0xu). }
    claim Hb0subU: b0 c= U.
    { exact (andER (x :e b0) (b0 c= U) Hb0xu). }
    claim Hb0neA: b0 :/\: Romega_infty <> Empty.
    { exact (Romega_infty_meets_product_basis b0 x Hb0B Hxb0). }
    (** If b0 ∩ A is nonempty and b0 ⊆ U then U ∩ A is nonempty. **)
    assume HUAempty: U :/\: Romega_infty = Empty.
    claim Hb0A_sub: b0 :/\: Romega_infty c= U :/\: Romega_infty.
    { let y. assume Hy: y :e b0 :/\: Romega_infty.
      claim Hyb0: y :e b0.
      { exact (binintersectE1 b0 Romega_infty y Hy). }
      claim HyA: y :e Romega_infty.
      { exact (binintersectE2 b0 Romega_infty y Hy). }
      claim HyU: y :e U.
      { exact (Hb0subU y Hyb0). }
      exact (binintersectI U Romega_infty y HyU HyA). }
    claim Hb0A_empty: b0 :/\: Romega_infty = Empty.
    { apply Empty_Subq_eq.
      claim HUAE: U :/\: Romega_infty c= Empty.
      { let y. assume Hy: y :e U :/\: Romega_infty.
        prove y :e Empty.
        rewrite <- HUAempty.
        exact Hy. }
      exact (Subq_tra (b0 :/\: Romega_infty) (U :/\: Romega_infty) Empty Hb0A_sub HUAE). }
    exact (Hb0neA Hb0A_empty). }
exact (SepI R_omega_space
            (fun x0 => forall U:set, U :e R_omega_product_topology -> x0 :e U -> U :/\: Romega_infty <> Empty)
            x
            Hx
            Hcond).
Qed.

Theorem R_omega_product_connected :
  connected_space (product_space omega (const_space_family omega R R_standard_topology))
    (product_topology_full omega (const_space_family omega R R_standard_topology)).
prove connected_space (product_space omega (const_space_family omega R R_standard_topology))
    (product_topology_full omega (const_space_family omega R R_standard_topology)).
set Xi := const_space_family omega R R_standard_topology.
set X := product_space omega Xi.
set Tx := product_topology_full omega Xi.
set A := Romega_infty.
claim HTx: topology_on X Tx.
{ exact Romega_product_topology_is_topology. }
claim HAsub: A c= X.
{ exact Romega_infty_sub_Romega. }
claim HAconn: connected_space A (subspace_topology X Tx A).
{ exact Romega_infty_connected. }
claim Hdense: closure_of X Tx A = X.
{ exact Romega_infty_dense. }
exact (connected_space_if_dense_connected_subset X Tx A HTx HAsub HAconn Hdense).
Qed.

(** from §24 Definition: path and path connectedness **) 
(** LATEX VERSION: A path from x to y is a map p:[0,1] to X with p(0)=x and p(1)=y; X is path connected if every two points can be joined by a path. **)
Definition path_between : set -> set -> set -> set -> prop := fun X x y p =>
  function_on p unit_interval X /\
  apply_fun p 0 = x /\ apply_fun p 1 = y.
Definition path_connected_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x y:set, x :e X -> y :e X ->
    exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.

(** Helper: extract function and endpoints from path_between **)
Theorem path_between_pair0 : forall X x y p:set,
  path_between X x y p -> function_on p unit_interval X /\ apply_fun p 0 = x.
let X x y p.
assume H: path_between X x y p.
exact (andEL (function_on p unit_interval X /\ apply_fun p 0 = x)
             (apply_fun p 1 = y)
             H).
Qed.

Theorem path_between_function_on : forall X x y p:set,
  path_between X x y p -> function_on p unit_interval X.
let X x y p.
assume H: path_between X x y p.
claim H0: function_on p unit_interval X /\ apply_fun p 0 = x.
{ exact (path_between_pair0 X x y p H). }
exact (andEL (function_on p unit_interval X) (apply_fun p 0 = x) H0).
Qed.

Theorem path_between_at_zero : forall X x y p:set,
  path_between X x y p -> apply_fun p 0 = x.
let X x y p.
assume H: path_between X x y p.
claim H0: function_on p unit_interval X /\ apply_fun p 0 = x.
{ exact (path_between_pair0 X x y p H). }
exact (andER (function_on p unit_interval X) (apply_fun p 0 = x) H0).
Qed.

Theorem path_between_at_one : forall X x y p:set,
  path_between X x y p -> apply_fun p 1 = y.
let X x y p.
assume H: path_between X x y p.
exact (andER (function_on p unit_interval X /\ apply_fun p 0 = x)
             (apply_fun p 1 = y)
             H).
Qed.

Theorem path_betweenI : forall X x y p:set,
  function_on p unit_interval X ->
  apply_fun p 0 = x ->
  apply_fun p 1 = y ->
  path_between X x y p.
let X x y p.
assume Hfun: function_on p unit_interval X.
assume H0: apply_fun p 0 = x.
assume H1: apply_fun p 1 = y.
claim Hpair0: function_on p unit_interval X /\ apply_fun p 0 = x.
{ exact (andI (function_on p unit_interval X) (apply_fun p 0 = x) Hfun H0). }
exact (andI (function_on p unit_interval X /\ apply_fun p 0 = x) (apply_fun p 1 = y) Hpair0 H1).
Qed.

(** Helper: split a path witness pair (path_between and continuity) **)
Theorem path_witness_between : forall X Tx x y p:set,
  (path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p) ->
  path_between X x y p.
let X Tx x y p.
assume H: path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
exact (andEL (path_between X x y p)
             (continuous_map unit_interval unit_interval_topology X Tx p)
             H).
Qed.

Theorem path_witness_continuous : forall X Tx x y p:set,
  (path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p) ->
  continuous_map unit_interval unit_interval_topology X Tx p.
let X Tx x y p.
assume H: path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
exact (andER (path_between X x y p)
             (continuous_map unit_interval unit_interval_topology X Tx p)
             H).
Qed.

(** Helper: extract topology_on from path_connected_space **)
Theorem path_connected_space_topology : forall X Tx:set,
  path_connected_space X Tx -> topology_on X Tx.
let X Tx.
assume H: path_connected_space X Tx.
exact (andEL (topology_on X Tx)
             (forall x y:set, x :e X -> y :e X ->
               exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p)
             H).
Qed.

(** Helper: extract existence of paths from path_connected_space **)
Theorem path_connected_space_paths : forall X Tx x y:set,
  path_connected_space X Tx -> x :e X -> y :e X ->
  exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
let X Tx x y.
assume H: path_connected_space X Tx.
assume Hx: x :e X.
assume Hy: y :e X.
claim Hpaths: forall x0 y0:set, x0 :e X -> y0 :e X ->
  exists p:set, path_between X x0 y0 p /\ continuous_map unit_interval unit_interval_topology X Tx p.
{ exact (andER (topology_on X Tx)
               (forall x0 y0:set, x0 :e X -> y0 :e X ->
                 exists p:set, path_between X x0 y0 p /\ continuous_map unit_interval unit_interval_topology X Tx p)
               H). }
exact (Hpaths x y Hx Hy).
Qed.

(** Helper axioms for path_connected_implies_connected **)
Theorem unit_interval_connected : connected_space unit_interval unit_interval_topology.
prove topology_on unit_interval unit_interval_topology /\
  ~(exists U V:set, U :e unit_interval_topology /\ V :e unit_interval_topology /\ separation_of unit_interval U V).
apply andI.
- exact unit_interval_topology_on.
- assume Hsep: exists U V:set, U :e unit_interval_topology /\ V :e unit_interval_topology /\ separation_of unit_interval U V.
  (** Destructure the separation (as in interval_connected) and defer the order argument. **)
  apply Hsep.
  let U. assume HexV: exists V:set, U :e unit_interval_topology /\ V :e unit_interval_topology /\ separation_of unit_interval U V.
  apply HexV.
  let V. assume HUV: U :e unit_interval_topology /\ V :e unit_interval_topology /\ separation_of unit_interval U V.
  claim HUV0: U :e unit_interval_topology /\ V :e unit_interval_topology.
  { exact (andEL (U :e unit_interval_topology /\ V :e unit_interval_topology)
                 (separation_of unit_interval U V)
                 HUV). }
  claim HUopen: U :e unit_interval_topology.
  { exact (andEL (U :e unit_interval_topology) (V :e unit_interval_topology) HUV0). }
  claim HVopen: V :e unit_interval_topology.
  { exact (andER (U :e unit_interval_topology) (V :e unit_interval_topology) HUV0). }
  claim HsepUV: separation_of unit_interval U V.
  { exact (andER (U :e unit_interval_topology /\ V :e unit_interval_topology)
                 (separation_of unit_interval U V)
                 HUV). }
  claim Hpart1: ((((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = unit_interval)
                 HsepUV). }
  claim Hunion: U :\/: V = unit_interval.
  { exact (andER ((((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = unit_interval)
                 HsepUV). }
  claim HAux: (((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty).
  { exact (andEL (((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty)
                 Hpart1). }
  claim HVne: V <> Empty.
  { exact (andER (((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty)
                 Hpart1). }
  claim Hpowdisj: (U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty)
                 (U <> Empty)
                 HAux). }
  claim HUne: U <> Empty.
  { exact (andER ((U :e Power unit_interval /\ V :e Power unit_interval) /\ U :/\: V = Empty)
                 (U <> Empty)
                 HAux). }
  claim Hpow: U :e Power unit_interval /\ V :e Power unit_interval.
  { exact (andEL (U :e Power unit_interval /\ V :e Power unit_interval)
                 (U :/\: V = Empty)
                 Hpowdisj). }
  claim Hdisj: U :/\: V = Empty.
  { exact (andER (U :e Power unit_interval /\ V :e Power unit_interval)
                 (U :/\: V = Empty)
                 Hpowdisj). }
  claim HUpow: U :e Power unit_interval.
  { exact (andEL (U :e Power unit_interval) (V :e Power unit_interval) Hpow). }
  claim HVpow: V :e Power unit_interval.
  { exact (andER (U :e Power unit_interval) (V :e Power unit_interval) Hpow). }
  claim HUsub: U c= unit_interval.
  { exact (PowerE unit_interval U HUpow). }
  claim HVsub: V c= unit_interval.
  { exact (PowerE unit_interval V HVpow). }
  claim Hexu0: exists u0:set, u0 :e U.
  { exact (nonempty_has_element U HUne). }
  claim Hexv0: exists v0:set, v0 :e V.
  { exact (nonempty_has_element V HVne). }
  (** Begin the standard connectedness contradiction argument (as in interval_connected). **)
  apply Hexu0.
  let u0. assume Hu0U: u0 :e U.
  apply Hexv0.
  let v0. assume Hv0V: v0 :e V.
  claim Hu0I: u0 :e unit_interval.
  { exact (HUsub u0 Hu0U). }
  claim Hv0I: v0 :e unit_interval.
  { exact (HVsub v0 Hv0V). }
  claim Hu0R: u0 :e R.
  { exact (SepE1 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) u0 Hu0I). }
  claim Hv0R: v0 :e R.
  { exact (SepE1 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) v0 Hv0I). }
  claim Hu0S: SNo u0.
  { exact (real_SNo u0 Hu0R). }
  claim Hv0S: SNo v0.
  { exact (real_SNo v0 Hv0R). }
  prove False.
  apply (SNoLt_trichotomy_or_impred u0 v0 Hu0S Hv0S False).
  - assume Hu0ltv0: u0 < v0.
    (** Adapt interval_connected to the subspace unit_interval. **)
    set A := {u :e U|Rlt u v0}.
    claim Hu0Rltv0: Rlt u0 v0.
    { exact (RltI u0 v0 Hu0R Hv0R Hu0ltv0). }
    claim Hu0inA: u0 :e A.
    { exact (SepI U (fun u:set => Rlt u v0) u0 Hu0U Hu0Rltv0). }
    claim HAinR: forall a:set, a :e A -> a :e R.
    { let a. assume HaA: a :e A.
      claim HaU: a :e U.
      { exact (SepE1 U (fun u:set => Rlt u v0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HUsub a HaU). }
      exact (unit_interval_sub_R a HaI). }
    claim Hub_ex: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
    { witness v0.
      apply andI.
      - exact Hv0R.
      - let a. assume HaA: a :e A.
        assume _. (** a :e R **)
        claim Harlt: Rlt a v0.
        { exact (SepE2 U (fun u:set => Rlt u v0) a HaA). }
        exact (Rlt_implies_Rle a v0 Harlt). }
    claim HAnen: exists a0:set, a0 :e A.
    { witness u0. exact Hu0inA. }
    claim Hexlub: exists l:set, R_lub A l.
    { exact (R_lub_exists A HAnen HAinR Hub_ex). }
    apply Hexlub.
    let l. assume Hlub: R_lub A l.
    claim HlR: l :e R.
    { exact (R_lub_in_R A l Hlub). }
    claim HlS: SNo l.
    { exact (real_SNo l HlR). }
    claim Hlubcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    claim HubA: forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hlubcore). }
    claim Hmin: forall u:set, u :e R ->
       (forall a:set, a :e A -> a :e R -> Rle a u) ->
       Rle l u.
    { exact (andER (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    claim Hlubv0: Rle l v0.
    { apply (Hmin v0 Hv0R).
      let a. assume HaA: a :e A.
      assume _. (** a :e R **)
      claim Harlt: Rlt a v0.
      { exact (SepE2 U (fun u:set => Rlt u v0) a HaA). }
      exact (Rlt_implies_Rle a v0 Harlt). }

    (** show 0 <= l and l <= 1, hence l :e unit_interval **)
    claim Hu0conj: ~(Rlt u0 0) /\ ~(Rlt 1 u0).
    { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) u0 Hu0I). }
    claim Hnlt_u0_0: ~(Rlt u0 0).
    { exact (andEL (~(Rlt u0 0)) (~(Rlt 1 u0)) Hu0conj). }
    claim Hu0ge0: Rle 0 u0.
    { exact (RleI 0 u0 real_0 Hu0R Hnlt_u0_0). }
    claim Hu0le_l: Rle u0 l.
    { exact (HubA u0 Hu0inA Hu0R). }
    claim H0le_l: Rle 0 l.
    { exact (Rle_tra 0 u0 l Hu0ge0 Hu0le_l). }
    claim H1R: 1 :e R.
    { exact real_1. }
    claim Hlub1: Rle l 1.
    { apply (Hmin 1 H1R).
      let a. assume HaA: a :e A.
      assume HaR: a :e R.
      claim HaU: a :e U.
      { exact (SepE1 U (fun u:set => Rlt u v0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HUsub a HaU). }
      claim Haconj: ~(Rlt a 0) /\ ~(Rlt 1 a).
      { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) a (HUsub a HaU)). }
      claim Hnlt_1a: ~(Rlt 1 a).
      { exact (andER (~(Rlt a 0)) (~(Rlt 1 a)) Haconj). }
      exact (RleI a 1 HaR H1R Hnlt_1a). }
    claim Hnlt_l_0: ~(Rlt l 0).
    { exact (RleE_nlt 0 l H0le_l). }
    claim Hnlt_1_l: ~(Rlt 1 l).
    { exact (RleE_nlt l 1 Hlub1). }
    claim HlI: l :e unit_interval.
    { exact (SepI R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) l HlR
             (andI (~(Rlt l 0)) (~(Rlt 1 l)) Hnlt_l_0 Hnlt_1_l)). }

    (** l ∈ U ∪ V since U ∪ V = unit_interval **)
    claim HlUV: l :e U :\/: V.
    { rewrite Hunion.
      exact HlI. }
    apply (binunionE U V l HlUV).
    + (** Case l ∈ U: derive u1∈A with l<u1, contradicting upper bound property **)
      assume HlU: l :e U.
      claim Hv0notU: v0 /:e U.
      { assume Hv0U: v0 :e U.
        claim Hv0UV: v0 :e U :/\: V.
        { exact (binintersectI U V v0 Hv0U Hv0V). }
        claim Hv0Empty: v0 :e Empty.
        { rewrite <- Hdisj.
          exact Hv0UV. }
        exact (EmptyE v0 Hv0Empty). }
      (** obtain an ambient open set Uamb with U = Uamb ∩ unit_interval **)
      claim HUopen_in: open_in unit_interval unit_interval_topology U.
      { exact (open_inI unit_interval unit_interval_topology U unit_interval_topology_on HUopen). }
      claim HexUamb: exists Uamb :e R_standard_topology, U = Uamb :/\: unit_interval.
      { exact (iffEL (open_in unit_interval unit_interval_topology U)
                     (exists Uamb :e R_standard_topology, U = Uamb :/\: unit_interval)
                     (open_in_subspace_iff R R_standard_topology unit_interval U
                        R_standard_topology_is_topology unit_interval_sub_R HUsub)
                     HUopen_in). }
      apply HexUamb.
      let Uamb. assume HUambpair: Uamb :e R_standard_topology /\ U = Uamb :/\: unit_interval.
      claim HUambOpen: Uamb :e R_standard_topology.
      { exact (andEL (Uamb :e R_standard_topology) (U = Uamb :/\: unit_interval) HUambpair). }
      claim HUeq: U = Uamb :/\: unit_interval.
      { exact (andER (Uamb :e R_standard_topology) (U = Uamb :/\: unit_interval) HUambpair). }
      claim HlUamb: l :e Uamb.
      { claim HlU2: l :e Uamb :/\: unit_interval.
        { rewrite <- HUeq.
          exact HlU. }
        exact (binintersectE1 Uamb unit_interval l HlU2). }
      (** obtain an interval (c,d) around l contained in Uamb **)
      claim Hexcd: exists c d:set,
        c :e R /\ d :e R /\
        l :e open_interval c d /\
        open_interval c d c= Uamb /\
        Rlt c l /\ Rlt l d.
      { exact (R_standard_open_refine_interval Uamb l HUambOpen HlUamb). }
      apply Hexcd.
      let c. assume Hexd.
      apply Hexd.
      let d. assume Hcdpack.
      (** destruct returned conjunction (left-associative) **)
      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l).
      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hld: Rlt l d.
      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb).
      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcl: Rlt c l.
      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Uamb)
                     Hcd2). }
      claim HIntSubUamb: open_interval c d c= Uamb.
      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Uamb)
                     Hcd2). }
      claim HcR: c :e R.
      { exact (andEL (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdR: d :e R.
      { exact (andER (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      (** show l < v0 using l ≤ v0 and v0 ∉ U **)
      claim Hlneqv0: ~(l = v0).
      { assume Heq: l = v0.
        claim Hv0U': v0 :e U.
        { rewrite <- Heq.
          exact HlU. }
        exact (Hv0notU Hv0U'). }
      claim Hlv0: Rlt l v0.
      { apply (SNoLt_trichotomy_or_impred l v0 HlS Hv0S (Rlt l v0)).
        - assume Hlt: l < v0.
          exact (RltI l v0 HlR Hv0R Hlt).
        - assume Heq: l = v0.
          exact (FalseE (Hlneqv0 Heq) (Rlt l v0)).
        - assume Hgt: v0 < l.
          claim Hv0l: Rlt v0 l.
          { exact (RltI v0 l Hv0R HlR Hgt). }
          claim Hnlt: ~(Rlt v0 l).
          { exact (RleE_nlt l v0 Hlubv0). }
          exact (FalseE (Hnlt Hv0l) (Rlt l v0)). }
      (** define positive gaps d-l and v0-l **)
      set gap1 := add_SNo d (minus_SNo l).
      set gap2 := add_SNo v0 (minus_SNo l).
      claim Hgap1R: gap1 :e R.
      { exact (real_add_SNo d HdR (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap2R: gap2 :e R.
      { exact (real_add_SNo v0 Hv0R (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap1pos: Rlt 0 gap1.
      { exact (Rlt_0_diff_of_lt l d Hld). }
      claim Hgap2pos: Rlt 0 gap2.
      { exact (Rlt_0_diff_of_lt l v0 Hlv0). }
      (** choose r3 < gap1 and r3 < gap2 **)
      apply (exists_eps_lt_two_pos_Euclid gap1 gap2 Hgap1R Hgap2R Hgap1pos Hgap2pos).
      let r3. assume Hr3pack.
      claim Hr3p1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1.
      { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
                     (Rlt r3 gap2)
                     Hr3pack). }
      claim Hr3ltgap2: Rlt r3 gap2.
      { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
                     (Rlt r3 gap2)
                     Hr3pack). }
      claim Hr3p0: r3 :e R /\ Rlt 0 r3.
      { exact (andEL (r3 :e R /\ Rlt 0 r3)
                     (Rlt r3 gap1)
                     Hr3p1). }
      claim Hr3ltgap1: Rlt r3 gap1.
      { exact (andER (r3 :e R /\ Rlt 0 r3)
                     (Rlt r3 gap1)
                     Hr3p1). }
      claim Hr3R: r3 :e R.
      { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3p0). }
      claim Hr3pos: Rlt 0 r3.
      { exact (andER (r3 :e R) (Rlt 0 r3) Hr3p0). }
      claim Hr3S: SNo r3.
      { exact (real_SNo r3 Hr3R). }
      claim Hr3posS: 0 < r3.
      { exact (RltE_lt 0 r3 Hr3pos). }
      (** set u1 = l + r3 **)
      claim Hu1R: add_SNo l r3 :e R.
      { exact (real_add_SNo l HlR r3 Hr3R). }
      claim Hu1S: SNo (add_SNo l r3).
      { exact (real_SNo (add_SNo l r3) Hu1R). }
      (** l < u1 **)
      claim Hl_lt_u1S: l < add_SNo l r3.
      { claim Hl0: add_SNo l 0 = l.
        { exact (add_SNo_0R l HlS). }
        claim Hlt: add_SNo l 0 < add_SNo l r3.
        { exact (add_SNo_Lt2 l 0 r3 HlS SNo_0 Hr3S Hr3posS). }
        rewrite <- Hl0 at 1.
        exact Hlt. }
      claim Hl_lt_u1: Rlt l (add_SNo l r3).
      { exact (RltI l (add_SNo l r3) HlR Hu1R Hl_lt_u1S). }
      (** u1 < d from r3 < d-l **)
      claim Hr3ltgap1S: r3 < gap1.
      { exact (RltE_lt r3 gap1 Hr3ltgap1). }
      claim Hgap1S: SNo gap1.
      { exact (real_SNo gap1 Hgap1R). }
      claim Hu1lt_dS': add_SNo r3 l < d.
      { exact (add_SNo_minus_Lt2 d l r3 HdS HlS Hr3S Hr3ltgap1S). }
      claim Hu1lt_dS: add_SNo l r3 < d.
      { claim Hcom2: add_SNo r3 l = add_SNo l r3.
        { exact (add_SNo_com r3 l Hr3S HlS). }
        rewrite <- Hcom2.
        exact Hu1lt_dS'. }
      claim Hu1lt_d: Rlt (add_SNo l r3) d.
      { exact (RltI (add_SNo l r3) d Hu1R HdR Hu1lt_dS). }
      (** u1 < v0 from r3 < v0-l **)
      claim Hr3ltgap2S: r3 < gap2.
      { exact (RltE_lt r3 gap2 Hr3ltgap2). }
      claim Hgap2S: SNo gap2.
      { exact (real_SNo gap2 Hgap2R). }
      claim Hu1lt_v0S': add_SNo r3 l < v0.
      { exact (add_SNo_minus_Lt2 v0 l r3 Hv0S HlS Hr3S Hr3ltgap2S). }
      claim Hu1lt_v0S: add_SNo l r3 < v0.
      { claim Hcom3: add_SNo r3 l = add_SNo l r3.
        { exact (add_SNo_com r3 l Hr3S HlS). }
        rewrite <- Hcom3.
        exact Hu1lt_v0S'. }
      claim Hu1lt_v0: Rlt (add_SNo l r3) v0.
      { exact (RltI (add_SNo l r3) v0 Hu1R Hv0R Hu1lt_v0S). }
      (** u1 ∈ open_interval c d, hence u1 ∈ Uamb **)
      claim Hu1InInt: add_SNo l r3 :e open_interval c d.
      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) (add_SNo l r3) Hu1R
                   (andI (Rlt c (add_SNo l r3)) (Rlt (add_SNo l r3) d)
                         (Rlt_tra c l (add_SNo l r3) Hcl Hl_lt_u1)
                         Hu1lt_d)). }
      claim Hu1Uamb: add_SNo l r3 :e Uamb.
      { exact (HIntSubUamb (add_SNo l r3) Hu1InInt). }
      (** u1 :e unit_interval **)
      claim Hv0conj: ~(Rlt v0 0) /\ ~(Rlt 1 v0).
      { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) v0 Hv0I). }
      claim Hnlt_1v0: ~(Rlt 1 v0).
      { exact (andER (~(Rlt v0 0)) (~(Rlt 1 v0)) Hv0conj). }
      claim Hv0le1: Rle v0 1.
      { exact (RleI v0 1 Hv0R H1R Hnlt_1v0). }
      claim Hu1le_v0: Rle (add_SNo l r3) v0.
      { exact (Rlt_implies_Rle (add_SNo l r3) v0 Hu1lt_v0). }
      claim Hu1le1: Rle (add_SNo l r3) 1.
      { exact (Rle_tra (add_SNo l r3) v0 1 Hu1le_v0 Hv0le1). }
      claim Hl_le_u1: Rle l (add_SNo l r3).
      { exact (Rlt_implies_Rle l (add_SNo l r3) Hl_lt_u1). }
      claim H0le_u1: Rle 0 (add_SNo l r3).
      { exact (Rle_tra 0 l (add_SNo l r3) H0le_l Hl_le_u1). }
      claim Hnlt_u1_0: ~(Rlt (add_SNo l r3) 0).
      { exact (RleE_nlt 0 (add_SNo l r3) H0le_u1). }
      claim Hnlt_1_u1: ~(Rlt 1 (add_SNo l r3)).
      { exact (RleE_nlt (add_SNo l r3) 1 Hu1le1). }
      claim Hu1I: add_SNo l r3 :e unit_interval.
      { exact (SepI R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) (add_SNo l r3) Hu1R
               (andI (~(Rlt (add_SNo l r3) 0)) (~(Rlt 1 (add_SNo l r3))) Hnlt_u1_0 Hnlt_1_u1)). }
      claim Hu1U: add_SNo l r3 :e U.
      { rewrite HUeq.
        exact (binintersectI Uamb unit_interval (add_SNo l r3) Hu1Uamb Hu1I). }
      claim Hu1A: add_SNo l r3 :e A.
      { exact (SepI U (fun u:set => Rlt u v0) (add_SNo l r3) Hu1U Hu1lt_v0). }
      (** contradiction with upper bound property HubA **)
      claim Hu1le_l: Rle (add_SNo l r3) l.
      { exact (HubA (add_SNo l r3) Hu1A Hu1R). }
      claim Hnlt: ~(Rlt l (add_SNo l r3)).
      { exact (RleE_nlt (add_SNo l r3) l Hu1le_l). }
      exact (Hnlt Hl_lt_u1).
    + (** Case l ∈ V: use openness of V and approximation-from-below to force a point in U∩V **)
      assume HlV: l :e V.
      claim HVopen_in: open_in unit_interval unit_interval_topology V.
      { exact (open_inI unit_interval unit_interval_topology V unit_interval_topology_on HVopen). }
      claim HexVamb: exists Vamb :e R_standard_topology, V = Vamb :/\: unit_interval.
      { exact (iffEL (open_in unit_interval unit_interval_topology V)
                     (exists Vamb :e R_standard_topology, V = Vamb :/\: unit_interval)
                     (open_in_subspace_iff R R_standard_topology unit_interval V
                        R_standard_topology_is_topology unit_interval_sub_R HVsub)
                     HVopen_in). }
      apply HexVamb.
      let Vamb. assume HVambpair: Vamb :e R_standard_topology /\ V = Vamb :/\: unit_interval.
      claim HVambOpen: Vamb :e R_standard_topology.
      { exact (andEL (Vamb :e R_standard_topology) (V = Vamb :/\: unit_interval) HVambpair). }
      claim HVeq: V = Vamb :/\: unit_interval.
      { exact (andER (Vamb :e R_standard_topology) (V = Vamb :/\: unit_interval) HVambpair). }
      claim HlVamb: l :e Vamb.
      { claim HlV2: l :e Vamb :/\: unit_interval.
        { rewrite <- HVeq.
          exact HlV. }
        exact (binintersectE1 Vamb unit_interval l HlV2). }
      (** get an interval (c,d) around l contained in Vamb **)
      claim Hexcd: exists c d:set,
        c :e R /\ d :e R /\
        l :e open_interval c d /\
        open_interval c d c= Vamb /\
        Rlt c l /\ Rlt l d.
      { exact (R_standard_open_refine_interval Vamb l HVambOpen HlVamb). }
      apply Hexcd.
      let c. assume Hexd.
      apply Hexd.
      let d. assume Hcdpack.
      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l).
      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hld: Rlt l d.
      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb).
      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcl: Rlt c l.
      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Vamb)
                     Hcd2). }
      claim HIntSubVamb: open_interval c d c= Vamb.
      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Vamb)
                     Hcd2). }
      claim HcR: c :e R.
      { exact (andEL (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdR: d :e R.
      { exact (andER (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HlS2: SNo l.
      { exact HlS. }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      (** pick eps0 < l-c **)
      set gap := add_SNo l (minus_SNo c).
      claim HgapR: gap :e R.
      { exact (real_add_SNo l HlR (minus_SNo c) (real_minus_SNo c HcR)). }
      claim HgapPos: Rlt 0 gap.
      { exact (Rlt_0_diff_of_lt c l Hcl). }
      claim Hexeps: exists Neps :e omega, eps_ Neps < gap.
      { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
      apply Hexeps.
      let Neps. assume HNepspair.
      claim HNepsO: Neps :e omega.
      { exact (andEL (Neps :e omega) (eps_ Neps < gap) HNepspair). }
      claim HepsltS: eps_ Neps < gap.
      { exact (andER (Neps :e omega) (eps_ Neps < gap) HNepspair). }
      claim HepsR: eps_ Neps :e R.
      { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
      claim HepsposS: 0 < eps_ Neps.
      { exact (SNo_eps_pos Neps HNepsO). }
      claim Hepspos: Rlt 0 (eps_ Neps).
      { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }
      (** show c < l - eps **)
      claim HcS: SNo c.
      { exact (real_SNo c HcR). }
      claim HepsS: SNo (eps_ Neps).
      { exact (real_SNo (eps_ Neps) HepsR). }
      claim HgapS: SNo gap.
      { exact (real_SNo gap HgapR). }
      claim HepsltR: Rlt (eps_ Neps) gap.
      { exact (RltI (eps_ Neps) gap HepsR HgapR HepsltS). }
      claim HepsltgapS: eps_ Neps < gap.
      { exact (RltE_lt (eps_ Neps) gap HepsltR). }
      claim Hsumlt1: add_SNo (eps_ Neps) c < l.
      { exact (add_SNo_minus_Lt2 l c (eps_ Neps) HlS2 HcS HepsS HepsltgapS). }
      claim Hsumlt2: add_SNo c (eps_ Neps) < l.
      { rewrite (add_SNo_com c (eps_ Neps) HcS HepsS).
        exact Hsumlt1. }
      claim Hclm: c < add_SNo l (minus_SNo (eps_ Neps)).
      { exact (add_SNo_minus_Lt2b l (eps_ Neps) c HlS2 HepsS HcS Hsumlt2). }
      claim HclmR: add_SNo l (minus_SNo (eps_ Neps)) :e R.
      { exact (real_add_SNo l HlR (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
      claim HclmRlt: Rlt c (add_SNo l (minus_SNo (eps_ Neps))).
      { exact (RltI c (add_SNo l (minus_SNo (eps_ Neps))) HcR HclmR Hclm). }
      (** get a∈A with l-eps < a **)
      claim Hexa: exists a:set, a :e A /\ a :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
      { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR Hepspos). }
      apply Hexa.
      let a. assume Haa.
      claim Haa1: a :e A /\ a :e R.
      { exact (andEL (a :e A /\ a :e R)
                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
                     Haa). }
      claim HaA: a :e A.
      { exact (andEL (a :e A) (a :e R) Haa1). }
      claim HaR: a :e R.
      { exact (andER (a :e A) (a :e R) Haa1). }
      claim Hltlm: Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
      { exact (andER (a :e A /\ a :e R)
                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
                     Haa). }
      claim Hcalt: c < a.
      { exact (RltE_lt c a (Rlt_tra c (add_SNo l (minus_SNo (eps_ Neps))) a HclmRlt Hltlm)). }
      claim Hca: Rlt c a.
      { exact (RltI c a HcR HaR Hcalt). }
      (** show a < d using a ≤ l and l < d **)
      claim HubA2: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
      { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
      claim Hale_l: Rle a l.
      { exact (HubA2 a HaA HaR). }
      claim Hnltla: ~(Rlt l a).
      { exact (RleE_nlt a l Hale_l). }
      claim Had: Rlt a d.
      { apply (SNoLt_trichotomy_or_impred a l (real_SNo a HaR) HlS2 (Rlt a d)).
        - assume Haltl: a < l.
          claim HaltlR: Rlt a l.
          { exact (RltI a l HaR HlR Haltl). }
          exact (Rlt_tra a l d HaltlR Hld).
        - assume Haeq: a = l.
          rewrite Haeq.
          exact Hld.
        - assume Hlta: l < a.
          claim HltaR: Rlt l a.
          { exact (RltI l a HlR HaR Hlta). }
          exact (FalseE (Hnltla HltaR) (Rlt a d)). }
      (** now a ∈ V and a ∈ U, contradiction with disjointness **)
      claim HaInInt: a :e open_interval c d.
      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) a HaR (andI (Rlt c a) (Rlt a d) Hca Had)). }
      claim HaVamb: a :e Vamb.
      { exact (HIntSubVamb a HaInInt). }
      claim HaU: a :e U.
      { exact (SepE1 U (fun u:set => Rlt u v0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HUsub a HaU). }
      claim HaV: a :e V.
      { rewrite HVeq.
        exact (binintersectI Vamb unit_interval a HaVamb HaI). }
      claim HaUV: a :e U :/\: V.
      { exact (binintersectI U V a HaU HaV). }
      claim HaEmpty: a :e Empty.
      { rewrite <- Hdisj.
        exact HaUV. }
      exact (EmptyE a HaEmpty).
  - assume Heq: u0 = v0.
    claim Hu0V: u0 :e V.
    { rewrite Heq.
      exact Hv0V. }
    claim Hu0UV: u0 :e U :/\: V.
    { exact (binintersectI U V u0 Hu0U Hu0V). }
    claim Hu0E: u0 :e Empty.
    { rewrite <- Hdisj.
      exact Hu0UV. }
    exact (EmptyE u0 Hu0E).
  - assume Hv0ltu0: v0 < u0.
    (** symmetric case: swap roles of U and V in the previous argument **)
    set A := {v :e V|Rlt v u0}.
    claim Hv0Rltu0: Rlt v0 u0.
    { exact (RltI v0 u0 Hv0R Hu0R Hv0ltu0). }
    claim Hv0inA: v0 :e A.
    { exact (SepI V (fun v:set => Rlt v u0) v0 Hv0V Hv0Rltu0). }
    claim HAinR: forall a:set, a :e A -> a :e R.
    { let a. assume HaA: a :e A.
      claim HaV: a :e V.
      { exact (SepE1 V (fun v:set => Rlt v u0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HVsub a HaV). }
      exact (unit_interval_sub_R a HaI). }
    claim Hub_ex: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
    { witness u0.
      apply andI.
      - exact Hu0R.
      - let a. assume HaA: a :e A.
        assume _. (** a :e R **)
        claim Harlt: Rlt a u0.
        { exact (SepE2 V (fun v:set => Rlt v u0) a HaA). }
        exact (Rlt_implies_Rle a u0 Harlt). }
    claim HAnen: exists a0:set, a0 :e A.
    { witness v0. exact Hv0inA. }
    claim Hexlub: exists l:set, R_lub A l.
    { exact (R_lub_exists A HAnen HAinR Hub_ex). }
    apply Hexlub.
    let l. assume Hlub: R_lub A l.
    claim HlR: l :e R.
    { exact (R_lub_in_R A l Hlub). }
    claim HlS: SNo l.
    { exact (real_SNo l HlR). }
    claim Hlubcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    claim HubA: forall a:set, a :e A -> a :e R -> Rle a l.
    { exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hlubcore). }
    claim Hmin: forall u:set, u :e R ->
       (forall a:set, a :e A -> a :e R -> Rle a u) ->
       Rle l u.
    { exact (andER (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
                   (forall u:set, u :e R ->
                      (forall a:set, a :e A -> a :e R -> Rle a u) ->
                      Rle l u)
                   Hlub). }
    claim Hlubu0: Rle l u0.
    { apply (Hmin u0 Hu0R).
      let a. assume HaA: a :e A.
      assume _. (** a :e R **)
      claim Harlt: Rlt a u0.
      { exact (SepE2 V (fun v:set => Rlt v u0) a HaA). }
      exact (Rlt_implies_Rle a u0 Harlt). }
    (** show l :e unit_interval as above **)
    claim Hv0conj: ~(Rlt v0 0) /\ ~(Rlt 1 v0).
    { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) v0 Hv0I). }
    claim Hnlt_v0_0: ~(Rlt v0 0).
    { exact (andEL (~(Rlt v0 0)) (~(Rlt 1 v0)) Hv0conj). }
    claim Hv0ge0: Rle 0 v0.
    { exact (RleI 0 v0 real_0 Hv0R Hnlt_v0_0). }
    claim Hv0le_l: Rle v0 l.
    { exact (HubA v0 Hv0inA Hv0R). }
    claim H0le_l: Rle 0 l.
    { exact (Rle_tra 0 v0 l Hv0ge0 Hv0le_l). }
    claim H1R: 1 :e R.
    { exact real_1. }
    claim Hlub1: Rle l 1.
    { apply (Hmin 1 H1R).
      let a. assume HaA: a :e A.
      assume HaR: a :e R.
      claim HaV: a :e V.
      { exact (SepE1 V (fun v:set => Rlt v u0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HVsub a HaV). }
      claim Haconj: ~(Rlt a 0) /\ ~(Rlt 1 a).
      { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) a (HVsub a HaV)). }
      claim Hnlt_1a: ~(Rlt 1 a).
      { exact (andER (~(Rlt a 0)) (~(Rlt 1 a)) Haconj). }
      exact (RleI a 1 HaR H1R Hnlt_1a). }
    claim Hnlt_l_0: ~(Rlt l 0).
    { exact (RleE_nlt 0 l H0le_l). }
    claim Hnlt_1_l: ~(Rlt 1 l).
    { exact (RleE_nlt l 1 Hlub1). }
    claim HlI: l :e unit_interval.
    { exact (SepI R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) l HlR
             (andI (~(Rlt l 0)) (~(Rlt 1 l)) Hnlt_l_0 Hnlt_1_l)). }
    claim HlUV: l :e U :\/: V.
    { rewrite Hunion.
      exact HlI. }
    apply (binunionE U V l HlUV).
    + (** Case l ∈ U: use openness of U to force a point in U∩V **)
      assume HlU: l :e U.
      claim HUopen_in: open_in unit_interval unit_interval_topology U.
      { exact (open_inI unit_interval unit_interval_topology U unit_interval_topology_on HUopen). }
      claim HexUamb: exists Uamb :e R_standard_topology, U = Uamb :/\: unit_interval.
      { exact (iffEL (open_in unit_interval unit_interval_topology U)
                     (exists Uamb :e R_standard_topology, U = Uamb :/\: unit_interval)
                     (open_in_subspace_iff R R_standard_topology unit_interval U
                        R_standard_topology_is_topology unit_interval_sub_R HUsub)
                     HUopen_in). }
      apply HexUamb.
      let Uamb. assume HUambpair: Uamb :e R_standard_topology /\ U = Uamb :/\: unit_interval.
      claim HUambOpen: Uamb :e R_standard_topology.
      { exact (andEL (Uamb :e R_standard_topology) (U = Uamb :/\: unit_interval) HUambpair). }
      claim HUeq: U = Uamb :/\: unit_interval.
      { exact (andER (Uamb :e R_standard_topology) (U = Uamb :/\: unit_interval) HUambpair). }
      claim HlUamb: l :e Uamb.
      { claim HlU2: l :e Uamb :/\: unit_interval.
        { rewrite <- HUeq.
          exact HlU. }
        exact (binintersectE1 Uamb unit_interval l HlU2). }
      claim Hexcd: exists c d:set,
        c :e R /\ d :e R /\
        l :e open_interval c d /\
        open_interval c d c= Uamb /\
        Rlt c l /\ Rlt l d.
      { exact (R_standard_open_refine_interval Uamb l HUambOpen HlUamb). }
      apply Hexcd.
      let c. assume Hexd.
      apply Hexd.
      let d. assume Hcdpack.
      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l).
      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hld: Rlt l d.
      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb).
      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcl: Rlt c l.
      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Uamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Uamb)
                     Hcd2). }
      claim HIntSubUamb: open_interval c d c= Uamb.
      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Uamb)
                     Hcd2). }
      claim HcR: c :e R.
      { exact (andEL (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdR: d :e R.
      { exact (andER (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      (** choose eps0 < l-c and then approximate l from below by a in A; this forces a in U∩V **)
      claim HlS2: SNo l.
      { exact HlS. }
      claim HcS: SNo c.
      { exact (real_SNo c HcR). }
      (** pick eps < l-c **)
      set gap := add_SNo l (minus_SNo c).
      claim HgapR: gap :e R.
      { exact (real_add_SNo l HlR (minus_SNo c) (real_minus_SNo c HcR)). }
      claim HgapPos: Rlt 0 gap.
      { exact (Rlt_0_diff_of_lt c l Hcl). }
      claim Hexeps: exists Neps :e omega, eps_ Neps < gap.
      { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
      apply Hexeps.
      let Neps. assume HNepspair.
      claim HNepsO: Neps :e omega.
      { exact (andEL (Neps :e omega) (eps_ Neps < gap) HNepspair). }
      claim HepsltS: eps_ Neps < gap.
      { exact (andER (Neps :e omega) (eps_ Neps < gap) HNepspair). }
      claim HepsR: eps_ Neps :e R.
      { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
      claim HepsposS: 0 < eps_ Neps.
      { exact (SNo_eps_pos Neps HNepsO). }
      claim Hepspos: Rlt 0 (eps_ Neps).
      { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }
      (** show c < l - eps **)
      claim HepsS: SNo (eps_ Neps).
      { exact (real_SNo (eps_ Neps) HepsR). }
      claim HgapS: SNo gap.
      { exact (real_SNo gap HgapR). }
      claim HepsltR: Rlt (eps_ Neps) gap.
      { exact (RltI (eps_ Neps) gap HepsR HgapR HepsltS). }
      claim HepsltgapS: eps_ Neps < gap.
      { exact (RltE_lt (eps_ Neps) gap HepsltR). }
      claim Hsumlt1: add_SNo (eps_ Neps) c < l.
      { exact (add_SNo_minus_Lt2 l c (eps_ Neps) HlS2 HcS HepsS HepsltgapS). }
      claim Hsumlt2: add_SNo c (eps_ Neps) < l.
      { rewrite (add_SNo_com c (eps_ Neps) HcS HepsS).
        exact Hsumlt1. }
      claim Hclm: c < add_SNo l (minus_SNo (eps_ Neps)).
      { exact (add_SNo_minus_Lt2b l (eps_ Neps) c HlS2 HepsS HcS Hsumlt2). }
      claim HclmR: add_SNo l (minus_SNo (eps_ Neps)) :e R.
      { exact (real_add_SNo l HlR (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
      claim HclmRlt: Rlt c (add_SNo l (minus_SNo (eps_ Neps))).
      { exact (RltI c (add_SNo l (minus_SNo (eps_ Neps))) HcR HclmR Hclm). }
      (** get a∈A with l-eps < a **)
      claim Hexa: exists a:set, a :e A /\ a :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
      { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR Hepspos). }
      apply Hexa.
      let a. assume Haa.
      claim Haa1: a :e A /\ a :e R.
      { exact (andEL (a :e A /\ a :e R)
                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
                     Haa). }
      claim HaA: a :e A.
      { exact (andEL (a :e A) (a :e R) Haa1). }
      claim HaR: a :e R.
      { exact (andER (a :e A) (a :e R) Haa1). }
      claim Hltlm: Rlt (add_SNo l (minus_SNo (eps_ Neps))) a.
      { exact (andER (a :e A /\ a :e R)
                     (Rlt (add_SNo l (minus_SNo (eps_ Neps))) a)
                     Haa). }
      claim Hcalt: c < a.
      { exact (RltE_lt c a (Rlt_tra c (add_SNo l (minus_SNo (eps_ Neps))) a HclmRlt Hltlm)). }
      claim Hca: Rlt c a.
      { exact (RltI c a HcR HaR Hcalt). }
      (** show a < d using a ≤ l and l < d **)
      claim HubA2: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
      { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
      claim Hale_l: Rle a l.
      { exact (HubA2 a HaA HaR). }
      claim Hnltla: ~(Rlt l a).
      { exact (RleE_nlt a l Hale_l). }
      claim Had: Rlt a d.
      { apply (SNoLt_trichotomy_or_impred a l (real_SNo a HaR) HlS2 (Rlt a d)).
        - assume Haltl: a < l.
          claim HaltlR: Rlt a l.
          { exact (RltI a l HaR HlR Haltl). }
          exact (Rlt_tra a l d HaltlR Hld).
        - assume Haeq: a = l.
          rewrite Haeq.
          exact Hld.
        - assume Hlta: l < a.
          claim HltaR: Rlt l a.
          { exact (RltI l a HlR HaR Hlta). }
          exact (FalseE (Hnltla HltaR) (Rlt a d)). }
      (** now a ∈ U and a ∈ V, contradiction with disjointness **)
      claim HaInInt: a :e open_interval c d.
      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) a HaR (andI (Rlt c a) (Rlt a d) Hca Had)). }
      claim HaUamb: a :e Uamb.
      { exact (HIntSubUamb a HaInInt). }
      claim HaV: a :e V.
      { exact (SepE1 V (fun v:set => Rlt v u0) a HaA). }
      claim HaI: a :e unit_interval.
      { exact (HVsub a HaV). }
      claim HaU: a :e U.
      { rewrite HUeq.
        exact (binintersectI Uamb unit_interval a HaUamb HaI). }
      claim HaUV: a :e U :/\: V.
      { exact (binintersectI U V a HaU HaV). }
      claim HaE: a :e Empty.
      { rewrite <- Hdisj.
        exact HaUV. }
      exact (EmptyE a HaE).
    + assume HlV: l :e V.
      (** mirror of the u0<v0 case (l ∈ U): find v1∈A above l inside V, contradicting that l is an upper bound **)
      claim Hu0notV: u0 /:e V.
      { assume Hu0V: u0 :e V.
        claim Hu0UV: u0 :e U :/\: V.
        { exact (binintersectI U V u0 Hu0U Hu0V). }
        claim Hu0E: u0 :e Empty.
        { rewrite <- Hdisj.
          exact Hu0UV. }
        exact (EmptyE u0 Hu0E). }
      claim Hlnequ0: ~(l = u0).
      { assume Heq: l = u0.
        claim Hu0V: u0 :e V.
        { rewrite <- Heq.
          exact HlV. }
        exact (Hu0notV Hu0V). }
      claim Hlu0: Rlt l u0.
      { apply (SNoLt_trichotomy_or_impred l u0 HlS Hu0S (Rlt l u0)).
        - assume Hlt: l < u0.
          exact (RltI l u0 HlR Hu0R Hlt).
        - assume Heq: l = u0.
          exact (FalseE (Hlnequ0 Heq) (Rlt l u0)).
        - assume Hgt: u0 < l.
          claim Hu0l: Rlt u0 l.
          { exact (RltI u0 l Hu0R HlR Hgt). }
          claim Hnlt: ~(Rlt u0 l).
          { exact (RleE_nlt l u0 Hlubu0). }
          exact (FalseE (Hnlt Hu0l) (Rlt l u0)). }
      claim HVopen_in: open_in unit_interval unit_interval_topology V.
      { exact (open_inI unit_interval unit_interval_topology V unit_interval_topology_on HVopen). }
      claim HexVamb: exists Vamb :e R_standard_topology, V = Vamb :/\: unit_interval.
      { exact (iffEL (open_in unit_interval unit_interval_topology V)
                     (exists Vamb :e R_standard_topology, V = Vamb :/\: unit_interval)
                     (open_in_subspace_iff R R_standard_topology unit_interval V
                        R_standard_topology_is_topology unit_interval_sub_R HVsub)
                     HVopen_in). }
      apply HexVamb.
      let Vamb. assume HVambpair: Vamb :e R_standard_topology /\ V = Vamb :/\: unit_interval.
      claim HVambOpen: Vamb :e R_standard_topology.
      { exact (andEL (Vamb :e R_standard_topology) (V = Vamb :/\: unit_interval) HVambpair). }
      claim HVeq: V = Vamb :/\: unit_interval.
      { exact (andER (Vamb :e R_standard_topology) (V = Vamb :/\: unit_interval) HVambpair). }
      claim HlVamb: l :e Vamb.
      { claim HlV2: l :e Vamb :/\: unit_interval.
        { rewrite <- HVeq.
          exact HlV. }
        exact (binintersectE1 Vamb unit_interval l HlV2). }
      (** obtain an interval (c,d) around l contained in Vamb **)
      claim Hexcd: exists c d:set,
        c :e R /\ d :e R /\
        l :e open_interval c d /\
        open_interval c d c= Vamb /\
        Rlt c l /\ Rlt l d.
      { exact (R_standard_open_refine_interval Vamb l HVambOpen HlVamb). }
      apply Hexcd.
      let c. assume Hexd.
      apply Hexd.
      let d. assume Hcdpack.
      (** destruct returned conjunction (left-associative) **)
      claim Hcd1: ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l).
      { exact (andEL ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hld: Rlt l d.
      { exact (andER ((((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb) /\ Rlt c l)
                     (Rlt l d)
                     Hcdpack). }
      claim Hcd2: (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb).
      { exact (andEL (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcl: Rlt c l.
      { exact (andER (((c :e R /\ d :e R) /\ l :e open_interval c d) /\ open_interval c d c= Vamb)
                     (Rlt c l)
                     Hcd1). }
      claim Hcd3: (c :e R /\ d :e R) /\ l :e open_interval c d.
      { exact (andEL ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Vamb)
                     Hcd2). }
      claim HIntSubVamb: open_interval c d c= Vamb.
      { exact (andER ((c :e R /\ d :e R) /\ l :e open_interval c d)
                     (open_interval c d c= Vamb)
                     Hcd2). }
      claim HcR: c :e R.
      { exact (andEL (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdR: d :e R.
      { exact (andER (c :e R) (d :e R)
                     (andEL (c :e R /\ d :e R) (l :e open_interval c d) Hcd3)). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      (** show l < u0 from l ≤ u0 and u0 ∉ V already done: Hlu0 **)
      (** choose r3 < d-l and r3 < u0-l **)
      set gap1 := add_SNo d (minus_SNo l).
      set gap2 := add_SNo u0 (minus_SNo l).
      claim Hgap1R: gap1 :e R.
      { exact (real_add_SNo d HdR (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap2R: gap2 :e R.
      { exact (real_add_SNo u0 Hu0R (minus_SNo l) (real_minus_SNo l HlR)). }
      claim Hgap1pos: Rlt 0 gap1.
      { exact (Rlt_0_diff_of_lt l d Hld). }
      claim Hgap2pos: Rlt 0 gap2.
      { exact (Rlt_0_diff_of_lt l u0 Hlu0). }
      apply (exists_eps_lt_two_pos_Euclid gap1 gap2 Hgap1R Hgap2R Hgap1pos Hgap2pos).
      let r3. assume Hr3pack.
      claim Hr3p1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1.
      { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
                     (Rlt r3 gap2)
                     Hr3pack). }
      claim Hr3ltgap2: Rlt r3 gap2.
      { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 gap1)
                     (Rlt r3 gap2)
                     Hr3pack). }
      claim Hr3p0: r3 :e R /\ Rlt 0 r3.
      { exact (andEL (r3 :e R /\ Rlt 0 r3)
                     (Rlt r3 gap1)
                     Hr3p1). }
      claim Hr3ltgap1: Rlt r3 gap1.
      { exact (andER (r3 :e R /\ Rlt 0 r3)
                     (Rlt r3 gap1)
                     Hr3p1). }
      claim Hr3R: r3 :e R.
      { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3p0). }
      claim Hr3pos: Rlt 0 r3.
      { exact (andER (r3 :e R) (Rlt 0 r3) Hr3p0). }
      claim Hr3S: SNo r3.
      { exact (real_SNo r3 Hr3R). }
      claim Hr3posS: 0 < r3.
      { exact (RltE_lt 0 r3 Hr3pos). }
      (** set v1 = l + r3; then l < v1 < min(d,u0) **)
      claim Hv1R: add_SNo l r3 :e R.
      { exact (real_add_SNo l HlR r3 Hr3R). }
      claim Hv1S: SNo (add_SNo l r3).
      { exact (real_SNo (add_SNo l r3) Hv1R). }
      claim Hl_lt_v1S: l < add_SNo l r3.
      { claim Hl0: add_SNo l 0 = l.
        { exact (add_SNo_0R l HlS). }
        claim Hlt: add_SNo l 0 < add_SNo l r3.
        { exact (add_SNo_Lt2 l 0 r3 HlS SNo_0 Hr3S Hr3posS). }
        rewrite <- Hl0 at 1.
        exact Hlt. }
      claim Hl_lt_v1: Rlt l (add_SNo l r3).
      { exact (RltI l (add_SNo l r3) HlR Hv1R Hl_lt_v1S). }
      (** v1 < d from r3 < d-l **)
      claim Hr3ltgap1S: r3 < gap1.
      { exact (RltE_lt r3 gap1 Hr3ltgap1). }
      claim Hgap1S: SNo gap1.
      { exact (real_SNo gap1 Hgap1R). }
      claim Hv1lt_dS': add_SNo r3 l < d.
      { exact (add_SNo_minus_Lt2 d l r3 HdS HlS Hr3S Hr3ltgap1S). }
      claim Hv1lt_dS: add_SNo l r3 < d.
      { claim Hcom2: add_SNo r3 l = add_SNo l r3.
        { exact (add_SNo_com r3 l Hr3S HlS). }
        rewrite <- Hcom2.
        exact Hv1lt_dS'. }
      claim Hv1lt_d: Rlt (add_SNo l r3) d.
      { exact (RltI (add_SNo l r3) d Hv1R HdR Hv1lt_dS). }
      (** v1 < u0 from r3 < u0-l **)
      claim Hr3ltgap2S: r3 < gap2.
      { exact (RltE_lt r3 gap2 Hr3ltgap2). }
      claim Hgap2S: SNo gap2.
      { exact (real_SNo gap2 Hgap2R). }
      claim Hv1lt_u0S': add_SNo r3 l < u0.
      { exact (add_SNo_minus_Lt2 u0 l r3 Hu0S HlS Hr3S Hr3ltgap2S). }
      claim Hv1lt_u0S: add_SNo l r3 < u0.
      { claim Hcom3: add_SNo r3 l = add_SNo l r3.
        { exact (add_SNo_com r3 l Hr3S HlS). }
        rewrite <- Hcom3.
        exact Hv1lt_u0S'. }
      claim Hv1lt_u0: Rlt (add_SNo l r3) u0.
      { exact (RltI (add_SNo l r3) u0 Hv1R Hu0R Hv1lt_u0S). }
      (** v1 ∈ open_interval c d, hence v1 ∈ Vamb **)
      claim Hv1InInt: add_SNo l r3 :e open_interval c d.
      { exact (SepI R (fun z:set => Rlt c z /\ Rlt z d) (add_SNo l r3) Hv1R
                   (andI (Rlt c (add_SNo l r3)) (Rlt (add_SNo l r3) d)
                         (Rlt_tra c l (add_SNo l r3) Hcl Hl_lt_v1)
                         Hv1lt_d)). }
      claim Hv1Vamb: add_SNo l r3 :e Vamb.
      { exact (HIntSubVamb (add_SNo l r3) Hv1InInt). }
      (** v1 :e unit_interval **)
      claim Hu0conj: ~(Rlt u0 0) /\ ~(Rlt 1 u0).
      { exact (SepE2 R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) u0 Hu0I). }
      claim Hnlt_1u0: ~(Rlt 1 u0).
      { exact (andER (~(Rlt u0 0)) (~(Rlt 1 u0)) Hu0conj). }
      claim Hu0le1: Rle u0 1.
      { exact (RleI u0 1 Hu0R real_1 Hnlt_1u0). }
      claim Hv1le_u0: Rle (add_SNo l r3) u0.
      { exact (Rlt_implies_Rle (add_SNo l r3) u0 Hv1lt_u0). }
      claim Hv1le1: Rle (add_SNo l r3) 1.
      { exact (Rle_tra (add_SNo l r3) u0 1 Hv1le_u0 Hu0le1). }
      claim Hl_le_v1: Rle l (add_SNo l r3).
      { exact (Rlt_implies_Rle l (add_SNo l r3) Hl_lt_v1). }
      claim H0le_v1: Rle 0 (add_SNo l r3).
      { exact (Rle_tra 0 l (add_SNo l r3) H0le_l Hl_le_v1). }
      claim Hnlt_v1_0: ~(Rlt (add_SNo l r3) 0).
      { exact (RleE_nlt 0 (add_SNo l r3) H0le_v1). }
      claim Hnlt_1_v1: ~(Rlt 1 (add_SNo l r3)).
      { exact (RleE_nlt (add_SNo l r3) 1 Hv1le1). }
      claim Hv1I: add_SNo l r3 :e unit_interval.
      { exact (SepI R (fun x:set => ~(Rlt x 0) /\ ~(Rlt 1 x)) (add_SNo l r3) Hv1R
               (andI (~(Rlt (add_SNo l r3) 0)) (~(Rlt 1 (add_SNo l r3))) Hnlt_v1_0 Hnlt_1_v1)). }
      claim Hv1V: add_SNo l r3 :e V.
      { rewrite HVeq.
        exact (binintersectI Vamb unit_interval (add_SNo l r3) Hv1Vamb Hv1I). }
      claim Hv1A: add_SNo l r3 :e A.
      { exact (SepI V (fun v:set => Rlt v u0) (add_SNo l r3) Hv1V Hv1lt_u0). }
      (** contradiction with upper bound property HubA **)
      claim Hv1le_l: Rle (add_SNo l r3) l.
      { exact (HubA (add_SNo l r3) Hv1A Hv1R). }
      claim Hnlt: ~(Rlt l (add_SNo l r3)).
      { exact (RleE_nlt (add_SNo l r3) l Hv1le_l). }
      exact (Hnlt Hl_lt_v1).
Qed.

Theorem zero_one_in_unit_interval : 0 :e unit_interval /\ 1 :e unit_interval.
apply andI.
- exact zero_in_unit_interval.
- exact one_in_unit_interval.
Qed.

(** helper: for any two points in X there exists a path_between witness **)
(** LATEX VERSION: For any x,y in X there is a path (as a function) from x to y. **)
Theorem path_between_exists : forall X x y:set,
  x :e X -> y :e X -> exists p:set, path_between X x y p.
let X x y.
assume HxX: x :e X.
assume HyX: y :e X.
prove exists p:set, path_between X x y p.
set p := {(t, If_i (t = 0) x y)|t :e unit_interval}.
witness p.
prove path_between X x y p.
prove function_on p unit_interval X /\ apply_fun p 0 = x /\ apply_fun p 1 = y.
apply andI.
- (** function_on p unit_interval X /\ apply_fun p 0 = x **)
  apply andI.
  + (** function_on **)
    let t. assume HtI: t :e unit_interval.
    prove apply_fun p t :e X.
    claim Happ: apply_fun p t = If_i (t = 0) x y.
    { prove apply_fun p t = If_i (t = 0) x y.
      prove Eps_i (fun u:set => (t,u) :e p) = If_i (t = 0) x y.
      claim Hpair: (t, If_i (t = 0) x y) :e p.
      { exact (ReplI unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y)) t HtI). }
      claim Heps: (t, Eps_i (fun u:set => (t,u) :e p)) :e p.
      { exact (Eps_i_ax (fun u:set => (t,u) :e p) (If_i (t = 0) x y) Hpair). }
      apply (ReplE_impred unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y))
              (t, Eps_i (fun u:set => (t,u) :e p)) Heps
              (Eps_i (fun u:set => (t,u) :e p) = If_i (t = 0) x y)).
      let t0. assume Ht0: t0 :e unit_interval.
      assume Heq: (t, Eps_i (fun u:set => (t,u) :e p)) = (t0, If_i (t0 = 0) x y).
      claim Ht_eq: t = t0.
      { rewrite <- (tuple_2_0_eq t (Eps_i (fun u:set => (t,u) :e p))).
        rewrite <- (tuple_2_0_eq t0 (If_i (t0 = 0) x y)).
        rewrite Heq.
        reflexivity. }
      claim Hu_eq: Eps_i (fun u:set => (t,u) :e p) = If_i (t0 = 0) x y.
      { rewrite <- (tuple_2_1_eq t (Eps_i (fun u:set => (t,u) :e p))).
        rewrite <- (tuple_2_1_eq t0 (If_i (t0 = 0) x y)).
        rewrite Heq.
        reflexivity. }
      rewrite Hu_eq.
      rewrite <- Ht_eq.
      reflexivity. }
    rewrite Happ.
    apply (xm (t = 0)).
    - assume Ht0: t = 0.
      rewrite (If_i_1 (t = 0) x y Ht0).
      exact HxX.
    - assume Hnt0: ~(t = 0).
      rewrite (If_i_0 (t = 0) x y Hnt0).
      exact HyX.
  + (** apply_fun p 0 = x **)
    claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
    { exact zero_one_in_unit_interval. }
    claim H0I: 0 :e unit_interval.
    { exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
    claim Happ0: apply_fun p 0 = If_i (0 = 0) x y.
    { prove apply_fun p 0 = If_i (0 = 0) x y.
      prove Eps_i (fun u:set => (0,u) :e p) = If_i (0 = 0) x y.
      claim Hpair: (0, If_i (0 = 0) x y) :e p.
      { exact (ReplI unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y)) 0 H0I). }
      claim Heps: (0, Eps_i (fun u:set => (0,u) :e p)) :e p.
      { exact (Eps_i_ax (fun u:set => (0,u) :e p) (If_i (0 = 0) x y) Hpair). }
      apply (ReplE_impred unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y))
              (0, Eps_i (fun u:set => (0,u) :e p)) Heps
              (Eps_i (fun u:set => (0,u) :e p) = If_i (0 = 0) x y)).
      let t0. assume Ht0: t0 :e unit_interval.
      assume Heq: (0, Eps_i (fun u:set => (0,u) :e p)) = (t0, If_i (t0 = 0) x y).
      claim Ht_eq: 0 = t0.
      { rewrite <- (tuple_2_0_eq 0 (Eps_i (fun u:set => (0,u) :e p))).
        rewrite <- (tuple_2_0_eq t0 (If_i (t0 = 0) x y)).
        rewrite Heq.
        reflexivity. }
      claim Hu_eq: Eps_i (fun u:set => (0,u) :e p) = If_i (t0 = 0) x y.
      { rewrite <- (tuple_2_1_eq 0 (Eps_i (fun u:set => (0,u) :e p))).
        rewrite <- (tuple_2_1_eq t0 (If_i (t0 = 0) x y)).
        rewrite Heq.
        reflexivity. }
      rewrite Hu_eq.
      rewrite <- Ht_eq.
      reflexivity. }
    rewrite Happ0.
    claim H00: 0 = 0.
    { reflexivity. }
    rewrite (If_i_1 (0 = 0) x y H00).
    reflexivity.
- (** apply_fun p 1 = y **)
  claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
  { exact zero_one_in_unit_interval. }
  claim H1I: 1 :e unit_interval.
  { exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }
  claim Happ1: apply_fun p 1 = If_i (1 = 0) x y.
  { prove apply_fun p 1 = If_i (1 = 0) x y.
    prove Eps_i (fun u:set => (1,u) :e p) = If_i (1 = 0) x y.
    claim Hpair: (1, If_i (1 = 0) x y) :e p.
    { exact (ReplI unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y)) 1 H1I). }
    claim Heps: (1, Eps_i (fun u:set => (1,u) :e p)) :e p.
    { exact (Eps_i_ax (fun u:set => (1,u) :e p) (If_i (1 = 0) x y) Hpair). }
    apply (ReplE_impred unit_interval (fun t0:set => (t0, If_i (t0 = 0) x y))
            (1, Eps_i (fun u:set => (1,u) :e p)) Heps
            (Eps_i (fun u:set => (1,u) :e p) = If_i (1 = 0) x y)).
    let t0. assume Ht0: t0 :e unit_interval.
    assume Heq: (1, Eps_i (fun u:set => (1,u) :e p)) = (t0, If_i (t0 = 0) x y).
    claim Ht_eq: 1 = t0.
    { rewrite <- (tuple_2_0_eq 1 (Eps_i (fun u:set => (1,u) :e p))).
      rewrite <- (tuple_2_0_eq t0 (If_i (t0 = 0) x y)).
      rewrite Heq.
      reflexivity. }
    claim Hu_eq: Eps_i (fun u:set => (1,u) :e p) = If_i (t0 = 0) x y.
    { rewrite <- (tuple_2_1_eq 1 (Eps_i (fun u:set => (1,u) :e p))).
      rewrite <- (tuple_2_1_eq t0 (If_i (t0 = 0) x y)).
      rewrite Heq.
      reflexivity. }
    rewrite Hu_eq.
    rewrite <- Ht_eq.
    reflexivity. }
  rewrite Happ1.
  claim Hneq: ~(1 = 0).
  { assume H10: 1 = 0.
    apply neq_0_1.
    rewrite H10.
    reflexivity. }
  rewrite (If_i_0 (1 = 0) x y Hneq).
  reflexivity.
Qed.

Theorem separation_has_elements : forall X U V:set,
  separation_of X U V ->
  (exists x:set, x :e U) /\ (exists y:set, y :e V).
let X U V. assume Hsep.
claim H1: (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty.
{ exact (andEL ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
               (U :\/: V = X) Hsep). }
claim H2: ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty.
{ exact (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
               (V <> Empty) H1). }
claim HUne: U <> Empty.
{ exact (andER (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)) (U <> Empty) H2). }
claim HVne: V <> Empty.
{ exact (andER ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)) (V <> Empty) H1). }
apply andI.
- exact (nonempty_has_element U HUne).
- exact (nonempty_has_element V HVne).
Qed.

Theorem separation_subsets : forall X U V:set,
  separation_of X U V ->
  U c= X /\ V c= X.
let X U V. assume Hsep.
claim H1: (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty.
{ exact (andEL ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
               (U :\/: V = X) Hsep). }
claim H2: ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty.
{ exact (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
               (V <> Empty) H1). }
claim H3: (U :e Power X /\ V :e Power X) /\ U :/\: V = Empty.
{ exact (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)
               (U <> Empty) H2). }
claim Hleft: U :e Power X /\ V :e Power X.
{ exact (andEL (U :e Power X /\ V :e Power X) (U :/\: V = Empty) H3). }
apply andI.
- exact (PowerE X U (andEL (U :e Power X) (V :e Power X) Hleft)).
- exact (PowerE X V (andER (U :e Power X) (V :e Power X) Hleft)).
Qed.

Theorem subset_elem : forall A B x:set,
  A c= B -> x :e A -> x :e B.
let A B x. assume HAB Hx. exact (HAB x Hx).
Qed.

(** from §24: path connected implies connected **) 
(** LATEX VERSION: Every path connected space is connected. **)
Theorem path_connected_implies_connected : forall X Tx:set,
  path_connected_space X Tx -> connected_space X Tx.
let X Tx.
assume Hpath: path_connected_space X Tx.
prove connected_space X Tx.
(** Extract components from path_connected_space **)
claim HTx: topology_on X Tx.
{ exact (path_connected_space_topology X Tx Hpath). }
claim Hpath_prop: forall x y:set, x :e X -> y :e X -> exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
{ let x y.
  assume Hx: x :e X.
  assume Hy: y :e X.
  exact (path_connected_space_paths X Tx x y Hpath Hx Hy). }
(** Prove X is connected by contradiction **)
prove topology_on X Tx /\ ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
apply andI.
- exact HTx.
- prove ~(exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V).
  assume HsepX: exists U V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
  (** Extract the separation of X **)
  apply HsepX.
  let U. assume HsepX_V: exists V:set, U :e Tx /\ V :e Tx /\ separation_of X U V.
  apply HsepX_V.
  let V. assume HUV.
  (** Extract components from nested conjunction **)
  claim HU: U :e Tx.
  { exact (andEL (U :e Tx) (V :e Tx)
                 (andEL (U :e Tx /\ V :e Tx) (separation_of X U V) HUV)). }
  claim HV: V :e Tx.
  { exact (andER (U :e Tx) (V :e Tx)
                 (andEL (U :e Tx /\ V :e Tx) (separation_of X U V) HUV)). }
  claim HsepXUV: separation_of X U V.
  { exact (andER (U :e Tx /\ V :e Tx) (separation_of X U V) HUV). }
  (** Get elements from the separation **)
  claim Helems: (exists x:set, x :e U) /\ (exists y:set, y :e V).
  { exact (separation_has_elements X U V HsepXUV). }
  claim HexU: exists x:set, x :e U.
  { exact (andEL (exists x:set, x :e U) (exists y:set, y :e V) Helems). }
  claim HexV: exists y:set, y :e V.
  { exact (andER (exists x:set, x :e U) (exists y:set, y :e V) Helems). }
  (** Pick specific elements **)
  apply HexU.
  let x. assume Hx: x :e U.
  apply HexV.
  let y. assume Hy: y :e V.
  (** Show x, y are in X **)
  claim Hsubsets: U c= X /\ V c= X.
  { exact (separation_subsets X U V HsepXUV). }
  claim HU_sub: U c= X.
  { exact (andEL (U c= X) (V c= X) Hsubsets). }
  claim HV_sub: V c= X.
  { exact (andER (U c= X) (V c= X) Hsubsets). }
  claim HxinX: x :e X.
  { exact (subset_elem U X x HU_sub Hx). }
  claim HyinX: y :e X.
  { exact (subset_elem V X y HV_sub Hy). }
  (** Get continuous path from x to y **)
  claim Hpathxy: exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
  { exact (Hpath_prop x y HxinX HyinX). }
  apply Hpathxy.
  let p. assume Hp_and_cont.
  (** Extract path_between and continuity **)
  claim Hp: path_between X x y p.
  { exact (path_witness_between X Tx x y p Hp_and_cont). }
  claim Hpcont: continuous_map unit_interval unit_interval_topology X Tx p.
  { exact (path_witness_continuous X Tx x y p Hp_and_cont). }
  (** Extract function and endpoints from Hp (left-associative /\) **)
  claim Hpfunc: function_on p unit_interval X.
  { exact (path_between_function_on X x y p Hp). }
  claim Hp0eq: apply_fun p 0 = x.
  { exact (path_between_at_zero X x y p Hp). }
  claim Hp1eq: apply_fun p 1 = y.
  { exact (path_between_at_one X x y p Hp). }

  (** Extract disjointness and union from separation_of X U V **)
  claim Hsep_left: ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = X) HsepXUV). }
  claim Hsep_mid: ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty.
  { exact (andEL (((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hsep_left). }
  claim Hsep_pow_disj: (U :e Power X /\ V :e Power X) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty)
                 (U <> Empty) Hsep_mid). }
  claim HdisjUV: U :/\: V = Empty.
  { exact (andER (U :e Power X /\ V :e Power X) (U :/\: V = Empty) Hsep_pow_disj). }
  claim HunionUV: U :\/: V = X.
  { exact (andER ((((U :e Power X /\ V :e Power X) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = X) HsepXUV). }

  (** Show preimages form a separation of the unit interval **)
  set preU := preimage_of unit_interval p U.
  set preV := preimage_of unit_interval p V.
  claim Hsep_UV: separation_of unit_interval preU preV.
  { prove preU :e Power unit_interval /\ preV :e Power unit_interval /\ preU :/\: preV = Empty /\ preU <> Empty /\ preV <> Empty /\ preU :\/: preV = unit_interval.
    apply andI.
    - prove ((((preU :e Power unit_interval /\ preV :e Power unit_interval) /\ preU :/\: preV = Empty) /\ preU <> Empty) /\ preV <> Empty).
      apply andI.
      + prove (((preU :e Power unit_interval /\ preV :e Power unit_interval) /\ preU :/\: preV = Empty) /\ preU <> Empty).
        apply andI.
        - prove ((preU :e Power unit_interval /\ preV :e Power unit_interval) /\ preU :/\: preV = Empty).
          apply andI.
          + prove preU :e Power unit_interval /\ preV :e Power unit_interval.
            apply andI.
            - prove preU :e Power unit_interval.
              apply PowerI.
              let t. assume Ht: t :e preU.
              exact (SepE1 unit_interval (fun t0:set => apply_fun p t0 :e U) t Ht).
            - prove preV :e Power unit_interval.
              apply PowerI.
              let t. assume Ht: t :e preV.
              exact (SepE1 unit_interval (fun t0:set => apply_fun p t0 :e V) t Ht).
          + prove preU :/\: preV = Empty.
            apply Empty_eq.
            let t. assume Ht: t :e preU :/\: preV.
            apply (binintersectE preU preV t Ht).
            assume HtU: t :e preU.
            assume HtV: t :e preV.
            claim HpU: apply_fun p t :e U.
            { exact (SepE2 unit_interval (fun t0:set => apply_fun p t0 :e U) t HtU). }
            claim HpV: apply_fun p t :e V.
            { exact (SepE2 unit_interval (fun t0:set => apply_fun p t0 :e V) t HtV). }
            claim HpUV: apply_fun p t :e U :/\: V.
            { exact (binintersectI U V (apply_fun p t) HpU HpV). }
            claim Hfalse: apply_fun p t :e Empty.
            { rewrite <- HdisjUV. exact HpUV. }
            exact (EmptyE (apply_fun p t) Hfalse).
        - (** preU <> Empty **)
          assume Heq: preU = Empty.
          claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
          { exact zero_one_in_unit_interval. }
          claim H0I: 0 :e unit_interval.
          { exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
          claim HxU: apply_fun p 0 :e U.
          { rewrite Hp0eq. exact Hx. }
          claim H0pre: 0 :e preU.
          { exact (SepI unit_interval (fun t0:set => apply_fun p t0 :e U) 0 H0I HxU). }
          claim Hsub: preU c= Empty.
          { rewrite Heq. exact (Subq_ref Empty). }
          claim H0Empty: 0 :e Empty.
          { exact (Hsub 0 H0pre). }
          exact (EmptyE 0 H0Empty).
      + (** preV <> Empty **)
        assume Heq: preV = Empty.
        claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
        { exact zero_one_in_unit_interval. }
        claim H1I: 1 :e unit_interval.
        { exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }
        claim HyV: apply_fun p 1 :e V.
        { rewrite Hp1eq. exact Hy. }
        claim H1pre: 1 :e preV.
        { exact (SepI unit_interval (fun t0:set => apply_fun p t0 :e V) 1 H1I HyV). }
        claim Hsub: preV c= Empty.
        { rewrite Heq. exact (Subq_ref Empty). }
        claim H1Empty: 1 :e Empty.
        { exact (Hsub 1 H1pre). }
        exact (EmptyE 1 H1Empty).
    - prove preU :\/: preV = unit_interval.
      apply set_ext.
      + let t. assume Ht: t :e preU :\/: preV.
        prove t :e unit_interval.
        apply (binunionE preU preV t Ht).
        - assume HtU: t :e preU.
          exact (SepE1 unit_interval (fun t0:set => apply_fun p t0 :e U) t HtU).
        - assume HtV: t :e preV.
          exact (SepE1 unit_interval (fun t0:set => apply_fun p t0 :e V) t HtV).
      + let t. assume HtI: t :e unit_interval.
        prove t :e preU :\/: preV.
        claim HptX: apply_fun p t :e X.
        { exact (Hpfunc t HtI). }
        claim HptUV: apply_fun p t :e U :\/: V.
        { rewrite HunionUV. exact HptX. }
        apply (binunionE U V (apply_fun p t) HptUV).
        - assume HptU: apply_fun p t :e U.
          apply binunionI1.
          exact (SepI unit_interval (fun t0:set => apply_fun p t0 :e U) t HtI HptU).
        - assume HptV: apply_fun p t :e V.
          apply binunionI2.
          exact (SepI unit_interval (fun t0:set => apply_fun p t0 :e V) t HtI HptV). }
  (** Preimages are open in unit_interval_topology **)
  claim HpreimgU: preU :e unit_interval_topology.
  { exact (andER (topology_on unit_interval unit_interval_topology /\ topology_on X Tx /\ function_on p unit_interval X)
                 (forall V0:set, V0 :e Tx -> preimage_of unit_interval p V0 :e unit_interval_topology)
                 Hpcont U HU). }
  claim HpreimgV: preV :e unit_interval_topology.
  { exact (andER (topology_on unit_interval unit_interval_topology /\ topology_on X Tx /\ function_on p unit_interval X)
                 (forall V0:set, V0 :e Tx -> preimage_of unit_interval p V0 :e unit_interval_topology)
                 Hpcont V HV). }
  (** This gives a separation of unit_interval **)
  claim Hsep_exists: exists U0 V0:set, U0 :e unit_interval_topology /\ V0 :e unit_interval_topology /\ separation_of unit_interval U0 V0.
  { witness preU. witness preV.
    prove preU :e unit_interval_topology /\ preV :e unit_interval_topology /\ separation_of unit_interval preU preV.
    apply andI.
    - apply andI.
      + exact HpreimgU.
      + exact HpreimgV.
    - exact Hsep_UV. }
  (** Contradiction with connectedness of unit_interval **)
  claim Hunit_nosep: ~(exists U0 V0:set, U0 :e unit_interval_topology /\ V0 :e unit_interval_topology /\ separation_of unit_interval U0 V0).
  { exact (andER (topology_on unit_interval unit_interval_topology)
                 (~(exists U0 V0:set, U0 :e unit_interval_topology /\ V0 :e unit_interval_topology /\ separation_of unit_interval U0 V0))
                 unit_interval_connected). }
  apply Hunit_nosep.
  exact Hsep_exists.
Qed.

(** from §24 Example: punctured euclidean space is path connected (placeholder) **)
(** LATEX VERSION: The plane with the origin removed is path connected. **)
(** FIXED: Origin is the ordered pair (0,0) so the removed set is {(0,0)}; setprod 0 0 is ∅ and does not represent the origin. **)
Theorem punctured_space_path_connected :
  path_connected_space (EuclidPlane :\: {(0,0)})
    (subspace_topology EuclidPlane R2_standard_topology (EuclidPlane :\: {(0,0)})).
prove path_connected_space (EuclidPlane :\: {(0,0)}) (subspace_topology EuclidPlane R2_standard_topology (EuclidPlane :\: {(0,0)})).
set X := EuclidPlane :\: {(0,0)}.
set Tx := subspace_topology EuclidPlane R2_standard_topology X.
prove topology_on X Tx /\
  forall x y:set, x :e X -> y :e X ->
    exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
apply andI.
- (** topology_on X Tx **)
  claim HtopPlane: topology_on EuclidPlane R2_standard_topology.
  { exact (product_topology_is_topology R R_standard_topology R R_standard_topology
           R_standard_topology_is_topology R_standard_topology_is_topology). }
  claim HXsub: X c= EuclidPlane.
  { exact (setminus_Subq EuclidPlane {(0,0)}). }
  exact (subspace_topology_is_topology EuclidPlane R2_standard_topology X HtopPlane HXsub).
- (** path connectedness (stub) **)
  let x y.
  assume Hx: x :e X.
	  assume Hy: y :e X.
	  prove exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
	  admit. (** FAIL **)
Qed.

(** from §24: continuous surjective image of a path connected space is path connected **) 
(** LATEX VERSION: If f:X→Y is continuous and surjective and X is path connected, then Y is path connected. **)
Theorem continuous_image_path_connected : forall X Tx Y Ty f:set,
  path_connected_space X Tx ->
  continuous_map X Tx Y Ty f ->
  (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y) ->
  path_connected_space Y Ty.
let X Tx Y Ty f.
assume Hpath: path_connected_space X Tx.
assume Hf: continuous_map X Tx Y Ty f.
assume Hsurj: forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y.
prove path_connected_space Y Ty.
(** Extract topology on Y from continuity hypothesis **)
claim Hf_left: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
              (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hf). }
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on X Tx) (topology_on Y Ty)
              (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hf_left)). }
claim Hpath_prop: forall x y:set, x :e X -> y :e X ->
  exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
{ let x y.
  assume Hx: x :e X.
  assume Hy: y :e X.
  exact (path_connected_space_paths X Tx x y Hpath Hx Hy). }

prove topology_on Y Ty /\
  forall y1 y2:set, y1 :e Y -> y2 :e Y ->
    exists p:set, path_between Y y1 y2 p /\ continuous_map unit_interval unit_interval_topology Y Ty p.
apply andI.
- exact HTy.
- let y1 y2.
  assume Hy1: y1 :e Y.
  assume Hy2: y2 :e Y.
  prove exists p:set, path_between Y y1 y2 p /\ continuous_map unit_interval unit_interval_topology Y Ty p.
  (** Choose preimages x1,x2 in X with f(xi)=yi **)
  apply (Hsurj y1 Hy1).
  let x1. assume Hx1pair: x1 :e X /\ apply_fun f x1 = y1.
  apply (Hsurj y2 Hy2).
  let x2. assume Hx2pair: x2 :e X /\ apply_fun f x2 = y2.
  claim Hx1X: x1 :e X.
  { exact (andEL (x1 :e X) (apply_fun f x1 = y1) Hx1pair). }
  claim Hfx1: apply_fun f x1 = y1.
  { exact (andER (x1 :e X) (apply_fun f x1 = y1) Hx1pair). }
  claim Hx2X: x2 :e X.
  { exact (andEL (x2 :e X) (apply_fun f x2 = y2) Hx2pair). }
  claim Hfx2: apply_fun f x2 = y2.
  { exact (andER (x2 :e X) (apply_fun f x2 = y2) Hx2pair). }

  (** Get a path p in X from x1 to x2 **)
  apply (Hpath_prop x1 x2 Hx1X Hx2X).
  let p. assume Hp_pair: path_between X x1 x2 p /\ continuous_map unit_interval unit_interval_topology X Tx p.
  claim Hp_between: path_between X x1 x2 p.
  { exact (path_witness_between X Tx x1 x2 p Hp_pair). }
  claim Hp_cont: continuous_map unit_interval unit_interval_topology X Tx p.
  { exact (path_witness_continuous X Tx x1 x2 p Hp_pair). }

  (** Define the composed path q = f ∘ p **)
  set q := compose_fun unit_interval p f.
  claim Hq_cont: continuous_map unit_interval unit_interval_topology Y Ty q.
  { exact (composition_continuous unit_interval unit_interval_topology X Tx Y Ty p f Hp_cont Hf). }
  claim Hq_left: (topology_on unit_interval unit_interval_topology /\ topology_on Y Ty) /\ function_on q unit_interval Y.
  { exact (andEL ((topology_on unit_interval unit_interval_topology /\ topology_on Y Ty) /\ function_on q unit_interval Y)
                (forall V:set, V :e Ty -> preimage_of unit_interval q V :e unit_interval_topology) Hq_cont). }
  claim Hq_fun: function_on q unit_interval Y.
  { exact (andER (topology_on unit_interval unit_interval_topology /\ topology_on Y Ty)
                (function_on q unit_interval Y) Hq_left). }

  (** Endpoints of q **)
  claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
  { exact zero_one_in_unit_interval. }
  claim H0: 0 :e unit_interval.
  { exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
  claim H1: 1 :e unit_interval.
  { exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }

  claim Hp_left: function_on p unit_interval X /\ apply_fun p 0 = x1.
  { exact (path_between_pair0 X x1 x2 p Hp_between). }
  claim Hp0: apply_fun p 0 = x1.
  { exact (path_between_at_zero X x1 x2 p Hp_between). }
  claim Hp1: apply_fun p 1 = x2.
  { exact (path_between_at_one X x1 x2 p Hp_between). }

  claim Hq0: apply_fun q 0 = y1.
  { claim Hq0a: apply_fun q 0 = apply_fun f (apply_fun p 0).
    { exact (compose_fun_apply unit_interval p f 0 H0). }
    rewrite Hq0a.
    rewrite Hp0.
    rewrite Hfx1.
    reflexivity. }
  claim Hq1: apply_fun q 1 = y2.
  { claim Hq1a: apply_fun q 1 = apply_fun f (apply_fun p 1).
    { exact (compose_fun_apply unit_interval p f 1 H1). }
    rewrite Hq1a.
    rewrite Hp1.
    rewrite Hfx2.
    reflexivity. }

  witness q.
  prove path_between Y y1 y2 q /\ continuous_map unit_interval unit_interval_topology Y Ty q.
  apply andI.
  - (** path_between **)
    prove function_on q unit_interval Y /\ apply_fun q 0 = y1 /\ apply_fun q 1 = y2.
    apply andI.
    + apply andI.
      * exact Hq_fun.
      * exact Hq0.
    + exact Hq1.
  - exact Hq_cont.
Qed.

(** from §24 Definition: path components equivalence relation **) 
(** LATEX VERSION: The path component of x is the set of points y that can be joined to x by a path in X. **)
Definition path_component_of : set -> set -> set -> set := fun X Tx x =>
  {y :e X | exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y}.

(** Helper axioms: path reversal and concatenation **)
Theorem path_component_symmetric_axiom : forall X Tx x y:set,
  topology_on X Tx -> x :e X -> y :e X ->
  y :e path_component_of X Tx x -> x :e path_component_of X Tx y.
let X Tx x y.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
assume HyX: y :e X.
assume HyPc: y :e path_component_of X Tx x.
prove x :e path_component_of X Tx y.
prove x :e {z :e X | exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = y /\ apply_fun p 1 = z}.
apply SepI.
- exact HxX.
- (** extract a path p from x to y, then reverse it **)
  prove exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = y /\ apply_fun p 1 = x.
  claim Hex: exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y.
  { exact (SepE2 X (fun y0:set => exists p:set,
       function_on p unit_interval X /\
       continuous_map unit_interval unit_interval_topology X Tx p /\
       apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyPc). }
  set p0 := Eps_i (fun p:set =>
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y).
  claim Hp0prop:
     function_on p0 unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p0 /\
     apply_fun p0 0 = x /\ apply_fun p0 1 = y.
  { exact (Eps_i_ex (fun p:set =>
       function_on p unit_interval X /\
       continuous_map unit_interval unit_interval_topology X Tx p /\
       apply_fun p 0 = x /\ apply_fun p 1 = y) Hex). }
  (** Hp0prop is a left-associated conjunction: (((P /\ Q) /\ R) /\ S) **)
  claim Hp0A:
    ((function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0) /\
      apply_fun p0 0 = x) /\
    apply_fun p0 1 = y.
  { exact Hp0prop. }
  claim Hp0B:
    (function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0) /\
    apply_fun p0 0 = x.
  { exact (andEL ((function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0) /\
                   apply_fun p0 0 = x)
                 (apply_fun p0 1 = y)
                 Hp0A). }
  claim Hp0C: function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0.
  { exact (andEL (function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0)
                 (apply_fun p0 0 = x)
                 Hp0B). }
  claim Hp_fun: function_on p0 unit_interval X.
  { exact (andEL (function_on p0 unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx p0)
                 Hp0C). }
  claim Hp_cont: continuous_map unit_interval unit_interval_topology X Tx p0.
  { exact (andER (function_on p0 unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx p0)
                 Hp0C). }
  claim Hp0eq: apply_fun p0 0 = x.
  { exact (andER (function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0)
                 (apply_fun p0 0 = x)
                 Hp0B). }
  claim Hp1eq: apply_fun p0 1 = y.
  { exact (andER ((function_on p0 unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p0) /\
                   apply_fun p0 0 = x)
                 (apply_fun p0 1 = y)
                 Hp0A). }

	  set q := compose_fun unit_interval flip_unit_interval p0.
	  witness q.
	  prove function_on q unit_interval X /\
	       continuous_map unit_interval unit_interval_topology X Tx q /\
	       apply_fun q 0 = y /\ apply_fun q 1 = x.
	  apply andI.
	  - (** left-associative goals: ((fun_on /\ cont) /\ q0eq) **)
	    apply andI.
	    + (** fun_on /\ cont **)
	      apply andI.
	      * exact (function_on_compose_fun unit_interval unit_interval X
	               flip_unit_interval p0
	               flip_unit_interval_function_on
	               Hp_fun).
	      * exact (composition_continuous unit_interval unit_interval_topology
	               unit_interval unit_interval_topology
	               X Tx
	               flip_unit_interval p0
	               flip_unit_interval_continuous
	               Hp_cont).
	    + (** q 0 = y **)
	      claim H0I: 0 :e unit_interval.
	      { exact zero_in_unit_interval. }
	      claim Hq0: apply_fun q 0 = apply_fun p0 (apply_fun flip_unit_interval 0).
	      { exact (compose_fun_apply unit_interval flip_unit_interval p0 0 H0I). }
	      rewrite Hq0.
	      rewrite flip_unit_interval_at_0.
	      rewrite Hp1eq.
	      reflexivity.
	  - (** q 1 = x **)
	    claim H1I: 1 :e unit_interval.
	    { exact one_in_unit_interval. }
	    claim Hq1: apply_fun q 1 = apply_fun p0 (apply_fun flip_unit_interval 1).
	    { exact (compose_fun_apply unit_interval flip_unit_interval p0 1 H1I). }
	    rewrite Hq1.
	    rewrite flip_unit_interval_at_1.
	    rewrite Hp0eq.
	    reflexivity.
Qed.

(** Helper infrastructure for concatenating paths on the unit interval **)
(** The midpoint is eps_ 1, and twice eps_ 1 equals 1. **)

(** left half of the unit interval: [0, eps_ 1] encoded by negated strict inequality **)
(** from §25: concatenating paths (split the parameter interval) **)
(** LATEX VERSION: Split I=[0,1] into the halves [0,1/2] and [1/2,1] and rescale them to define concatenation of paths. **)
Definition unit_interval_left_half : set :=
  {t :e unit_interval | ~(Rlt (eps_ 1) t)}.

(** right half of the unit interval: [eps_ 1, 1] encoded by negated strict inequality **)
(** from §25: concatenating paths (split the parameter interval) **)
(** LATEX VERSION: The right half [1/2,1] of I, used to rescale and paste paths. **)
Definition unit_interval_right_half : set :=
  {t :e unit_interval | ~(Rlt t (eps_ 1))}.

Theorem unit_interval_left_half_sub : unit_interval_left_half c= unit_interval.
let t.
assume Ht: t :e unit_interval_left_half.
exact (SepE1 unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) t Ht).
Qed.

Theorem unit_interval_right_half_sub : unit_interval_right_half c= unit_interval.
let t.
assume Ht: t :e unit_interval_right_half.
exact (SepE1 unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) t Ht).
Qed.

(** scaling maps used for concatenation, defined only on the appropriate halves **)
(** from §25: concatenating paths (rescaling maps) **)
(** LATEX VERSION: Use t↦2t on [0,1/2] and t↦2t−1 on [1/2,1] to reparametrize two paths into one. **)
Definition double_map_left_half : set := graph unit_interval_left_half (fun t:set => mul_SNo 2 t).
Definition double_minus_one_map_right_half : set :=
  graph unit_interval_right_half (fun t:set => add_SNo (mul_SNo 2 t) (minus_SNo 1)).

Theorem double_map_apply : forall t:set,
  t :e unit_interval_left_half ->
  apply_fun double_map_left_half t = mul_SNo 2 t.
let t.
assume Ht: t :e unit_interval_left_half.
rewrite (apply_fun_graph unit_interval_left_half (fun t0:set => mul_SNo 2 t0) t Ht).
reflexivity.
Qed.

Theorem double_minus_one_map_apply : forall t:set,
  t :e unit_interval_right_half ->
  apply_fun double_minus_one_map_right_half t = add_SNo (mul_SNo 2 t) (minus_SNo 1).
let t.
assume Ht: t :e unit_interval_right_half.
rewrite (apply_fun_graph unit_interval_right_half (fun t0:set => add_SNo (mul_SNo 2 t0) (minus_SNo 1)) t Ht).
reflexivity.
Qed.

(** helper: scaling by 2 via eps_ 1 preserves strict inequalities on R **)
Theorem Rlt_mul2_left_iff : forall a t:set,
  a :e R -> t :e R -> (Rlt a (mul_SNo 2 t) <-> Rlt (mul_SNo (eps_ 1) a) t).
let a t.
assume HaR: a :e R.
assume HtR: t :e R.
prove (Rlt a (mul_SNo 2 t) <-> Rlt (mul_SNo (eps_ 1) a) t).
apply iffI.
- assume Halt: Rlt a (mul_SNo 2 t).
  prove Rlt (mul_SNo (eps_ 1) a) t.
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim He1S: SNo (eps_ 1).
  { exact SNo_eps_1. }
  claim Hm2tS: SNo (mul_SNo 2 t).
  { exact (SNo_mul_SNo 2 t H2S HtS). }
  claim H0lte1: 0 < (eps_ 1).
  { exact (RltE_lt 0 (eps_ 1) eps_1_pos_R). }
  claim HaltS: a < mul_SNo 2 t.
  { exact (RltE_lt a (mul_SNo 2 t) Halt). }
  claim Hmul: mul_SNo (eps_ 1) a < mul_SNo (eps_ 1) (mul_SNo 2 t).
  { exact (pos_mul_SNo_Lt (eps_ 1) a (mul_SNo 2 t) He1S H0lte1 HaS Hm2tS HaltS). }
  claim Heq: mul_SNo (eps_ 1) (mul_SNo 2 t) = t.
  { rewrite (mul_SNo_assoc (eps_ 1) 2 t He1S H2S HtS).
    rewrite (mul_SNo_com (eps_ 1) 2 He1S H2S).
    rewrite eps_1_half_eq2.
    exact (mul_SNo_oneL t HtS). }
  claim Hmul': mul_SNo (eps_ 1) a < t.
  { rewrite <- Heq.
    exact Hmul. }
  claim Hmule1aR: mul_SNo (eps_ 1) a :e R.
  { claim HdefR: R = real.
    { reflexivity. }
    rewrite HdefR.
    claim HaReal: a :e real.
    { rewrite <- HdefR.
      exact HaR. }
    claim He1Real: (eps_ 1) :e real.
    { rewrite <- HdefR.
      exact eps_1_in_R. }
    exact (real_mul_SNo (eps_ 1) He1Real a HaReal). }
  exact (RltI (mul_SNo (eps_ 1) a) t Hmule1aR HtR Hmul').
- assume Hlt: Rlt (mul_SNo (eps_ 1) a) t.
  prove Rlt a (mul_SNo 2 t).
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim He1S: SNo (eps_ 1).
  { exact SNo_eps_1. }
  claim He1aS: SNo (mul_SNo (eps_ 1) a).
  { exact (SNo_mul_SNo (eps_ 1) a He1S HaS). }
  claim H0lt2: 0 < 2.
  { exact (SNoLt_0_2). }
  claim HltS: mul_SNo (eps_ 1) a < t.
  { exact (RltE_lt (mul_SNo (eps_ 1) a) t Hlt). }
  claim Hmul: mul_SNo 2 (mul_SNo (eps_ 1) a) < mul_SNo 2 t.
  { exact (pos_mul_SNo_Lt 2 (mul_SNo (eps_ 1) a) t H2S H0lt2 He1aS HtS HltS). }
  claim Heq: mul_SNo 2 (mul_SNo (eps_ 1) a) = a.
  { rewrite (mul_SNo_assoc 2 (eps_ 1) a H2S He1S HaS).
    rewrite eps_1_half_eq2.
    exact (mul_SNo_oneL a HaS). }
  claim Hmul': a < mul_SNo 2 t.
  { rewrite <- Heq at 1.
    exact Hmul. }
  claim H2tR: mul_SNo 2 t :e R.
  { claim HdefR: R = real.
    { reflexivity. }
    rewrite HdefR.
    claim H2Real: 2 :e real.
    { rewrite <- HdefR.
      exact real_2. }
    claim HtReal: t :e real.
    { rewrite <- HdefR.
      exact HtR. }
    exact (real_mul_SNo 2 H2Real t HtReal). }
  exact (RltI a (mul_SNo 2 t) HaR H2tR Hmul').
Qed.

(** helper: scaling by 2 via eps_ 1 on the right-hand side **)
Theorem Rlt_mul2_right_iff : forall t b:set,
  t :e R -> b :e R -> (Rlt (mul_SNo 2 t) b <-> Rlt t (mul_SNo (eps_ 1) b)).
let t b.
assume HtR: t :e R.
assume HbR: b :e R.
prove (Rlt (mul_SNo 2 t) b <-> Rlt t (mul_SNo (eps_ 1) b)).
apply iffI.
- assume Hlt: Rlt (mul_SNo 2 t) b.
  prove Rlt t (mul_SNo (eps_ 1) b).
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim He1S: SNo (eps_ 1).
  { exact SNo_eps_1. }
  claim H2tS: SNo (mul_SNo 2 t).
  { exact (SNo_mul_SNo 2 t H2S HtS). }
  claim H0lte1: 0 < (eps_ 1).
  { exact (RltE_lt 0 (eps_ 1) eps_1_pos_R). }
  claim HltS: mul_SNo 2 t < b.
  { exact (RltE_lt (mul_SNo 2 t) b Hlt). }
  claim Hmul: mul_SNo (eps_ 1) (mul_SNo 2 t) < mul_SNo (eps_ 1) b.
  { exact (pos_mul_SNo_Lt (eps_ 1) (mul_SNo 2 t) b He1S H0lte1 H2tS HbS HltS). }
  claim Heq: mul_SNo (eps_ 1) (mul_SNo 2 t) = t.
  { rewrite (mul_SNo_assoc (eps_ 1) 2 t He1S H2S HtS).
    rewrite (mul_SNo_com (eps_ 1) 2 He1S H2S).
    rewrite eps_1_half_eq2.
    exact (mul_SNo_oneL t HtS). }
  claim Hmul': t < mul_SNo (eps_ 1) b.
  { rewrite <- Heq at 1.
    exact Hmul. }
  claim He1bR: mul_SNo (eps_ 1) b :e R.
  { claim HdefR: R = real.
    { reflexivity. }
    rewrite HdefR.
    claim HbReal: b :e real.
    { rewrite <- HdefR.
      exact HbR. }
    claim He1Real: (eps_ 1) :e real.
    { rewrite <- HdefR.
      exact eps_1_in_R. }
    exact (real_mul_SNo (eps_ 1) He1Real b HbReal). }
  exact (RltI t (mul_SNo (eps_ 1) b) HtR He1bR Hmul').
- assume Hlt: Rlt t (mul_SNo (eps_ 1) b).
  prove Rlt (mul_SNo 2 t) b.
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim He1S: SNo (eps_ 1).
  { exact SNo_eps_1. }
  claim He1bS: SNo (mul_SNo (eps_ 1) b).
  { exact (SNo_mul_SNo (eps_ 1) b He1S HbS). }
  claim H0lt2: 0 < 2.
  { exact (SNoLt_0_2). }
  claim HltS: t < mul_SNo (eps_ 1) b.
  { exact (RltE_lt t (mul_SNo (eps_ 1) b) Hlt). }
  claim Hmul: mul_SNo 2 t < mul_SNo 2 (mul_SNo (eps_ 1) b).
  { exact (pos_mul_SNo_Lt 2 t (mul_SNo (eps_ 1) b) H2S H0lt2 HtS He1bS HltS). }
  claim Heq: mul_SNo 2 (mul_SNo (eps_ 1) b) = b.
  { rewrite (mul_SNo_assoc 2 (eps_ 1) b H2S He1S HbS).
    rewrite eps_1_half_eq2.
    exact (mul_SNo_oneL b HbS). }
  claim Hmul': mul_SNo 2 t < b.
  { rewrite <- Heq.
    exact Hmul. }
  claim H2tR: mul_SNo 2 t :e R.
  { claim HdefR: R = real.
    { reflexivity. }
    rewrite HdefR.
    claim H2Real: 2 :e real.
    { rewrite <- HdefR.
      exact real_2. }
    claim HtReal: t :e real.
    { rewrite <- HdefR.
      exact HtR. }
    exact (real_mul_SNo 2 H2Real t HtReal). }
  exact (RltI (mul_SNo 2 t) b H2tR HbR Hmul').
Qed.

Theorem zero_in_unit_interval_left_half : 0 :e unit_interval_left_half.
prove 0 :e unit_interval_left_half.
claim H0I: 0 :e unit_interval.
{ exact zero_in_unit_interval. }
exact (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0))
           0 H0I
           (not_Rlt_sym 0 (eps_ 1) eps_1_pos_R)).
Qed.

Theorem eps_1_in_unit_interval_left_half : eps_ 1 :e unit_interval_left_half.
prove eps_ 1 :e unit_interval_left_half.
claim HeI: eps_ 1 :e unit_interval.
{ exact eps_1_in_unit_interval. }
claim Hnlt: ~(Rlt (eps_ 1) (eps_ 1)).
{ exact (not_Rlt_refl (eps_ 1) eps_1_in_R). }
exact (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) (eps_ 1) HeI Hnlt).
Qed.

Theorem eps_1_in_unit_interval_right_half : eps_ 1 :e unit_interval_right_half.
prove eps_ 1 :e unit_interval_right_half.
claim HeI: eps_ 1 :e unit_interval.
{ exact eps_1_in_unit_interval. }
claim Hnlt: ~(Rlt (eps_ 1) (eps_ 1)).
{ exact (not_Rlt_refl (eps_ 1) eps_1_in_R). }
exact (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) (eps_ 1) HeI Hnlt).
Qed.

Theorem one_in_unit_interval_right_half : 1 :e unit_interval_right_half.
prove 1 :e unit_interval_right_half.
claim H1I: 1 :e unit_interval.
{ exact one_in_unit_interval. }
claim Hnlt: ~(Rlt 1 (eps_ 1)).
{ exact (not_Rlt_sym (eps_ 1) 1 eps_1_lt1_R). }
exact (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) 1 H1I Hnlt).
Qed.

Theorem double_map_at_0 : apply_fun double_map_left_half 0 = 0.
prove apply_fun double_map_left_half 0 = 0.
claim H0I: 0 :e unit_interval.
{ exact zero_in_unit_interval. }
rewrite (double_map_apply 0 zero_in_unit_interval_left_half).
rewrite (mul_SNo_zeroR 2 SNo_2).
reflexivity.
Qed.

Theorem double_map_at_eps1 : apply_fun double_map_left_half (eps_ 1) = 1.
prove apply_fun double_map_left_half (eps_ 1) = 1.
rewrite (double_map_apply (eps_ 1) eps_1_in_unit_interval_left_half).
exact eps_1_half_eq2.
Qed.

Theorem double_minus_one_map_at_eps1 : apply_fun double_minus_one_map_right_half (eps_ 1) = 0.
prove apply_fun double_minus_one_map_right_half (eps_ 1) = 0.
rewrite (double_minus_one_map_apply (eps_ 1) eps_1_in_unit_interval_right_half).
rewrite eps_1_half_eq2.
rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
reflexivity.
Qed.

Theorem double_minus_one_map_at_1 : apply_fun double_minus_one_map_right_half 1 = 1.
prove apply_fun double_minus_one_map_right_half 1 = 1.
rewrite (double_minus_one_map_apply 1 one_in_unit_interval_right_half).
rewrite (mul_SNo_oneR 2 SNo_2).
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (real_SNo (minus_SNo 1) Hm1R). }
rewrite <- add_SNo_1_1_2 at 1.
rewrite <- (add_SNo_assoc 1 1 (minus_SNo 1) SNo_1 SNo_1 Hm1S) at 1.
claim Hinner: add_SNo 1 (minus_SNo 1) = 0.
{ exact (add_SNo_minus_SNo_rinv 1 SNo_1). }
rewrite Hinner.
rewrite (add_SNo_0R 1 SNo_1).
reflexivity.
Qed.

(** placeholders: properties needed to justify concatenation via the pasting lemma **)
Theorem unit_interval_halves_cover :
  unit_interval_left_half :\/: unit_interval_right_half = unit_interval.
prove unit_interval_left_half :\/: unit_interval_right_half = unit_interval.
apply set_ext.
- let t. assume Ht: t :e unit_interval_left_half :\/: unit_interval_right_half.
  prove t :e unit_interval.
  apply (binunionE unit_interval_left_half unit_interval_right_half t Ht).
  * assume HtL: t :e unit_interval_left_half.
    exact (unit_interval_left_half_sub t HtL).
  * assume HtR: t :e unit_interval_right_half.
    exact (unit_interval_right_half_sub t HtR).
- let t. assume HtI: t :e unit_interval.
  prove t :e unit_interval_left_half :\/: unit_interval_right_half.
  apply (xm (Rlt t (eps_ 1))).
  * assume Htlt: Rlt t (eps_ 1).
    claim Hnlt: ~(Rlt (eps_ 1) t).
    { exact (not_Rlt_sym t (eps_ 1) Htlt). }
    claim HtL: t :e unit_interval_left_half.
    { exact (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) t HtI Hnlt). }
    exact (binunionI1 unit_interval_left_half unit_interval_right_half t HtL).
  * assume Hnlt: ~(Rlt t (eps_ 1)).
    claim HtR: t :e unit_interval_right_half.
    { exact (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) t HtI Hnlt). }
    exact (binunionI2 unit_interval_left_half unit_interval_right_half t HtR).
Qed.

Theorem unit_interval_halves_closed :
  closed_in unit_interval unit_interval_topology unit_interval_left_half /\
  closed_in unit_interval unit_interval_topology unit_interval_right_half.
prove closed_in unit_interval unit_interval_topology unit_interval_left_half /\
  closed_in unit_interval unit_interval_topology unit_interval_right_half.
apply andI.
- (** left half is closed in the subspace topology **)
  apply (closed_inI unit_interval unit_interval_topology unit_interval_left_half).
  * exact unit_interval_topology_on.
  * exact unit_interval_left_half_sub.
  * set V := {x :e R|Rlt (eps_ 1) x}.
	set U := V :/\: unit_interval.
	witness U.
	apply andI.
	- (** U is open in the unit interval topology **)
	   claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
	   { reflexivity. }
	   rewrite Hut.
	   claim HUpow: U :e Power unit_interval.
	   { exact (PowerI unit_interval U (binintersect_Subq_2 V unit_interval)). }
       claim Hex: exists W :e R_standard_topology, U = W :/\: unit_interval.
       { witness V.
         apply andI.
         - exact (open_ray_in_R_standard_topology (eps_ 1) eps_1_in_R).
         - reflexivity. }
       exact (SepI (Power unit_interval)
                   (fun U0:set => exists W :e R_standard_topology, U0 = W :/\: unit_interval)
                   U HUpow Hex).
	- (** left half is the complement of U in unit_interval **)
	   prove unit_interval_left_half = unit_interval :\: U.
	   apply set_ext.
       - let t. assume HtL: t :e unit_interval_left_half.
         prove t :e unit_interval :\: U.
         apply setminusI.
         + exact (unit_interval_left_half_sub t HtL).
         + assume HtU: t :e U.
           prove False.
           claim HtV: t :e V.
           { exact (binintersectE1 V unit_interval t HtU). }
           claim Hnlt: ~(Rlt (eps_ 1) t).
           { exact (SepE2 unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) t HtL). }
           claim Hlt: Rlt (eps_ 1) t.
           { exact (SepE2 R (fun x0:set => Rlt (eps_ 1) x0) t HtV). }
           exact (Hnlt Hlt).
       - let t. assume Ht: t :e unit_interval :\: U.
         prove t :e unit_interval_left_half.
         claim HtI: t :e unit_interval.
         { exact (setminusE1 unit_interval U t Ht). }
         apply (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) t HtI).
         prove ~(Rlt (eps_ 1) t).
         assume Hlt: Rlt (eps_ 1) t.
         prove False.
         claim HtR: t :e R.
         { exact (unit_interval_sub_R t HtI). }
         claim HtV: t :e V.
         { exact (SepI R (fun x0:set => Rlt (eps_ 1) x0) t HtR Hlt). }
         claim HtU2: t :e U.
         { exact (binintersectI V unit_interval t HtV HtI). }
         claim HnotU: t /:e U.
         { exact (setminusE2 unit_interval U t Ht). }
         exact (HnotU HtU2).
- (** right half is closed in the subspace topology **)
  apply (closed_inI unit_interval unit_interval_topology unit_interval_right_half).
  * exact unit_interval_topology_on.
  * exact unit_interval_right_half_sub.
  * set V := {x :e R|Rlt x (eps_ 1)}.
	set U := V :/\: unit_interval.
	witness U.
	apply andI.
	- (** U is open in the unit interval topology **)
	   claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
	   { reflexivity. }
	   rewrite Hut.
	   claim HUpow: U :e Power unit_interval.
	   { exact (PowerI unit_interval U (binintersect_Subq_2 V unit_interval)). }
       claim Hex: exists W :e R_standard_topology, U = W :/\: unit_interval.
       { witness V.
         apply andI.
         - exact (open_left_ray_in_R_standard_topology (eps_ 1) eps_1_in_R).
         - reflexivity. }
       exact (SepI (Power unit_interval)
                   (fun U0:set => exists W :e R_standard_topology, U0 = W :/\: unit_interval)
                   U HUpow Hex).
	- (** right half is the complement of U in unit_interval **)
	   prove unit_interval_right_half = unit_interval :\: U.
	   apply set_ext.
       - let t. assume HtR: t :e unit_interval_right_half.
         prove t :e unit_interval :\: U.
         apply setminusI.
         + exact (unit_interval_right_half_sub t HtR).
         + assume HtU: t :e U.
           prove False.
           claim HtV: t :e V.
           { exact (binintersectE1 V unit_interval t HtU). }
           claim Hnlt: ~(Rlt t (eps_ 1)).
           { exact (SepE2 unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) t HtR). }
           claim Hlt: Rlt t (eps_ 1).
           { exact (SepE2 R (fun x0:set => Rlt x0 (eps_ 1)) t HtV). }
           exact (Hnlt Hlt).
       - let t. assume Ht: t :e unit_interval :\: U.
         prove t :e unit_interval_right_half.
         claim HtI: t :e unit_interval.
         { exact (setminusE1 unit_interval U t Ht). }
         apply (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) t HtI).
         prove ~(Rlt t (eps_ 1)).
         assume Hlt: Rlt t (eps_ 1).
         prove False.
         claim HtR: t :e R.
         { exact (unit_interval_sub_R t HtI). }
         claim HtV: t :e V.
         { exact (SepI R (fun x0:set => Rlt x0 (eps_ 1)) t HtR Hlt). }
         claim HtU2: t :e U.
         { exact (binintersectI V unit_interval t HtV HtI). }
         claim HnotU: t /:e U.
         { exact (setminusE2 unit_interval U t Ht). }
         exact (HnotU HtU2).
Qed.

Theorem unit_interval_halves_intersection :
  (unit_interval_left_half :/\: unit_interval_right_half) = {eps_ 1}.
prove (unit_interval_left_half :/\: unit_interval_right_half) = {eps_ 1}.
apply set_ext.
- let t. assume Ht: t :e (unit_interval_left_half :/\: unit_interval_right_half).
  prove t :e {eps_ 1}.
  claim HtL: t :e unit_interval_left_half.
  { exact (binintersectE1 unit_interval_left_half unit_interval_right_half t Ht). }
  claim HtR: t :e unit_interval_right_half.
  { exact (binintersectE2 unit_interval_left_half unit_interval_right_half t Ht). }
  claim HtI: t :e unit_interval.
  { exact (unit_interval_left_half_sub t HtL). }
  claim HtReal: t :e R.
  { exact (unit_interval_sub_R t HtI). }
  claim HeReal: eps_ 1 :e R.
  { exact eps_1_in_R. }
  claim HtS: SNo t.
  { exact (real_SNo t HtReal). }
  claim HeS: SNo (eps_ 1).
  { exact (real_SNo (eps_ 1) HeReal). }
  claim Hnlt_et: ~(Rlt (eps_ 1) t).
  { exact (SepE2 unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) t HtL). }
  claim Hnlt_te: ~(Rlt t (eps_ 1)).
  { exact (SepE2 unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) t HtR). }
  apply (SNoLt_trichotomy_or_impred t (eps_ 1) HtS HeS (t :e {eps_ 1})).
  * assume HtltS: t < (eps_ 1).
    claim Htlt: Rlt t (eps_ 1).
    { exact (RltI t (eps_ 1) HtReal HeReal HtltS). }
    apply FalseE.
    exact (Hnlt_te Htlt).
  * assume Heq: t = eps_ 1.
    rewrite Heq.
    exact (SingI (eps_ 1)).
  * assume HeltS: (eps_ 1) < t.
    claim Helt: Rlt (eps_ 1) t.
    { exact (RltI (eps_ 1) t HeReal HtReal HeltS). }
    apply FalseE.
    exact (Hnlt_et Helt).
 - let t. assume Ht: t :e {eps_ 1}.
  prove t :e (unit_interval_left_half :/\: unit_interval_right_half).
  claim Hteq: t = eps_ 1.
  { exact (SingE (eps_ 1) t Ht). }
  rewrite Hteq.
  claim HeI: eps_ 1 :e unit_interval.
  { exact eps_1_in_unit_interval. }
  claim Hnlt_e: ~(Rlt (eps_ 1) (eps_ 1)).
  { exact (not_Rlt_refl (eps_ 1) eps_1_in_R). }
  claim Hnlt_e2: ~(Rlt (eps_ 1) (eps_ 1)).
  { exact (not_Rlt_refl (eps_ 1) eps_1_in_R). }
  claim HeL: eps_ 1 :e unit_interval_left_half.
  { exact (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0)) (eps_ 1) HeI Hnlt_e). }
  claim HeR: eps_ 1 :e unit_interval_right_half.
  { exact (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1))) (eps_ 1) HeI Hnlt_e2). }
  exact (binintersectI unit_interval_left_half unit_interval_right_half (eps_ 1) HeL HeR).
Qed.

Theorem double_map_function_on :
  function_on double_map_left_half unit_interval_left_half unit_interval.
let t.
assume HtL: t :e unit_interval_left_half.
prove apply_fun double_map_left_half t :e unit_interval.
rewrite (double_map_apply t HtL).
prove mul_SNo 2 t :e unit_interval.
claim HtI: t :e unit_interval.
{ exact (unit_interval_left_half_sub t HtL). }
claim HtR: t :e R.
{ exact (unit_interval_sub_R t HtI). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim H2R: 2 :e R.
{ exact two_in_R. }
claim HmulR: mul_SNo 2 t :e R.
{ exact (real_mul_SNo 2 H2R t HtR). }
apply (SepI R (fun s:set => ~(Rlt s 0) /\ ~(Rlt 1 s)) (mul_SNo 2 t) HmulR).
apply andI.
- (** show ~(mul_SNo 2 t < 0) **)
  assume Hlt: Rlt (mul_SNo 2 t) 0.
  prove False.
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim HmulS: SNo (mul_SNo 2 t).
  { exact (SNo_mul_SNo 2 t H2S HtS). }
  claim Ht0nlt: ~(Rlt t 0).
  { claim Hconj: ~(Rlt t 0) /\ ~(Rlt 1 t).
    { exact (SepE2 R (fun u:set => ~(Rlt u 0) /\ ~(Rlt 1 u)) t HtI). }
    exact (andEL (~(Rlt t 0)) (~(Rlt 1 t)) Hconj). }
  claim H0le2: 0 <= 2.
  { exact (SNoLtLe 0 2 SNoLt_0_2). }
  claim H0let: 0 <= t.
  { prove 0 <= t.
    apply (SNoLtLe_or t 0 HtS SNo_0).
    - assume Htlt0: t < 0.
      claim Hrtlt: Rlt t 0.
      { exact (RltI t 0 HtR real_0 Htlt0). }
      apply FalseE.
      exact (Ht0nlt Hrtlt).
    - assume H0let': 0 <= t.
      exact H0let'. }
  claim H0lemul: 0 <= mul_SNo 2 t.
  { exact (mul_SNo_nonneg_nonneg 2 t H2S HtS H0le2 H0let). }
  claim HmulLt0: mul_SNo 2 t < 0.
  { exact (RltE_lt (mul_SNo 2 t) 0 Hlt). }
  claim Hcases: 0 < (mul_SNo 2 t) \/ 0 = (mul_SNo 2 t).
  { exact (SNoLeE 0 (mul_SNo 2 t) SNo_0 HmulS H0lemul). }
  apply Hcases.
  - assume Hpos: 0 < (mul_SNo 2 t).
    claim H00: 0 < 0.
    { exact (SNoLt_tra 0 (mul_SNo 2 t) 0 SNo_0 HmulS SNo_0 Hpos HmulLt0). }
    exact ((SNoLt_irref 0) H00).
	  - assume Heq: 0 = (mul_SNo 2 t).
	    claim H00: 0 < 0.
	    { rewrite Heq at 1.
	      exact HmulLt0. }
	    exact ((SNoLt_irref 0) H00).
- (** show ~(1 < mul_SNo 2 t) **)
  assume Hlt: Rlt 1 (mul_SNo 2 t).
  prove False.
  claim H2S: SNo 2.
  { exact SNo_2. }
  claim HmulS: SNo (mul_SNo 2 t).
  { exact (SNo_mul_SNo 2 t H2S HtS). }
  claim HeS: SNo (eps_ 1).
  { exact (real_SNo (eps_ 1) eps_1_in_R). }
  claim Hnlt: ~(Rlt (eps_ 1) t).
  { exact (SepE2 unit_interval (fun u:set => ~(Rlt (eps_ 1) u)) t HtL). }
  claim Htle: t <= (eps_ 1).
  { prove t <= (eps_ 1).
    apply (SNoLtLe_or (eps_ 1) t HeS HtS).
    - assume Hepslt: (eps_ 1) < t.
      claim Hrtlt: Rlt (eps_ 1) t.
      { exact (RltI (eps_ 1) t eps_1_in_R HtR Hepslt). }
      apply FalseE.
      exact (Hnlt Hrtlt).
    - assume Htle': t <= (eps_ 1).
      exact Htle'. }
  claim H0le2: 0 <= 2.
  { exact (SNoLtLe 0 2 SNoLt_0_2). }
  claim H2tLe: mul_SNo 2 t <= 1.
  { claim H2eps: mul_SNo 2 t <= mul_SNo 2 (eps_ 1).
    { exact (nonneg_mul_SNo_Le 2 t (eps_ 1) H2S H0le2 HtS HeS Htle). }
    prove mul_SNo 2 t <= 1.
    rewrite <- eps_1_half_eq2 at 2.
    exact H2eps. }
  claim H1lt: 1 < (mul_SNo 2 t).
  { exact (RltE_lt 1 (mul_SNo 2 t) Hlt). }
  claim Hcases: (mul_SNo 2 t) < 1 \/ (mul_SNo 2 t) = 1.
  { exact (SNoLeE (mul_SNo 2 t) 1 HmulS SNo_1 H2tLe). }
  apply Hcases.
  - assume Hlt2: (mul_SNo 2 t) < 1.
    claim H11: 1 < 1.
    { exact (SNoLt_tra 1 (mul_SNo 2 t) 1 SNo_1 HmulS SNo_1 H1lt Hlt2). }
    exact ((SNoLt_irref 1) H11).
  - assume Heq: (mul_SNo 2 t) = 1.
    claim H11: 1 < 1.
    { rewrite <- Heq at 2.
      exact H1lt. }
    exact ((SNoLt_irref 1) H11).
Qed.

Theorem double_minus_one_map_function_on :
  function_on double_minus_one_map_right_half unit_interval_right_half unit_interval.
let t.
assume HtH: t :e unit_interval_right_half.
prove apply_fun double_minus_one_map_right_half t :e unit_interval.
rewrite (double_minus_one_map_apply t HtH).
prove add_SNo (mul_SNo 2 t) (minus_SNo 1) :e unit_interval.

claim HtI: t :e unit_interval.
{ exact (unit_interval_right_half_sub t HtH). }
claim HtR: t :e R.
{ exact (unit_interval_sub_R t HtI). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HeR: eps_ 1 :e R.
{ exact eps_1_in_R. }
claim HeS: SNo (eps_ 1).
{ exact (real_SNo (eps_ 1) HeR). }
claim H2R: 2 :e R.
{ exact two_in_R. }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (real_SNo (minus_SNo 1) Hm1R). }
claim H2S: SNo 2.
{ exact SNo_2. }

claim HmulR: mul_SNo 2 t :e R.
{ exact (real_mul_SNo 2 H2R t HtR). }
claim HsR: add_SNo (mul_SNo 2 t) (minus_SNo 1) :e R.
{ exact (real_add_SNo (mul_SNo 2 t) HmulR (minus_SNo 1) Hm1R). }
claim HsS: SNo (add_SNo (mul_SNo 2 t) (minus_SNo 1)).
{ exact (real_SNo (add_SNo (mul_SNo 2 t) (minus_SNo 1)) HsR). }

apply (SepI R (fun u:set => ~(Rlt u 0) /\ ~(Rlt 1 u))
         (add_SNo (mul_SNo 2 t) (minus_SNo 1)) HsR).
apply andI.
- assume Hlt: Rlt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) 0.
  prove False.
  claim Hslt0: add_SNo (mul_SNo 2 t) (minus_SNo 1) < 0.
  { exact (RltE_lt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) 0 Hlt). }

  claim Hnlt_t_eps: ~(Rlt t (eps_ 1)).
  { exact (SepE2 unit_interval (fun u:set => ~(Rlt u (eps_ 1))) t HtH). }
  claim Hepsle_t: (eps_ 1) <= t.
  { prove (eps_ 1) <= t.
    apply (SNoLtLe_or t (eps_ 1) HtS HeS).
    - assume Htlt: t < (eps_ 1).
      claim Hrlt: Rlt t (eps_ 1).
      { exact (RltI t (eps_ 1) HtR HeR Htlt). }
      apply FalseE.
      exact (Hnlt_t_eps Hrlt).
    - assume Hle: (eps_ 1) <= t.
      exact Hle. }

  claim H0le2: 0 <= 2.
  { exact (SNoLtLe 0 2 SNoLt_0_2). }
  claim H2eps_le_2t: mul_SNo 2 (eps_ 1) <= mul_SNo 2 t.
  { exact (nonneg_mul_SNo_Le 2 (eps_ 1) t H2S H0le2 HeS HtS Hepsle_t). }
  claim H1le2t: 1 <= mul_SNo 2 t.
  { rewrite <- eps_1_half_eq2 at 1.
    exact H2eps_le_2t. }
  claim H0les: 0 <= add_SNo (mul_SNo 2 t) (minus_SNo 1).
  { prove 0 <= add_SNo (mul_SNo 2 t) (minus_SNo 1).
    rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
    exact (add_SNo_Le1 1 (minus_SNo 1) (mul_SNo 2 t)
             SNo_1 Hm1S (SNo_mul_SNo 2 t H2S HtS)
             H1le2t). }

  claim Hcases: 0 < add_SNo (mul_SNo 2 t) (minus_SNo 1) \/
                0 = add_SNo (mul_SNo 2 t) (minus_SNo 1).
  { exact (SNoLeE 0 (add_SNo (mul_SNo 2 t) (minus_SNo 1)) SNo_0 HsS H0les). }
  apply Hcases.
  - assume Hpos: 0 < add_SNo (mul_SNo 2 t) (minus_SNo 1).
    claim H00: 0 < 0.
    { exact (SNoLt_tra 0 (add_SNo (mul_SNo 2 t) (minus_SNo 1)) 0
             SNo_0 HsS SNo_0 Hpos Hslt0). }
    exact ((SNoLt_irref 0) H00).
  - assume Heq: 0 = add_SNo (mul_SNo 2 t) (minus_SNo 1).
    claim H00: 0 < 0.
    { rewrite Heq at 1.
      exact Hslt0. }
    exact ((SNoLt_irref 0) H00).
- assume Hlt: Rlt 1 (add_SNo (mul_SNo 2 t) (minus_SNo 1)).
  prove False.
  claim H1lts: 1 < add_SNo (mul_SNo 2 t) (minus_SNo 1).
  { exact (RltE_lt 1 (add_SNo (mul_SNo 2 t) (minus_SNo 1)) Hlt). }

  claim Hnlt_1t: ~(Rlt 1 t).
  { claim Hconj: ~(Rlt t 0) /\ ~(Rlt 1 t).
    { exact (SepE2 R (fun u:set => ~(Rlt u 0) /\ ~(Rlt 1 u)) t HtI). }
    exact (andER (~(Rlt t 0)) (~(Rlt 1 t)) Hconj). }
  claim Htle1: t <= 1.
  { prove t <= 1.
    apply (SNoLtLe_or 1 t SNo_1 HtS).
    - assume H1lt: 1 < t.
      claim Hrlt: Rlt 1 t.
      { exact (RltI 1 t real_1 HtR H1lt). }
      apply FalseE.
      exact (Hnlt_1t Hrlt).
    - assume Hle: t <= 1.
      exact Hle. }

  claim H0le2: 0 <= 2.
  { exact (SNoLtLe 0 2 SNoLt_0_2). }
  claim H2t_le_2: mul_SNo 2 t <= mul_SNo 2 1.
  { exact (nonneg_mul_SNo_Le 2 t 1 H2S H0le2 HtS SNo_1 Htle1). }
  claim H2t_le_2': mul_SNo 2 t <= 2.
  { rewrite <- (mul_SNo_oneR 2 SNo_2) at 2.
    exact H2t_le_2. }
  claim Hsle_2m1: add_SNo (mul_SNo 2 t) (minus_SNo 1) <= add_SNo 2 (minus_SNo 1).
  { exact (add_SNo_Le1 (mul_SNo 2 t) (minus_SNo 1) 2
           (SNo_mul_SNo 2 t H2S HtS) Hm1S SNo_2
           H2t_le_2'). }
  claim H2m1eq1: add_SNo 2 (minus_SNo 1) = 1.
  { rewrite <- add_SNo_1_1_2 at 1.
    rewrite <- (add_SNo_assoc 1 1 (minus_SNo 1) SNo_1 SNo_1 Hm1S) at 1.
    rewrite (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
    rewrite (add_SNo_0R 1 SNo_1) at 1.
    reflexivity. }
  claim Hsle1: add_SNo (mul_SNo 2 t) (minus_SNo 1) <= 1.
  { claim H2m1S: SNo (add_SNo 2 (minus_SNo 1)).
    { exact (SNo_add_SNo 2 (minus_SNo 1) SNo_2 Hm1S). }
    claim H2m1le1: add_SNo 2 (minus_SNo 1) <= 1.
    { rewrite H2m1eq1 at 1.
      exact (SNoLe_ref 1). }
    exact (SNoLe_tra (add_SNo (mul_SNo 2 t) (minus_SNo 1))
                     (add_SNo 2 (minus_SNo 1))
                     1
                     HsS H2m1S SNo_1
                     Hsle_2m1 H2m1le1). }

  claim Hcases: add_SNo (mul_SNo 2 t) (minus_SNo 1) < 1 \/
                add_SNo (mul_SNo 2 t) (minus_SNo 1) = 1.
  { exact (SNoLeE (add_SNo (mul_SNo 2 t) (minus_SNo 1)) 1 HsS SNo_1 Hsle1). }
  apply Hcases.
  - assume Hslt1: add_SNo (mul_SNo 2 t) (minus_SNo 1) < 1.
    claim H11: 1 < 1.
    { exact (SNoLt_tra 1 (add_SNo (mul_SNo 2 t) (minus_SNo 1)) 1
             SNo_1 HsS SNo_1 H1lts Hslt1). }
    exact ((SNoLt_irref 1) H11).
  - assume Heq: add_SNo (mul_SNo 2 t) (minus_SNo 1) = 1.
    claim H11: 1 < 1.
    { rewrite <- Heq at 2.
      exact H1lts. }
    exact ((SNoLt_irref 1) H11).
Qed.

Theorem double_map_continuous :
  continuous_map unit_interval_left_half
    (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
    unit_interval unit_interval_topology
    double_map_left_half.
prove continuous_map unit_interval_left_half
        (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
        unit_interval unit_interval_topology
        double_map_left_half.
(** range restriction: factor through R, then restrict codomain to unit_interval **)
claim HcontR: continuous_map unit_interval_left_half
  (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
  R R_standard_topology
  double_map_left_half.
{ set Tx := subspace_topology unit_interval unit_interval_topology unit_interval_left_half.
  set S := open_rays_subbasis R.

  claim HTui: topology_on unit_interval unit_interval_topology.
  { exact unit_interval_topology_on. }
  claim HTx: topology_on unit_interval_left_half Tx.
  { exact (subspace_topology_is_topology unit_interval unit_interval_topology unit_interval_left_half
           HTui
           unit_interval_left_half_sub). }

  claim HS: subbasis_on R S.
  { exact (open_rays_subbasis_is_subbasis R). }

  claim Hfun: function_on double_map_left_half unit_interval_left_half R.
  { let t. assume Ht: t :e unit_interval_left_half.
    prove apply_fun double_map_left_half t :e R.
    claim HtI: t :e unit_interval.
    { exact (unit_interval_left_half_sub t Ht). }
    claim HtR: t :e R.
    { exact (unit_interval_sub_R t HtI). }
    claim H2R: 2 :e R.
    { exact real_2. }
    claim HmulR: mul_SNo 2 t :e R.
    { claim HdefR: R = real.
      { reflexivity. }
      rewrite HdefR.
      claim H2Real: 2 :e real.
      { rewrite <- HdefR.
        exact H2R. }
      claim HtReal: t :e real.
      { rewrite <- HdefR.
        exact HtR. }
      exact (real_mul_SNo 2 H2Real t HtReal). }
    rewrite (double_map_apply t Ht).
    exact HmulR. }

  claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
  { rewrite open_rays_subbasis_for_order_topology_R.
    rewrite standard_topology_is_order_topology.
    reflexivity. }
  rewrite <- Hgen.

  claim HpreS: forall s:set, s :e S -> preimage_of unit_interval_left_half double_map_left_half s :e Tx.
  { let s. assume HsS: s :e S.
    prove preimage_of unit_interval_left_half double_map_left_half s :e Tx.
    apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                       :\/:
                       {I :e Power R | exists b :e R, I = open_ray_lower R b})
                      {R}
                      s
                      (preimage_of unit_interval_left_half double_map_left_half s :e Tx)).
    - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                        :\/:
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}).
      apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}
                        s
                        (preimage_of unit_interval_left_half double_map_left_half s :e Tx)).
      + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
        claim Hex: exists a :e R, s = open_ray_upper R a.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                      s Hsu). }
        apply Hex.
        let a. assume Hcore.
        apply Hcore.
        assume HaR: a :e R.
        assume Hseq: s = open_ray_upper R a.
        rewrite Hseq.

        set c := mul_SNo (eps_ 1) a.
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HaReal: a :e real.
          { rewrite <- HdefR.
            exact HaR. }
          claim He1Real: (eps_ 1) :e real.
          { rewrite <- HdefR.
            exact eps_1_in_R. }
          exact (real_mul_SNo (eps_ 1) He1Real a HaReal). }

        claim HpreEq: preimage_of unit_interval_left_half double_map_left_half (open_ray_upper R a)
                      = (open_ray_upper R c) :/\: unit_interval_left_half.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval_left_half double_map_left_half (open_ray_upper R a).
            prove t :e (open_ray_upper R c) :/\: unit_interval_left_half.
            claim HtLH: t :e unit_interval_left_half.
            { exact (SepE1 unit_interval_left_half
                         (fun u : set => apply_fun double_map_left_half u :e open_ray_upper R a) t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun double_map_left_half t :e open_ray_upper R a.
            { exact (SepE2 unit_interval_left_half
                         (fun u : set => apply_fun double_map_left_half u :e open_ray_upper R a) t Ht). }
            claim Hrel: order_rel R a (apply_fun double_map_left_half t).
            { exact (SepE2 R (fun x0 : set => order_rel R a x0) (apply_fun double_map_left_half t) Himg). }
            claim Hrlt: Rlt a (apply_fun double_map_left_half t).
            { exact (order_rel_R_implies_Rlt a (apply_fun double_map_left_half t) Hrel). }
            claim Hrlt2: Rlt a (mul_SNo 2 t).
            { rewrite <- (double_map_apply t HtLH).
              exact Hrlt. }
            claim Hrltc: Rlt c t.
            { exact (iffEL (Rlt a (mul_SNo 2 t)) (Rlt (mul_SNo (eps_ 1) a) t)
                          (Rlt_mul2_left_iff a t HaR HtR) Hrlt2). }
            claim HcRel: order_rel R c t.
            { exact (Rlt_implies_order_rel_R c t Hrltc). }
            claim HtRay: t :e open_ray_upper R c.
            { exact (SepI R (fun x0 : set => order_rel R c x0) t HtR HcRel). }
            exact (binintersectI (open_ray_upper R c) unit_interval_left_half t HtRay HtLH).
          - let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_left_half.
            prove t :e preimage_of unit_interval_left_half double_map_left_half (open_ray_upper R a).
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 (open_ray_upper R c) unit_interval_left_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R c t.
            { exact (SepE2 R (fun x0 : set => order_rel R c x0) t HtRay). }
            claim Hrlt: Rlt c t.
            { exact (order_rel_R_implies_Rlt c t Hrel). }
            claim Hrlt2: Rlt a (mul_SNo 2 t).
            { exact (iffER (Rlt a (mul_SNo 2 t)) (Rlt (mul_SNo (eps_ 1) a) t)
                          (Rlt_mul2_left_iff a t HaR HtR) Hrlt). }
            claim Hrlt3: Rlt a (apply_fun double_map_left_half t).
            { rewrite (double_map_apply t HtLH).
              exact Hrlt2. }
            claim Hrel2: order_rel R a (apply_fun double_map_left_half t).
            { exact (Rlt_implies_order_rel_R a (apply_fun double_map_left_half t) Hrlt3). }
            claim HimgR: apply_fun double_map_left_half t :e R.
            { exact (Hfun t HtLH). }
            claim Himg: apply_fun double_map_left_half t :e open_ray_upper R a.
            { exact (SepI R (fun x0 : set => order_rel R a x0)
                          (apply_fun double_map_left_half t) HimgR Hrel2). }
            exact (SepI unit_interval_left_half
                        (fun u : set => apply_fun double_map_left_half u :e open_ray_upper R a)
                        t HtLH Himg). }

        rewrite HpreEq.
        prove (open_ray_upper R c) :/\: unit_interval_left_half :e Tx.
        prove (open_ray_upper R c) :/\: unit_interval_left_half :e
             {W :e Power unit_interval_left_half | exists Z :e unit_interval_topology,
                  W = Z :/\: unit_interval_left_half}.
        claim Hpow: (open_ray_upper R c) :/\: unit_interval_left_half :e Power unit_interval_left_half.
        { apply PowerI.
          let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_left_half.
          exact (binintersectE2 (open_ray_upper R c) unit_interval_left_half t Ht). }
        set Z0 := (open_ray_upper R c) :/\: unit_interval.
        claim HZ0: Z0 :e unit_interval_topology.
        { claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
          { reflexivity. }
          rewrite Hut.
          prove Z0 :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim HZ0pow: Z0 :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0.
            exact (binintersectE2 (open_ray_upper R c) unit_interval t Ht). }
          claim HopenR: open_ray_upper R c :e R_standard_topology.
          { rewrite <- standard_topology_is_order_topology.
            claim HcS: c :e R.
            { exact HcR. }
            claim HsRay: open_ray_upper R c :e open_rays_subbasis R.
            { exact (open_ray_upper_in_open_rays_subbasis R c HcS). }
            exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) HsRay). }
          claim Hex: exists Z :e R_standard_topology, Z0 = Z :/\: unit_interval.
          { witness (open_ray_upper R c).
            apply andI.
            - exact HopenR.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      Z0 HZ0pow Hex). }
        claim Heq: (open_ray_upper R c) :/\: unit_interval_left_half = Z0 :/\: unit_interval_left_half.
        { apply set_ext.
          - let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_left_half.
            prove t :e Z0 :/\: unit_interval_left_half.
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 (open_ray_upper R c) unit_interval_left_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtZ0: t :e Z0.
            { exact (binintersectI (open_ray_upper R c) unit_interval t HtRay HtI). }
            exact (binintersectI Z0 unit_interval_left_half t HtZ0 HtLH).
          - let t. assume Ht: t :e Z0 :/\: unit_interval_left_half.
            prove t :e (open_ray_upper R c) :/\: unit_interval_left_half.
            claim HtZ0: t :e Z0.
            { exact (binintersectE1 Z0 unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 Z0 unit_interval_left_half t Ht). }
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval t HtZ0). }
            exact (binintersectI (open_ray_upper R c) unit_interval_left_half t HtRay HtLH). }
        claim Hex: exists Z :e unit_interval_topology,
          (open_ray_upper R c) :/\: unit_interval_left_half = Z :/\: unit_interval_left_half.
        { witness Z0.
          apply andI.
          - exact HZ0.
          - rewrite <- Heq.
            reflexivity. }
        exact (SepI (Power unit_interval_left_half)
                    (fun W0 : set => exists Z :e unit_interval_topology, W0 = Z :/\: unit_interval_left_half)
                    ((open_ray_upper R c) :/\: unit_interval_left_half)
                    Hpow
                    Hex).
      + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
        claim Hex: exists b :e R, s = open_ray_lower R b.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                      s Hsl). }
        apply Hex.
        let b. assume Hcore.
        apply Hcore.
        assume HbR: b :e R.
        assume Hseq: s = open_ray_lower R b.
        rewrite Hseq.

        set c := mul_SNo (eps_ 1) b.
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HbReal: b :e real.
          { rewrite <- HdefR.
            exact HbR. }
          claim He1Real: (eps_ 1) :e real.
          { rewrite <- HdefR.
            exact eps_1_in_R. }
          exact (real_mul_SNo (eps_ 1) He1Real b HbReal). }

        claim HpreEq: preimage_of unit_interval_left_half double_map_left_half (open_ray_lower R b)
                      = (open_ray_lower R c) :/\: unit_interval_left_half.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval_left_half double_map_left_half (open_ray_lower R b).
            prove t :e (open_ray_lower R c) :/\: unit_interval_left_half.
            claim HtLH: t :e unit_interval_left_half.
            { exact (SepE1 unit_interval_left_half
                         (fun u : set => apply_fun double_map_left_half u :e open_ray_lower R b) t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun double_map_left_half t :e open_ray_lower R b.
            { exact (SepE2 unit_interval_left_half
                         (fun u : set => apply_fun double_map_left_half u :e open_ray_lower R b) t Ht). }
            claim Hrel: order_rel R (apply_fun double_map_left_half t) b.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 b) (apply_fun double_map_left_half t) Himg). }
            claim Hrlt: Rlt (apply_fun double_map_left_half t) b.
            { exact (order_rel_R_implies_Rlt (apply_fun double_map_left_half t) b Hrel). }
            claim Hrlt2: Rlt (mul_SNo 2 t) b.
            { rewrite <- (double_map_apply t HtLH) at 1.
              exact Hrlt. }
            claim Hrltc: Rlt t c.
            { exact (iffEL (Rlt (mul_SNo 2 t) b) (Rlt t (mul_SNo (eps_ 1) b))
                          (Rlt_mul2_right_iff t b HtR HbR) Hrlt2). }
            claim HcRel: order_rel R t c.
            { exact (Rlt_implies_order_rel_R t c Hrltc). }
            claim HtRay: t :e open_ray_lower R c.
            { exact (SepI R (fun x0 : set => order_rel R x0 c) t HtR HcRel). }
            exact (binintersectI (open_ray_lower R c) unit_interval_left_half t HtRay HtLH).
          - let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_left_half.
            prove t :e preimage_of unit_interval_left_half double_map_left_half (open_ray_lower R b).
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 (open_ray_lower R c) unit_interval_left_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R t c.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 c) t HtRay). }
            claim Hrlt: Rlt t c.
            { exact (order_rel_R_implies_Rlt t c Hrel). }
            claim Hrlt2: Rlt (mul_SNo 2 t) b.
            { exact (iffER (Rlt (mul_SNo 2 t) b) (Rlt t (mul_SNo (eps_ 1) b))
                          (Rlt_mul2_right_iff t b HtR HbR) Hrlt). }
            claim Hrlt3: Rlt (apply_fun double_map_left_half t) b.
            { rewrite (double_map_apply t HtLH) at 1.
              exact Hrlt2. }
            claim Hrel2: order_rel R (apply_fun double_map_left_half t) b.
            { exact (Rlt_implies_order_rel_R (apply_fun double_map_left_half t) b Hrlt3). }
            claim HimgR: apply_fun double_map_left_half t :e R.
            { exact (Hfun t HtLH). }
            claim Himg: apply_fun double_map_left_half t :e open_ray_lower R b.
            { exact (SepI R (fun x0 : set => order_rel R x0 b)
                          (apply_fun double_map_left_half t) HimgR Hrel2). }
            exact (SepI unit_interval_left_half
                        (fun u : set => apply_fun double_map_left_half u :e open_ray_lower R b)
                        t HtLH Himg). }

        rewrite HpreEq.
        prove (open_ray_lower R c) :/\: unit_interval_left_half :e Tx.
        prove (open_ray_lower R c) :/\: unit_interval_left_half :e
             {W :e Power unit_interval_left_half | exists Z :e unit_interval_topology,
                  W = Z :/\: unit_interval_left_half}.
        claim Hpow: (open_ray_lower R c) :/\: unit_interval_left_half :e Power unit_interval_left_half.
        { apply PowerI.
          let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_left_half.
          exact (binintersectE2 (open_ray_lower R c) unit_interval_left_half t Ht). }
        set Z0 := (open_ray_lower R c) :/\: unit_interval.
        claim HZ0: Z0 :e unit_interval_topology.
        { claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
          { reflexivity. }
          rewrite Hut.
          prove Z0 :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim HZ0pow: Z0 :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0.
            exact (binintersectE2 (open_ray_lower R c) unit_interval t Ht). }
          claim HopenR: open_ray_lower R c :e R_standard_topology.
          { rewrite <- standard_topology_is_order_topology.
            claim HcS: c :e R.
            { exact HcR. }
            claim HsRay: open_ray_lower R c :e open_rays_subbasis R.
            { exact (open_ray_lower_in_open_rays_subbasis R c HcS). }
            exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R c) HsRay). }
          claim Hex: exists Z :e R_standard_topology, Z0 = Z :/\: unit_interval.
          { witness (open_ray_lower R c).
            apply andI.
            - exact HopenR.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      Z0 HZ0pow Hex). }
        claim Heq: (open_ray_lower R c) :/\: unit_interval_left_half = Z0 :/\: unit_interval_left_half.
        { apply set_ext.
          - let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_left_half.
            prove t :e Z0 :/\: unit_interval_left_half.
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 (open_ray_lower R c) unit_interval_left_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_left_half_sub t HtLH). }
            claim HtZ0: t :e Z0.
            { exact (binintersectI (open_ray_lower R c) unit_interval t HtRay HtI). }
            exact (binintersectI Z0 unit_interval_left_half t HtZ0 HtLH).
          - let t. assume Ht: t :e Z0 :/\: unit_interval_left_half.
            prove t :e (open_ray_lower R c) :/\: unit_interval_left_half.
            claim HtZ0: t :e Z0.
            { exact (binintersectE1 Z0 unit_interval_left_half t Ht). }
            claim HtLH: t :e unit_interval_left_half.
            { exact (binintersectE2 Z0 unit_interval_left_half t Ht). }
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval t HtZ0). }
            exact (binintersectI (open_ray_lower R c) unit_interval_left_half t HtRay HtLH). }
        claim Hex: exists Z :e unit_interval_topology,
          (open_ray_lower R c) :/\: unit_interval_left_half = Z :/\: unit_interval_left_half.
        { witness Z0.
          apply andI.
          - exact HZ0.
          - rewrite <- Heq.
            reflexivity. }
        exact (SepI (Power unit_interval_left_half)
                    (fun W0 : set => exists Z :e unit_interval_topology, W0 = Z :/\: unit_interval_left_half)
                    ((open_ray_lower R c) :/\: unit_interval_left_half)
                    Hpow
                    Hex).
      + exact Hs0.
    - assume HsR: s :e {R}.
      claim Hseq: s = R.
      { exact (SingE R s HsR). }
      rewrite Hseq.
      claim Heq: preimage_of unit_interval_left_half double_map_left_half R = unit_interval_left_half.
      { exact (preimage_of_whole unit_interval_left_half R double_map_left_half Hfun). }
      rewrite Heq.
      exact (topology_has_X unit_interval_left_half Tx HTx).
    - exact HsS. }

  exact (continuous_map_from_subbasis unit_interval_left_half Tx R S double_map_left_half
          HTx Hfun HS HpreS). }

claim Himg: forall t:set, t :e unit_interval_left_half -> apply_fun double_map_left_half t :e unit_interval.
{ let t. assume Ht: t :e unit_interval_left_half.
  exact (double_map_function_on t Ht). }

claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
rewrite Hut.
exact (continuous_map_range_restrict unit_interval_left_half
        (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
        R R_standard_topology
        double_map_left_half
        unit_interval
        HcontR
        unit_interval_sub_R
        Himg).
Qed.

Theorem double_minus_one_map_continuous :
  continuous_map unit_interval_right_half
    (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
    unit_interval unit_interval_topology
    double_minus_one_map_right_half.
prove continuous_map unit_interval_right_half
        (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
        unit_interval unit_interval_topology
        double_minus_one_map_right_half.
(** range restriction: factor through R, then restrict codomain to unit_interval **)
claim HcontR: continuous_map unit_interval_right_half
  (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
  R R_standard_topology
  double_minus_one_map_right_half.
{ set Tx := subspace_topology unit_interval unit_interval_topology unit_interval_right_half.
  set S := open_rays_subbasis R.

  claim HTui: topology_on unit_interval unit_interval_topology.
  { exact unit_interval_topology_on. }
  claim HTx: topology_on unit_interval_right_half Tx.
  { exact (subspace_topology_is_topology unit_interval unit_interval_topology unit_interval_right_half
           HTui
           unit_interval_right_half_sub). }

  claim HS: subbasis_on R S.
  { exact (open_rays_subbasis_is_subbasis R). }

  claim Hfun: function_on double_minus_one_map_right_half unit_interval_right_half R.
  { let t. assume Ht: t :e unit_interval_right_half.
    prove apply_fun double_minus_one_map_right_half t :e R.
    claim HtI: t :e unit_interval.
    { exact (unit_interval_right_half_sub t Ht). }
    claim HtR: t :e R.
    { exact (unit_interval_sub_R t HtI). }
    claim H2R: 2 :e R.
    { exact real_2. }
    claim Hm1R: (minus_SNo 1) :e R.
    { claim HdefR: R = real.
      { reflexivity. }
      rewrite HdefR.
      exact (real_minus_SNo 1 real_1). }
    claim HmulR: mul_SNo 2 t :e R.
    { claim HdefR: R = real.
      { reflexivity. }
      rewrite HdefR.
      claim H2Real: 2 :e real.
      { rewrite <- HdefR.
        exact H2R. }
      claim HtReal: t :e real.
      { rewrite <- HdefR.
        exact HtR. }
      exact (real_mul_SNo 2 H2Real t HtReal). }
    claim HaddR: add_SNo (mul_SNo 2 t) (minus_SNo 1) :e R.
    { claim HdefR: R = real.
      { reflexivity. }
      rewrite HdefR.
      claim HmulReal: mul_SNo 2 t :e real.
      { rewrite <- HdefR.
        exact HmulR. }
      claim Hm1Real: (minus_SNo 1) :e real.
      { rewrite <- HdefR.
        exact Hm1R. }
      exact (real_add_SNo (mul_SNo 2 t) HmulReal (minus_SNo 1) Hm1Real). }
    rewrite (double_minus_one_map_apply t Ht).
    exact HaddR. }

  claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
  { rewrite open_rays_subbasis_for_order_topology_R.
    rewrite standard_topology_is_order_topology.
    reflexivity. }
  rewrite <- Hgen.

  claim Haddm1L: forall a x:set,
    a :e R -> x :e R -> (Rlt a (add_SNo x (minus_SNo 1)) <-> Rlt (add_SNo a 1) x).
  { let a x.
    assume HaR: a :e R.
    assume HxR: x :e R.
    prove (Rlt a (add_SNo x (minus_SNo 1)) <-> Rlt (add_SNo a 1) x).
    apply iffI.
    - assume Hlt: Rlt a (add_SNo x (minus_SNo 1)).
      prove Rlt (add_SNo a 1) x.
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim Hx_m1S: SNo (add_SNo x (minus_SNo 1)).
      { exact (SNo_add_SNo x (minus_SNo 1) HxS Hm1S). }
      claim HltS: a < add_SNo x (minus_SNo 1).
      { exact (RltE_lt a (add_SNo x (minus_SNo 1)) Hlt). }
      claim Hstep: add_SNo a 1 < add_SNo (add_SNo x (minus_SNo 1)) 1.
      { exact (add_SNo_Lt1 a 1 (add_SNo x (minus_SNo 1)) HaS SNo_1 Hx_m1S HltS). }
      claim Heq: add_SNo (add_SNo x (minus_SNo 1)) 1 = x.
      { rewrite <- (add_SNo_assoc x (minus_SNo 1) 1 HxS Hm1S SNo_1).
        rewrite (add_SNo_minus_SNo_linv 1 SNo_1).
        exact (add_SNo_0R x HxS). }
      claim Hstep2: add_SNo a 1 < x.
      { rewrite <- Heq.
        exact Hstep. }
      claim Ha1R: add_SNo a 1 :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HaReal: a :e real.
        { rewrite <- HdefR.
          exact HaR. }
        exact (real_add_SNo a HaReal 1 real_1). }
      exact (RltI (add_SNo a 1) x Ha1R HxR Hstep2).
    - assume Hlt: Rlt (add_SNo a 1) x.
      prove Rlt a (add_SNo x (minus_SNo 1)).
      claim HaS: SNo a.
      { exact (real_SNo a HaR). }
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim Ha1S: SNo (add_SNo a 1).
      { exact (SNo_add_SNo a 1 HaS SNo_1). }
      claim HltS: add_SNo a 1 < x.
      { exact (RltE_lt (add_SNo a 1) x Hlt). }
      claim Hstep: add_SNo (add_SNo a 1) (minus_SNo 1) < add_SNo x (minus_SNo 1).
      { exact (add_SNo_Lt1 (add_SNo a 1) (minus_SNo 1) x Ha1S Hm1S HxS HltS). }
      claim Heq: add_SNo (add_SNo a 1) (minus_SNo 1) = a.
      { rewrite <- (add_SNo_assoc a 1 (minus_SNo 1) HaS SNo_1 Hm1S).
        rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
        exact (add_SNo_0R a HaS). }
      claim Hstep2: a < add_SNo x (minus_SNo 1).
      { rewrite <- Heq at 1.
        exact Hstep. }
      claim Hx_m1R: add_SNo x (minus_SNo 1) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HxReal: x :e real.
        { rewrite <- HdefR.
          exact HxR. }
        exact (real_add_SNo x HxReal (minus_SNo 1) (real_minus_SNo 1 real_1)). }
      exact (RltI a (add_SNo x (minus_SNo 1)) HaR Hx_m1R Hstep2). }

  claim Haddm1R: forall x b:set,
    x :e R -> b :e R -> (Rlt (add_SNo x (minus_SNo 1)) b <-> Rlt x (add_SNo b 1)).
  { let x b.
    assume HxR: x :e R.
    assume HbR: b :e R.
    prove (Rlt (add_SNo x (minus_SNo 1)) b <-> Rlt x (add_SNo b 1)).
    apply iffI.
    - assume Hlt: Rlt (add_SNo x (minus_SNo 1)) b.
      prove Rlt x (add_SNo b 1).
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim Hx_m1S: SNo (add_SNo x (minus_SNo 1)).
      { exact (SNo_add_SNo x (minus_SNo 1) HxS Hm1S). }
      claim HltS: add_SNo x (minus_SNo 1) < b.
      { exact (RltE_lt (add_SNo x (minus_SNo 1)) b Hlt). }
      claim Hstep: add_SNo (add_SNo x (minus_SNo 1)) 1 < add_SNo b 1.
      { exact (add_SNo_Lt1 (add_SNo x (minus_SNo 1)) 1 b Hx_m1S SNo_1 HbS HltS). }
      claim Heq: add_SNo (add_SNo x (minus_SNo 1)) 1 = x.
      { rewrite <- (add_SNo_assoc x (minus_SNo 1) 1 HxS Hm1S SNo_1).
        rewrite (add_SNo_minus_SNo_linv 1 SNo_1).
        exact (add_SNo_0R x HxS). }
      claim Hstep2: x < add_SNo b 1.
      { rewrite <- Heq at 1.
        exact Hstep. }
      claim Hb1R: add_SNo b 1 :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HbReal: b :e real.
        { rewrite <- HdefR.
          exact HbR. }
        exact (real_add_SNo b HbReal 1 real_1). }
      exact (RltI x (add_SNo b 1) HxR Hb1R Hstep2).
    - assume Hlt: Rlt x (add_SNo b 1).
      prove Rlt (add_SNo x (minus_SNo 1)) b.
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim Hb1S: SNo (add_SNo b 1).
      { exact (SNo_add_SNo b 1 HbS SNo_1). }
      claim HltS: x < add_SNo b 1.
      { exact (RltE_lt x (add_SNo b 1) Hlt). }
      claim Hstep: add_SNo x (minus_SNo 1) < add_SNo (add_SNo b 1) (minus_SNo 1).
      { exact (add_SNo_Lt1 x (minus_SNo 1) (add_SNo b 1) HxS Hm1S Hb1S HltS). }
      claim Heq: add_SNo (add_SNo b 1) (minus_SNo 1) = b.
      { rewrite <- (add_SNo_assoc b 1 (minus_SNo 1) HbS SNo_1 Hm1S).
        rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
        exact (add_SNo_0R b HbS). }
      claim Hstep2: add_SNo x (minus_SNo 1) < b.
      { rewrite <- Heq.
        exact Hstep. }
      claim Hx_m1R: add_SNo x (minus_SNo 1) :e R.
      { claim HdefR: R = real.
        { reflexivity. }
        rewrite HdefR.
        claim HxReal: x :e real.
        { rewrite <- HdefR.
          exact HxR. }
        exact (real_add_SNo x HxReal (minus_SNo 1) (real_minus_SNo 1 real_1)). }
      exact (RltI (add_SNo x (minus_SNo 1)) b Hx_m1R HbR Hstep2). }

  claim HpreS: forall s:set, s :e S -> preimage_of unit_interval_right_half double_minus_one_map_right_half s :e Tx.
  { let s. assume HsS: s :e S.
    prove preimage_of unit_interval_right_half double_minus_one_map_right_half s :e Tx.
    apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                       :\/:
                       {I :e Power R | exists b :e R, I = open_ray_lower R b})
                      {R}
                      s
                      (preimage_of unit_interval_right_half double_minus_one_map_right_half s :e Tx)).
    - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                        :\/:
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}).
      apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                        {I :e Power R | exists b :e R, I = open_ray_lower R b}
                        s
                        (preimage_of unit_interval_right_half double_minus_one_map_right_half s :e Tx)).
      + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
        claim Hex: exists a :e R, s = open_ray_upper R a.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                      s Hsu). }
        apply Hex.
        let a. assume Hcore.
        apply Hcore.
        assume HaR: a :e R.
        assume Hseq: s = open_ray_upper R a.
        rewrite Hseq.

        set d := add_SNo a 1.
        set c := mul_SNo (eps_ 1) d.

        claim HdR: d :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HaReal: a :e real.
          { rewrite <- HdefR.
            exact HaR. }
          exact (real_add_SNo a HaReal 1 real_1). }
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HdReal: d :e real.
          { rewrite <- HdefR.
            exact HdR. }
          exact (real_mul_SNo (eps_ 1) eps_1_in_R d HdReal). }

        claim HpreEq: preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_upper R a)
                      = (open_ray_upper R c) :/\: unit_interval_right_half.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_upper R a).
            prove t :e (open_ray_upper R c) :/\: unit_interval_right_half.
            claim HtRH: t :e unit_interval_right_half.
            { exact (SepE1 unit_interval_right_half
                         (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_upper R a) t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun double_minus_one_map_right_half t :e open_ray_upper R a.
            { exact (SepE2 unit_interval_right_half
                         (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_upper R a) t Ht). }
            claim Hrel: order_rel R a (apply_fun double_minus_one_map_right_half t).
            { exact (SepE2 R (fun x0 : set => order_rel R a x0) (apply_fun double_minus_one_map_right_half t) Himg). }
            claim Hrlt: Rlt a (apply_fun double_minus_one_map_right_half t).
            { exact (order_rel_R_implies_Rlt a (apply_fun double_minus_one_map_right_half t) Hrel). }
            claim Hrlt2: Rlt a (add_SNo (mul_SNo 2 t) (minus_SNo 1)).
            { rewrite <- (double_minus_one_map_apply t HtRH).
              exact Hrlt. }
            claim H2tR: mul_SNo 2 t :e R.
            { claim HdefR: R = real.
              { reflexivity. }
              rewrite HdefR.
              claim H2Real: 2 :e real.
              { rewrite <- HdefR.
                exact real_2. }
              claim HtReal: t :e real.
              { rewrite <- HdefR.
                exact HtR. }
              exact (real_mul_SNo 2 H2Real t HtReal). }
            claim Hrlt3: Rlt d (mul_SNo 2 t).
            { exact (iffEL (Rlt a (add_SNo (mul_SNo 2 t) (minus_SNo 1))) (Rlt (add_SNo a 1) (mul_SNo 2 t))
                          (Haddm1L a (mul_SNo 2 t) HaR H2tR) Hrlt2). }
            claim Hrlt4: Rlt c t.
            { exact (iffEL (Rlt d (mul_SNo 2 t)) (Rlt (mul_SNo (eps_ 1) d) t)
                          (Rlt_mul2_left_iff d t HdR HtR) Hrlt3). }
            claim HcRel: order_rel R c t.
            { exact (Rlt_implies_order_rel_R c t Hrlt4). }
            claim HtRay: t :e open_ray_upper R c.
            { exact (SepI R (fun x0 : set => order_rel R c x0) t HtR HcRel). }
            exact (binintersectI (open_ray_upper R c) unit_interval_right_half t HtRay HtRH).
          - let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_right_half.
            prove t :e preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_upper R a).
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 (open_ray_upper R c) unit_interval_right_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R c t.
            { exact (SepE2 R (fun x0 : set => order_rel R c x0) t HtRay). }
            claim Hrlt: Rlt c t.
            { exact (order_rel_R_implies_Rlt c t Hrel). }
            claim Hrlt2: Rlt d (mul_SNo 2 t).
            { exact (iffER (Rlt d (mul_SNo 2 t)) (Rlt (mul_SNo (eps_ 1) d) t)
                          (Rlt_mul2_left_iff d t HdR HtR) Hrlt). }
            claim H2tR: mul_SNo 2 t :e R.
            { claim HdefR: R = real.
              { reflexivity. }
              rewrite HdefR.
              claim H2Real: 2 :e real.
              { rewrite <- HdefR.
                exact real_2. }
              claim HtReal: t :e real.
              { rewrite <- HdefR.
                exact HtR. }
              exact (real_mul_SNo 2 H2Real t HtReal). }
            claim Hrlt3: Rlt a (add_SNo (mul_SNo 2 t) (minus_SNo 1)).
            { exact (iffER (Rlt a (add_SNo (mul_SNo 2 t) (minus_SNo 1))) (Rlt (add_SNo a 1) (mul_SNo 2 t))
                          (Haddm1L a (mul_SNo 2 t) HaR H2tR) Hrlt2). }
            claim Hrlt4: Rlt a (apply_fun double_minus_one_map_right_half t).
            { rewrite (double_minus_one_map_apply t HtRH).
              exact Hrlt3. }
            claim Hrel2: order_rel R a (apply_fun double_minus_one_map_right_half t).
            { exact (Rlt_implies_order_rel_R a (apply_fun double_minus_one_map_right_half t) Hrlt4). }
            claim HimgR: apply_fun double_minus_one_map_right_half t :e R.
            { exact (Hfun t HtRH). }
            claim Himg: apply_fun double_minus_one_map_right_half t :e open_ray_upper R a.
            { exact (SepI R (fun x0 : set => order_rel R a x0)
                          (apply_fun double_minus_one_map_right_half t) HimgR Hrel2). }
            exact (SepI unit_interval_right_half
                        (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_upper R a)
                        t HtRH Himg). }

        rewrite HpreEq.
        prove (open_ray_upper R c) :/\: unit_interval_right_half :e Tx.
        prove (open_ray_upper R c) :/\: unit_interval_right_half :e
             {W :e Power unit_interval_right_half | exists Z :e unit_interval_topology,
                  W = Z :/\: unit_interval_right_half}.
        claim Hpow: (open_ray_upper R c) :/\: unit_interval_right_half :e Power unit_interval_right_half.
        { apply PowerI.
          let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_right_half.
          exact (binintersectE2 (open_ray_upper R c) unit_interval_right_half t Ht). }
        set Z0 := (open_ray_upper R c) :/\: unit_interval.
        claim HZ0: Z0 :e unit_interval_topology.
        { claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
          { reflexivity. }
          rewrite Hut.
          prove Z0 :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim HZ0pow: Z0 :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0.
            exact (binintersectE2 (open_ray_upper R c) unit_interval t Ht). }
          claim HopenR: open_ray_upper R c :e R_standard_topology.
          { rewrite <- standard_topology_is_order_topology.
            claim HsRay: open_ray_upper R c :e open_rays_subbasis R.
            { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
            exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) HsRay). }
          claim Hex: exists Z :e R_standard_topology, Z0 = Z :/\: unit_interval.
          { witness (open_ray_upper R c).
            apply andI.
            - exact HopenR.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      Z0 HZ0pow Hex). }
        claim Heq: (open_ray_upper R c) :/\: unit_interval_right_half = Z0 :/\: unit_interval_right_half.
        { apply set_ext.
          - let t. assume Ht: t :e (open_ray_upper R c) :/\: unit_interval_right_half.
            prove t :e Z0 :/\: unit_interval_right_half.
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 (open_ray_upper R c) unit_interval_right_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtZ0: t :e Z0.
            { exact (binintersectI (open_ray_upper R c) unit_interval t HtRay HtI). }
            exact (binintersectI Z0 unit_interval_right_half t HtZ0 HtRH).
          - let t. assume Ht: t :e Z0 :/\: unit_interval_right_half.
            prove t :e (open_ray_upper R c) :/\: unit_interval_right_half.
            claim HtZ0: t :e Z0.
            { exact (binintersectE1 Z0 unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 Z0 unit_interval_right_half t Ht). }
            claim HtRay: t :e open_ray_upper R c.
            { exact (binintersectE1 (open_ray_upper R c) unit_interval t HtZ0). }
            exact (binintersectI (open_ray_upper R c) unit_interval_right_half t HtRay HtRH). }
        claim Hex: exists Z :e unit_interval_topology,
          (open_ray_upper R c) :/\: unit_interval_right_half = Z :/\: unit_interval_right_half.
        { witness Z0.
          apply andI.
          - exact HZ0.
          - rewrite <- Heq.
            reflexivity. }
        exact (SepI (Power unit_interval_right_half)
                    (fun W0 : set => exists Z :e unit_interval_topology, W0 = Z :/\: unit_interval_right_half)
                    ((open_ray_upper R c) :/\: unit_interval_right_half)
                    Hpow
                    Hex).
      + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
        claim Hex: exists b :e R, s = open_ray_lower R b.
        { exact (SepE2 (Power R)
                      (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                      s Hsl). }
        apply Hex.
        let b. assume Hcore.
        apply Hcore.
        assume HbR: b :e R.
        assume Hseq: s = open_ray_lower R b.
        rewrite Hseq.

        set d := add_SNo b 1.
        set c := mul_SNo (eps_ 1) d.

        claim HdR: d :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HbReal: b :e real.
          { rewrite <- HdefR.
            exact HbR. }
          exact (real_add_SNo b HbReal 1 real_1). }
        claim HcR: c :e R.
        { claim HdefR: R = real.
          { reflexivity. }
          rewrite HdefR.
          claim HdReal: d :e real.
          { rewrite <- HdefR.
            exact HdR. }
          exact (real_mul_SNo (eps_ 1) eps_1_in_R d HdReal). }

        claim HpreEq: preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_lower R b)
                      = (open_ray_lower R c) :/\: unit_interval_right_half.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_lower R b).
            prove t :e (open_ray_lower R c) :/\: unit_interval_right_half.
            claim HtRH: t :e unit_interval_right_half.
            { exact (SepE1 unit_interval_right_half
                         (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_lower R b) t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Himg: apply_fun double_minus_one_map_right_half t :e open_ray_lower R b.
            { exact (SepE2 unit_interval_right_half
                         (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_lower R b) t Ht). }
            claim Hrel: order_rel R (apply_fun double_minus_one_map_right_half t) b.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 b) (apply_fun double_minus_one_map_right_half t) Himg). }
            claim Hrlt: Rlt (apply_fun double_minus_one_map_right_half t) b.
            { exact (order_rel_R_implies_Rlt (apply_fun double_minus_one_map_right_half t) b Hrel). }
            claim Hrlt2: Rlt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) b.
            { rewrite <- (double_minus_one_map_apply t HtRH).
              exact Hrlt. }
            claim H2tR: mul_SNo 2 t :e R.
            { claim HdefR: R = real.
              { reflexivity. }
              rewrite HdefR.
              claim H2Real: 2 :e real.
              { rewrite <- HdefR.
                exact real_2. }
              claim HtReal: t :e real.
              { rewrite <- HdefR.
                exact HtR. }
              exact (real_mul_SNo 2 H2Real t HtReal). }
            claim Hrlt3: Rlt (mul_SNo 2 t) d.
            { exact (iffEL (Rlt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) b) (Rlt (mul_SNo 2 t) (add_SNo b 1))
                          (Haddm1R (mul_SNo 2 t) b H2tR HbR) Hrlt2). }
            claim Hrlt4: Rlt t c.
            { exact (iffEL (Rlt (mul_SNo 2 t) d) (Rlt t (mul_SNo (eps_ 1) d))
                          (Rlt_mul2_right_iff t d HtR HdR) Hrlt3). }
            claim HcRel: order_rel R t c.
            { exact (Rlt_implies_order_rel_R t c Hrlt4). }
            claim HtRay: t :e open_ray_lower R c.
            { exact (SepI R (fun x0 : set => order_rel R x0 c) t HtR HcRel). }
            exact (binintersectI (open_ray_lower R c) unit_interval_right_half t HtRay HtRH).
          - let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_right_half.
            prove t :e preimage_of unit_interval_right_half double_minus_one_map_right_half (open_ray_lower R b).
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 (open_ray_lower R c) unit_interval_right_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtR: t :e R.
            { exact (unit_interval_sub_R t HtI). }
            claim Hrel: order_rel R t c.
            { exact (SepE2 R (fun x0 : set => order_rel R x0 c) t HtRay). }
            claim Hrlt: Rlt t c.
            { exact (order_rel_R_implies_Rlt t c Hrel). }
            claim Hrlt2: Rlt (mul_SNo 2 t) d.
            { exact (iffER (Rlt (mul_SNo 2 t) d) (Rlt t (mul_SNo (eps_ 1) d))
                          (Rlt_mul2_right_iff t d HtR HdR) Hrlt). }
            claim H2tR: mul_SNo 2 t :e R.
            { claim HdefR: R = real.
              { reflexivity. }
              rewrite HdefR.
              claim H2Real: 2 :e real.
              { rewrite <- HdefR.
                exact real_2. }
              claim HtReal: t :e real.
              { rewrite <- HdefR.
                exact HtR. }
              exact (real_mul_SNo 2 H2Real t HtReal). }
            claim Hrlt3: Rlt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) b.
            { exact (iffER (Rlt (add_SNo (mul_SNo 2 t) (minus_SNo 1)) b) (Rlt (mul_SNo 2 t) (add_SNo b 1))
                          (Haddm1R (mul_SNo 2 t) b H2tR HbR) Hrlt2). }
            claim Hrlt4: Rlt (apply_fun double_minus_one_map_right_half t) b.
            { rewrite (double_minus_one_map_apply t HtRH).
              exact Hrlt3. }
            claim Hrel2: order_rel R (apply_fun double_minus_one_map_right_half t) b.
            { exact (Rlt_implies_order_rel_R (apply_fun double_minus_one_map_right_half t) b Hrlt4). }
            claim HimgR: apply_fun double_minus_one_map_right_half t :e R.
            { exact (Hfun t HtRH). }
            claim Himg: apply_fun double_minus_one_map_right_half t :e open_ray_lower R b.
            { exact (SepI R (fun x0 : set => order_rel R x0 b)
                          (apply_fun double_minus_one_map_right_half t) HimgR Hrel2). }
            exact (SepI unit_interval_right_half
                        (fun u : set => apply_fun double_minus_one_map_right_half u :e open_ray_lower R b)
                        t HtRH Himg). }

        rewrite HpreEq.
        prove (open_ray_lower R c) :/\: unit_interval_right_half :e Tx.
        prove (open_ray_lower R c) :/\: unit_interval_right_half :e
             {W :e Power unit_interval_right_half | exists Z :e unit_interval_topology,
                  W = Z :/\: unit_interval_right_half}.
        claim Hpow: (open_ray_lower R c) :/\: unit_interval_right_half :e Power unit_interval_right_half.
        { apply PowerI.
          let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_right_half.
          exact (binintersectE2 (open_ray_lower R c) unit_interval_right_half t Ht). }
        set Z0 := (open_ray_lower R c) :/\: unit_interval.
        claim HZ0: Z0 :e unit_interval_topology.
        { claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
          { reflexivity. }
          rewrite Hut.
          prove Z0 :e {W :e Power unit_interval | exists Z :e R_standard_topology, W = Z :/\: unit_interval}.
          claim HZ0pow: Z0 :e Power unit_interval.
          { apply PowerI.
            let t. assume Ht: t :e Z0.
            exact (binintersectE2 (open_ray_lower R c) unit_interval t Ht). }
          claim HopenR: open_ray_lower R c :e R_standard_topology.
          { rewrite <- standard_topology_is_order_topology.
            claim HsRay: open_ray_lower R c :e open_rays_subbasis R.
            { exact (open_ray_lower_in_open_rays_subbasis R c HcR). }
            exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R c) HsRay). }
          claim Hex: exists Z :e R_standard_topology, Z0 = Z :/\: unit_interval.
          { witness (open_ray_lower R c).
            apply andI.
            - exact HopenR.
            - reflexivity. }
          exact (SepI (Power unit_interval)
                      (fun W0 : set => exists Z :e R_standard_topology, W0 = Z :/\: unit_interval)
                      Z0 HZ0pow Hex). }
        claim Heq: (open_ray_lower R c) :/\: unit_interval_right_half = Z0 :/\: unit_interval_right_half.
        { apply set_ext.
          - let t. assume Ht: t :e (open_ray_lower R c) :/\: unit_interval_right_half.
            prove t :e Z0 :/\: unit_interval_right_half.
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 (open_ray_lower R c) unit_interval_right_half t Ht). }
            claim HtI: t :e unit_interval.
            { exact (unit_interval_right_half_sub t HtRH). }
            claim HtZ0: t :e Z0.
            { exact (binintersectI (open_ray_lower R c) unit_interval t HtRay HtI). }
            exact (binintersectI Z0 unit_interval_right_half t HtZ0 HtRH).
          - let t. assume Ht: t :e Z0 :/\: unit_interval_right_half.
            prove t :e (open_ray_lower R c) :/\: unit_interval_right_half.
            claim HtZ0: t :e Z0.
            { exact (binintersectE1 Z0 unit_interval_right_half t Ht). }
            claim HtRH: t :e unit_interval_right_half.
            { exact (binintersectE2 Z0 unit_interval_right_half t Ht). }
            claim HtRay: t :e open_ray_lower R c.
            { exact (binintersectE1 (open_ray_lower R c) unit_interval t HtZ0). }
            exact (binintersectI (open_ray_lower R c) unit_interval_right_half t HtRay HtRH). }
        claim Hex: exists Z :e unit_interval_topology,
          (open_ray_lower R c) :/\: unit_interval_right_half = Z :/\: unit_interval_right_half.
        { witness Z0.
          apply andI.
          - exact HZ0.
          - rewrite <- Heq.
            reflexivity. }
        exact (SepI (Power unit_interval_right_half)
                    (fun W0 : set => exists Z :e unit_interval_topology, W0 = Z :/\: unit_interval_right_half)
                    ((open_ray_lower R c) :/\: unit_interval_right_half)
                    Hpow
                    Hex).
      + exact Hs0.
    - assume HsR: s :e {R}.
      claim Hseq: s = R.
      { exact (SingE R s HsR). }
      rewrite Hseq.
      claim Heq: preimage_of unit_interval_right_half double_minus_one_map_right_half R = unit_interval_right_half.
      { exact (preimage_of_whole unit_interval_right_half R double_minus_one_map_right_half Hfun). }
      rewrite Heq.
      exact (topology_has_X unit_interval_right_half Tx HTx).
    - exact HsS. }

  exact (continuous_map_from_subbasis unit_interval_right_half Tx R S double_minus_one_map_right_half
          HTx Hfun HS HpreS). }

claim Himg: forall t:set, t :e unit_interval_right_half -> apply_fun double_minus_one_map_right_half t :e unit_interval.
{ let t. assume Ht: t :e unit_interval_right_half.
  exact (double_minus_one_map_function_on t Ht). }

claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
rewrite Hut.
exact (continuous_map_range_restrict unit_interval_right_half
        (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
        R R_standard_topology
        double_minus_one_map_right_half
        unit_interval
        HcontR
        unit_interval_sub_R
        Himg).
Qed.

Theorem path_component_transitive_axiom : forall X Tx x y z:set,
  topology_on X Tx -> x :e X -> y :e X -> z :e X ->
  y :e path_component_of X Tx x -> z :e path_component_of X Tx y ->
  z :e path_component_of X Tx x.
let X Tx x y z.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
assume HyX: y :e X.
assume HzX: z :e X.
assume HyPc: y :e path_component_of X Tx x.
assume HzPc: z :e path_component_of X Tx y.
prove z :e path_component_of X Tx x.
prove z :e {y0 :e X | exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y0}.
apply SepI.
- exact HzX.
- (** extract p: x→y and q: y→z, then concatenate **)
  claim Hex1: exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y.
  { exact (SepE2 X (fun y0:set => exists p:set,
       function_on p unit_interval X /\
       continuous_map unit_interval unit_interval_topology X Tx p /\
       apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyPc). }
  claim Hex2: exists q:set,
     function_on q unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx q /\
     apply_fun q 0 = y /\ apply_fun q 1 = z.
  { exact (SepE2 X (fun y0:set => exists p:set,
       function_on p unit_interval X /\
       continuous_map unit_interval unit_interval_topology X Tx p /\
       apply_fun p 0 = y /\ apply_fun p 1 = y0) z HzPc). }
  apply Hex1.
	  let p. assume Hp.
	  apply Hex2.
	  let q. assume Hq.
	  (** concatenate p and q to obtain a path from x to z **)
	  set pf := compose_fun unit_interval_left_half double_map_left_half p.
	  set qf := compose_fun unit_interval_right_half double_minus_one_map_right_half q.

  claim Hp_fun: function_on p unit_interval X.
  { claim HpA:
      ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
        apply_fun p 0 = x) /\
      apply_fun p 1 = y.
    { exact Hp. }
    claim HpB: (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
      apply_fun p 0 = x.
    { exact (andEL ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
                     apply_fun p 0 = x)
                   (apply_fun p 1 = y)
                   HpA). }
    claim HpC: function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p.
    { exact (andEL (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p)
                   (apply_fun p 0 = x)
                   HpB). }
    exact (andEL (function_on p unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx p)
                 HpC). }

  claim Hp_cont: continuous_map unit_interval unit_interval_topology X Tx p.
  { claim HpA:
      ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
        apply_fun p 0 = x) /\
      apply_fun p 1 = y.
    { exact Hp. }
    claim HpB: (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
      apply_fun p 0 = x.
    { exact (andEL ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
                     apply_fun p 0 = x)
                   (apply_fun p 1 = y)
                   HpA). }
    claim HpC: function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p.
    { exact (andEL (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p)
                   (apply_fun p 0 = x)
                   HpB). }
    exact (andER (function_on p unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx p)
                 HpC). }

  claim Hp0: apply_fun p 0 = x.
  { claim HpA:
      ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
        apply_fun p 0 = x) /\
      apply_fun p 1 = y.
    { exact Hp. }
    claim HpB: (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
      apply_fun p 0 = x.
    { exact (andEL ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
                     apply_fun p 0 = x)
                   (apply_fun p 1 = y)
                   HpA). }
    exact (andER (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p)
                 (apply_fun p 0 = x)
                 HpB). }

  claim Hp1: apply_fun p 1 = y.
  { claim HpA:
      ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
        apply_fun p 0 = x) /\
      apply_fun p 1 = y.
    { exact Hp. }
    exact (andER ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\
                   apply_fun p 0 = x)
                 (apply_fun p 1 = y)
                 HpA). }

  claim Hq_fun: function_on q unit_interval X.
  { claim HqA:
      ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
        apply_fun q 0 = y) /\
      apply_fun q 1 = z.
    { exact Hq. }
    claim HqB: (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
      apply_fun q 0 = y.
    { exact (andEL ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
                     apply_fun q 0 = y)
                   (apply_fun q 1 = z)
                   HqA). }
    claim HqC: function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q.
    { exact (andEL (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q)
                   (apply_fun q 0 = y)
                   HqB). }
    exact (andEL (function_on q unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx q)
                 HqC). }

  claim Hq_cont: continuous_map unit_interval unit_interval_topology X Tx q.
  { claim HqA:
      ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
        apply_fun q 0 = y) /\
      apply_fun q 1 = z.
    { exact Hq. }
    claim HqB: (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
      apply_fun q 0 = y.
    { exact (andEL ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
                     apply_fun q 0 = y)
                   (apply_fun q 1 = z)
                   HqA). }
    claim HqC: function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q.
    { exact (andEL (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q)
                   (apply_fun q 0 = y)
                   HqB). }
    exact (andER (function_on q unit_interval X)
                 (continuous_map unit_interval unit_interval_topology X Tx q)
                 HqC). }

  claim Hq0: apply_fun q 0 = y.
  { claim HqA:
      ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
        apply_fun q 0 = y) /\
      apply_fun q 1 = z.
    { exact Hq. }
    claim HqB: (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
      apply_fun q 0 = y.
    { exact (andEL ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
                     apply_fun q 0 = y)
                   (apply_fun q 1 = z)
                   HqA). }
    exact (andER (function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q)
                 (apply_fun q 0 = y)
                 HqB). }

  claim Hq1: apply_fun q 1 = z.
  { claim HqA:
      ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
        apply_fun q 0 = y) /\
      apply_fun q 1 = z.
    { exact Hq. }
    exact (andER ((function_on q unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx q) /\
                   apply_fun q 0 = y)
                 (apply_fun q 1 = z)
                 HqA). }

	  claim Hpf_fun: function_on pf unit_interval_left_half X.
	  { exact (function_on_compose_fun unit_interval_left_half unit_interval X
	           double_map_left_half p
	           double_map_function_on
	           Hp_fun). }
	
	  claim Hqf_fun: function_on qf unit_interval_right_half X.
	  { exact (function_on_compose_fun unit_interval_right_half unit_interval X
	           double_minus_one_map_right_half q
	           double_minus_one_map_function_on
	           Hq_fun). }
	
	  claim Hpf_cont: continuous_map unit_interval_left_half
	    (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
	    X Tx pf.
	  { exact (composition_continuous unit_interval_left_half
	           (subspace_topology unit_interval unit_interval_topology unit_interval_left_half)
	           unit_interval unit_interval_topology
	           X Tx
	           double_map_left_half p
	           double_map_continuous
	           Hp_cont). }
	
	  claim Hqf_cont: continuous_map unit_interval_right_half
	    (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
	    X Tx qf.
	  { exact (composition_continuous unit_interval_right_half
	           (subspace_topology unit_interval unit_interval_topology unit_interval_right_half)
	           unit_interval unit_interval_topology
	           X Tx
	           double_minus_one_map_right_half q
	           double_minus_one_map_continuous
	           Hq_cont). }

  claim Hleft_closed: closed_in unit_interval unit_interval_topology unit_interval_left_half.
  { exact (andEL (closed_in unit_interval unit_interval_topology unit_interval_left_half)
                 (closed_in unit_interval unit_interval_topology unit_interval_right_half)
                 unit_interval_halves_closed). }
  claim Hright_closed: closed_in unit_interval unit_interval_topology unit_interval_right_half.
  { exact (andER (closed_in unit_interval unit_interval_topology unit_interval_left_half)
                 (closed_in unit_interval unit_interval_topology unit_interval_right_half)
                 unit_interval_halves_closed). }

	  claim Hagree: forall t:set,
	    t :e (unit_interval_left_half :/\: unit_interval_right_half) ->
	    apply_fun pf t = apply_fun qf t.
	  { let t.
	    assume Ht: t :e (unit_interval_left_half :/\: unit_interval_right_half).
	    claim HtSing: t :e {eps_ 1}.
	    { rewrite <- unit_interval_halves_intersection.
	      exact Ht. }
	    claim Hteq: t = eps_ 1.
	    { exact (SingE (eps_ 1) t HtSing). }
	    rewrite Hteq.
	    claim Hpf: apply_fun pf (eps_ 1) = apply_fun p (apply_fun double_map_left_half (eps_ 1)).
	    { exact (compose_fun_apply unit_interval_left_half double_map_left_half p (eps_ 1)
	             eps_1_in_unit_interval_left_half). }
	    claim Hqf: apply_fun qf (eps_ 1) = apply_fun q (apply_fun double_minus_one_map_right_half (eps_ 1)).
	    { exact (compose_fun_apply unit_interval_right_half double_minus_one_map_right_half q (eps_ 1)
	             eps_1_in_unit_interval_right_half). }
	    rewrite Hpf.
	    rewrite Hqf.
	    rewrite double_map_at_eps1.
	    rewrite double_minus_one_map_at_eps1.
	    rewrite Hp1.
	    rewrite Hq0.
	    reflexivity. }

  claim Hexh: exists h:set, continuous_map unit_interval unit_interval_topology X Tx h /\
    ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
     (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t)).
	  { exact (pasting_lemma unit_interval
	           unit_interval_left_half
	           unit_interval_right_half
	           X
	           unit_interval_topology
	           Tx
	           pf qf
	           unit_interval_topology_on
	           Hleft_closed
	           Hright_closed
	           unit_interval_halves_cover
	           Hpf_cont
	           Hqf_cont
	           Hagree). }
  apply Hexh.
  let h.
  assume Hh: continuous_map unit_interval unit_interval_topology X Tx h /\
    ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
     (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t)).
  prove exists p0:set,
    function_on p0 unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx p0 /\
    apply_fun p0 0 = x /\ apply_fun p0 1 = z.
  witness h.
  prove function_on h unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx h /\
    apply_fun h 0 = x /\ apply_fun h 1 = z.
  apply andI.
  - (** (function_on /\ continuous_map) /\ (apply_fun h 0 = x) **)
    apply andI.
    + (** function_on /\ continuous_map **)
      apply andI.
      * exact (continuous_map_function_on unit_interval unit_interval_topology X Tx h
               (andEL (continuous_map unit_interval unit_interval_topology X Tx h)
                      ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
                       (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t))
                      Hh)).
      * exact (andEL (continuous_map unit_interval unit_interval_topology X Tx h)
                     ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
                      (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t))
                     Hh).
    + (** apply_fun h 0 = x **)
      claim H0I: 0 :e unit_interval.
      { exact zero_in_unit_interval. }
      claim H0left: 0 :e unit_interval_left_half.
      { exact (SepI unit_interval (fun t0:set => ~(Rlt (eps_ 1) t0))
                 0 H0I
                 (not_Rlt_sym 0 (eps_ 1) eps_1_pos_R)). }
      claim Hleft: forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t.
      { exact (andEL (forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t)
                     (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t)
                     (andER (continuous_map unit_interval unit_interval_topology X Tx h)
                            ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
                             (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t))
                            Hh)). }
	      rewrite (Hleft 0 H0left).
	      claim Hpf0: apply_fun pf 0 = apply_fun p (apply_fun double_map_left_half 0).
	      { exact (compose_fun_apply unit_interval_left_half double_map_left_half p 0
	               zero_in_unit_interval_left_half). }
	      rewrite Hpf0.
	      rewrite double_map_at_0.
	      rewrite Hp0.
	      reflexivity.
  - (** apply_fun h 1 = z **)
    claim H1I: 1 :e unit_interval.
    { exact one_in_unit_interval. }
    claim H1right: 1 :e unit_interval_right_half.
    { exact (SepI unit_interval (fun t0:set => ~(Rlt t0 (eps_ 1)))
               1 H1I
               (not_Rlt_sym (eps_ 1) 1 eps_1_lt1_R)). }
    claim Hright: forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t.
    { exact (andER (forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t)
                   (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t)
                   (andER (continuous_map unit_interval unit_interval_topology X Tx h)
                          ((forall t:set, t :e unit_interval_left_half -> apply_fun h t = apply_fun pf t) /\
                           (forall t:set, t :e unit_interval_right_half -> apply_fun h t = apply_fun qf t))
                          Hh)). }
	    rewrite (Hright 1 H1right).
	    claim Hqf1: apply_fun qf 1 = apply_fun q (apply_fun double_minus_one_map_right_half 1).
	    { exact (compose_fun_apply unit_interval_right_half double_minus_one_map_right_half q 1
	             one_in_unit_interval_right_half). }
	    rewrite Hqf1.
	    rewrite double_minus_one_map_at_1.
	    rewrite Hq1.
	    reflexivity.
Qed.

(** Helper: a path connected subspace lies inside a single path component **)
Theorem subspace_path_connected_implies_in_path_component : forall X Tx V y z:set,
  topology_on X Tx -> V c= X ->
  path_connected_space V (subspace_topology X Tx V) ->
  y :e V -> z :e V ->
  z :e path_component_of X Tx y.
let X Tx V y z.
assume HTx: topology_on X Tx.
assume HVsubX: V c= X.
assume HpathV: path_connected_space V (subspace_topology X Tx V).
assume HyV: y :e V.
assume HzV: z :e V.
prove z :e path_component_of X Tx y.
claim HyX: y :e X.
{ exact (HVsubX y HyV). }
claim HzX: z :e X.
{ exact (HVsubX z HzV). }
claim HtopV: topology_on V (subspace_topology X Tx V).
{ exact (path_connected_space_topology V (subspace_topology X Tx V) HpathV). }
claim Hpaths: forall x0 y0:set, x0 :e V -> y0 :e V ->
  exists p:set, path_between V x0 y0 p /\ continuous_map unit_interval unit_interval_topology V (subspace_topology X Tx V) p.
{ let x0 y0.
  assume Hx0: x0 :e V.
  assume Hy0: y0 :e V.
  exact (path_connected_space_paths V (subspace_topology X Tx V) x0 y0 HpathV Hx0 Hy0). }
claim Hex: exists p:set, path_between V y z p /\ continuous_map unit_interval unit_interval_topology V (subspace_topology X Tx V) p.
{ exact (Hpaths y z HyV HzV). }
apply Hex.
let p.
assume Hp: path_between V y z p /\ continuous_map unit_interval unit_interval_topology V (subspace_topology X Tx V) p.
claim Hpb: path_between V y z p.
{ exact (path_witness_between V (subspace_topology X Tx V) y z p Hp). }
claim HpcontV: continuous_map unit_interval unit_interval_topology V (subspace_topology X Tx V) p.
{ exact (path_witness_continuous V (subspace_topology X Tx V) y z p Hp). }
claim HpbL: function_on p unit_interval V /\ apply_fun p 0 = y.
{ exact (path_between_pair0 V y z p Hpb). }
claim Hp1: apply_fun p 1 = z.
{ exact (path_between_at_one V y z p Hpb). }
claim Hp0: apply_fun p 0 = y.
{ exact (path_between_at_zero V y z p Hpb). }
claim HpfunV: function_on p unit_interval V.
{ exact (path_between_function_on V y z p Hpb). }
set j := {(y0,y0) | y0 :e V}.
claim Hjdef: j = {(y0,y0) | y0 :e V}.
{ reflexivity. }
claim Hjfun: function_on j V X.
{ let v. assume HvV: v :e V.
  prove apply_fun j v :e X.
  claim Hjv: apply_fun j v = v.
  { rewrite Hjdef.
    exact (identity_function_apply V v HvV). }
  rewrite Hjv.
  exact (HVsubX v HvV). }
set q := compose_fun unit_interval p j.
claim Hqfun: function_on q unit_interval X.
{ exact (function_on_compose_fun unit_interval V X p j HpfunV Hjfun). }
claim HcontJ: continuous_map V (subspace_topology X Tx V) X Tx j.
{ prove topology_on V (subspace_topology X Tx V) /\ topology_on X Tx /\ function_on j V X /\
    forall U:set, U :e Tx -> preimage_of V j U :e subspace_topology X Tx V.
  apply andI.
  - apply andI.
    + apply andI.
      * exact HtopV.
      * exact HTx.
    + exact Hjfun.
  - let U. assume HU: U :e Tx.
    prove preimage_of V j U :e subspace_topology X Tx V.
    claim Heq: preimage_of V j U = U :/\: V.
    { apply set_ext.
      - let v. assume Hv: v :e preimage_of V j U.
        claim HvV: v :e V.
        { exact (SepE1 V (fun v0:set => apply_fun j v0 :e U) v Hv). }
        claim HjinU: apply_fun j v :e U.
    { exact (SepE2 V (fun v0:set => apply_fun j v0 :e U) v Hv). }
        claim Hjv0: apply_fun {(y0,y0) | y0 :e V} v = v.
        { exact (identity_function_apply V v HvV). }
        claim HjinU0: apply_fun {(y0,y0) | y0 :e V} v :e U.
        { rewrite <- Hjdef.
          exact HjinU. }
        claim HvU: v :e U.
        { rewrite <- Hjv0.
          exact HjinU0. }
        exact (binintersectI U V v HvU HvV).
      - let v. assume Hv: v :e U :/\: V.
        apply (binintersectE U V v Hv).
        assume HvU: v :e U.
        assume HvV: v :e V.
        prove v :e preimage_of V j U.
        prove v :e {v0 :e V | apply_fun j v0 :e U}.
        apply SepI.
        * exact HvV.
        * claim Hjv0: apply_fun {(y0,y0) | y0 :e V} v = v.
          { exact (identity_function_apply V v HvV). }
          prove apply_fun j v :e U.
          rewrite Hjdef.
          claim HvU0: apply_fun {(y0,y0) | y0 :e V} v :e U.
          { rewrite Hjv0.
            exact HvU. }
          exact HvU0. }
    rewrite Heq.
    prove U :/\: V :e subspace_topology X Tx V.
    prove U :/\: V :e {W :e Power V | exists V0 :e Tx, W = V0 :/\: V}.
    apply SepI.
    * apply PowerI.
      exact (binintersect_Subq_2 U V).
    * prove exists V0 :e Tx, U :/\: V = V0 :/\: V.
      witness U.
      apply andI.
      + exact HU.
      + reflexivity. }
claim Hqcont: continuous_map unit_interval unit_interval_topology X Tx q.
{ exact (composition_continuous unit_interval unit_interval_topology V (subspace_topology X Tx V) X Tx p j HpcontV HcontJ). }
claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
{ exact zero_one_in_unit_interval. }
claim H0I: 0 :e unit_interval.
{ exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
claim H1I: 1 :e unit_interval.
{ exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }
claim Hq0: apply_fun q 0 = y.
{ claim Hq0def: apply_fun q 0 = apply_fun j (apply_fun p 0).
  { exact (compose_fun_apply unit_interval p j 0 H0I). }
  rewrite Hq0def.
  rewrite Hp0.
  claim Hjy: apply_fun j y = y.
  { rewrite Hjdef.
    exact (identity_function_apply V y HyV). }
  rewrite Hjy.
  reflexivity. }
claim Hq1: apply_fun q 1 = z.
{ claim Hq1def: apply_fun q 1 = apply_fun j (apply_fun p 1).
  { exact (compose_fun_apply unit_interval p j 1 H1I). }
  rewrite Hq1def.
  rewrite Hp1.
  claim Hjz: apply_fun j z = z.
  { rewrite Hjdef.
    exact (identity_function_apply V z HzV). }
  rewrite Hjz.
  reflexivity. }
prove z :e {y0 :e X | exists q0:set,
  function_on q0 unit_interval X /\
  continuous_map unit_interval unit_interval_topology X Tx q0 /\
  apply_fun q0 0 = y /\ apply_fun q0 1 = y0}.
apply SepI.
- exact HzX.
- prove exists q0:set,
    function_on q0 unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx q0 /\
    apply_fun q0 0 = y /\ apply_fun q0 1 = z.
  witness q.
  prove function_on q unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx q /\
    apply_fun q 0 = y /\ apply_fun q 1 = z.
  apply andI.
  - apply andI.
    + apply andI.
      * exact Hqfun.
      * exact Hqcont.
    + exact Hq0.
  - exact Hq1.
Qed.

(** Helper: path component is reflexive **)
(** LATEX VERSION: Any point is path connectible to itself via the constant path. **)
Theorem path_component_reflexive : forall X Tx x:set,
  topology_on X Tx -> x :e X -> x :e path_component_of X Tx x.
let X Tx x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
prove x :e path_component_of X Tx x.
prove x :e {y :e X | exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y}.
apply SepI.
- exact HxX.
- (** constant path p(t)=x **)
  prove exists p:set, function_on p unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx p /\
    apply_fun p 0 = x /\ apply_fun p 1 = x.
  set p := const_fun unit_interval x.
  witness p.
  prove function_on p unit_interval X /\
    continuous_map unit_interval unit_interval_topology X Tx p /\
    apply_fun p 0 = x /\ apply_fun p 1 = x.
  (** Conjunction is left-associative: (((A /\ B) /\ C) /\ D) **)
  apply andI.
  - (** (function_on /\ continuous_map) /\ (apply_fun p 0 = x) **)
    apply andI.
    + (** function_on /\ continuous_map **)
      apply andI.
      * (** function_on **)
        let t. assume HtI: t :e unit_interval.
        prove apply_fun p t :e X.
        claim Hpt: apply_fun p t = x.
        { exact (const_fun_apply unit_interval x t HtI). }
        rewrite Hpt.
        exact HxX.
      * (** continuous_map **)
        claim HtopI: topology_on unit_interval unit_interval_topology.
        { exact unit_interval_topology_on. }
        exact (const_fun_continuous unit_interval unit_interval_topology X Tx x HtopI HTx HxX).
    + (** apply_fun p 0 = x **)
      claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
      { exact zero_one_in_unit_interval. }
      claim H0: 0 :e unit_interval.
      { exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
      exact (const_fun_apply unit_interval x 0 H0).
  - (** apply_fun p 1 = x **)
    claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
    { exact zero_one_in_unit_interval. }
    claim H1: 1 :e unit_interval.
    { exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }
    exact (const_fun_apply unit_interval x 1 H1).
Qed.

(** from §24: path components form equivalence classes **) 
(** LATEX VERSION: Path components are equivalence classes under path-connectibility. **)
Theorem path_components_equivalence_relation : forall X Tx:set,
  topology_on X Tx ->
  (forall x:set, x :e X -> x :e path_component_of X Tx x) /\
  (forall x y:set, x :e X -> y :e X -> y :e path_component_of X Tx x -> x :e path_component_of X Tx y) /\
  (forall x y z:set, x :e X -> y :e X -> z :e X ->
     y :e path_component_of X Tx x -> z :e path_component_of X Tx y ->
     z :e path_component_of X Tx x).
let X Tx.
assume HTx: topology_on X Tx.
prove (forall x:set, x :e X -> x :e path_component_of X Tx x) /\
  (forall x y:set, x :e X -> y :e X -> y :e path_component_of X Tx x -> x :e path_component_of X Tx y) /\
  (forall x y z:set, x :e X -> y :e X -> z :e X ->
     y :e path_component_of X Tx x -> z :e path_component_of X Tx y ->
     z :e path_component_of X Tx x).
(** Conjunction is left-associative: (P1 /\ P2) /\ P3 **)
  apply andI.
  - (** P1 /\ P2 **)
    apply andI.
    * (** reflexive **)
      let x. assume HxX: x :e X.
      exact (path_component_reflexive X Tx x HTx HxX).
    * (** symmetric: reverse path **)
      let x y.
      assume HxX: x :e X.
      assume HyX: y :e X.
      assume HyPc: y :e path_component_of X Tx x.
      exact (path_component_symmetric_axiom X Tx x y HTx HxX HyX HyPc).
  - (** transitive: concatenate paths **)
    let x y z.
    assume HxX: x :e X.
    assume HyX: y :e X.
    assume HzX: z :e X.
    assume HyPc: y :e path_component_of X Tx x.
    assume HzPc: z :e path_component_of X Tx y.
    exact (path_component_transitive_axiom X Tx x y z HTx HxX HyX HzX HyPc HzPc).
Qed.

(** from §25 Definition: components and local connectedness **) 
(** LATEX VERSION: Component_of X Tx x is the union of connected subspaces containing x; locally_connected means every neighborhood contains a connected open neighborhood of the point. **)
Definition component_of : set -> set -> set -> set := fun X Tx x =>
  {y :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C}.
Definition locally_connected : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x:set, x :e X ->
    forall U:set, U :e Tx -> x :e U ->
      exists V:set, V :e Tx /\ x :e V /\ V c= U /\ connected_space V (subspace_topology X Tx V).

(** Helper: extract topology_on from locally_connected **)
Theorem locally_connected_topology : forall X Tx:set,
  locally_connected X Tx -> topology_on X Tx.
let X Tx.
assume H: locally_connected X Tx.
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X ->
               forall U:set, U :e Tx -> x :e U ->
                 exists V:set, V :e Tx /\ x :e V /\ V c= U /\ connected_space V (subspace_topology X Tx V))
             H).
Qed.

(** Helper: extract local connectedness property **)
Theorem locally_connected_local : forall X Tx x U:set,
  locally_connected X Tx ->
  x :e X ->
  U :e Tx ->
  x :e U ->
  exists V:set, V :e Tx /\ x :e V /\ V c= U /\ connected_space V (subspace_topology X Tx V).
let X Tx x U.
assume H: locally_connected X Tx.
assume Hx: x :e X.
assume HU: U :e Tx.
assume HxU: x :e U.
claim Hprop: forall x0:set, x0 :e X ->
  forall U0:set, U0 :e Tx -> x0 :e U0 ->
    exists V:set, V :e Tx /\ x0 :e V /\ V c= U0 /\ connected_space V (subspace_topology X Tx V).
{ exact (andER (topology_on X Tx)
               (forall x0:set, x0 :e X ->
                 forall U0:set, U0 :e Tx -> x0 :e U0 ->
                   exists V:set, V :e Tx /\ x0 :e V /\ V c= U0 /\ connected_space V (subspace_topology X Tx V))
               H). }
exact (Hprop x Hx U HU HxU).
Qed.

(** from §25 Definition: locally path connected **)
(** LATEX VERSION: Locally path connected means each point has a neighborhood basis of path-connected sets. **)
Definition locally_path_connected : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x:set, x :e X ->
    forall U:set, U :e Tx -> x :e U ->
      exists V:set, V :e Tx /\ x :e V /\ V c= U /\ path_connected_space V (subspace_topology X Tx V).

(** Helper: extract topology_on from locally_path_connected **)
Theorem locally_path_connected_topology : forall X Tx:set,
  locally_path_connected X Tx -> topology_on X Tx.
let X Tx.
assume H: locally_path_connected X Tx.
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X ->
               forall U:set, U :e Tx -> x :e U ->
                 exists V:set, V :e Tx /\ x :e V /\ V c= U /\ path_connected_space V (subspace_topology X Tx V))
             H).
Qed.

(** Helper: extract local path connectedness property **)
Theorem locally_path_connected_local : forall X Tx x U:set,
  locally_path_connected X Tx ->
  x :e X ->
  U :e Tx ->
  x :e U ->
  exists V:set, V :e Tx /\ x :e V /\ V c= U /\ path_connected_space V (subspace_topology X Tx V).
let X Tx x U.
assume H: locally_path_connected X Tx.
assume Hx: x :e X.
assume HU: U :e Tx.
assume HxU: x :e U.
claim Hprop: forall x0:set, x0 :e X ->
  forall U0:set, U0 :e Tx -> x0 :e U0 ->
    exists V:set, V :e Tx /\ x0 :e V /\ V c= U0 /\ path_connected_space V (subspace_topology X Tx V).
{ exact (andER (topology_on X Tx)
               (forall x0:set, x0 :e X ->
                 forall U0:set, U0 :e Tx -> x0 :e U0 ->
                   exists V:set, V :e Tx /\ x0 :e V /\ V c= U0 /\ path_connected_space V (subspace_topology X Tx V))
               H). }
exact (Hprop x Hx U HU HxU).
Qed.

(** Helper: singleton subspace is connected **)
Theorem singleton_subspace_connected : forall X Tx x:set,
  topology_on X Tx -> x :e X ->
  connected_space {x} (subspace_topology X Tx {x}).
let X Tx x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
prove connected_space {x} (subspace_topology X Tx {x}).
prove topology_on {x} (subspace_topology X Tx {x}) /\
  ~(exists U V:set, U :e subspace_topology X Tx {x} /\ V :e subspace_topology X Tx {x} /\ separation_of {x} U V).
apply andI.
- (** topology_on {x} (subspace_topology X Tx {x}) **)
  claim Hsub: {x} c= X.
  { let y. assume Hy: y :e {x}.
    prove y :e X.
    claim HyEq: y = x.
    { exact (SingE x y Hy). }
    rewrite HyEq.
    exact HxX. }
  exact (subspace_topology_is_topology X Tx {x} HTx Hsub).
- (** no separation exists **)
  assume Hsep: exists U V:set, U :e subspace_topology X Tx {x} /\ V :e subspace_topology X Tx {x} /\ separation_of {x} U V.
  apply Hsep.
  let U. assume HexV: exists V:set, U :e subspace_topology X Tx {x} /\ V :e subspace_topology X Tx {x} /\ separation_of {x} U V.
  apply HexV.
  let V. assume HUV.
  claim HopenUV: (U :e subspace_topology X Tx {x} /\ V :e subspace_topology X Tx {x}) /\ separation_of {x} U V.
  { exact HUV. }
  claim Hsepof: separation_of {x} U V.
  { exact (andER (U :e subspace_topology X Tx {x} /\ V :e subspace_topology X Tx {x})
                 (separation_of {x} U V) HopenUV). }
  (** Extract U<>Empty, V<>Empty, and U∩V=Empty and Power-membership from separation_of **)
  claim Hpre: ((((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty).
  { exact (andEL ((((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) /\ U <> Empty) /\ V <> Empty)
                 (U :\/: V = {x}) Hsepof). }
  claim Hpre2: (((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) /\ U <> Empty).
  { exact (andEL (((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) /\ U <> Empty)
                 (V <> Empty) Hpre). }
  claim HUneq: U <> Empty.
  { exact (andER ((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) (U <> Empty) Hpre2). }
  claim HVneq: V <> Empty.
  { exact (andER ((((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) /\ U <> Empty)) (V <> Empty) Hpre). }
  claim HpowDisj: (U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty.
  { exact (andEL ((U :e Power {x} /\ V :e Power {x}) /\ U :/\: V = Empty) (U <> Empty) Hpre2). }
  claim HpowUV: U :e Power {x} /\ V :e Power {x}.
  { exact (andEL (U :e Power {x} /\ V :e Power {x}) (U :/\: V = Empty) HpowDisj). }
  claim HUpow: U :e Power {x}.
  { exact (andEL (U :e Power {x}) (V :e Power {x}) HpowUV). }
  claim HVpow: V :e Power {x}.
  { exact (andER (U :e Power {x}) (V :e Power {x}) HpowUV). }
  claim Hdisj: U :/\: V = Empty.
  { exact (andER (U :e Power {x} /\ V :e Power {x}) (U :/\: V = Empty) HpowDisj). }
  (** Pick u∈U and v∈V; both must equal x, contradiction with disjointness **)
  apply (nonempty_has_element U HUneq).
  let u. assume Hu: u :e U.
  apply (nonempty_has_element V HVneq).
  let v. assume Hv: v :e V.
  claim HUsub: U c= {x}.
  { exact (PowerE {x} U HUpow). }
  claim HVsub: V c= {x}.
  { exact (PowerE {x} V HVpow). }
  claim Hux: u = x.
  { exact (SingE x u (HUsub u Hu)). }
  claim Hvx: v = x.
  { exact (SingE x v (HVsub v Hv)). }
  claim HxU: x :e U.
  { rewrite <- Hux. exact Hu. }
  claim HxV: x :e V.
  { rewrite <- Hvx. exact Hv. }
  claim HxUV: x :e U :/\: V.
  { exact (binintersectI U V x HxU HxV). }
  claim HxE: x :e Empty.
  { rewrite <- Hdisj. exact HxUV. }
  exact (EmptyE x HxE).
Qed.

(** Helper: a point lies in its own component **)
Theorem point_in_component : forall X Tx x:set,
  topology_on X Tx -> x :e X -> x :e component_of X Tx x.
let X Tx x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
prove x :e component_of X Tx x.
prove x :e {y :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C}.
apply SepI.
- exact HxX.
- prove exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ x :e C.
  witness {x}.
  prove connected_space {x} (subspace_topology X Tx {x}) /\ x :e {x} /\ x :e {x}.
  apply andI.
  + apply andI.
    - exact (singleton_subspace_connected X Tx x HTx HxX).
    - exact (SingI x).
  + exact (SingI x).
Qed.

(** Helper: connected subspace witness implies subset of X **)
Theorem connected_subspace_subset : forall X Tx C:set,
  topology_on X Tx ->
  connected_space C (subspace_topology X Tx C) ->
  C c= X.
let X Tx C.
assume HTx: topology_on X Tx.
assume HCconn: connected_space C (subspace_topology X Tx C).
prove C c= X.
claim HCtop: topology_on C (subspace_topology X Tx C).
{ exact (connected_space_topology C (subspace_topology X Tx C) HCconn). }
	claim HCinSub: C :e subspace_topology X Tx C.
	{ exact (topology_has_X C (subspace_topology X Tx C) HCtop). }
	claim HexV: exists V :e Tx, C = V :/\: C.
	{ exact (subspace_topologyE X Tx C C HCinSub). }
	apply HexV.
let V. assume HVpair.
claim HVTx: V :e Tx.
{ exact (andEL (V :e Tx) (C = V :/\: C) HVpair). }
claim HCeq: C = V :/\: C.
{ exact (andER (V :e Tx) (C = V :/\: C) HVpair). }
claim HCsubV: C c= V.
{ rewrite HCeq.
  exact (binintersect_Subq_1 V C). }
claim HVsubX: V c= X.
{ exact (topology_elem_subset X Tx V HTx HVTx). }
exact (Subq_tra C V X HCsubV HVsubX).
Qed.

(** Helper: the component of a point is connected **)
Theorem component_of_connected : forall X Tx x:set,
  topology_on X Tx -> x :e X ->
  connected_space (component_of X Tx x) (subspace_topology X Tx (component_of X Tx x)).
let X Tx x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
set F := {C :e Power X | connected_space C (subspace_topology X Tx C) /\ x :e C}.
claim HFsub: forall C:set, C :e F -> C c= X.
{ let C. assume HCinF: C :e F.
  claim HCpow: C :e Power X.
  { exact (SepE1 (Power X) (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0) C HCinF). }
  exact (PowerE X C HCpow). }
claim HFconn: forall C:set, C :e F -> connected_space C (subspace_topology X Tx C).
{ let C. assume HCinF: C :e F.
  claim HCpair: connected_space C (subspace_topology X Tx C) /\ x :e C.
  { exact (SepE2 (Power X) (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0) C HCinF). }
  exact (andEL (connected_space C (subspace_topology X Tx C)) (x :e C) HCpair). }
claim Hcommon: exists w:set, forall C:set, C :e F -> w :e C.
{ witness x.
  let C. assume HCinF: C :e F.
  claim HCpair: connected_space C (subspace_topology X Tx C) /\ x :e C.
  { exact (SepE2 (Power X) (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0) C HCinF). }
  exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C) HCpair). }
claim HUnionConn: connected_space (Union F) (subspace_topology X Tx (Union F)).
{ exact (union_connected_common_point X Tx F HTx HFsub HFconn Hcommon). }
claim Heq: component_of X Tx x = Union F.
{ apply set_ext.
  - let y. assume Hy: y :e component_of X Tx x.
    prove y :e Union F.
    claim HexC: exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    { exact (SepE2 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy). }
    apply HexC.
    let C. assume HC: connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    claim HCconn: connected_space C (subspace_topology X Tx C).
    { exact (andEL (connected_space C (subspace_topology X Tx C)) (x :e C)
                   (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HxC: x :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C)
                   (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HyC: y :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC). }
    claim HCsubX: C c= X.
    { exact (connected_subspace_subset X Tx C HTx HCconn). }
    claim HCpow: C :e Power X.
    { exact (PowerI X C HCsubX). }
    claim HCinF: C :e F.
    { prove C :e {C0 :e Power X | connected_space C0 (subspace_topology X Tx C0) /\ x :e C0}.
      apply SepI.
      - exact HCpow.
      - prove connected_space C (subspace_topology X Tx C) /\ x :e C.
        apply andI.
        * exact HCconn.
        * exact HxC. }
    exact (UnionI F y C HyC HCinF).
  - let y. assume Hy: y :e Union F.
    prove y :e component_of X Tx x.
    apply (UnionE F y Hy).
    let C. assume Hex: y :e C /\ C :e F.
    claim HyC: y :e C.
    { exact (andEL (y :e C) (C :e F) Hex). }
    claim HCinF: C :e F.
    { exact (andER (y :e C) (C :e F) Hex). }
    claim HCsubX: C c= X.
    { exact (HFsub C HCinF). }
    claim HCpair: connected_space C (subspace_topology X Tx C) /\ x :e C.
    { exact (SepE2 (Power X) (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0) C HCinF). }
    claim HCconn: connected_space C (subspace_topology X Tx C).
    { exact (andEL (connected_space C (subspace_topology X Tx C)) (x :e C) HCpair). }
    claim HxC: x :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C) HCpair). }
    prove y :e {y0 :e X | exists D:set, connected_space D (subspace_topology X Tx D) /\ x :e D /\ y0 :e D}.
    apply SepI.
    - exact (HCsubX y HyC).
    - prove exists D:set, connected_space D (subspace_topology X Tx D) /\ x :e D /\ y :e D.
      witness C.
      prove connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
      apply andI.
      + apply andI.
        * exact HCconn.
        * exact HxC.
      + exact HyC. }
prove connected_space (component_of X Tx x) (subspace_topology X Tx (component_of X Tx x)).
rewrite Heq.
exact HUnionConn.
Qed.

(** Helper: if y lies in the component of x, their components coincide **)
Theorem component_of_eq_if_in : forall X Tx x y:set,
  topology_on X Tx -> x :e X ->
  y :e component_of X Tx x ->
  component_of X Tx y = component_of X Tx x.
let X Tx x y.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
assume HyComp: y :e component_of X Tx x.
prove component_of X Tx y = component_of X Tx x.
claim HyX: y :e X.
{ exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y HyComp). }
claim HexC: exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
{ exact (SepE2 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y HyComp). }
apply set_ext.
- let z. assume Hz: z :e component_of X Tx y.
  prove z :e component_of X Tx x.
  claim HzX: z :e X.
  { exact (SepE1 X (fun z0:set => exists D:set, connected_space D (subspace_topology X Tx D) /\ y :e D /\ z0 :e D) z Hz). }
  claim HexD: exists D:set, connected_space D (subspace_topology X Tx D) /\ y :e D /\ z :e D.
  { exact (SepE2 X (fun z0:set => exists D:set, connected_space D (subspace_topology X Tx D) /\ y :e D /\ z0 :e D) z Hz). }
  prove z :e {y0 :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C}.
  apply SepI.
  - exact HzX.
  - (** build a connected witness containing x and z by union of connected sets through y **)
    set C := Eps_i (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y :e C0).
    claim HC: connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    { exact (Eps_i_ex (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y :e C0) HexC). }
    set D := Eps_i (fun D0:set => connected_space D0 (subspace_topology X Tx D0) /\ y :e D0 /\ z :e D0).
    claim HD: connected_space D (subspace_topology X Tx D) /\ y :e D /\ z :e D.
    { exact (Eps_i_ex (fun D0:set => connected_space D0 (subspace_topology X Tx D0) /\ y :e D0 /\ z :e D0) HexD). }
    claim HCconn: connected_space C (subspace_topology X Tx C).
    { exact (andEL (connected_space C (subspace_topology X Tx C)) (x :e C) (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HxC: x :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C)
                   (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HyC: y :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC). }
    claim HDconn: connected_space D (subspace_topology X Tx D).
    { exact (andEL (connected_space D (subspace_topology X Tx D)) (y :e D) (andEL (connected_space D (subspace_topology X Tx D) /\ y :e D) (z :e D) HD)). }
    claim HyD: y :e D.
    { exact (andER (connected_space D (subspace_topology X Tx D)) (y :e D)
                   (andEL (connected_space D (subspace_topology X Tx D) /\ y :e D) (z :e D) HD)). }
    claim HzD: z :e D.
    { exact (andER (connected_space D (subspace_topology X Tx D) /\ y :e D) (z :e D) HD). }
    claim HCsubX: C c= X.
    { exact (connected_subspace_subset X Tx C HTx HCconn). }
    claim HDsubX: D c= X.
    { exact (connected_subspace_subset X Tx D HTx HDconn). }
    (** connectedness of C∪D by common point y **)
    set F := UPair C D.
    claim HFsub: forall E:set, E :e F -> E c= X.
    { let E. assume HE: E :e F.
      apply (UPairE E C D HE (E c= X)).
      - assume HEq: E = C. rewrite HEq. exact HCsubX.
      - assume HEq: E = D. rewrite HEq. exact HDsubX. }
    claim HFconn: forall E:set, E :e F -> connected_space E (subspace_topology X Tx E).
    { let E. assume HE: E :e F.
      apply (UPairE E C D HE (connected_space E (subspace_topology X Tx E))).
      - assume HEq: E = C. rewrite HEq. exact HCconn.
      - assume HEq: E = D. rewrite HEq. exact HDconn. }
    claim Hcommon: exists w:set, forall E:set, E :e F -> w :e E.
    { witness y.
      let E. assume HE: E :e F.
      apply (UPairE E C D HE (y :e E)).
      - assume HEq: E = C. rewrite HEq. exact HyC.
      - assume HEq: E = D. rewrite HEq. exact HyD. }
    claim HUnionConn: connected_space (Union F) (subspace_topology X Tx (Union F)).
    { exact (union_connected_common_point X Tx F HTx HFsub HFconn Hcommon). }
    (** x and z are in Union(F) **)
    claim HCinF: C :e F.
    { exact (UPairI1 C D). }
    claim HDinF: D :e F.
    { exact (UPairI2 C D). }
    claim HxUF: x :e Union F.
    { exact (UnionI F x C HxC HCinF). }
    claim HzUF: z :e Union F.
    { exact (UnionI F z D HzD HDinF). }
    prove exists C0:set, connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ z :e C0.
    witness (Union F).
    prove connected_space (Union F) (subspace_topology X Tx (Union F)) /\ x :e Union F /\ z :e Union F.
    apply andI.
    - apply andI.
      + exact HUnionConn.
      + exact HxUF.
    - exact HzUF.
- let z. assume Hz: z :e component_of X Tx x.
  prove z :e component_of X Tx y.
  claim HzX: z :e X.
  { exact (SepE1 X (fun z0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ z0 :e C) z Hz). }
  claim HexCz: exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ z :e C.
  { exact (SepE2 X (fun z0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ z0 :e C) z Hz). }
  prove z :e {y0 :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ y :e C /\ y0 :e C}.
  apply SepI.
  - exact HzX.
  - (** symmetric argument swapping x and y **)
    set C := Eps_i (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y :e C0).
    claim HC: connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    { exact (Eps_i_ex (fun C0:set => connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y :e C0) HexC). }
    set D := Eps_i (fun D0:set => connected_space D0 (subspace_topology X Tx D0) /\ x :e D0 /\ z :e D0).
    claim HD: connected_space D (subspace_topology X Tx D) /\ x :e D /\ z :e D.
    { exact (Eps_i_ex (fun D0:set => connected_space D0 (subspace_topology X Tx D0) /\ x :e D0 /\ z :e D0) HexCz). }
    claim HCconn: connected_space C (subspace_topology X Tx C).
    { exact (andEL (connected_space C (subspace_topology X Tx C)) (x :e C) (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HxC: x :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C)
                   (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
    claim HyC: y :e C.
    { exact (andER (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC). }
    claim HDconn: connected_space D (subspace_topology X Tx D).
    { exact (andEL (connected_space D (subspace_topology X Tx D)) (x :e D) (andEL (connected_space D (subspace_topology X Tx D) /\ x :e D) (z :e D) HD)). }
    claim HxD: x :e D.
    { exact (andER (connected_space D (subspace_topology X Tx D)) (x :e D)
                   (andEL (connected_space D (subspace_topology X Tx D) /\ x :e D) (z :e D) HD)). }
    claim HzD: z :e D.
    { exact (andER (connected_space D (subspace_topology X Tx D) /\ x :e D) (z :e D) HD). }
    claim HCsubX: C c= X.
    { exact (connected_subspace_subset X Tx C HTx HCconn). }
    claim HDsubX: D c= X.
    { exact (connected_subspace_subset X Tx D HTx HDconn). }
    set F := UPair C D.
    claim HFsub: forall E:set, E :e F -> E c= X.
    { let E. assume HE: E :e F.
      apply (UPairE E C D HE (E c= X)).
      - assume HEq: E = C. rewrite HEq. exact HCsubX.
      - assume HEq: E = D. rewrite HEq. exact HDsubX. }
    claim HFconn: forall E:set, E :e F -> connected_space E (subspace_topology X Tx E).
    { let E. assume HE: E :e F.
      apply (UPairE E C D HE (connected_space E (subspace_topology X Tx E))).
      - assume HEq: E = C. rewrite HEq. exact HCconn.
      - assume HEq: E = D. rewrite HEq. exact HDconn. }
    claim Hcommon: exists w:set, forall E:set, E :e F -> w :e E.
    { witness x.
      let E. assume HE: E :e F.
      apply (UPairE E C D HE (x :e E)).
      - assume HEq: E = C. rewrite HEq. exact HxC.
      - assume HEq: E = D. rewrite HEq. exact HxD. }
    claim HUnionConn: connected_space (Union F) (subspace_topology X Tx (Union F)).
    { exact (union_connected_common_point X Tx F HTx HFsub HFconn Hcommon). }
    claim HCinF: C :e F.
    { exact (UPairI1 C D). }
    claim HDinF: D :e F.
    { exact (UPairI2 C D). }
    claim HyUF: y :e Union F.
    { exact (UnionI F y C HyC HCinF). }
    claim HzUF: z :e Union F.
    { exact (UnionI F z D HzD HDinF). }
    prove exists C0:set, connected_space C0 (subspace_topology X Tx C0) /\ y :e C0 /\ z :e C0.
    witness (Union F).
    prove connected_space (Union F) (subspace_topology X Tx (Union F)) /\ y :e Union F /\ z :e Union F.
    apply andI.
    - apply andI.
      + exact HUnionConn.
      + exact HyUF.
    - exact HzUF.
Qed.

(** helper: in a connected space, the component of any point is the whole space **)
(** LATEX VERSION: If X is connected then the component of any point is X. **)
Theorem component_of_whole : forall X Tx x:set,
  connected_space X Tx -> x :e X -> component_of X Tx x = X.
let X Tx x.
assume Hconn: connected_space X Tx.
assume HxX: x :e X.
prove component_of X Tx x = X.
claim HTx: topology_on X Tx.
{ exact (connected_space_topology X Tx Hconn). }
apply set_ext.
- let y. assume Hy: y :e component_of X Tx x.
  prove y :e X.
  exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy).
- let y. assume HyX: y :e X.
  prove y :e component_of X Tx x.
  prove y :e {y0 :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C}.
  apply SepI.
  - exact HyX.
  - claim Hsubeq: subspace_topology X Tx X = Tx.
    { exact (subspace_topology_whole X Tx HTx). }
    claim HconnSub: connected_space X (subspace_topology X Tx X).
    { rewrite Hsubeq.
      exact Hconn. }
    prove exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    witness X.
    apply andI.
    - apply andI.
      + exact HconnSub.
      + exact HxX.
    - exact HyX.
Qed.

(** helper: in a path connected space, the path component of any point is the whole space **)
(** LATEX VERSION: If X is path connected then the path component of any point is X. **)
Theorem path_component_of_whole : forall X Tx x:set,
  path_connected_space X Tx -> x :e X -> path_component_of X Tx x = X.
let X Tx x.
assume Hpath: path_connected_space X Tx.
assume HxX: x :e X.
prove path_component_of X Tx x = X.
claim HTx: topology_on X Tx.
{ exact (path_connected_space_topology X Tx Hpath). }
claim Hpathprop: forall x0 y0:set, x0 :e X -> y0 :e X ->
  exists p:set, path_between X x0 y0 p /\ continuous_map unit_interval unit_interval_topology X Tx p.
{ let x0 y0.
  assume Hx0: x0 :e X.
  assume Hy0: y0 :e X.
  exact (path_connected_space_paths X Tx x0 y0 Hpath Hx0 Hy0). }
apply set_ext.
- (** path_component_of subset X **)
  let y. assume Hy: y :e path_component_of X Tx x.
  prove y :e X.
  exact (SepE1 X (fun y0:set => exists p:set,
                    function_on p unit_interval X /\
                    continuous_map unit_interval unit_interval_topology X Tx p /\
                    apply_fun p 0 = x /\ apply_fun p 1 = y0) y Hy).
- (** X subset path_component_of **)
  let y. assume HyX: y :e X.
  prove y :e path_component_of X Tx x.
  prove y :e {y0 :e X | exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y0}.
  apply SepI.
  - exact HyX.
  - claim Hex: exists p:set, path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
    { exact (Hpathprop x y HxX HyX). }
    apply Hex.
    let p.
    assume Hp: path_between X x y p /\ continuous_map unit_interval unit_interval_topology X Tx p.
    claim Hpb: path_between X x y p.
    { exact (path_witness_between X Tx x y p Hp). }
    claim Hcont: continuous_map unit_interval unit_interval_topology X Tx p.
    { exact (path_witness_continuous X Tx x y p Hp). }
    prove exists q:set, function_on q unit_interval X /\
      continuous_map unit_interval unit_interval_topology X Tx q /\
      apply_fun q 0 = x /\ apply_fun q 1 = y.
    witness p.
    prove function_on p unit_interval X /\
      continuous_map unit_interval unit_interval_topology X Tx p /\
      apply_fun p 0 = x /\ apply_fun p 1 = y.
    claim HpbL: function_on p unit_interval X /\ apply_fun p 0 = x.
    { exact (path_between_pair0 X x y p Hpb). }
    claim Hp1: apply_fun p 1 = y.
    { exact (path_between_at_one X x y p Hpb). }
    claim Hp0: apply_fun p 0 = x.
    { exact (path_between_at_zero X x y p Hpb). }
    claim Hfun: function_on p unit_interval X.
    { exact (path_between_function_on X x y p Hpb). }
    apply andI.
    - apply andI.
      + apply andI.
        * exact Hfun.
        * exact Hcont.
      + exact Hp0.
    - exact Hp1.
Qed.

(** from §23 Connected Spaces / separations: disjoint families **)
(** LATEX VERSION: A family is pairwise disjoint if any two distinct members have empty intersection. **)
Definition pairwise_disjoint : set -> prop := fun Fam =>
  forall U V:set, U :e Fam -> V :e Fam -> U <> V -> U :/\: V = Empty.

(** from §26 Compactness: cover relation **)
(** LATEX VERSION: A family U covers X if every point of X lies in some member of U. **)
Definition covers : set -> set -> prop :=
  fun X U => forall x:set, x :e X -> exists u:set, u :e U /\ x :e u.

(** from §25: path components open in locally path connected spaces **) 
(** LATEX VERSION: In a locally path connected space, every path component is open. **)
Theorem path_components_open : forall X Tx:set,
  locally_path_connected X Tx ->
  forall x:set, x :e X ->
    open_in X Tx (path_component_of X Tx x).
let X Tx.
assume Hlpc: locally_path_connected X Tx.
let x.
assume Hx: x :e X.
prove open_in X Tx (path_component_of X Tx x).
prove topology_on X Tx /\ path_component_of X Tx x :e Tx.
claim HTx: topology_on X Tx.
{ exact (locally_path_connected_topology X Tx Hlpc). }
claim Hlpcprop: forall x0:set, x0 :e X ->
  forall U:set, U :e Tx -> x0 :e U ->
    exists V:set, V :e Tx /\ x0 :e V /\ V c= U /\ path_connected_space V (subspace_topology X Tx V).
{ let x0. assume Hx0: x0 :e X.
  let U. assume HU: U :e Tx.
  assume Hx0U: x0 :e U.
  exact (locally_path_connected_local X Tx x0 U Hlpc Hx0 HU Hx0U). }
apply andI.
- exact HTx.
- set P := path_component_of X Tx x.
  set Fam := {V :e Tx | V c= P /\ path_connected_space V (subspace_topology X Tx V)}.
  claim HFsub: Fam c= Tx.
  { let V. assume HV: V :e Fam.
    exact (SepE1 Tx (fun V0:set => V0 c= P /\ path_connected_space V0 (subspace_topology X Tx V0)) V HV). }
  claim HUnionTx: Union Fam :e Tx.
  { exact (topology_union_closed X Tx Fam HTx HFsub). }
  claim HUnionEq: Union Fam = P.
  { apply set_ext.
    - let y. assume Hy: y :e Union Fam.
      apply (UnionE Fam y Hy).
      let V. assume Hex: y :e V /\ V :e Fam.
      claim HyV: y :e V.
      { exact (andEL (y :e V) (V :e Fam) Hex). }
      claim HVFam: V :e Fam.
      { exact (andER (y :e V) (V :e Fam) Hex). }
      claim HVpair: V c= P /\ path_connected_space V (subspace_topology X Tx V).
      { exact (SepE2 Tx (fun V0:set => V0 c= P /\ path_connected_space V0 (subspace_topology X Tx V0)) V HVFam). }
      claim HVsubP: V c= P.
      { exact (andEL (V c= P) (path_connected_space V (subspace_topology X Tx V)) HVpair). }
      exact (HVsubP y HyV).
    - let y. assume HyP: y :e P.
      claim HyX: y :e X.
      { exact (SepE1 X (fun y0:set => exists p:set,
        function_on p unit_interval X /\
        continuous_map unit_interval unit_interval_topology X Tx p /\
        apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyP). }
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HexV: exists V:set, V :e Tx /\ y :e V /\ V c= X /\ path_connected_space V (subspace_topology X Tx V).
      { exact (Hlpcprop y HyX X HXTx HyX). }
      apply HexV.
      let V. assume HV: V :e Tx /\ y :e V /\ V c= X /\ path_connected_space V (subspace_topology X Tx V).
      claim HVpre: ((V :e Tx /\ y :e V) /\ V c= X).
      { exact (andEL ((V :e Tx /\ y :e V) /\ V c= X)
                     (path_connected_space V (subspace_topology X Tx V)) HV). }
      claim HVpath: path_connected_space V (subspace_topology X Tx V).
      { exact (andER ((V :e Tx /\ y :e V) /\ V c= X)
                     (path_connected_space V (subspace_topology X Tx V)) HV). }
      claim HVTx_y: V :e Tx /\ y :e V.
      { exact (andEL (V :e Tx /\ y :e V) (V c= X) HVpre). }
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (y :e V) HVTx_y). }
      claim HyV: y :e V.
      { exact (andER (V :e Tx) (y :e V) HVTx_y). }
      claim HVsubX: V c= X.
      { exact (andER (V :e Tx /\ y :e V) (V c= X) HVpre). }
      claim HVsubP: V c= P.
      { let z. assume HzV: z :e V.
        prove z :e P.
        claim HzX: z :e X.
        { exact (HVsubX z HzV). }
        claim HzPcy: z :e path_component_of X Tx y.
        { exact (subspace_path_connected_implies_in_path_component X Tx V y z HTx HVsubX HVpath HyV HzV). }
        exact (path_component_transitive_axiom X Tx x y z HTx Hx HyX HzX HyP HzPcy). }
      claim HVinFam: V :e Fam.
      { prove V :e {V0 :e Tx | V0 c= P /\ path_connected_space V0 (subspace_topology X Tx V0)}.
        apply SepI.
        - exact HVTx.
        - prove V c= P /\ path_connected_space V (subspace_topology X Tx V).
          apply andI.
          * exact HVsubP.
          * exact HVpath. }
      exact (UnionI Fam y V HyV HVinFam). }
  rewrite <- HUnionEq.
  exact HUnionTx.
Qed.

(** from §25: components equal path components when locally path connected **) 
(** LATEX VERSION: In a locally path connected space, components coincide with path components. **)
Theorem components_equal_path_components : forall X Tx:set,
  locally_path_connected X Tx ->
  forall x:set, x :e X ->
    path_component_of X Tx x = component_of X Tx x.
let X Tx.
assume Hlpc: locally_path_connected X Tx.
let x.
assume Hx: x :e X.
prove path_component_of X Tx x = component_of X Tx x.
claim HTx: topology_on X Tx.
{ exact (locally_path_connected_topology X Tx Hlpc). }
claim Hlpcprop: forall x0:set, x0 :e X ->
  forall U:set, U :e Tx -> x0 :e U ->
    exists V:set, V :e Tx /\ x0 :e V /\ V c= U /\ path_connected_space V (subspace_topology X Tx V).
{ let x0. assume Hx0: x0 :e X.
  let U. assume HU: U :e Tx.
  assume Hx0U: x0 :e U.
  exact (locally_path_connected_local X Tx x0 U Hlpc Hx0 HU Hx0U). }
set P := path_component_of X Tx x.
set C := component_of X Tx x.
claim HCsubX: C c= X.
{ let y. assume Hy: y :e C.
  exact (SepE1 X (fun y0:set => exists C0:set, connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y0 :e C0) y Hy). }
claim HopenP: open_in X Tx P.
{ exact (path_components_open X Tx Hlpc x Hx). }
claim HPinTx: P :e Tx.
{ exact (open_in_elem X Tx P HopenP). }
claim HxP: x :e P.
{ exact (path_component_reflexive X Tx x HTx Hx). }
claim HxC: x :e C.
{ exact (point_in_component X Tx x HTx Hx). }
apply set_ext.
- (** P ⊆ C **)
  let y. assume HyP: y :e P.
  prove y :e C.
  claim HyX: y :e X.
  { exact (SepE1 X (fun y0:set => exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyP). }
  claim Hex: exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y.
  { exact (SepE2 X (fun y0:set => exists p:set,
     function_on p unit_interval X /\
     continuous_map unit_interval unit_interval_topology X Tx p /\
     apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyP). }
  apply Hex.
  let p. assume Hp.
  claim H01: 0 :e unit_interval /\ 1 :e unit_interval.
  { exact zero_one_in_unit_interval. }
  claim H0I: 0 :e unit_interval.
  { exact (andEL (0 :e unit_interval) (1 :e unit_interval) H01). }
  claim H1I: 1 :e unit_interval.
  { exact (andER (0 :e unit_interval) (1 :e unit_interval) H01). }
  claim Htmp: ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\ apply_fun p 0 = x) /\ apply_fun p 1 = y.
  { exact Hp. }
  claim Hp1: apply_fun p 1 = y.
  { exact (andER ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\ apply_fun p 0 = x)
                 (apply_fun p 1 = y) Htmp). }
  claim Htmp2: (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\ apply_fun p 0 = x.
  { exact (andEL ((function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p) /\ apply_fun p 0 = x)
                 (apply_fun p 1 = y) Htmp). }
  claim Hp0: apply_fun p 0 = x.
  { exact (andER (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p)
                 (apply_fun p 0 = x) Htmp2). }
  claim Hpfc: function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p.
  { exact (andEL (function_on p unit_interval X /\ continuous_map unit_interval unit_interval_topology X Tx p)
                 (apply_fun p 0 = x) Htmp2). }
  claim Hpfun: function_on p unit_interval X.
  { exact (andEL (function_on p unit_interval X) (continuous_map unit_interval unit_interval_topology X Tx p) Hpfc). }
  claim Hpcont: continuous_map unit_interval unit_interval_topology X Tx p.
  { exact (andER (function_on p unit_interval X) (continuous_map unit_interval unit_interval_topology X Tx p) Hpfc). }
  set Img := image_of p unit_interval.
  claim HimgConn: connected_space Img (subspace_topology X Tx Img).
  { exact (continuous_image_connected unit_interval unit_interval_topology X Tx p unit_interval_connected Hpcont). }
  claim HxImg: x :e Img.
  { claim Hpx: apply_fun p 0 :e Img.
    { exact (ReplI unit_interval (fun t:set => apply_fun p t) 0 H0I). }
    rewrite <- Hp0.
    exact Hpx. }
  claim HyImg: y :e Img.
  { claim Hpy: apply_fun p 1 :e Img.
    { exact (ReplI unit_interval (fun t:set => apply_fun p t) 1 H1I). }
    rewrite <- Hp1.
    exact Hpy. }
  prove y :e {y0 :e X | exists C0:set, connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y0 :e C0}.
  apply SepI.
  - exact HyX.
  - prove exists C0:set, connected_space C0 (subspace_topology X Tx C0) /\ x :e C0 /\ y :e C0.
    witness Img.
    prove connected_space Img (subspace_topology X Tx Img) /\ x :e Img /\ y :e Img.
    apply andI.
    + apply andI.
      * exact HimgConn.
      * exact HxImg.
    + exact HyImg.
- (** C ⊆ P **)
  let y. assume HyC: y :e C.
  prove y :e P.
  set Tc := subspace_topology X Tx C.
  claim HCconn: connected_space C Tc.
  { exact (component_of_connected X Tx x HTx Hx). }
  claim HtopC: topology_on C Tc.
  { exact (andEL (topology_on C Tc)
                 (~(exists U V:set, U :e Tc /\ V :e Tc /\ separation_of C U V))
                 HCconn). }
  set A := P :/\: C.
  set D := C :\: P.
  claim HA_subC: A c= C.
  { exact (binintersect_Subq_2 P C). }
  claim HAopen: open_in C Tc A.
  { claim Hiff: open_in C Tc A <-> exists V :e Tx, A = V :/\: C.
    { exact (open_in_subspace_iff X Tx C A HTx HCsubX HA_subC). }
    apply (iffER (open_in C Tc A) (exists V :e Tx, A = V :/\: C) Hiff).
    prove exists V :e Tx, A = V :/\: C.
    witness P.
    apply andI.
    - exact HPinTx.
    - reflexivity. }
  (** D is open in the subspace topology on C **)
  set UFam := {W :e Tc | W c= D}.
  claim HUFsub: UFam c= Tc.
  { let W. assume HW: W :e UFam.
    exact (SepE1 Tc (fun W0:set => W0 c= D) W HW). }
  claim HUnionTc: Union UFam :e Tc.
  { exact (topology_union_closed C Tc UFam HtopC HUFsub). }
  claim HUnionEq: Union UFam = D.
  { apply set_ext.
    - let z. assume Hz: z :e Union UFam.
      apply (UnionE UFam z Hz).
      let W. assume HexW: z :e W /\ W :e UFam.
      claim HzW: z :e W.
      { exact (andEL (z :e W) (W :e UFam) HexW). }
      claim HWUF: W :e UFam.
      { exact (andER (z :e W) (W :e UFam) HexW). }
      claim HWsubD: W c= D.
      { exact (SepE2 Tc (fun W0:set => W0 c= D) W HWUF). }
      exact (HWsubD z HzW).
    - let z. assume HzD: z :e D.
      claim HzC: z :e C.
      { exact (setminusE1 C P z HzD). }
      claim HzNotP: z /:e P.
      { exact (setminusE2 C P z HzD). }
      claim HzX: z :e X.
      { exact (HCsubX z HzC). }
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HexV: exists V:set, V :e Tx /\ z :e V /\ V c= X /\ path_connected_space V (subspace_topology X Tx V).
      { exact (Hlpcprop z HzX X HXTx HzX). }
      apply HexV.
      let V. assume HV: V :e Tx /\ z :e V /\ V c= X /\ path_connected_space V (subspace_topology X Tx V).
      claim HVpre: ((V :e Tx /\ z :e V) /\ V c= X).
      { exact (andEL ((V :e Tx /\ z :e V) /\ V c= X)
                     (path_connected_space V (subspace_topology X Tx V)) HV). }
      claim HVpath: path_connected_space V (subspace_topology X Tx V).
      { exact (andER ((V :e Tx /\ z :e V) /\ V c= X)
                     (path_connected_space V (subspace_topology X Tx V)) HV). }
      claim HVTx_z: V :e Tx /\ z :e V.
      { exact (andEL (V :e Tx /\ z :e V) (V c= X) HVpre). }
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (z :e V) HVTx_z). }
      claim HzV: z :e V.
      { exact (andER (V :e Tx) (z :e V) HVTx_z). }
      claim HVsubX: V c= X.
      { exact (andER (V :e Tx /\ z :e V) (V c= X) HVpre). }
      set W := V :/\: C.
      claim HW_Tc: W :e Tc.
      { prove W :e {U :e Power C | exists V0 :e Tx, U = V0 :/\: C}.
        apply SepI.
        - apply PowerI.
          exact (binintersect_Subq_2 V C).
        - prove exists V0 :e Tx, W = V0 :/\: C.
          witness V.
          apply andI.
          + exact HVTx.
          + reflexivity. }
      claim HzW: z :e W.
      { exact (binintersectI V C z HzV HzC). }
      claim HWsubD: W c= D.
      { let t. assume HtW: t :e W.
        apply (binintersectE V C t HtW).
        assume HtV: t :e V.
        assume HtC: t :e C.
        prove t :e D.
        prove t :e C :\: P.
        apply setminusI.
        - exact HtC.
        - assume HtP: t :e P.
          claim HzPc_t: z :e path_component_of X Tx t.
          { exact (subspace_path_connected_implies_in_path_component X Tx V t z HTx HVsubX HVpath HtV HzV). }
          claim HtX: t :e X.
          { exact (HCsubX t HtC). }
          claim HzPc_x: z :e path_component_of X Tx x.
          { exact (path_component_transitive_axiom X Tx x t z HTx Hx HtX HzX HtP HzPc_t). }
          exact (HzNotP HzPc_x). }
      claim HWUF: W :e UFam.
      { prove W :e {W0 :e Tc | W0 c= D}.
        apply SepI.
        - exact HW_Tc.
        - exact HWsubD. }
      exact (UnionI UFam z W HzW HWUF). }
  claim HD_Tc: D :e Tc.
  { rewrite <- HUnionEq.
    exact HUnionTc. }
  claim HDopen: open_in C Tc D.
  { exact (open_inI C Tc D HtopC HD_Tc). }
  claim HAeq: A = C :\: D.
  { apply set_ext.
    - let t. assume HtA: t :e A.
      apply (binintersectE P C t HtA).
      assume HtP: t :e P.
      assume HtC: t :e C.
      prove t :e C :\: D.
      apply setminusI.
      + exact HtC.
      + assume HtD: t :e D.
        claim HtNotP: t /:e P.
        { exact (setminusE2 C P t HtD). }
        exact (HtNotP HtP).
    - let t. assume HtCD: t :e C :\: D.
      claim HtC: t :e C.
      { exact (setminusE1 C D t HtCD). }
      claim HtNotD: t /:e D.
      { exact (setminusE2 C D t HtCD). }
      claim HtP: t :e P.
      { apply (xm (t :e P)).
        - assume HtP0: t :e P. exact HtP0.
        - assume HtNotP: t /:e P.
          apply FalseE.
          apply HtNotD.
          exact (setminusI C P t HtC HtNotP). }
      exact (binintersectI P C t HtP HtC). }
  claim HAclosed: closed_in C Tc A.
  { claim HDinTc: D :e Tc.
    { exact HD_Tc. }
    claim Hcl: closed_in C Tc (C :\: D).
    { exact (closed_of_open_complement C Tc D HtopC HDinTc). }
    rewrite HAeq.
    exact Hcl. }
  (** show A = C by connectedness of C and clopen property of A **)
  claim HnoClopen: ~(exists B:set, B <> Empty /\ B <> C /\ open_in C Tc B /\ closed_in C Tc B).
  { exact (iffEL (connected_space C Tc)
                 (~(exists B:set, B <> Empty /\ B <> C /\ open_in C Tc B /\ closed_in C Tc B))
                 (connected_iff_no_nontrivial_clopen C Tc HtopC) HCconn). }
  claim HAne: A <> Empty.
  { exact (elem_implies_nonempty A x (binintersectI P C x HxP HxC)). }
  claim HAeqC: A = C.
  { apply (xm (A = C)).
    - assume H. exact H.
    - assume Hneq: A <> C.
      apply FalseE.
      apply HnoClopen.
      witness A.
      prove A <> Empty /\ A <> C /\ open_in C Tc A /\ closed_in C Tc A.
      apply andI.
      - apply andI.
        + apply andI.
          * exact HAne.
          * exact Hneq.
        + exact HAopen.
      - exact HAclosed. }
  claim HyA: y :e A.
  { rewrite HAeqC.
    exact HyC. }
  apply (binintersectE P C y HyA).
  assume HyP: y :e P.
  assume HyC0: y :e C.
  exact HyP.
Qed.

(** from §25: components are closed **) 
(** LATEX VERSION: Every component is closed in X. **)
Theorem components_are_closed : forall X Tx:set,
  topology_on X Tx ->
  forall x:set, x :e X -> closed_in X Tx (component_of X Tx x).
let X Tx.
assume HTx: topology_on X Tx.
let x.
assume Hx: x :e X.
prove closed_in X Tx (component_of X Tx x).
set A := component_of X Tx x.
set B := closure_of X Tx A.
claim HBdef: B = closure_of X Tx A.
{ reflexivity. }
claim HAsub: A c= X.
{ let y. assume Hy: y :e A.
  exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy). }
claim HBsub: B c= X.
{ rewrite HBdef.
  exact (closure_in_space X Tx A HTx). }
claim HAB: A c= B.
{ rewrite HBdef.
  exact (subset_of_closure X Tx A HTx HAsub). }
claim HAconn: connected_space A (subspace_topology X Tx A).
{ exact (component_of_connected X Tx x HTx Hx). }
claim HBcl: B c= closure_of X Tx A.
{ rewrite HBdef.
  exact (Subq_ref (closure_of X Tx A)). }
claim HBconn: connected_space B (subspace_topology X Tx B).
{ exact (connected_with_limit_points X Tx A B HTx HAsub HBsub HAconn HAB HBcl). }
claim HBsubA: B c= A.
{ let y. assume Hy: y :e B.
  prove y :e A.
  prove y :e {y0 :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C}.
  apply SepI.
  - exact (HBsub y Hy).
  - prove exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
    witness B.
    prove connected_space B (subspace_topology X Tx B) /\ x :e B /\ y :e B.
    apply andI.
    + apply andI.
      * exact HBconn.
      * claim HxA: x :e A.
        { exact (point_in_component X Tx x HTx Hx). }
        exact (HAB x HxA).
    + exact Hy. }
claim Heq: B = A.
{ apply set_ext.
  - let y. assume Hy: y :e B.
    exact (HBsubA y Hy).
  - let y. assume Hy: y :e A.
    exact (HAB y Hy). }
claim HBclosed0: closed_in X Tx (closure_of X Tx A).
{ exact (closure_is_closed X Tx A HTx HAsub). }
claim HBclosed: closed_in X Tx B.
{ rewrite <- HBdef.
  exact HBclosed0. }
claim HAclosed: closed_in X Tx A.
{ rewrite <- Heq.
  exact HBclosed. }
exact HAclosed.
Qed.

(** from §25: components are open in locally connected spaces **) 
(** LATEX VERSION: In a locally connected space, every component is open. **)
Theorem components_are_open_in_locally_connected : forall X Tx:set,
  locally_connected X Tx ->
  forall x:set, x :e X -> open_in X Tx (component_of X Tx x).
let X Tx.
assume Hloc: locally_connected X Tx.
let x.
assume HxX: x :e X.
prove open_in X Tx (component_of X Tx x).
prove topology_on X Tx /\ component_of X Tx x :e Tx.
claim HTx: topology_on X Tx.
{ exact (locally_connected_topology X Tx Hloc). }
claim Hlocprop: forall y:set, y :e X ->
  forall U:set, U :e Tx -> y :e U ->
    exists V:set, V :e Tx /\ y :e V /\ V c= U /\ connected_space V (subspace_topology X Tx V).
{ let y. assume Hy: y :e X.
  let U. assume HU: U :e Tx.
  assume HyU: y :e U.
  exact (locally_connected_local X Tx y U Hloc Hy HU HyU). }
apply andI.
- exact HTx.
- set Comp := component_of X Tx x.
  set UFam := {V :e Tx | V c= Comp /\ connected_space V (subspace_topology X Tx V)}.
  claim HUFsub: UFam c= Tx.
  { let V. assume HV: V :e UFam.
    exact (SepE1 Tx (fun V0:set => V0 c= Comp /\ connected_space V0 (subspace_topology X Tx V0)) V HV). }
  claim HUnionTx: Union UFam :e Tx.
  { exact (topology_union_closed X Tx UFam HTx HUFsub). }
  claim HUnionEq: Union UFam = Comp.
  { apply set_ext.
    - let y. assume Hy: y :e Union UFam.
      apply (UnionE UFam y Hy).
      let V. assume Hex: y :e V /\ V :e UFam.
      claim HyV: y :e V.
      { exact (andEL (y :e V) (V :e UFam) Hex). }
      claim HVUF: V :e UFam.
      { exact (andER (y :e V) (V :e UFam) Hex). }
      claim HVpair: V c= Comp /\ connected_space V (subspace_topology X Tx V).
      { exact (SepE2 Tx (fun V0:set => V0 c= Comp /\ connected_space V0 (subspace_topology X Tx V0)) V HVUF). }
      claim HVsubComp: V c= Comp.
      { exact (andEL (V c= Comp) (connected_space V (subspace_topology X Tx V)) HVpair). }
      exact (HVsubComp y HyV).
    - let y. assume Hy: y :e Comp.
      claim HyX: y :e X.
      { exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy). }
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HexV: exists V:set, V :e Tx /\ y :e V /\ V c= X /\ connected_space V (subspace_topology X Tx V).
      { exact (Hlocprop y HyX X HXTx HyX). }
      apply HexV.
      let V. assume HV: V :e Tx /\ y :e V /\ V c= X /\ connected_space V (subspace_topology X Tx V).
      claim HVpre: ((V :e Tx /\ y :e V) /\ V c= X).
      { exact (andEL ((V :e Tx /\ y :e V) /\ V c= X)
                     (connected_space V (subspace_topology X Tx V)) HV). }
      claim HVconn: connected_space V (subspace_topology X Tx V).
      { exact (andER ((V :e Tx /\ y :e V) /\ V c= X)
                     (connected_space V (subspace_topology X Tx V)) HV). }
      claim HVTx_y: V :e Tx /\ y :e V.
      { exact (andEL (V :e Tx /\ y :e V) (V c= X) HVpre). }
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (y :e V) HVTx_y). }
      claim HyV: y :e V.
      { exact (andER (V :e Tx) (y :e V) HVTx_y). }
      claim HVsubX: V c= X.
      { exact (andER (V :e Tx /\ y :e V) (V c= X) HVpre). }
      claim HcompEq: component_of X Tx y = component_of X Tx x.
      { exact (component_of_eq_if_in X Tx x y HTx HxX Hy). }
      claim HVsubComp: V c= Comp.
      { let z. assume HzV: z :e V.
        prove z :e Comp.
        claim HzX: z :e X.
        { exact (HVsubX z HzV). }
        claim HzCompy: z :e component_of X Tx y.
        { prove z :e {y0 :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ y :e C /\ y0 :e C}.
          apply SepI.
          - exact HzX.
          - prove exists C:set, connected_space C (subspace_topology X Tx C) /\ y :e C /\ z :e C.
            witness V.
            prove connected_space V (subspace_topology X Tx V) /\ y :e V /\ z :e V.
            apply andI.
            + apply andI.
              * exact HVconn.
              * exact HyV.
            + exact HzV. }
        rewrite <- HcompEq.
        exact HzCompy. }
      claim HVinUFam: V :e UFam.
      { prove V :e {V0 :e Tx | V0 c= Comp /\ connected_space V0 (subspace_topology X Tx V0)}.
        apply SepI.
        - exact HVTx.
        - prove V c= Comp /\ connected_space V (subspace_topology X Tx V).
          apply andI.
          * exact HVsubComp.
          * exact HVconn. }
      exact (UnionI UFam y V HyV HVinUFam). }
  claim HCompTx: Comp :e Tx.
  { rewrite <- HUnionEq.
    exact HUnionTx. }
  exact HCompTx.
Qed.

(** from §25: components partition the space **) 
(** LATEX VERSION: Components cover X and are pairwise disjoint. **)
Theorem components_partition_space : forall X Tx:set,
  topology_on X Tx ->
  covers X {component_of X Tx x | x :e X} /\
  pairwise_disjoint {component_of X Tx x | x :e X}.
let X Tx.
assume HTx: topology_on X Tx.
prove covers X {component_of X Tx x | x :e X} /\ pairwise_disjoint {component_of X Tx x | x :e X}.
apply andI.
- (** covers X by components **)
  let x. assume HxX: x :e X.
  witness (component_of X Tx x).
  prove component_of X Tx x :e {component_of X Tx x0|x0 :e X} /\ x :e component_of X Tx x.
  apply andI.
  - exact (ReplI X (fun x0:set => component_of X Tx x0) x HxX).
  - (** x lies in its own component (use singleton {x} as connected subspace) **)
    prove x :e component_of X Tx x.
    prove x :e {y :e X | exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C}.
    apply SepI.
    - exact HxX.
    - prove exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ x :e C.
      witness {x}.
      prove connected_space {x} (subspace_topology X Tx {x}) /\ x :e {x} /\ x :e {x}.
      apply andI.
      + apply andI.
        * exact (singleton_subspace_connected X Tx x HTx HxX).
        * exact (SingI x).
      + exact (SingI x).
- (** pairwise disjointness of distinct components **)
  let U V.
  assume HU: U :e {component_of X Tx x | x :e X}.
  assume HV: V :e {component_of X Tx x | x :e X}.
  assume Hneq: U <> V.
  prove U :/\: V = Empty.
  (** represent U and V as components of points in X **)
  apply (ReplE_impred X (fun x0:set => component_of X Tx x0) U HU).
  let x1. assume Hx1X: x1 :e X.
  assume HUeq: U = component_of X Tx x1.
  apply (ReplE_impred X (fun x0:set => component_of X Tx x0) V HV).
  let x2. assume Hx2X: x2 :e X.
  assume HVeql: V = component_of X Tx x2.
  (** show intersection must be empty, else equality would follow **)
  apply Empty_eq.
  let z. assume Hz: z :e U :/\: V.
  apply (binintersectE U V z Hz).
  assume HzU: z :e U.
  assume HzV: z :e V.
  claim HzComp1: z :e component_of X Tx x1.
  { rewrite <- HUeq. exact HzU. }
  claim HzComp2: z :e component_of X Tx x2.
  { rewrite <- HVeql. exact HzV. }
  (** z lies in X by definition of component_of **)
  claim HzX: z :e X.
  { exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x1 :e C /\ y0 :e C) z HzComp1). }
  (** component(z) = component(x1) and component(z) = component(x2) **)
  claim Heq1: component_of X Tx z = component_of X Tx x1.
  { exact (component_of_eq_if_in X Tx x1 z HTx Hx1X HzComp1). }
  claim Heq2: component_of X Tx z = component_of X Tx x2.
  { exact (component_of_eq_if_in X Tx x2 z HTx Hx2X HzComp2). }
  claim HcompEq: component_of X Tx x1 = component_of X Tx x2.
  { rewrite <- Heq1.
    rewrite Heq2.
    reflexivity. }
  claim HUVeq: U = V.
  { rewrite HUeq.
    rewrite HVeql.
    exact HcompEq. }
  apply FalseE.
  exact (Hneq HUVeq).
Qed.

(** from §25: quotient of locally connected space is locally connected **) 
(** LATEX VERSION: Quotients of locally connected spaces remain locally connected. **)
Theorem quotient_preserves_local_connectedness : forall X Tx Y f:set,
  quotient_map X Tx Y f ->
  locally_connected X Tx ->
  locally_connected Y (quotient_topology X Tx Y f).
let X Tx Y f.
assume Hquot: quotient_map X Tx Y f.
assume Hloc: locally_connected X Tx.
prove locally_connected Y (quotient_topology X Tx Y f).
set Q := quotient_topology X Tx Y f.
claim HTx: topology_on X Tx.
{ exact (locally_connected_topology X Tx Hloc). }
claim HTyQ: topology_on Y Q.
{ exact (quotient_topology_is_topology X Tx Y f HTx Hquot). }
claim Hfun: function_on f X Y.
{ exact (andER (topology_on X Tx) (function_on f X Y)
               (andEL (topology_on X Tx /\ function_on f X Y)
                      (forall y0:set, y0 :e Y -> exists x:set, x :e X /\ apply_fun f x = y0)
                      Hquot)). }
claim Hsurj: forall y0:set, y0 :e Y -> exists x:set, x :e X /\ apply_fun f x = y0.
{ exact (andER (topology_on X Tx /\ function_on f X Y)
               (forall y0:set, y0 :e Y -> exists x:set, x :e X /\ apply_fun f x = y0)
               Hquot). }
claim Hcont: continuous_map X Tx Y Q f.
{ prove topology_on X Tx /\ topology_on Y Q /\ function_on f X Y /\
    forall W:set, W :e Q -> preimage_of X f W :e Tx.
  apply andI.
  - apply andI.
    + apply andI.
      * exact HTx.
      * exact HTyQ.
    + exact Hfun.
  - let W. assume HW: W :e Q.
    claim Hraw: {x0 :e X|apply_fun f x0 :e W} :e Tx.
    { exact (SepE2 (Power Y) (fun V0:set => {x0 :e X|apply_fun f x0 :e V0} :e Tx) W HW). }
    claim Heq: preimage_of X f W = {x0 :e X|apply_fun f x0 :e W}.
    { reflexivity. }
    rewrite Heq.
    exact Hraw. }

prove topology_on Y Q /\
  forall y:set, y :e Y ->
    forall U:set, U :e Q -> y :e U ->
      exists V:set, V :e Q /\ y :e V /\ V c= U /\ connected_space V (subspace_topology Y Q V).
apply andI.
- exact HTyQ.
- let y. assume HyY: y :e Y.
  let U. assume HU: U :e Q.
  assume HyU: y :e U.

  claim HUpowY: U :e Power Y.
  { exact (SepE1 (Power Y) (fun V0:set => preimage_of X f V0 :e Tx) U HU). }
  claim HUsubY: U c= Y.
  { exact (PowerE Y U HUpowY). }
  set Tu := subspace_topology Y Q U.
  claim HTu: topology_on U Tu.
  { exact (subspace_topology_is_topology Y Q U HTyQ HUsubY). }

  (** Let V be the component of y in the open set U (as a subspace). **)
  set V := component_of U Tu y.
  claim HyV: y :e V.
  { exact (point_in_component U Tu y HTu HyU). }
  claim HVsubU: V c= U.
  { let t. assume Ht: t :e V.
    exact (SepE1 U (fun t0:set => exists C:set, connected_space C (subspace_topology U Tu C) /\ y :e C /\ t0 :e C) t Ht). }
  claim HVsubY: V c= Y.
  { exact (Subq_tra V U Y HVsubU HUsubY). }

  (** V is connected in the ambient subspace topology on Y. **)
  claim HconnVu: connected_space V (subspace_topology U Tu V).
  { exact (component_of_connected U Tu y HTu HyU). }
  claim HeqTopV: subspace_topology U Tu V = subspace_topology Y Q V.
  { exact (ex16_1_subspace_transitive Y Q U V HTyQ HUsubY HVsubU). }
  claim HconnV: connected_space V (subspace_topology Y Q V).
  { rewrite <- HeqTopV.
    exact HconnVu. }

  (** Show V is open in the quotient topology by proving its preimage is open in Tx. **)
  set preU := preimage_of X f U.
  claim HpreU: preU :e Tx.
  { claim Hraw: {x0 :e X|apply_fun f x0 :e U} :e Tx.
    { exact (SepE2 (Power Y) (fun V0:set => {x0 :e X|apply_fun f x0 :e V0} :e Tx) U HU). }
    claim Heq: preU = {x0 :e X|apply_fun f x0 :e U}.
    { reflexivity. }
    rewrite Heq.
    exact Hraw. }

  set preV := preimage_of X f V.
  set UFam := {W :e Tx | W c= preV /\ connected_space W (subspace_topology X Tx W)}.
  claim HUFsub: UFam c= Tx.
  { let W. assume HW: W :e UFam.
    exact (SepE1 Tx (fun W0:set => W0 c= preV /\ connected_space W0 (subspace_topology X Tx W0)) W HW). }
  claim HUnionTx: Union UFam :e Tx.
  { exact (topology_union_closed X Tx UFam HTx HUFsub). }
  claim HUnionEq: Union UFam = preV.
  { apply set_ext.
    - let x0. assume Hx0: x0 :e Union UFam.
      apply (UnionE UFam x0 Hx0).
      let W. assume Hx0W: x0 :e W /\ W :e UFam.
      claim Hx0W0: x0 :e W.
      { exact (andEL (x0 :e W) (W :e UFam) Hx0W). }
      claim HWUF: W :e UFam.
      { exact (andER (x0 :e W) (W :e UFam) Hx0W). }
      claim HWprop: W c= preV /\ connected_space W (subspace_topology X Tx W).
      { exact (SepE2 Tx (fun W0:set => W0 c= preV /\ connected_space W0 (subspace_topology X Tx W0)) W HWUF). }
      claim HWsub: W c= preV.
      { exact (andEL (W c= preV) (connected_space W (subspace_topology X Tx W)) HWprop). }
      exact (HWsub x0 Hx0W0).
    - let x0. assume Hx0: x0 :e preV.
      (** Extract y0 = f(x0) ∈ V, and use local connectedness in the open set preU. **)
      claim Hx0X: x0 :e X.
      { exact (SepE1 X (fun x1:set => apply_fun f x1 :e V) x0 Hx0). }
      claim Hy0V: apply_fun f x0 :e V.
      { exact (SepE2 X (fun x1:set => apply_fun f x1 :e V) x0 Hx0). }
      claim Hy0U: apply_fun f x0 :e U.
      { exact (HVsubU (apply_fun f x0) Hy0V). }
      claim Hx0preU: x0 :e preU.
      { claim Heq: preU = {x1 :e X|apply_fun f x1 :e U}.
        { reflexivity. }
        rewrite Heq.
        exact (SepI X (fun x1:set => apply_fun f x1 :e U) x0 Hx0X Hy0U). }

      apply (locally_connected_local X Tx x0 preU Hloc Hx0X HpreU Hx0preU).
      let W0. assume HW0pack: W0 :e Tx /\ x0 :e W0 /\ W0 c= preU /\ connected_space W0 (subspace_topology X Tx W0).

      claim HW0pair: (W0 :e Tx /\ x0 :e W0) /\ W0 c= preU.
      { exact (andEL ((W0 :e Tx /\ x0 :e W0) /\ W0 c= preU)
                     (connected_space W0 (subspace_topology X Tx W0))
                     HW0pack). }
      claim HW0Tx: W0 :e Tx.
      { exact (andEL (W0 :e Tx) (x0 :e W0)
                     (andEL (W0 :e Tx /\ x0 :e W0) (W0 c= preU) HW0pair)). }
      claim Hx0W0: x0 :e W0.
      { exact (andER (W0 :e Tx) (x0 :e W0)
                     (andEL (W0 :e Tx /\ x0 :e W0) (W0 c= preU) HW0pair)). }
      claim HW0subpreU: W0 c= preU.
      { exact (andER (W0 :e Tx /\ x0 :e W0) (W0 c= preU) HW0pair). }
      claim HW0conn: connected_space W0 (subspace_topology X Tx W0).
      { exact (andER ((W0 :e Tx /\ x0 :e W0) /\ W0 c= preU)
                     (connected_space W0 (subspace_topology X Tx W0))
                     HW0pack). }

      (** Show W0 ⊆ preV by showing f[W0] ⊆ V. **)
      set ImW0 := image_of f W0.
      claim HImSubU: ImW0 c= U.
      { let y1. assume Hy1: y1 :e ImW0.
        apply (ReplE_impred W0 (fun z:set => apply_fun f z) y1 Hy1).
        let z. assume HzW0: z :e W0.
        assume Hy1eq: y1 = apply_fun f z.
        claim HzpreU: z :e preU.
        { exact (HW0subpreU z HzW0). }
        claim HfzU: apply_fun f z :e U.
        { exact (SepE2 X (fun u0:set => apply_fun f u0 :e U) z HzpreU). }
        rewrite Hy1eq.
        exact HfzU. }

      claim HcontW0: continuous_map W0 (subspace_topology X Tx W0) Y Q f.
      { claim HW0subX: W0 c= X.
        { exact (topology_elem_subset X Tx W0 HTx HW0Tx). }
        exact (continuous_on_subspace_rule X Tx Y Q f W0 HTx HTyQ HW0subX Hcont). }
      claim HImConnY: connected_space ImW0 (subspace_topology Y Q ImW0).
      { exact (continuous_image_connected W0 (subspace_topology X Tx W0) Y Q f HW0conn HcontW0). }
      claim HeqTopIm: subspace_topology U Tu ImW0 = subspace_topology Y Q ImW0.
      { exact (ex16_1_subspace_transitive Y Q U ImW0 HTyQ HUsubY HImSubU). }
      claim HImConnU: connected_space ImW0 (subspace_topology U Tu ImW0).
      { rewrite HeqTopIm.
        exact HImConnY. }

      claim Hy0Im: apply_fun f x0 :e ImW0.
      { exact (ReplI W0 (fun z:set => apply_fun f z) x0 Hx0W0). }

      claim HImSubComp: ImW0 c= component_of U Tu (apply_fun f x0).
      { let y1. assume Hy1: y1 :e ImW0.
        prove y1 :e component_of U Tu (apply_fun f x0).
        prove y1 :e {t :e U | exists C:set, connected_space C (subspace_topology U Tu C) /\ apply_fun f x0 :e C /\ t :e C}.
        apply SepI.
        - exact (HImSubU y1 Hy1).
        - prove exists C:set, connected_space C (subspace_topology U Tu C) /\ apply_fun f x0 :e C /\ y1 :e C.
          witness ImW0.
          prove connected_space ImW0 (subspace_topology U Tu ImW0) /\ apply_fun f x0 :e ImW0 /\ y1 :e ImW0.
          apply andI.
          + apply andI.
            * exact HImConnU.
            * exact Hy0Im.
          + exact Hy1. }

      (** Since y0 ∈ V (the component of y in U), component(y0) = V. **)
      claim Hy0U0: apply_fun f x0 :e U.
      { exact Hy0U. }
      claim HeqComp: component_of U Tu (apply_fun f x0) = V.
      { claim HVdef: V = component_of U Tu y.
        { reflexivity. }
        claim Hy0Comp: apply_fun f x0 :e component_of U Tu y.
        { rewrite <- HVdef.
          exact Hy0V. }
        rewrite HVdef.
        exact (component_of_eq_if_in U Tu y (apply_fun f x0) HTu HyU Hy0Comp). }
      claim HImSubV: ImW0 c= V.
      { rewrite <- HeqComp.
        exact HImSubComp. }

      claim HW0subpreV: W0 c= preV.
      { let z. assume Hz: z :e W0.
        prove z :e preV.
        claim HfzV: apply_fun f z :e V.
        { claim HfzIm: apply_fun f z :e ImW0.
          { exact (ReplI W0 (fun t:set => apply_fun f t) z Hz). }
          exact (HImSubV (apply_fun f z) HfzIm). }
        exact (SepI X (fun x1:set => apply_fun f x1 :e V) z
                    (topology_elem_subset X Tx W0 HTx HW0Tx z Hz)
                    HfzV). }

      claim HW0inUFam: W0 :e UFam.
      { apply SepI.
        - exact HW0Tx.
        - prove W0 c= preV /\ connected_space W0 (subspace_topology X Tx W0).
          apply andI.
          + exact HW0subpreV.
          + exact HW0conn. }
      exact (UnionI UFam x0 W0 Hx0W0 HW0inUFam). }
  claim HpreV: preV :e Tx.
  { rewrite <- HUnionEq.
    exact HUnionTx. }
  claim HVpowY: V :e Power Y.
  { apply PowerI.
    let y0. assume Hy0: y0 :e V.
    exact (HVsubY y0 Hy0). }
  claim HVQ: V :e Q.
  { exact (SepI (Power Y) (fun V0:set => preimage_of X f V0 :e Tx) V HVpowY HpreV). }

  witness V.
  prove V :e Q /\ y :e V /\ V c= U /\ connected_space V (subspace_topology Y Q V).
  apply andI.
  - apply andI.
    + apply andI.
      * exact HVQ.
      * exact HyV.
    + exact HVsubU.
  - exact HconnV.
Qed.

(** from §25 Definition: quasicomponent equivalence relation **) 
(** LATEX VERSION: The quasicomponent of x consists of points that cannot be separated from x by a clopen set. **)
Definition quasicomponent_of : set -> set -> set -> set := fun X Tx x =>
  {y :e X | forall U:set, open_in X Tx U -> closed_in X Tx U -> x :e U -> y :e U}.

(** from §25: components vs quasicomponents **) 
(** LATEX VERSION: Components are contained in quasicomponents; in locally connected spaces they are equal. **)
Theorem components_vs_quasicomponents : forall X Tx:set,
  topology_on X Tx ->
  (forall x:set, component_of X Tx x c= quasicomponent_of X Tx x) /\
  (locally_connected X Tx -> forall x:set, x :e X -> component_of X Tx x = quasicomponent_of X Tx x).
let X Tx.
assume HTx: topology_on X Tx.
prove (forall x:set, component_of X Tx x c= quasicomponent_of X Tx x) /\
  (locally_connected X Tx -> forall x:set, x :e X -> component_of X Tx x = quasicomponent_of X Tx x).
claim Hsub: forall x:set, component_of X Tx x c= quasicomponent_of X Tx x.
{ let x.
  prove component_of X Tx x c= quasicomponent_of X Tx x.
  let y. assume Hy: y :e component_of X Tx x.
  prove y :e quasicomponent_of X Tx x.
  prove y :e {y0 :e X | forall U:set, open_in X Tx U -> closed_in X Tx U -> x :e U -> y0 :e U}.
  apply SepI.
  - exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy).
  - let U.
    assume HUopen: open_in X Tx U.
    assume HUclosed: closed_in X Tx U.
    assume HxU: x :e U.
    prove y :e U.
    apply (xm (U = X)).
    + assume HUeqX: U = X.
      rewrite HUeqX.
      exact (SepE1 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy).
    + assume HUnX: U <> X.
      claim HUsubX: U c= X.
      { exact (open_in_subset X Tx U HUopen). }
      claim HUne: U <> Empty.
      { exact (elem_implies_nonempty U x HxU). }
      claim HsepUX: separation_of X U (X :\: U).
      { exact (separation_of_complement X U HUsubX HUne HUnX). }
      claim HUinTx: U :e Tx.
      { exact (andER (topology_on X Tx) (U :e Tx) HUopen). }
      claim HcompOpen: open_in X Tx (X :\: U).
      { exact (open_of_closed_complement X Tx U HUclosed). }
      claim HcompinTx: (X :\: U) :e Tx.
      { exact (andER (topology_on X Tx) ((X :\: U) :e Tx) HcompOpen). }
      claim HexC: exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y :e C.
      { exact (SepE2 X (fun y0:set => exists C:set, connected_space C (subspace_topology X Tx C) /\ x :e C /\ y0 :e C) y Hy). }
      apply HexC.
      let C. assume HC.
      claim HCconn: connected_space C (subspace_topology X Tx C).
      { exact (andEL (connected_space C (subspace_topology X Tx C))
                     (x :e C) (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
      claim HxC: x :e C.
      { exact (andER (connected_space C (subspace_topology X Tx C)) (x :e C)
                     (andEL (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC)). }
      claim HyC: y :e C.
      { exact (andER (connected_space C (subspace_topology X Tx C) /\ x :e C) (y :e C) HC). }
      claim HCsubX: C c= X.
      { exact (connected_subspace_subset X Tx C HTx HCconn). }
      claim Hside: C c= U \/ C c= (X :\: U).
      { exact (connected_subset_in_separation_side X Tx U (X :\: U) C HTx HCsubX HCconn HUinTx HcompinTx HsepUX). }
      apply (Hside (y :e U)).
      - assume HCsubU: C c= U.
        exact (HCsubU y HyC).
      - assume HCsubComp: C c= (X :\: U).
        claim HxComp: x :e X :\: U.
        { exact (HCsubComp x HxC). }
        claim HxNotU: x /:e U.
        { exact (setminusE2 X U x HxComp). }
        apply FalseE.
        exact (HxNotU HxU). }
claim Heq: locally_connected X Tx -> forall x:set, x :e X -> component_of X Tx x = quasicomponent_of X Tx x.
{ assume Hloc: locally_connected X Tx.
  let x. assume HxX: x :e X.
  prove component_of X Tx x = quasicomponent_of X Tx x.
  apply set_ext.
  - let y. assume Hy: y :e component_of X Tx x.
    exact (Hsub x y Hy).
  - let y. assume HyQ: y :e quasicomponent_of X Tx x.
    prove y :e component_of X Tx x.
    claim HUopen: open_in X Tx (component_of X Tx x).
    { exact (components_are_open_in_locally_connected X Tx Hloc x HxX). }
    claim HUclosed: closed_in X Tx (component_of X Tx x).
    { exact (components_are_closed X Tx HTx x HxX). }
    claim HxU: x :e component_of X Tx x.
    { exact (point_in_component X Tx x HTx HxX). }
    claim Hprop: forall U:set, open_in X Tx U -> closed_in X Tx U -> x :e U -> y :e U.
    { exact (SepE2 X (fun y0:set => forall U:set, open_in X Tx U -> closed_in X Tx U -> x :e U -> y0 :e U) y HyQ). }
    exact (Hprop (component_of X Tx x) HUopen HUclosed HxU). }
apply andI.
- exact Hsub.
- exact Heq.
Qed.

(** from §23 Exercise: components and path components of ℝℓ **) 
(** LATEX VERSION: In the lower limit topology on R, every component is a singleton. **)
(** Helper for §23 Exercise: the right closed ray [a,∞) is open in R_l **)
Theorem right_closed_ray_in_R_lower_limit_topology : forall a:set, a :e R ->
  {x :e R|~(Rlt x a)} :e R_lower_limit_topology.
let a. assume HaR: a :e R.
set U := {x :e R|~(Rlt x a)}.
prove U :e R_lower_limit_topology.
prove U :e generated_topology R R_lower_limit_basis.
claim HUsub: U c= R.
{ let x. assume HxU: x :e U.
  exact (SepE1 R (fun x0:set => ~(Rlt x0 a)) x HxU). }
claim HUpow: U :e Power R.
{ exact (PowerI R U HUsub). }
claim HUprop: forall x0 :e U, exists b :e R_lower_limit_basis, x0 :e b /\ b c= U.
{ let x. assume HxU: x :e U.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => ~(Rlt x0 a)) x HxU). }
  claim HxNotLtA: ~(Rlt x a).
  { exact (SepE2 R (fun x0:set => ~(Rlt x0 a)) x HxU). }
  claim Hax: Rle a x.
  { exact (RleI a x HaR HxR HxNotLtA). }
  claim Hx1R: (add_SNo x 1) :e R.
  { exact (real_add_SNo x HxR 1 real_1). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim H0S: SNo 0.
  { exact (real_SNo 0 real_0). }
  claim H1S: SNo 1.
  { exact (real_SNo 1 real_1). }
  claim Hx0lt: add_SNo x 0 < add_SNo x 1.
  { exact (add_SNo_Lt2 x 0 1 HxS H0S H1S SNoLt_0_1). }
  claim Hx0eq: add_SNo x 0 = x.
  { exact (add_SNo_0R x HxS). }
  claim Hxlt: x < add_SNo x 1.
  { rewrite <- Hx0eq at 1.
    exact Hx0lt. }
  claim HxRlt: Rlt x (add_SNo x 1).
  { exact (RltI x (add_SNo x 1) HxR Hx1R Hxlt). }
  witness (halfopen_interval_left x (add_SNo x 1)).
  apply andI.
  - prove halfopen_interval_left x (add_SNo x 1) :e R_lower_limit_basis.
    apply (famunionI R (fun aa:set => {halfopen_interval_left aa bb|bb :e R})
                    x
                    (halfopen_interval_left x (add_SNo x 1))
                    HxR).
    prove halfopen_interval_left x (add_SNo x 1) :e {halfopen_interval_left x bb|bb :e R}.
    exact (ReplI R (fun bb:set => halfopen_interval_left x bb) (add_SNo x 1) Hx1R).
  - apply andI.
    + prove x :e halfopen_interval_left x (add_SNo x 1).
      exact (halfopen_interval_left_leftmem x (add_SNo x 1) HxRlt).
    + prove halfopen_interval_left x (add_SNo x 1) c= U.
      let t. assume HtB: t :e halfopen_interval_left x (add_SNo x 1).
      prove t :e U.
      claim HtR: t :e R.
      { exact (SepE1 R (fun z:set => ~(Rlt z x) /\ Rlt z (add_SNo x 1)) t HtB). }
      claim HtProp: ~(Rlt t x) /\ Rlt t (add_SNo x 1).
      { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z (add_SNo x 1)) t HtB). }
      claim HtNotLtX: ~(Rlt t x).
      { exact (andEL (~(Rlt t x)) (Rlt t (add_SNo x 1)) HtProp). }
      prove t :e {x0 :e R|~(Rlt x0 a)}.
      apply (SepI R (fun x0:set => ~(Rlt x0 a)) t HtR).
      assume HtLtA: Rlt t a.
      claim HtLtX: Rlt t x.
      { exact (Rlt_Rle_tra t a x HtLtA Hax). }
      exact (HtNotLtX HtLtX). }
exact (SepI (Power R)
            (fun U0:set => forall x0 :e U0, exists b :e R_lower_limit_basis, x0 :e b /\ b c= U0)
            U
            HUpow
            HUprop).
Qed.

(** Helper for §23 Exercise: complement of [a,b) is union of a left open ray and a right closed ray **)
Theorem halfopen_interval_left_complement_eq_rays : forall a b:set,
  a :e R -> b :e R ->
  R :\: (halfopen_interval_left a b) =
    {x :e R|Rlt x a} :\/: {x :e R|~(Rlt x b)}.
let a b. assume HaR: a :e R. assume HbR: b :e R.
apply set_ext.
- let x. assume Hx: x :e R :\: halfopen_interval_left a b.
  prove x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|~(Rlt x0 b)}.
  claim Hpair: x :e R /\ x /:e halfopen_interval_left a b.
  { exact (setminusE R (halfopen_interval_left a b) x Hx). }
  claim HxR: x :e R.
  { exact (andEL (x :e R) (x /:e halfopen_interval_left a b) Hpair). }
  claim HxNotI: x /:e halfopen_interval_left a b.
  { exact (andER (x :e R) (x /:e halfopen_interval_left a b) Hpair). }
  apply (xm (Rlt x a)).
  * assume Hxa: Rlt x a.
    apply binunionI1.
    exact (SepI R (fun x0:set => Rlt x0 a) x HxR Hxa).
  * assume Hnxa: ~(Rlt x a).
    apply (xm (Rlt x b)).
    { assume Hxb: Rlt x b.
      claim HxinI: x :e halfopen_interval_left a b.
      { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) x HxR (andI (~(Rlt x a)) (Rlt x b) Hnxa Hxb)). }
      apply FalseE.
      exact (HxNotI HxinI). }
    { assume Hnxb: ~(Rlt x b).
      apply binunionI2.
      exact (SepI R (fun x0:set => ~(Rlt x0 b)) x HxR Hnxb). }
- let x. assume Hx: x :e {x0 :e R|Rlt x0 a} :\/: {x0 :e R|~(Rlt x0 b)}.
  prove x :e R :\: halfopen_interval_left a b.
  apply (binunionE {x0 :e R|Rlt x0 a} {x0 :e R|~(Rlt x0 b)} x Hx).
  * assume HxL: x :e {x0 :e R|Rlt x0 a}.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0:set => Rlt x0 a) x HxL). }
    claim Hxa: Rlt x a.
    { exact (SepE2 R (fun x0:set => Rlt x0 a) x HxL). }
    prove x :e R :\: halfopen_interval_left a b.
    apply (setminusI R (halfopen_interval_left a b) x HxR).
    assume HxinI: x :e halfopen_interval_left a b.
    claim Hprop: ~(Rlt x a) /\ Rlt x b.
    { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) x HxinI). }
    claim Hnxa: ~(Rlt x a).
    { exact (andEL (~(Rlt x a)) (Rlt x b) Hprop). }
    exact (Hnxa Hxa).
  * assume HxRr: x :e {x0 :e R|~(Rlt x0 b)}.
    claim HxR: x :e R.
    { exact (SepE1 R (fun x0:set => ~(Rlt x0 b)) x HxRr). }
    claim Hnxb: ~(Rlt x b).
    { exact (SepE2 R (fun x0:set => ~(Rlt x0 b)) x HxRr). }
    prove x :e R :\: halfopen_interval_left a b.
    apply (setminusI R (halfopen_interval_left a b) x HxR).
    assume HxinI: x :e halfopen_interval_left a b.
    claim Hprop: ~(Rlt x a) /\ Rlt x b.
    { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) x HxinI). }
    claim Hxb: Rlt x b.
    { exact (andER (~(Rlt x a)) (Rlt x b) Hprop). }
    exact (Hnxb Hxb).
Qed.

(** Helper for §23 Exercise: complements of half-open intervals lie in R_l **)
Theorem complement_halfopen_interval_left_in_R_lower_limit_topology : forall a b:set,
  a :e R -> b :e R -> (R :\: halfopen_interval_left a b) :e R_lower_limit_topology.
let a b. assume HaR: a :e R. assume HbR: b :e R.
claim HTl: topology_on R R_lower_limit_topology.
{ exact R_lower_limit_topology_is_topology. }
set L := {x :e R|Rlt x a}.
set Rr := {x :e R|~(Rlt x b)}.
claim HLstd: L :e R_standard_topology.
{ exact (open_left_ray_in_R_standard_topology a HaR). }
claim Hf: R_standard_topology c= R_lower_limit_topology.
{ exact R_lower_limit_finer_than_R_standard. }
claim HL: L :e R_lower_limit_topology.
{ exact (Hf L HLstd). }
claim HRr: Rr :e R_lower_limit_topology.
{ exact (right_closed_ray_in_R_lower_limit_topology b HbR). }
claim Hunion: L :\/: Rr :e R_lower_limit_topology.
{ exact (topology_binunion_closed R R_lower_limit_topology L Rr HTl HL HRr). }
claim Heq: R :\: halfopen_interval_left a b = L :\/: Rr.
{ exact (halfopen_interval_left_complement_eq_rays a b HaR HbR). }
rewrite Heq.
exact Hunion.
Qed.

Theorem ex23_Rl_components :
  component_of R R_lower_limit_topology 0 = {0} /\
  (forall x:set, x :e R -> component_of R R_lower_limit_topology x = {x}).
prove component_of R R_lower_limit_topology 0 = {0} /\ (forall x:set, x :e R -> component_of R R_lower_limit_topology x = {x}).
claim Hall: forall x:set, x :e R -> component_of R R_lower_limit_topology x = {x}.
{ let x. assume HxR: x :e R.
  apply set_ext.
  - let y. assume Hy: y :e component_of R R_lower_limit_topology x.
    prove y :e {x}.
    claim HyR: y :e R.
    { exact (SepE1 R (fun y0:set => exists C:set, connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C /\ y0 :e C) y Hy). }
    claim HyS: SNo y.
    { exact (real_SNo y HyR). }
    claim HxS: SNo x.
    { exact (real_SNo x HxR). }
    claim HyProp: exists C:set, connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C /\ y :e C.
    { exact (SepE2 R (fun y0:set => exists C:set, connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C /\ y0 :e C) y Hy). }
    apply (SNoLt_trichotomy_or_impred y x HyS HxS (y :e {x})).
    - assume Hylt: y < x.
	      apply HyProp.
	      let C. assume HC.
	      claim HCcore: connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C.
	      { exact (andEL (connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C) (y :e C) HC). }
	      claim HyC: y :e C.
	      { exact (andER (connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C) (y :e C) HC). }
	      claim HCconn: connected_space C (subspace_topology R R_lower_limit_topology C).
	      { exact (andEL (connected_space C (subspace_topology R R_lower_limit_topology C)) (x :e C) HCcore). }
	      claim HxC: x :e C.
	      { exact (andER (connected_space C (subspace_topology R R_lower_limit_topology C)) (x :e C) HCcore). }
      claim HTl: topology_on R R_lower_limit_topology.
      { exact R_lower_limit_topology_is_topology. }
      claim HCsubR: C c= R.
      { exact (connected_subspace_subset R R_lower_limit_topology C HTl HCconn). }
      set I := halfopen_interval_left y x.
      claim Hyx: Rlt y x.
      { exact (RltI y x HyR HxR Hylt). }
      claim HI: I :e R_lower_limit_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology y x HyR HxR). }
      claim HcompI: (R :\: I) :e R_lower_limit_topology.
      { exact (complement_halfopen_interval_left_in_R_lower_limit_topology y x HyR HxR). }
      set A := I :/\: C.
      claim HAne: A <> Empty.
      { assume Heq: A = Empty.
        claim HyI: y :e I.
        { exact (halfopen_interval_left_leftmem y x Hyx). }
        claim HyA: y :e A.
        { exact (binintersectI I C y HyI HyC). }
        claim HyE: y :e Empty.
        { rewrite <- Heq. exact HyA. }
        exact (EmptyE y HyE). }
      claim HAnC: A <> C.
      { assume Heq: A = C.
        claim HxNotI: x /:e I.
        { assume HxinI: x :e I.
          claim HxPropI: ~(Rlt x y) /\ Rlt x x.
          { exact (SepE2 R (fun z:set => ~(Rlt z y) /\ Rlt z x) x HxinI). }
          claim HxSelf: Rlt x x.
          { exact (andER (~(Rlt x y)) (Rlt x x) HxPropI). }
          exact ((not_Rlt_refl x HxR) HxSelf). }
        claim HxNotA: x /:e A.
        { assume HxA: x :e A.
          exact (HxNotI (binintersectE1 I C x HxA)). }
        claim HxA': x :e A.
        { rewrite Heq. exact HxC. }
        exact (HxNotA HxA'). }
      set Tc := subspace_topology R R_lower_limit_topology C.
      claim HTc: topology_on C Tc.
      { exact (andEL (topology_on C Tc) (~(exists U V:set, U :e Tc /\ V :e Tc /\ separation_of C U V)) HCconn). }
      claim HAinTc: A :e Tc.
      { exact (subspace_topologyI R R_lower_limit_topology C I HI). }
      claim HAopen: open_in C Tc A.
      { exact (andI (topology_on C Tc) (A :e Tc) HTc HAinTc). }
      claim HUinTc: (C :\: A) :e Tc.
      { claim HeqU: C :\: A = (R :\: I) :/\: C.
        { apply set_ext.
          - let z. assume Hz: z :e C :\: A.
            prove z :e (R :\: I) :/\: C.
            claim Hzpair: z :e C /\ z /:e A.
            { exact (setminusE C A z Hz). }
            claim HzC: z :e C.
            { exact (andEL (z :e C) (z /:e A) Hzpair). }
            claim HzNotA: z /:e A.
            { exact (andER (z :e C) (z /:e A) Hzpair). }
            claim HzR: z :e R.
            { exact (HCsubR z HzC). }
            claim HzNotI: z /:e I.
            { assume HzI: z :e I.
              apply HzNotA.
              exact (binintersectI I C z HzI HzC). }
            apply binintersectI.
            * exact (setminusI R I z HzR HzNotI).
            * exact HzC.
          - let z. assume Hz: z :e (R :\: I) :/\: C.
            prove z :e C :\: A.
            apply (binintersectE (R :\: I) C z Hz).
            assume HzRI: z :e R :\: I.
            assume HzC: z :e C.
            claim HzNotI: z /:e I.
            { exact (setminusE2 R I z HzRI). }
            apply (setminusI C A z HzC).
            assume HzA: z :e A.
            exact (HzNotI (binintersectE1 I C z HzA)). }
        rewrite HeqU.
        exact (subspace_topologyI R R_lower_limit_topology C (R :\: I) HcompI). }
      claim HAclosed: closed_in C Tc A.
      { rewrite <- (setminus_setminus_eq C A (binintersect_Subq_2 I C)).
        exact (closed_of_open_complement C Tc (C :\: A) HTc HUinTc). }
      claim Hnoclopen: ~(exists A0:set, A0 <> Empty /\ A0 <> C /\ open_in C Tc A0 /\ closed_in C Tc A0).
      { exact (iffEL (connected_space C Tc)
                     (~(exists A0:set, A0 <> Empty /\ A0 <> C /\ open_in C Tc A0 /\ closed_in C Tc A0))
                     (connected_iff_no_nontrivial_clopen C Tc HTc)
                     HCconn). }
      apply FalseE.
      apply Hnoclopen.
      witness A.
      claim Hpair: A <> Empty /\ A <> C.
      { exact (andI (A <> Empty) (A <> C) HAne HAnC). }
      claim Htriple: (A <> Empty /\ A <> C) /\ open_in C Tc A.
      { exact (andI (A <> Empty /\ A <> C) (open_in C Tc A) Hpair HAopen). }
      exact (andI ((A <> Empty /\ A <> C) /\ open_in C Tc A)
                  (closed_in C Tc A)
                  Htriple
                  HAclosed).
    - assume Hyeq: y = x.
      rewrite Hyeq.
      exact (SingI x).
    - assume Hxlt: x < y.
	      apply HyProp.
	      let C. assume HC.
	      claim HCcore: connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C.
	      { exact (andEL (connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C) (y :e C) HC). }
	      claim HyC: y :e C.
	      { exact (andER (connected_space C (subspace_topology R R_lower_limit_topology C) /\ x :e C) (y :e C) HC). }
	      claim HCconn: connected_space C (subspace_topology R R_lower_limit_topology C).
	      { exact (andEL (connected_space C (subspace_topology R R_lower_limit_topology C)) (x :e C) HCcore). }
	      claim HxC: x :e C.
	      { exact (andER (connected_space C (subspace_topology R R_lower_limit_topology C)) (x :e C) HCcore). }
      claim HTl: topology_on R R_lower_limit_topology.
      { exact R_lower_limit_topology_is_topology. }
      claim HCsubR: C c= R.
      { exact (connected_subspace_subset R R_lower_limit_topology C HTl HCconn). }
      set I := halfopen_interval_left x y.
      claim Hxylt: Rlt x y.
      { exact (RltI x y HxR HyR Hxlt). }
      claim HI: I :e R_lower_limit_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology x y HxR HyR). }
      claim HcompI: (R :\: I) :e R_lower_limit_topology.
      { exact (complement_halfopen_interval_left_in_R_lower_limit_topology x y HxR HyR). }
      set A := I :/\: C.
      claim HAne: A <> Empty.
      { assume Heq: A = Empty.
        claim HxI: x :e I.
        { exact (halfopen_interval_left_leftmem x y Hxylt). }
        claim HxA: x :e A.
        { exact (binintersectI I C x HxI HxC). }
        claim HxE: x :e Empty.
        { rewrite <- Heq. exact HxA. }
        exact (EmptyE x HxE). }
      claim HAnC: A <> C.
      { assume Heq: A = C.
        claim HyNotI: y /:e I.
        { assume HyinI: y :e I.
          claim HyPropI: ~(Rlt y x) /\ Rlt y y.
          { exact (SepE2 R (fun z:set => ~(Rlt z x) /\ Rlt z y) y HyinI). }
          claim HySelf: Rlt y y.
          { exact (andER (~(Rlt y x)) (Rlt y y) HyPropI). }
          exact ((not_Rlt_refl y HyR) HySelf). }
        claim HyNotA: y /:e A.
        { assume HyA: y :e A.
          exact (HyNotI (binintersectE1 I C y HyA)). }
        claim HyA': y :e A.
        { rewrite Heq. exact HyC. }
        exact (HyNotA HyA'). }
      set Tc := subspace_topology R R_lower_limit_topology C.
      claim HTc: topology_on C Tc.
      { exact (andEL (topology_on C Tc) (~(exists U V:set, U :e Tc /\ V :e Tc /\ separation_of C U V)) HCconn). }
      claim HAinTc: A :e Tc.
      { exact (subspace_topologyI R R_lower_limit_topology C I HI). }
      claim HAopen: open_in C Tc A.
      { exact (andI (topology_on C Tc) (A :e Tc) HTc HAinTc). }
      claim HUinTc: (C :\: A) :e Tc.
      { claim HeqU: C :\: A = (R :\: I) :/\: C.
        { apply set_ext.
          - let z. assume Hz: z :e C :\: A.
            prove z :e (R :\: I) :/\: C.
            claim Hzpair: z :e C /\ z /:e A.
            { exact (setminusE C A z Hz). }
            claim HzC: z :e C.
            { exact (andEL (z :e C) (z /:e A) Hzpair). }
            claim HzNotA: z /:e A.
            { exact (andER (z :e C) (z /:e A) Hzpair). }
            claim HzR: z :e R.
            { exact (HCsubR z HzC). }
            claim HzNotI: z /:e I.
            { assume HzI: z :e I.
              apply HzNotA.
              exact (binintersectI I C z HzI HzC). }
            apply binintersectI.
            * exact (setminusI R I z HzR HzNotI).
            * exact HzC.
          - let z. assume Hz: z :e (R :\: I) :/\: C.
            prove z :e C :\: A.
            apply (binintersectE (R :\: I) C z Hz).
            assume HzRI: z :e R :\: I.
            assume HzC: z :e C.
            claim HzNotI: z /:e I.
            { exact (setminusE2 R I z HzRI). }
            apply (setminusI C A z HzC).
            assume HzA: z :e A.
            exact (HzNotI (binintersectE1 I C z HzA)). }
        rewrite HeqU.
        exact (subspace_topologyI R R_lower_limit_topology C (R :\: I) HcompI). }
      claim HAclosed: closed_in C Tc A.
      { rewrite <- (setminus_setminus_eq C A (binintersect_Subq_2 I C)).
        exact (closed_of_open_complement C Tc (C :\: A) HTc HUinTc). }
      claim Hnoclopen: ~(exists A0:set, A0 <> Empty /\ A0 <> C /\ open_in C Tc A0 /\ closed_in C Tc A0).
      { exact (iffEL (connected_space C Tc)
                     (~(exists A0:set, A0 <> Empty /\ A0 <> C /\ open_in C Tc A0 /\ closed_in C Tc A0))
                     (connected_iff_no_nontrivial_clopen C Tc HTc)
                     HCconn). }
      apply FalseE.
      apply Hnoclopen.
      witness A.
      claim Hpair: A <> Empty /\ A <> C.
      { exact (andI (A <> Empty) (A <> C) HAne HAnC). }
      claim Htriple: (A <> Empty /\ A <> C) /\ open_in C Tc A.
      { exact (andI (A <> Empty /\ A <> C) (open_in C Tc A) Hpair HAopen). }
      exact (andI ((A <> Empty /\ A <> C) /\ open_in C Tc A)
                  (closed_in C Tc A)
                  Htriple
                  HAclosed).
  - let y. assume Hy: y :e {x}.
    prove y :e component_of R R_lower_limit_topology x.
    claim HyEq: y = x.
    { exact (SingE x y Hy). }
    rewrite HyEq.
    exact (point_in_component R R_lower_limit_topology x R_lower_limit_topology_is_topology HxR). }
apply andI.
- exact (Hall 0 real_0).
- exact Hall.
Qed.

(** from §23 Exercise: components of ℝ^ω in product/uniform/box topologies **) 
(** LATEX VERSION: For R to the omega, compare components in product and box type topologies. **)
Theorem ex23_Romega_components :
  component_of (product_space omega (const_space_family omega R R_standard_topology)) (product_topology_full omega (const_space_family omega R R_standard_topology)) (const_family omega 0) =
    product_space omega (const_space_family omega R R_standard_topology) /\
  component_of (product_space omega (const_space_family omega R R_standard_topology)) (box_topology omega (const_space_family omega R R_standard_topology)) (const_family omega 0) =
    {f :e product_space omega (const_space_family omega R R_standard_topology) | exists F:set, finite F /\ forall i:set, i :e omega :\: F -> apply_fun f i = 0}.
prove component_of (product_space omega (const_space_family omega R R_standard_topology)) (product_topology_full omega (const_space_family omega R R_standard_topology)) (const_family omega 0) = product_space omega (const_space_family omega R R_standard_topology) /\ component_of (product_space omega (const_space_family omega R R_standard_topology)) (box_topology omega (const_space_family omega R R_standard_topology)) (const_family omega 0) = {f :e product_space omega (const_space_family omega R R_standard_topology) | exists F:set, finite F /\ forall i:set, i :e omega :\: F -> apply_fun f i = 0}.
apply andI.
- (** product topology: connected **)
  admit. (** FAIL **)
- (** box topology: finite support condition **)
  admit. (** FAIL **)
Qed.

(** from §23 Exercise: ordered square locally connected but not locally path connected **) 
(** LATEX VERSION: The ordered square is locally connected but not locally path connected. **)
Theorem ex23_ordered_square_locally_conn_not_pathconn :
  locally_connected ordered_square ordered_square_topology /\
  ~ locally_path_connected ordered_square ordered_square_topology.
prove locally_connected ordered_square ordered_square_topology /\ ~ locally_path_connected ordered_square ordered_square_topology.
apply andI.
- (** locally_connected **)
  admit. (** FAIL **)
- (** not locally_path_connected **)
  admit. (** FAIL **)
Qed.

(** from §23 Exercise: connected open subsets of locally path connected spaces are path connected **) 
(** LATEX VERSION: In a locally path connected space, every open connected subset is path connected. **)
Theorem ex23_connected_open_sets_path_connected : forall X Tx U:set,
  locally_path_connected X Tx -> open_in X Tx U -> connected_space U (subspace_topology X Tx U) -> path_connected_space U (subspace_topology X Tx U).
let X Tx U.
assume Hlpc: locally_path_connected X Tx.
assume HU: open_in X Tx U.
assume Hconn: connected_space U (subspace_topology X Tx U).
prove path_connected_space U (subspace_topology X Tx U).
set Tu := subspace_topology X Tx U.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X ->
                 forall V:set, V :e Tx -> x :e V ->
                   exists W:set, W :e Tx /\ x :e W /\ W c= V /\ path_connected_space W (subspace_topology X Tx W))
               Hlpc). }
claim Hlpcprop: forall x:set, x :e X ->
  forall V:set, V :e Tx -> x :e V ->
    exists W:set, W :e Tx /\ x :e W /\ W c= V /\ path_connected_space W (subspace_topology X Tx W).
{ exact (andER (topology_on X Tx)
               (forall x:set, x :e X ->
                 forall V:set, V :e Tx -> x :e V ->
                   exists W:set, W :e Tx /\ x :e W /\ W c= V /\ path_connected_space W (subspace_topology X Tx W))
               Hlpc). }
claim HUsubX: U c= X.
{ exact (open_in_subset X Tx U HU). }
claim HUinTx: U :e Tx.
{ exact (open_in_elem X Tx U HU). }
claim HtopU: topology_on U Tu.
{ exact (subspace_topology_is_topology X Tx U HTx HUsubX). }

(** locally path connectedness is inherited by open subspaces **)
claim HlpcU: locally_path_connected U Tu.
{ prove topology_on U Tu /\
    forall x:set, x :e U ->
      forall V:set, V :e Tu -> x :e V ->
        exists W:set, W :e Tu /\ x :e W /\ W c= V /\ path_connected_space W (subspace_topology U Tu W).
  apply andI.
  - exact HtopU.
  - let x. assume HxU: x :e U.
    let V. assume HV: V :e Tu.
    assume HxV: x :e V.
    claim HxX: x :e X.
    { exact (HUsubX x HxU). }
    claim HVpowU: V :e Power U.
    { exact (SepE1 (Power U) (fun V0:set => exists W0 :e Tx, V0 = W0 :/\: U) V HV). }
    claim HVrep: exists W0 :e Tx, V = W0 :/\: U.
    { exact (SepE2 (Power U) (fun V0:set => exists W0 :e Tx, V0 = W0 :/\: U) V HV). }
    apply HVrep.
    let W0. assume HW0pair.
    claim HW0: W0 :e Tx.
    { exact (andEL (W0 :e Tx) (V = W0 :/\: U) HW0pair). }
    claim HVeql: V = W0 :/\: U.
    { exact (andER (W0 :e Tx) (V = W0 :/\: U) HW0pair). }
    claim HxWU: x :e W0 :/\: U.
    { rewrite <- HVeql. exact HxV. }
    claim HxW0: x :e W0.
    { exact (binintersectE1 W0 U x HxWU). }
    claim HWUinTx: (W0 :/\: U) :e Tx.
    { exact (topology_binintersect_closed X Tx W0 U HTx HW0 HUinTx). }
    claim HexW: exists W:set, W :e Tx /\ x :e W /\ W c= (W0 :/\: U) /\ path_connected_space W (subspace_topology X Tx W).
	    { exact (Hlpcprop x HxX (W0 :/\: U) HWUinTx HxWU). }
	    apply HexW.
	    let W. assume HW.
	    claim HWL: (W :e Tx /\ x :e W) /\ W c= (W0 :/\: U).
	    { exact (andEL ((W :e Tx /\ x :e W) /\ W c= (W0 :/\: U))
	                   (path_connected_space W (subspace_topology X Tx W)) HW). }
	    claim HWpath: path_connected_space W (subspace_topology X Tx W).
	    { exact (andER ((W :e Tx /\ x :e W) /\ W c= (W0 :/\: U))
	                   (path_connected_space W (subspace_topology X Tx W)) HW). }
	    claim HW12: W :e Tx /\ x :e W.
	    { exact (andEL (W :e Tx /\ x :e W) (W c= (W0 :/\: U)) HWL). }
	    claim HWsubWU: W c= (W0 :/\: U).
	    { exact (andER (W :e Tx /\ x :e W) (W c= (W0 :/\: U)) HWL). }
	    claim HWTx: W :e Tx.
	    { exact (andEL (W :e Tx) (x :e W) HW12). }
	    claim HxW: x :e W.
	    { exact (andER (W :e Tx) (x :e W) HW12). }
    claim HWsubU: W c= U.
    { let z. assume HzW: z :e W.
      claim HzWU: z :e W0 :/\: U.
      { exact (HWsubWU z HzW). }
      exact (binintersectE2 W0 U z HzWU). }
    claim HWpowU: W :e Power U.
    { exact (PowerI U W HWsubU). }
    claim HWUeq: W = W :/\: U.
	    { apply set_ext.
	      - let z. assume HzW: z :e W.
	        exact (binintersectI W U z HzW (HWsubU z HzW)).
	      - let z. assume HzWU: z :e W :/\: U.
	        exact (binintersectE1 W U z HzWU). }
	    claim HWTu: W :e Tu.
	    { claim HexWopen: open_in U Tu W.
	      { claim Hex: exists V0 :e Tx, W = V0 :/\: U.
	        { witness W.
	          apply andI.
	          - exact HWTx.
	          - exact HWUeq. }
	        exact (iffER (open_in U Tu W)
	                     (exists V0 :e Tx, W = V0 :/\: U)
	                     (open_in_subspace_iff X Tx U W HTx HUsubX HWsubU)
	                     Hex). }
	      exact (open_in_elem U Tu W HexWopen). }
    claim Hsubtrans: subspace_topology U Tu W = subspace_topology X Tx W.
    { exact (ex16_1_subspace_transitive X Tx U W HTx HUsubX HWsubU). }
    claim HWpathU: path_connected_space W (subspace_topology U Tu W).
    { rewrite Hsubtrans.
      exact HWpath. }
    witness W.
    prove W :e Tu /\ x :e W /\ W c= V /\ path_connected_space W (subspace_topology U Tu W).
    apply andI.
    - apply andI.
      + apply andI.
        * exact HWTu.
        * exact HxW.
      + prove W c= V.
        rewrite HVeql.
        exact HWsubWU.
    - exact HWpathU. }

prove topology_on U Tu /\
  forall x y:set, x :e U -> y :e U ->
    exists p:set, path_between U x y p /\ continuous_map unit_interval unit_interval_topology U Tu p.
apply andI.
- exact HtopU.
- let x y.
  assume HxU: x :e U.
  assume HyU: y :e U.
  set Pc := path_component_of U Tu x.
  claim HPcOpen: open_in U Tu Pc.
  { exact (path_components_open U Tu HlpcU x HxU). }
  claim HPcInTu: Pc :e Tu.
  { exact (open_in_elem U Tu Pc HPcOpen). }
  claim HxPc: x :e Pc.
  { exact (path_component_reflexive U Tu x HtopU HxU). }
  claim HPcNe: Pc <> Empty.
  { exact (elem_implies_nonempty Pc x HxPc). }
  (** show Pc is closed by showing its complement is open **)
  set D := U :\: Pc.
  set Fam := {path_component_of U Tu z | z :e D}.
  claim HFsub: Fam c= Tu.
  { let W. assume HW: W :e Fam.
    apply (ReplE_impred D (fun z:set => path_component_of U Tu z) W HW).
    let z. assume HzD: z :e D.
    assume HWeq: W = path_component_of U Tu z.
    claim HzU: z :e U.
    { exact (setminusE1 U Pc z HzD). }
    claim Hopenz: open_in U Tu (path_component_of U Tu z).
    { exact (path_components_open U Tu HlpcU z HzU). }
    claim HinTu: path_component_of U Tu z :e Tu.
    { exact (open_in_elem U Tu (path_component_of U Tu z) Hopenz). }
    rewrite HWeq.
    exact HinTu. }
  claim HUnionTu: Union Fam :e Tu.
  { exact (topology_union_closed U Tu Fam HtopU HFsub). }
  claim HUnionEq: Union Fam = D.
  { (** use equivalence relation properties of path components **)
    claim Heqrel: (forall z:set, z :e U -> z :e path_component_of U Tu z) /\
      (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b) /\
      (forall a b c:set, a :e U -> b :e U -> c :e U ->
         b :e path_component_of U Tu a -> c :e path_component_of U Tu b ->
         c :e path_component_of U Tu a).
    { exact (path_components_equivalence_relation U Tu HtopU). }
    claim H12: (forall z:set, z :e U -> z :e path_component_of U Tu z) /\
      (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b).
    { exact (andEL ((forall z:set, z :e U -> z :e path_component_of U Tu z) /\
                    (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b))
                   (forall a b c:set, a :e U -> b :e U -> c :e U ->
                      b :e path_component_of U Tu a -> c :e path_component_of U Tu b ->
                      c :e path_component_of U Tu a)
                   Heqrel). }
    claim Hrefl: forall z:set, z :e U -> z :e path_component_of U Tu z.
    { exact (andEL (forall z:set, z :e U -> z :e path_component_of U Tu z)
                   (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b)
                   H12). }
    claim Hsym: forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b.
    { exact (andER (forall z:set, z :e U -> z :e path_component_of U Tu z)
                   (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b)
                   H12). }
    claim Htrans: forall a b c:set, a :e U -> b :e U -> c :e U ->
      b :e path_component_of U Tu a -> c :e path_component_of U Tu b ->
      c :e path_component_of U Tu a.
    { exact (andER ((forall z:set, z :e U -> z :e path_component_of U Tu z) /\
                    (forall a b:set, a :e U -> b :e U -> b :e path_component_of U Tu a -> a :e path_component_of U Tu b))
                   (forall a b c:set, a :e U -> b :e U -> c :e U ->
                      b :e path_component_of U Tu a -> c :e path_component_of U Tu b ->
                      c :e path_component_of U Tu a)
                   Heqrel). }
    apply set_ext.
    - let t. assume HtU: t :e Union Fam.
      apply (UnionE Fam t HtU).
      let W. assume Hex: t :e W /\ W :e Fam.
      claim HWt: t :e W.
      { exact (andEL (t :e W) (W :e Fam) Hex). }
      claim HWFam: W :e Fam.
      { exact (andER (t :e W) (W :e Fam) Hex). }
      claim HWdef: exists z :e D, W = path_component_of U Tu z.
      { exact (ReplE D (fun z:set => path_component_of U Tu z) W HWFam). }
      apply HWdef.
      let z. assume Hzpair.
      claim HzD: z :e D.
      { exact (andEL (z :e D) (W = path_component_of U Tu z) Hzpair). }
      claim HWeq: W = path_component_of U Tu z.
      { exact (andER (z :e D) (W = path_component_of U Tu z) Hzpair). }
      claim HtW: t :e W.
      { exact HWt. }
      claim HtPc_z: t :e path_component_of U Tu z.
      { rewrite <- HWeq.
        exact HtW. }
      claim HtU0: t :e U.
      { exact (SepE1 U (fun y0:set => exists p:set, function_on p unit_interval U /\
                 continuous_map unit_interval unit_interval_topology U Tu p /\
                 apply_fun p 0 = z /\ apply_fun p 1 = y0) t HtPc_z). }
      prove t :e D.
      prove t :e U :\: Pc.
      apply setminusI.
      - exact HtU0.
      - assume HtPc: t :e Pc.
        claim HzU: z :e U.
        { exact (setminusE1 U Pc z HzD). }
        claim HzNotPc: z /:e Pc.
        { exact (setminusE2 U Pc z HzD). }
        claim HzPc_t: z :e path_component_of U Tu t.
        { exact (Hsym z t HzU HtU0 HtPc_z). }
        claim HzPc_x: z :e path_component_of U Tu x.
        { exact (Htrans x t z HxU HtU0 HzU HtPc HzPc_t). }
        exact (HzNotPc HzPc_x).
    - let t. assume HtD: t :e D.
      prove t :e Union Fam.
      claim HtU0: t :e U.
      { exact (setminusE1 U Pc t HtD). }
      claim HtFam: path_component_of U Tu t :e Fam.
      { exact (ReplI D (fun z:set => path_component_of U Tu z) t HtD). }
      claim HtPc_t: t :e path_component_of U Tu t.
      { exact (Hrefl t HtU0). }
      exact (UnionI Fam t (path_component_of U Tu t) HtPc_t HtFam). }
  claim HDinTu: D :e Tu.
  { rewrite <- HUnionEq.
    exact HUnionTu. }
  claim HPcClosed: closed_in U Tu Pc.
  { apply (closed_inI U Tu Pc).
    - exact HtopU.
    - prove Pc c= U.
      let t. assume HtPc: t :e Pc.
      exact (SepE1 U (fun y0:set => exists p:set, function_on p unit_interval U /\
             continuous_map unit_interval unit_interval_topology U Tu p /\
             apply_fun p 0 = x /\ apply_fun p 1 = y0) t HtPc).
    - witness D.
      apply andI.
      + exact HDinTu.
      + (** Pc = U \\ D **)
        apply set_ext.
        * let t. assume HtPc: t :e Pc.
          prove t :e U :\: D.
          apply setminusI.
          - exact (SepE1 U (fun y0:set => exists p:set, function_on p unit_interval U /\
               continuous_map unit_interval unit_interval_topology U Tu p /\
               apply_fun p 0 = x /\ apply_fun p 1 = y0) t HtPc).
          - assume HtD: t :e D.
             claim HtNotPc: t /:e Pc.
             { exact (setminusE2 U Pc t HtD). }
             exact (HtNotPc HtPc).
        * let t. assume HtUD: t :e U :\: D.
          claim HtU: t :e U.
          { exact (setminusE1 U D t HtUD). }
          claim HtNotD: t /:e D.
          { exact (setminusE2 U D t HtUD). }
          apply (xm (t :e Pc)).
          - assume HtPc: t :e Pc. exact HtPc.
	          - assume HtNotPc: t /:e Pc.
	             apply FalseE.
	             apply HtNotD.
	             exact (setminusI U Pc t HtU HtNotPc). } 
	  (** conclude Pc = U by connectedness and clopen property **)
	  claim HnoClopen: ~(exists B:set, B <> Empty /\ B <> U /\ open_in U Tu B /\ closed_in U Tu B).
	  { exact (iffEL (connected_space U Tu)
	                 (~(exists B:set, B <> Empty /\ B <> U /\ open_in U Tu B /\ closed_in U Tu B))
                 (connected_iff_no_nontrivial_clopen U Tu HtopU) Hconn). }
  claim HPcEqU: Pc = U.
  { apply (xm (Pc = U)).
    - assume H. exact H.
    - assume Hneq: Pc <> U.
      apply FalseE.
      apply HnoClopen.
      witness Pc.
      prove Pc <> Empty /\ Pc <> U /\ open_in U Tu Pc /\ closed_in U Tu Pc.
      apply andI.
      - apply andI.
        + apply andI.
          * exact HPcNe.
          * exact Hneq.
        + exact HPcOpen.
      - exact HPcClosed. }
  claim HyPc: y :e Pc.
  { rewrite HPcEqU.
    exact HyU. }
  (** extract a path witness from membership in the path component **)
  claim HexPath: exists p:set,
    function_on p unit_interval U /\
    continuous_map unit_interval unit_interval_topology U Tu p /\
    apply_fun p 0 = x /\ apply_fun p 1 = y.
  { exact (SepE2 U (fun y0:set => exists p:set, function_on p unit_interval U /\
           continuous_map unit_interval unit_interval_topology U Tu p /\
           apply_fun p 0 = x /\ apply_fun p 1 = y0) y HyPc). }
  apply HexPath.
  let p. assume Hp.
  witness p.
  prove path_between U x y p /\ continuous_map unit_interval unit_interval_topology U Tu p.
  claim HpAB0: (function_on p unit_interval U /\
                continuous_map unit_interval unit_interval_topology U Tu p) /\
               apply_fun p 0 = x.
  { exact (andEL ((function_on p unit_interval U /\
                   continuous_map unit_interval unit_interval_topology U Tu p) /\
                  apply_fun p 0 = x)
                 (apply_fun p 1 = y) Hp). }
  claim Hp1: apply_fun p 1 = y.
  { exact (andER ((function_on p unit_interval U /\
                   continuous_map unit_interval unit_interval_topology U Tu p) /\
                  apply_fun p 0 = x)
                 (apply_fun p 1 = y) Hp). }
  claim HpAB: function_on p unit_interval U /\
              continuous_map unit_interval unit_interval_topology U Tu p.
  { exact (andEL (function_on p unit_interval U /\
                  continuous_map unit_interval unit_interval_topology U Tu p)
                 (apply_fun p 0 = x) HpAB0). }
  claim Hp0: apply_fun p 0 = x.
  { exact (andER (function_on p unit_interval U /\
                  continuous_map unit_interval unit_interval_topology U Tu p)
                 (apply_fun p 0 = x) HpAB0). }
  claim HpFun: function_on p unit_interval U.
  { exact (andEL (function_on p unit_interval U)
                 (continuous_map unit_interval unit_interval_topology U Tu p)
                 HpAB). }
  claim HpCont: continuous_map unit_interval unit_interval_topology U Tu p.
  { exact (andER (function_on p unit_interval U)
                 (continuous_map unit_interval unit_interval_topology U Tu p)
                 HpAB). }
  apply andI.
  - prove function_on p unit_interval U /\ apply_fun p 0 = x /\ apply_fun p 1 = y.
    apply andI.
    + apply andI.
      - exact HpFun.
      - exact Hp0.
    + exact Hp1.
  - exact HpCont.
Qed.

(** from §23 Exercise: examples of path connected but not locally connected subsets of ℝ^2 **) 
(** LATEX VERSION: There exists a subset of the plane that is path connected but not locally connected. **)
Theorem ex23_path_connected_not_locally_connected_examples :
  exists A:set,
    A c= EuclidPlane /\ path_connected_space A (subspace_topology EuclidPlane R2_standard_topology A) /\
    ~ locally_connected A (subspace_topology EuclidPlane R2_standard_topology A).
prove exists A:set,
    A c= EuclidPlane /\ path_connected_space A (subspace_topology EuclidPlane R2_standard_topology A) /\
    ~ locally_connected A (subspace_topology EuclidPlane R2_standard_topology A).
admit. (** FAIL **)
Qed.

(** from §26 Definition: compact space **) 
(** LATEX VERSION: A space is compact if every open cover has a finite subcover. **)
Definition open_cover_of : set -> set -> set -> prop := fun X Tx Fam =>
  topology_on X Tx /\ Fam c= Power X /\ X c= Union Fam /\ (forall U:set, U :e Fam -> U :e Tx).

(** Helper: extract topology_on from open_cover_of **)
Theorem open_cover_of_topology : forall X Tx Fam:set,
  open_cover_of X Tx Fam -> topology_on X Tx.
let X Tx Fam.
assume H: open_cover_of X Tx Fam.
claim H0: ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam) /\ (forall U:set, U :e Fam -> U :e Tx).
{ exact H. }
claim H1: (topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam.
{ exact (andEL ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam)
               (forall U:set, U :e Fam -> U :e Tx)
               H0). }
claim H2: topology_on X Tx /\ Fam c= Power X.
{ exact (andEL (topology_on X Tx /\ Fam c= Power X)
               (X c= Union Fam)
               H1). }
exact (andEL (topology_on X Tx) (Fam c= Power X) H2).
Qed.

(** Helper: extract Fam c= Power X from open_cover_of **)
Theorem open_cover_of_family_sub : forall X Tx Fam:set,
  open_cover_of X Tx Fam -> Fam c= Power X.
let X Tx Fam.
assume H: open_cover_of X Tx Fam.
claim H0: ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam) /\ (forall U:set, U :e Fam -> U :e Tx).
{ exact H. }
claim H1: (topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam.
{ exact (andEL ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam)
               (forall U:set, U :e Fam -> U :e Tx)
               H0). }
claim H2: topology_on X Tx /\ Fam c= Power X.
{ exact (andEL (topology_on X Tx /\ Fam c= Power X)
               (X c= Union Fam)
               H1). }
exact (andER (topology_on X Tx) (Fam c= Power X) H2).
Qed.

(** Helper: extract cover property X c= Union Fam from open_cover_of **)
Theorem open_cover_of_covers : forall X Tx Fam:set,
  open_cover_of X Tx Fam -> X c= Union Fam.
let X Tx Fam.
assume H: open_cover_of X Tx Fam.
claim H0: ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam) /\ (forall U:set, U :e Fam -> U :e Tx).
{ exact H. }
claim H1: (topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam.
{ exact (andEL ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam)
               (forall U:set, U :e Fam -> U :e Tx)
               H0). }
exact (andER (topology_on X Tx /\ Fam c= Power X) (X c= Union Fam) H1).
Qed.

(** Helper: extract openness of cover members from open_cover_of **)
Theorem open_cover_of_members_open : forall X Tx Fam U:set,
  open_cover_of X Tx Fam -> U :e Fam -> U :e Tx.
let X Tx Fam U.
assume H: open_cover_of X Tx Fam.
assume HU: U :e Fam.
claim H0: ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam) /\ (forall U0:set, U0 :e Fam -> U0 :e Tx).
{ exact H. }
claim Hprop: forall U0:set, U0 :e Fam -> U0 :e Tx.
{ exact (andER ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam)
               (forall U0:set, U0 :e Fam -> U0 :e Tx)
               H0). }
exact (Hprop U HU).
Qed.

(** from §26 Compactness: finite subcover **)
(** LATEX VERSION: A cover has a finite subcover if some finite subcollection still covers X. **)
Definition has_finite_subcover : set -> set -> set -> prop := fun X Tx Fam =>
  exists G:set, G c= Fam /\ finite G /\ X c= Union G.

(** Helper: introduce `has_finite_subcover` with an explicit witness. **)
Theorem has_finite_subcoverI : forall X Tx Fam G:set,
  G c= Fam /\ finite G /\ X c= Union G -> has_finite_subcover X Tx Fam.
let X Tx Fam G.
assume HG: G c= Fam /\ finite G /\ X c= Union G.
prove has_finite_subcover X Tx Fam.
prove exists G1:set, G1 c= Fam /\ finite G1 /\ X c= Union G1.
witness G.
exact HG.
Qed.

(** from §26 Compactness: compact space **)
(** LATEX VERSION: X is compact if every open cover of X has a finite subcover. **)
Definition compact_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\ forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.

(** Helper: extract topology_on from compact_space **)
Theorem compact_space_topology : forall X Tx:set,
  compact_space X Tx -> topology_on X Tx.
let X Tx.
assume H: compact_space X Tx.
exact (andEL (topology_on X Tx)
             (forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam)
             H).
Qed.

(** Helper: extract finite subcover property from compact_space **)
Theorem compact_space_subcover_property : forall X Tx:set,
  compact_space X Tx ->
  forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.
let X Tx.
assume H: compact_space X Tx.
claim Hprop: forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.
{ exact (andER (topology_on X Tx)
               (forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam)
               H). }
exact Hprop.
Qed.

(** from §26: open cover characterization **) 
(** LATEX VERSION: In a compact space, every open cover has a finite subcover. **)
Theorem Heine_Borel_subcover : forall X Tx Fam:set,
  compact_space X Tx ->
  open_cover_of X Tx Fam ->
  has_finite_subcover X Tx Fam.
let X Tx Fam.
assume Hcomp: compact_space X Tx.
assume HFam: open_cover_of X Tx Fam.
prove has_finite_subcover X Tx Fam.
exact (compact_space_subcover_property X Tx Hcomp Fam HFam).
Qed.

(** from §26 Lemma 26.1: covering a subspace by ambient opens **)
(** LATEX VERSION: A subspace Y is compact iff every cover of Y by open sets of X has a finite subcover. **)
(** FIXED: Use ambient cover condition (Fam c= Tx /\ Y c= Union Fam) instead of open_cover_of Y Tx Fam, since Tx is a topology on X. **)
Theorem compact_subspace_via_ambient_covers : forall X Tx Y:set,
  topology_on X Tx -> Y c= X ->
  (compact_space Y (subspace_topology X Tx Y) <->
    forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam).
let X Tx Y.
assume HTx: topology_on X Tx.
assume HY: Y c= X.
prove compact_space Y (subspace_topology X Tx Y) <->
    forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam.
set Ty := subspace_topology X Tx Y.
apply iffI.
- (** -> **)
  assume Hcomp: compact_space Y Ty.
  prove forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam.
  let Fam. assume Hcov: Fam c= Tx /\ Y c= Union Fam.
  claim HFamSub: Fam c= Tx.
  { exact (andEL (Fam c= Tx) (Y c= Union Fam) Hcov). }
  claim HYcov: Y c= Union Fam.
  { exact (andER (Fam c= Tx) (Y c= Union Fam) Hcov). }
  (** Turn the ambient cover into a subspace open cover by intersecting with Y. **)
  set FamY := {U :/\: Y|U :e Fam}.
  claim HtopY: topology_on Y Ty.
  { exact (andEL (topology_on Y Ty)
                 (forall Fam:set, open_cover_of Y Ty Fam -> has_finite_subcover Y Ty Fam)
                 Hcomp). }
  claim HcoverFamY: open_cover_of Y Ty FamY.
  { prove topology_on Y Ty /\ FamY c= Power Y /\ Y c= Union FamY /\ (forall U:set, U :e FamY -> U :e Ty).
    (** conjunction is left-associative: (((A /\ B) /\ C) /\ D) **)
    apply andI.
    - (** (A /\ B) /\ C **)
      apply andI.
      + (** A /\ B **)
        apply andI.
        * exact HtopY.
        * (** FamY c= Power Y **)
          let W. assume HW: W :e FamY.
          prove W :e Power Y.
          apply (ReplE_impred Fam (fun U:set => U :/\: Y) W HW).
          let U. assume HUfam: U :e Fam.
          assume HWeq: W = U :/\: Y.
          rewrite HWeq.
          apply PowerI.
          exact (binintersect_Subq_2 U Y).
      + (** Y c= Union FamY **)
        let y. assume HyY: y :e Y.
        prove y :e Union FamY.
        claim HyUnionFam: y :e Union Fam.
        { exact (HYcov y HyY). }
        apply (UnionE_impred Fam y HyUnionFam).
        let U. assume HyU: y :e U.
        assume HUfam: U :e Fam.
        prove y :e Union FamY.
        apply (UnionI FamY y (U :/\: Y)).
        - prove y :e U :/\: Y.
          exact (binintersectI U Y y HyU HyY).
        - prove (U :/\: Y) :e FamY.
          exact (ReplI Fam (fun V:set => V :/\: Y) U HUfam).
    - (** each cover element is open in the subspace topology **)
      let W. assume HW: W :e FamY.
      prove W :e Ty.
      apply (ReplE_impred Fam (fun U:set => U :/\: Y) W HW).
	      let U. assume HUfam: U :e Fam.
	      assume HWeq: W = U :/\: Y.
	      rewrite HWeq.
	      exact (subspace_topologyI X Tx Y U (HFamSub U HUfam)).
	  }
	  (** Apply compactness of Y in the subspace topology. **)
	  claim Hsubcover: forall Fam0:set, open_cover_of Y Ty Fam0 -> has_finite_subcover Y Ty Fam0.
	  { exact (andER (topology_on Y Ty)
	                 (forall Fam0:set, open_cover_of Y Ty Fam0 -> has_finite_subcover Y Ty Fam0)
	                 Hcomp). }
  claim HfinY: has_finite_subcover Y Ty FamY.
  { exact (Hsubcover FamY HcoverFamY). }
  apply HfinY.
  let GY. assume HGY: GY c= FamY /\ finite GY /\ Y c= Union GY.
  (** conjunction is left-associative: (A /\ B) /\ C **)
  claim HGYleft: GY c= FamY /\ finite GY.
  { exact (andEL (GY c= FamY /\ finite GY) (Y c= Union GY) HGY). }
  claim HGYsub: GY c= FamY.
  { exact (andEL (GY c= FamY) (finite GY) HGYleft). }
  claim HGYfin: finite GY.
  { exact (andER (GY c= FamY) (finite GY) HGYleft). }
  claim HGYcov: Y c= Union GY.
  { exact (andER (GY c= FamY /\ finite GY) (Y c= Union GY) HGY). }
	  (** Choose, for each W in GY, an ambient set U in Fam with W = U /\ Y. **)
	  set pickU := fun W:set => Eps_i (fun U:set => U :e Fam /\ W = U :/\: Y).
	  set G := {pickU W|W :e GY}.
		  prove exists G1:set, G1 c= Fam /\ finite G1 /\ Y c= Union G1.
		  witness G.
		  prove G c= Fam /\ finite G /\ Y c= Union G.
	  apply andI.
  - apply andI.
    + (** G c= Fam **)
      let U. assume HU: U :e G.
      prove U :e Fam.
      apply (ReplE_impred GY (fun W:set => pickU W) U HU).
      let W. assume HWGY: W :e GY.
      assume HeqU: U = pickU W.
      rewrite HeqU.
      (** show pickU W is in Fam using epsilon **)
      claim HWFamY: W :e FamY.
      { exact (HGYsub W HWGY). }
      claim HexU: exists U0:set, U0 :e Fam /\ W = U0 :/\: Y.
      { apply (ReplE_impred Fam (fun U1:set => U1 :/\: Y) W HWFamY).
        let U0. assume HU0fam: U0 :e Fam.
        assume HW0: W = U0 :/\: Y.
        witness U0.
        apply andI.
        - exact HU0fam.
        - exact HW0. }
      (** apply epsilon to obtain membership in Fam **)
      apply HexU.
      let U0. assume HU0pair: U0 :e Fam /\ W = U0 :/\: Y.
      claim HU0: U0 :e Fam.
      { exact (andEL (U0 :e Fam) (W = U0 :/\: Y) HU0pair). }
      exact (andEL (pickU W :e Fam) (W = pickU W :/\: Y)
                   (Eps_i_ax (fun U1:set => U1 :e Fam /\ W = U1 :/\: Y) U0 HU0pair)).
    + (** finite G **)
      exact (Repl_finite (fun W:set => pickU W) GY HGYfin).
  - (** Y c= Union G **)
    let y. assume HyY: y :e Y.
    prove y :e Union G.
    claim HyUGY: y :e Union GY.
    { exact (HGYcov y HyY). }
    apply (UnionE_impred GY y HyUGY).
    let W. assume HyW: y :e W.
    assume HWGY: W :e GY.
    prove y :e Union G.
    (** show y in pickU W **)
    claim HWFamY: W :e FamY.
    { exact (HGYsub W HWGY). }
    claim HexU: exists U0:set, U0 :e Fam /\ W = U0 :/\: Y.
    { apply (ReplE_impred Fam (fun U1:set => U1 :/\: Y) W HWFamY).
      let U0. assume HU0fam: U0 :e Fam.
      assume HW0: W = U0 :/\: Y.
      witness U0.
      apply andI.
      - exact HU0fam.
      - exact HW0. }
    claim Hpick: W = pickU W :/\: Y.
    { apply HexU.
      let U0. assume HU0pair: U0 :e Fam /\ W = U0 :/\: Y.
      exact (andER (pickU W :e Fam) (W = pickU W :/\: Y)
                   (Eps_i_ax (fun U1:set => U1 :e Fam /\ W = U1 :/\: Y) U0 HU0pair)). }
	  claim HyInPick: y :e pickU W.
	  { claim HyWY: y :e pickU W :/\: Y.
	    { rewrite <- Hpick at 1.
	      exact HyW. }
	    exact (binintersectE1 (pickU W) Y y HyWY). }
	    exact (UnionI G y (pickU W) HyInPick
	                  (ReplI GY (fun W0:set => pickU W0) W HWGY)).

- (** <- **)
  assume Hprop: forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam.
  prove compact_space Y Ty.
  prove topology_on Y Ty /\ forall Fam:set, open_cover_of Y Ty Fam -> has_finite_subcover Y Ty Fam.
  apply andI.
  - exact (subspace_topology_is_topology X Tx Y HTx HY).
	  - let Fam0. assume Hcov0: open_cover_of Y Ty Fam0.
	    prove has_finite_subcover Y Ty Fam0.
	    (** Extract cover facts **)
	    (** open_cover_of Y Ty Fam0 is left-associative: (((A /\ B) /\ C) /\ D) **)
	    claim Hcov0_ABC: (topology_on Y Ty /\ Fam0 c= Power Y) /\ Y c= Union Fam0.
	    { exact (andEL ((topology_on Y Ty /\ Fam0 c= Power Y) /\ Y c= Union Fam0)
	                   (forall U:set, U :e Fam0 -> U :e Ty) Hcov0). }
	    claim Hcov0_AB: topology_on Y Ty /\ Fam0 c= Power Y.
	    { exact (andEL (topology_on Y Ty /\ Fam0 c= Power Y) (Y c= Union Fam0) Hcov0_ABC). }
	    claim HF0subPow: Fam0 c= Power Y.
	    { exact (andER (topology_on Y Ty) (Fam0 c= Power Y) Hcov0_AB). }
	    claim HYcov0: Y c= Union Fam0.
	    { exact (andER (topology_on Y Ty /\ Fam0 c= Power Y) (Y c= Union Fam0) Hcov0_ABC). }
	    claim HF0open: forall U:set, U :e Fam0 -> U :e Ty.
	    { exact (andER ((topology_on Y Ty /\ Fam0 c= Power Y) /\ Y c= Union Fam0)
	                   (forall U:set, U :e Fam0 -> U :e Ty) Hcov0). }

    (** For each W in Fam0 choose an ambient open V in Tx with W = V /\ Y. **)
    set Vof := fun W:set => Eps_i (fun V:set => V :e Tx /\ W = V :/\: Y).
    set Fam := {Vof W|W :e Fam0}.
    claim HFamSub: Fam c= Tx.
    { let V. assume HV: V :e Fam.
      prove V :e Tx.
      apply (ReplE_impred Fam0 (fun W:set => Vof W) V HV).
      let W. assume HW: W :e Fam0.
      assume HVeq: V = Vof W.
      rewrite HVeq.
      (** epsilon yields Vof W in Tx **)
      claim HexV: exists V0:set, V0 :e Tx /\ W = V0 :/\: Y.
      { claim HWty: W :e Ty.
        { exact (HF0open W HW). }
        claim HWsub: W :e subspace_topology X Tx Y.
        { claim HdefTy: Ty = subspace_topology X Tx Y.
          { reflexivity. }
          rewrite <- HdefTy.
          exact HWty. }
        exact (subspace_topologyE X Tx Y W HWsub). }
      apply HexV.
      let V0. assume HV0pair: V0 :e Tx /\ W = V0 :/\: Y.
      exact (andEL (Vof W :e Tx) (W = Vof W :/\: Y)
                   (Eps_i_ax (fun V1:set => V1 :e Tx /\ W = V1 :/\: Y) V0 HV0pair)). }

    claim HYcovFam: Y c= Union Fam.
    { let y. assume HyY: y :e Y.
      prove y :e Union Fam.
      claim HyUF0: y :e Union Fam0.
      { exact (HYcov0 y HyY). }
      apply (UnionE_impred Fam0 y HyUF0).
      let W. assume HyW: y :e W.
      assume HW: W :e Fam0.
      prove y :e Union Fam.
      claim HyV: y :e Vof W.
      { (** y in Vof W **)
        claim HexV: exists V0:set, V0 :e Tx /\ W = V0 :/\: Y.
        { claim HWty: W :e Ty.
          { exact (HF0open W HW). }
          claim HWsub: W :e subspace_topology X Tx Y.
          { claim HdefTy: Ty = subspace_topology X Tx Y.
            { reflexivity. }
            rewrite <- HdefTy.
            exact HWty. }
          exact (subspace_topologyE X Tx Y W HWsub). }
        claim Hpick: W = Vof W :/\: Y.
        { apply HexV.
          let V0. assume HV0pair: V0 :e Tx /\ W = V0 :/\: Y.
          exact (andER (Vof W :e Tx) (W = Vof W :/\: Y)
                       (Eps_i_ax (fun V1:set => V1 :e Tx /\ W = V1 :/\: Y) V0 HV0pair)). }
        claim HyWY: y :e Vof W :/\: Y.
        { rewrite <- Hpick at 1.
          exact HyW. }
        exact (binintersectE1 (Vof W) Y y HyWY). }
      claim HVFam: (Vof W) :e Fam.
      { exact (ReplI Fam0 (fun W0:set => Vof W0) W HW). }
      exact (UnionI Fam y (Vof W) HyV HVFam). }

    (** Apply the ambient-cover property to get finite subcover G of Fam **)
    claim Hfin: has_finite_subcover Y Tx Fam.
    { exact (Hprop Fam (andI (Fam c= Tx) (Y c= Union Fam) HFamSub HYcovFam)). }
	    apply Hfin.
	    let G. assume HG: G c= Fam /\ finite G /\ Y c= Union G.
	    (** conjunction is left-associative: (A /\ B) /\ C **)
	    claim HGleft: G c= Fam /\ finite G.
	    { exact (andEL (G c= Fam /\ finite G) (Y c= Union G) HG). }
	    claim HGsub: G c= Fam.
	    { exact (andEL (G c= Fam) (finite G) HGleft). }
	    claim HGfin: finite G.
	    { exact (andER (G c= Fam) (finite G) HGleft). }
	    claim HGcov: Y c= Union G.
	    { exact (andER (G c= Fam /\ finite G) (Y c= Union G) HG). }

	    (** Convert G back to a finite subfamily of Fam0. **)
	    set Wof := fun V:set => Eps_i (fun W:set => W :e Fam0 /\ V = Vof W).
	    set G0 := {Wof V|V :e G}.
	    prove exists G1:set, G1 c= Fam0 /\ finite G1 /\ Y c= Union G1.
	    witness G0.
	    prove G0 c= Fam0 /\ finite G0 /\ Y c= Union G0.
    apply andI.
    - apply andI.
      + (** G0 c= Fam0 **)
        let W. assume HW: W :e G0.
        prove W :e Fam0.
        apply (ReplE_impred G (fun V:set => Wof V) W HW).
        let V. assume HVG: V :e G.
        assume HWof: W = Wof V.
        rewrite HWof.
        (** epsilon picks W in Fam0 **)
        claim HVFam: V :e Fam.
        { exact (HGsub V HVG). }
        claim HexW: exists W0:set, W0 :e Fam0 /\ V = Vof W0.
        { apply (ReplE_impred Fam0 (fun W0:set => Vof W0) V HVFam).
          let W0. assume HW0: W0 :e Fam0.
          assume HVeq: V = Vof W0.
          witness W0.
          apply andI.
          - exact HW0.
          - exact HVeq. }
        apply HexW.
        let W0. assume HW0pair: W0 :e Fam0 /\ V = Vof W0.
        exact (andEL (Wof V :e Fam0) (V = Vof (Wof V))
                     (Eps_i_ax (fun W1:set => W1 :e Fam0 /\ V = Vof W1) W0 HW0pair)).
      + (** finite G0 **)
        exact (Repl_finite (fun V:set => Wof V) G HGfin).
    - (** Y c= Union G0 **)
      let y. assume HyY: y :e Y.
      prove y :e Union G0.
      claim HyUG: y :e Union G.
      { exact (HGcov y HyY). }
      apply (UnionE_impred G y HyUG).
      let V. assume HyV: y :e V.
      assume HVG: V :e G.
      prove y :e Union G0.
      (** show y in Wof V, using that V = Vof (Wof V) and Wof V = (Vof (Wof V)) /\ Y **)
      claim HVFam: V :e Fam.
      { exact (HGsub V HVG). }
      claim HexW: exists W0:set, W0 :e Fam0 /\ V = Vof W0.
      { apply (ReplE_impred Fam0 (fun W0:set => Vof W0) V HVFam).
        let W0. assume HW0: W0 :e Fam0.
        assume HVeq: V = Vof W0.
        witness W0.
        apply andI.
        - exact HW0.
        - exact HVeq. }
      claim HVeq: V = Vof (Wof V).
      { apply HexW.
        let W0. assume HW0pair: W0 :e Fam0 /\ V = Vof W0.
        exact (andER (Wof V :e Fam0) (V = Vof (Wof V))
                     (Eps_i_ax (fun W1:set => W1 :e Fam0 /\ V = Vof W1) W0 HW0pair)). }
      claim HWty: (Wof V) :e Ty.
      { claim HWinFam0: (Wof V) :e Fam0.
        { apply HexW.
          let W0. assume HW0pair: W0 :e Fam0 /\ V = Vof W0.
          exact (andEL (Wof V :e Fam0) (V = Vof (Wof V))
                       (Eps_i_ax (fun W1:set => W1 :e Fam0 /\ V = Vof W1) W0 HW0pair)). }
        exact (HF0open (Wof V) HWinFam0). }
      claim HexV: exists V0:set, V0 :e Tx /\ (Wof V) = V0 :/\: Y.
      { claim HWsub: (Wof V) :e subspace_topology X Tx Y.
        { claim HdefTy: Ty = subspace_topology X Tx Y.
          { reflexivity. }
          rewrite <- HdefTy.
          exact HWty. }
        exact (subspace_topologyE X Tx Y (Wof V) HWsub). }
      claim HWrepr: (Wof V) = (Vof (Wof V)) :/\: Y.
      { apply HexV.
        let V0. assume HV0pair: V0 :e Tx /\ (Wof V) = V0 :/\: Y.
        exact (andER (Vof (Wof V) :e Tx) ((Wof V) = (Vof (Wof V)) :/\: Y)
                     (Eps_i_ax (fun V1:set => V1 :e Tx /\ (Wof V) = V1 :/\: Y) V0 HV0pair)). }
      claim HyInWof: y :e (Wof V).
      { rewrite HWrepr at 1.
        rewrite <- HVeq at 1.
        exact (binintersectI V Y y HyV HyY). }
      exact (UnionI G0 y (Wof V) HyInWof
                    (ReplI G (fun V0:set => Wof V0) V HVG)).
Qed.

(** from §26 Theorem 26.2: closed subspaces of compact spaces are compact **) 
(** LATEX VERSION: If X is compact and Y is closed in X, then Y is compact in the subspace topology. **)
Theorem closed_subspace_compact : forall X Tx Y:set,
  compact_space X Tx -> closed_in X Tx Y -> compact_space Y (subspace_topology X Tx Y).
let X Tx Y.
assume Hcomp: compact_space X Tx.
assume HY: closed_in X Tx Y.
prove compact_space Y (subspace_topology X Tx Y).
set Ty := subspace_topology X Tx Y.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }
claim HsubcoverX: forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.
{ exact (compact_space_subcover_property X Tx Hcomp). }
claim HYsub: Y c= X.
{ exact (closed_in_subset X Tx Y HY). }
(** Choose an open complement U of Y in X. **)
claim HexU: exists U :e Tx, Y = X :\: U.
{ claim HYparts: Y c= X /\ exists U :e Tx, Y = X :\: U.
  { exact (andER (topology_on X Tx) (Y c= X /\ exists U :e Tx, Y = X :\: U) HY). }
  exact (andER (Y c= X) (exists U :e Tx, Y = X :\: U) HYparts). }
apply HexU.
let U.
assume HUpair: U :e Tx /\ Y = X :\: U.
claim HUu: U :e Tx.
{ exact (andEL (U :e Tx) (Y = X :\: U) HUpair). }
claim HYeq: Y = X :\: U.
{ exact (andER (U :e Tx) (Y = X :\: U) HUpair). }

(** Use the characterization via ambient open covers. **)
claim Hequiv:
  (compact_space Y Ty <->
    forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam).
{ exact (compact_subspace_via_ambient_covers X Tx Y HTx HYsub). }
apply (iffER (compact_space Y Ty)
             (forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam)
             Hequiv).

let Fam. assume HFamcov: Fam c= Tx /\ Y c= Union Fam.
claim HFamSub: Fam c= Tx.
{ exact (andEL (Fam c= Tx) (Y c= Union Fam) HFamcov). }
claim HYcovFam: Y c= Union Fam.
{ exact (andER (Fam c= Tx) (Y c= Union Fam) HFamcov). }

(** Extend the cover of Y by adding U; this covers X. **)
set CoverX := Fam :\/: {U}.
claim HcoverX: open_cover_of X Tx CoverX.
{ prove topology_on X Tx /\ CoverX c= Power X /\ X c= Union CoverX /\ (forall V:set, V :e CoverX -> V :e Tx).
  apply andI.
  - (** (CoverX c= Power X) /\ X c= Union CoverX **)
    apply andI.
    + (** topology_on X Tx /\ CoverX c= Power X **)
      apply andI.
      * exact HTx.
      * (** CoverX c= Power X **)
	        let V. assume HV: V :e CoverX.
	        prove V :e Power X.
	        apply (binunionE Fam {U} V HV).
	        - assume HVF: V :e Fam.
	           claim HVTx: V :e Tx.
	           { exact (HFamSub V HVF). }
	           claim HVsub: V c= X.
	           { exact (topology_elem_subset X Tx V HTx HVTx). }
	           exact (PowerI X V HVsub).
	        - assume HVU: V :e {U}.
	           claim HVe: V = U.
	           { exact (SingE U V HVU). }
	           rewrite HVe.
	           claim HUsub: U c= X.
	           { exact (topology_elem_subset X Tx U HTx HUu). }
	           exact (PowerI X U HUsub).
    + (** X c= Union CoverX **)
      let x. assume HxX: x :e X.
      prove x :e Union CoverX.
      apply (xm (x :e U)).
      * assume HxU: x :e U.
        exact (UnionI CoverX x U HxU (binunionI2 Fam {U} U (SingI U))).
      * assume HxnotU: ~ x :e U.
        claim HxY: x :e Y.
        { rewrite HYeq.
          exact (setminusI X U x HxX HxnotU). }
        claim HxUFam: x :e Union Fam.
        { exact (HYcovFam x HxY). }
        apply (UnionE_impred Fam x HxUFam).
        let V. assume HxV: x :e V.
        assume HVF: V :e Fam.
        prove x :e Union CoverX.
        exact (UnionI CoverX x V HxV (binunionI1 Fam {U} V HVF)).
  - (** each element of CoverX is open in Tx **)
    let V. assume HV: V :e CoverX.
    prove V :e Tx.
    apply (binunionE Fam {U} V HV).
    + assume HVF: V :e Fam.
      exact (HFamSub V HVF).
    + assume HVU: V :e {U}.
      claim HVe: V = U.
      { exact (SingE U V HVU). }
      rewrite HVe.
      exact HUu. }

(** Compactness of X gives a finite subcover of CoverX. **)
claim HfinCoverX: has_finite_subcover X Tx CoverX.
{ exact (HsubcoverX CoverX HcoverX). }
apply HfinCoverX.
let G. assume HG: G c= CoverX /\ finite G /\ X c= Union G.
claim HGleft: G c= CoverX /\ finite G.
{ exact (andEL (G c= CoverX /\ finite G) (X c= Union G) HG). }
claim HGsub: G c= CoverX.
{ exact (andEL (G c= CoverX) (finite G) HGleft). }
claim HGfin: finite G.
{ exact (andER (G c= CoverX) (finite G) HGleft). }
claim HGcovX: X c= Union G.
{ exact (andER (G c= CoverX /\ finite G) (X c= Union G) HG). }

(** Remove U from G to obtain a finite subcover drawn from Fam. **)
set G1 := G :\: {U}.
claim HG1subG: G1 c= G.
{ exact (setminus_Subq G {U}). }
claim HG1fin: finite G1.
{ exact (Subq_finite G HGfin G1 HG1subG). }
claim HG1subFam: G1 c= Fam.
{ let V. assume HVG1: V :e G1.
  prove V :e Fam.
  claim HVG: V :e G.
  { exact (setminusE1 G {U} V HVG1). }
  claim HVnotU: V /:e {U}.
  { exact (setminusE2 G {U} V HVG1). }
  claim HVinCover: V :e CoverX.
  { exact (HGsub V HVG). }
  apply (binunionE Fam {U} V HVinCover).
  - assume HVF: V :e Fam.
    exact HVF.
  - assume HVU: V :e {U}.
    prove V :e Fam.
    prove False.
    apply HVnotU.
    exact HVU. }
claim HYcovG1: Y c= Union G1.
{ let y. assume HyY: y :e Y.
  prove y :e Union G1.
  claim HyX: y :e X.
  { exact (HYsub y HyY). }
  claim HyUG: y :e Union G.
  { exact (HGcovX y HyX). }
  apply (UnionE_impred G y HyUG).
  let V. assume HyV: y :e V.
  assume HVG: V :e G.
  prove y :e Union G1.
  claim HVinCover: V :e CoverX.
  { exact (HGsub V HVG). }
  claim HVnotU: V /:e {U}.
  { apply (binunionE Fam {U} V HVinCover).
    - assume HVF: V :e Fam.
      prove V /:e {U}.
      assume HVU: V :e {U}.
      claim HVe: V = U.
      { exact (SingE U V HVU). }
	      (** y in Y implies y not in U **)
	      claim HyNotU: y /:e U.
	      { claim HyYU: y :e X :\: U.
	        { rewrite <- HYeq at 1.
	          exact HyY. }
	        exact (setminusE2 X U y HyYU). }
	      apply HyNotU.
	      rewrite <- HVe.
	      exact HyV.
	    - assume HVU: V :e {U}.
	      prove V /:e {U}.
	      assume HVU2: V :e {U}.
	      claim HVe: V = U.
	      { exact (SingE U V HVU2). }
	      claim HyNotU: y /:e U.
	      { claim HyYU: y :e X :\: U.
	        { rewrite <- HYeq at 1.
	          exact HyY. }
	        exact (setminusE2 X U y HyYU). }
	      apply HyNotU.
	      rewrite <- HVe.
	      exact HyV. }
  claim HVG1: V :e G1.
  { exact (setminusI G {U} V HVG HVnotU). }
  exact (UnionI G1 y V HyV HVG1). }

claim HG1left: G1 c= Fam /\ finite G1.
{ apply andI.
  - exact HG1subFam.
  - exact HG1fin. }
claim HG1triple: G1 c= Fam /\ finite G1 /\ Y c= Union G1.
{ apply andI.
  - exact HG1left.
  - exact HYcovG1. }
exact (has_finite_subcoverI Y Tx Fam G1 HG1triple).
Qed.

(** helper: separating point and compact set in Hausdorff space **)
(** This duplicates the proof of §26 Lemma 26.4, placed here so §26 Theorem 26.3 can use it without forward references. **)
Theorem Hausdorff_separate_point_compact_set_aux : forall X Tx Y x:set,
  Hausdorff_space X Tx -> Y c= X -> compact_space Y (subspace_topology X Tx Y) -> x :e X -> x /:e Y ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
let X Tx Y x.
assume HH: Hausdorff_space X Tx.
assume HYsub: Y c= X.
assume Hcomp: compact_space Y (subspace_topology X Tx Y).
assume HxX: x :e X.
assume Hx: x /:e Y.
prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
set Ty := subspace_topology X Tx Y.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
claim Hsep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ exact (andER (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }

(** Choose V_y and U_y for each y in Y. **)
set Vof := fun y:set =>
  Eps_i (fun V:set => exists U:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty).
set Uof := fun y:set =>
  Eps_i (fun U:set => U :e Tx /\ x :e U /\ U :/\: (Vof y) = Empty).

claim Vof_exists: forall y:set, y :e Y ->
  exists U:set, U :e Tx /\ (Vof y) :e Tx /\ x :e U /\ y :e (Vof y) /\ U :/\: (Vof y) = Empty.
{ let y. assume HyY: y :e Y.
  claim HyX: y :e X.
  { exact (HYsub y HyY). }
  claim Hneq: x <> y.
  { assume Heq: x = y.
    apply Hx.
    rewrite Heq.
    exact HyY. }
  claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
  { exact (Hsep x y HxX HyX Hneq). }
  apply Hex.
  let U0. assume HexV0: exists V0:set, U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ y :e V0 /\ U0 :/\: V0 = Empty.
  apply HexV0.
  let V0. assume HUV0: U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ y :e V0 /\ U0 :/\: V0 = Empty.
  claim HpV0: exists U:set, U :e Tx /\ V0 :e Tx /\ x :e U /\ y :e V0 /\ U :/\: V0 = Empty.
  { witness U0.
    exact HUV0. }
  exact (Eps_i_ax (fun V:set => exists U:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty) V0 HpV0). }

claim Vof_in_Tx: forall y:set, y :e Y -> (Vof y) :e Tx.
{ let y. assume HyY: y :e Y.
  apply (Vof_exists y HyY).
  let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
  (** conjunction is left-associative **)
  claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
  { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                 (U0 :/\: (Vof y) = Empty) HU0). }
  claim HU0A1: (U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0.
  { exact (andEL ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }
  claim HU0AB: U0 :e Tx /\ (Vof y) :e Tx.
  { exact (andEL (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
  exact (andER (U0 :e Tx) ((Vof y) :e Tx) HU0AB). }

claim y_in_Vof: forall y:set, y :e Y -> y :e (Vof y).
{ let y. assume HyY: y :e Y.
  apply (Vof_exists y HyY).
  let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
  claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
  { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                 (U0 :/\: (Vof y) = Empty) HU0). }
  exact (andER ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }

claim Uof_props: forall y:set, y :e Y ->
  (Uof y) :e Tx /\ x :e (Uof y) /\ (Uof y) :/\: (Vof y) = Empty.
{ let y. assume HyY: y :e Y.
  claim HexU: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 :/\: (Vof y) = Empty.
  { apply (Vof_exists y HyY).
    let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
    witness U0.
    claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
    { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                   (U0 :/\: (Vof y) = Empty) HU0). }
    claim HU0A1: (U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0.
    { exact (andEL ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }
    claim HU0AB: U0 :e Tx /\ (Vof y) :e Tx.
    { exact (andEL (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
    claim HU0Tx: U0 :e Tx.
    { exact (andEL (U0 :e Tx) ((Vof y) :e Tx) HU0AB). }
    claim HxU0: x :e U0.
    { exact (andER (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
    claim HU0disj: U0 :/\: (Vof y) = Empty.
    { exact (andER (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                   (U0 :/\: (Vof y) = Empty) HU0). }
    claim HU0pair: U0 :e Tx /\ x :e U0.
    { apply andI.
      - exact HU0Tx.
      - exact HxU0. }
    exact (andI (U0 :e Tx /\ x :e U0) (U0 :/\: (Vof y) = Empty) HU0pair HU0disj). }
  apply HexU.
  let U0. assume HU0: U0 :e Tx /\ x :e U0 /\ U0 :/\: (Vof y) = Empty.
  exact (Eps_i_ax (fun U:set => U :e Tx /\ x :e U /\ U :/\: (Vof y) = Empty) U0 HU0). }

(** Finite open cover of Y by the ambient opens Vof y. **)
set VFam := {Vof y|y :e Y}.
claim HVFamSub: VFam c= Tx.
{ let V. assume HV: V :e VFam.
  apply (ReplE_impred Y (fun y0:set => Vof y0) V HV).
  let y. assume HyY: y :e Y.
  assume HVe: V = Vof y.
  rewrite HVe.
  exact (Vof_in_Tx y HyY). }
claim HYcovVFam: Y c= Union VFam.
{ let y. assume HyY: y :e Y.
  prove y :e Union VFam.
  exact (UnionI VFam y (Vof y) (y_in_Vof y HyY) (ReplI Y (fun y0:set => Vof y0) y HyY)). }

(** Use compactness of Y in the subspace topology to obtain a finite subcover from VFam. **)
claim Hcovprop: forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam.
{ exact (iffEL (compact_space Y Ty)
               (forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam)
               (compact_subspace_via_ambient_covers X Tx Y HTx HYsub) Hcomp). }
claim Hfin: has_finite_subcover Y Tx VFam.
{ exact (Hcovprop VFam (andI (VFam c= Tx) (Y c= Union VFam) HVFamSub HYcovVFam)). }
apply Hfin.
let G. assume HG: G c= VFam /\ finite G /\ Y c= Union G.
claim HGleft: G c= VFam /\ finite G.
{ exact (andEL (G c= VFam /\ finite G) (Y c= Union G) HG). }
claim HGsub: G c= VFam.
{ exact (andEL (G c= VFam) (finite G) HGleft). }
claim HGfin: finite G.
{ exact (andER (G c= VFam) (finite G) HGleft). }
claim HGcov: Y c= Union G.
{ exact (andER (G c= VFam /\ finite G) (Y c= Union G) HG). }

(** Build the separating open sets U and V from the finite subcover G. **)
set V := Union G.
claim HGTX: G c= Tx.
{ let W. assume HW: W :e G.
  claim HWVFam: W :e VFam.
  { exact (HGsub W HW). }
  exact (HVFamSub W HWVFam). }
claim HVopen: V :e Tx.
{ exact (topology_union_closed X Tx G HTx HGTX). }
claim HYsubV: Y c= V.
{ exact HGcov. }

set pickY := fun V0:set => Eps_i (fun y0:set => y0 :e Y /\ V0 = Vof y0).
set UFam := {Uof (pickY V0)|V0 :e G}.
set U := intersection_of_family X UFam.

claim HUFamSub: UFam c= Tx.
{ let U0. assume HU0: U0 :e UFam.
  apply (ReplE_impred G (fun V0:set => Uof (pickY V0)) U0 HU0).
  let V0. assume HV0G: V0 :e G.
  assume HU0eq: U0 = Uof (pickY V0).
  rewrite HU0eq.
  claim Hpick: pickY V0 :e Y.
  { claim HV0VFam: V0 :e VFam.
    { exact (HGsub V0 HV0G). }
    apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
    let y0. assume Hy0Y: y0 :e Y.
    assume HV0eq: V0 = Vof y0.
    claim Hp: (y0 :e Y /\ V0 = Vof y0).
    { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
    exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0))
                 (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp)). }
  claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (Uof_props (pickY V0) Hpick). }
  claim HUof1: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)).
  { exact (andEL ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                 ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
  exact (andEL ((Uof (pickY V0)) :e Tx) (x :e (Uof (pickY V0))) HUof1). }

claim HUFamFin: finite UFam.
{ exact (Repl_finite (fun V0:set => Uof (pickY V0)) G HGfin). }
claim HUFamPow: UFam :e Power Tx.
{ exact (PowerI Tx UFam HUFamSub). }
claim HUopen: U :e Tx.
{ exact (finite_intersection_in_topology X Tx UFam HTx HUFamPow HUFamFin). }

claim HxU: x :e U.
{ prove x :e intersection_of_family X UFam.
  prove x :e {z :e X | forall T:set, T :e UFam -> z :e T}.
  apply SepI.
  - exact HxX.
  - let W. assume HW: W :e UFam.
    apply (ReplE_impred G (fun V0:set => Uof (pickY V0)) W HW).
    let V0. assume HV0G: V0 :e G.
    assume HWeq: W = Uof (pickY V0).
    rewrite HWeq.
    claim Hpick: pickY V0 :e Y.
    { claim HV0VFam: V0 :e VFam.
      { exact (HGsub V0 HV0G). }
      apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
      let y0. assume Hy0Y: y0 :e Y.
      assume HV0eq: V0 = Vof y0.
      claim Hp: (y0 :e Y /\ V0 = Vof y0).
      { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
      exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0))
                   (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp)). }
    claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
    { exact (Uof_props (pickY V0) Hpick). }
    claim HUof1: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)).
    { exact (andEL ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                   ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
    exact (andER ((Uof (pickY V0)) :e Tx) (x :e (Uof (pickY V0))) HUof1). }

claim HUVdisj: U :/\: V = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e U :/\: V.
  prove False.
  claim HzU: z :e U.
  { exact (binintersectE1 U V z Hz). }
  claim HzV: z :e V.
  { exact (binintersectE2 U V z Hz). }
  claim HzUG: z :e Union G.
  { exact HzV. }
  apply (UnionE_impred G z HzUG).
  let V0. assume HzV0: z :e V0.
  assume HV0G: V0 :e G.
  claim HV0VFam: V0 :e VFam.
  { exact (HGsub V0 HV0G). }
  apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
  let y0. assume Hy0Y: y0 :e Y.
  assume HV0eq: V0 = Vof y0.
  claim Hp: y0 :e Y /\ V0 = Vof y0.
  { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
  claim HpickY: pickY V0 :e Y /\ V0 = Vof (pickY V0).
  { exact (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp). }
  claim Hpick: pickY V0 :e Y.
  { exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0)) HpickY). }
  claim HV0rep: V0 = Vof (pickY V0).
  { exact (andER (pickY V0 :e Y) (V0 = Vof (pickY V0)) HpickY). }
  claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (Uof_props (pickY V0) Hpick). }
  claim HUofdisj: (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (andER ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                 ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
  claim HzUof: z :e (Uof (pickY V0)).
  { claim Hall: forall T:set, T :e UFam -> z :e T.
    { exact (SepE2 X (fun z0:set => forall T:set, T :e UFam -> z0 :e T) z HzU). }
    apply Hall.
    exact (ReplI G (fun V1:set => Uof (pickY V1)) V0 HV0G). }
  claim HzVof: z :e (Vof (pickY V0)).
  { rewrite <- HV0rep at 1.
    exact HzV0. }
  claim HzInt: z :e (Uof (pickY V0)) :/\: (Vof (pickY V0)).
  { exact (binintersectI (Uof (pickY V0)) (Vof (pickY V0)) z HzUof HzVof). }
  claim HzEmpty: z :e Empty.
  { rewrite <- HUofdisj at 1.
    exact HzInt. }
  exact (EmptyE z HzEmpty False). }

witness U.
witness V.
prove U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - exact HUopen.
      - exact HVopen.
    * exact HxU.
  + exact HYsubV.
- exact HUVdisj.
Qed.

(** from §26 Theorem 26.3: compact subspaces of Hausdorff spaces are closed **) 
(** LATEX VERSION: In a Hausdorff space, every compact subspace is closed. **)
Theorem compact_subspace_in_Hausdorff_closed : forall X Tx Y:set,
  Hausdorff_space X Tx -> Y c= X -> compact_space Y (subspace_topology X Tx Y) -> closed_in X Tx Y.
let X Tx Y.
assume HH: Hausdorff_space X Tx.
assume HYsub: Y c= X.
assume Hcomp: compact_space Y (subspace_topology X Tx Y).
prove closed_in X Tx Y.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
prove topology_on X Tx /\ (Y c= X /\ exists U :e Tx, Y = X :\: U).
apply andI.
- exact HTx.
- prove Y c= X /\ exists U :e Tx, Y = X :\: U.
  apply andI.
  + exact HYsub.
  + (** show X \\ Y is open and use double complement **)
    witness (X :\: Y).
    apply andI.
    * (** X\\Y :e Tx **)
      set UFam := {U :e Tx | exists x0:set, x0 :e X :\: Y /\ x0 :e U /\ U :/\: Y = Empty}.
      claim HUFamSub: UFam c= Tx.
      { let U. assume HU: U :e UFam.
        exact (SepE1 Tx (fun U0:set => exists x0:set, x0 :e X :\: Y /\ x0 :e U0 /\ U0 :/\: Y = Empty) U HU). }
      claim HUnionEq: Union UFam = X :\: Y.
      { apply set_ext.
        - let z. assume Hz: z :e Union UFam.
          prove z :e X :\: Y.
          apply (UnionE_impred UFam z Hz).
          let U. assume HzU: z :e U.
          assume HU: U :e UFam.
          claim HUtx: U :e Tx.
          { exact (SepE1 Tx (fun U0:set => exists x0:set, x0 :e X :\: Y /\ x0 :e U0 /\ U0 :/\: Y = Empty) U HU). }
          claim HUsubX: U c= X.
          { exact (topology_elem_subset X Tx U HTx HUtx). }
          claim HzX: z :e X.
          { exact (HUsubX z HzU). }
          claim Hpred: exists x0:set, x0 :e X :\: Y /\ x0 :e U /\ U :/\: Y = Empty.
          { exact (SepE2 Tx (fun U0:set => exists x0:set, x0 :e X :\: Y /\ x0 :e U0 /\ U0 :/\: Y = Empty) U HU). }
          apply Hpred.
          let x0. assume Hx0: x0 :e X :\: Y /\ x0 :e U /\ U :/\: Y = Empty.
          claim HUYempty: U :/\: Y = Empty.
          { exact (andER (x0 :e X :\: Y /\ x0 :e U) (U :/\: Y = Empty) Hx0). }
          claim HzNotY: z /:e Y.
          { assume HzY: z :e Y.
            claim HzInt: z :e U :/\: Y.
            { exact (binintersectI U Y z HzU HzY). }
	            claim HzEmpty: z :e Empty.
	            { rewrite <- HUYempty at 1.
	              exact HzInt. }
	            exact (EmptyE z HzEmpty False). }
	          exact (setminusI X Y z HzX HzNotY).
        - let z. assume Hz: z :e X :\: Y.
          prove z :e Union UFam.
          claim HzX: z :e X.
          { exact (setminusE1 X Y z Hz). }
          claim HzNotY: z /:e Y.
          { exact (setminusE2 X Y z Hz). }
          claim HexUV: exists U V:set, U :e Tx /\ V :e Tx /\ z :e U /\ Y c= V /\ U :/\: V = Empty.
          { exact (Hausdorff_separate_point_compact_set_aux X Tx Y z HH HYsub Hcomp HzX HzNotY). }
          apply HexUV.
          let U. assume HexV: exists V:set, U :e Tx /\ V :e Tx /\ z :e U /\ Y c= V /\ U :/\: V = Empty.
          apply HexV.
          let V. assume Hconj: U :e Tx /\ V :e Tx /\ z :e U /\ Y c= V /\ U :/\: V = Empty.
          claim HconjA: ((U :e Tx /\ V :e Tx) /\ z :e U) /\ Y c= V.
          { exact (andEL (((U :e Tx /\ V :e Tx) /\ z :e U) /\ Y c= V) (U :/\: V = Empty) Hconj). }
          claim HUVempty: U :/\: V = Empty.
          { exact (andER (((U :e Tx /\ V :e Tx) /\ z :e U) /\ Y c= V) (U :/\: V = Empty) Hconj). }
          claim HUVz: (U :e Tx /\ V :e Tx) /\ z :e U.
          { exact (andEL ((U :e Tx /\ V :e Tx) /\ z :e U) (Y c= V) HconjA). }
          claim HUtx: U :e Tx.
          { exact (andEL (U :e Tx) (V :e Tx)
                         (andEL (U :e Tx /\ V :e Tx) (z :e U) HUVz)). }
          claim HzU: z :e U.
          { exact (andER (U :e Tx /\ V :e Tx) (z :e U) HUVz). }
          claim HYsubV: Y c= V.
          { exact (andER ((U :e Tx /\ V :e Tx) /\ z :e U) (Y c= V) HconjA). }
          (** show U /\\ Y = Empty using Y c= V and U /\\ V = Empty **)
          claim HUYsub: U :/\: Y c= U :/\: V.
          { let t. assume Ht: t :e U :/\: Y.
            prove t :e U :/\: V.
            claim HtU: t :e U.
            { exact (binintersectE1 U Y t Ht). }
            claim HtY: t :e Y.
            { exact (binintersectE2 U Y t Ht). }
            claim HtV: t :e V.
            { exact (HYsubV t HtY). }
            exact (binintersectI U V t HtU HtV). }
          claim HUYempty: U :/\: Y = Empty.
          { apply Empty_Subq_eq.
            let t. assume Ht: t :e U :/\: Y.
            prove False.
            claim HtUV: t :e U :/\: V.
            { exact (HUYsub t Ht). }
            claim HtEmpty: t :e Empty.
            { rewrite <- HUVempty at 1.
              exact HtUV. }
            exact (EmptyE t HtEmpty False). }
          claim HzXY: z :e X :\: Y.
          { exact (setminusI X Y z HzX HzNotY). }
          claim HUinUFam: U :e UFam.
          { apply (SepI Tx
                        (fun U0:set => exists x0:set, x0 :e X :\: Y /\ x0 :e U0 /\ U0 :/\: Y = Empty)
                        U
                        HUtx).
            witness z.
            (** conjunction is left-associative **)
            apply andI.
            + apply andI.
              * exact HzXY.
              * exact HzU.
            + exact HUYempty. }
          exact (UnionI UFam z U HzU HUinUFam). }
      (** Union UFam is open, hence X\\Y is open **)
      rewrite <- HUnionEq at 1.
      exact (topology_union_closed X Tx UFam HTx HUFamSub).
	    * (** Y = X \\ (X \\ Y) **)
	      symmetry.
	      exact (setminus_setminus_eq X Y HYsub).
Qed.

(** from §26 Lemma 26.4: separating point and compact set in Hausdorff space **)
(** LATEX VERSION: In a Hausdorff space, a point not in a compact set can be separated from that compact set by disjoint open sets. **)
(** FIXED: Point disjointness is x /:e Y (x not an element of Y), not x :/\: Y = Empty which treats x as a set. **)
Theorem Hausdorff_separate_point_compact_set : forall X Tx Y x:set,
  Hausdorff_space X Tx -> Y c= X -> compact_space Y (subspace_topology X Tx Y) -> x :e X -> x /:e Y ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
let X Tx Y x.
assume HH: Hausdorff_space X Tx.
assume HYsub: Y c= X.
assume Hcomp: compact_space Y (subspace_topology X Tx Y).
assume HxX: x :e X.
assume Hx: x /:e Y.
prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
set Ty := subspace_topology X Tx Y.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
claim Hsep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
  exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
{ exact (andER (topology_on X Tx)
               (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }

(** Choose V_y and U_y for each y in Y. **)
set Vof := fun y:set =>
  Eps_i (fun V:set => exists U:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty).
set Uof := fun y:set =>
  Eps_i (fun U:set => U :e Tx /\ x :e U /\ U :/\: (Vof y) = Empty).

claim Vof_exists: forall y:set, y :e Y ->
  exists U:set, U :e Tx /\ (Vof y) :e Tx /\ x :e U /\ y :e (Vof y) /\ U :/\: (Vof y) = Empty.
{ let y. assume HyY: y :e Y.
  claim HyX: y :e X.
  { exact (HYsub y HyY). }
  claim Hneq: x <> y.
  { assume Heq: x = y.
    apply Hx.
    rewrite Heq.
    exact HyY. }
  claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
  { exact (Hsep x y HxX HyX Hneq). }
  apply Hex.
  let U0. assume HexV0: exists V0:set, U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ y :e V0 /\ U0 :/\: V0 = Empty.
  apply HexV0.
  let V0. assume HUV0: U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ y :e V0 /\ U0 :/\: V0 = Empty.
  claim HpV0: exists U:set, U :e Tx /\ V0 :e Tx /\ x :e U /\ y :e V0 /\ U :/\: V0 = Empty.
  { witness U0.
    exact HUV0. }
  exact (Eps_i_ax (fun V:set => exists U:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty) V0 HpV0). }

claim Vof_in_Tx: forall y:set, y :e Y -> (Vof y) :e Tx.
{ let y. assume HyY: y :e Y.
  apply (Vof_exists y HyY).
  let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
  (** conjunction is left-associative **)
  claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
  { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                 (U0 :/\: (Vof y) = Empty) HU0). }
  claim HU0A1: (U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0.
  { exact (andEL ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }
  claim HU0AB: U0 :e Tx /\ (Vof y) :e Tx.
  { exact (andEL (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
  exact (andER (U0 :e Tx) ((Vof y) :e Tx) HU0AB). }

claim y_in_Vof: forall y:set, y :e Y -> y :e (Vof y).
{ let y. assume HyY: y :e Y.
  apply (Vof_exists y HyY).
  let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
  claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
  { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
                 (U0 :/\: (Vof y) = Empty) HU0). }
  exact (andER ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }

claim Uof_props: forall y:set, y :e Y ->
  (Uof y) :e Tx /\ x :e (Uof y) /\ (Uof y) :/\: (Vof y) = Empty.
{ let y. assume HyY: y :e Y.
  claim HexU: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 :/\: (Vof y) = Empty.
  { apply (Vof_exists y HyY).
	    let U0. assume HU0: U0 :e Tx /\ (Vof y) :e Tx /\ x :e U0 /\ y :e (Vof y) /\ U0 :/\: (Vof y) = Empty.
	    witness U0.
	    claim HU0A: ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y).
	    { exact (andEL (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
	                   (U0 :/\: (Vof y) = Empty) HU0). }
	    claim HU0A1: (U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0.
	    { exact (andEL ((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) (y :e (Vof y)) HU0A). }
	    claim HU0AB: U0 :e Tx /\ (Vof y) :e Tx.
	    { exact (andEL (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
	    claim HU0Tx: U0 :e Tx.
	    { exact (andEL (U0 :e Tx) ((Vof y) :e Tx) HU0AB). }
	    claim HxU0: x :e U0.
	    { exact (andER (U0 :e Tx /\ (Vof y) :e Tx) (x :e U0) HU0A1). }
		    claim HU0disj: U0 :/\: (Vof y) = Empty.
		    { exact (andER (((U0 :e Tx /\ (Vof y) :e Tx) /\ x :e U0) /\ y :e (Vof y))
		                   (U0 :/\: (Vof y) = Empty) HU0). }
		    claim HU0pair: U0 :e Tx /\ x :e U0.
		    { apply andI.
		      - exact HU0Tx.
		      - exact HxU0. }
		    exact (andI (U0 :e Tx /\ x :e U0) (U0 :/\: (Vof y) = Empty) HU0pair HU0disj). }
  apply HexU.
  let U0. assume HU0: U0 :e Tx /\ x :e U0 /\ U0 :/\: (Vof y) = Empty.
  exact (Eps_i_ax (fun U:set => U :e Tx /\ x :e U /\ U :/\: (Vof y) = Empty) U0 HU0). }

(** Finite open cover of Y by the ambient opens Vof y. **)
set VFam := {Vof y|y :e Y}.
claim HVFamSub: VFam c= Tx.
{ let V. assume HV: V :e VFam.
  apply (ReplE_impred Y (fun y0:set => Vof y0) V HV).
  let y. assume HyY: y :e Y.
  assume HVe: V = Vof y.
  rewrite HVe.
  exact (Vof_in_Tx y HyY). }
claim HYcovVFam: Y c= Union VFam.
{ let y. assume HyY: y :e Y.
  prove y :e Union VFam.
  exact (UnionI VFam y (Vof y) (y_in_Vof y HyY) (ReplI Y (fun y0:set => Vof y0) y HyY)). }

(** Use compactness of Y in the subspace topology to obtain a finite subcover from VFam. **)
claim Hcovprop: forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam.
{ exact (iffEL (compact_space Y Ty)
               (forall Fam:set, (Fam c= Tx /\ Y c= Union Fam) -> has_finite_subcover Y Tx Fam)
               (compact_subspace_via_ambient_covers X Tx Y HTx HYsub) Hcomp). }
claim Hfin: has_finite_subcover Y Tx VFam.
{ exact (Hcovprop VFam (andI (VFam c= Tx) (Y c= Union VFam) HVFamSub HYcovVFam)). }
apply Hfin.
let G. assume HG: G c= VFam /\ finite G /\ Y c= Union G.
claim HGleft: G c= VFam /\ finite G.
{ exact (andEL (G c= VFam /\ finite G) (Y c= Union G) HG). }
claim HGsub: G c= VFam.
{ exact (andEL (G c= VFam) (finite G) HGleft). }
claim HGfin: finite G.
{ exact (andER (G c= VFam) (finite G) HGleft). }
claim HGcov: Y c= Union G.
{ exact (andER (G c= VFam /\ finite G) (Y c= Union G) HG). }

(** Build the separating open sets U and V from the finite subcover G. **)
set V := Union G.
claim HGTX: G c= Tx.
{ let W. assume HW: W :e G.
  claim HWVFam: W :e VFam.
  { exact (HGsub W HW). }
  exact (HVFamSub W HWVFam). }
claim HVopen: V :e Tx.
{ exact (topology_union_closed X Tx G HTx HGTX). }
claim HYsubV: Y c= V.
{ exact HGcov. }

set pickY := fun V0:set => Eps_i (fun y0:set => y0 :e Y /\ V0 = Vof y0).
set UFam := {Uof (pickY V0)|V0 :e G}.
set U := intersection_of_family X UFam.

claim HUFamSub: UFam c= Tx.
{ let U0. assume HU0: U0 :e UFam.
  apply (ReplE_impred G (fun V0:set => Uof (pickY V0)) U0 HU0).
  let V0. assume HV0G: V0 :e G.
  assume HU0eq: U0 = Uof (pickY V0).
  rewrite HU0eq.
  claim Hpick: pickY V0 :e Y.
  { claim HV0VFam: V0 :e VFam.
    { exact (HGsub V0 HV0G). }
    apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
    let y0. assume Hy0Y: y0 :e Y.
    assume HV0eq: V0 = Vof y0.
    claim Hp: (y0 :e Y /\ V0 = Vof y0).
    { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
    exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0))
                 (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp)). }
  claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (Uof_props (pickY V0) Hpick). }
  claim HUof1: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)).
  { exact (andEL ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                 ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
  exact (andEL ((Uof (pickY V0)) :e Tx) (x :e (Uof (pickY V0))) HUof1). }

claim HUFamFin: finite UFam.
{ exact (Repl_finite (fun V0:set => Uof (pickY V0)) G HGfin). }
claim HUFamPow: UFam :e Power Tx.
{ exact (PowerI Tx UFam HUFamSub). }
claim HUopen: U :e Tx.
{ exact (finite_intersection_in_topology X Tx UFam HTx HUFamPow HUFamFin). }

claim HxU: x :e U.
{ prove x :e intersection_of_family X UFam.
  prove x :e {z :e X | forall T:set, T :e UFam -> z :e T}.
  apply SepI.
  - exact HxX.
  - let W. assume HW: W :e UFam.
    apply (ReplE_impred G (fun V0:set => Uof (pickY V0)) W HW).
    let V0. assume HV0G: V0 :e G.
    assume HWeq: W = Uof (pickY V0).
    rewrite HWeq.
    claim Hpick: pickY V0 :e Y.
    { claim HV0VFam: V0 :e VFam.
      { exact (HGsub V0 HV0G). }
      apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
      let y0. assume Hy0Y: y0 :e Y.
      assume HV0eq: V0 = Vof y0.
      claim Hp: (y0 :e Y /\ V0 = Vof y0).
      { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
      exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0))
                   (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp)). }
    claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
    { exact (Uof_props (pickY V0) Hpick). }
    claim HUof1: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)).
    { exact (andEL ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                   ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
    exact (andER ((Uof (pickY V0)) :e Tx) (x :e (Uof (pickY V0))) HUof1). }

claim HUVdisj: U :/\: V = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e U :/\: V.
  prove False.
  claim HzU: z :e U.
  { exact (binintersectE1 U V z Hz). }
  claim HzV: z :e V.
  { exact (binintersectE2 U V z Hz). }
  claim HzUG: z :e Union G.
  { exact HzV. }
  apply (UnionE_impred G z HzUG).
  let V0. assume HzV0: z :e V0.
  assume HV0G: V0 :e G.
  claim HV0VFam: V0 :e VFam.
  { exact (HGsub V0 HV0G). }
  apply (ReplE_impred Y (fun y0:set => Vof y0) V0 HV0VFam).
  let y0. assume Hy0Y: y0 :e Y.
  assume HV0eq: V0 = Vof y0.
  claim Hp: y0 :e Y /\ V0 = Vof y0.
  { exact (andI (y0 :e Y) (V0 = Vof y0) Hy0Y HV0eq). }
  claim HpickY: pickY V0 :e Y /\ V0 = Vof (pickY V0).
  { exact (Eps_i_ax (fun y:set => y :e Y /\ V0 = Vof y) y0 Hp). }
  claim Hpick: pickY V0 :e Y.
  { exact (andEL (pickY V0 :e Y) (V0 = Vof (pickY V0)) HpickY). }
  claim HV0rep: V0 = Vof (pickY V0).
  { exact (andER (pickY V0 :e Y) (V0 = Vof (pickY V0)) HpickY). }
  claim HUof: (Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)) /\ (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (Uof_props (pickY V0) Hpick). }
  claim HUofdisj: (Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty.
  { exact (andER ((Uof (pickY V0)) :e Tx /\ x :e (Uof (pickY V0)))
                 ((Uof (pickY V0)) :/\: (Vof (pickY V0)) = Empty) HUof). }
  claim HzUof: z :e (Uof (pickY V0)).
  { claim Hall: forall T:set, T :e UFam -> z :e T.
    { exact (SepE2 X (fun z0:set => forall T:set, T :e UFam -> z0 :e T) z HzU). }
    apply Hall.
    exact (ReplI G (fun V1:set => Uof (pickY V1)) V0 HV0G). }
  claim HzVof: z :e (Vof (pickY V0)).
  { rewrite <- HV0rep at 1.
    exact HzV0. }
  claim HzInt: z :e (Uof (pickY V0)) :/\: (Vof (pickY V0)).
  { exact (binintersectI (Uof (pickY V0)) (Vof (pickY V0)) z HzUof HzVof). }
  claim HzEmpty: z :e Empty.
  { rewrite <- HUofdisj at 1.
    exact HzInt. }
  exact (EmptyE z HzEmpty False). }

witness U.
witness V.
prove U :e Tx /\ V :e Tx /\ x :e U /\ Y c= V /\ U :/\: V = Empty.
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - exact HUopen.
      - exact HVopen.
    * exact HxU.
  + exact HYsubV.
- exact HUVdisj.
Qed.

(** from §26 Theorem 26.5: compactness preserved under continuous maps **) 
(** LATEX VERSION: The continuous image of a compact space is compact (in the subspace topology on the image). **)
Definition image_of_fun : set -> set -> set := fun f X => image_of f X.

Theorem continuous_image_compact : forall X Tx Y Ty f:set,
  compact_space X Tx -> continuous_map X Tx Y Ty f ->
  compact_space (image_of_fun f X) (subspace_topology Y Ty (image_of_fun f X)).
let X Tx Y Ty f.
assume Hcomp: compact_space X Tx.
assume Hf: continuous_map X Tx Y Ty f.
prove compact_space (image_of_fun f X) (subspace_topology Y Ty (image_of_fun f X)).
set Img := image_of_fun f X.
set Timg := subspace_topology Y Ty Img.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }
claim HsubcoverX: forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.
{ exact (compact_space_subcover_property X Tx Hcomp). }

claim Hf_left: ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y) /\ (forall V:set, V :e Ty -> preimage_of X f V :e Tx).
{ exact Hf. }
claim Hf_mid: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf_left). }
claim Hf_pre: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hf_left). }
claim HtopXY: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hf_mid). }
claim HTy: topology_on Y Ty.
{ exact (andER (topology_on X Tx) (topology_on Y Ty) HtopXY). }
claim Hfun: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hf_mid). }

claim HImgSubY: Img c= Y.
{ let y. assume Hy: y :e Img.
  apply (ReplE_impred X (fun x0:set => apply_fun f x0) y Hy).
  let x0. assume Hx0X: x0 :e X.
  assume Heq: y = apply_fun f x0.
  rewrite Heq.
  exact (Hfun x0 Hx0X). }

claim Hprop: forall Fam:set, (Fam c= Ty /\ Img c= Union Fam) -> has_finite_subcover Img Ty Fam.
{ let Fam. assume Hcov: Fam c= Ty /\ Img c= Union Fam.
  claim HFamSub: Fam c= Ty.
  { exact (andEL (Fam c= Ty) (Img c= Union Fam) Hcov). }
  claim HImgCov: Img c= Union Fam.
  { exact (andER (Fam c= Ty) (Img c= Union Fam) Hcov). }

  set PreFam := {preimage_of X f V|V :e Fam}.

  claim HPrePow: PreFam c= Power X.
  { let W. assume HW: W :e PreFam.
    apply (ReplE_impred Fam (fun V0:set => preimage_of X f V0) W HW).
    let V0. assume HV0: V0 :e Fam.
    assume HWeq: W = preimage_of X f V0.
    rewrite HWeq.
    prove preimage_of X f V0 :e Power X.
    apply PowerI.
    let x0. assume Hx0: x0 :e preimage_of X f V0.
    apply (SepE X (fun u:set => apply_fun f u :e V0) x0 Hx0).
    assume Hx0X. assume _. exact Hx0X. }

  claim HPreOpen: forall W:set, W :e PreFam -> W :e Tx.
  { let W. assume HW: W :e PreFam.
    apply (ReplE_impred Fam (fun V0:set => preimage_of X f V0) W HW).
    let V0. assume HV0: V0 :e Fam.
    assume HWeq: W = preimage_of X f V0.
    claim HV0Ty: V0 :e Ty.
    { exact (HFamSub V0 HV0). }
    rewrite HWeq.
    exact (Hf_pre V0 HV0Ty). }

  claim HXcov: X c= Union PreFam.
  { let x0. assume Hx0X: x0 :e X.
    prove x0 :e Union PreFam.
    claim HyImg: apply_fun f x0 :e Img.
    { exact (ReplI X (fun x1:set => apply_fun f x1) x0 Hx0X). }
    claim HyUnion: apply_fun f x0 :e Union Fam.
    { exact (HImgCov (apply_fun f x0) HyImg). }
    apply (UnionE_impred Fam (apply_fun f x0) HyUnion).
    let V0. assume HyV0: apply_fun f x0 :e V0.
    assume HV0: V0 :e Fam.
    claim Hx0Pre: x0 :e preimage_of X f V0.
    { prove x0 :e {u :e X | apply_fun f u :e V0}.
      apply SepI.
      - exact Hx0X.
      - exact HyV0. }
    exact (UnionI PreFam x0 (preimage_of X f V0) Hx0Pre
                 (ReplI Fam (fun V1:set => preimage_of X f V1) V0 HV0)). }

  claim HopenCov: open_cover_of X Tx PreFam.
  { prove topology_on X Tx /\ PreFam c= Power X /\ X c= Union PreFam /\ (forall U:set, U :e PreFam -> U :e Tx).
    apply andI.
    - (** left-associative: ((A /\ B) /\ C) **)
      apply andI.
      + apply andI.
        * exact HTx.
        * exact HPrePow.
      + exact HXcov.
    - exact HPreOpen. }

  claim HfinPre: has_finite_subcover X Tx PreFam.
  { exact (HsubcoverX PreFam HopenCov). }

  apply HfinPre.
  let Gpre. assume HGpre: Gpre c= PreFam /\ finite Gpre /\ X c= Union Gpre.
  claim HGpreLeft: Gpre c= PreFam /\ finite Gpre.
  { exact (andEL (Gpre c= PreFam /\ finite Gpre) (X c= Union Gpre) HGpre). }
  claim HGpreSub: Gpre c= PreFam.
  { exact (andEL (Gpre c= PreFam) (finite Gpre) HGpreLeft). }
  claim HGpreFin: finite Gpre.
  { exact (andER (Gpre c= PreFam) (finite Gpre) HGpreLeft). }
  claim HXcovGpre: X c= Union Gpre.
  { exact (andER (Gpre c= PreFam /\ finite Gpre) (X c= Union Gpre) HGpre). }

  set pickV := fun W:set => Eps_i (fun V0:set => V0 :e Fam /\ W = preimage_of X f V0).
  set G := {pickV W|W :e Gpre}.

  claim HGsubFam: G c= Fam.
  { let V0. assume HV0: V0 :e G.
    apply (ReplE_impred Gpre (fun W0:set => pickV W0) V0 HV0).
    let W0. assume HW0G: W0 :e Gpre.
    assume HV0eq: V0 = pickV W0.
    claim HW0Pre: W0 :e PreFam.
    { exact (HGpreSub W0 HW0G). }
    claim Hex: exists V1:set, V1 :e Fam /\ W0 = preimage_of X f V1.
    { apply (ReplE_impred Fam (fun V2:set => preimage_of X f V2) W0 HW0Pre).
      let V2. assume HV2: V2 :e Fam.
      assume HW0eq2: W0 = preimage_of X f V2.
      witness V2.
      exact (andI (V2 :e Fam) (W0 = preimage_of X f V2) HV2 HW0eq2). }
    apply Hex.
    let V1. assume HV1: V1 :e Fam /\ W0 = preimage_of X f V1.
    claim Hpick: pickV W0 :e Fam /\ W0 = preimage_of X f (pickV W0).
    { exact (Eps_i_ax (fun V:set => V :e Fam /\ W0 = preimage_of X f V) V1 HV1). }
    rewrite HV0eq.
    exact (andEL (pickV W0 :e Fam) (W0 = preimage_of X f (pickV W0)) Hpick). }

  claim HGfin: finite G.
  { exact (Repl_finite (fun W0:set => pickV W0) Gpre HGpreFin). }

  claim HImgCovG: Img c= Union G.
  { let y. assume Hy: y :e Img.
    prove y :e Union G.
    apply (ReplE_impred X (fun x0:set => apply_fun f x0) y Hy).
    let x0. assume Hx0X: x0 :e X.
    assume Heq: y = apply_fun f x0.
    claim Hx0UG: x0 :e Union Gpre.
    { exact (HXcovGpre x0 Hx0X). }
    apply (UnionE_impred Gpre x0 Hx0UG).
    let W0. assume Hx0W0: x0 :e W0.
    assume HW0G: W0 :e Gpre.
    claim HW0Pre: W0 :e PreFam.
    { exact (HGpreSub W0 HW0G). }
    claim Hex: exists V1:set, V1 :e Fam /\ W0 = preimage_of X f V1.
    { apply (ReplE_impred Fam (fun V2:set => preimage_of X f V2) W0 HW0Pre).
      let V2. assume HV2: V2 :e Fam.
      assume HW0eq2: W0 = preimage_of X f V2.
      witness V2.
      exact (andI (V2 :e Fam) (W0 = preimage_of X f V2) HV2 HW0eq2). }
    apply Hex.
    let V1. assume HV1: V1 :e Fam /\ W0 = preimage_of X f V1.
    claim Hpick: pickV W0 :e Fam /\ W0 = preimage_of X f (pickV W0).
    { exact (Eps_i_ax (fun V:set => V :e Fam /\ W0 = preimage_of X f V) V1 HV1). }
    claim HW0eq: W0 = preimage_of X f (pickV W0).
    { exact (andER (pickV W0 :e Fam) (W0 = preimage_of X f (pickV W0)) Hpick). }
    claim Hx0Pre: x0 :e preimage_of X f (pickV W0).
    { rewrite <- HW0eq at 1.
      exact Hx0W0. }
    claim HyV: apply_fun f x0 :e pickV W0.
    { apply (SepE X (fun u:set => apply_fun f u :e pickV W0) x0 Hx0Pre).
      assume _. assume Hy0. exact Hy0. }
    rewrite Heq.
    exact (UnionI G (apply_fun f x0) (pickV W0) HyV (ReplI Gpre (fun W1:set => pickV W1) W0 HW0G)). }

  exact (has_finite_subcoverI Img Ty Fam G (andI (G c= Fam /\ finite G) (Img c= Union G)
                                                 (andI (G c= Fam) (finite G) HGsubFam HGfin)
                                                 HImgCovG)). }

exact (iffER (compact_space Img Timg)
             (forall Fam:set, (Fam c= Ty /\ Img c= Union Fam) -> has_finite_subcover Img Ty Fam)
             (compact_subspace_via_ambient_covers Y Ty Img HTy HImgSubY)
             Hprop).
Qed.

(** from §26: tube lemma used in product compactness **)
(** LATEX VERSION: Tube lemma: in X×Y with Y compact, a neighborhood of {x0}×Y contains some U×Y. **)
(** FIXED: Use setprod U {y} c= N (subset) rather than setprod U y :e N; tube lemma encodes U×Y c= N and can be viewed pointwise as forall y:e Y, setprod U {y} c= N. **)
Theorem tube_lemma : forall X Tx Y Ty:set,
  topology_on X Tx -> topology_on Y Ty ->
  compact_space Y Ty ->
  forall x0:set, x0 :e X ->
  forall N:set, N :e product_topology X Tx Y Ty /\ setprod {x0} Y c= N ->
    exists U:set, U :e Tx /\ x0 :e U /\
      setprod U Y c= N.
let X Tx Y Ty.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
assume Hcomp: compact_space Y Ty.
let x0.
assume Hx0: x0 :e X.
let N.
assume HN: N :e product_topology X Tx Y Ty /\ setprod {x0} Y c= N.
prove exists U:set, U :e Tx /\ x0 :e U /\ setprod U Y c= N.
(** Use that N is open in the topology generated by the product basis, then cover Y by suitable open slices. **)
set B := product_subbasis X Tx Y Ty.
claim HBasis: basis_on (setprod X Y) B.
{ exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
claim HNtop: N :e generated_topology (setprod X Y) B.
{ exact (andEL (N :e product_topology X Tx Y Ty) (setprod {x0} Y c= N) HN). }
claim HNsub: setprod {x0} Y c= N.
{ exact (andER (N :e product_topology X Tx Y Ty) (setprod {x0} Y c= N) HN). }
claim HNrefine: forall p :e N, exists b :e B, p :e b /\ b c= N.
{ exact (SepE2 (Power (setprod X Y))
               (fun U0:set => forall x :e U0, exists b :e B, x :e b /\ b c= U0)
               N HNtop). }
set VFam := {V :e Ty|exists U:set, U :e Tx /\ x0 :e U /\ setprod U V c= N}.
claim HVFamSubTy: VFam c= Ty.
{ let V. assume HV: V :e VFam.
  exact (SepE1 Ty (fun V0:set => exists U:set, U :e Tx /\ x0 :e U /\ setprod U V0 c= N) V HV). }
claim HtopY: topology_on Y Ty.
{ exact (compact_space_topology Y Ty Hcomp). }
claim HTyPow: Ty c= Power Y.
{ exact (topology_subset_axiom Y Ty HtopY). }
claim HVFamPowY: VFam c= Power Y.
{ let V. assume HV: V :e VFam.
  claim HVTy: V :e Ty.
  { exact (HVFamSubTy V HV). }
  exact (HTyPow V HVTy). }
claim HYcov: Y c= Union VFam.
{ let y. assume Hy: y :e Y.
  prove y :e Union VFam.
  set p := (x0,y).
  claim HpXY: p :e setprod {x0} Y.
  { exact (tuple_2_setprod_by_pair_Sigma {x0} Y x0 y (SingI x0) Hy). }
  claim HpN: p :e N.
  { exact (HNsub p HpXY). }
  claim Hrect: exists b :e B, p :e b /\ b c= N.
  { exact (HNrefine p HpN). }
  apply Hrect.
  let b. assume Hbpair.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (p :e b /\ b c= N) Hbpair). }
  claim Hbprop: p :e b /\ b c= N.
  { exact (andER (b :e B) (p :e b /\ b c= N) Hbpair). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= N) Hbprop). }
  claim HbsubN: b c= N.
  { exact (andER (p :e b) (b c= N) Hbprop). }
  apply (famunionE_impred Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b HbB).
  let U0. assume HU0Tx: U0 :e Tx.
  assume HbIn: b :e {rectangle_set U0 V0|V0 :e Ty}.
  apply (ReplE_impred Ty (fun V0:set => rectangle_set U0 V0) b HbIn).
  let V0. assume HV0Ty: V0 :e Ty.
  assume HbEq: b = rectangle_set U0 V0.
  claim HpUV: p :e setprod U0 V0.
  { prove p :e rectangle_set U0 V0.
    rewrite <- HbEq at 1.
    exact Hpb. }
  claim HpXY0: p :e setprod {x0} {y}.
  { exact (tuple_2_setprod_by_pair_Sigma {x0} {y} x0 y (SingI x0) (SingI y)). }
  claim Hcoords: x0 :e U0 /\ y :e V0.
  { exact (setprod_coords_in x0 y U0 V0 p HpXY0 HpUV). }
  claim Hx0U0: x0 :e U0.
  { exact (andEL (x0 :e U0) (y :e V0) Hcoords). }
  claim HyV0: y :e V0.
  { exact (andER (x0 :e U0) (y :e V0) Hcoords). }
  claim HrectSub: setprod U0 V0 c= N.
  { rewrite <- HbEq at 1.
    exact HbsubN. }
  claim HV0Fam: V0 :e VFam.
  { apply (SepI Ty (fun V1:set => exists U1:set, U1 :e Tx /\ x0 :e U1 /\ setprod U1 V1 c= N) V0 HV0Ty).
    witness U0.
    exact (andI (U0 :e Tx /\ x0 :e U0) (setprod U0 V0 c= N)
                (andI (U0 :e Tx) (x0 :e U0) HU0Tx Hx0U0)
                HrectSub). }
  exact (UnionI VFam y V0 HyV0 HV0Fam). }
claim HVFamCover: open_cover_of Y Ty VFam.
{ prove topology_on Y Ty /\ VFam c= Power Y /\ Y c= Union VFam /\ (forall U:set, U :e VFam -> U :e Ty).
  (** conjunction is left-associative: (((A /\ B) /\ C) /\ D) **)
  apply andI.
  - apply andI.
    + apply andI.
      * exact HtopY.
      * exact HVFamPowY.
    + exact HYcov.
  - let V. assume HV: V :e VFam.
    exact (HVFamSubTy V HV). }
claim Hfin: has_finite_subcover Y Ty VFam.
{ exact (Heine_Borel_subcover Y Ty VFam Hcomp HVFamCover). }
apply Hfin.
let G. assume HGtriple: G c= VFam /\ finite G /\ Y c= Union G.
set pickU := fun V:set => Eps_i (fun U0:set => U0 :e Tx /\ x0 :e U0 /\ setprod U0 V c= N).
claim HpickU: forall V:set, V :e VFam -> pickU V :e Tx /\ x0 :e pickU V /\ setprod (pickU V) V c= N.
{ let V. assume HV: V :e VFam.
  claim Hex: exists U0:set, U0 :e Tx /\ x0 :e U0 /\ setprod U0 V c= N.
  { exact (SepE2 Ty (fun V0:set => exists U0:set, U0 :e Tx /\ x0 :e U0 /\ setprod U0 V0 c= N) V HV). }
  apply Hex.
  let U0. assume HU0: U0 :e Tx /\ x0 :e U0 /\ setprod U0 V c= N.
  claim Hax: pickU V :e Tx /\ x0 :e pickU V /\ setprod (pickU V) V c= N.
  { exact (Eps_i_ax (fun U1:set => U1 :e Tx /\ x0 :e U1 /\ setprod U1 V c= N) U0 HU0). }
  exact Hax. }
claim HGsub: G c= VFam.
{ exact (andEL (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HGtriple)). }
claim HGfin: finite G.
{ exact (andER (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HGtriple)). }
claim HYcovG: Y c= Union G.
{ exact (andER (G c= VFam /\ finite G) (Y c= Union G) HGtriple). }
set UFam := {pickU V|V :e G}.
claim HUFamFin: finite UFam.
{ exact (Repl_finite (fun V:set => pickU V) G HGfin). }
claim HUFamPow: UFam :e Power Tx.
{ apply PowerI Tx UFam.
  let U0. assume HU0: U0 :e UFam.
  prove U0 :e Tx.
  apply (ReplE_impred G (fun V0:set => pickU V0) U0 HU0).
  let V0. assume HV0G: V0 :e G.
  assume HU0Eq: U0 = pickU V0.
  claim HV0Fam: V0 :e VFam.
  { exact (HGsub V0 HV0G). }
  claim HU0Prop: pickU V0 :e Tx /\ x0 :e pickU V0 /\ setprod (pickU V0) V0 c= N.
  { exact (HpickU V0 HV0Fam). }
  claim HU0AB: pickU V0 :e Tx /\ x0 :e pickU V0.
  { exact (andEL (pickU V0 :e Tx /\ x0 :e pickU V0) (setprod (pickU V0) V0 c= N) HU0Prop). }
  claim HU0Tx: pickU V0 :e Tx.
  { exact (andEL (pickU V0 :e Tx) (x0 :e pickU V0) HU0AB). }
  rewrite HU0Eq.
  exact HU0Tx. }
set U := intersection_of_family X UFam.
claim HUinTx: U :e Tx.
{ exact (finite_intersection_in_topology X Tx UFam HTx HUFamPow HUFamFin). }
claim Hx0U: x0 :e U.
{ prove x0 :e intersection_of_family X UFam.
  claim Hall: forall W:set, W :e UFam -> x0 :e W.
  { let W. assume HW: W :e UFam.
    prove x0 :e W.
    apply (ReplE_impred G (fun V0:set => pickU V0) W HW).
    let V0. assume HV0G: V0 :e G.
    assume HWEq: W = pickU V0.
    claim HV0Fam: V0 :e VFam.
    { exact (HGsub V0 HV0G). }
    claim HWProp: pickU V0 :e Tx /\ x0 :e pickU V0 /\ setprod (pickU V0) V0 c= N.
    { exact (HpickU V0 HV0Fam). }
    claim HWPropAB: pickU V0 :e Tx /\ x0 :e pickU V0.
    { exact (andEL (pickU V0 :e Tx /\ x0 :e pickU V0) (setprod (pickU V0) V0 c= N) HWProp). }
    claim Hx0Pick: x0 :e pickU V0.
    { exact (andER (pickU V0 :e Tx) (x0 :e pickU V0) HWPropAB). }
    rewrite HWEq.
    exact Hx0Pick. }
  exact (SepI X (fun x:set => forall W:set, W :e UFam -> x :e W) x0 Hx0 Hall). }
claim HUsubN: setprod U Y c= N.
{ let p. assume Hp: p :e setprod U Y.
  prove p :e N.
  claim Hp0: p 0 :e U.
  { exact (ap0_Sigma U (fun u:set => Y) p Hp). }
  claim Hp1: p 1 :e Y.
  { exact (ap1_Sigma U (fun u:set => Y) p Hp). }
  claim HpEta: p = (p 0, p 1).
  { exact (setprod_eta U Y p Hp). }
  claim Hp1InUnion: p 1 :e Union G.
  { exact (HYcovG (p 1) Hp1). }
  apply (UnionE_impred G (p 1) Hp1InUnion).
  let V0. assume Hp1V0: p 1 :e V0.
  assume HV0G: V0 :e G.
  claim HV0Fam: V0 :e VFam.
  { exact (HGsub V0 HV0G). }
  claim HV0Ty: V0 :e Ty.
  { exact (HVFamSubTy V0 HV0Fam). }
  claim Hpick: pickU V0 :e Tx /\ x0 :e pickU V0 /\ setprod (pickU V0) V0 c= N.
  { exact (HpickU V0 HV0Fam). }
  claim HrectSubN: setprod (pickU V0) V0 c= N.
  { exact (andER (pickU V0 :e Tx /\ x0 :e pickU V0) (setprod (pickU V0) V0 c= N) Hpick). }
  claim Hp0Pick: p 0 :e pickU V0.
  { claim Hp0All: forall W:set, W :e UFam -> p 0 :e W.
    { exact (SepE2 X (fun x:set => forall W:set, W :e UFam -> x :e W) (p 0) Hp0). }
    claim Hmem: pickU V0 :e UFam.
    { exact (ReplI G (fun V1:set => pickU V1) V0 HV0G). }
    exact (Hp0All (pickU V0) Hmem). }
  claim HpairIn: (p 0, p 1) :e setprod (pickU V0) V0.
  { exact (tuple_2_setprod_by_pair_Sigma (pickU V0) V0 (p 0) (p 1) Hp0Pick Hp1V0). }
  claim HpN: (p 0, p 1) :e N.
  { exact (HrectSubN (p 0, p 1) HpairIn). }
  rewrite HpEta.
  exact HpN. }
witness U.
exact (andI (U :e Tx /\ x0 :e U) (setprod U Y c= N)
            (andI (U :e Tx) (x0 :e U) HUinTx Hx0U)
            HUsubN).
Qed.

(** from §26 Theorem 26.6: compact-to-Hausdorff bijection is a homeomorphism **) 
(** LATEX VERSION: A continuous bijection from compact space to Hausdorff space is a homeomorphism. **)
Definition bijection : set -> set -> set -> prop := fun X Y f =>
  function_on f X Y /\
  (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y /\
     (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x)).

(** from §26 Theorem 26.6: inverse of a bijection (graph form) **)
(** LATEX VERSION: If f:X→Y is bijective, define its inverse f^{-1}:Y→X; we represent it as a graph { (y, f^{-1}(y)) | y∈Y }. **)
Definition inv_fun_graph : set -> set -> set -> set := fun X f Y =>
  {(y, inv X (fun x:set => apply_fun f x) y)|y :e Y}.

Theorem inv_fun_graph_apply : forall X Y f y:set,
  y :e Y -> apply_fun (inv_fun_graph X f Y) y = inv X (fun x:set => apply_fun f x) y.
let X Y f y.
assume Hy: y :e Y.
prove apply_fun (inv_fun_graph X f Y) y = inv X (fun x:set => apply_fun f x) y.
prove apply_fun {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y} y = inv X (fun x:set => apply_fun f x) y.
prove Eps_i (fun z => (y,z) :e {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y}) =
      inv X (fun x:set => apply_fun f x) y.
claim H1: (y, inv X (fun x:set => apply_fun f x) y) :e {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y}.
{ exact (ReplI Y (fun y0:set => (y0, inv X (fun x:set => apply_fun f x) y0)) y Hy). }
claim H2: (y, Eps_i (fun z => (y,z) :e {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y})) :e
          {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y}.
{ exact (Eps_i_ax (fun z => (y,z) :e {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y})
                  (inv X (fun x:set => apply_fun f x) y) H1). }
apply (ReplE_impred Y (fun y0:set => (y0, inv X (fun x:set => apply_fun f x) y0))
                    (y, Eps_i (fun z => (y,z) :e {(y0, inv X (fun x:set => apply_fun f x) y0) | y0 :e Y})) H2).
let y0.
assume Hy0: y0 :e Y.
assume Heq: (y, Eps_i (fun z => (y,z) :e {(y1, inv X (fun x:set => apply_fun f x) y1) | y1 :e Y})) =
            (y0, inv X (fun x:set => apply_fun f x) y0).
claim Hy_eq: y = y0.
{ rewrite <- (tuple_2_0_eq y (Eps_i (fun z => (y,z) :e {(y1, inv X (fun x:set => apply_fun f x) y1) | y1 :e Y}))).
  rewrite <- (tuple_2_0_eq y0 (inv X (fun x:set => apply_fun f x) y0)).
  rewrite Heq.
  reflexivity. }
claim Hz_eq: Eps_i (fun z => (y,z) :e {(y1, inv X (fun x:set => apply_fun f x) y1) | y1 :e Y}) =
             inv X (fun x:set => apply_fun f x) y0.
{ rewrite <- (tuple_2_1_eq y (Eps_i (fun z => (y,z) :e {(y1, inv X (fun x:set => apply_fun f x) y1) | y1 :e Y}))).
  rewrite <- (tuple_2_1_eq y0 (inv X (fun x:set => apply_fun f x) y0)).
  rewrite Heq.
  reflexivity. }
rewrite Hz_eq.
rewrite <- Hy_eq.
reflexivity.
Qed.

Theorem bijection_surj : forall X Y f y:set,
  bijection X Y f -> y :e Y -> exists x:set, x :e X /\ apply_fun f x = y.
let X Y f y.
assume Hbij: bijection X Y f.
assume Hy: y :e Y.
apply Hbij.
assume Hfun: function_on f X Y.
assume Huniq.
apply (Huniq y Hy).
let x.
assume Hx: x :e X /\ apply_fun f x = y /\ (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x).
witness x.
claim Hx0: x :e X /\ apply_fun f x = y.
{ exact (andEL (x :e X /\ apply_fun f x = y)
               (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x) Hx). }
exact Hx0.
Qed.

Theorem bijection_inj : forall X Y f u v:set,
  bijection X Y f -> u :e X -> v :e X -> apply_fun f u = apply_fun f v -> u = v.
let X Y f u v.
assume Hbij: bijection X Y f.
assume HuX: u :e X.
assume HvX: v :e X.
assume Heq: apply_fun f u = apply_fun f v.
apply Hbij.
assume Hfun: function_on f X Y.
assume Huniq.
claim HyY: apply_fun f u :e Y.
{ exact (Hfun u HuX). }
apply (Huniq (apply_fun f u) HyY).
let x.
assume Hx: x :e X /\ apply_fun f x = apply_fun f u /\
           (forall x':set, x' :e X -> apply_fun f x' = apply_fun f u -> x' = x).
claim Hxuniq: forall x':set, x' :e X -> apply_fun f x' = apply_fun f u -> x' = x.
{ exact (andER (x :e X /\ apply_fun f x = apply_fun f u)
               (forall x':set, x' :e X -> apply_fun f x' = apply_fun f u -> x' = x)
               Hx). }
claim Hu: u = x.
{ apply (Hxuniq u HuX).
  reflexivity. }
claim Hv: v = x.
{ apply (Hxuniq v HvX).
  symmetry.
  exact Heq. }
rewrite Hu.
rewrite Hv.
reflexivity.
Qed.

Theorem inv_fun_graph_right_inverse : forall X Y f y:set,
  bijection X Y f -> y :e Y -> apply_fun f (apply_fun (inv_fun_graph X f Y) y) = y.
let X Y f y.
assume Hbij: bijection X Y f.
assume Hy: y :e Y.
prove apply_fun f (apply_fun (inv_fun_graph X f Y) y) = y.
claim Hginv: apply_fun (inv_fun_graph X f Y) y = inv X (fun u:set => apply_fun f u) y.
{ exact (inv_fun_graph_apply X Y f y Hy). }
rewrite Hginv.
claim Hsurj: forall w :e Y, exists u :e X, apply_fun f u = w.
{ let w. assume Hw: w :e Y.
  claim Hex: exists u:set, u :e X /\ apply_fun f u = w.
  { exact (bijection_surj X Y f w Hbij Hw). }
  exact Hex. }
claim Hpair: inv X (fun u:set => apply_fun f u) y :e X /\
             apply_fun f (inv X (fun u:set => apply_fun f u) y) = y.
{ exact (surj_rinv X Y (fun u:set => apply_fun f u) Hsurj y Hy). }
exact (andER (inv X (fun u:set => apply_fun f u) y :e X)
             (apply_fun f (inv X (fun u:set => apply_fun f u) y) = y)
             Hpair).
Qed.

Theorem inv_fun_graph_left_inverse : forall X Y f x:set,
  bijection X Y f -> x :e X -> apply_fun (inv_fun_graph X f Y) (apply_fun f x) = x.
let X Y f x.
assume Hbij: bijection X Y f.
assume Hx: x :e X.
prove apply_fun (inv_fun_graph X f Y) (apply_fun f x) = x.
claim Hfun: function_on f X Y.
{ exact (andEL (function_on f X Y)
               (forall y:set, y :e Y -> exists x0:set, x0 :e X /\ apply_fun f x0 = y /\ (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x0))
               Hbij). }
claim HyY: apply_fun f x :e Y.
{ exact (Hfun x Hx). }
claim Hginv: apply_fun (inv_fun_graph X f Y) (apply_fun f x) =
             inv X (fun u:set => apply_fun f u) (apply_fun f x).
{ exact (inv_fun_graph_apply X Y f (apply_fun f x) HyY). }
rewrite Hginv.
claim Hinj: forall u v :e X, apply_fun f u = apply_fun f v -> u = v.
{ let u. assume Hu: u :e X.
  let v. assume Hv: v :e X.
  assume Heq.
  exact (bijection_inj X Y f u v Hbij Hu Hv Heq). }
exact (inj_linv X (fun u:set => apply_fun f u) Hinj x Hx).
Qed.

Theorem inv_fun_graph_preimage_eq_image : forall X Y f A:set,
  bijection X Y f -> A c= X ->
  preimage_of Y (inv_fun_graph X f Y) A = image_of_fun f A.
let X Y f A.
assume Hbij: bijection X Y f.
assume HA: A c= X.
set g := inv_fun_graph X f Y.
apply set_ext.
- let y. assume Hy: y :e preimage_of Y g A.
  prove y :e image_of_fun f A.
  claim HyY: y :e Y.
  { exact (SepE1 Y (fun u:set => apply_fun g u :e A) y Hy). }
  claim HgyA: apply_fun g y :e A.
  { exact (SepE2 Y (fun u:set => apply_fun g u :e A) y Hy). }
  claim Heq: apply_fun f (apply_fun g y) = y.
  { exact (inv_fun_graph_right_inverse X Y f y Hbij HyY). }
  claim HyImg: apply_fun f (apply_fun g y) :e image_of_fun f A.
  { exact (ReplI A (fun x0:set => apply_fun f x0) (apply_fun g y) HgyA). }
  rewrite <- Heq.
  exact HyImg.
- let y. assume Hy: y :e image_of_fun f A.
  prove y :e preimage_of Y g A.
  apply (ReplE_impred A (fun x0:set => apply_fun f x0) y Hy).
  let x.
  assume HxA: x :e A.
  assume Heq: y = apply_fun f x.
  prove y :e {u :e Y | apply_fun g u :e A}.
  apply SepI.
  + claim HxX: x :e X.
    { exact (HA x HxA). }
    claim Hfun: function_on f X Y.
    { exact (andEL (function_on f X Y)
                   (forall y0:set, y0 :e Y -> exists x0:set, x0 :e X /\ apply_fun f x0 = y0 /\ (forall x':set, x' :e X -> apply_fun f x' = y0 -> x' = x0))
                   Hbij). }
    rewrite Heq.
    exact (Hfun x HxX).
  + prove apply_fun g y :e A.
    rewrite Heq.
    claim HxX: x :e X.
    { exact (HA x HxA). }
    claim Hinv: apply_fun g (apply_fun f x) = x.
    { exact (inv_fun_graph_left_inverse X Y f x Hbij HxX). }
    rewrite Hinv.
    exact HxA.
Qed.

(** from §13: absolute value notation **)
(** LATEX VERSION: We write |x| for the absolute value of x. **)
Definition Abs : set -> set := abs_SNo.

Theorem compact_to_Hausdorff_inverse_continuous : forall X Tx Y Ty f:set,
  compact_space X Tx -> Hausdorff_space Y Ty ->
  continuous_map X Tx Y Ty f -> bijection X Y f ->
  continuous_map Y Ty X Tx (inv_fun_graph X f Y).
let X Tx Y Ty f.
assume Hcomp: compact_space X Tx.
assume HH: Hausdorff_space Y Ty.
assume Hcont: continuous_map X Tx Y Ty f.
assume Hbij: bijection X Y f.
set g := inv_fun_graph X f Y.
prove continuous_map Y Ty X Tx g.
prove topology_on Y Ty /\ topology_on X Tx /\ function_on g Y X /\
      forall V:set, V :e Tx -> preimage_of Y g V :e Ty.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty)
               (forall x1 x2:set, x1 :e Y -> x2 :e Y -> x1 <> x2 ->
                 exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
claim Hfun: function_on f X Y.
{ exact (andEL (function_on f X Y)
               (forall y:set, y :e Y -> exists x0:set, x0 :e X /\ apply_fun f x0 = y /\ (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x0))
               Hbij). }
claim Hgfun: function_on g Y X.
{ let y. assume Hy: y :e Y.
  prove apply_fun g y :e X.
  claim Hginv: apply_fun g y = inv X (fun u:set => apply_fun f u) y.
  { exact (inv_fun_graph_apply X Y f y Hy). }
  rewrite Hginv.
  claim Hsurj: forall w :e Y, exists u :e X, apply_fun f u = w.
  { let w. assume Hw: w :e Y.
    claim Hex: exists u:set, u :e X /\ apply_fun f u = w.
    { exact (bijection_surj X Y f w Hbij Hw). }
    exact Hex. }
  claim Hpair: inv X (fun u:set => apply_fun f u) y :e X /\
               apply_fun f (inv X (fun u:set => apply_fun f u) y) = y.
  { exact (surj_rinv X Y (fun u:set => apply_fun f u) Hsurj y Hy). }
  exact (andEL (inv X (fun u:set => apply_fun f u) y :e X)
               (apply_fun f (inv X (fun u:set => apply_fun f u) y) = y)
               Hpair). }

apply andI.
- apply andI.
  + apply andI.
    * exact HTy.
    * exact HTx.
  + exact Hgfun.
- let V. assume HV: V :e Tx.
  prove preimage_of Y g V :e Ty.
  set C := X :\: V.
  claim HCclosed: closed_in X Tx C.
  { exact (closed_of_open_complement X Tx V HTx HV). }
  claim HCsub: C c= X.
  { exact (closed_in_subset X Tx C HCclosed). }
  claim HpreCeq: preimage_of Y g C = image_of_fun f C.
  { exact (inv_fun_graph_preimage_eq_image X Y f C Hbij HCsub). }
  claim HimgSubY: image_of_fun f C c= Y.
  { let y. assume Hy: y :e image_of_fun f C.
    apply (ReplE_impred C (fun x0:set => apply_fun f x0) y Hy).
    let x0. assume Hx0C: x0 :e C.
    assume Heq: y = apply_fun f x0.
    claim Hx0X: x0 :e X.
    { exact (HCsub x0 Hx0C). }
    rewrite Heq.
    exact (Hfun x0 Hx0X). }
  claim HcompC: compact_space C (subspace_topology X Tx C).
  { exact (closed_subspace_compact X Tx C Hcomp HCclosed). }
  claim HcontC: continuous_map C (subspace_topology X Tx C) Y Ty f.
  { exact (continuous_on_subspace X Tx Y Ty f C HTx HCsub Hcont). }
  claim HimgComp: compact_space (image_of_fun f C) (subspace_topology Y Ty (image_of_fun f C)).
  { exact (continuous_image_compact C (subspace_topology X Tx C) Y Ty f HcompC HcontC). }
  claim HimgClosed: closed_in Y Ty (image_of_fun f C).
  { exact (compact_subspace_in_Hausdorff_closed Y Ty (image_of_fun f C) HH HimgSubY HimgComp). }
  claim HpreClosed: closed_in Y Ty (preimage_of Y g C).
  { rewrite HpreCeq at 1.
    exact HimgClosed. }
  claim Hop: open_in Y Ty (Y :\: preimage_of Y g C).
  { exact (open_of_closed_complement Y Ty (preimage_of Y g C) HpreClosed). }
  claim HopTy: (Y :\: preimage_of Y g C) :e Ty.
  { exact (andER (topology_on Y Ty) ((Y :\: preimage_of Y g C) :e Ty) Hop). }
  claim HpreEq: preimage_of Y g V = Y :\: preimage_of Y g C.
  { apply set_ext.
    - let y. assume Hy: y :e preimage_of Y g V.
      prove y :e Y :\: preimage_of Y g C.
      claim HyY: y :e Y.
      { exact (SepE1 Y (fun u:set => apply_fun g u :e V) y Hy). }
      claim HgyV: apply_fun g y :e V.
      { exact (SepE2 Y (fun u:set => apply_fun g u :e V) y Hy). }
      apply setminusI.
      + exact HyY.
      + assume HyC: y :e preimage_of Y g C.
        claim HgyC: apply_fun g y :e C.
        { exact (SepE2 Y (fun u:set => apply_fun g u :e C) y HyC). }
        apply (setminusE X V (apply_fun g y) HgyC).
        assume _. assume HnotV.
        exact (HnotV HgyV).
    - let y. assume Hy: y :e Y :\: preimage_of Y g C.
      prove y :e preimage_of Y g V.
      apply (setminusE Y (preimage_of Y g C) y Hy).
      assume HyY: y :e Y.
      assume HyNot: y /:e preimage_of Y g C.
      prove y :e {u :e Y | apply_fun g u :e V}.
      apply SepI.
      + exact HyY.
      + prove apply_fun g y :e V.
        claim HgyX: apply_fun g y :e X.
        { exact (Hgfun y HyY). }
        apply (xm (apply_fun g y :e V)).
        - assume HVin. exact HVin.
        - assume HnotV: ~(apply_fun g y :e V).
          claim HnotVin: apply_fun g y /:e V.
          { assume H0. exact (HnotV H0). }
          claim HgyC: apply_fun g y :e C.
          { exact (setminusI X V (apply_fun g y) HgyX HnotVin). }
          claim HyC: y :e preimage_of Y g C.
          { prove y :e {u :e Y | apply_fun g u :e C}.
            apply SepI.
            - exact HyY.
            - exact HgyC. }
          apply FalseE.
          exact (HyNot HyC). }
  rewrite HpreEq.
  exact HopTy.
Qed.

Theorem compact_to_Hausdorff_bijection_homeomorphism : forall X Tx Y Ty f:set,
  compact_space X Tx -> Hausdorff_space Y Ty ->
  continuous_map X Tx Y Ty f -> bijection X Y f ->
  homeomorphism X Tx Y Ty f.
let X Tx Y Ty f.
assume Hcomp: compact_space X Tx.
assume HH: Hausdorff_space Y Ty.
assume Hcont: continuous_map X Tx Y Ty f.
assume Hbij: bijection X Y f.
prove homeomorphism X Tx Y Ty f.
prove continuous_map X Tx Y Ty f /\
      exists g:set, continuous_map Y Ty X Tx g /\
        (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
        (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
apply andI.
- exact Hcont.
- set g := inv_fun_graph X f Y.
  witness g.
  apply andI.
  + apply andI.
    * exact (compact_to_Hausdorff_inverse_continuous X Tx Y Ty f Hcomp HH Hcont Hbij).
    * let x. assume Hx: x :e X.
      prove apply_fun g (apply_fun f x) = x.
      claim Hfun: function_on f X Y.
      { exact (andEL (function_on f X Y)
                     (forall y:set, y :e Y -> exists x0:set, x0 :e X /\ apply_fun f x0 = y /\ (forall x':set, x' :e X -> apply_fun f x' = y -> x' = x0))
                     Hbij). }
      claim HyY: apply_fun f x :e Y.
      { exact (Hfun x Hx). }
      claim Hginv: apply_fun g (apply_fun f x) = inv X (fun u:set => apply_fun f u) (apply_fun f x).
      { exact (inv_fun_graph_apply X Y f (apply_fun f x) HyY). }
      rewrite Hginv.
      claim Hinj: forall u v :e X, apply_fun f u = apply_fun f v -> u = v.
      { let u. assume Hu: u :e X.
        let v. assume Hv: v :e X.
        assume Heq.
        exact (bijection_inj X Y f u v Hbij Hu Hv Heq). }
      exact (inj_linv X (fun u:set => apply_fun f u) Hinj x Hx).
  + let y. assume Hy: y :e Y.
    prove apply_fun f (apply_fun g y) = y.
    claim Hginv: apply_fun g y = inv X (fun u:set => apply_fun f u) y.
    { exact (inv_fun_graph_apply X Y f y Hy). }
    rewrite Hginv.
    claim Hsurj: forall w :e Y, exists u :e X, apply_fun f u = w.
    { let w. assume Hw: w :e Y.
      claim Hex: exists u:set, u :e X /\ apply_fun f u = w.
      { exact (bijection_surj X Y f w Hbij Hw). }
      exact Hex. }
    claim Hpair: inv X (fun u:set => apply_fun f u) y :e X /\
                 apply_fun f (inv X (fun u:set => apply_fun f u) y) = y.
    { exact (surj_rinv X Y (fun u:set => apply_fun f u) Hsurj y Hy). }
    exact (andER (inv X (fun u:set => apply_fun f u) y :e X)
                 (apply_fun f (inv X (fun u:set => apply_fun f u) y) = y)
                 Hpair).
Qed.

(** LATEX VERSION: A subset A⊂ℝ is bounded if |x|≤M for some real M. **)
Definition bounded_subset_of_reals : set -> prop := fun A =>
  exists M:set, M :e R /\ forall x:set, x :e A -> ~(Rlt M (Abs x)).

(** helper: elements of omega are reals **)
Theorem omega_in_R : forall n:set, n :e omega -> n :e R.
let n. assume Hn: n :e omega.
claim HnSNoS: n :e SNoS_ omega.
{ exact (omega_SNoS_omega n Hn). }
exact (SNoS_omega_real n HnSNoS).
Qed.

(** helper: successors of naturals are reals **)
Theorem ordsucc_in_R : forall n:set, n :e omega -> ordsucc n :e R.
let n. assume Hn: n :e omega.
exact (omega_in_R (ordsucc n) (omega_ordsucc n Hn)).
Qed.

(** helper: an interval around 0 bounds Abs **)
Theorem interval_bounds_Abs : forall M x:set,
  M :e R -> x :e R ->
  Rlt (minus_SNo M) x -> Rlt x M ->
  ~(Rlt M (Abs x)).
let M x.
assume HM: M :e R.
assume HxR: x :e R.
assume Hlx: Rlt (minus_SNo M) x.
assume HxM: Rlt x M.
assume HMAbs: Rlt M (Abs x).
claim HAbsR: Abs x :e R.
{ exact (RltE_right M (Abs x) HMAbs). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 False).
- assume Hxlt0: x < 0.
  claim Habseq: Abs x = minus_SNo x.
  { exact (neg_abs_SNo x HxS Hxlt0). }
  claim HMltAbs: M < Abs x.
  { exact (RltE_lt M (Abs x) HMAbs). }
  claim HMltnegx: M < minus_SNo x.
  { rewrite <- Habseq.
    exact HMltAbs. }
  claim Hlxs: minus_SNo M < x.
  { exact (RltE_lt (minus_SNo M) x Hlx). }
  claim HmR: minus_SNo M :e R.
  { exact (real_minus_SNo M HM). }
  claim HmS: SNo (minus_SNo M).
  { exact (real_SNo (minus_SNo M) HmR). }
  claim Hnegxlt: minus_SNo x < minus_SNo (minus_SNo M).
  { exact (minus_SNo_Lt_contra (minus_SNo M) x HmS HxS Hlxs). }
  claim Hminv: minus_SNo (minus_SNo M) = M.
  { exact (minus_SNo_invol M (real_SNo M HM)). }
  claim HnegxltM: minus_SNo x < M.
  { rewrite <- Hminv.
    exact Hnegxlt. }
  claim HAbsltM: Abs x < M.
  { rewrite Habseq at 1.
    exact HnegxltM. }
  claim HRltAbsM: Rlt (Abs x) M.
  { exact (RltI (Abs x) M HAbsR HM HAbsltM). }
  claim HMM: Rlt M M.
  { exact (Rlt_tra M (Abs x) M HMAbs HRltAbsM). }
  exact ((not_Rlt_refl M HM) HMM).
- assume Hxeq0: x = 0.
  claim H0le0: 0 <= 0.
  { apply (SNoLtLe_or 0 0 SNo_0 SNo_0 (0 <= 0)).
    - assume H00: 0 < 0.
      exact (SNoLtLe 0 0 H00).
    - assume H. exact H. }
  claim Habseq: Abs 0 = 0.
  { exact (nonneg_abs_SNo 0 H0le0). }
  claim Hx0M: Rlt 0 M.
  { rewrite <- Hxeq0.
    exact HxM. }
  claim HMlt0: Rlt M 0.
  { claim HAbsx0: Abs x = 0.
    { rewrite Hxeq0 at 1.
      exact Habseq. }
    rewrite <- HAbsx0.
    exact HMAbs. }
  claim HMM: Rlt M M.
  { exact (Rlt_tra M 0 M HMlt0 Hx0M). }
  exact ((not_Rlt_refl M HM) HMM).
- assume H0ltx: 0 < x.
  claim H0lex: 0 <= x.
  { exact (SNoLtLe 0 x H0ltx). }
  claim Habseq: Abs x = x.
  { exact (nonneg_abs_SNo x H0lex). }
  claim HMltAbs: M < Abs x.
  { exact (RltE_lt M (Abs x) HMAbs). }
  claim HMltx: M < x.
  { rewrite <- Habseq.
    exact HMltAbs. }
  claim HxltM: x < M.
  { exact (RltE_lt x M HxM). }
  claim HRltMx: Rlt M x.
  { exact (RltI M x HM HxR HMltx). }
  claim HRltxM: Rlt x M.
  { exact HxM. }
  claim HMM: Rlt M M.
  { exact (Rlt_tra M x M HRltMx HRltxM). }
  exact ((not_Rlt_refl M HM) HMM).
Qed.

(** from §26 Theorem 26.7: finite products of compact spaces are compact **) 
(** LATEX VERSION: Finite product of compact spaces is compact. **)
Theorem finite_product_compact : forall X Tx Y Ty:set,
  compact_space X Tx -> compact_space Y Ty ->
  compact_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HX: compact_space X Tx.
assume HY: compact_space Y Ty.
prove compact_space (setprod X Y) (product_topology X Tx Y Ty).
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\
      forall Fam:set,
        open_cover_of (setprod X Y) (product_topology X Tx Y Ty) Fam ->
        has_finite_subcover (setprod X Y) (product_topology X Tx Y Ty) Fam.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx HX). }
claim HTy: topology_on Y Ty.
{ exact (compact_space_topology Y Ty HY). }
apply andI.
- exact (product_topology_is_topology X Tx Y Ty HTx HTy).
- let Fam. assume HFam: open_cover_of (setprod X Y) (product_topology X Tx Y Ty) Fam.
  prove has_finite_subcover (setprod X Y) (product_topology X Tx Y Ty) Fam.
  set UFam := {U :e Tx|exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H}.
  claim HcovUFam: open_cover_of X Tx UFam.
  { prove topology_on X Tx /\ UFam c= Power X /\ X c= Union UFam /\ (forall U:set, U :e UFam -> U :e Tx).
    claim HUFamSubTx: UFam c= Tx.
    { let U. assume HU: U :e UFam.
      exact (SepE1 Tx (fun U0:set => exists H:set, H c= Fam /\ finite H /\ setprod U0 Y c= Union H) U HU). }
    claim HTxPow: Tx c= Power X.
    { exact (topology_subset_axiom X Tx HTx). }
    claim HUFamPow: UFam c= Power X.
    { let U. assume HU: U :e UFam.
      claim HUTx: U :e Tx.
      { exact (HUFamSubTx U HU). }
      exact (HTxPow U HUTx). }
    apply andI.
    - apply andI.
      + apply andI.
        * exact HTx.
        * exact HUFamPow.
      + prove X c= Union UFam.
        let x. assume Hx: x :e X.
        prove x :e Union UFam.
        claim HexTube: exists U:set,
          U :e Tx /\ x :e U /\
          exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H.
        { (** Reduce to producing a finite subfamily H of Fam that covers {x}×Y, then apply tube_lemma to N = Union H. **)
          claim HFamOpen: forall U0:set, U0 :e Fam -> U0 :e product_topology X Tx Y Ty.
          { let U0. assume HU0: U0 :e Fam.
            exact (open_cover_of_members_open (setprod X Y) (product_topology X Tx Y Ty) Fam U0 HFam HU0). }
          claim HexSlice: exists H:set, H c= Fam /\ finite H /\ setprod {x} Y c= Union H.
          { (** Build an open cover of Y by second-coordinate slices coming from rectangles inside members of Fam. **)
            claim HcovXY: setprod X Y c= Union Fam.
            { exact (open_cover_of_covers (setprod X Y) (product_topology X Tx Y Ty) Fam HFam). }
            set B := product_subbasis X Tx Y Ty.
            claim HBasis: basis_on (setprod X Y) B.
            { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
            set VFam := {V :e Ty|exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V c= N0}.
            claim HVFamSubTy: VFam c= Ty.
            { let V. assume HV: V :e VFam.
              exact (SepE1 Ty (fun V0:set => exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V0 c= N0) V HV). }
            claim HTyPow: Ty c= Power Y.
            { exact (topology_subset_axiom Y Ty HTy). }
            claim HVFamPow: VFam c= Power Y.
            { let V. assume HV: V :e VFam.
              claim HVTy: V :e Ty.
              { exact (HVFamSubTy V HV). }
              exact (HTyPow V HVTy). }
            claim HYcovV: Y c= Union VFam.
            { let y. assume Hy: y :e Y.
              prove y :e Union VFam.
              set p := (x,y).
              claim HpXY: p :e setprod X Y.
              { exact (tuple_2_setprod_by_pair_Sigma X Y x y Hx Hy). }
              claim HpInUnion: p :e Union Fam.
              { exact (HcovXY p HpXY). }
              apply (UnionE_impred Fam p HpInUnion).
              let N0. assume HpN0: p :e N0.
              assume HN0Fam: N0 :e Fam.
              claim HN0Top: N0 :e generated_topology (setprod X Y) B.
              { exact (HFamOpen N0 HN0Fam). }
              claim HN0refine: forall q :e N0, exists b :e B, q :e b /\ b c= N0.
              { exact (SepE2 (Power (setprod X Y))
                             (fun U0:set => forall q :e U0, exists b :e B, q :e b /\ b c= U0)
                             N0 HN0Top). }
              claim Hexb: exists b :e B, p :e b /\ b c= N0.
              { exact (HN0refine p HpN0). }
              apply Hexb.
              let b. assume Hbpair.
              claim HbB: b :e B.
              { exact (andEL (b :e B) (p :e b /\ b c= N0) Hbpair). }
              claim Hbprop: p :e b /\ b c= N0.
              { exact (andER (b :e B) (p :e b /\ b c= N0) Hbpair). }
              claim Hpb: p :e b.
              { exact (andEL (p :e b) (b c= N0) Hbprop). }
              claim HbsubN0: b c= N0.
              { exact (andER (p :e b) (b c= N0) Hbprop). }
              apply (famunionE_impred Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b HbB).
              let U0. assume HU0Tx: U0 :e Tx.
              assume HbIn: b :e {rectangle_set U0 V0|V0 :e Ty}.
              apply (ReplE_impred Ty (fun V0:set => rectangle_set U0 V0) b HbIn).
              let V0. assume HV0Ty: V0 :e Ty.
              assume HbEq: b = rectangle_set U0 V0.
              claim HpUV: p :e setprod U0 V0.
              { prove p :e rectangle_set U0 V0.
                rewrite <- HbEq at 1.
                exact Hpb. }
              claim HpXY0: p :e setprod {x} {y}.
              { exact (tuple_2_setprod_by_pair_Sigma {x} {y} x y (SingI x) (SingI y)). }
              claim Hcoords: x :e U0 /\ y :e V0.
              { exact (setprod_coords_in x y U0 V0 p HpXY0 HpUV). }
              claim HxU0: x :e U0.
              { exact (andEL (x :e U0) (y :e V0) Hcoords). }
              claim HyV0: y :e V0.
              { exact (andER (x :e U0) (y :e V0) Hcoords). }
              claim HrectSub: setprod U0 V0 c= N0.
              { rewrite <- HbEq at 1.
                exact HbsubN0. }
              claim HV0Fam: V0 :e VFam.
              { apply (SepI Ty (fun V1:set => exists U1:set, U1 :e Tx /\ x :e U1 /\ exists N1:set, N1 :e Fam /\ setprod U1 V1 c= N1) V0 HV0Ty).
                witness U0.
                prove U0 :e Tx /\ x :e U0 /\ exists N1:set, N1 :e Fam /\ setprod U0 V0 c= N1.
                apply andI.
                - exact (andI (U0 :e Tx) (x :e U0) HU0Tx HxU0).
                - witness N0.
                  exact (andI (N0 :e Fam) (setprod U0 V0 c= N0) HN0Fam HrectSub). }
              exact (UnionI VFam y V0 HyV0 HV0Fam). }
            claim HVFamCover: open_cover_of Y Ty VFam.
            { prove topology_on Y Ty /\ VFam c= Power Y /\ Y c= Union VFam /\ (forall U0:set, U0 :e VFam -> U0 :e Ty).
              apply andI.
              - apply andI.
                + apply andI.
                  * exact HTy.
                  * exact HVFamPow.
                + exact HYcovV.
              - let V. assume HV: V :e VFam.
                exact (HVFamSubTy V HV). }
            claim HfinV: has_finite_subcover Y Ty VFam.
            { exact (Heine_Borel_subcover Y Ty VFam HY HVFamCover). }
            apply HfinV.
            let G. assume HG: G c= VFam /\ finite G /\ Y c= Union G.
            claim HGsub: G c= VFam.
            { exact (andEL (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HG)). }
            claim HGfin: finite G.
            { exact (andER (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HG)). }
            claim HYcovG: Y c= Union G.
            { exact (andER (G c= VFam /\ finite G) (Y c= Union G) HG). }
            set pickU := fun V:set => Eps_i (fun U0:set => U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V c= N0).
            claim HpickU: forall V:set, V :e VFam -> pickU V :e Tx /\ x :e pickU V /\ exists N0:set, N0 :e Fam /\ setprod (pickU V) V c= N0.
            { let V. assume HV: V :e VFam.
              claim Hex: exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V c= N0.
              { exact (SepE2 Ty (fun V0:set => exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V0 c= N0) V HV). }
              apply Hex.
              let U0. assume HU0: U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Fam /\ setprod U0 V c= N0.
              exact (Eps_i_ax (fun U1:set => U1 :e Tx /\ x :e U1 /\ exists N0:set, N0 :e Fam /\ setprod U1 V c= N0) U0 HU0). }
            set pickN := fun V:set => Eps_i (fun N0:set => N0 :e Fam /\ setprod (pickU V) V c= N0).
            claim HpickN: forall V:set, V :e VFam -> pickN V :e Fam /\ setprod (pickU V) V c= pickN V.
            { let V. assume HV: V :e VFam.
              claim Hprop: pickU V :e Tx /\ x :e pickU V /\ exists N0:set, N0 :e Fam /\ setprod (pickU V) V c= N0.
              { exact (HpickU V HV). }
              claim HpropAB: pickU V :e Tx /\ x :e pickU V.
              { exact (andEL (pickU V :e Tx /\ x :e pickU V) (exists N0:set, N0 :e Fam /\ setprod (pickU V) V c= N0) Hprop). }
              claim HexN: exists N0:set, N0 :e Fam /\ setprod (pickU V) V c= N0.
              { exact (andER (pickU V :e Tx /\ x :e pickU V) (exists N0:set, N0 :e Fam /\ setprod (pickU V) V c= N0) Hprop). }
              apply HexN.
              let N0. assume HN0: N0 :e Fam /\ setprod (pickU V) V c= N0.
              exact (Eps_i_ax (fun N1:set => N1 :e Fam /\ setprod (pickU V) V c= N1) N0 HN0). }
            set H := {pickN V|V :e G}.
            witness H.
            apply andI.
            - apply andI.
              + prove H c= Fam.
                let N0. assume HN0: N0 :e H.
                apply (ReplE_impred G (fun V0:set => pickN V0) N0 HN0).
                let V0. assume HV0G: V0 :e G.
                assume HN0Eq: N0 = pickN V0.
                claim HV0Fam: V0 :e VFam.
                { exact (HGsub V0 HV0G). }
                claim HNprop: pickN V0 :e Fam /\ setprod (pickU V0) V0 c= pickN V0.
                { exact (HpickN V0 HV0Fam). }
                claim HN0Fam: pickN V0 :e Fam.
                { exact (andEL (pickN V0 :e Fam) (setprod (pickU V0) V0 c= pickN V0) HNprop). }
                rewrite HN0Eq.
                exact HN0Fam.
              + exact (Repl_finite (fun V0:set => pickN V0) G HGfin).
            - prove setprod {x} Y c= Union H.
              let p. assume Hp: p :e setprod {x} Y.
              prove p :e Union H.
                  claim Hp0: p 0 :e {x}.
                  { exact (ap0_Sigma {x} (fun _:set => Y) p Hp). }
                  claim Hp1: p 1 :e Y.
                  { exact (ap1_Sigma {x} (fun _:set => Y) p Hp). }
                  claim Hp0eq: p 0 = x.
                  { exact (SingE x (p 0) Hp0). }
                  claim HpEta: p = (p 0, p 1).
                  { exact (setprod_eta {x} Y p Hp). }
                  claim Hp1InUnion: p 1 :e Union G.
                  { exact (HYcovG (p 1) Hp1). }
                  apply (UnionE_impred G (p 1) Hp1InUnion).
                  let V0. assume Hp1V0: p 1 :e V0.
                  assume HV0G: V0 :e G.
                  claim HV0Fam: V0 :e VFam.
                  { exact (HGsub V0 HV0G). }
                  claim HUN: pickU V0 :e Tx /\ x :e pickU V0 /\ exists N0:set, N0 :e Fam /\ setprod (pickU V0) V0 c= N0.
                  { exact (HpickU V0 HV0Fam). }
                  claim HUNAB: pickU V0 :e Tx /\ x :e pickU V0.
                  { exact (andEL (pickU V0 :e Tx /\ x :e pickU V0) (exists N0:set, N0 :e Fam /\ setprod (pickU V0) V0 c= N0) HUN). }
                  claim HxPick: x :e pickU V0.
                  { exact (andER (pickU V0 :e Tx) (x :e pickU V0) HUNAB). }
                  claim HNprop: pickN V0 :e Fam /\ setprod (pickU V0) V0 c= pickN V0.
                  { exact (HpickN V0 HV0Fam). }
                  claim HrectSub: setprod (pickU V0) V0 c= pickN V0.
                  { exact (andER (pickN V0 :e Fam) (setprod (pickU V0) V0 c= pickN V0) HNprop). }
                  claim HpInRect: (x, p 1) :e setprod (pickU V0) V0.
                  { exact (tuple_2_setprod_by_pair_Sigma (pickU V0) V0 x (p 1) HxPick Hp1V0). }
                  claim HpInN: (x, p 1) :e pickN V0.
                  { exact (HrectSub (x, p 1) HpInRect). }
                  claim HNinH: pickN V0 :e H.
                  { exact (ReplI G (fun V1:set => pickN V1) V0 HV0G). }
                  rewrite HpEta.
                  rewrite Hp0eq at 1.
	                  exact (UnionI H (x, p 1) (pickN V0) HpInN HNinH).
	          }
	          apply HexSlice.
          let H. assume HH: H c= Fam /\ finite H /\ setprod {x} Y c= Union H.
          claim HHsub: H c= Fam.
          { exact (andEL (H c= Fam) (finite H) (andEL (H c= Fam /\ finite H) (setprod {x} Y c= Union H) HH)). }
          claim HHfin: finite H.
          { exact (andER (H c= Fam) (finite H) (andEL (H c= Fam /\ finite H) (setprod {x} Y c= Union H) HH)). }
          claim HHcov: setprod {x} Y c= Union H.
          { exact (andER (H c= Fam /\ finite H) (setprod {x} Y c= Union H) HH). }
          claim HHsubTop: H c= product_topology X Tx Y Ty.
          { let N0. assume HN0: N0 :e H.
            claim HN0Fam: N0 :e Fam.
            { exact (HHsub N0 HN0). }
            exact (HFamOpen N0 HN0Fam). }
          claim HtopProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
          { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
          claim HNtop: Union H :e product_topology X Tx Y Ty.
          { exact (topology_union_closed (setprod X Y) (product_topology X Tx Y Ty) H HtopProd HHsubTop). }
          claim Htube: exists U:set, U :e Tx /\ x :e U /\ setprod U Y c= Union H.
          { exact (tube_lemma X Tx Y Ty HTx HTy HY x Hx (Union H)
                 (andI ((Union H) :e product_topology X Tx Y Ty) (setprod {x} Y c= Union H) HNtop HHcov)). }
          apply Htube.
          let U. assume HU: U :e Tx /\ x :e U /\ setprod U Y c= Union H.
          claim HUAB0: U :e Tx /\ x :e U.
          { exact (andEL (U :e Tx /\ x :e U) (setprod U Y c= Union H) HU). }
          witness U.
          apply andI.
          - exact HUAB0.
          - witness H.
            exact (andI (H c= Fam /\ finite H) (setprod U Y c= Union H)
                        (andI (H c= Fam) (finite H) HHsub HHfin)
                        (andER (U :e Tx /\ x :e U) (setprod U Y c= Union H) HU)). }
        apply HexTube.
        let U. assume HU: U :e Tx /\ x :e U /\ exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H.
        claim HUAB: U :e Tx /\ x :e U.
        { exact (andEL (U :e Tx /\ x :e U) (exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H) HU). }
        claim HUtx: U :e Tx.
        { exact (andEL (U :e Tx) (x :e U) HUAB). }
        claim HxU: x :e U.
        { exact (andER (U :e Tx) (x :e U) HUAB). }
        claim HexH: exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H.
        { exact (andER (U :e Tx /\ x :e U) (exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H) HU). }
        claim HUinUFam: U :e UFam.
        { apply (SepI Tx (fun U0:set => exists H:set, H c= Fam /\ finite H /\ setprod U0 Y c= Union H) U HUtx).
          exact HexH. }
        exact (UnionI UFam x U HxU HUinUFam).
    - let U. assume HU: U :e UFam.
      exact (HUFamSubTx U HU). }
  claim HfinUFam: has_finite_subcover X Tx UFam.
  { exact (Heine_Borel_subcover X Tx UFam HX HcovUFam). }
  apply HfinUFam.
  let K. assume HK: K c= UFam /\ finite K /\ X c= Union K.
  claim HKsub: K c= UFam.
  { exact (andEL (K c= UFam) (finite K) (andEL (K c= UFam /\ finite K) (X c= Union K) HK)). }
  claim HKfin: finite K.
  { exact (andER (K c= UFam) (finite K) (andEL (K c= UFam /\ finite K) (X c= Union K) HK)). }
  claim HXcovK: X c= Union K.
  { exact (andER (K c= UFam /\ finite K) (X c= Union K) HK). }
  set pickH := fun U:set => Eps_i (fun H:set => H c= Fam /\ finite H /\ setprod U Y c= Union H).
  claim HpickH: forall U:set, U :e UFam -> pickH U c= Fam /\ finite (pickH U) /\ setprod U Y c= Union (pickH U).
  { let U. assume HU: U :e UFam.
    claim Hex: exists H:set, H c= Fam /\ finite H /\ setprod U Y c= Union H.
    { exact (SepE2 Tx (fun U0:set => exists H:set, H c= Fam /\ finite H /\ setprod U0 Y c= Union H) U HU). }
    apply Hex.
    let H0. assume HH0: H0 c= Fam /\ finite H0 /\ setprod U Y c= Union H0.
    exact (Eps_i_ax (fun H:set => H c= Fam /\ finite H /\ setprod U Y c= Union H) H0 HH0). }
  set G := \/_ U :e K, pickH U.
  prove has_finite_subcover (setprod X Y) (product_topology X Tx Y Ty) Fam.
  prove exists G0:set, G0 c= Fam /\ finite G0 /\ setprod X Y c= Union G0.
  witness G.
  apply andI.
  - prove G c= Fam /\ finite G.
    apply andI.
    + prove G c= Fam.
      let N. assume HN: N :e G.
      prove N :e Fam.
      apply (famunionE_impred K (fun U0:set => pickH U0) N HN).
      let U0. assume HU0K: U0 :e K.
      assume HNin: N :e pickH U0.
      claim HU0UFam: U0 :e UFam.
      { exact (HKsub U0 HU0K). }
      claim Hprop: pickH U0 c= Fam /\ finite (pickH U0) /\ setprod U0 Y c= Union (pickH U0).
      { exact (HpickH U0 HU0UFam). }
      claim HpropAB: pickH U0 c= Fam /\ finite (pickH U0).
      { exact (andEL (pickH U0 c= Fam /\ finite (pickH U0)) (setprod U0 Y c= Union (pickH U0)) Hprop). }
      claim HsubFam: pickH U0 c= Fam.
      { exact (andEL (pickH U0 c= Fam) (finite (pickH U0)) HpropAB). }
      exact (HsubFam N HNin).
    + prove finite G.
      claim HpEmpty: Empty c= UFam -> finite (\/_ U :e Empty, pickH U).
      { assume _.
        rewrite (famunion_Empty (fun U:set => pickH U)).
        exact finite_Empty. }
      claim HpStep: forall K0 y:set,
        finite K0 -> y /:e K0 ->
        (K0 c= UFam -> finite (\/_ U :e K0, pickH U)) ->
        ((K0 :\/: {y}) c= UFam -> finite (\/_ U :e (K0 :\/: {y}), pickH U)).
      { let K0 y.
        assume HK0fin HyNotin IH.
        assume Hsub: (K0 :\/: {y}) c= UFam.
        claim HK0sub: K0 c= UFam.
        { let U. assume HU: U :e K0.
          exact (Hsub U (binunionI1 K0 {y} U HU)). }
        claim HyUFam: y :e UFam.
        { exact (Hsub y (binunionI2 K0 {y} y (SingI y))). }
        claim Hfin0: finite (\/_ U :e K0, pickH U).
        { exact (IH HK0sub). }
        claim HpropY: pickH y c= Fam /\ finite (pickH y) /\ setprod y Y c= Union (pickH y).
        { exact (HpickH y HyUFam). }
        claim HpropYAB: pickH y c= Fam /\ finite (pickH y).
        { exact (andEL (pickH y c= Fam /\ finite (pickH y)) (setprod y Y c= Union (pickH y)) HpropY). }
        claim HfinY: finite (pickH y).
        { exact (andER (pickH y c= Fam) (finite (pickH y)) HpropYAB). }
        claim Heq: (\/_ U :e (K0 :\/: {y}), pickH U) = (\/_ U :e K0, pickH U) :\/: pickH y.
        { apply set_ext.
          - let N. assume HN: N :e (\/_ U :e (K0 :\/: {y}), pickH U).
            prove N :e (\/_ U :e K0, pickH U) :\/: pickH y.
            apply (famunionE_impred (K0 :\/: {y}) (fun U1:set => pickH U1) N HN).
            let U1. assume HU1: U1 :e K0 :\/: {y}.
            assume HNin: N :e pickH U1.
            apply (binunionE' K0 {y} U1 (N :e (\/_ U :e K0, pickH U) :\/: pickH y)).
            + assume HU1K0: U1 :e K0.
              apply binunionI1.
              exact (famunionI K0 (fun U2:set => pickH U2) U1 N HU1K0 HNin).
            + assume HU1y: U1 :e {y}.
              claim HU1eq: U1 = y.
              { exact (SingE y U1 HU1y). }
              claim HNy: N :e pickH y.
              { prove N :e pickH y.
                rewrite <- HU1eq at 1.
                exact HNin. }
              exact (binunionI2 (\/_ U :e K0, pickH U) (pickH y) N HNy).
            + exact HU1.
          - let N. assume HN: N :e (\/_ U :e K0, pickH U) :\/: pickH y.
            prove N :e (\/_ U :e (K0 :\/: {y}), pickH U).
            apply (binunionE' (\/_ U :e K0, pickH U) (pickH y) N (N :e (\/_ U :e (K0 :\/: {y}), pickH U))).
            + assume HN0: N :e (\/_ U :e K0, pickH U).
              apply (famunionE_impred K0 (fun U1:set => pickH U1) N HN0).
              let U1. assume HU1K0: U1 :e K0.
              assume HN1: N :e pickH U1.
              exact (famunionI (K0 :\/: {y}) (fun U2:set => pickH U2) U1 N (binunionI1 K0 {y} U1 HU1K0) HN1).
            + assume HNy: N :e pickH y.
              exact (famunionI (K0 :\/: {y}) (fun U2:set => pickH U2) y N (binunionI2 K0 {y} y (SingI y)) HNy).
            + exact HN. }
        rewrite Heq.
        exact (binunion_finite (\/_ U :e K0, pickH U) Hfin0 (pickH y) HfinY). }
      claim Hall: K c= UFam -> finite (\/_ U :e K, pickH U).
      { exact (finite_ind (fun K0:set => K0 c= UFam -> finite (\/_ U :e K0, pickH U)) HpEmpty HpStep K HKfin). }
      exact (Hall HKsub).
  - let p. assume Hp: p :e setprod X Y.
    prove p :e Union G.
    claim Hp0X: p 0 :e X.
    { exact (ap0_Sigma X (fun _:set => Y) p Hp). }
    claim Hp1Y: p 1 :e Y.
    { exact (ap1_Sigma X (fun _:set => Y) p Hp). }
    claim HpEta: p = (p 0, p 1).
    { exact (setprod_eta X Y p Hp). }
    claim Hp0InUnion: p 0 :e Union K.
    { exact (HXcovK (p 0) Hp0X). }
    apply (UnionE_impred K (p 0) Hp0InUnion).
    let U0. assume Hp0U0: p 0 :e U0.
    assume HU0K: U0 :e K.
    claim HU0UFam: U0 :e UFam.
    { exact (HKsub U0 HU0K). }
    claim Hprop: pickH U0 c= Fam /\ finite (pickH U0) /\ setprod U0 Y c= Union (pickH U0).
    { exact (HpickH U0 HU0UFam). }
    claim HcovU0: setprod U0 Y c= Union (pickH U0).
    { exact (andER (pickH U0 c= Fam /\ finite (pickH U0)) (setprod U0 Y c= Union (pickH U0)) Hprop). }
    claim HpInU0Y: (p 0, p 1) :e setprod U0 Y.
    { exact (tuple_2_setprod_by_pair_Sigma U0 Y (p 0) (p 1) Hp0U0 Hp1Y). }
    claim HpInUnionPick: (p 0, p 1) :e Union (pickH U0).
    { exact (HcovU0 (p 0, p 1) HpInU0Y). }
    apply (UnionE_impred (pickH U0) (p 0, p 1) HpInUnionPick).
    let N. assume HpN: (p 0, p 1) :e N.
    assume HNpick: N :e pickH U0.
    claim HNinG: N :e G.
    { exact (famunionI K (fun U1:set => pickH U1) U0 N HU0K HNpick). }
    rewrite HpEta.
    exact (UnionI G (p 0, p 1) N HpN HNinG).
Qed.

(** from §26 Exercises: compactness examples and properties **) 
(** LATEX VERSION: Exercises: unit interval closed in ℝ, unit interval compact, etc. **)
Theorem unit_interval_compact_axiom : compact_space unit_interval unit_interval_topology.
admit. (** FAIL **)
Qed.
Theorem ex26_compactness_exercises :
  (closed_in R R_standard_topology unit_interval) /\
  (compact_space unit_interval unit_interval_topology).
 prove closed_in R R_standard_topology unit_interval /\ compact_space unit_interval unit_interval_topology.
 apply andI.
- (** unit interval is closed in R **)
  prove closed_in R R_standard_topology unit_interval.
  claim HT: topology_on R R_standard_topology.
  { exact R_standard_topology_is_topology_local. }
  prove topology_on R R_standard_topology /\ (unit_interval c= R /\ exists U :e R_standard_topology, unit_interval = R :\: U).
  apply andI.
  - exact HT.
  - apply andI.
    + (** unit_interval c= R **)
      let x. assume Hx: x :e unit_interval.
      prove x :e R.
      exact (SepE1 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) x Hx).
    + (** witness the open complement **)
      set L0 := {x :e R|Rlt x 0}.
      set R1 := {x :e R|Rlt 1 x}.
      set U := L0 :\/: R1.
      witness U.
      apply andI.
      * (** U is open in R_standard_topology **)
        claim HL0: L0 :e R_standard_topology.
        { exact (open_left_ray_in_R_standard_topology 0 real_0). }
        claim HR1: R1 :e R_standard_topology.
        { exact (open_ray_in_R_standard_topology 1 real_1). }
        exact (topology_binunion_closed R R_standard_topology L0 R1 HT HL0 HR1).
      * (** unit_interval = R \\ U **)
        apply set_ext.
        { let x. assume Hx: x :e unit_interval.
          prove x :e R :\: U.
          claim HxR: x :e R.
          { exact (SepE1 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) x Hx). }
          claim Hxprop: ~(Rlt x 0) /\ ~(Rlt 1 x).
          { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) x Hx). }
          claim Hnx0: ~(Rlt x 0).
          { exact (andEL (~(Rlt x 0)) (~(Rlt 1 x)) Hxprop). }
          claim Hn1x: ~(Rlt 1 x).
          { exact (andER (~(Rlt x 0)) (~(Rlt 1 x)) Hxprop). }
          apply (setminusI R U x HxR).
          assume Hxu: x :e U.
          apply (binunionE L0 R1 x Hxu).
          - assume HxL: x :e L0.
            claim Hlt: Rlt x 0.
            { exact (SepE2 R (fun x0:set => Rlt x0 0) x HxL). }
            exact (Hnx0 Hlt).
          - assume HxR1: x :e R1.
            claim Hlt: Rlt 1 x.
            { exact (SepE2 R (fun x0:set => Rlt 1 x0) x HxR1). }
            exact (Hn1x Hlt). }
        { let x. assume Hx: x :e R :\: U.
          prove x :e unit_interval.
          claim HxR: x :e R.
          { exact (setminusE1 R U x Hx). }
          claim HxnotU: x /:e U.
          { exact (setminusE2 R U x Hx). }
          apply (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) x HxR).
          apply andI.
          - (** ~(x < 0) **)
            assume Hlt: Rlt x 0.
            prove False.
            claim HxL0: x :e L0.
            { exact (SepI R (fun x0:set => Rlt x0 0) x HxR Hlt). }
            claim HxU: x :e U.
            { exact (binunionI1 L0 R1 x HxL0). }
            exact (HxnotU HxU).
          - (** ~(1 < x) **)
            assume Hlt: Rlt 1 x.
            prove False.
            claim HxR1: x :e R1.
            { exact (SepI R (fun x0:set => Rlt 1 x0) x HxR Hlt). }
            claim HxU: x :e U.
            { exact (binunionI2 L0 R1 x HxR1). }
            exact (HxnotU HxU). }
- (** compactness part **)
  exact unit_interval_compact_axiom.
Qed.

(** from §26/§27: Heine-Borel on ℝ (closed and bounded sets) **) 
(** LATEX VERSION: Heine–Borel: compact subsets of ℝ are closed and bounded; converses addressed. **)
Theorem Heine_Borel_closed_bounded : forall A:set,
  A c= R ->
  compact_space A (subspace_topology R R_standard_topology A) ->
  closed_in R R_standard_topology A /\ bounded_subset_of_reals A.
let A.
assume HA: A c= R.
assume Hcomp: compact_space A (subspace_topology R R_standard_topology A).
prove closed_in R R_standard_topology A /\ bounded_subset_of_reals A.
apply andI.
- exact (compact_subspace_in_Hausdorff_closed R R_standard_topology A R_standard_topology_Hausdorff HA Hcomp).
- (** boundedness **)
	  apply (xm (A = Empty)).
	  + assume HA0: A = Empty.
	    prove exists M:set, M :e R /\ forall x:set, x :e A -> ~(Rlt M (Abs x)).
	    witness 0.
	    apply andI.
	    * exact real_0.
	    * let x. assume HxA: x :e A.
	      prove ~(Rlt 0 (Abs x)).
	      assume H.
	      claim HxE: x :e Empty.
	      { rewrite <- HA0.
	        exact HxA. }
	      exact (EmptyE x HxE).
	  + assume HAne: ~(A = Empty).
	    prove exists M:set, M :e R /\ forall x:set, x :e A -> ~(Rlt M (Abs x)).
	    claim HTtop: topology_on R R_standard_topology.
	    { exact R_standard_topology_is_topology_local. }
    claim Hiff:
      compact_space A (subspace_topology R R_standard_topology A) <->
        forall Fam:set, (Fam c= R_standard_topology /\ A c= Union Fam) ->
          has_finite_subcover A R_standard_topology Fam.
    { exact (compact_subspace_via_ambient_covers R R_standard_topology A HTtop HA). }
    claim Hcovprop:
      forall Fam:set, (Fam c= R_standard_topology /\ A c= Union Fam) ->
        has_finite_subcover A R_standard_topology Fam.
    { exact (iffEL (compact_space A (subspace_topology R R_standard_topology A))
                   (forall Fam:set, (Fam c= R_standard_topology /\ A c= Union Fam) ->
                      has_finite_subcover A R_standard_topology Fam)
                   Hiff Hcomp). }
    set f := fun n:set => open_interval (minus_SNo (ordsucc n)) (ordsucc n).
    set Fam0 := {f n|n :e omega}.
    claim HFam0sub: Fam0 c= R_standard_topology.
    { let U. assume HU: U :e Fam0.
      apply (ReplE_impred omega (fun n0:set => f n0) U HU (U :e R_standard_topology)).
      let n0. assume Hn0: n0 :e omega.
      assume Heq: U = f n0.
      rewrite Heq.
      prove f n0 :e R_standard_topology.
      claim Hbasis: basis_on R R_standard_basis.
      { exact R_standard_basis_is_basis_local. }
      claim Hn0s: ordsucc n0 :e R.
      { exact (ordsucc_in_R n0 Hn0). }
      claim Hmn0R: minus_SNo (ordsucc n0) :e R.
      { exact (real_minus_SNo (ordsucc n0) Hn0s). }
      claim HfInBasis: f n0 :e R_standard_basis.
      { set a := minus_SNo (ordsucc n0).
        set b := ordsucc n0.
        claim HaR: a :e R.
        { exact Hmn0R. }
        claim HbR: b :e R.
        { exact Hn0s. }
        claim Hinner: open_interval a b :e {open_interval a bb|bb :e R}.
        { exact (ReplI R (fun bb:set => open_interval a bb) b HbR). }
        exact (famunionI R (fun aa:set => {open_interval aa bb|bb :e R}) a (open_interval a b) HaR Hinner). }
      exact (basis_in_generated R R_standard_basis (f n0) Hbasis HfInBasis). }
    claim HAcover: A c= Union Fam0.
    { let x. assume HxA: x :e A.
      prove x :e Union Fam0.
      claim HxR: x :e R.
      { exact (HA x HxA). }
      (** Find an index n with x in f n. **)
      claim Hup: exists N:set, N :e omega /\ x < N.
      { apply (real_E x HxR (exists N:set, N :e omega /\ x < N)).
        assume HxS: SNo x.
        assume Hlev: SNoLev x :e ordsucc omega.
        assume HxSNoS: x :e SNoS_ (ordsucc omega).
        assume HmOmLt: minus_SNo omega < x.
        assume HxLtOm: x < omega.
        assume Huniq.
        assume Happrox.
        exact (SNoS_ordsucc_omega_bdd_above x HxSNoS HxLtOm). }
      claim Hlow: exists N:set, N :e omega /\ minus_SNo N < x.
      { apply (real_E x HxR (exists N:set, N :e omega /\ minus_SNo N < x)).
        assume HxS: SNo x.
        assume Hlev: SNoLev x :e ordsucc omega.
        assume HxSNoS: x :e SNoS_ (ordsucc omega).
        assume HmOmLt: minus_SNo omega < x.
        assume HxLtOm: x < omega.
        assume Huniq.
        assume Happrox.
        exact (SNoS_ordsucc_omega_bdd_below x HxSNoS HmOmLt). }
      apply Hup.
      let Nup. assume Hupconj.
      claim HNup: Nup :e omega.
      { exact (andEL (Nup :e omega) (x < Nup) Hupconj). }
      claim HxNup: x < Nup.
      { exact (andER (Nup :e omega) (x < Nup) Hupconj). }
      apply Hlow.
      let Nlow. assume Hlowconj.
      claim HNlow: Nlow :e omega.
      { exact (andEL (Nlow :e omega) (minus_SNo Nlow < x) Hlowconj). }
      claim HNlowx: minus_SNo Nlow < x.
      { exact (andER (Nlow :e omega) (minus_SNo Nlow < x) Hlowconj). }
      set n := Nup :\/: Nlow.
      claim HnO: n :e omega.
      { exact (omega_binunion Nup Nlow HNup HNlow). }
      claim Hordomega: ordinal omega.
      { exact omega_ordinal. }
      claim HordNup: ordinal Nup.
      { exact (ordinal_Hered omega Hordomega Nup HNup). }
      claim HordNlow: ordinal Nlow.
      { exact (ordinal_Hered omega Hordomega Nlow HNlow). }
      claim Hordn: ordinal n.
      { exact (ordinal_Hered omega Hordomega n HnO). }
      claim HNupSub: Nup c= n.
      { let t. assume Ht: t :e Nup.
        exact (binunionI1 Nup Nlow t Ht). }
      claim HNlowSub: Nlow c= n.
      { let t. assume Ht: t :e Nlow.
        exact (binunionI2 Nup Nlow t Ht). }
      claim HNupLe: Nup <= n.
      { exact (ordinal_Subq_SNoLe Nup n HordNup Hordn HNupSub). }
      claim HNlowLe: Nlow <= n.
      { exact (ordinal_Subq_SNoLe Nlow n HordNlow Hordn HNlowSub). }
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HNupS: SNo Nup.
      { exact (omega_SNo Nup HNup). }
      claim HnS: SNo n.
      { exact (omega_SNo n HnO). }
      claim Hxlt_n: x < n.
      { exact (SNoLtLe_tra x Nup n HxS HNupS HnS HxNup HNupLe). }
      claim Hn_in_ordsucc: n :e ordsucc n.
      { exact (ordsuccI2 n). }
      claim Hord_ordsucc: ordinal (ordsucc n).
      { exact (ordinal_ordsucc n Hordn). }
      claim Hnlt_ordsucc: n < ordsucc n.
      { exact (ordinal_In_SNoLt (ordsucc n) Hord_ordsucc n Hn_in_ordsucc). }
      claim HordS: SNo (ordsucc n).
      { exact (omega_SNo (ordsucc n) (omega_ordsucc n HnO)). }
      claim Hxlt_ordsucc: x < ordsucc n.
      { exact (SNoLt_tra x n (ordsucc n) HxS HnS HordS Hxlt_n Hnlt_ordsucc). }
      (** Lower bound: - ordsucc n < x. **)
      claim HNlowS: SNo Nlow.
      { exact (omega_SNo Nlow HNlow). }
      claim Hneg_nS: SNo (minus_SNo n).
      { exact (SNo_minus_SNo n HnS). }
      claim Hneg_NlowS: SNo (minus_SNo Nlow).
      { exact (SNo_minus_SNo Nlow HNlowS). }
      claim Hle_neg: minus_SNo n <= minus_SNo Nlow.
      { exact (minus_SNo_Le_contra Nlow n HNlowS HnS HNlowLe). }
      claim Hneglow_lt_x: minus_SNo Nlow < x.
      { exact HNlowx. }
      claim Hneg_n_lt_x: minus_SNo n < x.
      { exact (SNoLeLt_tra (minus_SNo n) (minus_SNo Nlow) x Hneg_nS Hneg_NlowS HxS Hle_neg Hneglow_lt_x). }
      claim Hnlt_ordsucc_neg: minus_SNo (ordsucc n) < minus_SNo n.
      { exact (minus_SNo_Lt_contra n (ordsucc n) HnS HordS Hnlt_ordsucc). }
      claim Hneg_ordsucc_lt_x: minus_SNo (ordsucc n) < x.
      { exact (SNoLt_tra (minus_SNo (ordsucc n)) (minus_SNo n) x
                         (SNo_minus_SNo (ordsucc n) HordS)
                         Hneg_nS
                         HxS
                         Hnlt_ordsucc_neg
                         Hneg_n_lt_x). }
      (** Now x is in the open interval. **)
      claim HordsuccR: ordsucc n :e R.
      { exact (ordsucc_in_R n HnO). }
      claim HnegordsuccR: minus_SNo (ordsucc n) :e R.
      { exact (real_minus_SNo (ordsucc n) HordsuccR). }
      claim HRltL: Rlt (minus_SNo (ordsucc n)) x.
      { exact (RltI (minus_SNo (ordsucc n)) x HnegordsuccR HxR Hneg_ordsucc_lt_x). }
      claim HRltR: Rlt x (ordsucc n).
      { exact (RltI x (ordsucc n) HxR HordsuccR Hxlt_ordsucc). }
      claim HxIn: x :e f n.
      { exact (SepI R (fun x0:set => Rlt (minus_SNo (ordsucc n)) x0 /\ Rlt x0 (ordsucc n))
                   x HxR (andI (Rlt (minus_SNo (ordsucc n)) x) (Rlt x (ordsucc n)) HRltL HRltR)). }
      claim HfnFam: f n :e Fam0.
      { exact (ReplI omega (fun n0:set => f n0) n HnO). }
      exact (UnionI Fam0 x (f n) HxIn HfnFam). }
    claim Hfincover: has_finite_subcover A R_standard_topology Fam0.
    { exact (Hcovprop Fam0 (andI (Fam0 c= R_standard_topology) (A c= Union Fam0) HFam0sub HAcover)). }
    apply Hfincover.
    let G. assume HGtriple.
    claim HGsub: G c= Fam0.
    { exact (andEL (G c= Fam0) (finite G) (andEL (G c= Fam0 /\ finite G) (A c= Union G) HGtriple)). }
    claim HGfin: finite G.
    { exact (andER (G c= Fam0) (finite G) (andEL (G c= Fam0 /\ finite G) (A c= Union G) HGtriple)). }
    claim HAcovG: A c= Union G.
    { exact (andER (G c= Fam0 /\ finite G) (A c= Union G) HGtriple). }
    set pickN := fun U:set => Eps_i (fun n0:set => n0 :e omega /\ U = f n0).
    set Nset := {pickN U|U :e G}.
    claim HNsetFin: finite Nset.
    { exact (Repl_finite (fun U0:set => pickN U0) G HGfin). }
    claim HexA: exists x:set, x :e A.
    { exact (nonempty_has_element A HAne). }
    apply HexA.
    let x0. assume Hx0A: x0 :e A.
    claim Hx0UG: x0 :e Union G.
    { exact (HAcovG x0 Hx0A). }
    claim HexU0: exists U0:set, x0 :e U0 /\ U0 :e G.
    { exact (iffEL (x0 :e Union G)
                   (exists Y:set, x0 :e Y /\ Y :e G)
                   (UnionEq G x0) Hx0UG). }
    apply HexU0.
    let U0. assume HU0conj.
    claim HU0G: U0 :e G.
    { exact (andER (x0 :e U0) (U0 :e G) HU0conj). }
    claim HU0Fam0: U0 :e Fam0.
    { exact (HGsub U0 HU0G). }
    claim Hexn0: exists n0:set, n0 :e omega /\ U0 = f n0.
    { exact (ReplE omega (fun n0:set => f n0) U0 HU0Fam0). }
    claim HpickU0: pickN U0 :e omega /\ U0 = f (pickN U0).
    { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U0 = f n0) Hexn0). }
    claim HpickU0O: pickN U0 :e omega.
    { exact (andEL (pickN U0 :e omega) (U0 = f (pickN U0)) HpickU0). }
    claim HNsetNe: Nset <> Empty.
    { apply (elem_implies_nonempty Nset (pickN U0)).
      exact (ReplI G (fun U:set => pickN U) U0 HU0G). }
    claim HAllSNo: forall y :e Nset, SNo y.
    { let y. assume Hy: y :e Nset.
      apply (ReplE_impred G (fun U:set => pickN U) y Hy (SNo y)).
      let U. assume HU: U :e G.
      assume Hey: y = pickN U.
      rewrite Hey.
      claim HUfam: U :e Fam0.
      { exact (HGsub U HU). }
      claim Hexn: exists n0:set, n0 :e omega /\ U = f n0.
      { exact (ReplE omega (fun n0:set => f n0) U HUfam). }
      claim Hpick: pickN U :e omega /\ U = f (pickN U).
      { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U = f n0) Hexn). }
      claim HpickO: pickN U :e omega.
      { exact (andEL (pickN U :e omega) (U = f (pickN U)) Hpick). }
      exact (omega_SNo (pickN U) HpickO). }
    claim Hexmax: exists nmax:set, SNo_max_of Nset nmax.
    { exact (finite_max_exists Nset (fun y Hy => HAllSNo y Hy) HNsetFin HNsetNe). }
    apply Hexmax.
    let nmax. assume Hmax.
    claim HnmaxIn: nmax :e Nset.
    { exact (andEL (nmax :e Nset) (SNo nmax) (andEL (nmax :e Nset /\ SNo nmax) (forall y :e Nset, SNo y -> y <= nmax) Hmax)). }
    claim HnmaxS: SNo nmax.
    { exact (andER (nmax :e Nset) (SNo nmax) (andEL (nmax :e Nset /\ SNo nmax) (forall y :e Nset, SNo y -> y <= nmax) Hmax)). }
    claim Hmaxprop: forall y :e Nset, SNo y -> y <= nmax.
    { exact (andER (nmax :e Nset /\ SNo nmax) (forall y :e Nset, SNo y -> y <= nmax) Hmax). }
    (** The bound is M = ordsucc nmax. **)
    set M := ordsucc nmax.
    witness M.
    apply andI.
    * claim HnmaxO: nmax :e omega.
      { apply (ReplE_impred G (fun U:set => pickN U) nmax HnmaxIn (nmax :e omega)).
        let U. assume HU: U :e G.
        assume Heq: nmax = pickN U.
        rewrite Heq.
        claim HUfam: U :e Fam0.
        { exact (HGsub U HU). }
        claim Hexn: exists n0:set, n0 :e omega /\ U = f n0.
        { exact (ReplE omega (fun n0:set => f n0) U HUfam). }
        claim Hpick: pickN U :e omega /\ U = f (pickN U).
        { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U = f n0) Hexn). }
        exact (andEL (pickN U :e omega) (U = f (pickN U)) Hpick). }
      exact (ordsucc_in_R nmax HnmaxO).
    * let x. assume HxA: x :e A.
      prove ~(Rlt M (Abs x)).
      claim HxUG: x :e Union G.
      { exact (HAcovG x HxA). }
      (** Use UnionEq via iff to extract a witness. **)
      claim HexU: exists U:set, x :e U /\ U :e G.
      { exact (iffEL (x :e Union G) (exists Y:set, x :e Y /\ Y :e G) (UnionEq G x) HxUG). }
      apply HexU.
      let U. assume HUconj.
      claim HUinG: U :e G.
      { exact (andER (x :e U) (U :e G) HUconj). }
      claim HxU: x :e U.
      { exact (andEL (x :e U) (U :e G) HUconj). }
      claim HUfam: U :e Fam0.
      { exact (HGsub U HUinG). }
      claim Hexn: exists n0:set, n0 :e omega /\ U = f n0.
      { exact (ReplE omega (fun n0:set => f n0) U HUfam). }
      claim Hpick: pickN U :e omega /\ U = f (pickN U).
      { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U = f n0) Hexn). }
      claim HnU: pickN U :e omega.
      { exact (andEL (pickN U :e omega) (U = f (pickN U)) Hpick). }
      claim HUeq: U = f (pickN U).
      { exact (andER (pickN U :e omega) (U = f (pickN U)) Hpick). }
      claim HNin: pickN U :e Nset.
      { exact (ReplI G (fun U0:set => pickN U0) U HUinG). }
      claim HNle: pickN U <= nmax.
      { exact (Hmaxprop (pickN U) HNin (omega_SNo (pickN U) HnU)). }
      claim HordsuccLe: ordsucc (pickN U) <= M.
      { (** use n<=nmax implies n+1 <= nmax+1 **)
        claim HnU_S: SNo (pickN U).
        { exact (omega_SNo (pickN U) HnU). }
        claim HnmaxO: nmax :e omega.
        { apply (ReplE_impred G (fun U0:set => pickN U0) nmax HnmaxIn (nmax :e omega)).
          let U1. assume HU1: U1 :e G.
          assume Heq: nmax = pickN U1.
          rewrite Heq.
          claim HU1fam: U1 :e Fam0.
          { exact (HGsub U1 HU1). }
          claim Hexn1: exists n0:set, n0 :e omega /\ U1 = f n0.
          { exact (ReplE omega (fun n0:set => f n0) U1 HU1fam). }
          claim Hpick1: pickN U1 :e omega /\ U1 = f (pickN U1).
          { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U1 = f n0) Hexn1). }
          exact (andEL (pickN U1 :e omega) (U1 = f (pickN U1)) Hpick1). }
        claim Hnmax_S: SNo nmax.
        { exact (omega_SNo nmax HnmaxO). }
        claim H1S: SNo 1.
        { exact SNo_1. }
        claim Hadd: add_SNo (pickN U) 1 <= add_SNo nmax 1.
        { exact (add_SNo_Le1 (pickN U) 1 nmax HnU_S H1S Hnmax_S HNle). }
        claim Hm1: add_SNo (pickN U) 1 = ordsucc (pickN U).
        { exact (add_SNo_1_ordsucc (pickN U) HnU). }
        claim Hm2: add_SNo nmax 1 = ordsucc nmax.
        { exact (add_SNo_1_ordsucc nmax HnmaxO). }
        rewrite <- Hm1.
        rewrite <- Hm2.
        exact Hadd. }
      claim HxUfn: x :e f (pickN U).
      { rewrite <- HUeq.
        exact HxU. }
      claim HxR: x :e R.
      { exact (HA x HxA). }
      claim Hxconj: Rlt (minus_SNo (ordsucc (pickN U))) x /\ Rlt x (ordsucc (pickN U)).
      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo (ordsucc (pickN U))) x0 /\ Rlt x0 (ordsucc (pickN U))) x HxUfn). }
      claim HxL: Rlt (minus_SNo (ordsucc (pickN U))) x.
      { exact (andEL (Rlt (minus_SNo (ordsucc (pickN U))) x) (Rlt x (ordsucc (pickN U))) Hxconj). }
      claim HxRgt: Rlt x (ordsucc (pickN U)).
      { exact (andER (Rlt (minus_SNo (ordsucc (pickN U))) x) (Rlt x (ordsucc (pickN U))) Hxconj). }
      (** Strengthen bounds to M. **)
      (** Use interval_bounds_Abs with endpoints -M and M. **)
      claim HNsetSubOmega: Nset c= omega.
      { let y. assume Hy: y :e Nset.
        apply (ReplE_impred G (fun U0:set => pickN U0) y Hy (y :e omega)).
        let U0. assume HU0: U0 :e G.
        assume Hey: y = pickN U0.
        rewrite Hey.
        claim HU0fam: U0 :e Fam0.
        { exact (HGsub U0 HU0). }
        claim Hexn0: exists n0:set, n0 :e omega /\ U0 = f n0.
        { exact (ReplE omega (fun n0:set => f n0) U0 HU0fam). }
        claim Hpick0: pickN U0 :e omega /\ U0 = f (pickN U0).
        { exact (Eps_i_ex (fun n0:set => n0 :e omega /\ U0 = f n0) Hexn0). }
        exact (andEL (pickN U0 :e omega) (U0 = f (pickN U0)) Hpick0). }
      claim HnmaxO: nmax :e omega.
      { exact (HNsetSubOmega nmax HnmaxIn). }
      claim HM: M :e R.
      { exact (ordsucc_in_R nmax HnmaxO). }
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HM_S: SNo M.
      { exact (real_SNo M HM). }
      claim HmU: ordsucc (pickN U) :e R.
      { exact (ordsucc_in_R (pickN U) HnU). }
      claim HmU_S: SNo (ordsucc (pickN U)).
      { exact (omega_SNo (ordsucc (pickN U)) (omega_ordsucc (pickN U) HnU)). }
      claim HxltmU: x < ordsucc (pickN U).
      { exact (RltE_lt x (ordsucc (pickN U)) HxRgt). }
      claim HxltM: x < M.
      { exact (SNoLtLe_tra x (ordsucc (pickN U)) M HxS HmU_S HM_S HxltmU HordsuccLe). }
      claim HRltxM: Rlt x M.
      { exact (RltI x M HxR HM HxltM). }
      claim HnegM_R: minus_SNo M :e R.
      { exact (real_minus_SNo M HM). }
      claim HnegM_S: SNo (minus_SNo M).
      { exact (SNo_minus_SNo M HM_S). }
      claim HnegmU_S: SNo (minus_SNo (ordsucc (pickN U))).
      { exact (SNo_minus_SNo (ordsucc (pickN U)) HmU_S). }
      claim Hxgt_negmU: minus_SNo (ordsucc (pickN U)) < x.
      { exact (RltE_lt (minus_SNo (ordsucc (pickN U))) x HxL). }
      claim Hle_neg: minus_SNo M <= minus_SNo (ordsucc (pickN U)).
      { exact (minus_SNo_Le_contra (ordsucc (pickN U)) M HmU_S HM_S HordsuccLe). }
      claim HnegM_lt_x: minus_SNo M < x.
      { exact (SNoLeLt_tra (minus_SNo M) (minus_SNo (ordsucc (pickN U))) x HnegM_S HnegmU_S HxS Hle_neg Hxgt_negmU). }
      claim HRltnegMx: Rlt (minus_SNo M) x.
      { exact (RltI (minus_SNo M) x HnegM_R HxR HnegM_lt_x). }
      exact (interval_bounds_Abs M x HM HxR HRltnegMx HRltxM).
Qed.

(** from §27: compact subspaces of ℝ are closed and bounded **) 
(** LATEX VERSION: Any compact subspace of ℝ is closed and bounded. **)
Theorem compact_real_closed_bounded : forall A:set,
  compact_space A (subspace_topology R R_standard_topology A) ->
  closed_in R R_standard_topology A /\ bounded_subset_of_reals A.
let A.
assume Hcomp: compact_space A (subspace_topology R R_standard_topology A).
prove closed_in R R_standard_topology A /\ bounded_subset_of_reals A.
claim HtopA: topology_on A (subspace_topology R R_standard_topology A).
{ exact (andEL (topology_on A (subspace_topology R R_standard_topology A))
               (forall Fam:set, open_cover_of A (subspace_topology R R_standard_topology A) Fam ->
                  has_finite_subcover A (subspace_topology R R_standard_topology A) Fam)
               Hcomp). }
claim HAin: A :e subspace_topology R R_standard_topology A.
{ exact (topology_has_X A (subspace_topology R R_standard_topology A) HtopA). }
claim HexV: exists V :e R_standard_topology, A = V :/\: A.
{ exact (SepE2 (Power A)
               (fun U0:set => exists V :e R_standard_topology, U0 = V :/\: A)
               A HAin). }
apply HexV.
let V. assume HVpair.
claim HV: V :e R_standard_topology.
{ exact (andEL (V :e R_standard_topology) (A = V :/\: A) HVpair). }
claim HAeq: A = V :/\: A.
{ exact (andER (V :e R_standard_topology) (A = V :/\: A) HVpair). }
claim HT: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim HVsubR: V c= R.
{ exact (topology_elem_subset R R_standard_topology V HT HV). }
claim HA: A c= R.
{ let x. assume HxA: x :e A.
  claim HxVA: x :e V :/\: A.
  { rewrite <- HAeq.
    exact HxA. }
  claim HxV: x :e V.
  { exact (binintersectE1 V A x HxVA). }
  exact (HVsubR x HxV). }
exact (Heine_Borel_closed_bounded A HA Hcomp).
Qed.

(** from §28 Definition: limit point compactness **) 
(** LATEX VERSION: Limit point compact means every infinite subset has a limit point in X. **)
Definition limit_point_compact : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall A:set, A c= X -> infinite A -> exists x:set, limit_point_of X Tx A x.

(** Helper: extract topology_on from limit_point_compact **)
Theorem limit_point_compact_topology : forall X Tx:set,
  limit_point_compact X Tx -> topology_on X Tx.
let X Tx.
assume H: limit_point_compact X Tx.
exact (andEL (topology_on X Tx)
             (forall A:set, A c= X -> infinite A -> exists x:set, limit_point_of X Tx A x)
             H).
Qed.

(** Helper: extract limit point property from limit_point_compact **)
Theorem limit_point_compact_property : forall X Tx A:set,
  limit_point_compact X Tx -> A c= X -> infinite A -> exists x:set, limit_point_of X Tx A x.
let X Tx A.
assume H: limit_point_compact X Tx.
assume HA: A c= X.
assume Hinf: infinite A.
claim Hprop: forall A0:set, A0 c= X -> infinite A0 -> exists x:set, limit_point_of X Tx A0 x.
{ exact (andER (topology_on X Tx)
               (forall A0:set, A0 c= X -> infinite A0 -> exists x:set, limit_point_of X Tx A0 x)
               H). }
exact (Hprop A HA Hinf).
Qed.

(** LATEX VERSION: Compact ⇒ limit point compact. **)
Theorem compact_implies_limit_point_compact : forall X Tx:set,
  compact_space X Tx -> limit_point_compact X Tx.
let X Tx.
assume Hcomp: compact_space X Tx.
prove limit_point_compact X Tx.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }
prove topology_on X Tx /\
  forall A:set, A c= X -> infinite A -> exists x:set, limit_point_of X Tx A x.
apply andI.
- exact HTx.
- let A.
  assume HA: A c= X.
  assume HinfA: infinite A.
  prove exists x:set, limit_point_of X Tx A x.
  apply (xm (exists x:set, limit_point_of X Tx A x)).
  + assume Hex: exists x:set, limit_point_of X Tx A x.
    exact Hex.
  + assume Hnone: ~(exists x:set, limit_point_of X Tx A x).
    prove exists x:set, limit_point_of X Tx A x.
    apply FalseE.
    prove False.

    set Fam := {U :e Tx | exists x:set, x :e X /\ x :e U /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U)}.

    claim HFam_in_Tx: forall U:set, U :e Fam -> U :e Tx.
    { let U. assume HU: U :e Fam.
      exact (SepE1 Tx (fun U0:set => exists x:set, x :e X /\ x :e U0 /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U0)) U HU). }

    claim HFam_sub_PowX: Fam c= Power X.
    { let U. assume HU: U :e Fam.
      prove U :e Power X.
      claim HUinTx: U :e Tx.
      { exact (HFam_in_Tx U HU). }
      claim HUsubX: U c= X.
      { exact (topology_elem_subset X Tx U HTx HUinTx). }
      exact (PowerI X U HUsubX). }

    claim HX_sub_UnionFam: X c= Union Fam.
    { let x. assume HxX: x :e X.
      prove x :e Union Fam.
      claim HnotLp: ~ limit_point_of X Tx A x.
      { assume Hlp: limit_point_of X Tx A x.
        apply Hnone.
        witness x.
        exact Hlp. }

      claim HnotForall: ~(forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
      { assume Hall: forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
        apply HnotLp.
        prove topology_on X Tx /\ x :e X /\ forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
        apply andI.
        - apply andI.
          + exact HTx.
          + exact HxX.
        - exact Hall. }

      claim HexU: exists U:set, ~(U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
      { exact (not_all_ex_demorgan_i (fun U:set => U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U) HnotForall). }
      apply HexU.
      let U.
      assume HnotImp: ~(U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).

      claim HUinTx: U :e Tx.
      { apply (xm (U :e Tx)).
        - assume HU: U :e Tx.
          exact HU.
        - assume HUn: U /:e Tx.
          prove U :e Tx.
          apply FalseE.
          prove False.
          claim Himp: U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
          { assume HU0: U :e Tx.
            assume _.
            apply FalseE.
            exact (HUn HU0). }
          exact (HnotImp Himp). }

      claim HxU: x :e U.
      { apply (xm (x :e U)).
        - assume Hxu: x :e U.
          exact Hxu.
        - assume HxUn: x /:e U.
          prove x :e U.
          apply FalseE.
          prove False.
          claim Himp: U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
          { assume _.
            assume Hxu: x :e U.
            apply FalseE.
            exact (HxUn Hxu). }
          exact (HnotImp Himp). }

      claim HnoY: ~(exists y:set, y :e A /\ y <> x /\ y :e U).
      { assume Hexy: exists y:set, y :e A /\ y <> x /\ y :e U.
        prove False.
        claim Himp: U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
        { assume _. assume _. exact Hexy. }
        exact (HnotImp Himp). }

      claim HUinFam: U :e Fam.
      { apply (SepI Tx
                    (fun U0:set => exists x0:set, x0 :e X /\ x0 :e U0 /\ ~(exists y:set, y :e A /\ y <> x0 /\ y :e U0))
                    U HUinTx).
        witness x.
        apply andI.
        - apply andI.
          + exact HxX.
          + exact HxU.
        - exact HnoY. }

      exact (UnionI Fam x U HxU HUinFam). }

    claim HFam_cover: open_cover_of X Tx Fam.
    { prove topology_on X Tx /\ Fam c= Power X /\ X c= Union Fam /\ (forall U:set, U :e Fam -> U :e Tx).
      apply andI.
      - prove (topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam.
        apply andI.
        + prove topology_on X Tx /\ Fam c= Power X.
          apply andI.
          * exact HTx.
          * exact HFam_sub_PowX.
        + exact HX_sub_UnionFam.
      - exact HFam_in_Tx. }

    claim Hsub: has_finite_subcover X Tx Fam.
    { exact (Heine_Borel_subcover X Tx Fam Hcomp HFam_cover). }
    apply Hsub.
    let G.
    assume HG: G c= Fam /\ finite G /\ X c= Union G.

    claim HG1: G c= Fam /\ finite G.
    { exact (andEL (G c= Fam /\ finite G) (X c= Union G) HG). }
    claim HGsub: G c= Fam.
    { exact (andEL (G c= Fam) (finite G) HG1). }
    claim HGfin: finite G.
    { exact (andER (G c= Fam) (finite G) HG1). }
    claim HXcovG: X c= Union G.
    { exact (andER (G c= Fam /\ finite G) (X c= Union G) HG). }

    set pickX := fun U:set => Eps_i (fun x:set => x :e X /\ x :e U /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U)).
    set Ximg := {pickX U|U :e G}.

    claim HXimgFin: finite Ximg.
    { exact (Repl_finite (fun U:set => pickX U) G HGfin). }

    claim HAsubXimg: A c= Ximg.
    { let a. assume HaA: a :e A.
      prove a :e Ximg.
      claim HaX: a :e X.
      { exact (HA a HaA). }
      claim HaUnionG: a :e Union G.
      { exact (HXcovG a HaX). }
      apply (UnionE_impred G a HaUnionG).
      let U.
      assume HaU: a :e U.
      assume HUinG: U :e G.

      claim HUinFam: U :e Fam.
      { exact (HGsub U HUinG). }
      claim HexxU: exists x:set, x :e X /\ x :e U /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U).
      { exact (SepE2 Tx
                    (fun U0:set => exists x:set, x :e X /\ x :e U0 /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U0))
                    U HUinFam). }
      claim HpickProp: pickX U :e X /\ pickX U :e U /\ ~(exists y:set, y :e A /\ y <> pickX U /\ y :e U).
      { apply HexxU.
        let x0.
        assume Hx0: x0 :e X /\ x0 :e U /\ ~(exists y:set, y :e A /\ y <> x0 /\ y :e U).
        exact (Eps_i_ax (fun x:set => x :e X /\ x :e U /\ ~(exists y:set, y :e A /\ y <> x /\ y :e U)) x0 Hx0). }

      claim HnoOther: ~(exists y:set, y :e A /\ y <> pickX U /\ y :e U).
      { exact (andER (pickX U :e X /\ pickX U :e U) (~(exists y:set, y :e A /\ y <> pickX U /\ y :e U)) HpickProp). }

      claim HaEq: a = pickX U.
      { apply (xm (a = pickX U)).
        - assume Heq: a = pickX U.
          exact Heq.
        - assume Hneq: a <> pickX U.
          prove a = pickX U.
          apply FalseE.
          prove False.
          claim Hexy: exists y:set, y :e A /\ y <> pickX U /\ y :e U.
          { witness a.
            apply andI.
            - apply andI.
              + exact HaA.
              + exact Hneq.
            - exact HaU. }
          exact (HnoOther Hexy). }

      claim HpickInImg: pickX U :e Ximg.
      { exact (ReplI G (fun U0:set => pickX U0) U HUinG). }
      rewrite HaEq.
      exact HpickInImg. }

    claim HfinA: finite A.
    { exact (Subq_finite Ximg HXimgFin A HAsubXimg). }
    exact (HinfA HfinA).
Qed.

(** from §28: limit point compactness vs compactness **) 
(** LATEX VERSION: Limit point compact need not imply compact; provides counterexample placeholder. **)
Theorem limit_point_compact_not_necessarily_compact :
  exists X Tx:set, limit_point_compact X Tx /\ ~ compact_space X Tx.
prove exists X Tx:set, limit_point_compact X Tx /\ ~ compact_space X Tx.
set Y := {0,1}.
set Ty := indiscrete_topology Y.
set Tx0 := discrete_topology omega.
set X := setprod omega Y.
set Tx := product_topology omega Tx0 Y Ty.
witness X.
witness Tx.
apply andI.
- (** limit_point_compact X Tx **)
  prove limit_point_compact X Tx.
  prove topology_on X Tx /\
    forall A:set, A c= X -> infinite A -> exists x:set, limit_point_of X Tx A x.
  apply andI.
  + (** topology_on X Tx **)
    exact (product_topology_is_topology omega Tx0 Y Ty (discrete_topology_on omega) (indiscrete_topology_on Y)).
  + (** every infinite A has a limit point **)
    let A.
    assume HA: A c= X.
    assume HinfA: infinite A.
    prove exists x:set, limit_point_of X Tx A x.
    (** First: A is nonempty since Empty is finite. **)
	    claim HAnotEmpty: A <> Empty.
	    { apply (xm (A = Empty)).
	      - assume HAeq: A = Empty.
	        apply FalseE.
	        prove False.
	        apply HinfA.
	        rewrite HAeq.
	        exact finite_Empty.
	      - assume Hneq: A <> Empty.
	        exact Hneq. }
    (** Extract an element a :e A by classical reasoning. **)
    claim Hexa: exists a:set, a :e A.
    { apply (xm (exists a:set, a :e A)).
      - assume Hex. exact Hex.
	      - assume Hnoex: ~(exists a:set, a :e A).
	        apply FalseE.
	        prove False.
	        apply HAnotEmpty.
	        apply set_ext.
	        + let x. assume HxA: x :e A.
	          apply FalseE.
	          prove False.
	          claim Hex: exists a:set, a :e A.
	          { witness x.
	            exact HxA. }
	          exact (Hnoex Hex).
		        + let x. assume HxE: x :e Empty.
		          apply FalseE.
		          prove False.
		          apply (EmptyE x).
		          exact HxE. }
    apply Hexa.
    let a. assume HaA: a :e A.
    claim HaX: a :e X.
    { exact (HA a HaA). }
    claim Ha0w: a 0 :e omega.
    { exact (ap0_Sigma omega (fun _ : set => Y) a HaX). }
    claim Ha1Y: a 1 :e Y.
    { exact (ap1_Sigma omega (fun _ : set => Y) a HaX). }
    claim Ha1cases: a 1 = 0 \/ a 1 = 1.
    { exact (UPairE (a 1) 0 1 Ha1Y). }
    apply Ha1cases.
    * (** Case a = (a0,0); use x = (a0,1) as a limit point. **)
      assume Ha10: a 1 = 0.
      set x := (a 0, 1).
      witness x.
      prove limit_point_of X Tx A x.
	      prove topology_on X Tx /\ x :e X /\
	        forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
	      apply andI.
	      - apply andI.
	        + (** topology_on X Tx **)
	          exact (product_topology_is_topology omega Tx0 Y Ty (discrete_topology_on omega) (indiscrete_topology_on Y)).
	        + (** x :e X **)
	          claim H1Y: 1 :e Y.
	          { exact (UPairI2 0 1). }
	          exact (tuple_2_setprod_by_pair_Sigma omega Y (a 0) 1 Ha0w H1Y).
	      - (** neighborhood condition **)
	        let U. assume HU: U :e Tx. assume HxU: x :e U.
	        prove exists y:set, y :e A /\ y <> x /\ y :e U.
         (** Use the generated_topology neighborhood property to find a basis rectangle b ⊂ U with x ∈ b. **)
         claim HUprop: forall p :e U, exists b :e product_subbasis omega Tx0 Y Ty, p :e b /\ b c= U.
         { exact (SepE2 (Power X)
                        (fun U0 : set => forall p0 :e U0,
                           exists b :e product_subbasis omega Tx0 Y Ty, p0 :e b /\ b c= U0)
                        U HU). }
	         claim Hexb: exists b :e product_subbasis omega Tx0 Y Ty, x :e b /\ b c= U.
	         { exact (HUprop x HxU). }
	         apply Hexb.
	         let b. assume Hbp: b :e product_subbasis omega Tx0 Y Ty /\ (x :e b /\ b c= U).
	         claim HbB: b :e product_subbasis omega Tx0 Y Ty.
	         { exact (andEL (b :e product_subbasis omega Tx0 Y Ty) (x :e b /\ b c= U) Hbp). }
	         claim Hbprop: x :e b /\ b c= U.
	         { exact (andER (b :e product_subbasis omega Tx0 Y Ty) (x :e b /\ b c= U) Hbp). }
	         claim Hxb: x :e b.
	         { exact (andEL (x :e b) (b c= U) Hbprop). }
	         claim HbsubU: b c= U.
	         { exact (andER (x :e b) (b c= U) Hbprop). }
         (** Decode b as a rectangle_set U0 V0. **)
         claim HexU0: exists U0 :e Tx0, b :e {rectangle_set U0 V|V :e Ty}.
         { exact (famunionE Tx0 (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbB). }
         apply HexU0.
         let U0. assume HU0pair: U0 :e Tx0 /\ b :e {rectangle_set U0 V|V :e Ty}.
         claim HU0: U0 :e Tx0.
         { exact (andEL (U0 :e Tx0) (b :e {rectangle_set U0 V|V :e Ty}) HU0pair). }
         claim HbRepl: b :e {rectangle_set U0 V|V :e Ty}.
         { exact (andER (U0 :e Tx0) (b :e {rectangle_set U0 V|V :e Ty}) HU0pair). }
         claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
         { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbRepl). }
         apply HexV0.
         let V0. assume HV0pair: V0 :e Ty /\ b = rectangle_set U0 V0.
         claim HV0: V0 :e Ty.
         { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }
         claim Hbeq: b = rectangle_set U0 V0.
         { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }
         (** From x ∈ b = U0×V0, infer a0 ∈ U0 and 1 ∈ V0. **)
         claim HxRect: x :e rectangle_set U0 V0.
         { rewrite <- Hbeq. exact Hxb. }
         claim Hx0U0: x 0 :e U0.
         { exact (ap0_Sigma U0 (fun _ : set => V0) x HxRect). }
         claim Hx1V0: x 1 :e V0.
         { exact (ap1_Sigma U0 (fun _ : set => V0) x HxRect). }
         claim Hx0eq: x 0 = a 0.
         { exact (tuple_2_0_eq (a 0) 1). }
         claim Hx1eq: x 1 = 1.
         { exact (tuple_2_1_eq (a 0) 1). }
         claim Ha0U0: a 0 :e U0.
         { rewrite <- Hx0eq.
           exact Hx0U0. }
         (** In the indiscrete topology, the only nonempty open is Y, so V0 = Y. **)
         claim HV0cases: V0 = Empty \/ V0 = Y.
         { exact (UPairE V0 Empty Y HV0). }
         claim HV0ne: V0 <> Empty.
         { exact (elem_implies_nonempty V0 (x 1) Hx1V0). }
         claim HV0Y: V0 = Y.
         { apply HV0cases.
           - assume HV0E: V0 = Empty.
             apply FalseE.
             prove False.
             exact (HV0ne HV0E).
           - assume HV0Y': V0 = Y.
             exact HV0Y'. }
	         claim HxRectY: x :e rectangle_set U0 Y.
	         { rewrite <- HV0Y.
	           exact HxRect. }
         (** Now show a ∈ b ⊆ U, hence a ∈ U. **)
         claim HaEta: a = (a 0, a 1).
         { exact (setprod_eta omega Y a HaX). }
         claim H0Y: 0 :e Y.
         { exact (UPairI1 0 1). }
         claim HaInRect: a :e rectangle_set U0 V0.
         { rewrite HV0Y.
           rewrite HaEta.
           rewrite Ha10.
           exact (tuple_2_setprod_by_pair_Sigma U0 Y (a 0) 0 Ha0U0 H0Y). }
         claim HaInb: a :e b.
         { rewrite Hbeq.
           exact HaInRect. }
	         claim HaU: a :e U.
	         { exact (HbsubU a HaInb). }
	         witness a.
	         apply andI.
	         - apply andI.
	           + exact HaA.
	           + prove a <> x.
		             assume Heq: a = x.
		             claim Heq1: a 1 = x 1.
		             { rewrite <- Heq.
		               reflexivity. }
		             claim H01: 0 = 1.
		             { rewrite <- Ha10 at 1.
		               rewrite <- Hx1eq at 2.
		               exact Heq1. }
	             exact (neq_0_1 H01).
	         - exact HaU.
    * (** Case a = (a0,1); use x = (a0,0) as a limit point. **)
      assume Ha11: a 1 = 1.
      set x := (a 0, 0).
      witness x.
      prove limit_point_of X Tx A x.
	      prove topology_on X Tx /\ x :e X /\
	        forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
	      apply andI.
	      - apply andI.
	        + exact (product_topology_is_topology omega Tx0 Y Ty (discrete_topology_on omega) (indiscrete_topology_on Y)).
	        + claim H0Y: 0 :e Y.
	          { exact (UPairI1 0 1). }
	          exact (tuple_2_setprod_by_pair_Sigma omega Y (a 0) 0 Ha0w H0Y).
	      - let U. assume HU: U :e Tx. assume HxU: x :e U.
	        prove exists y:set, y :e A /\ y <> x /\ y :e U.
         claim HUprop: forall p :e U, exists b :e product_subbasis omega Tx0 Y Ty, p :e b /\ b c= U.
         { exact (SepE2 (Power X)
                        (fun U0 : set => forall p0 :e U0,
                           exists b :e product_subbasis omega Tx0 Y Ty, p0 :e b /\ b c= U0)
                        U HU). }
	         claim Hexb: exists b :e product_subbasis omega Tx0 Y Ty, x :e b /\ b c= U.
	         { exact (HUprop x HxU). }
	         apply Hexb.
	         let b. assume Hbp: b :e product_subbasis omega Tx0 Y Ty /\ (x :e b /\ b c= U).
	         claim HbB: b :e product_subbasis omega Tx0 Y Ty.
	         { exact (andEL (b :e product_subbasis omega Tx0 Y Ty) (x :e b /\ b c= U) Hbp). }
	         claim Hbprop: x :e b /\ b c= U.
	         { exact (andER (b :e product_subbasis omega Tx0 Y Ty) (x :e b /\ b c= U) Hbp). }
	         claim Hxb: x :e b.
	         { exact (andEL (x :e b) (b c= U) Hbprop). }
	         claim HbsubU: b c= U.
	         { exact (andER (x :e b) (b c= U) Hbprop). }
         claim HexU0: exists U0 :e Tx0, b :e {rectangle_set U0 V|V :e Ty}.
         { exact (famunionE Tx0 (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbB). }
         apply HexU0.
         let U0. assume HU0pair: U0 :e Tx0 /\ b :e {rectangle_set U0 V|V :e Ty}.
         claim HbRepl: b :e {rectangle_set U0 V|V :e Ty}.
         { exact (andER (U0 :e Tx0) (b :e {rectangle_set U0 V|V :e Ty}) HU0pair). }
         claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
         { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbRepl). }
         apply HexV0.
         let V0. assume HV0pair: V0 :e Ty /\ b = rectangle_set U0 V0.
         claim HV0: V0 :e Ty.
         { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }
         claim Hbeq: b = rectangle_set U0 V0.
         { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }
         claim HxRect: x :e rectangle_set U0 V0.
         { rewrite <- Hbeq. exact Hxb. }
         claim Hx0U0: x 0 :e U0.
         { exact (ap0_Sigma U0 (fun _ : set => V0) x HxRect). }
         claim Hx1V0: x 1 :e V0.
         { exact (ap1_Sigma U0 (fun _ : set => V0) x HxRect). }
         claim Hx0eq: x 0 = a 0.
         { exact (tuple_2_0_eq (a 0) 0). }
         claim Hx1eq: x 1 = 0.
         { exact (tuple_2_1_eq (a 0) 0). }
         claim Ha0U0: a 0 :e U0.
         { rewrite <- Hx0eq.
           exact Hx0U0. }
         claim HV0cases: V0 = Empty \/ V0 = Y.
         { exact (UPairE V0 Empty Y HV0). }
         claim HV0ne: V0 <> Empty.
         { exact (elem_implies_nonempty V0 (x 1) Hx1V0). }
         claim HV0Y: V0 = Y.
         { apply HV0cases.
           - assume HV0E: V0 = Empty.
             apply FalseE.
             prove False.
             exact (HV0ne HV0E).
           - assume HV0Y': V0 = Y.
             exact HV0Y'. }
         claim HaEta: a = (a 0, a 1).
         { exact (setprod_eta omega Y a HaX). }
         claim H1Y: 1 :e Y.
         { exact (UPairI2 0 1). }
         claim HaInRect: a :e rectangle_set U0 V0.
         { rewrite HV0Y.
           rewrite HaEta.
           rewrite Ha11.
           exact (tuple_2_setprod_by_pair_Sigma U0 Y (a 0) 1 Ha0U0 H1Y). }
         claim HaInb: a :e b.
         { rewrite Hbeq.
           exact HaInRect. }
	         claim HaU: a :e U.
	         { exact (HbsubU a HaInb). }
	         witness a.
	         apply andI.
	         - apply andI.
	           + exact HaA.
	           + prove a <> x.
		             assume Heq: a = x.
		             claim Heq1: a 1 = x 1.
		             { rewrite <- Heq.
		               reflexivity. }
		             claim H01: 0 = 1.
		             { rewrite <- Ha11 at 1.
		               rewrite <- Hx1eq at 1.
		               rewrite Heq1.
		               reflexivity. }
	             exact (neq_0_1 H01).
	         - exact HaU.
- (** ~ compact_space X Tx **)
  prove ~ compact_space X Tx.
  assume Hcomp: compact_space X Tx.
  (** Define the standard open cover by vertical fibers {n}×Y. **)
	  set Fam := {rectangle_set {n} Y|n :e omega}.
	  claim Hcov: open_cover_of X Tx Fam.
	  { prove topology_on X Tx /\ Fam c= Power X /\ X c= Union Fam /\ (forall U0:set, U0 :e Fam -> U0 :e Tx).
	    (** conjunction is left-associative: ((topology_on /\ FamSub) /\ Xcov) /\ AllOpen **)
	    apply andI.
	    - apply andI.
	      + (** topology_on /\ Fam c= Power X **)
	        apply andI.
	        * exact (product_topology_is_topology omega Tx0 Y Ty (discrete_topology_on omega) (indiscrete_topology_on Y)).
	        * (** Fam c= Power X **)
	          let U0. assume HU0: U0 :e Fam.
	          prove U0 :e Power X.
	          apply (ReplE omega (fun n:set => rectangle_set {n} Y) U0 HU0).
	          let n. assume Hnconj: n :e omega /\ U0 = rectangle_set {n} Y.
	          claim Hn: n :e omega.
	          { exact (andEL (n :e omega) (U0 = rectangle_set {n} Y) Hnconj). }
	          claim HU0eq: U0 = rectangle_set {n} Y.
	          { exact (andER (n :e omega) (U0 = rectangle_set {n} Y) Hnconj). }
	          claim HsingSub: {n} c= omega.
	          { exact (singleton_subset n omega Hn). }
	          claim HrectSub: rectangle_set {n} Y c= X.
	          { exact (setprod_Subq {n} Y omega Y HsingSub (Subq_ref Y)). }
	          rewrite HU0eq.
	          exact (PowerI X (rectangle_set {n} Y) HrectSub).
	      + (** X c= Union Fam **)
	        let p. assume HpX: p :e X.
	        prove p :e Union Fam.
	        claim Hp0w: p 0 :e omega.
	        { exact (ap0_Sigma omega (fun _ : set => Y) p HpX). }
	        claim Hp1Y: p 1 :e Y.
	        { exact (ap1_Sigma omega (fun _ : set => Y) p HpX). }
	        claim HpEta: p = (p 0, p 1).
	        { exact (setprod_eta omega Y p HpX). }
	        claim HU0Fam: rectangle_set {p 0} Y :e Fam.
	        { exact (ReplI omega (fun n:set => rectangle_set {n} Y) (p 0) Hp0w). }
		        claim HpU0: p :e rectangle_set {p 0} Y.
		        { rewrite HpEta at 1.
		          claim Hsing: p 0 :e {p 0}.
		          { exact (SingI (p 0)). }
		          exact (tuple_2_rectangle_set {p 0} Y (p 0) (p 1) Hsing Hp1Y). }
	        exact (UnionI Fam p (rectangle_set {p 0} Y) HpU0 HU0Fam).
	    - (** every U0 ∈ Fam is open in Tx **)
	      let U0. assume HU0: U0 :e Fam.
	      prove U0 :e Tx.
	      apply (ReplE omega (fun n:set => rectangle_set {n} Y) U0 HU0).
	      let n. assume Hnconj: n :e omega /\ U0 = rectangle_set {n} Y.
	      claim Hn: n :e omega.
	      { exact (andEL (n :e omega) (U0 = rectangle_set {n} Y) Hnconj). }
	      claim HU0eq: U0 = rectangle_set {n} Y.
	      { exact (andER (n :e omega) (U0 = rectangle_set {n} Y) Hnconj). }
	      claim HTx0: topology_on omega Tx0.
	      { exact (discrete_topology_on omega). }
	      claim HTy: topology_on Y Ty.
	      { exact (indiscrete_topology_on Y). }
	      claim HBasis: basis_on X (product_subbasis omega Tx0 Y Ty).
	      { exact (product_subbasis_is_basis omega Tx0 Y Ty HTx0 HTy). }
	      claim HsingOpen: {n} :e Tx0.
	      { apply PowerI.
	        exact (singleton_subset n omega Hn). }
	      claim HYopen: Y :e Ty.
	      { exact (topology_has_X Y Ty HTy). }
	      claim HU0sub: rectangle_set {n} Y :e product_subbasis omega Tx0 Y Ty.
	      { claim HrectFam: rectangle_set {n} Y :e {rectangle_set {n} V0|V0 :e Ty}.
	        { exact (ReplI Ty (fun V0:set => rectangle_set {n} V0) Y HYopen). }
	        exact (famunionI Tx0 (fun U1:set => {rectangle_set U1 V0|V0 :e Ty}) {n} (rectangle_set {n} Y) HsingOpen HrectFam). }
	      rewrite HU0eq.
	      exact (generated_topology_contains_basis X (product_subbasis omega Tx0 Y Ty) HBasis (rectangle_set {n} Y) HU0sub). }
  claim Hfin: has_finite_subcover X Tx Fam.
  { exact (compact_space_subcover_property X Tx Hcomp Fam Hcov). }
	  (** Any finite subcover induces a finite set of indices covering all of omega; contradiction. **)
	  apply Hfin.
	  let G. assume HG: G c= Fam /\ finite G /\ X c= Union G.
	  (** conjunction is left-associative: (G⊆Fam /\ finite G) /\ X⊆Union G **)
	  claim HGleft: G c= Fam /\ finite G.
	  { exact (andEL (G c= Fam /\ finite G) (X c= Union G) HG). }
	  claim HcovG: X c= Union G.
	  { exact (andER (G c= Fam /\ finite G) (X c= Union G) HG). }
	  claim HGsub: G c= Fam.
	  { exact (andEL (G c= Fam) (finite G) HGleft). }
	  claim HGfin: finite G.
	  { exact (andER (G c= Fam) (finite G) HGleft). }
  (** PickN associates to each g∈G its unique index n with g = {n}×Y. **)
  set pickN := fun g:set => Eps_i (fun n:set => n :e omega /\ g = rectangle_set {n} Y).
  set N := {pickN g|g :e G}.
  claim HNfin: finite N.
  { exact (Repl_finite (fun g:set => pickN g) G HGfin). }
  (** omega ⊆ N because G covers every (m,0). **)
  claim H0Y: 0 :e Y.
  { exact (UPairI1 0 1). }
  claim HomegaSub: omega c= N.
  { let m. assume Hm: m :e omega.
    prove m :e N.
    set p := (m,0).
    claim HpX: p :e X.
    { exact (tuple_2_setprod_by_pair_Sigma omega Y m 0 Hm H0Y). }
    claim HpUnion: p :e Union G.
    { exact (HcovG p HpX). }
    apply (UnionE_impred G p HpUnion).
    let g. assume Hpg: p :e g.
    assume HgG: g :e G.
    (** derive the defining property for pickN g from g∈Fam **)
	    claim HgFam: g :e Fam.
	    { exact (HGsub g HgG). }
		    claim Hexn: exists n:set, n :e omega /\ g = rectangle_set {n} Y.
		    { exact (ReplE omega (fun n0:set => rectangle_set {n0} Y) g HgFam). }
    claim HpickProp: pickN g :e omega /\ g = rectangle_set {pickN g} Y.
    { exact (Eps_i_ex (fun n:set => n :e omega /\ g = rectangle_set {n} Y) Hexn). }
    claim HgeqPick: g = rectangle_set {pickN g} Y.
    { exact (andER (pickN g :e omega) (g = rectangle_set {pickN g} Y) HpickProp). }
    claim HpInPickRect: p :e rectangle_set {pickN g} Y.
    { rewrite <- HgeqPick.
      exact Hpg. }
    claim Hp0InSing: p 0 :e {pickN g}.
    { exact (ap0_Sigma {pickN g} (fun _ : set => Y) p HpInPickRect). }
    claim Hpeq0: p 0 = m.
    { exact (tuple_2_0_eq m 0). }
    claim HmInSing: m :e {pickN g}.
    { rewrite <- Hpeq0.
      exact Hp0InSing. }
    claim HmEq: m = pickN g.
    { exact (SingE (pickN g) m HmInSing). }
    rewrite HmEq.
    exact (ReplI G (fun g0:set => pickN g0) g HgG). }
  (** Conclude finite omega, contradicting infinity. **)
  claim HfinOmega: finite omega.
  { exact (Subq_finite N HNfin omega HomegaSub). }
  claim HinfOmega: infinite omega.
  { claim Hatleast: atleastp omega omega.
    { exact (Subq_atleastp omega omega (Subq_ref omega)). }
    exact (atleastp_omega_infinite omega Hatleast). }
  apply FalseE.
  prove False.
  exact (HinfOmega HfinOmega).
Qed.

(** from §29 Definition: local compactness **) 
(** LATEX VERSION: Locally compact means each point has a neighborhood whose closure is compact. **)
Definition locally_compact : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x:set, x :e X ->
    exists U:set, U :e Tx /\ x :e U /\
      compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)).

(** Helper: extract topology_on from locally_compact **)
Theorem locally_compact_topology : forall X Tx:set,
  locally_compact X Tx -> topology_on X Tx.
let X Tx.
assume H: locally_compact X Tx.
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X ->
               exists U:set, U :e Tx /\ x :e U /\
                 compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)))
             H).
Qed.

(** Helper: extract local compactness neighborhood property **)
Theorem locally_compact_local : forall X Tx x:set,
  locally_compact X Tx ->
  x :e X ->
  exists U:set, U :e Tx /\ x :e U /\
    compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)).
let X Tx x.
assume H: locally_compact X Tx.
assume Hx: x :e X.
claim Hprop: forall x0:set, x0 :e X ->
  exists U:set, U :e Tx /\ x0 :e U /\
    compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)).
{ exact (andER (topology_on X Tx)
               (forall x0:set, x0 :e X ->
                 exists U:set, U :e Tx /\ x0 :e U /\
                   compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)))
               H). }
exact (Hprop x Hx).
Qed.

(** LATEX VERSION: In Hausdorff spaces, compact subsets are closed. **)
Theorem Hausdorff_compact_sets_closed : forall X Tx A:set,
  Hausdorff_space X Tx ->
  A c= X ->
  compact_space A (subspace_topology X Tx A) ->
  closed_in X Tx A.
let X Tx A.
assume HH: Hausdorff_space X Tx.
assume HA: A c= X.
assume Hcomp: compact_space A (subspace_topology X Tx A).
prove closed_in X Tx A.
exact (compact_subspace_in_Hausdorff_closed X Tx A HH HA Hcomp).
Qed.

(** Helper: Empty subspace is compact **)
Theorem compact_empty_subspace : forall X Tx:set,
  topology_on X Tx ->
  compact_space Empty (subspace_topology X Tx Empty).
let X Tx.
assume HTx: topology_on X Tx.
prove compact_space Empty (subspace_topology X Tx Empty).
prove topology_on Empty (subspace_topology X Tx Empty) /\
  forall Fam:set, open_cover_of Empty (subspace_topology X Tx Empty) Fam ->
    has_finite_subcover Empty (subspace_topology X Tx Empty) Fam.
apply andI.
- (** topology_on Empty (subspace_topology X Tx Empty) **)
  exact (subspace_topology_is_topology X Tx Empty HTx (Subq_Empty X)).
  - (** finite subcover property is trivial on Empty **)
  let Fam. assume HFam: open_cover_of Empty (subspace_topology X Tx Empty) Fam.
  apply (has_finite_subcoverI Empty (subspace_topology X Tx Empty) Fam Empty).
  apply andI.
  + (** Empty c= Fam /\ finite Empty **)
    apply andI.
    * exact (Subq_Empty Fam).
    * exact finite_Empty.
  + (** Empty c= Union Empty **)
    exact (Subq_Empty (Union Empty)).
Qed.

(** from §29: one-point compactification placeholder **) 
(** LATEX VERSION: One-point compactification of a locally compact Hausdorff space. **)
Definition one_point_compactification : set -> set -> set -> set -> prop := fun X Tx Y Ty =>
  compact_space Y Ty /\ Hausdorff_space Y Ty /\ X c= Y /\
  exists p:set, p :e Y /\ ~ p :e X /\
    subspace_topology Y Ty X = Tx /\
    (forall y:set, y :e Y -> y :e X \/ y = p).

Theorem one_point_compactification_exists : forall X Tx:set,
  locally_compact X Tx -> Hausdorff_space X Tx ->
  exists Y Ty:set, one_point_compactification X Tx Y Ty.
let X Tx.
assume Hlc: locally_compact X Tx.
assume HH: Hausdorff_space X Tx.
prove exists Y Ty:set, one_point_compactification X Tx Y Ty.
set p := X.
set Y := X :\/: {p}.
set Ty := {U :e Power Y |
  (p /:e U /\ U :e Tx) \/
  (p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K)}.
witness Y.
witness Ty.
claim HHausY: Hausdorff_space Y Ty.
{ prove topology_on Y Ty /\
    forall x1 x2:set, x1 :e Y -> x2 :e Y -> x1 <> x2 ->
      exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  apply andI.
	  - (** topology_on Y Ty **)
	    prove topology_on Y Ty.
	    claim HTx: topology_on X Tx.
	    { exact (locally_compact_topology X Tx Hlc). }
	    prove Ty c= Power Y
	      /\ Empty :e Ty
	      /\ Y :e Ty
	      /\ (forall UFam :e Power Ty, Union UFam :e Ty)
	      /\ (forall U :e Ty, forall V :e Ty, U :/\: V :e Ty).
	    (** Build the left-associative conjunction in topology_on Y Ty. **)
	    apply andI.
    + (** (((Ty c= Power Y /\ Empty :e Ty) /\ Y :e Ty) /\ Union axiom) **)
      apply andI.
	      * (** (Ty c= Power Y /\ Empty :e Ty) /\ Y :e Ty **)
	        apply andI.
	        - (** Ty c= Power Y /\ Empty :e Ty **)
	           apply andI.
           { (** Ty c= Power Y **)
             prove Ty c= Power Y.
             let U. assume HUty: U :e Ty.
             exact (SepE1 (Power Y)
                          (fun U0:set =>
                            (p /:e U0 /\ U0 :e Tx) \/
                            (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                          U
                          HUty).
           }
           { (** Empty :e Ty **)
             prove Empty :e Ty.
             claim HEmptyPowY: Empty :e Power Y.
             { exact (Empty_In_Power Y). }
             claim HEmptyTx: Empty :e Tx.
             { exact (topology_has_empty X Tx HTx). }
             claim HpnotEmpty: p /:e Empty.
             { exact (EmptyE p). }
             claim HPred:
               (p /:e Empty /\ Empty :e Tx) \/
               (p :e Empty /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ Empty = Y :\: K).
             { exact (orIL (p /:e Empty /\ Empty :e Tx)
                           (p :e Empty /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ Empty = Y :\: K)
                           (andI (p /:e Empty) (Empty :e Tx) HpnotEmpty HEmptyTx)). }
             exact (SepI (Power Y)
                         (fun U0:set =>
                           (p /:e U0 /\ U0 :e Tx) \/
                           (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                         Empty
                         HEmptyPowY
                         HPred).
           }
	        - (** Y :e Ty **)
	           prove Y :e Ty.
           claim HYpowY: Y :e Power Y.
           { exact (Self_In_Power Y). }
           claim HpY: p :e Y.
           { exact (binunionI2 X {p} p (SingI p)). }
           claim HEmptyComp: compact_space Empty (subspace_topology X Tx Empty).
           { exact (compact_empty_subspace X Tx HTx). }
           claim HPredY:
             (p /:e Y /\ Y :e Tx) \/
             (p :e Y /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ Y = Y :\: K).
           { apply orIR.
             apply andI.
             - exact HpY.
	             - witness Empty.
	               apply andI.
	               * (** compact_space Empty (subspace_topology X Tx Empty) /\ Empty c= X **)
	                 apply andI.
	                 + exact HEmptyComp.
	                 + exact (Subq_Empty X).
	               * (** Y = Y :\: Empty **)
	                 rewrite (setminus_Empty_eq Y). reflexivity.
	           }
           exact (SepI (Power Y)
                       (fun U0:set =>
                         (p /:e U0 /\ U0 :e Tx) \/
                         (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                       Y
                       HYpowY
                       HPredY).
      * (** Union axiom **)
        let UFam. assume HUFamPow: UFam :e Power Ty.
        prove Union UFam :e Ty.
        claim HUFamSub: UFam c= Ty.
        { exact (PowerE Ty UFam HUFamPow). }
        claim HUnionPowY: Union UFam :e Power Y.
        { apply PowerI.
          let y. assume HyU: y :e Union UFam.
          apply (UnionE_impred UFam y HyU).
          let U. assume HyUin: y :e U. assume HUUFam: U :e UFam.
          claim HUty: U :e Ty.
          { exact (HUFamSub U HUUFam). }
          claim HUpowY: U :e Power Y.
          { exact (SepE1 (Power Y)
                         (fun U0:set =>
                           (p /:e U0 /\ U0 :e Tx) \/
                           (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                         U
                         HUty). }
          claim HUsubY: U c= Y.
          { exact (PowerE Y U HUpowY). }
          exact (HUsubY y HyUin). }
        apply (xm (p :e Union UFam)).
        - (** p in Union UFam **)
           assume HpUnion: p :e Union UFam.
           set K := Y :\: Union UFam.
           claim HUnionEq: Union UFam = Y :\: K.
           { rewrite (setminus_setminus_eq Y (Union UFam) (PowerE Y (Union UFam) HUnionPowY)).
             reflexivity. }
           claim HKsubX: K c= X.
           { let y. assume HyK: y :e K.
             claim HyY: y :e Y.
             { exact (setminusE1 Y (Union UFam) y HyK). }
             apply (binunionE X {p} y HyY (y :e X)).
             - assume HyX: y :e X. exact HyX.
             - assume Hyp: y :e {p}.
               claim Heq: y = p.
               { exact (SingE p y Hyp). }
               apply FalseE.
               apply (setminusE2 Y (Union UFam) y HyK).
               rewrite Heq.
               exact HpUnion. }
           claim HPredUnion:
             (p /:e Union UFam /\ Union UFam :e Tx) \/
             (p :e Union UFam /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ Union UFam = Y :\: K0).
           { apply orIR.
             apply andI.
             - exact HpUnion.
	             - witness K.
	               apply andI.
		               * (** compact_space K (subspace_topology X Tx K) /\ K c= X **)
		                 apply andI.
		                 + (** compact_space K (subspace_topology X Tx K) **)
		                   prove compact_space K (subspace_topology X Tx K).
		                   (** Choose U0 ∈ UFam with p ∈ U0, obtain a compact complement Kp from U0, then show K is closed in Kp. **)
		                   apply (UnionE_impred UFam p HpUnion).
		                   let U0.
		                   assume HpU0: p :e U0.
		                   assume HU0Fam: U0 :e UFam.
		                   claim HU0Ty: U0 :e Ty.
		                   { exact (HUFamSub U0 HU0Fam). }
		                   claim HU0prop:
		                     (p /:e U0 /\ U0 :e Tx) \/
		                     (p :e U0 /\ exists Kp:set, compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X /\ U0 = Y :\: Kp).
		                   { exact (SepE2 (Power Y)
		                                  (fun U0:set =>
		                                    (p /:e U0 /\ U0 :e Tx) \/
		                                    (p :e U0 /\ exists Kp:set, compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X /\ U0 = Y :\: Kp))
		                                  U0
		                                  HU0Ty). }
		                   apply HU0prop.
		                   - assume Hbad: p /:e U0 /\ U0 :e Tx.
		                     apply FalseE.
		                     exact ((andEL (p /:e U0) (U0 :e Tx) Hbad) HpU0).
		                   - assume Hgood: p :e U0 /\ exists Kp:set, compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X /\ U0 = Y :\: Kp.
		                     claim HexKp:
		                       exists Kp:set, compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X /\ U0 = Y :\: Kp.
		                     { exact (andER (p :e U0)
		                                    (exists Kp:set, compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X /\ U0 = Y :\: Kp)
		                                    Hgood). }
		                     apply HexKp.
		                     let Kp. assume HKpPkg.
		                     (** Extract compactness and subset facts about Kp, and the representation U0 = Y\\Kp. **)
		                     claim HKpLeft: compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X.
		                     { exact (andEL (compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X)
		                                    (U0 = Y :\: Kp)
		                                    HKpPkg). }
		                     claim HKpComp: compact_space Kp (subspace_topology X Tx Kp).
		                     { exact (andEL (compact_space Kp (subspace_topology X Tx Kp))
		                                    (Kp c= X)
		                                    HKpLeft). }
		                     claim HKpSubX: Kp c= X.
		                     { exact (andER (compact_space Kp (subspace_topology X Tx Kp))
		                                    (Kp c= X)
		                                    HKpLeft). }
		                     claim HU0eq: U0 = Y :\: Kp.
		                     { exact (andER (compact_space Kp (subspace_topology X Tx Kp) /\ Kp c= X)
		                                    (U0 = Y :\: Kp)
		                                    HKpPkg). }
		                     (** K ⊆ Kp because K ⊆ Y\\U0 = Y\\(Y\\Kp) = Kp (since Kp ⊆ Y). **)
		                     claim HKpSubY: Kp c= Y.
		                     { let y. assume HyKp: y :e Kp.
		                       exact (binunionI1 X {p} y (HKpSubX y HyKp)). }
		                     claim HKsubKp: K c= Kp.
		                     { let y. assume HyK: y :e K.
		                       claim HyY: y :e Y.
		                       { exact (setminusE1 Y (Union UFam) y HyK). }
		                       claim HyNotUnion: y /:e Union UFam.
		                       { exact (setminusE2 Y (Union UFam) y HyK). }
		                       claim HyNotU0: y /:e U0.
		                       { assume HyU0: y :e U0.
		                         exact (HyNotUnion (UnionI UFam y U0 HyU0 HU0Fam)). }
		                       claim HyNotYKp: y /:e (Y :\: Kp).
		                       { rewrite <- HU0eq. exact HyNotU0. }
		                       claim HyInYYKp: y :e Y :\: (Y :\: Kp).
		                       { exact (setminusI Y (Y :\: Kp) y HyY HyNotYKp). }
		                       rewrite <- (setminus_setminus_eq Y Kp HKpSubY).
		                       exact HyInYYKp. }
		                     set TopKp := subspace_topology X Tx Kp.
		                     claim HTopKp: topology_on Kp TopKp.
		                     { exact (compact_space_topology Kp TopKp HKpComp). }
		                     (** If Kp\\K is open in TopKp, then K is closed in Kp, hence compact. **)
		                     claim HUopen: Kp :\: K :e TopKp.
		                     { (** Express Kp\\K as a union of sets of the form U∩Kp, and use union-closure of the subspace topology. **)
		                       set FamKp := {W :e TopKp | exists U:set, U :e UFam /\ W = U :/\: Kp}.
		                       claim HFamKpPow: FamKp :e Power TopKp.
		                       { apply PowerI.
		                         let W. assume HW: W :e FamKp.
		                         exact (SepE1 TopKp (fun W0:set => exists U:set, U :e UFam /\ W0 = U :/\: Kp) W HW). }
		                       claim HUnionFamKpTop: Union FamKp :e TopKp.
		                       { exact (topology_union_closed_pow Kp TopKp FamKp HTopKp HFamKpPow). }
		                       claim HeqUnion: Kp :\: K = Union FamKp.
		                       { apply set_ext.
		                         - let y. assume Hy: y :e Kp :\: K.
		                           claim HyKp: y :e Kp.
		                           { exact (setminusE1 Kp K y Hy). }
		                           claim HyNotK: y /:e K.
		                           { exact (setminusE2 Kp K y Hy). }
		                           claim HyY: y :e Y.
		                           { exact (HKpSubY y HyKp). }
		                           (** From y∉K = Y\\Union UFam and y∈Y, deduce y∈Union UFam. **)
		                           claim HyUnion: y :e Union UFam.
		                           { apply (xm (y :e Union UFam)).
		                             - assume HyU. exact HyU.
		                             - assume HyNotUnion: ~(y :e Union UFam).
		                               claim HyK: y :e K.
		                               { exact (setminusI Y (Union UFam) y HyY HyNotUnion). }
		                               apply FalseE.
		                               exact (HyNotK HyK). }
		                           (** Choose U∈UFam with y∈U; then W := U∩Kp is in FamKp and contains y. **)
		                           apply (UnionE_impred UFam y HyUnion).
		                           let U. assume HyU: y :e U. assume HUUFam: U :e UFam.
		                           set W := U :/\: Kp.
		                           claim HyW: y :e W.
		                           { exact (binintersectI U Kp y HyU HyKp). }
		                           (** Show W ∈ TopKp. **)
		                           claim HWTop: W :e TopKp.
		                           { claim HWpow: W :e Power Kp.
		                             { apply PowerI.
		                               let z. assume HzW: z :e W.
		                               exact (binintersectE2 U Kp z HzW). }
		                             claim HUty: U :e Ty.
		                             { exact (HUFamSub U HUUFam). }
		                             claim HUprop:
		                               (p /:e U /\ U :e Tx) \/
		                               (p :e U /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1).
		                             { exact (SepE2 (Power Y)
		                                            (fun U0:set =>
		                                              (p /:e U0 /\ U0 :e Tx) \/
		                                              (p :e U0 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U0 = Y :\: K1))
		                                            U
		                                            HUty). }
		                             apply HUprop.
			                             - assume Hcase: p /:e U /\ U :e Tx.
			                               claim HUinTx: U :e Tx.
			                               { exact (andER (p /:e U) (U :e Tx) Hcase). }
			                               (** In the subspace topology, U∩Kp is open with witness U∈Tx. **)
			                               claim HexV: exists V :e Tx, W = V :/\: Kp.
			                               { witness U.
			                                 apply andI.
			                                 - exact HUinTx.
			                                 - reflexivity. }
			                               exact (SepI (Power Kp)
			                                           (fun W0:set => exists V :e Tx, W0 = V :/\: Kp)
			                                           W
			                                           HWpow
			                                           HexV).
		                             - assume Hcase: p :e U /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1.
		                               claim HexK1: exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1.
		                               { exact (andER (p :e U)
		                                              (exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1)
		                                              Hcase). }
		                               apply HexK1.
		                               let K1. assume HK1pkg.
		                               claim HK1left: compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X.
		                               { exact (andEL (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
		                                              (U = Y :\: K1)
		                                              HK1pkg). }
		                               claim HK1comp: compact_space K1 (subspace_topology X Tx K1).
		                               { exact (andEL (compact_space K1 (subspace_topology X Tx K1))
		                                              (K1 c= X)
		                                              HK1left). }
		                               claim HK1subX: K1 c= X.
		                               { exact (andER (compact_space K1 (subspace_topology X Tx K1))
		                                              (K1 c= X)
		                                              HK1left). }
		                               claim HUeq: U = Y :\: K1.
		                               { exact (andER (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
		                                              (U = Y :\: K1)
		                                              HK1pkg). }
		                               claim HK1closed: closed_in X Tx K1.
		                               { exact (Hausdorff_compact_sets_closed X Tx K1 HH HK1subX HK1comp). }
		                               claim Hop: open_in X Tx (X :\: K1).
		                               { exact (open_of_closed_complement X Tx K1 HK1closed). }
		                               claim HVinTx: (X :\: K1) :e Tx.
		                               { exact (open_in_elem X Tx (X :\: K1) Hop). }
		                               (** Show W = (X\\K1) ∩ Kp. **)
		                               claim HeqW: W = (X :\: K1) :/\: Kp.
		                               { rewrite HUeq.
		                                 apply set_ext.
		                                 - let x. assume Hx: x :e (Y :\: K1) :/\: Kp.
		                                   claim HxYK1: x :e Y :\: K1.
		                                   { exact (binintersectE1 (Y :\: K1) Kp x Hx). }
		                                   claim HxKp: x :e Kp.
		                                   { exact (binintersectE2 (Y :\: K1) Kp x Hx). }
		                                   claim HxnotK1: x /:e K1.
		                                   { exact (setminusE2 Y K1 x HxYK1). }
		                                   claim HxX: x :e X.
		                                   { exact (HKpSubX x HxKp). }
		                                   claim HxXK1: x :e X :\: K1.
		                                   { exact (setminusI X K1 x HxX HxnotK1). }
		                                   apply binintersectI.
		                                   * exact HxXK1.
		                                   * exact HxKp.
		                                 - let x. assume Hx: x :e (X :\: K1) :/\: Kp.
		                                   claim HxXK1: x :e X :\: K1.
		                                   { exact (binintersectE1 (X :\: K1) Kp x Hx). }
		                                   claim HxKp: x :e Kp.
		                                   { exact (binintersectE2 (X :\: K1) Kp x Hx). }
		                                   claim HxnotK1: x /:e K1.
		                                   { exact (setminusE2 X K1 x HxXK1). }
		                                   claim HxY: x :e Y.
		                                   { exact (HKpSubY x HxKp). }
		                                   claim HxYK1: x :e Y :\: K1.
		                                   { exact (setminusI Y K1 x HxY HxnotK1). }
		                                   apply binintersectI.
		                                   * exact HxYK1.
		                                   * exact HxKp. }
		                               (** Conclude W ∈ subspace_topology X Tx Kp. **)
		                               claim HexV: exists V :e Tx, W = V :/\: Kp.
		                               { witness (X :\: K1).
		                                 apply andI.
		                                 - exact HVinTx.
		                                 - exact HeqW. }
		                               exact (SepI (Power Kp)
		                                           (fun W0:set => exists V :e Tx, W0 = V :/\: Kp)
		                                           W
		                                           HWpow
		                                           HexV). }
		                           (** Now W ∈ FamKp. **)
		                           claim HWFam: W :e FamKp.
		                           { claim HexU: exists U0:set, U0 :e UFam /\ W = U0 :/\: Kp.
		                             { witness U.
		                               apply andI.
		                               - exact HUUFam.
		                               - reflexivity. }
		                             exact (SepI TopKp (fun W0:set => exists U0:set, U0 :e UFam /\ W0 = U0 :/\: Kp) W HWTop HexU). }
		                           exact (UnionI FamKp y W HyW HWFam).
		                         - let y. assume Hy: y :e Union FamKp.
		                           apply (UnionE_impred FamKp y Hy).
		                           let W. assume HyW: y :e W. assume HWFam: W :e FamKp.
		                           claim HexU: exists U:set, U :e UFam /\ W = U :/\: Kp.
		                           { exact (SepE2 TopKp (fun W0:set => exists U:set, U :e UFam /\ W0 = U :/\: Kp) W HWFam). }
		                           apply HexU.
		                           let U. assume HUand.
		                           claim HUUFam: U :e UFam.
		                           { exact (andEL (U :e UFam) (W = U :/\: Kp) HUand). }
		                           claim HWeq: W = U :/\: Kp.
		                           { exact (andER (U :e UFam) (W = U :/\: Kp) HUand). }
		                           claim HyUKp: y :e U :/\: Kp.
		                           { rewrite <- HWeq. exact HyW. }
		                           claim HyKp: y :e Kp.
		                           { exact (binintersectE2 U Kp y HyUKp). }
		                           claim HyU: y :e U.
		                           { exact (binintersectE1 U Kp y HyUKp). }
		                           claim HyUnionUFam: y :e Union UFam.
		                           { exact (UnionI UFam y U HyU HUUFam). }
		                           claim HyNotK: y /:e K.
		                           { assume HyK: y :e K.
		                             claim HyNotUnion: y /:e Union UFam.
		                             { exact (setminusE2 Y (Union UFam) y HyK). }
		                             exact (HyNotUnion HyUnionUFam). }
		                           exact (setminusI Kp K y HyKp HyNotK). }
		                       rewrite HeqUnion.
		                       exact HUnionFamKpTop. }
		                     claim HKclosedTmp: closed_in Kp TopKp (Kp :\: (Kp :\: K)).
		                     { exact (closed_of_open_complement Kp TopKp (Kp :\: K) HTopKp HUopen). }
		                     claim HKclosed: closed_in Kp TopKp K.
		                     { rewrite <- (setminus_setminus_eq Kp K HKsubKp).
		                       exact HKclosedTmp. }
		                     claim HKcompSub: compact_space K (subspace_topology Kp TopKp K).
		                     { exact (closed_subspace_compact Kp TopKp K HKpComp HKclosed). }
		                     claim HeqTop: subspace_topology Kp TopKp K = subspace_topology X Tx K.
		                     { exact (ex16_1_subspace_transitive X Tx Kp K HTx HKpSubX HKsubKp). }
		                     rewrite <- HeqTop.
		                     exact HKcompSub.
		                 + exact HKsubX.
		               * (** Union UFam = Y :\: K **)
		                 exact HUnionEq. }
	           exact (SepI (Power Y)
                       (fun U0:set =>
                         (p /:e U0 /\ U0 :e Tx) \/
                         (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
                       (Union UFam)
                       HUnionPowY
                       HPredUnion).
        - (** p not in Union UFam **)
           assume HpNotUnion: ~(p :e Union UFam).
           claim HpNotUnion2: p /:e Union UFam.
           { exact HpNotUnion. }
           claim HUFamTx: UFam c= Tx.
           { let U. assume HUUFam: U :e UFam.
             claim HUty: U :e Ty.
             { exact (HUFamSub U HUUFam). }
             claim HUprop:
               (p /:e U /\ U :e Tx) \/
               (p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K).
             { exact (SepE2 (Power Y)
                            (fun U0:set =>
                              (p /:e U0 /\ U0 :e Tx) \/
                              (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                            U
                            HUty). }
             apply HUprop.
             - assume Hcase: p /:e U /\ U :e Tx.
               exact (andER (p /:e U) (U :e Tx) Hcase).
             - assume Hcase: p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K.
               apply FalseE.
               claim HpU: p :e U.
               { exact (andEL (p :e U) (exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K) Hcase). }
               apply HpNotUnion.
               exact (UnionI UFam p U HpU HUUFam). }
           claim HUnionTx: Union UFam :e Tx.
           { exact (topology_union_closed X Tx UFam HTx HUFamTx). }
           claim HPredUnion:
             (p /:e Union UFam /\ Union UFam :e Tx) \/
             (p :e Union UFam /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ Union UFam = Y :\: K0).
           { exact (orIL (p /:e Union UFam /\ Union UFam :e Tx)
                         (p :e Union UFam /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ Union UFam = Y :\: K0)
                         (andI (p /:e Union UFam) (Union UFam :e Tx) HpNotUnion2 HUnionTx)). }
           exact (SepI (Power Y)
                       (fun U0:set =>
                         (p /:e U0 /\ U0 :e Tx) \/
                         (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
                       (Union UFam)
                       HUnionPowY
                       HPredUnion).
    + (** Intersection axiom **)
      let U. assume HUty: U :e Ty.
      let V. assume HVty: V :e Ty.
      prove U :/\: V :e Ty.
      claim HUpowY: U :e Power Y.
      { exact (SepE1 (Power Y)
                     (fun U0:set =>
                       (p /:e U0 /\ U0 :e Tx) \/
                       (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                     U
                     HUty). }
      claim HVpowY: V :e Power Y.
      { exact (SepE1 (Power Y)
                     (fun U0:set =>
                       (p /:e U0 /\ U0 :e Tx) \/
                       (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                     V
                     HVty). }
      claim HUVpowY: U :/\: V :e Power Y.
      { apply PowerI.
        let y. assume HyUV: y :e U :/\: V.
        claim HyU: y :e U.
        { exact (binintersectE1 U V y HyUV). }
        claim HUsubY: U c= Y.
        { exact (PowerE Y U HUpowY). }
        exact (HUsubY y HyU). }
      claim HUprop:
        (p /:e U /\ U :e Tx) \/
        (p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K).
      { exact (SepE2 (Power Y)
                     (fun U0:set =>
                       (p /:e U0 /\ U0 :e Tx) \/
                       (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                     U
                     HUty). }
      claim HVprop:
        (p /:e V /\ V :e Tx) \/
        (p :e V /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K).
      { exact (SepE2 (Power Y)
                     (fun U0:set =>
                       (p /:e U0 /\ U0 :e Tx) \/
                       (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                     V
                     HVty). }
      apply HUprop.
      * assume HcaseU: p /:e U /\ U :e Tx.
        claim HUpnot: p /:e U.
        { exact (andEL (p /:e U) (U :e Tx) HcaseU). }
        claim HUinTx: U :e Tx.
        { exact (andER (p /:e U) (U :e Tx) HcaseU). }
        apply HVprop.
        - assume HcaseV: p /:e V /\ V :e Tx.
           claim HVinTx: V :e Tx.
           { exact (andER (p /:e V) (V :e Tx) HcaseV). }
           claim HUVinTx: U :/\: V :e Tx.
           { exact (topology_binintersect_closed X Tx U V HTx HUinTx HVinTx). }
           claim HpnotUV: p /:e U :/\: V.
           { assume HpUV: p :e U :/\: V.
             claim HpU: p :e U.
             { exact (binintersectE1 U V p HpUV). }
             exact (HUpnot HpU). }
           claim HPredUV:
             (p /:e U :/\: V /\ U :/\: V :e Tx) \/
             (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0).
           { exact (orIL (p /:e U :/\: V /\ U :/\: V :e Tx)
                         (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0)
                         (andI (p /:e U :/\: V) (U :/\: V :e Tx) HpnotUV HUVinTx)). }
           exact (SepI (Power Y)
                       (fun U0:set =>
                         (p /:e U0 /\ U0 :e Tx) \/
                         (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
                       (U :/\: V)
                       HUVpowY
                       HPredUV).
        - assume HcaseV: p :e V /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K.
           claim HexK: exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K.
           { exact (andER (p :e V)
                          (exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K)
                          HcaseV). }
	           apply HexK.
	           let K. assume HKpkg.
	           claim HKleft: compact_space K (subspace_topology X Tx K) /\ K c= X.
	           { exact (andEL (compact_space K (subspace_topology X Tx K) /\ K c= X)
	                          (V = Y :\: K)
	                          HKpkg). }
	           claim HKcomp: compact_space K (subspace_topology X Tx K).
	           { exact (andEL (compact_space K (subspace_topology X Tx K))
	                          (K c= X)
	                          HKleft). }
	           claim HKsubX: K c= X.
	           { exact (andER (compact_space K (subspace_topology X Tx K))
	                          (K c= X)
	                          HKleft). }
	           claim HVeq: V = Y :\: K.
	           { exact (andER (compact_space K (subspace_topology X Tx K) /\ K c= X)
	                          (V = Y :\: K)
	                          HKpkg). }
           claim HclK: closed_in X Tx K.
           { exact (Hausdorff_compact_sets_closed X Tx K HH HKsubX HKcomp). }
           claim HopK: open_in X Tx (X :\: K).
           { exact (open_of_closed_complement X Tx K HclK). }
           claim HUVinTx: U :/\: (X :\: K) :e Tx.
           { exact (topology_binintersect_closed X Tx U (X :\: K) HTx HUinTx (open_in_elem X Tx (X :\: K) HopK)). }
           claim HUVeq: U :/\: V = U :/\: (X :\: K).
           { rewrite HVeq.
             apply set_ext.
             - let x. assume Hx: x :e U :/\: (Y :\: K).
               claim HxU: x :e U.
               { exact (binintersectE1 U (Y :\: K) x Hx). }
               claim HxYK: x :e Y :\: K.
               { exact (binintersectE2 U (Y :\: K) x Hx). }
               claim HxnotK: x /:e K.
               { exact (setminusE2 Y K x HxYK). }
               claim HxX: x :e X.
               { exact ((topology_elem_subset X Tx U HTx HUinTx) x HxU). }
               claim HxXK: x :e X :\: K.
               { exact (setminusI X K x HxX HxnotK). }
               exact (binintersectI U (X :\: K) x HxU HxXK).
             - let x. assume Hx: x :e U :/\: (X :\: K).
               claim HxU: x :e U.
               { exact (binintersectE1 U (X :\: K) x Hx). }
               claim HxXK: x :e X :\: K.
               { exact (binintersectE2 U (X :\: K) x Hx). }
               claim HxnotK: x /:e K.
               { exact (setminusE2 X K x HxXK). }
               claim HxY: x :e Y.
               { exact (binunionI1 X {p} x ((topology_elem_subset X Tx U HTx HUinTx) x HxU)). }
               claim HxYK: x :e Y :\: K.
               { exact (setminusI Y K x HxY HxnotK). }
               exact (binintersectI U (Y :\: K) x HxU HxYK). }
           claim HpnotUV: p /:e U :/\: V.
           { assume HpUV: p :e U :/\: V.
             claim HpU: p :e U.
             { exact (binintersectE1 U V p HpUV). }
             exact (HUpnot HpU). }
	           claim HPredUV:
	             (p /:e U :/\: V /\ U :/\: V :e Tx) \/
	             (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0).
		           { claim HUVinTx2: U :/\: V :e Tx.
		             { rewrite HUVeq. exact HUVinTx. }
		             exact (orIL (p /:e U :/\: V /\ U :/\: V :e Tx)
		                         (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0)
		                         (andI (p /:e U :/\: V) (U :/\: V :e Tx) HpnotUV HUVinTx2)). }
		           exact (SepI (Power Y)
		                       (fun U0:set =>
		                         (p /:e U0 /\ U0 :e Tx) \/
		                         (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
		                       (U :/\: V)
		                       HUVpowY
		                       HPredUV).
	      * assume HcaseU: p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K.
	        (** U contains p, so U = Y\\K1 for some compact K1⊆X; split on whether V contains p. **)
	        claim HexK1: exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1.
	        { exact (andER (p :e U)
	                       (exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1)
	                       HcaseU). }
	        apply HexK1.
	        let K1. assume HK1pkg.
	        claim HK1left: compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X.
	        { exact (andEL (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
	                       (U = Y :\: K1)
	                       HK1pkg). }
	        claim HK1comp: compact_space K1 (subspace_topology X Tx K1).
	        { exact (andEL (compact_space K1 (subspace_topology X Tx K1))
	                       (K1 c= X)
	                       HK1left). }
	        claim HK1subX: K1 c= X.
	        { exact (andER (compact_space K1 (subspace_topology X Tx K1))
	                       (K1 c= X)
	                       HK1left). }
	        claim HUeq: U = Y :\: K1.
	        { exact (andER (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
	                       (U = Y :\: K1)
	                       HK1pkg). }
	        claim HclK1: closed_in X Tx K1.
	        { exact (Hausdorff_compact_sets_closed X Tx K1 HH HK1subX HK1comp). }
	        claim HopK1: open_in X Tx (X :\: K1).
	        { exact (open_of_closed_complement X Tx K1 HclK1). }
	        claim HXK1inTx: (X :\: K1) :e Tx.
	        { exact (open_in_elem X Tx (X :\: K1) HopK1). }

	        apply HVprop.
	        - assume HcaseV: p /:e V /\ V :e Tx.
	          (** then p /∈ U∩V and U∩V is Tx-open (V ∩ (X\\K1)) **)
	          claim HVinTx: V :e Tx.
	          { exact (andER (p /:e V) (V :e Tx) HcaseV). }
	          claim HVsubX: V c= X.
	          { exact (topology_elem_subset X Tx V HTx HVinTx). }
	          claim HUVinTx: V :/\: (X :\: K1) :e Tx.
	          { exact (topology_binintersect_closed X Tx V (X :\: K1) HTx HVinTx HXK1inTx). }
	          claim HpnotUV: p /:e U :/\: V.
	          { assume HpUV: p :e U :/\: V.
	            claim HpV: p :e V.
	            { exact (binintersectE2 U V p HpUV). }
	            exact ((andEL (p /:e V) (V :e Tx) HcaseV) HpV). }
	          claim HeqUV: U :/\: V = V :/\: (X :\: K1).
	          { rewrite HUeq.
	            apply set_ext.
	            - let x. assume Hx: x :e (Y :\: K1) :/\: V.
	              claim HxYK1: x :e Y :\: K1.
	              { exact (binintersectE1 (Y :\: K1) V x Hx). }
	              claim HxV: x :e V.
	              { exact (binintersectE2 (Y :\: K1) V x Hx). }
	              claim HxnotK1: x /:e K1.
	              { exact (setminusE2 Y K1 x HxYK1). }
	              claim HxX: x :e X.
	              { exact (HVsubX x HxV). }
	              claim HxXK1: x :e X :\: K1.
	              { exact (setminusI X K1 x HxX HxnotK1). }
	              exact (binintersectI V (X :\: K1) x HxV HxXK1).
	            - let x. assume Hx: x :e V :/\: (X :\: K1).
	              claim HxV: x :e V.
	              { exact (binintersectE1 V (X :\: K1) x Hx). }
	              claim HxXK1: x :e X :\: K1.
	              { exact (binintersectE2 V (X :\: K1) x Hx). }
	              claim HxnotK1: x /:e K1.
	              { exact (setminusE2 X K1 x HxXK1). }
	              claim HxY: x :e Y.
	              { exact (binunionI1 X {p} x (HVsubX x HxV)). }
	              claim HxYK1: x :e Y :\: K1.
	              { exact (setminusI Y K1 x HxY HxnotK1). }
	              exact (binintersectI (Y :\: K1) V x HxYK1 HxV). }
	          claim HPredUV:
	            (p /:e U :/\: V /\ U :/\: V :e Tx) \/
	            (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0).
	          { claim HUVinTx2: U :/\: V :e Tx.
	            { rewrite HeqUV. exact HUVinTx. }
	            exact (orIL (p /:e U :/\: V /\ U :/\: V :e Tx)
	                      (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0)
	                      (andI (p /:e U :/\: V) (U :/\: V :e Tx) HpnotUV HUVinTx2)). }
	          exact (SepI (Power Y)
	                      (fun U0:set =>
	                        (p /:e U0 /\ U0 :e Tx) \/
	                        (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
	                      (U :/\: V)
	                      HUVpowY
	                      HPredUV).
	        - assume HcaseV: p :e V /\ exists K2:set, compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X /\ V = Y :\: K2.
	          (** both U and V contain p: U∩V = Y\\(K1 ∪ K2) with compact K1∪K2 **)
	          claim HexK2: exists K2:set, compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X /\ V = Y :\: K2.
	          { exact (andER (p :e V)
	                         (exists K2:set, compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X /\ V = Y :\: K2)
	                         HcaseV). }
	          apply HexK2.
	          let K2. assume HK2pkg.
	          claim HK2left: compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X.
	          { exact (andEL (compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X)
	                         (V = Y :\: K2)
	                         HK2pkg). }
	          claim HK2comp: compact_space K2 (subspace_topology X Tx K2).
	          { exact (andEL (compact_space K2 (subspace_topology X Tx K2))
	                         (K2 c= X)
	                         HK2left). }
	          claim HK2subX: K2 c= X.
	          { exact (andER (compact_space K2 (subspace_topology X Tx K2))
	                         (K2 c= X)
	                         HK2left). }
	          claim HVeq: V = Y :\: K2.
	          { exact (andER (compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X)
	                         (V = Y :\: K2)
	                         HK2pkg). }
	          set K12 := K1 :\/: K2.
	          claim HK12subX: K12 c= X.
	          { let x. assume Hx: x :e K12.
	            apply (binunionE K1 K2 x Hx (x :e X)).
	            - assume HxK1: x :e K1. exact (HK1subX x HxK1).
	            - assume HxK2: x :e K2. exact (HK2subX x HxK2). }
	          claim HK12comp: compact_space K12 (subspace_topology X Tx K12).
	          { (** finite-subcover argument via ambient covers for K1 and K2 **)
	            claim HK1equiv:
	              (compact_space K1 (subspace_topology X Tx K1) <->
	                forall Fam:set, (Fam c= Tx /\ K1 c= Union Fam) -> has_finite_subcover K1 Tx Fam).
	            { exact (compact_subspace_via_ambient_covers X Tx K1 HTx HK1subX). }
	            claim HK2equiv:
	              (compact_space K2 (subspace_topology X Tx K2) <->
	                forall Fam:set, (Fam c= Tx /\ K2 c= Union Fam) -> has_finite_subcover K2 Tx Fam).
	            { exact (compact_subspace_via_ambient_covers X Tx K2 HTx HK2subX). }
	            claim HK1amb: forall Fam:set, (Fam c= Tx /\ K1 c= Union Fam) -> has_finite_subcover K1 Tx Fam.
	            { exact (iffEL (compact_space K1 (subspace_topology X Tx K1))
	                           (forall Fam:set, (Fam c= Tx /\ K1 c= Union Fam) -> has_finite_subcover K1 Tx Fam)
	                           HK1equiv
	                           HK1comp). }
	            claim HK2amb: forall Fam:set, (Fam c= Tx /\ K2 c= Union Fam) -> has_finite_subcover K2 Tx Fam.
	            { exact (iffEL (compact_space K2 (subspace_topology X Tx K2))
	                           (forall Fam:set, (Fam c= Tx /\ K2 c= Union Fam) -> has_finite_subcover K2 Tx Fam)
	                           HK2equiv
	                           HK2comp). }
	            (** Apply the <- direction of compact_subspace_via_ambient_covers for K12. **)
	            claim HK12equiv:
	              (compact_space K12 (subspace_topology X Tx K12) <->
	                forall Fam:set, (Fam c= Tx /\ K12 c= Union Fam) -> has_finite_subcover K12 Tx Fam).
	            { exact (compact_subspace_via_ambient_covers X Tx K12 HTx HK12subX). }
	            apply (iffER (compact_space K12 (subspace_topology X Tx K12))
	                         (forall Fam:set, (Fam c= Tx /\ K12 c= Union Fam) -> has_finite_subcover K12 Tx Fam)
	                         HK12equiv).
	            let Fam. assume Hcov: Fam c= Tx /\ K12 c= Union Fam.
	            claim HFsub: Fam c= Tx.
	            { exact (andEL (Fam c= Tx) (K12 c= Union Fam) Hcov). }
	            claim HK12cov: K12 c= Union Fam.
	            { exact (andER (Fam c= Tx) (K12 c= Union Fam) Hcov). }
	            claim HK1cov: K1 c= Union Fam.
	            { let x. assume HxK1: x :e K1.
	              exact (HK12cov x (binunionI1 K1 K2 x HxK1)). }
	            claim HK2cov: K2 c= Union Fam.
	            { let x. assume HxK2: x :e K2.
	              exact (HK12cov x (binunionI2 K1 K2 x HxK2)). }
	            claim Hfin1: has_finite_subcover K1 Tx Fam.
	            { exact (HK1amb Fam (andI (Fam c= Tx) (K1 c= Union Fam) HFsub HK1cov)). }
	            claim Hfin2: has_finite_subcover K2 Tx Fam.
	            { exact (HK2amb Fam (andI (Fam c= Tx) (K2 c= Union Fam) HFsub HK2cov)). }
	            apply Hfin1.
	            let G1. assume HG1.
	            apply Hfin2.
	            let G2. assume HG2.
	            (** Combine the two finite subcovers. **)
	            set G := G1 :\/: G2.
		            apply (has_finite_subcoverI K12 Tx Fam G).
		            apply andI.
		            - (** G c= Fam /\ finite G **)
		              apply andI.
		              + let U0. assume HU0: U0 :e G.
		                apply (binunionE G1 G2 U0 HU0 (U0 :e Fam)).
		                * assume HU0G1: U0 :e G1.
		                  claim HG1left: G1 c= Fam /\ finite G1.
		                  { exact (andEL (G1 c= Fam /\ finite G1) (K1 c= Union G1) HG1). }
		                  claim HG1sub: G1 c= Fam.
		                  { exact (andEL (G1 c= Fam) (finite G1) HG1left). }
		                  exact (HG1sub U0 HU0G1).
		                * assume HU0G2: U0 :e G2.
		                  claim HG2left: G2 c= Fam /\ finite G2.
		                  { exact (andEL (G2 c= Fam /\ finite G2) (K2 c= Union G2) HG2). }
		                  claim HG2sub: G2 c= Fam.
		                  { exact (andEL (G2 c= Fam) (finite G2) HG2left). }
		                  exact (HG2sub U0 HU0G2).
		              + claim HG1left: G1 c= Fam /\ finite G1.
		                { exact (andEL (G1 c= Fam /\ finite G1) (K1 c= Union G1) HG1). }
		                claim HG2left: G2 c= Fam /\ finite G2.
		                { exact (andEL (G2 c= Fam /\ finite G2) (K2 c= Union G2) HG2). }
		                exact (binunion_finite G1 (andER (G1 c= Fam) (finite G1) HG1left)
		                                       G2 (andER (G2 c= Fam) (finite G2) HG2left)).
		            - (** K12 c= Union G **)
		              let x. assume HxK12: x :e K12.
		              apply (binunionE K1 K2 x HxK12 (x :e Union G)).
		              + assume HxK1: x :e K1.
		                claim HG1cov: K1 c= Union G1.
		                { exact (andER (G1 c= Fam /\ finite G1) (K1 c= Union G1) HG1). }
		                claim Hcov1: x :e Union G1.
		                { exact (HG1cov x HxK1). }
		                apply (UnionE_impred G1 x Hcov1).
		                let U0. assume HxU0: x :e U0. assume HU0G1: U0 :e G1.
		                exact (UnionI G x U0 HxU0 (binunionI1 G1 G2 U0 HU0G1)).
		              + assume HxK2: x :e K2.
		                claim HG2cov: K2 c= Union G2.
		                { exact (andER (G2 c= Fam /\ finite G2) (K2 c= Union G2) HG2). }
		                claim Hcov2: x :e Union G2.
		                { exact (HG2cov x HxK2). }
			                apply (UnionE_impred G2 x Hcov2).
			                let U0. assume HxU0: x :e U0. assume HU0G2: U0 :e G2.
			                exact (UnionI G x U0 HxU0 (binunionI2 G1 G2 U0 HU0G2)).
		          }
	          claim HpUV: p :e U :/\: V.
	          { exact (binintersectI U V p (andEL (p :e U) (exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1) HcaseU)
	                                          (andEL (p :e V) (exists K2:set, compact_space K2 (subspace_topology X Tx K2) /\ K2 c= X /\ V = Y :\: K2) HcaseV)). }
	          claim HeqUV: U :/\: V = Y :\: K12.
	          { rewrite HUeq.
	            rewrite HVeq.
	            apply set_ext.
	            - let x. assume Hx: x :e (Y :\: K1) :/\: (Y :\: K2).
	              claim HxYK1: x :e Y :\: K1.
	              { exact (binintersectE1 (Y :\: K1) (Y :\: K2) x Hx). }
	              claim HxYK2: x :e Y :\: K2.
	              { exact (binintersectE2 (Y :\: K1) (Y :\: K2) x Hx). }
	              claim HxY: x :e Y.
	              { exact (setminusE1 Y K1 x HxYK1). }
	              claim HxnotK1: x /:e K1.
	              { exact (setminusE2 Y K1 x HxYK1). }
	              claim HxnotK2: x /:e K2.
	              { exact (setminusE2 Y K2 x HxYK2). }
	              claim HxnotK12: x /:e K12.
	              { assume HxK12: x :e K12.
	                apply (binunionE K1 K2 x HxK12 False).
	                - assume HxK1: x :e K1. exact (HxnotK1 HxK1).
	                - assume HxK2: x :e K2. exact (HxnotK2 HxK2). }
	              exact (setminusI Y K12 x HxY HxnotK12).
	            - let x. assume Hx: x :e Y :\: K12.
	              claim HxY: x :e Y.
	              { exact (setminusE1 Y K12 x Hx). }
	              claim HxnotK12: x /:e K12.
	              { exact (setminusE2 Y K12 x Hx). }
	              claim HxnotK1: x /:e K1.
	              { assume HxK1: x :e K1.
	                apply HxnotK12.
	                exact (binunionI1 K1 K2 x HxK1). }
	              claim HxnotK2: x /:e K2.
	              { assume HxK2: x :e K2.
	                apply HxnotK12.
	                exact (binunionI2 K1 K2 x HxK2). }
	              claim HxYK1: x :e Y :\: K1.
	              { exact (setminusI Y K1 x HxY HxnotK1). }
	              claim HxYK2: x :e Y :\: K2.
	              { exact (setminusI Y K2 x HxY HxnotK2). }
	              exact (binintersectI (Y :\: K1) (Y :\: K2) x HxYK1 HxYK2). }
	          claim HPredUV:
	            (p /:e U :/\: V /\ U :/\: V :e Tx) \/
	            (p :e U :/\: V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U :/\: V = Y :\: K0).
	          { apply orIR.
	            apply andI.
	            - exact HpUV.
	            - witness K12.
	              apply andI.
	              * (** compact_space K12 (...) /\ K12 c= X **)
	                apply andI.
	                + exact HK12comp.
	                + exact HK12subX.
	              * exact HeqUV. }
	          exact (SepI (Power Y)
	                      (fun U0:set =>
	                        (p /:e U0 /\ U0 :e Tx) \/
	                        (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
	                      (U :/\: V)
	                      HUVpowY
	                      HPredUV).
  - (** separation axiom **)
    let x1 x2.
    assume Hx1Y: x1 :e Y.
    assume Hx2Y: x2 :e Y.
    assume Hneq: x1 <> x2.
    prove exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
    apply (binunionE X {p} x1 Hx1Y
      (exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
    + (** x1 in X **)
      assume Hx1X: x1 :e X.
      apply (binunionE X {p} x2 Hx2Y
        (exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
      * (** x2 in X: use Hausdorff separation in X **)
        assume Hx2X: x2 :e X.
        claim HTx: topology_on X Tx.
        { exact (Hausdorff_space_topology X Tx HH). }
        apply (Hausdorff_space_separation X Tx x1 x2 HH Hx1X Hx2X Hneq).
        let U. assume HexV.
        apply HexV.
        let V. assume HUV.
        witness U.
        witness V.
        (** transport the Tx-open sets to Ty-open sets via the first disjunct **)
        claim HUV1: ((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V.
        { exact (andEL (((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V)
                       (U :/\: V = Empty)
                       HUV). }
        claim HUVempty: U :/\: V = Empty.
        { exact (andER (((U :e Tx /\ V :e Tx) /\ x1 :e U) /\ x2 :e V)
                       (U :/\: V = Empty)
                       HUV). }
        claim HUV2: (U :e Tx /\ V :e Tx) /\ x1 :e U.
        { exact (andEL ((U :e Tx /\ V :e Tx) /\ x1 :e U)
                       (x2 :e V)
                       HUV1). }
        claim Hx2V: x2 :e V.
        { exact (andER ((U :e Tx /\ V :e Tx) /\ x1 :e U)
                       (x2 :e V)
                       HUV1). }
        claim HUV3: U :e Tx /\ V :e Tx.
        { exact (andEL (U :e Tx /\ V :e Tx)
                       (x1 :e U)
                       HUV2). }
        claim Hx1U: x1 :e U.
        { exact (andER (U :e Tx /\ V :e Tx)
                       (x1 :e U)
                       HUV2). }
        claim HUinTx: U :e Tx.
        { exact (andEL (U :e Tx) (V :e Tx) HUV3). }
        claim HVinTx: V :e Tx.
        { exact (andER (U :e Tx) (V :e Tx) HUV3). }
        claim HUsubX: U c= X.
        { exact (topology_elem_subset X Tx U HTx HUinTx). }
        claim HVsubX: V c= X.
        { exact (topology_elem_subset X Tx V HTx HVinTx). }
        claim HpnotU: p /:e U.
        { assume HpU: p :e U.
          claim HpX: p :e X.
          { exact (HUsubX p HpU). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HpnotV: p /:e V.
        { assume HpV: p :e V.
          claim HpX: p :e X.
          { exact (HVsubX p HpV). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        (** show U :e Ty and V :e Ty **)
        claim HUsubY: U c= Y.
        { let z. assume HzU: z :e U.
          exact (binunionI1 X {p} z (HUsubX z HzU)). }
        claim HVsubY: V c= Y.
        { let z. assume HzV: z :e V.
          exact (binunionI1 X {p} z (HVsubX z HzV)). }
        claim HUpowY: U :e Power Y.
        { exact (PowerI Y U HUsubY). }
        claim HVpowY: V :e Power Y.
        { exact (PowerI Y V HVsubY). }
        claim HUinTy: U :e Ty.
        { exact (SepI (Power Y)
                      (fun U0:set =>
                        (p /:e U0 /\ U0 :e Tx) \/
                        (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                      U
                      HUpowY
                      (orIL (p /:e U /\ U :e Tx)
                            (p :e U /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U = Y :\: K)
                            (andI (p /:e U) (U :e Tx) HpnotU HUinTx))). }
        claim HVinTy: V :e Ty.
        { exact (SepI (Power Y)
                      (fun U0:set =>
                        (p /:e U0 /\ U0 :e Tx) \/
                        (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                      V
                      HVpowY
                      (orIL (p /:e V /\ V :e Tx)
                            (p :e V /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K)
                            (andI (p /:e V) (V :e Tx) HpnotV HVinTx))). }
        apply and5I.
        - exact HUinTy.
        - exact HVinTy.
        - exact Hx1U.
        - exact Hx2V.
        - exact HUVempty.
      * (** x2 = p: use local compactness around x1 **)
        assume Hx2p: x2 :e {p}.
        claim Hx2eq: x2 = p.
        { exact (SingE p x2 Hx2p). }
        claim HTx: topology_on X Tx.
        { exact (locally_compact_topology X Tx Hlc). }
        apply (locally_compact_local X Tx x1 Hlc Hx1X).
        let U. assume HU0.
        claim HUleft: U :e Tx /\ x1 :e U.
        { exact (andEL (U :e Tx /\ x1 :e U)
                       (compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)))
                       HU0). }
        claim HKcomp: compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)).
        { exact (andER (U :e Tx /\ x1 :e U)
                       (compact_space (closure_of X Tx U) (subspace_topology X Tx (closure_of X Tx U)))
                       HU0). }
        claim HUopen: U :e Tx.
        { exact (andEL (U :e Tx) (x1 :e U) HUleft). }
        claim Hx1U: x1 :e U.
        { exact (andER (U :e Tx) (x1 :e U) HUleft). }
        set K := closure_of X Tx U.
        set V := Y :\: K.
        claim HKsubX: K c= X.
        { exact (closure_in_space X Tx U HTx). }
        claim HUsubX: U c= X.
        { exact (topology_elem_subset X Tx U HTx HUopen). }
        claim HUsubK: U c= K.
        { exact (subset_of_closure X Tx U HTx HUsubX). }
        claim HpnotU: p /:e U.
        { assume HpU: p :e U.
          claim HpX: p :e X.
          { exact (HUsubX p HpU). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HUsubY: U c= Y.
        { let z. assume HzU: z :e U.
          exact (binunionI1 X {p} z (HUsubX z HzU)). }
        claim HUpowY: U :e Power Y.
        { exact (PowerI Y U HUsubY). }
        claim HUinTy: U :e Ty.
        { exact (SepI (Power Y)
                      (fun U0:set =>
                        (p /:e U0 /\ U0 :e Tx) \/
                        (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
                      U
                      HUpowY
                      (orIL (p /:e U /\ U :e Tx)
                            (p :e U /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U = Y :\: K0)
                            (andI (p /:e U) (U :e Tx) HpnotU HUopen))). }
        (** V is open around p by definition **)
        claim HVsubY: V c= Y.
        { let z. assume Hz: z :e V.
          exact (setminusE1 Y K z Hz). }
        claim HVpowY: V :e Power Y.
        { exact (PowerI Y V HVsubY). }
        claim HpY: p :e Y.
        { exact (binunionI2 X {p} p (SingI p)). }
        claim HpnotK: p /:e K.
        { assume HpK: p :e K.
          claim HpX: p :e X.
          { exact (HKsubX p HpK). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HpV: p :e V.
        { exact (setminusI Y K p HpY HpnotK). }
        claim HVinTy: V :e Ty.
        { apply (SepI (Power Y)
                      (fun U0:set =>
                        (p /:e U0 /\ U0 :e Tx) \/
                        (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0))
                      V
                      HVpowY).
          prove (p /:e V /\ V :e Tx) \/
                (p :e V /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ V = Y :\: K0).
          apply orIR.
          apply andI.
          - exact HpV.
          - witness K.
            apply andI.
            + (** compact_space K ... /\ K c= X **)
              apply andI.
              * exact HKcomp.
              * exact HKsubX.
            + reflexivity. }
        (** disjointness: U ∩ V = Empty since U ⊆ K and V = Y\\K **)
        claim HUVempty: U :/\: V = Empty.
        { apply set_ext.
          - let z. assume Hz: z :e U :/\: V.
            apply FalseE.
            claim Hzpair: z :e U /\ z :e V.
            { exact (binintersectE U V z Hz). }
            claim HzU: z :e U.
            { exact (andEL (z :e U) (z :e V) Hzpair). }
            claim HzV: z :e V.
            { exact (andER (z :e U) (z :e V) Hzpair). }
            claim HzK: z :e K.
            { exact (HUsubK z HzU). }
            claim HznotK: z /:e K.
            { exact (setminusE2 Y K z HzV). }
            exact (HznotK HzK).
          - exact (Subq_Empty (U :/\: V)). }
        witness U.
        witness V.
        apply and5I.
        - exact HUinTy.
        - exact HVinTy.
        - exact Hx1U.
        - rewrite Hx2eq. exact HpV.
        - exact HUVempty.
    + (** x1 = p: symmetric case **)
      assume Hx1p: x1 :e {p}.
      claim Hx1eq: x1 = p.
      { exact (SingE p x1 Hx1p). }
      apply (binunionE X {p} x2 Hx2Y
        (exists U V:set, U :e Ty /\ V :e Ty /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
      * (** x2 in X: swap roles and reuse previous argument **)
        assume Hx2X: x2 :e X.
        claim HTx: topology_on X Tx.
        { exact (locally_compact_topology X Tx Hlc). }
        apply (locally_compact_local X Tx x2 Hlc Hx2X).
        let U0. assume HU0.
        claim HUleft: U0 :e Tx /\ x2 :e U0.
        { exact (andEL (U0 :e Tx /\ x2 :e U0)
                       (compact_space (closure_of X Tx U0) (subspace_topology X Tx (closure_of X Tx U0)))
                       HU0). }
        claim HKcomp: compact_space (closure_of X Tx U0) (subspace_topology X Tx (closure_of X Tx U0)).
        { exact (andER (U0 :e Tx /\ x2 :e U0)
                       (compact_space (closure_of X Tx U0) (subspace_topology X Tx (closure_of X Tx U0)))
                       HU0). }
        claim HUopen: U0 :e Tx.
        { exact (andEL (U0 :e Tx) (x2 :e U0) HUleft). }
        claim Hx2U: x2 :e U0.
        { exact (andER (U0 :e Tx) (x2 :e U0) HUleft). }
        set K0 := closure_of X Tx U0.
        set V0 := Y :\: K0.
        claim HKsubX: K0 c= X.
        { exact (closure_in_space X Tx U0 HTx). }
        claim HUsubX: U0 c= X.
        { exact (topology_elem_subset X Tx U0 HTx HUopen). }
        claim HUsubK: U0 c= K0.
        { exact (subset_of_closure X Tx U0 HTx HUsubX). }
        claim HpnotU: p /:e U0.
        { assume HpU: p :e U0.
          claim HpX: p :e X.
          { exact (HUsubX p HpU). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HUsubY: U0 c= Y.
        { let z. assume HzU: z :e U0.
          exact (binunionI1 X {p} z (HUsubX z HzU)). }
        claim HUpowY: U0 :e Power Y.
        { exact (PowerI Y U0 HUsubY). }
        claim HUinTy: U0 :e Ty.
        { exact (SepI (Power Y)
                      (fun U1:set =>
                        (p /:e U1 /\ U1 :e Tx) \/
                        (p :e U1 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U1 = Y :\: K1))
                      U0
                      HUpowY
                      (orIL (p /:e U0 /\ U0 :e Tx)
                            (p :e U0 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U0 = Y :\: K1)
                            (andI (p /:e U0) (U0 :e Tx) HpnotU HUopen))). }
        claim HVsubY: V0 c= Y.
        { let z. assume Hz: z :e V0.
          exact (setminusE1 Y K0 z Hz). }
        claim HVpowY: V0 :e Power Y.
        { exact (PowerI Y V0 HVsubY). }
        claim HpY: p :e Y.
        { exact (binunionI2 X {p} p (SingI p)). }
        claim HpnotK: p /:e K0.
        { assume HpK: p :e K0.
          claim HpX: p :e X.
          { exact (HKsubX p HpK). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HpV: p :e V0.
        { exact (setminusI Y K0 p HpY HpnotK). }
        claim HVinTy: V0 :e Ty.
        { apply (SepI (Power Y)
                      (fun U1:set =>
                        (p /:e U1 /\ U1 :e Tx) \/
                        (p :e U1 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U1 = Y :\: K1))
                      V0
                      HVpowY).
          prove (p /:e V0 /\ V0 :e Tx) \/
                (p :e V0 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ V0 = Y :\: K1).
          apply orIR.
          apply andI.
          - exact HpV.
          - witness K0.
            apply andI.
            + apply andI.
              * exact HKcomp.
              * exact HKsubX.
            + reflexivity. }
        claim HUVempty: U0 :/\: V0 = Empty.
        { apply set_ext.
          - let z. assume Hz: z :e U0 :/\: V0.
            apply FalseE.
            claim Hzpair: z :e U0 /\ z :e V0.
            { exact (binintersectE U0 V0 z Hz). }
            claim HzU: z :e U0.
            { exact (andEL (z :e U0) (z :e V0) Hzpair). }
            claim HzV: z :e V0.
            { exact (andER (z :e U0) (z :e V0) Hzpair). }
            claim HzK: z :e K0.
            { exact (HUsubK z HzU). }
            claim HznotK: z /:e K0.
            { exact (setminusE2 Y K0 z HzV). }
            exact (HznotK HzK).
          - exact (Subq_Empty (U0 :/\: V0)). }
        witness V0.
        witness U0.
        apply and5I.
        - exact HVinTy.
        - exact HUinTy.
        - rewrite Hx1eq. exact HpV.
        - exact Hx2U.
        - rewrite (binintersect_com V0 U0). exact HUVempty.
      * (** x2 = p: contradiction with distinctness **)
        assume Hx2p: x2 :e {p}.
        claim Hx1p': x1 = p.
        { exact (SingE p x1 Hx1p). }
        claim Hx2p': x2 = p.
        { exact (SingE p x2 Hx2p). }
        apply FalseE.
        apply Hneq.
        rewrite Hx1p'.
	        rewrite Hx2p'.
	        reflexivity. }
claim HcompY: compact_space Y Ty.
{ (** Standard one-point compactification compactness argument. **)
  claim HTy: topology_on Y Ty.
  { exact (Hausdorff_space_topology Y Ty HHausY). }
  prove compact_space Y Ty.
  prove topology_on Y Ty /\ forall Fam:set, open_cover_of Y Ty Fam -> has_finite_subcover Y Ty Fam.
  apply andI.
  - exact HTy.
  - let Fam. assume HFam: open_cover_of Y Ty Fam.
    prove has_finite_subcover Y Ty Fam.
    (** Choose a member U0 of the cover containing p. **)
    claim HYcov: Y c= Union Fam.
    { exact (open_cover_of_covers Y Ty Fam HFam). }
    claim HpY: p :e Y.
    { exact (binunionI2 X {p} p (SingI p)). }
    claim HpUnion: p :e Union Fam.
    { exact (HYcov p HpY). }
    apply (UnionE_impred Fam p HpUnion).
    let U0. assume HpU0: p :e U0. assume HU0Fam: U0 :e Fam.
    claim HU0Ty: U0 :e Ty.
    { exact (open_cover_of_members_open Y Ty Fam U0 HFam HU0Fam). }
    claim HU0prop:
      (p /:e U0 /\ U0 :e Tx) \/
      (p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0).
    { exact (SepE2 (Power Y)
                   (fun U1:set =>
                     (p /:e U1 /\ U1 :e Tx) \/
                     (p :e U1 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U1 = Y :\: K0))
                   U0
                   HU0Ty). }
    apply HU0prop.
    - assume Hbad: p /:e U0 /\ U0 :e Tx.
      apply FalseE.
      exact ((andEL (p /:e U0) (U0 :e Tx) Hbad) HpU0).
	    - assume Hgood: p :e U0 /\ exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0.
	      (** Use compactness of the complement K0 to extract a finite subcover of K0, then add U0. **)
	      claim HexK0:
	        exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0.
	      { exact (andER (p :e U0)
	                     (exists K0:set, compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X /\ U0 = Y :\: K0)
	                     Hgood). }
	      apply HexK0.
	      let K0. assume HK0pkg.
	      claim HK0left: compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X.
	      { exact (andEL (compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X)
	                     (U0 = Y :\: K0)
	                     HK0pkg). }
	      claim HK0comp: compact_space K0 (subspace_topology X Tx K0).
	      { exact (andEL (compact_space K0 (subspace_topology X Tx K0))
	                     (K0 c= X)
	                     HK0left). }
	      claim HK0subX: K0 c= X.
	      { exact (andER (compact_space K0 (subspace_topology X Tx K0))
	                     (K0 c= X)
	                     HK0left). }
	      claim HU0eq: U0 = Y :\: K0.
	      { exact (andER (compact_space K0 (subspace_topology X Tx K0) /\ K0 c= X)
	                     (U0 = Y :\: K0)
	                     HK0pkg). }
	      claim HTxX: topology_on X Tx.
	      { exact (locally_compact_topology X Tx Hlc). }
	      (** Build an ambient Tx-open cover of K0 derived from Fam by intersecting with X. **)
	      set FamX := {V :e Tx | exists U:set, U :e Fam /\ V = U :/\: X}.
	      claim HFamXsub: FamX c= Tx.
	      { let V. assume HV: V :e FamX.
	        exact (SepE1 Tx (fun V0:set => exists U:set, U :e Fam /\ V0 = U :/\: X) V HV). }
	      claim HK0covFamX: K0 c= Union FamX.
	      { let x. assume HxK0: x :e K0.
	        claim HxX: x :e X.
	        { exact (HK0subX x HxK0). }
	        claim HxY: x :e Y.
	        { exact (binunionI1 X {p} x HxX). }
	        claim HxUnionFam: x :e Union Fam.
	        { exact (HYcov x HxY). }
	        (** Choose U∈Fam with x∈U, and set V := U∩X ∈ Tx. **)
	        apply (UnionE_impred Fam x HxUnionFam).
	        let U. assume HxU: x :e U. assume HUinFam: U :e Fam.
	        claim HUinTy: U :e Ty.
	        { exact (open_cover_of_members_open Y Ty Fam U HFam HUinFam). }
	        claim HUprop:
	          (p /:e U /\ U :e Tx) \/
	          (p :e U /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1).
	        { exact (SepE2 (Power Y)
	                       (fun U1:set =>
	                         (p /:e U1 /\ U1 :e Tx) \/
	                         (p :e U1 /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U1 = Y :\: K1))
	                       U
	                       HUinTy). }
	        set V := U :/\: X.
	        claim HVTx: V :e Tx.
	        { apply HUprop.
	          - assume Hcase: p /:e U /\ U :e Tx.
	            claim HUinTx: U :e Tx.
	            { exact (andER (p /:e U) (U :e Tx) Hcase). }
	            claim HUs: U c= X.
	            { exact (topology_elem_subset X Tx U HTxX HUinTx). }
	            rewrite (binintersect_Subq_eq_1 U X HUs).
	            exact HUinTx.
	          - assume Hcase: p :e U /\ exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1.
	            claim HexK1: exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1.
	            { exact (andER (p :e U)
	                           (exists K1:set, compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X /\ U = Y :\: K1)
	                           Hcase). }
	            apply HexK1.
	            let K1. assume HK1pkg.
	            claim HK1left: compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X.
	            { exact (andEL (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
	                           (U = Y :\: K1)
	                           HK1pkg). }
	            claim HK1comp: compact_space K1 (subspace_topology X Tx K1).
	            { exact (andEL (compact_space K1 (subspace_topology X Tx K1))
	                           (K1 c= X)
	                           HK1left). }
	            claim HK1subX: K1 c= X.
	            { exact (andER (compact_space K1 (subspace_topology X Tx K1))
	                           (K1 c= X)
	                           HK1left). }
	            claim HUeq1: U = Y :\: K1.
	            { exact (andER (compact_space K1 (subspace_topology X Tx K1) /\ K1 c= X)
	                           (U = Y :\: K1)
	                           HK1pkg). }
	            claim HK1closed: closed_in X Tx K1.
	            { exact (Hausdorff_compact_sets_closed X Tx K1 HH HK1subX HK1comp). }
		            claim Hop: open_in X Tx (X :\: K1).
		            { exact (open_of_closed_complement X Tx K1 HK1closed). }
		            claim HXK1: (X :\: K1) :e Tx.
		            { exact (open_in_elem X Tx (X :\: K1) Hop). }
		            rewrite HUeq1.
		            claim HeqV: (Y :\: K1) :/\: X = X :\: K1.
		            { apply set_ext.
		              - let y. assume Hy: y :e (Y :\: K1) :/\: X.
		                claim HyYK1: y :e Y :\: K1.
		                { exact (binintersectE1 (Y :\: K1) X y Hy). }
		                claim HyX: y :e X.
		                { exact (binintersectE2 (Y :\: K1) X y Hy). }
		                claim HynotK1: y /:e K1.
		                { exact (setminusE2 Y K1 y HyYK1). }
		                exact (setminusI X K1 y HyX HynotK1).
		              - let y. assume Hy: y :e X :\: K1.
		                claim HyX: y :e X.
		                { exact (setminusE1 X K1 y Hy). }
		                claim HynotK1: y /:e K1.
		                { exact (setminusE2 X K1 y Hy). }
		                claim HyY: y :e Y.
		                { exact (binunionI1 X {p} y HyX). }
		                claim HyYK1: y :e Y :\: K1.
		                { exact (setminusI Y K1 y HyY HynotK1). }
		                exact (binintersectI (Y :\: K1) X y HyYK1 HyX). }
		            rewrite HeqV.
		            exact HXK1. }
		        claim HVinFamX: V :e FamX.
		        { apply (SepI Tx (fun V0:set => exists U0:set, U0 :e Fam /\ V0 = U0 :/\: X) V).
		          - exact HVTx.
		          - prove exists U0:set, U0 :e Fam /\ V = U0 :/\: X.
		            witness U.
		            apply andI.
		            * exact HUinFam.
		            * reflexivity. }
	        claim HxV: x :e V.
	        { exact (binintersectI U X x HxU HxX). }
	        exact (UnionI FamX x V HxV HVinFamX). }
	      (** Apply compactness of K0 via ambient covers to FamX. **)
	      claim HK0equiv:
	        (compact_space K0 (subspace_topology X Tx K0) <->
	          forall Fam0:set, (Fam0 c= Tx /\ K0 c= Union Fam0) -> has_finite_subcover K0 Tx Fam0).
	      { exact (compact_subspace_via_ambient_covers X Tx K0 HTxX HK0subX). }
	      claim HK0amb:
	        forall Fam0:set, (Fam0 c= Tx /\ K0 c= Union Fam0) -> has_finite_subcover K0 Tx Fam0.
	      { exact (iffEL (compact_space K0 (subspace_topology X Tx K0))
	                     (forall Fam0:set, (Fam0 c= Tx /\ K0 c= Union Fam0) -> has_finite_subcover K0 Tx Fam0)
	                     HK0equiv
	                     HK0comp). }
	      claim HfinX: has_finite_subcover K0 Tx FamX.
	      { exact (HK0amb FamX (andI (FamX c= Tx) (K0 c= Union FamX) HFamXsub HK0covFamX)). }
	      (** Lift the finite subcover of K0 by Tx-sets in FamX to a finite subcover of Y by Ty-sets in Fam. **)
		      apply HfinX.
		      let Gx. assume HGx.
		      claim HGxleft: Gx c= FamX /\ finite Gx.
		      { exact (andEL (Gx c= FamX /\ finite Gx) (K0 c= Union Gx) HGx). }
		      claim HGxsub: Gx c= FamX.
		      { exact (andEL (Gx c= FamX) (finite Gx) HGxleft). }
		      claim HGxfin: finite Gx.
		      { exact (andER (Gx c= FamX) (finite Gx) HGxleft). }
		      claim HK0covGx: K0 c= Union Gx.
		      { exact (andER (Gx c= FamX /\ finite Gx) (K0 c= Union Gx) HGx). }
	      (** Choose, for each V∈Gx, one U∈Fam with V = U∩X. **)
	      set pickU := fun V:set => Eps_i (fun U:set => U :e Fam /\ V = U :/\: X).
	      set Gpre := {pickU V|V :e Gx}.
	      claim HGpreFin: finite Gpre.
	      { exact (Repl_finite (fun V:set => pickU V) Gx HGxfin). }
	      claim HGpreSub: Gpre c= Fam.
	      { let U. assume HU: U :e Gpre.
	        claim HexV: exists V:set, V :e Gx /\ U = pickU V.
	        { exact (ReplE Gx (fun V0:set => pickU V0) U HU). }
	        apply HexV.
	        let V. assume HVand.
	        claim HVinGx: V :e Gx.
	        { exact (andEL (V :e Gx) (U = pickU V) HVand). }
	        claim HUeqp: U = pickU V.
	        { exact (andER (V :e Gx) (U = pickU V) HVand). }
	        claim HVinFamX: V :e FamX.
	        { exact (HGxsub V HVinGx). }
	        claim HexU: exists U0:set, U0 :e Fam /\ V = U0 :/\: X.
	        { exact (SepE2 Tx (fun V0:set => exists U0:set, U0 :e Fam /\ V0 = U0 :/\: X) V HVinFamX). }
	        claim Hpick: (pickU V) :e Fam /\ V = (pickU V) :/\: X.
	        { apply HexU.
	          let U0. assume HU0and.
	          exact (Eps_i_ax (fun U1:set => U1 :e Fam /\ V = U1 :/\: X) U0 HU0and). }
	        rewrite HUeqp.
	        exact (andEL ((pickU V) :e Fam) (V = (pickU V) :/\: X) Hpick). }
	      claim HK0covGpre: K0 c= Union Gpre.
	      { let x. assume HxK0: x :e K0.
	        claim HxUnion: x :e Union Gx.
	        { exact (HK0covGx x HxK0). }
	        apply (UnionE_impred Gx x HxUnion).
	        let V. assume HxV: x :e V. assume HVinGx: V :e Gx.
	        claim HVinFamX: V :e FamX.
	        { exact (HGxsub V HVinGx). }
	        claim HexU: exists U0:set, U0 :e Fam /\ V = U0 :/\: X.
	        { exact (SepE2 Tx (fun V0:set => exists U0:set, U0 :e Fam /\ V0 = U0 :/\: X) V HVinFamX). }
	        claim Hpick: (pickU V) :e Fam /\ V = (pickU V) :/\: X.
	        { apply HexU.
	          let U0. assume HU0and.
	          exact (Eps_i_ax (fun U1:set => U1 :e Fam /\ V = U1 :/\: X) U0 HU0and). }
		        claim HxPick: x :e pickU V.
		        { claim HxV': x :e (pickU V) :/\: X.
		          { claim HeqV: V = (pickU V) :/\: X.
		            { exact (andER ((pickU V) :e Fam) (V = (pickU V) :/\: X) Hpick). }
		            rewrite <- HeqV.
		            exact HxV. }
		          exact (binintersectE1 (pickU V) X x HxV'). }
		        claim HpickInGpre: pickU V :e Gpre.
		        { exact (ReplI Gx (fun V0:set => pickU V0) V HVinGx). }
		        exact (UnionI Gpre x (pickU V) HxPick HpickInGpre). }
		      (** Final finite subcover of Y: G := Gpre ∪ {U0}. **)
		      set G := Gpre :\/: {U0}.
		      apply (has_finite_subcoverI Y Ty Fam G).
		      apply andI.
		      - (** G c= Fam /\ finite G **)
		        apply andI.
		        + (** G c= Fam **)
		          let U. assume HU: U :e G.
		          apply (binunionE Gpre {U0} U HU (U :e Fam)).
		          * assume HUpre: U :e Gpre.
		            exact (HGpreSub U HUpre).
		          * assume HUsing: U :e {U0}.
		            claim Heq: U = U0.
		            { exact (SingE U0 U HUsing). }
		            rewrite Heq.
		            exact HU0Fam.
		        + (** finite G **)
		          exact (binunion_finite Gpre HGpreFin {U0} (Sing_finite U0)).
		      - (** Y c= Union G **)
		        let y. assume HyY: y :e Y.
		        apply (binunionE X {p} y HyY (y :e Union G)).
		        + (** y in X **)
		          assume HyX: y :e X.
		          apply (xm (y :e U0)).
		          * assume HyU0: y :e U0.
		            exact (UnionI G y U0 HyU0 (binunionI2 Gpre {U0} U0 (SingI U0))).
		          * assume HyNotU0: ~(y :e U0).
		            claim HyK0: y :e K0.
		            { apply (xm (y :e K0)).
		              - assume HyK0. exact HyK0.
		              - assume HyNotK0: ~(y :e K0).
		                claim HyU0': y :e U0.
		                { rewrite HU0eq.
		                  exact (setminusI Y K0 y HyY HyNotK0). }
		                apply FalseE.
		                exact (HyNotU0 HyU0'). }
		            claim HyUnionPre: y :e Union Gpre.
		            { exact (HK0covGpre y HyK0). }
		            apply (UnionE_impred Gpre y HyUnionPre).
		            let U. assume HyU: y :e U. assume HUpre: U :e Gpre.
		            exact (UnionI G y U HyU (binunionI1 Gpre {U0} U HUpre)).
		        + (** y = p **)
		          assume Hyp: y :e {p}.
		          claim Heq: y = p.
		          { exact (SingE p y Hyp). }
		          rewrite Heq.
		          exact (UnionI G p U0 HpU0 (binunionI2 Gpre {U0} U0 (SingI U0))).
		      }
claim HXsubY: X c= Y.
{ let x. assume HxX: x :e X.
  exact (binunionI1 X {p} x HxX). }
claim HexPoint:
  exists p0:set, p0 :e Y /\ ~ p0 :e X /\
    subspace_topology Y Ty X = Tx /\
    (forall y:set, y :e Y -> y :e X \/ y = p0).
{ witness p.
  apply andI.
  - (** (p :e Y /\ ~ p :e X) /\ subspace_topology Y Ty X = Tx **)
    prove (p :e Y /\ ~ p :e X) /\ subspace_topology Y Ty X = Tx.
    apply andI.
    + (** p :e Y /\ ~ p :e X **)
      apply andI.
      * (** p :e Y **)
        exact (binunionI2 X {p} p (SingI p)).
      * (** ~ p :e X **)
        claim HpEq: p = X.
        { reflexivity. }
        rewrite HpEq.
        exact (In_irref X).
    + (** subspace_topology Y Ty X = Tx **)
      claim HTx: topology_on X Tx.
      { exact (locally_compact_topology X Tx Hlc). }
      apply set_ext.
	      * let W. assume HW: W :e subspace_topology Y Ty X.
	        prove W :e Tx.
	        claim Hex: exists V :e Ty, W = V :/\: X.
	        { exact (subspace_topologyE Y Ty X W HW). }
	        apply Hex.
	        let V. assume HVpair.
	        claim HV: V :e Ty.
	        { exact (andEL (V :e Ty) (W = V :/\: X) HVpair). }
        claim HWeq: W = V :/\: X.
        { exact (andER (V :e Ty) (W = V :/\: X) HVpair). }
        claim HVprop:
          (p /:e V /\ V :e Tx) \/
          (p :e V /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K).
        { exact (SepE2 (Power Y)
                       (fun U0:set =>
                         (p /:e U0 /\ U0 :e Tx) \/
                         (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                       V
                       HV). }
        apply HVprop.
        - assume Hcase: p /:e V /\ V :e Tx.
           claim HVinTx: V :e Tx.
           { exact (andER (p /:e V) (V :e Tx) Hcase). }
           claim HVsubX: V c= X.
           { exact (topology_elem_subset X Tx V HTx HVinTx). }
           claim HVeq: V :/\: X = V.
           { exact (binintersect_Subq_eq_1 V X HVsubX). }
           claim HWeqV: W = V.
           { rewrite HWeq. exact HVeq. }
           rewrite HWeqV.
           exact HVinTx.
        - assume Hcase: p :e V /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K.
           claim HexK: exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K.
           { exact (andER (p :e V)
                          (exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ V = Y :\: K)
                          Hcase). }
           apply HexK.
           let K. assume HKpkg.
           claim HKleft: compact_space K (subspace_topology X Tx K) /\ K c= X.
           { exact (andEL (compact_space K (subspace_topology X Tx K) /\ K c= X)
                          (V = Y :\: K)
                          HKpkg). }
           claim HKcomp: compact_space K (subspace_topology X Tx K).
           { exact (andEL (compact_space K (subspace_topology X Tx K)) (K c= X) HKleft). }
           claim HKsubX: K c= X.
           { exact (andER (compact_space K (subspace_topology X Tx K)) (K c= X) HKleft). }
           claim HVe: V = Y :\: K.
           { exact (andER (compact_space K (subspace_topology X Tx K) /\ K c= X)
                          (V = Y :\: K)
                          HKpkg). }
           claim HWdef: W = (Y :\: K) :/\: X.
           { rewrite HWeq. rewrite HVe. reflexivity. }
           claim HeqWXK: (Y :\: K) :/\: X = X :\: K.
           { apply set_ext.
             - let x. assume Hx: x :e (Y :\: K) :/\: X.
               prove x :e X :\: K.
               claim Hpair: x :e (Y :\: K) /\ x :e X.
               { exact (binintersectE (Y :\: K) X x Hx). }
               claim HxYK: x :e Y :\: K.
               { exact (andEL (x :e Y :\: K) (x :e X) Hpair). }
               claim HxX: x :e X.
               { exact (andER (x :e Y :\: K) (x :e X) Hpair). }
               claim HxnotK: x /:e K.
               { exact (setminusE2 Y K x HxYK). }
               exact (setminusI X K x HxX HxnotK).
             - let x. assume Hx: x :e X :\: K.
               prove x :e (Y :\: K) :/\: X.
               claim HxX: x :e X.
               { exact (setminusE1 X K x Hx). }
               claim HxnotK: x /:e K.
               { exact (setminusE2 X K x Hx). }
               claim HxY: x :e Y.
               { exact (binunionI1 X {p} x HxX). }
               claim HxYK: x :e Y :\: K.
               { exact (setminusI Y K x HxY HxnotK). }
               exact (binintersectI (Y :\: K) X x HxYK HxX). }
           claim HWis: W = X :\: K.
           { rewrite HWdef. exact HeqWXK. }
           rewrite HWis.
           claim HKclosed: closed_in X Tx K.
           { exact (Hausdorff_compact_sets_closed X Tx K HH HKsubX HKcomp). }
           claim HKpkg2: K c= X /\ exists U:set, U :e Tx /\ K = X :\: U.
           { exact (closed_in_package X Tx K HKclosed). }
           claim HexU: exists U:set, U :e Tx /\ K = X :\: U.
           { exact (andER (K c= X) (exists U:set, U :e Tx /\ K = X :\: U) HKpkg2). }
           apply HexU.
           let U. assume HUpkg.
           claim HUinTx: U :e Tx.
           { exact (andEL (U :e Tx) (K = X :\: U) HUpkg). }
           claim HKeq: K = X :\: U.
           { exact (andER (U :e Tx) (K = X :\: U) HUpkg). }
           claim HUsubX: U c= X.
           { exact (topology_elem_subset X Tx U HTx HUinTx). }
           claim HeqXminusK: X :\: K = U.
           { apply set_ext.
             - let x. assume Hx: x :e X :\: K.
               prove x :e U.
               claim HxX: x :e X.
               { exact (setminusE1 X K x Hx). }
               claim HxnotK: x /:e K.
               { exact (setminusE2 X K x Hx). }
               claim HxnotXU: x /:e X :\: U.
               { rewrite <- HKeq. exact HxnotK. }
               apply (xm (x :e U)).
               + assume HxU: x :e U.
                 exact HxU.
               + assume HxnotU: ~(x :e U).
                 claim HxXU: x :e X :\: U.
                 { exact (setminusI X U x HxX HxnotU). }
                 apply FalseE.
                 exact (HxnotXU HxXU).
             - let x. assume Hx: x :e U.
               prove x :e X :\: K.
               claim HxX: x :e X.
               { exact (HUsubX x Hx). }
               claim HxnotK: x /:e K.
               { assume HxK: x :e K.
	                 claim HxXU: x :e X :\: U.
	                 { rewrite <- HKeq. exact HxK. }
                 claim HxnotU: x /:e U.
                 { exact (setminusE2 X U x HxXU). }
                 exact (HxnotU Hx). }
               exact (setminusI X K x HxX HxnotK). }
           rewrite HeqXminusK.
           exact HUinTx.
      * let W. assume HW: W :e Tx.
        prove W :e subspace_topology Y Ty X.
        claim HWsubX: W c= X.
        { exact (topology_elem_subset X Tx W HTx HW). }
        claim HWsubY: W c= Y.
        { let x. assume HxW: x :e W.
          exact (binunionI1 X {p} x (HWsubX x HxW)). }
        claim HWpowY: W :e Power Y.
        { exact (PowerI Y W HWsubY). }
        claim HpnotW: p /:e W.
        { assume HpW: p :e W.
          claim HpX: p :e X.
          { exact (HWsubX p HpW). }
          claim HpEq: p = X.
          { reflexivity. }
          claim HXself: X :e X.
          { rewrite <- HpEq. exact HpX. }
          exact ((In_irref X) HXself). }
        claim HWTy: W :e Ty.
        { exact (SepI (Power Y)
                     (fun U0:set =>
                       (p /:e U0 /\ U0 :e Tx) \/
                       (p :e U0 /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ U0 = Y :\: K))
                     W
                     HWpowY
                     (orIL (p /:e W /\ W :e Tx)
                           (p :e W /\ exists K:set, compact_space K (subspace_topology X Tx K) /\ K c= X /\ W = Y :\: K)
                           (andI (p /:e W) (W :e Tx) HpnotW HW))). }
        claim HWpowX: W :e Power X.
        { exact (PowerI X W HWsubX). }
        claim HeqW: W = W :/\: X.
        { rewrite (binintersect_Subq_eq_1 W X HWsubX). reflexivity. }
        claim Hex: exists V :e Ty, W = V :/\: X.
        { witness W.
          exact (andI (W :e Ty) (W = W :/\: X) HWTy HeqW). }
        exact (SepI (Power X) (fun U0:set => exists V :e Ty, U0 = V :/\: X) W HWpowX Hex).
  - (** forall y:set, y :e Y -> y :e X \/ y = p **)
    let y. assume Hy: y :e Y.
    apply (binunionE X {p} y Hy).
    + assume HyX: y :e X.
      exact (orIL (y :e X) (y = p) HyX).
    + assume Hyp: y :e {p}.
      claim Heq: y = p.
      { exact (SingE p y Hyp). }
      exact (orIR (y :e X) (y = p) Heq). }
prove one_point_compactification X Tx Y Ty.
exact
  (andI
    ((compact_space Y Ty /\ Hausdorff_space Y Ty) /\ X c= Y)
    (exists p0:set, p0 :e Y /\ ~ p0 :e X /\ subspace_topology Y Ty X = Tx /\ (forall y:set, y :e Y -> y :e X \/ y = p0))
    (andI
      (compact_space Y Ty /\ Hausdorff_space Y Ty)
      (X c= Y)
      (andI (compact_space Y Ty) (Hausdorff_space Y Ty) HcompY HHausY)
      HXsubY)
    HexPoint).
Qed.

(** from §29 Exercises: local compactness and compactification **) 
(** LATEX VERSION: Exercises on constructing one-point compactifications. **)
Theorem ex29_local_compactness_exercises :
  forall X Tx:set, locally_compact X Tx -> Hausdorff_space X Tx ->
  exists Y Ty:set, one_point_compactification X Tx Y Ty.
let X Tx.
assume Hlc: locally_compact X Tx.
assume HH: Hausdorff_space X Tx.
prove exists Y Ty:set, one_point_compactification X Tx Y Ty.
exact (one_point_compactification_exists X Tx Hlc HH).
Qed.

(** from exercises after §29: directed sets **)
(** LATEX VERSION: A directed set J is a set with a partial order <= such that each pair has an upper bound. **)
Definition relation_on : set -> set -> prop := fun le J =>
  forall a b:set, (a,b) :e le -> a :e J /\ b :e J.

Definition partial_order_on : set -> set -> prop := fun J le =>
  relation_on le J /\
  (forall a:set, a :e J -> (a,a) :e le) /\
  (forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b) /\
  (forall a b c:set, a :e J -> b :e J -> c :e J ->
    (a,b) :e le -> (b,c) :e le -> (a,c) :e le).

(** helper: extract reflexivity from partial_order_on **)
Theorem partial_order_on_refl : forall J le:set,
  partial_order_on J le ->
  forall a:set, a :e J -> (a,a) :e le.
let J le.
assume Hpo: partial_order_on J le.
prove forall a:set, a :e J -> (a,a) :e le.
let a. assume HaJ: a :e J.
claim Htmp: (relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
            (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0).
{ exact (andEL
          ((relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
           (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0))
          (forall a0 b0 c0:set, a0 :e J -> b0 :e J -> c0 :e J ->
             (a0,b0) :e le -> (b0,c0) :e le -> (a0,c0) :e le)
          Hpo). }
claim Hrelrefl: relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le).
{ exact (andEL
          (relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le))
          (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0)
          Htmp). }
claim Hrefl: forall a0:set, a0 :e J -> (a0,a0) :e le.
{ exact (andER
          (relation_on le J)
          (forall a0:set, a0 :e J -> (a0,a0) :e le)
          Hrelrefl). }
exact (Hrefl a HaJ).
Qed.

(** helper: extract antisymmetry from partial_order_on **)
Theorem partial_order_on_antisym : forall J le:set,
  partial_order_on J le ->
  forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b.
let J le.
assume Hpo: partial_order_on J le.
prove forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b.
let a b.
assume HaJ: a :e J.
assume HbJ: b :e J.
assume Hab: (a,b) :e le.
assume Hba: (b,a) :e le.
claim Htmp: (relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
            (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0).
{ exact (andEL
          ((relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
           (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0))
          (forall a0 b0 c0:set, a0 :e J -> b0 :e J -> c0 :e J ->
             (a0,b0) :e le -> (b0,c0) :e le -> (a0,c0) :e le)
          Hpo). }
claim Hantisym: forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0.
{ exact (andER
          (relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le))
          (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0)
          Htmp). }
exact (Hantisym a b HaJ HbJ Hab Hba).
Qed.

(** helper: extract transitivity from partial_order_on **)
Theorem partial_order_on_trans : forall J le:set,
  partial_order_on J le ->
  forall a b c:set, a :e J -> b :e J -> c :e J ->
    (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
let J le.
assume Hpo: partial_order_on J le.
prove forall a b c:set, a :e J -> b :e J -> c :e J ->
  (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
let a b c.
assume HaJ: a :e J.
assume HbJ: b :e J.
assume HcJ: c :e J.
assume Hab: (a,b) :e le.
assume Hbc: (b,c) :e le.
claim Hleft: ((relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
              (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0)).
{ exact (andEL
          ((relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
           (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0))
          (forall a0 b0 c0:set, a0 :e J -> b0 :e J -> c0 :e J ->
             (a0,b0) :e le -> (b0,c0) :e le -> (a0,c0) :e le)
          Hpo). }
claim Htrans: forall a0 b0 c0:set, a0 :e J -> b0 :e J -> c0 :e J ->
  (a0,b0) :e le -> (b0,c0) :e le -> (a0,c0) :e le.
{ exact (andER
          ((relation_on le J /\ (forall a0:set, a0 :e J -> (a0,a0) :e le)) /\
           (forall a0 b0:set, a0 :e J -> b0 :e J -> (a0,b0) :e le -> (b0,a0) :e le -> a0 = b0))
          (forall a0 b0 c0:set, a0 :e J -> b0 :e J -> c0 :e J ->
             (a0,b0) :e le -> (b0,c0) :e le -> (a0,c0) :e le)
          Hpo). }
exact (Htrans a b c HaJ HbJ HcJ Hab Hbc).
Qed.

(** from exercises after §29: directed set **)
(** LATEX VERSION: A directed set is a nonempty partially ordered set in which any two elements have a common upper bound. **)
Definition directed_set : set -> set -> prop := fun J le =>
  (J <> Empty /\ partial_order_on J le) /\
  forall a b:set, a :e J -> b :e J ->
    exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le.

(** helper: extract partial_order_on from directed_set **)
Theorem directed_set_partial_order : forall J le:set,
  directed_set J le -> partial_order_on J le.
let J le.
assume HJ: directed_set J le.
claim Hleft: J <> Empty /\ partial_order_on J le.
{ exact (andEL
          (J <> Empty /\ partial_order_on J le)
          (forall a b:set, a :e J -> b :e J ->
             exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
          HJ). }
exact (andER (J <> Empty) (partial_order_on J le) Hleft).
Qed.

(** helper: reflexivity from directed_set **)
Theorem directed_set_refl : forall J le:set,
  directed_set J le ->
  forall a:set, a :e J -> (a,a) :e le.
let J le.
assume HJ: directed_set J le.
exact (partial_order_on_refl J le (directed_set_partial_order J le HJ)).
Qed.

(** helper: transitivity from directed_set **)
Theorem directed_set_trans : forall J le:set,
  directed_set J le ->
  forall a b c:set, a :e J -> b :e J -> c :e J ->
    (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
let J le.
assume HJ: directed_set J le.
exact (partial_order_on_trans J le (directed_set_partial_order J le HJ)).
Qed.

(** helper: directed sets are nonempty **)
Theorem directed_set_nonempty : forall J le:set, directed_set J le -> J <> Empty.
let J le. assume HJ: directed_set J le.
prove J <> Empty.
claim Hleft: J <> Empty /\ partial_order_on J le.
{ exact (andEL (J <> Empty /\ partial_order_on J le)
               (forall a b:set, a :e J -> b :e J ->
                 exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
               HJ). }
exact (andEL (J <> Empty) (partial_order_on J le) Hleft).
Qed.

(** helper: upper bound property of a directed set **)
Theorem directed_set_upper_bound_property : forall J le:set,
  directed_set J le ->
  forall i j:set, i :e J -> j :e J ->
    exists k:set, k :e J /\ (i,k) :e le /\ (j,k) :e le.
let J le. assume HJ: directed_set J le.
prove forall i j:set, i :e J -> j :e J ->
  exists k:set, k :e J /\ (i,k) :e le /\ (j,k) :e le.
let i j. assume HiJ: i :e J. assume HjJ: j :e J.
claim Hdir:
  forall a b:set, a :e J -> b :e J ->
    exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le.
{ exact (andER (J <> Empty /\ partial_order_on J le)
               (forall a b:set, a :e J -> b :e J ->
                 exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
               HJ). }
exact (Hdir i j HiJ HjJ).
Qed.

(** helper: every element in a directed set has an upper bound in the set **)
(** LATEX VERSION: In a directed set J, for each i in J there exists k in J with i <= k. **)
Theorem directed_set_upper_bound : forall J le i:set,
  directed_set J le -> i :e J -> exists k:set, k :e J /\ (i,k) :e le.
let J le i.
assume HJ: directed_set J le.
assume HiJ: i :e J.
prove exists k:set, k :e J /\ (i,k) :e le.
claim Hexk: exists k:set, k :e J /\ (i,k) :e le /\ (i,k) :e le.
{ exact (directed_set_upper_bound_property J le HJ i i HiJ HiJ). }
apply Hexk.
let k. assume Hk.
witness k.
exact (andEL (k :e J /\ (i,k) :e le) ((i,k) :e le) Hk).
Qed.

(** helper: upper bound for two elements in a directed set **)
(** LATEX VERSION: In a directed set J, for i,j in J there exists k in J with i <= k and j <= k. **)
Theorem directed_set_pair_upper_bound : forall J le i j:set,
  directed_set J le -> i :e J -> j :e J ->
  exists k:set, k :e J /\ (i,k) :e le /\ (j,k) :e le.
let J le i j.
assume HJ: directed_set J le.
assume HiJ: i :e J.
assume HjJ: j :e J.
prove exists k:set, k :e J /\ (i,k) :e le /\ (j,k) :e le.
exact (directed_set_upper_bound_property J le HJ i j HiJ HjJ).
Qed.

(** from exercises after §29: examples of directed sets **)
(** LATEX VERSION: Examples: simply ordered sets, Power(S) by inclusion, intersection-closed families by reverse inclusion, closed sets by inclusion. **)
Theorem examples_of_directed_sets : forall J le:set, directed_set J le -> directed_set J le.
let J le.
assume H: directed_set J le.
prove directed_set J le.
exact H.
Qed.

(** relation restriction to a subset **)
(** LATEX VERSION: Restrict an order relation <= on J to a subset K of J. **)
Definition rel_restrict : set -> set -> set := fun le K =>
  {p :e le | p 0 :e K /\ p 1 :e K}.

(** helper: definitional unfolding for rel_restrict **)
Theorem rel_restrict_def : forall le K:set,
  rel_restrict le K = {p :e le | p 0 :e K /\ p 1 :e K}.
let le K.
reflexivity.
Qed.

(** helper: elimination for rel_restrict **)
Theorem rel_restrictE : forall le K a b:set,
  (a,b) :e rel_restrict le K -> (a,b) :e le /\ a :e K /\ b :e K.
let le K a b.
assume HabK: (a,b) :e rel_restrict le K.
claim HabK': (a,b) :e {p :e le | p 0 :e K /\ p 1 :e K}.
{ rewrite <- (rel_restrict_def le K).
  exact HabK. }
claim Hraw: (a,b) :e le /\ ((a,b) 0 :e K /\ (a,b) 1 :e K).
{ exact (SepE le (fun p:set => p 0 :e K /\ p 1 :e K) (a,b) HabK'). }
claim Hab: (a,b) :e le.
{ exact (andEL ((a,b) :e le) (((a,b) 0 :e K /\ (a,b) 1 :e K)) Hraw). }
claim Ha0: ((a,b) 0) :e K.
{ exact (andEL (((a,b) 0 :e K)) (((a,b) 1 :e K))
              (andER ((a,b) :e le) (((a,b) 0 :e K /\ (a,b) 1 :e K)) Hraw)). }
claim Hb1: ((a,b) 1) :e K.
{ exact (andER (((a,b) 0 :e K)) (((a,b) 1 :e K))
              (andER ((a,b) :e le) (((a,b) 0 :e K /\ (a,b) 1 :e K)) Hraw)). }
apply and3I.
- exact Hab.
- rewrite <- (tuple_2_0_eq a b). exact Ha0.
- rewrite <- (tuple_2_1_eq a b). exact Hb1.
Qed.

(** helper: introduction for rel_restrict **)
Theorem rel_restrictI : forall le K a b:set,
  (a,b) :e le -> a :e K -> b :e K -> (a,b) :e rel_restrict le K.
let le K a b.
assume Hab: (a,b) :e le.
assume HaK: a :e K.
assume HbK: b :e K.
prove (a,b) :e rel_restrict le K.
rewrite (rel_restrict_def le K).
apply (SepI le (fun p:set => p 0 :e K /\ p 1 :e K) (a,b) Hab).
apply andI.
- rewrite (tuple_2_0_eq a b). exact HaK.
- rewrite (tuple_2_1_eq a b). exact HbK.
Qed.

(** from exercises after §29: cofinal subsets of directed sets are directed **)
(** LATEX VERSION: If J is directed and K is cofinal in J, then K is directed (with the restricted order). **)
Theorem cofinal_subset_directed : forall J le K:set,
  directed_set J le -> K c= J ->
  (forall a:set, a :e J -> exists b:set, b :e K /\ (a,b) :e le) ->
  directed_set K (rel_restrict le K).
let J le K.
assume HJ: directed_set J le.
assume HK: K c= J.
assume Hcofinal: forall a:set, a :e J -> exists b:set, b :e K /\ (a,b) :e le.
prove directed_set K (rel_restrict le K).
prove (K <> Empty /\ partial_order_on K (rel_restrict le K))
  /\ forall a b:set, a :e K -> b :e K ->
    exists c:set, c :e K /\ (a,c) :e rel_restrict le K /\ (b,c) :e rel_restrict le K.
apply andI.
- (** nonempty and partial order on K **)
  prove K <> Empty /\ partial_order_on K (rel_restrict le K).
  apply andI.
  + (** K nonempty via cofinality **)
    assume HK0: K = Empty.
    prove False.
    claim HJne: J <> Empty.
    { exact (directed_set_nonempty J le HJ). }
    claim Hexj: exists j0:set, j0 :e J.
    { exact (nonempty_has_element J HJne). }
    apply Hexj.
    let j0. assume Hj0: j0 :e J.
    claim Hexk: exists k0:set, k0 :e K /\ (j0,k0) :e le.
    { exact (Hcofinal j0 Hj0). }
    apply Hexk.
    let k0. assume Hk0pair.
    claim Hk0K: k0 :e K.
    { exact (andEL (k0 :e K) ((j0,k0) :e le) Hk0pair). }
    claim Hk0E: k0 :e Empty.
    { rewrite <- HK0. exact Hk0K. }
    exact (EmptyE k0 Hk0E).
  + (** partial order on K via restriction of le **)
    prove partial_order_on K (rel_restrict le K).
    (** unpack partial_order_on J le from HJ **)
    apply HJ. assume Hleft Hdir.
	    apply Hleft. assume HJne Hpo.
	    (** unfold partial_order_on K (rel_restrict le K) **)
	    prove relation_on (rel_restrict le K) K /\
	      (forall a:set, a :e K -> (a,a) :e rel_restrict le K) /\
	      (forall a b:set, a :e K -> b :e K -> (a,b) :e rel_restrict le K -> (b,a) :e rel_restrict le K -> a = b) /\
	      (forall a b c:set, a :e K -> b :e K -> c :e K ->
	        (a,b) :e rel_restrict le K -> (b,c) :e rel_restrict le K -> (a,c) :e rel_restrict le K).
	    (** pull out reflexive/antisym/trans for J **)
	    claim Hrefl: forall a:set, a :e J -> (a,a) :e le.
	    { exact (partial_order_on_refl J le Hpo). }
	    claim Hantisym: forall a b:set, a :e J -> b :e J ->
	      (a,b) :e le -> (b,a) :e le -> a = b.
	    { exact (partial_order_on_antisym J le Hpo). }
	    claim Htrans: forall a b c:set, a :e J -> b :e J -> c :e J ->
	      (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
	    { exact (partial_order_on_trans J le Hpo). }
	    apply andI.
	    - (** (relation_on /\ reflexive) /\ antisymmetric **)
	      apply andI.
	      + (** relation_on /\ reflexive **)
	        apply andI.
	        * (** relation_on on K **)
	          prove relation_on (rel_restrict le K) K.
	          prove forall a b:set, (a,b) :e rel_restrict le K -> a :e K /\ b :e K.
	          let a b.
	          assume Hab: (a,b) :e rel_restrict le K.
	          prove a :e K /\ b :e K.
	          claim Hab3: (a,b) :e le /\ a :e K /\ b :e K.
	          { exact (rel_restrictE le K a b Hab). }
	          claim Hab2: (a,b) :e le /\ a :e K.
	          { exact (andEL ((a,b) :e le /\ a :e K) (b :e K) Hab3). }
	          claim HaK: a :e K.
	          { exact (andER ((a,b) :e le) (a :e K) Hab2). }
	          claim HbK: b :e K.
	          { exact (andER ((a,b) :e le /\ a :e K) (b :e K) Hab3). }
	          apply andI.
	          - prove a :e K.
	            exact HaK.
	          - prove b :e K.
	            exact HbK.
	        * (** reflexive **)
	          let a. assume HaK: a :e K.
	          prove (a,a) :e rel_restrict le K.
	          claim HaJ: a :e J.
	          { exact (HK a HaK). }
	          claim Haa: (a,a) :e le.
	          { exact (Hrefl a HaJ). }
	          exact (rel_restrictI le K a a Haa HaK HaK).
	      + (** antisymmetric **)
	        let a b.
	        assume HaK: a :e K.
	        assume HbK: b :e K.
        assume HabK: (a,b) :e rel_restrict le K.
        assume HbaK: (b,a) :e rel_restrict le K.
        prove a = b.
        claim HaJ: a :e J.
        { exact (HK a HaK). }
        claim HbJ: b :e J.
	        { exact (HK b HbK). }
	        claim Hab: (a,b) :e le.
	        { claim Hab3: (a,b) :e le /\ a :e K /\ b :e K.
	          { exact (rel_restrictE le K a b HabK). }
	          claim Hab2: (a,b) :e le /\ a :e K.
	          { exact (andEL ((a,b) :e le /\ a :e K) (b :e K) Hab3). }
	          exact (andEL ((a,b) :e le) (a :e K) Hab2). }
	        claim Hba: (b,a) :e le.
	        { claim Hba3: (b,a) :e le /\ b :e K /\ a :e K.
	          { exact (rel_restrictE le K b a HbaK). }
	          claim Hba2: (b,a) :e le /\ b :e K.
	          { exact (andEL ((b,a) :e le /\ b :e K) (a :e K) Hba3). }
	          exact (andEL ((b,a) :e le) (b :e K) Hba2). }
	        exact (Hantisym a b HaJ HbJ Hab Hba).
	    - (** transitive **)
	      let a b c.
	      assume HaK: a :e K.
      assume HbK: b :e K.
      assume HcK: c :e K.
      assume HabK: (a,b) :e rel_restrict le K.
      assume HbcK: (b,c) :e rel_restrict le K.
      prove (a,c) :e rel_restrict le K.
      claim HaJ: a :e J.
      { exact (HK a HaK). }
	      claim HbJ: b :e J.
	      { exact (HK b HbK). }
	      claim HcJ: c :e J.
	      { exact (HK c HcK). }
	      claim Hab: (a,b) :e le.
	      { claim Hab3: (a,b) :e le /\ a :e K /\ b :e K.
	        { exact (rel_restrictE le K a b HabK). }
	        claim Hab2: (a,b) :e le /\ a :e K.
	        { exact (andEL ((a,b) :e le /\ a :e K) (b :e K) Hab3). }
	        exact (andEL ((a,b) :e le) (a :e K) Hab2). }
	      claim Hbc: (b,c) :e le.
	      { claim Hbc3: (b,c) :e le /\ b :e K /\ c :e K.
	        { exact (rel_restrictE le K b c HbcK). }
	        claim Hbc2: (b,c) :e le /\ b :e K.
	        { exact (andEL ((b,c) :e le /\ b :e K) (c :e K) Hbc3). }
	        exact (andEL ((b,c) :e le) (b :e K) Hbc2). }
		      claim Hac: (a,c) :e le.
		      { exact (Htrans a b c HaJ HbJ HcJ Hab Hbc). }
		      exact (rel_restrictI le K a c Hac HaK HcK).
- (** directedness in K **)
  let a b.
  assume HaK: a :e K.
  assume HbK: b :e K.
  prove exists c:set, c :e K /\ (a,c) :e rel_restrict le K /\ (b,c) :e rel_restrict le K.
		  (** unpack directedness and transitivity on J **)
		  apply HJ. assume Hleft Hdir.
		  apply Hleft. assume HJne Hpo.
		  claim Htrans: forall a b c:set, a :e J -> b :e J -> c :e J ->
		    (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
		  { exact (partial_order_on_trans J le Hpo). }
		  claim HaJ: a :e J.
		  { exact (HK a HaK). }
		  claim HbJ: b :e J.
		  { exact (HK b HbK). }
	  claim Hexm: exists m:set, m :e J /\ (a,m) :e le /\ (b,m) :e le.
	  { exact (Hdir a b HaJ HbJ). }
	  apply Hexm.
	  let m. assume Hm.
	  (** destruct Hm as left-associated conjunction **)
	  apply Hm. assume Hmleft Hbm.
	  apply Hmleft. assume HmJ Ham.
	  claim Hexk: exists k:set, k :e K /\ (m,k) :e le.
	  { exact (Hcofinal m HmJ). }
  apply Hexk.
  let k. assume Hkpair.
  claim HkK: k :e K.
  { exact (andEL (k :e K) ((m,k) :e le) Hkpair). }
  claim Hmk: (m,k) :e le.
  { exact (andER (k :e K) ((m,k) :e le) Hkpair). }
  claim HkJ: k :e J.
  { exact (HK k HkK). }
  claim Hak: (a,k) :e le.
  { exact (Htrans a m k HaJ HmJ HkJ Ham Hmk). }
	  claim Hbk: (b,k) :e le.
	  { exact (Htrans b m k HbJ HmJ HkJ Hbm Hmk). }
	  witness k.
	  apply andI.
	  - apply andI.
	    * exact HkK.
	    * prove (a,k) :e {p :e le | p 0 :e K /\ p 1 :e K}.
	      apply (SepI le (fun p:set => p 0 :e K /\ p 1 :e K) (a,k) Hak).
	      apply andI.
	      - rewrite (tuple_2_0_eq a k). exact HaK.
	      - rewrite (tuple_2_1_eq a k). exact HkK.
	  - prove (b,k) :e {p :e le | p 0 :e K /\ p 1 :e K}.
	    apply (SepI le (fun p:set => p 0 :e K /\ p 1 :e K) (b,k) Hbk).
	    apply andI.
	    * rewrite (tuple_2_0_eq b k). exact HbK.
	    * rewrite (tuple_2_1_eq b k). exact HkK.
Qed.

(** from exercises after §29: nets as functions from directed sets **) 
(** LATEX VERSION: A net is a function from a directed set into a space. **)
(** FIXED: net_on now requires total_function_on and functional_graph, so apply_fun behaves as the unique graph value and not just an Eps choice. **)
Definition net_on : set -> prop := fun net =>
  exists J le X:set, directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.

(** helper: a net in a specified space X **)
(** LATEX VERSION: A net in X is a function f:J→X from a directed set J. **)
Definition net_in_space : set -> set -> prop := fun X net =>
  exists J le:set, directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.

(** helper: graph comprehension yields a total function **)
(** LATEX VERSION: If g maps A into Y, then its graph is a total function A -> Y. **)
Theorem total_function_on_graph : forall A Y:set, forall g:set->set,
  (forall a:set, a :e A -> g a :e Y) ->
  total_function_on (graph A g) A Y.
let A Y g.
assume Hg: forall a:set, a :e A -> g a :e Y.
prove total_function_on (graph A g) A Y.
prove function_on (graph A g) A Y /\
  forall a:set, a :e A -> exists y:set, y :e Y /\ (a,y) :e (graph A g).
apply andI.
- (** function_on **)
  prove function_on (graph A g) A Y.
  let a. assume Ha: a :e A.
  rewrite (apply_fun_graph A g a Ha).
  exact (Hg a Ha).
- (** totality **)
  let a. assume Ha: a :e A.
  witness (g a).
  apply andI.
  + exact (Hg a Ha).
  + exact (ReplI A (fun a0:set => (a0, g a0)) a Ha).
Qed.

(** helper: a graph comprehension is a subset of the corresponding set-product **)
(** LATEX VERSION: If g(a)∈Y for all a∈A, then graph(A,g) ⊆ A×Y. **)
Theorem graph_subset_setprod : forall A Y:set, forall g:set->set,
  (forall a:set, a :e A -> g a :e Y) ->
  graph A g c= setprod A Y.
let A Y g.
assume Hg: forall a:set, a :e A -> g a :e Y.
let p. assume Hp: p :e graph A g.
prove p :e setprod A Y.
apply (ReplE_impred A (fun a0:set => (a0, g a0)) p Hp (p :e setprod A Y)).
let a. assume Ha: a :e A.
assume Heq: p = (a, g a).
rewrite Heq.
exact (tuple_2_setprod_by_pair_Sigma A Y a (g a) Ha (Hg a Ha)).
Qed.

(** helper: a graph comprehension yields an element of function_space **)
(** LATEX VERSION: If g maps A into Y, then graph(A,g) is a function A→Y, hence an element of function_space(A,Y). **)
Theorem graph_in_function_space : forall A Y:set, forall g:set->set,
  (forall a:set, a :e A -> g a :e Y) ->
  graph A g :e function_space A Y.
let A Y g.
assume Hg: forall a:set, a :e A -> g a :e Y.
claim Htot: total_function_on (graph A g) A Y.
{ exact (total_function_on_graph A Y g Hg). }
claim Hfun: function_on (graph A g) A Y.
{ exact (andEL (function_on (graph A g) A Y)
               (forall a:set, a :e A -> exists y:set, y :e Y /\ (a,y) :e graph A g)
               Htot). }
claim Hsub: graph A g c= setprod A Y.
{ exact (graph_subset_setprod A Y g Hg). }
claim Hpow: graph A g :e Power (setprod A Y).
{ exact (PowerI (setprod A Y) (graph A g) Hsub). }
exact (SepI (Power (setprod A Y)) (fun f0:set => function_on f0 A Y) (graph A g) Hpow Hfun).
Qed.

(** from exercises after §29: subnet definition placeholder **)
(** LATEX VERSION: Definition of subnet (Exercise, placeholder formalization). **)
(** FIXED: Cofinality condition is forall j:e J, exists k0:e K, forall k:e K with k0<=k, we have j<=phi(k); old version forced phi to be constant; also subnet values satisfy sub(k) = net(phi(k)) in the same codomain X. **) 
(** FIXED: subnet_of now requires total_function_on and functional_graph for net, sub, and phi, avoiding apply_fun ambiguity on these maps. **)
(** SUSPICIOUS DEFINITION: subnet_of packages shared codomain and cofinal map; relating it to net_converges may require an index-alignment lemma since net_converges hides the index set. **) 
Definition subnet_of : set -> set -> prop := fun net sub =>
  exists J leJ K leK X phi:set,
    directed_set J leJ /\ directed_set K leK /\
    total_function_on net J X /\ functional_graph net /\
    total_function_on sub K X /\ functional_graph sub /\
    total_function_on phi K J /\ functional_graph phi /\
    graph_domain_subset net J /\ graph_domain_subset sub K /\ graph_domain_subset phi K /\
    (forall i j:set, i :e K -> j :e K -> (i,j) :e leK ->
      (apply_fun phi i, apply_fun phi j) :e leJ) /\
    (forall j:set, j :e J -> exists k:set, k :e K /\ (j, apply_fun phi k) :e leJ) /\
    (forall k:set, k :e K ->
      apply_fun sub k = apply_fun net (apply_fun phi k)).

(** helper: unpack the leK predicate used for pair-index subnets **)
(** LATEX VERSION: In the product-directed order, (i,j) <= means neighborhood shrinks and index increases. **)
Theorem pair_order_pred :
  forall K le i j:set,
    (i,j) :e {q :e setprod K K | (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le} ->
    (j 0) c= (i 0) /\ ((i 1),(j 1)) :e le.
let K le i j.
assume Hij: (i,j) :e {q :e setprod K K | (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le}.
claim Hraw: ((i,j) 1) 0 c= ((i,j) 0) 0 /\ (((i,j) 0) 1, ((i,j) 1) 1) :e le.
{ exact (SepE2 (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (i,j) Hij). }
apply andI.
- (** (j 0) c= (i 0) **)
  let y. assume Hy: y :e (j 0).
  prove y :e (i 0).
  claim Hsub: ((i,j) 1) 0 c= ((i,j) 0) 0.
  { exact (andEL (((i,j) 1) 0 c= ((i,j) 0) 0) ((((i,j) 0) 1, ((i,j) 1) 1) :e le) Hraw). }
  claim Hy1: y :e (((i,j) 1) 0).
  { rewrite (tuple_2_1_eq i j). exact Hy. }
  claim Hy0: y :e (((i,j) 0) 0).
  { exact (Hsub y Hy1). }
  rewrite <- (tuple_2_0_eq i j).
  exact Hy0.
	- (** ((i 1),(j 1)) :e le **)
	  claim Hle: (((i,j) 0) 1, ((i,j) 1) 1) :e le.
	  { exact (andER (((i,j) 1) 0 c= ((i,j) 0) 0) ((((i,j) 0) 1, ((i,j) 1) 1) :e le) Hraw). }
	  claim Hi1: ((i,j) 0) 1 = (i 1).
	  { rewrite (tuple_2_0_eq i j). reflexivity. }
	  claim Hj1: ((i,j) 1) 1 = (j 1).
	  { rewrite (tuple_2_1_eq i j). reflexivity. }
	  rewrite <- Hi1.
	  rewrite <- Hj1.
	  exact Hle.
Qed.

(** helper: a subnet is a net **)
(** LATEX VERSION: Any subnet is itself a net on some directed set. **)
Theorem subnet_implies_net_on : forall net sub:set, subnet_of net sub -> net_on sub.
let net sub.
assume Hsub: subnet_of net sub.
prove net_on sub.
apply Hsub.
let J.
assume Hex1.
apply Hex1.
let leJ.
assume Hex2.
apply Hex2.
let K.
assume Hex3.
apply Hex3.
let leK.
assume Hex4.
apply Hex4.
let X.
assume Hex5.
apply Hex5.
let phi.
assume Hall.
prove exists J0 le0 X0:set,
  directed_set J0 le0 /\ total_function_on sub J0 X0 /\ functional_graph sub /\ graph_domain_subset sub J0.
witness K.
witness leK.
witness X.
prove directed_set K leK /\ total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K.
(** unpack the conjunction chain in subnet_of (left-associative) **)
apply Hall. assume H13 Hvals.
apply H13. assume H12 Hcofinal.
apply H12. assume H11 Hmono.
apply H11. assume H10 Hdomphi.
apply H10. assume H9 Hdomsub.
apply H9. assume H8 Hdomnet.
apply H8. assume H7 Hgraphphi.
apply H7. assume H6 Htotphi.
apply H6. assume H5 Hgraphsub.
apply H5. assume H4 Htotsub.
apply H4. assume H3 Hgraphnet.
apply H3. assume H2 Htotnet.
apply H2. assume HdirJ HdirK.
apply and4I.
- exact HdirK.
- exact Htotsub.
- exact Hgraphsub.
- exact Hdomsub.
Qed.

(** helper: if sub is a subnet, net is a net **)
(** LATEX VERSION: The original function in a subnet pair is also a net. **)
Theorem subnet_implies_net_on_source : forall net sub:set, subnet_of net sub -> net_on net.
let net sub.
assume Hsub: subnet_of net sub.
prove net_on net.
apply Hsub.
let J.
assume Hex1.
apply Hex1.
let leJ.
assume Hex2.
apply Hex2.
let K.
assume Hex3.
apply Hex3.
let leK.
assume Hex4.
apply Hex4.
let X.
assume Hex5.
apply Hex5.
let phi.
assume Hall.
prove exists J0 le0 X0:set,
  directed_set J0 le0 /\ total_function_on net J0 X0 /\ functional_graph net /\ graph_domain_subset net J0.
witness J.
witness leJ.
witness X.
prove directed_set J leJ /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.
(** unpack the conjunction chain in subnet_of (left-associative) **)
apply Hall. assume H13 Hvals.
apply H13. assume H12 Hcofinal.
apply H12. assume H11 Hmono.
apply H11. assume H10 Hdomphi.
apply H10. assume H9 Hdomsub.
apply H9. assume H8 Hdomnet.
apply H8. assume H7 Hgraphphi.
apply H7. assume H6 Htotphi.
apply H6. assume H5 Hgraphsub.
apply H5. assume H4 Htotsub.
apply H4. assume H3 Hgraphnet.
apply H3. assume H2 Htotnet.
apply H2. assume HdirJ HdirK.
apply and4I.
- exact HdirJ.
- exact Htotnet.
- exact Hgraphnet.
- exact Hdomnet.
Qed.

(** helper: conjunction introduction up to 14 **)
Section PropN2.
Variable P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 P11 P12 P13 P14:prop.

Theorem and8I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7.
  apply and7I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
- exact H8.
Qed.

Theorem and9I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8.
  apply and8I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
- exact H9.
Qed.

Theorem and10I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 -> P10 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9. assume H10:P10.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9.
  apply and9I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
  - exact H9.
- exact H10.
Qed.

Theorem and11I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 -> P10 -> P11 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9. assume H10:P10. assume H11:P11.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10.
  apply and10I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
  - exact H9.
  - exact H10.
- exact H11.
Qed.

Theorem and12I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 -> P10 -> P11 -> P12 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11 /\ P12.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9. assume H10:P10. assume H11:P11. assume H12:P12.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11.
  apply and11I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
  - exact H9.
  - exact H10.
  - exact H11.
- exact H12.
Qed.

Theorem and13I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 -> P10 -> P11 -> P12 -> P13 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11 /\ P12 /\ P13.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9. assume H10:P10. assume H11:P11. assume H12:P12. assume H13:P13.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11 /\ P12.
  apply and12I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
  - exact H9.
  - exact H10.
  - exact H11.
  - exact H12.
- exact H13.
Qed.

Theorem and14I : P1 -> P2 -> P3 -> P4 -> P5 -> P6 -> P7 -> P8 -> P9 -> P10 -> P11 -> P12 -> P13 -> P14 ->
  P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11 /\ P12 /\ P13 /\ P14.
assume H1:P1. assume H2:P2. assume H3:P3. assume H4:P4.
assume H5:P5. assume H6:P6. assume H7:P7. assume H8:P8. assume H9:P9. assume H10:P10. assume H11:P11. assume H12:P12. assume H13:P13. assume H14:P14.
apply andI.
- prove P1 /\ P2 /\ P3 /\ P4 /\ P5 /\ P6 /\ P7 /\ P8 /\ P9 /\ P10 /\ P11 /\ P12 /\ P13.
  apply and13I.
  - exact H1.
  - exact H2.
  - exact H3.
  - exact H4.
  - exact H5.
  - exact H6.
  - exact H7.
  - exact H8.
  - exact H9.
  - exact H10.
  - exact H11.
  - exact H12.
  - exact H13.
- exact H14.
Qed.

End PropN2.

(** helper: a net is a subnet of itself **)
(** LATEX VERSION: Every net is a subnet of itself via the identity index map. **)
Theorem subnet_of_refl_witnessed : forall J le X net:set,
  directed_set J le ->
  total_function_on net J X -> functional_graph net -> graph_domain_subset net J ->
  subnet_of net net.
let J le X net.
assume HdirJ: directed_set J le.
assume Hnettot: total_function_on net J X.
assume Hnetgraph: functional_graph net.
assume Hnetdom: graph_domain_subset net J.
prove subnet_of net net.
prove exists J0 leJ0 K0 leK0 X0 phi0:set,
  directed_set J0 leJ0 /\ directed_set K0 leK0 /\
  total_function_on net J0 X0 /\ functional_graph net /\
  total_function_on net K0 X0 /\ functional_graph net /\
  total_function_on phi0 K0 J0 /\ functional_graph phi0 /\
  graph_domain_subset net J0 /\ graph_domain_subset net K0 /\ graph_domain_subset phi0 K0 /\
  (forall i j:set, i :e K0 -> j :e K0 -> (i,j) :e leK0 ->
    (apply_fun phi0 i, apply_fun phi0 j) :e leJ0) /\
  (forall j:set, j :e J0 -> exists k:set, k :e K0 /\ (j, apply_fun phi0 k) :e leJ0) /\
  (forall k:set, k :e K0 -> apply_fun net k = apply_fun net (apply_fun phi0 k)).
witness J.
witness le.
witness J.
witness le.
witness X.
witness {(y,y) | y :e J}.
prove directed_set J le /\ directed_set J le /\
  total_function_on net J X /\ functional_graph net /\
  total_function_on net J X /\ functional_graph net /\
  total_function_on {(y,y) | y :e J} J J /\ functional_graph {(y,y) | y :e J} /\
  graph_domain_subset net J /\ graph_domain_subset net J /\ graph_domain_subset {(y,y) | y :e J} J /\
  (forall i j:set, i :e J -> j :e J -> (i,j) :e le ->
    (apply_fun {(y,y) | y :e J} i, apply_fun {(y,y) | y :e J} j) :e le) /\
  (forall j:set, j :e J -> exists k:set, k :e J /\ (j, apply_fun {(y,y) | y :e J} k) :e le) /\
  (forall k:set, k :e J ->
	  apply_fun net k = apply_fun net (apply_fun {(y,y) | y :e J} k)).
	(** reflexivity on J from directedness **)
	claim Hrefl: forall j:set, j :e J -> (j,j) :e le.
	{ exact (directed_set_refl J le HdirJ). }
	claim Hmono_id: forall i j:set, i :e J -> j :e J -> (i,j) :e le ->
	  (apply_fun {(y,y) | y :e J} i, apply_fun {(y,y) | y :e J} j) :e le.
	{ let i j.
	  assume HiJ: i :e J.
  assume HjJ: j :e J.
  assume Hij: (i,j) :e le.
  rewrite (identity_function_apply J i HiJ).
  rewrite (identity_function_apply J j HjJ).
  exact Hij. }
claim Hcofinal_id: forall j:set, j :e J -> exists k:set, k :e J /\ (j, apply_fun {(y,y) | y :e J} k) :e le.
{ let j.
  assume HjJ: j :e J.
  witness j.
  apply andI.
  - exact HjJ.
  - rewrite (identity_function_apply J j HjJ).
    exact (Hrefl j HjJ). }
claim Hvals_id: forall k:set, k :e J -> apply_fun net k = apply_fun net (apply_fun {(y,y) | y :e J} k).
{ let k.
  assume HkJ: k :e J.
  rewrite (identity_function_apply J k HkJ).
  reflexivity. }
apply and14I.
- exact HdirJ.
- exact HdirJ.
- exact Hnettot.
- exact Hnetgraph.
- exact Hnettot.
- exact Hnetgraph.
- exact (identity_total_function_on J).
- exact (functional_graph_graph J (fun y:set => y)).
- exact Hnetdom.
- exact Hnetdom.
- exact (graph_domain_subset_graph J (fun y:set => y)).
- exact Hmono_id.
- exact Hcofinal_id.
- exact Hvals_id.
Qed.

(** helper: if net_on net then subnet_of net net **)
(** LATEX VERSION: Every net admits the trivial subnet given by itself. **)
Theorem subnet_of_refl : forall net:set, net_on net -> subnet_of net net.
let net. assume Hnet: net_on net.
prove subnet_of net net.
claim Hex: exists J le X:set,
  directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.
{ exact Hnet. }
apply Hex.
let J.
assume Hex1.
apply Hex1.
let le.
assume Hex2.
apply Hex2.
let X.
assume Hall.
(** unpack the 4-way conjunction in net_on (left-associative) **)
apply Hall. assume Hleft Hdom.
apply Hleft. assume Hleft2 Hgraph.
apply Hleft2. assume Hdir Htot.
exact (subnet_of_refl_witnessed J le X net Hdir Htot Hgraph Hdom).
Qed.

(** from exercises after §29: accumulation point of a net **)
(** LATEX VERSION: An accumulation point of a net means every neighborhood contains infinitely many (or cofinal) net points; placeholder formalization. **)
(** FIXED: accumulation_point_of_net now includes Tx, quantifies only over U:e Tx with x:e U, and uses cofinality forall j0:e J, exists j>=j0 with net(j):e U; net is total_function_on into X with functional_graph. **) 
Definition accumulation_point_of_net : set -> set -> set -> set -> prop := fun X Tx net x =>
  exists J le:set, topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.

(** from exercises after §29: net convergence **)
(** LATEX VERSION: A net converges to x if eventually in every neighborhood U of x. **)
(** FIXED: net_converges uses eventuality: forall U:e Tx with x:e U, exists i0:e J such that forall i:e J with i0<=i (i0 :e i \/ i0 = i), we have net(i):e U; net is total_function_on with functional_graph. **) 
Definition net_converges : set -> set -> set -> set -> prop := fun X Tx net x =>
  exists J le:set, topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.

(** helper: explicit-index version of net convergence **)
(** LATEX VERSION: A net f:J→X converges to x if for each neighborhood U of x there exists i0∈J such that for all i≥i0, f(i)∈U. **)
Definition net_converges_on : set -> set -> set -> set -> set -> set -> prop := fun X Tx net J le x =>
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.

(** helper: convergence-on implies convergence (existential index) **)
Theorem net_converges_on_implies_net_converges : forall X Tx net J le x:set,
  net_converges_on X Tx net J le x -> net_converges X Tx net x.
let X Tx net J le x.
assume H: net_converges_on X Tx net J le x.
prove net_converges X Tx net x.
prove exists J0 le0:set,
  topology_on X Tx /\ directed_set J0 le0 /\ total_function_on net J0 X /\ functional_graph net /\ graph_domain_subset net J0 /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J0 /\
        forall i:set, i :e J0 -> (i0,i) :e le0 -> apply_fun net i :e U.
witness J.
witness le.
exact H.
Qed.

(** helper: convergent net has an explicit index witness **)
Theorem net_converges_implies_exists_net_converges_on : forall X Tx net x:set,
  net_converges X Tx net x -> exists J le:set, net_converges_on X Tx net J le x.
let X Tx net x.
assume H: net_converges X Tx net x.
exact H.
Qed.

(** helper: convergent nets have accumulation points at the limit **)
(** LATEX VERSION: If a net converges to x, then x is an accumulation point of the net. **)
Theorem net_converges_implies_accumulation_point : forall X Tx net x:set,
  net_converges X Tx net x -> accumulation_point_of_net X Tx net x.
let X Tx net x.
assume Hconv: net_converges X Tx net x.
prove accumulation_point_of_net X Tx net x.
apply Hconv.
let J.
assume HJ: exists le:set,
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
apply HJ.
let le.
assume Hdata:
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
prove accumulation_point_of_net X Tx net x.
prove exists J0 le0:set,
  topology_on X Tx /\ directed_set J0 le0 /\ total_function_on net J0 X /\ functional_graph net /\ graph_domain_subset net J0 /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      forall j0:set, j0 :e J0 ->
        exists j:set, j :e J0 /\ (j0,j) :e le0 /\ apply_fun net j :e U.
witness J.
witness le.
(** unpack the convergence data **)
apply Hdata.
assume Hcore Hevent.
apply Hcore.
assume Hcore5 HxX.
apply Hcore5.
assume Hcore4 Hdom.
apply Hcore4.
assume Hcore3 Hgraph.
apply Hcore3.
assume Hcore2 Htot.
apply Hcore2.
assume HTx HdirJ.
(** build the accumulation_point_of_net conjunction **)
apply andI.
- prove topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X.
  apply and6I.
  + exact HTx.
  + exact HdirJ.
  + exact Htot.
  + exact Hgraph.
  + exact Hdom.
  + exact HxX.
- (** neighborhood condition **)
  let U.
  assume HU: U :e Tx.
  assume HxU: x :e U.
  let j0.
  assume Hj0J: j0 :e J.
  prove exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
  claim Hexi0: exists i0:set, i0 :e J /\
    forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
  { exact (Hevent U HU HxU). }
  apply Hexi0.
  let i0.
  assume Hi0pair.
  apply Hi0pair.
  assume Hi0J Hafter.
  claim Hexk: exists k:set, k :e J /\ (j0,k) :e le /\ (i0,k) :e le.
  { exact (directed_set_upper_bound_property J le HdirJ j0 i0 Hj0J Hi0J). }
  apply Hexk.
  let k.
  assume Hk.
  apply Hk.
  assume Hkleft Hik.
  apply Hkleft.
	  assume HkJ Hjk.
	  witness k.
	  apply and3I.
	  - exact HkJ.
	  - exact Hjk.
	  - exact (Hafter k HkJ Hik).
Qed.

(** helper: any convergent net is a net_on **)
(** LATEX VERSION: If a net converges, then it is a net (it has some directed index set). **)
Theorem net_converges_implies_net_on : forall X Tx net x:set,
  net_converges X Tx net x -> net_on net.
let X Tx net x.
assume H: net_converges X Tx net x.
prove net_on net.
apply H.
let J. assume HJ: exists le:set,
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
apply HJ.
let le. assume Hdata:
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
prove net_on net.
prove exists J0 le0 X0:set, directed_set J0 le0 /\ total_function_on net J0 X0 /\ functional_graph net /\ graph_domain_subset net J0.
witness J.
witness le.
witness X.
claim Hcore: topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X.
{ exact (andEL (topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X)
               (forall U:set, U :e Tx -> x :e U ->
                 exists i0:set, i0 :e J /\
                   forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U)
               Hdata). }
claim Hcore5: topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.
{ exact (andEL (topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J)
               (x :e X)
               Hcore). }
claim Hcore4: topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net.
{ exact (andEL (topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net)
               (graph_domain_subset net J)
               Hcore5). }
claim Hdir: directed_set J le.
{ exact (andER (topology_on X Tx) (directed_set J le)
               (andEL (topology_on X Tx /\ directed_set J le) (total_function_on net J X)
                      (andEL (topology_on X Tx /\ directed_set J le /\ total_function_on net J X) (functional_graph net) Hcore4))). }
claim Htot: total_function_on net J X.
{ exact (andER (topology_on X Tx /\ directed_set J le) (total_function_on net J X)
               (andEL (topology_on X Tx /\ directed_set J le /\ total_function_on net J X) (functional_graph net) Hcore4)). }
claim Hgraph: functional_graph net.
{ exact (andER (topology_on X Tx /\ directed_set J le /\ total_function_on net J X) (functional_graph net) Hcore4). }
claim Hdom: graph_domain_subset net J.
{ exact (andER (topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net) (graph_domain_subset net J) Hcore5). }
apply and4I.
- exact Hdir.
- exact Htot.
- exact Hgraph.
- exact Hdom.
Qed.

(** helper: packaged subnet witness with explicit index sets **)
(** LATEX VERSION: Data of a subnet given by a cofinal order-preserving map phi:K→J. **)
Definition subnet_of_witness : set -> set -> set -> set -> set -> set -> set -> set -> prop :=
  fun net sub J leJ K leK X phi =>
    directed_set J leJ /\ directed_set K leK /\
    total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\
    total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K /\
    total_function_on phi K J /\ functional_graph phi /\ graph_domain_subset phi K /\
    (forall i j:set, i :e K -> j :e K -> (i,j) :e leK ->
      (apply_fun phi i, apply_fun phi j) :e leJ) /\
    (forall j:set, j :e J -> exists k:set, k :e K /\ (j, apply_fun phi k) :e leJ) /\
    (forall k:set, k :e K ->
      apply_fun sub k = apply_fun net (apply_fun phi k)).

(** helper: subnet preserves convergence for fixed index set witnesses **)
(** LATEX VERSION: If net converges along J and sub is obtained by a cofinal map phi:K→J, then sub converges. **)
Theorem subnet_preserves_convergence_witnessed :
  forall X Tx net sub x J leJ K leK phi:set,
    topology_on X Tx ->
    directed_set J leJ ->
    directed_set K leK ->
    total_function_on net J X ->
    functional_graph net ->
    graph_domain_subset net J ->
    total_function_on sub K X ->
    functional_graph sub ->
    graph_domain_subset sub K ->
    total_function_on phi K J ->
    functional_graph phi ->
    graph_domain_subset phi K ->
    (forall i j:set, i :e K -> j :e K -> (i,j) :e leK ->
      (apply_fun phi i, apply_fun phi j) :e leJ) ->
    (forall j:set, j :e J -> exists k:set, k :e K /\ (j, apply_fun phi k) :e leJ) ->
    (forall k:set, k :e K ->
      apply_fun sub k = apply_fun net (apply_fun phi k)) ->
    x :e X ->
    (forall U:set, U :e Tx -> x :e U ->
      exists j0:set, j0 :e J /\
        forall j:set, j :e J -> (j0,j) :e leJ ->
          apply_fun net j :e U) ->
    net_converges X Tx sub x.
let X Tx net sub x J leJ K leK phi.
assume HTx: topology_on X Tx.
assume HdirJ: directed_set J leJ.
assume HdirK: directed_set K leK.
assume Hnettot: total_function_on net J X.
assume Hnetgraph: functional_graph net.
assume Hnetdom: graph_domain_subset net J.
assume Hsubtot: total_function_on sub K X.
assume Hsubgraph: functional_graph sub.
assume Hsubdom: graph_domain_subset sub K.
assume Hphitot: total_function_on phi K J.
assume Hphigraph: functional_graph phi.
assume Hphidom: graph_domain_subset phi K.
assume Hmono:
  forall i j:set, i :e K -> j :e K -> (i,j) :e leK ->
    (apply_fun phi i, apply_fun phi j) :e leJ.
assume Hcofinal: forall j:set, j :e J -> exists k:set, k :e K /\ (j, apply_fun phi k) :e leJ.
assume Hsubeq:
  forall k:set, k :e K -> apply_fun sub k = apply_fun net (apply_fun phi k).
assume HxX: x :e X.
assume Htail:
  forall U:set, U :e Tx -> x :e U ->
    exists j0:set, j0 :e J /\
      forall j:set, j :e J -> (j0,j) :e leJ ->
        apply_fun net j :e U.
prove net_converges X Tx sub x.
prove exists J0 le0:set, topology_on X Tx /\ directed_set J0 le0 /\ total_function_on sub J0 X /\ functional_graph sub /\ graph_domain_subset sub J0 /\ x :e X /\
  forall U:set, U :e Tx -> x :e U ->
    exists i0:set, i0 :e J0 /\
      forall i:set, i :e J0 -> (i0,i) :e le0 -> apply_fun sub i :e U.
witness K.
witness leK.
(** build the left-associated conjunction for net_converges **)
apply andI.
- prove topology_on X Tx /\ directed_set K leK /\ total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K /\ x :e X.
  apply and6I.
  + exact HTx.
  + exact HdirK.
  + exact Hsubtot.
  + exact Hsubgraph.
  + exact Hsubdom.
  + exact HxX.
- (** neighborhood eventuality for sub **)
  let U.
  assume HU: U :e Tx.
  assume HxU: x :e U.
  claim Hexj0: exists j0:set, j0 :e J /\
    forall j:set, j :e J -> (j0,j) :e leJ -> apply_fun net j :e U.
  { exact (Htail U HU HxU). }
  apply Hexj0.
  let j0.
  assume Hj0pair.
  apply Hj0pair.
  assume Hj0J HafterJ.
  claim Hexk0: exists k0:set, k0 :e K /\ (j0, apply_fun phi k0) :e leJ.
  { exact (Hcofinal j0 Hj0J). }
  apply Hexk0.
  let k0.
  assume Hk0pair.
  apply Hk0pair.
  assume Hk0K Hj0phi0.
  witness k0.
  apply andI.
  - exact Hk0K.
  - let k.
    assume HkK: k :e K.
    assume Hk0k: (k0,k) :e leK.
    prove apply_fun sub k :e U.
    claim Hphi0J: apply_fun phi k0 :e J.
    { exact (total_function_on_apply_fun_in_Y phi K J k0 Hphitot Hk0K). }
    claim HphikJ: apply_fun phi k :e J.
    { exact (total_function_on_apply_fun_in_Y phi K J k Hphitot HkK). }
    claim Hphimon: (apply_fun phi k0, apply_fun phi k) :e leJ.
    { exact (Hmono k0 k Hk0K HkK Hk0k). }
    claim Hj0phik: (j0, apply_fun phi k) :e leJ.
    { exact (directed_set_trans J leJ HdirJ j0 (apply_fun phi k0) (apply_fun phi k) Hj0J Hphi0J HphikJ Hj0phi0 Hphimon). }
    rewrite (Hsubeq k HkK).
    exact (HafterJ (apply_fun phi k) HphikJ Hj0phik).
Qed.

(** from exercises after §29: convergence of subnets **) 
(** LATEX VERSION: If a net converges, then every subnet converges to the same limit. **)
(** NOTE: In this development the directed data is explicit: use the witnessed subnet relation and convergence-on predicate. **)
Theorem subnet_preserves_convergence :
  forall X Tx net sub x J leJ K leK phi:set,
    subnet_of_witness net sub J leJ K leK X phi ->
    net_converges_on X Tx net J leJ x ->
    net_converges_on X Tx sub K leK x.
let X Tx net sub x J leJ K leK phi.
assume Hw: subnet_of_witness net sub J leJ K leK X phi.
assume Hconv: net_converges_on X Tx net J leJ x.
prove net_converges_on X Tx sub K leK x.

(** unpack Hconv (left-associated conjunction) **)
apply Hconv. assume Hcore Htail.
apply Hcore. assume Hcore5 HxX.
apply Hcore5. assume Hcore4 Hdomnet.
apply Hcore4. assume Hcore3 Hgraphnet.
apply Hcore3. assume Hcore2 Htotnet.
apply Hcore2. assume HTx HdirJ.

(** unpack Hw only for subnet-specific data **)
apply Hw. assume Hwcore Hvals.
apply Hwcore. assume Hwcore2 Hcofinal.
apply Hwcore2. assume Hwcore3 Hmono.
apply Hwcore3. assume Hwcore4 Hdomphi.
apply Hwcore4. assume Hwcore5 Hgraphphi.
apply Hwcore5. assume Hwcore6 Htotphi.
apply Hwcore6. assume Hwcore7 Hdomsub.
apply Hwcore7. assume Hwcore8 Hgraphsub.
apply Hwcore8. assume Hwcore9 Htotsub.
apply Hwcore9. assume Hwcore10 Hdomnet2.
apply Hwcore10. assume Hwcore11 Hgraphnet2.
apply Hwcore11. assume Hwcore12 Htotnet2.
apply Hwcore12. assume HdirJ2 HdirK.

prove topology_on X Tx /\ directed_set K leK /\ total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K /\ x :e X /\
  forall U:set, U :e Tx -> x :e U ->
    exists i0:set, i0 :e K /\
      forall i:set, i :e K -> (i0,i) :e leK -> apply_fun sub i :e U.
apply andI.
- (** core data **)
  prove topology_on X Tx /\ directed_set K leK /\ total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K /\ x :e X.
  apply and6I.
  + exact HTx.
  + exact HdirK.
  + exact Htotsub.
  + exact Hgraphsub.
  + exact Hdomsub.
  + exact HxX.
- (** eventuality for sub along leK **)
  let U.
  assume HU: U :e Tx.
  assume HxU: x :e U.
  claim Hexj0: exists j0:set, j0 :e J /\
    forall j:set, j :e J -> (j0,j) :e leJ -> apply_fun net j :e U.
  { exact (Htail U HU HxU). }
  apply Hexj0.
  let j0.
  assume Hj0pair.
  apply Hj0pair.
  assume Hj0J HafterJ.
  claim Hexk0: exists k0:set, k0 :e K /\ (j0, apply_fun phi k0) :e leJ.
  { exact (Hcofinal j0 Hj0J). }
  apply Hexk0.
  let k0.
  assume Hk0pair.
  apply Hk0pair.
  assume Hk0K Hj0phi0.
  witness k0.
  apply andI.
  + exact Hk0K.
  + let k.
    assume HkK: k :e K.
    assume Hk0k: (k0,k) :e leK.
    prove apply_fun sub k :e U.
    claim Hphi0J: apply_fun phi k0 :e J.
    { exact (total_function_on_apply_fun_in_Y phi K J k0 Htotphi Hk0K). }
	    claim HphikJ: apply_fun phi k :e J.
	    { exact (total_function_on_apply_fun_in_Y phi K J k Htotphi HkK). }
	    claim Hphimon: (apply_fun phi k0, apply_fun phi k) :e leJ.
	    { exact (Hmono k0 k Hk0K HkK Hk0k). }
	    claim Hj0phik: (j0, apply_fun phi k) :e leJ.
	    { exact (directed_set_trans J leJ HdirJ j0 (apply_fun phi k0) (apply_fun phi k) Hj0J Hphi0J HphikJ Hj0phi0 Hphimon). }
	    rewrite (Hvals k HkK).
	    exact (HafterJ (apply_fun phi k) HphikJ Hj0phik).
Qed.

(** from exercises after §29: closure via nets **) 
(** LATEX VERSION: Theorem. Let A ⊂ X. Then x ∈ \bar{A} iff there is a net of points of A converging to x. **)
Definition net_points_in : set -> set -> set -> prop := fun A net J =>
  forall j:set, j :e J -> apply_fun net j :e A.

(** helper: reverse-inclusion relation on a family of sets **)
Definition rev_inclusion_rel : set -> set := fun J =>
  {p :e setprod J J | p 1 c= p 0}.

Theorem rev_inclusion_rel_def : forall J:set,
  rev_inclusion_rel J = {p :e setprod J J | p 1 c= p 0}.
let J.
reflexivity.
Qed.

Theorem rev_inclusion_relE : forall J a b:set,
  (a,b) :e rev_inclusion_rel J -> (a,b) :e setprod J J /\ b c= a.
let J a b.
assume Hab: (a,b) :e rev_inclusion_rel J.
claim Hab': (a,b) :e {p :e setprod J J | p 1 c= p 0}.
{ rewrite <- (rev_inclusion_rel_def J).
  exact Hab. }
claim Hprod: (a,b) :e setprod J J.
{ exact (SepE1 (setprod J J) (fun p:set => p 1 c= p 0) (a,b) Hab'). }
claim Hsub: (a,b) 1 c= (a,b) 0.
{ exact (SepE2 (setprod J J) (fun p:set => p 1 c= p 0) (a,b) Hab'). }
apply andI.
- exact Hprod.
- prove b c= a.
  let y. assume Hy: y :e b.
  prove y :e a.
  claim Hy1: y :e (a,b) 1.
  { rewrite (tuple_2_1_eq a b). exact Hy. }
  claim Hy0: y :e (a,b) 0.
  { exact (Hsub y Hy1). }
  rewrite <- (tuple_2_0_eq a b).
  exact Hy0.
Qed.

Theorem rev_inclusion_relI : forall J a b:set,
  (a,b) :e setprod J J -> b c= a -> (a,b) :e rev_inclusion_rel J.
let J a b.
assume Hprod: (a,b) :e setprod J J.
assume Hsub: b c= a.
prove (a,b) :e rev_inclusion_rel J.
rewrite (rev_inclusion_rel_def J).
apply (SepI (setprod J J) (fun p:set => p 1 c= p 0) (a,b) Hprod).
prove (a,b) 1 c= (a,b) 0.
let y. assume Hy: y :e (a,b) 1.
prove y :e (a,b) 0.
claim Hyb: y :e b.
{ rewrite <- (tuple_2_1_eq a b). exact Hy. }
claim Hya: y :e a.
{ exact (Hsub y Hyb). }
rewrite (tuple_2_0_eq a b).
exact Hya.
Qed.

(** helper: inclusion relation on a family of sets **)
Definition inclusion_rel : set -> set := fun J =>
  {p :e setprod J J | (p 0) c= (p 1)}.

Theorem inclusion_rel_def : forall J:set,
  inclusion_rel J = {p :e setprod J J | (p 0) c= (p 1)}.
let J.
reflexivity.
Qed.

Theorem inclusion_relE : forall J a b:set,
  (a,b) :e inclusion_rel J -> (a,b) :e setprod J J /\ a c= b.
let J a b.
assume Hab: (a,b) :e inclusion_rel J.
claim Hab': (a,b) :e {p :e setprod J J | (p 0) c= (p 1)}.
{ rewrite <- (inclusion_rel_def J).
  exact Hab. }
claim Hprod: (a,b) :e setprod J J.
{ exact (SepE1 (setprod J J) (fun p:set => (p 0) c= (p 1)) (a,b) Hab'). }
claim Hsub: (a,b) 0 c= (a,b) 1.
{ exact (SepE2 (setprod J J) (fun p:set => (p 0) c= (p 1)) (a,b) Hab'). }
apply andI.
- exact Hprod.
- prove a c= b.
  let y. assume Hy: y :e a.
  prove y :e b.
  claim Hy0: y :e (a,b) 0.
  { rewrite (tuple_2_0_eq a b). exact Hy. }
  claim Hy1: y :e (a,b) 1.
  { exact (Hsub y Hy0). }
  rewrite <- (tuple_2_1_eq a b).
  exact Hy1.
Qed.

Theorem inclusion_relI : forall J a b:set,
  (a,b) :e setprod J J -> a c= b -> (a,b) :e inclusion_rel J.
let J a b.
assume Hprod: (a,b) :e setprod J J.
assume Hsub: a c= b.
prove (a,b) :e inclusion_rel J.
rewrite (inclusion_rel_def J).
apply (SepI (setprod J J) (fun p:set => (p 0) c= (p 1)) (a,b) Hprod).
prove (a,b) 0 c= (a,b) 1.
let y. assume Hy: y :e (a,b) 0.
prove y :e (a,b) 1.
claim Hya: y :e a.
{ rewrite <- (tuple_2_0_eq a b). exact Hy. }
claim Hyb: y :e b.
{ exact (Hsub y Hya). }
rewrite (tuple_2_1_eq a b).
exact Hyb.
Qed.

(** helper: neighborhoods at a point form a directed set (reverse inclusion) **)
(** LATEX VERSION: The collection {U∈Tx | x∈U} is directed under reverse inclusion; an upper bound for U,V is U∩V. **)
Theorem neighborhoods_directed_by_reverse_inclusion : forall X Tx x:set,
  topology_on X Tx -> x :e X ->
  directed_set {U :e Tx | x :e U} (rev_inclusion_rel {U :e Tx | x :e U}).
let X Tx x.
assume HTx: topology_on X Tx.
assume HxX: x :e X.
set J := {U :e Tx | x :e U}.
set le := rev_inclusion_rel J.
prove directed_set J le.
prove (J <> Empty /\ partial_order_on J le) /\
  forall a b:set, a :e J -> b :e J -> exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le.
apply andI.
- (** J <> Empty /\ partial_order_on J le **)
  apply andI.
  + (** J <> Empty **)
    claim HXTx: X :e Tx.
    { exact (topology_has_X X Tx HTx). }
    claim HXJ: X :e J.
    { exact (SepI Tx (fun U0:set => x :e U0) X HXTx HxX). }
    exact (elem_implies_nonempty J X HXJ).
  + (** partial_order_on J le **)
    prove partial_order_on J le.
    prove relation_on le J /\
      (forall a:set, a :e J -> (a,a) :e le) /\
      (forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b) /\
      (forall a b c:set, a :e J -> b :e J -> c :e J -> (a,b) :e le -> (b,c) :e le -> (a,c) :e le).
    apply andI.
    - (** (relation_on /\ refl) /\ antisym **)
      apply andI.
      + (** relation_on /\ refl **)
        apply andI.
	        - (** relation_on le J **)
	          prove relation_on le J.
	          let a b. assume Hab: (a,b) :e le.
	          prove a :e J /\ b :e J.
	          claim Hprod: (a,b) :e setprod J J.
	          { exact (andEL ((a,b) :e setprod J J) (b c= a) (rev_inclusion_relE J a b Hab)). }
	          claim Ha0: (a,b) 0 :e J.
	          { exact (ap0_Sigma J (fun _ : set => J) (a,b) Hprod). }
	          claim Hb1: (a,b) 1 :e J.
	          { exact (ap1_Sigma J (fun _ : set => J) (a,b) Hprod). }
          apply andI.
          + rewrite <- (tuple_2_0_eq a b). exact Ha0.
          + rewrite <- (tuple_2_1_eq a b). exact Hb1.
	        - (** reflexive **)
	          let a. assume HaJ: a :e J.
	          prove (a,a) :e le.
	          apply (rev_inclusion_relI J a a).
	          + exact (tuple_2_setprod_by_pair_Sigma J J a a HaJ HaJ).
	          + exact (Subq_ref a).
      + (** antisymmetric **)
        let a b.
        assume HaJ: a :e J.
        assume HbJ: b :e J.
	        assume Hab: (a,b) :e le.
	        assume Hba: (b,a) :e le.
	        prove a = b.
	        claim Hab_sub: b c= a.
	        { exact (andER ((a,b) :e setprod J J) (b c= a) (rev_inclusion_relE J a b Hab)). }
	        claim Hba_sub: a c= b.
	        { exact (andER ((b,a) :e setprod J J) (a c= b) (rev_inclusion_relE J b a Hba)). }
	        apply set_ext.
	        - let y. assume Hy: y :e a.
	          prove y :e b.
	          exact (Hba_sub y Hy).
	        - let y. assume Hy: y :e b.
	          prove y :e a.
	          exact (Hab_sub y Hy).
    - (** transitive **)
      let a b c.
      assume HaJ: a :e J.
      assume HbJ: b :e J.
      assume HcJ: c :e J.
	      assume Hab: (a,b) :e le.
	      assume Hbc: (b,c) :e le.
	      prove (a,c) :e le.
	      claim Hab_sub: b c= a.
	      { exact (andER ((a,b) :e setprod J J) (b c= a) (rev_inclusion_relE J a b Hab)). }
	      claim Hbc_sub: c c= b.
	      { exact (andER ((b,c) :e setprod J J) (c c= b) (rev_inclusion_relE J b c Hbc)). }
	      claim Hca: c c= a.
	      { exact (Subq_tra c b a Hbc_sub Hab_sub). }
	      apply (rev_inclusion_relI J a c).
	      + exact (tuple_2_setprod_by_pair_Sigma J J a c HaJ HcJ).
	      + exact Hca.
- (** upper bound property of neighborhoods under reverse inclusion **)
  let U V.
  assume HUJ: U :e J.
  assume HVJ: V :e J.
  witness (U :/\: V).
  prove U :/\: V :e J /\ (U, U :/\: V) :e le /\ (V, U :/\: V) :e le.
  claim HUTx: U :e Tx.
  { exact (SepE1 Tx (fun U0:set => x :e U0) U HUJ). }
  claim HVTx: V :e Tx.
  { exact (SepE1 Tx (fun U0:set => x :e U0) V HVJ). }
  claim HxU: x :e U.
  { exact (SepE2 Tx (fun U0:set => x :e U0) U HUJ). }
  claim HxV: x :e V.
  { exact (SepE2 Tx (fun U0:set => x :e U0) V HVJ). }
  claim HWTx: U :/\: V :e Tx.
  { exact (topology_binintersect_closed X Tx U V HTx HUTx HVTx). }
  claim HxW: x :e U :/\: V.
  { exact (binintersectI U V x HxU HxV). }
  claim HWJ: U :/\: V :e J.
  { exact (SepI Tx (fun U0:set => x :e U0) (U :/\: V) HWTx HxW). }
	  (** conjunction is left-associative: (A /\ B) /\ C **)
	  apply andI.
	  + apply andI.
	    - exact HWJ.
	    - apply (rev_inclusion_relI J U (U :/\: V)).
	      + exact (tuple_2_setprod_by_pair_Sigma J J U (U :/\: V) HUJ HWJ).
	      + exact (binintersect_Subq_1 U V).
	  + apply (rev_inclusion_relI J V (U :/\: V)).
	    - exact (tuple_2_setprod_by_pair_Sigma J J V (U :/\: V) HVJ HWJ).
	    - exact (binintersect_Subq_2 U V).
Qed.

Theorem closure_via_nets : forall X Tx A x:set,
  topology_on X Tx ->
  (x :e closure_of X Tx A <->
    exists net J le:set, net_converges_on X Tx net J le x /\ net_points_in A net J).
let X Tx A x.
assume HTx: topology_on X Tx.
prove x :e closure_of X Tx A <->
  exists net J le:set, net_converges_on X Tx net J le x /\ net_points_in A net J.
apply iffI.
- assume Hxcl: x :e closure_of X Tx A.
  prove exists net J le:set, net_converges_on X Tx net J le x /\ net_points_in A net J.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hxcl). }
	  claim Hmeet: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
	  { exact (SepE2 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hxcl). }
	  set J := {U :e Tx | x :e U}.
	  set le := rev_inclusion_rel J.
	  set g := fun U:set => Eps_i (fun y:set => y :e U :/\: A).
	  set net := graph J g.
  claim HTsub: Tx c= Power X.
  { exact (topology_sub_Power X Tx HTx). }
  claim HsubX: forall U:set, U :e Tx -> U c= X.
  { let U. assume HU: U :e Tx.
    claim HU_pow: U :e Power X.
    { exact (HTsub U HU). }
    exact (PowerE X U HU_pow). }
  claim HJmeet: forall U:set, U :e J -> U :/\: A <> Empty.
  { let U. assume HUJ: U :e J.
    claim HUTx: U :e Tx.
    { exact (SepE1 Tx (fun U0:set => x :e U0) U HUJ). }
    claim HxU: x :e U.
    { exact (SepE2 Tx (fun U0:set => x :e U0) U HUJ). }
    exact (Hmeet U HUTx HxU). }
  claim Hg_in: forall U:set, U :e J -> g U :e U :/\: A.
  { let U. assume HUJ: U :e J.
    claim HUne: U :/\: A <> Empty.
    { exact (HJmeet U HUJ). }
    claim Hexy: exists y:set, y :e U :/\: A.
    { exact (nonempty_has_element (U :/\: A) HUne). }
    exact (Eps_i_ex (fun y:set => y :e U :/\: A) Hexy). }
  claim Hg_in_X: forall U:set, U :e J -> g U :e X.
  { let U. assume HUJ: U :e J.
    claim HUTx: U :e Tx.
    { exact (SepE1 Tx (fun U0:set => x :e U0) U HUJ). }
    claim HUsub: U c= X.
    { exact (HsubX U HUTx). }
    claim HgU_in_U: g U :e U.
    { exact (binintersectE1 U A (g U) (Hg_in U HUJ)). }
    exact (HUsub (g U) HgU_in_U). }
	  claim Hdir: directed_set J le.
	  { exact (neighborhoods_directed_by_reverse_inclusion X Tx x HTx HxX). }
	  claim Htot: total_function_on net J X.
	  { exact (total_function_on_graph J X g Hg_in_X). }
	  witness net.
	  witness J.
  witness le.
  apply andI.
  - prove net_converges_on X Tx net J le x.
    prove topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
      forall U:set, U :e Tx -> x :e U ->
        exists i0:set, i0 :e J /\
          forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
    apply andI.
    - (** core **)
      prove topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X.
      apply and6I.
      + exact HTx.
      + exact Hdir.
      + exact Htot.
      + exact (functional_graph_graph J g).
      + exact (graph_domain_subset_graph J g).
      + exact HxX.
    - (** tail **)
      let U0.
      assume HU0: U0 :e Tx.
      assume HxU0: x :e U0.
      prove exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U0.
      witness U0.
      apply andI.
      + exact (SepI Tx (fun U0a:set => x :e U0a) U0 HU0 HxU0).
	      + let i. assume HiJ: i :e J.
		        assume Hlei: (U0,i) :e le.
		        prove apply_fun net i :e U0.
		        claim HiSub: i c= U0.
		        { exact (andER ((U0,i) :e setprod J J) (i c= U0) (rev_inclusion_relE J U0 i Hlei)). }
		        rewrite (apply_fun_graph J g i HiJ).
		        claim Hgi_in_i: g i :e i.
		        { exact (binintersectE1 i A (g i) (Hg_in i HiJ)). }
		        exact (HiSub (g i) Hgi_in_i).
  - prove net_points_in A net J.
    let U. assume HUJ: U :e J.
    prove apply_fun net U :e A.
    rewrite (apply_fun_graph J g U HUJ).
    exact (binintersectE2 U A (g U) (Hg_in U HUJ)).
- assume Hex: exists net J le:set, net_converges_on X Tx net J le x /\ net_points_in A net J.
  apply Hex.
  let net.
  assume Hex1: exists J le:set, net_converges_on X Tx net J le x /\ net_points_in A net J.
  apply Hex1.
  let J.
  assume Hex2: exists le:set, net_converges_on X Tx net J le x /\ net_points_in A net J.
  apply Hex2.
  let le.
  assume Hboth: net_converges_on X Tx net J le x /\ net_points_in A net J.
  apply Hboth.
  assume Hconv Hpts.
  (** unfold closure_of via SepI **)
  (** unfold net_converges_on into core + tail **)
  apply Hconv.
  assume Hcore Htail.
  apply Hcore.
  assume Hcore5 HxX.
  apply Hcore5.
  assume Hcore4 Hdom.
  apply Hcore4.
  assume Hcore3 Hgraph.
  apply Hcore3.
  assume Hcore2 Htot.
  apply Hcore2.
  assume HTx0 HdirJ.
  prove x :e closure_of X Tx A.
  prove x :e {x0 :e X | forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty}.
  apply (SepI X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX).
  (** show every neighborhood meets A **)
  let U.
  assume HU: U :e Tx.
  assume HxU: x :e U.
  prove U :/\: A <> Empty.
  (** get eventual index i0 for U from convergence tail **)
  claim Hexi0: exists i0:set, i0 :e J /\
    forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e U.
  { exact (Htail U HU HxU). }
  apply Hexi0.
  let i0.
	  assume Hi0pair.
	  apply Hi0pair.
	  assume Hi0J Hafter.
	  claim Hi0refl: (i0,i0) :e le.
	  { exact (directed_set_refl J le HdirJ i0 Hi0J). }
	  claim HyU: apply_fun net i0 :e U.
	  { exact (Hafter i0 Hi0J Hi0refl). }
	  claim HyA: apply_fun net i0 :e A.
	  { exact (Hpts i0 Hi0J). }
  claim HyUA: apply_fun net i0 :e U :/\: A.
  { exact (binintersectI U A (apply_fun net i0) HyU HyA). }
  (** conclude nonempty **)
  assume Hempty: U :/\: A = Empty.
  claim HyEmpty: apply_fun net i0 :e Empty.
  { rewrite <- Hempty. exact HyUA. }
  exact (EmptyE (apply_fun net i0) HyEmpty False).
Qed.

(** from exercises after §29: continuity via nets **)
(** LATEX VERSION: Theorem. f is continuous iff for every convergent net (x_a)→x, the net (f(x_a)) converges to f(x). **)
Theorem continuity_via_nets : forall X Tx Y Ty f:set,
  topology_on X Tx -> topology_on Y Ty ->
  (continuous_map X Tx Y Ty f <->
    forall net J le x:set,
      net_converges_on X Tx net J le x ->
        net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x)).
let X Tx Y Ty f.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove (continuous_map X Tx Y Ty f <->
    forall net J le x:set,
      net_converges_on X Tx net J le x ->
        net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x)).
apply iffI.
- assume Hcont: continuous_map X Tx Y Ty f.
  prove forall net J le x:set,
    net_converges_on X Tx net J le x ->
      net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x).
  let net J le x.
  assume Hnetconv: net_converges_on X Tx net J le x.
  (** extract function_on f X Y and preimage condition from continuity **)
  claim HfXY: function_on f X Y.
  { exact (continuous_map_function_on X Tx Y Ty f Hcont). }
  claim Hpre: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  { exact (continuous_map_preimage X Tx Y Ty f Hcont). }
  (** unpack net_converges_on for net **)
  apply Hnetconv.
  assume Hcore Htail.
  apply Hcore.
  assume Hcore5 HxX.
  apply Hcore5.
  assume Hcore4 Hdom.
  apply Hcore4.
  assume Hcore3 Hgraph.
  apply Hcore3.
  assume Hcore2 Htot.
  apply Hcore2.
  assume HTx0 HdirJ.
  (** build net_converges_on for the composed net **)
  prove net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x).
  prove topology_on Y Ty /\ directed_set J le /\ total_function_on (compose_fun J net f) J Y /\ functional_graph (compose_fun J net f) /\ graph_domain_subset (compose_fun J net f) J /\ (apply_fun f x) :e Y /\
    forall V:set, V :e Ty -> apply_fun f x :e V ->
      exists i0:set, i0 :e J /\
        forall i:set, i :e J -> (i0,i) :e le -> apply_fun (compose_fun J net f) i :e V.
	  apply andI.
	  - (** core data **)
	    apply and6I.
	    + exact HTy.
	    + exact HdirJ.
	    + claim Hnetfun: function_on net J X.
	      { exact (total_function_on_function_on net J X Htot). }
	      exact (total_function_on_compose_fun J X Y net f Hnetfun HfXY).
	    + exact (functional_graph_compose_fun J net f).
	    + exact (graph_domain_subset_compose_fun J net f).
	    + exact (HfXY x HxX).
	  - (** tail for composed net **)
    let V.
    assume HV: V :e Ty.
    assume HfxV: apply_fun f x :e V.
    set W := preimage_of X f V.
    claim HWTx: W :e Tx.
    { exact (Hpre V HV). }
    claim HxW: x :e W.
    { exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
    claim Hexi0: exists i0:set, i0 :e J /\
      forall i:set, i :e J -> (i0,i) :e le -> apply_fun net i :e W.
    { exact (Htail W HWTx HxW). }
    apply Hexi0.
    let i0.
    assume Hi0pair.
    apply Hi0pair.
    assume Hi0J Hafter.
    witness i0.
    apply andI.
    + exact Hi0J.
    + let i.
      assume HiJ: i :e J.
      assume Hi0i: (i0,i) :e le.
      prove apply_fun (compose_fun J net f) i :e V.
      claim HnetiW: apply_fun net i :e W.
      { exact (Hafter i HiJ Hi0i). }
      claim HnetiV: apply_fun f (apply_fun net i) :e V.
      { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) (apply_fun net i) HnetiW). }
      claim Happ: apply_fun (compose_fun J net f) i = apply_fun f (apply_fun net i).
      { exact (compose_fun_apply J net f i HiJ). }
      rewrite Happ.
      exact HnetiV.
- assume Hnets: forall net J le x:set,
    net_converges_on X Tx net J le x ->
      net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x).
  prove continuous_map X Tx Y Ty f.
  prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
    forall V:set, V :e Ty -> preimage_of X f V :e Tx.
  (** continuous_map is a left-associated conjunction **)
  apply andI.
  - (** (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y **)
    apply andI.
    + (** topology_on X Tx /\ topology_on Y Ty **)
      apply andI.
      - exact HTx.
      - exact HTy.
    + (** function_on f X Y **)
      prove function_on f X Y.
      let x. assume HxX: x :e X.
      (** constant net at x on singleton index {x} **)
      set J0 := {x}.
      set le0 := setprod J0 J0.
      set net0 := graph J0 (fun _:set => x).
      claim Hdir0: directed_set J0 le0.
      { prove directed_set J0 le0.
        prove (J0 <> Empty /\ partial_order_on J0 le0) /\
          forall a b:set, a :e J0 -> b :e J0 ->
            exists c:set, c :e J0 /\ (a,c) :e le0 /\ (b,c) :e le0.
        apply andI.
        - (** nonempty and partial order **)
          apply andI.
          + exact (elem_implies_nonempty J0 x (SingI x)).
	          + (** partial_order_on J0 le0 **)
	            prove partial_order_on J0 le0.
	            prove ((relation_on le0 J0 /\
	                     (forall a:set, a :e J0 -> (a,a) :e le0)) /\
	                    (forall a b:set, a :e J0 -> b :e J0 ->
	                      (a,b) :e le0 -> (b,a) :e le0 -> a = b)) /\
	                  (forall a b c:set, a :e J0 -> b :e J0 -> c :e J0 ->
	                    (a,b) :e le0 -> (b,c) :e le0 -> (a,c) :e le0).
	            (** partial_order_on is left-associated: ((relation_on /\ refl) /\ antisym) /\ trans **)
	            apply andI.
            - (** (relation_on /\ refl) /\ antisym **)
              apply andI.
              + (** relation_on /\ refl **)
                apply andI.
                - (** relation_on le0 J0 **)
                  prove relation_on le0 J0.
                  let a b. assume Hab: (a,b) :e le0.
                  prove a :e J0 /\ b :e J0.
                  claim Ha0: (a,b) 0 :e J0.
                  { exact (ap0_Sigma J0 (fun _ : set => J0) (a,b) Hab). }
                  claim Hb1: (a,b) 1 :e J0.
                  { exact (ap1_Sigma J0 (fun _ : set => J0) (a,b) Hab). }
                  apply andI.
                  - rewrite <- (tuple_2_0_eq a b). exact Ha0.
                  - rewrite <- (tuple_2_1_eq a b). exact Hb1.
                - (** reflexive **)
                  let a. assume HaJ: a :e J0.
                  claim HaEq: a = x.
                  { exact (SingE x a HaJ). }
                  rewrite HaEq.
                  exact (tuple_2_setprod_by_pair_Sigma J0 J0 x x (SingI x) (SingI x)).
              + (** antisymmetric **)
                let a b.
                assume HaJ: a :e J0.
                assume HbJ: b :e J0.
                assume Hab: (a,b) :e le0.
                assume Hba: (b,a) :e le0.
                prove a = b.
                rewrite (SingE x a HaJ).
                rewrite (SingE x b HbJ).
                reflexivity.
            - (** transitive **)
              let a b c.
              assume HaJ: a :e J0.
              assume HbJ: b :e J0.
              assume HcJ: c :e J0.
              assume Hab: (a,b) :e le0.
              assume Hbc: (b,c) :e le0.
              prove (a,c) :e le0.
              claim HaEq: a = x.
              { exact (SingE x a HaJ). }
              claim HcEq: c = x.
              { exact (SingE x c HcJ). }
              rewrite HaEq.
              rewrite HcEq.
              exact (tuple_2_setprod_by_pair_Sigma J0 J0 x x (SingI x) (SingI x)).
        - (** upper bound property **)
          let a b. assume HaJ: a :e J0. assume HbJ: b :e J0.
          witness x.
          apply andI.
          + apply andI.
            - exact (SingI x).
            - claim HaEq: a = x.
              { exact (SingE x a HaJ). }
              rewrite HaEq.
              exact (tuple_2_setprod_by_pair_Sigma J0 J0 x x (SingI x) (SingI x)).
          + claim HbEq: b = x.
            { exact (SingE x b HbJ). }
            rewrite HbEq.
            exact (tuple_2_setprod_by_pair_Sigma J0 J0 x x (SingI x) (SingI x)). }
      claim Hnet0conv: net_converges_on X Tx net0 J0 le0 x.
      { prove net_converges_on X Tx net0 J0 le0 x.
	        prove topology_on X Tx /\ directed_set J0 le0 /\ total_function_on net0 J0 X /\ functional_graph net0 /\ graph_domain_subset net0 J0 /\ x :e X /\
	          forall U:set, U :e Tx -> x :e U ->
	            exists i0:set, i0 :e J0 /\
	              forall i:set, i :e J0 -> (i0,i) :e le0 -> apply_fun net0 i :e U.
	        apply andI.
	        - (** core **)
	          prove topology_on X Tx /\ directed_set J0 le0 /\ total_function_on net0 J0 X /\ functional_graph net0 /\ graph_domain_subset net0 J0 /\ x :e X.
	          apply and6I.
	          + exact HTx.
	          + exact Hdir0.
	          + claim Hgconst: forall j:set, j :e J0 -> (fun _:set => x) j :e X.
	            { let j. assume Hj: j :e J0. exact HxX. }
	            exact (total_function_on_graph J0 X (fun _:set => x) Hgconst).
	          + exact (functional_graph_graph J0 (fun _:set => x)).
	          + exact (graph_domain_subset_graph J0 (fun _:set => x)).
	          + exact HxX.
	        - (** tail **)
	          let U. assume HU: U :e Tx. assume HxU: x :e U.
	          witness x.
	          apply andI.
          + exact (SingI x).
          + let i. assume Hi: i :e J0.
            assume Hle: (x,i) :e le0.
            rewrite (apply_fun_graph J0 (fun _:set => x) i Hi).
            exact HxU. }
      claim Himg0: net_converges_on Y Ty (compose_fun J0 net0 f) J0 le0 (apply_fun f x).
      { exact (Hnets net0 J0 le0 x Hnet0conv). }
      apply Himg0.
      assume Hcore0 Htail0.
      apply Hcore0.
      assume Hcore05 HfxY.
      exact HfxY.
  - (** preimage condition **)
    let V. assume HV: V :e Ty.
    set W := preimage_of X f V.
    prove W :e Tx.
    (** family of opens contained in W **)
    set Fam := {U :e Tx | U c= W}.
    claim HFamPow: Fam :e Power Tx.
    { apply PowerI.
      let U. assume HU: U :e Fam.
      exact (SepE1 Tx (fun U0:set => U0 c= W) U HU). }
    (** neighborhood lemma: each x in W has an open neighborhood contained in W **)
    claim Hnbhd: forall x0:set, x0 :e W -> exists U:set, U :e Tx /\ x0 :e U /\ U c= W.
    { let x0. assume Hx0W: x0 :e W.
      claim Hx0X: x0 :e X.
      { exact (SepE1 X (fun z:set => apply_fun f z :e V) x0 Hx0W). }
      claim Hfx0V: apply_fun f x0 :e V.
      { exact (SepE2 X (fun z:set => apply_fun f z :e V) x0 Hx0W). }
      (** show x0 not in closure of X \\ W **)
      claim Hnotcl: x0 /:e closure_of X Tx (X :\: W).
      { apply (xm (x0 :e closure_of X Tx (X :\: W))).
        - assume Hcl: x0 :e closure_of X Tx (X :\: W).
          (** build a net in X\\W converging to x0 **)
	          claim Hexnet: exists net J le:set,
	            net_converges_on X Tx net J le x0 /\ net_points_in (X :\: W) net J.
	          { exact (iffEL (x0 :e closure_of X Tx (X :\: W))
	                         (exists net J le:set,
	                           net_converges_on X Tx net J le x0 /\ net_points_in (X :\: W) net J)
	                         (closure_via_nets X Tx (X :\: W) x0 HTx)
	                         Hcl). }
          apply Hexnet.
          let net. assume Hex1: exists J le:set, net_converges_on X Tx net J le x0 /\ net_points_in (X :\: W) net J.
          apply Hex1.
          let J. assume Hex2: exists le:set, net_converges_on X Tx net J le x0 /\ net_points_in (X :\: W) net J.
          apply Hex2.
          let le. assume Hboth: net_converges_on X Tx net J le x0 /\ net_points_in (X :\: W) net J.
          apply Hboth. assume Hconv Hpts.
          claim Himg: net_converges_on Y Ty (compose_fun J net f) J le (apply_fun f x0).
          { exact (Hnets net J le x0 Hconv). }
          (** extract directed_set J le and reflexivity **)
          apply Himg. assume Hcore Htail.
          apply Hcore. assume Hcore5 Hfx0Y.
          apply Hcore5. assume Hcore4 Hdom.
          apply Hcore4. assume Hcore3 Hgraph.
          apply Hcore3. assume Hcore2 Htot.
          apply Hcore2. assume HTy0 Hdir.
          (** use the tail for neighborhood V **)
          claim Hexi0: exists i0:set, i0 :e J /\
            forall i:set, i :e J -> (i0,i) :e le -> apply_fun (compose_fun J net f) i :e V.
          { exact (Htail V HV Hfx0V). }
          apply Hexi0.
          let i0. assume Hi0pair.
          apply Hi0pair. assume Hi0J Hafter.
          (** get (i0,i0) :e le from directed_set reflexivity **)
          claim Hleft: J <> Empty /\ partial_order_on J le.
          { exact (andEL (J <> Empty /\ partial_order_on J le)
                         (forall a b:set, a :e J -> b :e J ->
                           exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
                         Hdir). }
	          claim Hpo: partial_order_on J le.
	          { exact (andER (J <> Empty) (partial_order_on J le) Hleft). }
	          claim Hrefl: forall a:set, a :e J -> (a,a) :e le.
	          { exact (partial_order_on_refl J le Hpo). }
	          claim Hrefl0: (i0,i0) :e le.
	          { exact (Hrefl i0 Hi0J). }
          (** now show i0 violates eventuality since all points lie outside V **)
          claim HnotV: apply_fun (compose_fun J net f) i0 /:e V.
          { claim Hneti0: apply_fun net i0 :e X :\: W.
            { exact (Hpts i0 Hi0J). }
            claim Hi0X: apply_fun net i0 :e X.
            { exact (setminusE1 X W (apply_fun net i0) Hneti0). }
            claim Hi0notW: apply_fun net i0 /:e W.
            { exact (setminusE2 X W (apply_fun net i0) Hneti0). }
            assume Hbad: apply_fun (compose_fun J net f) i0 :e V.
            claim Happ: apply_fun (compose_fun J net f) i0 = apply_fun f (apply_fun net i0).
            { exact (compose_fun_apply J net f i0 Hi0J). }
            claim Hfi0V: apply_fun f (apply_fun net i0) :e V.
            { rewrite <- Happ. exact Hbad. }
            claim Hi0W: apply_fun net i0 :e W.
            { exact (SepI X (fun z:set => apply_fun f z :e V) (apply_fun net i0) Hi0X Hfi0V). }
            exact (Hi0notW Hi0W False). }
	          claim Hv: apply_fun (compose_fun J net f) i0 :e V.
	          { exact (Hafter i0 Hi0J Hrefl0). }
	          assume Hcl2: x0 :e closure_of X Tx (X :\: W).
	          exact (HnotV Hv).
	        - assume Hncl: x0 /:e closure_of X Tx (X :\: W).
	          exact Hncl. }
      (** from not-closure derive an open neighborhood contained in W **)
      apply (xm (exists U:set, U :e Tx /\ x0 :e U /\ U c= W)).
      - assume Hex. exact Hex.
      - assume Hno.
        apply FalseE.
        (** show x0 is in the closure, contradicting Hnotcl **)
        claim Hx0cl: x0 :e closure_of X Tx (X :\: W).
        { prove x0 :e {z :e X | forall U:set, U :e Tx -> z :e U -> U :/\: (X :\: W) <> Empty}.
          apply (SepI X (fun z:set => forall U:set, U :e Tx -> z :e U -> U :/\: (X :\: W) <> Empty) x0 Hx0X).
          let U. assume HU: U :e Tx. assume Hx0U: x0 :e U.
          prove U :/\: (X :\: W) <> Empty.
          assume Hemp: U :/\: (X :\: W) = Empty.
          (** Hemp implies U c= W **)
          claim HUsW: U c= W.
          { let y. assume HyU: y :e U.
            prove y :e W.
            apply (xm (y :e W)).
            - assume HyW: y :e W. exact HyW.
            - assume HyNW: y /:e W.
              claim HyX: y :e X.
              { claim HUsubX: U c= X.
                { exact (PowerE X U ((topology_sub_Power X Tx HTx) U HU)). }
                exact (HUsubX y HyU). }
              claim HyInComp: y :e X :\: W.
              { exact (setminusI X W y HyX HyNW). }
              claim HyInInt: y :e U :/\: (X :\: W).
              { exact (binintersectI U (X :\: W) y HyU HyInComp). }
	              claim HyEmpty: y :e Empty.
	              { rewrite <- Hemp. exact HyInInt. }
	              apply FalseE.
	              exact (EmptyE y HyEmpty). }
          apply Hno.
          witness U.
          prove (U :e Tx /\ x0 :e U) /\ U c= W.
          apply andI.
          - apply andI.
            + exact HU.
            + exact Hx0U.
          - exact HUsW. }
          exact (Hnotcl Hx0cl). }
    (** show Union Fam = W **)
    claim HUnionEq: Union Fam = W.
    { apply set_ext.
      - (** Union Fam c= W **)
        let y. assume Hy: y :e Union Fam.
        apply (UnionE_impred Fam y Hy (y :e W)).
        let U. assume HyU: y :e U.
        assume HUFam: U :e Fam.
        claim HUsub: U c= W.
        { exact (SepE2 Tx (fun U0:set => U0 c= W) U HUFam). }
        exact (HUsub y HyU).
      - (** W c= Union Fam **)
        let y. assume HyW: y :e W.
        claim HexU: exists U:set, U :e Tx /\ y :e U /\ U c= W.
        { exact (Hnbhd y HyW). }
	        apply HexU.
	        let U. assume HUpack: U :e Tx /\ y :e U /\ U c= W.
	        claim Hleft: U :e Tx /\ y :e U.
	        { exact (andEL (U :e Tx /\ y :e U) (U c= W) HUpack). }
	        claim HU: U :e Tx.
	        { exact (andEL (U :e Tx) (y :e U) Hleft). }
	        claim HyU: y :e U.
	        { exact (andER (U :e Tx) (y :e U) Hleft). }
	        claim HUsW: U c= W.
	        { exact (andER (U :e Tx /\ y :e U) (U c= W) HUpack). }
	        claim HUFam: U :e Fam.
	        { exact (SepI Tx (fun U0:set => U0 c= W) U HU HUsW). }
	        exact (UnionI Fam y U HyU HUFam). }
    claim HUnionOpen: Union Fam :e Tx.
    { exact (topology_union_axiom X Tx HTx Fam HFamPow). }
    rewrite <- HUnionEq.
    exact HUnionOpen.
Qed.

(** from exercises after §29: accumulation points and subnets **)
(** LATEX VERSION: Every accumulation point of a net has a subnet converging to it. **)
Theorem subnet_converges_to_accumulation : forall X Tx net x:set,
  accumulation_point_of_net X Tx net x -> exists sub:set, subnet_of net sub /\ net_converges X Tx sub x.
let X Tx net x.
assume Hacc: accumulation_point_of_net X Tx net x.
prove exists sub:set, subnet_of net sub /\ net_converges X Tx sub x.
apply Hacc.
let J.
assume Hexle:
  exists le:set, topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
apply Hexle.
let le.
assume Hdata:
  topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
apply Hdata.
assume Hcore Hfreq.
apply Hcore.
assume Hcore5 HxX.
apply Hcore5.
assume Hcore4 Hdomnet.
apply Hcore4.
assume Hcore3 Hgraphnet.
apply Hcore3.
assume Hcore2 Htotnet.
apply Hcore2.
assume HTx HdirJ.

claim Hfunnet: function_on net J X.
{ exact (total_function_on_function_on net J X Htotnet). }

(** extract reflexivity of le from directed_set J le **)
claim Hrefl: forall j0:set, j0 :e J -> (j0,j0) :e le.
{ let j0. assume Hj0: j0 :e J.
  exact (directed_set_refl J le HdirJ j0 Hj0). }

(** build the standard neighborhood-index subnet **)
set N := {U :e Tx | x :e U}.
set K := {p :e setprod N J | apply_fun net (p 1) :e p 0}.
set leK := {q :e setprod K K | (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le}.
set phi := graph K (fun k:set => k 1).
set sub := graph K (fun k:set => apply_fun net (k 1)).

(** directed_set K leK is the only hard infrastructure point here **)
claim HdirK: directed_set K leK.
{ prove directed_set K leK.
  (** extract partial_order_on J le data **)
  claim HJpack: J <> Empty /\ partial_order_on J le.
  { exact (andEL (J <> Empty /\ partial_order_on J le)
                 (forall a b:set, a :e J -> b :e J ->
                   exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
                 HdirJ). }
  claim HJpo: partial_order_on J le.
  { exact (andER (J <> Empty) (partial_order_on J le) HJpack). }
  claim HantisymJ:
    forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b.
  { exact (partial_order_on_antisym J le HJpo). }
  claim HtransJ:
    forall a b c:set, a :e J -> b :e J -> c :e J -> (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
  { exact (partial_order_on_trans J le HJpo). }

  prove (K <> Empty /\ partial_order_on K leK) /\
    forall a b:set, a :e K -> b :e K ->
      exists c:set, c :e K /\ (a,c) :e leK /\ (b,c) :e leK.
  apply andI.
  - (** K <> Empty /\ partial_order_on K leK **)
    apply andI.
    + (** K <> Empty **)
      claim HJne: J <> Empty.
      { exact (andEL (J <> Empty) (partial_order_on J le) HJpack). }
      claim Hexj0: exists j0:set, j0 :e J.
      { exact (nonempty_has_element J HJne). }
      apply Hexj0.
      let j0. assume Hj0: j0 :e J.
      claim HXTx: X :e Tx.
      { exact (topology_has_X X Tx HTx). }
      claim HXN: X :e N.
      { exact (SepI Tx (fun U0:set => x :e U0) X HXTx HxX). }
      claim Hnetj0X: apply_fun net j0 :e X.
      { exact (Hfunnet j0 Hj0). }
      claim HpProd: (X,j0) :e setprod N J.
      { exact (tuple_2_setprod_by_pair_Sigma N J X j0 HXN Hj0). }
      claim Hp_in: apply_fun net ((X,j0) 1) :e (X,j0) 0.
      { rewrite (tuple_2_1_eq X j0).
        rewrite (tuple_2_0_eq X j0).
        exact Hnetj0X. }
      claim HpK: (X,j0) :e K.
      { exact (SepI (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) (X,j0) HpProd Hp_in). }
      exact (elem_implies_nonempty K (X,j0) HpK).
    + (** partial_order_on K leK **)
      prove partial_order_on K leK.
      prove relation_on leK K /\
        (forall a:set, a :e K -> (a,a) :e leK) /\
        (forall a b:set, a :e K -> b :e K -> (a,b) :e leK -> (b,a) :e leK -> a = b) /\
        (forall a b c:set, a :e K -> b :e K -> c :e K -> (a,b) :e leK -> (b,c) :e leK -> (a,c) :e leK).
      apply andI.
      - (** (relation_on /\ refl) /\ antisym **)
        apply andI.
        + (** relation_on /\ refl **)
          apply andI.
          - (** relation_on leK K **)
            prove relation_on leK K.
            let a b. assume Hab: (a,b) :e leK.
            prove a :e K /\ b :e K.
            claim Hprod: (a,b) :e setprod K K.
            { exact (SepE1 (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (a,b) Hab). }
            claim HaK: (a,b) 0 :e K.
            { exact (ap0_Sigma K (fun _ : set => K) (a,b) Hprod). }
            claim HbK: (a,b) 1 :e K.
            { exact (ap1_Sigma K (fun _ : set => K) (a,b) Hprod). }
            apply andI.
            - rewrite <- (tuple_2_0_eq a b). exact HaK.
            - rewrite <- (tuple_2_1_eq a b). exact HbK.
          - (** reflexive **)
            let a. assume HaK: a :e K.
            prove (a,a) :e leK.
            apply (SepI (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (a,a)).
            + exact (tuple_2_setprod_by_pair_Sigma K K a a HaK HaK).
            + apply andI.
              - rewrite (tuple_2_1_eq a a).
                rewrite (tuple_2_0_eq a a).
                exact (Subq_ref (a 0)).
              - claim HaProd: a :e setprod N J.
                { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) a HaK). }
                claim Ha1J: a 1 :e J.
                { exact (ap1_Sigma N (fun _ : set => J) a HaProd). }
                rewrite (tuple_2_0_eq a a).
                rewrite (tuple_2_1_eq a a).
                exact (Hrefl (a 1) Ha1J).
        + (** antisymmetric **)
          let a b.
          assume HaK: a :e K.
          assume HbK: b :e K.
          assume Hab: (a,b) :e leK.
          assume Hba: (b,a) :e leK.
          prove a = b.
          claim Habp: (b 0) c= (a 0) /\ ((a 1),(b 1)) :e le.
          { exact (pair_order_pred K le a b Hab). }
          claim Hbabp: (a 0) c= (b 0) /\ ((b 1),(a 1)) :e le.
          { exact (pair_order_pred K le b a Hba). }
          claim Hb0suba0: (b 0) c= (a 0).
          { exact (andEL ((b 0) c= (a 0)) (((a 1),(b 1)) :e le) Habp). }
          claim Ha0subb0: (a 0) c= (b 0).
          { exact (andEL ((a 0) c= (b 0)) (((b 1),(a 1)) :e le) Hbabp). }
          claim Ha0eq: (a 0) = (b 0).
          { apply set_ext.
            - let y. assume Hy: y :e (a 0). exact (Ha0subb0 y Hy).
            - let y. assume Hy: y :e (b 0). exact (Hb0suba0 y Hy). }
          claim Hab1: ((a 1),(b 1)) :e le.
          { exact (andER ((b 0) c= (a 0)) (((a 1),(b 1)) :e le) Habp). }
          claim Hba1: ((b 1),(a 1)) :e le.
          { exact (andER ((a 0) c= (b 0)) (((b 1),(a 1)) :e le) Hbabp). }
          claim HaProd: a :e setprod N J.
          { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) a HaK). }
          claim HbProd: b :e setprod N J.
          { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) b HbK). }
          claim Ha1J: a 1 :e J.
          { exact (ap1_Sigma N (fun _ : set => J) a HaProd). }
          claim Hb1J: b 1 :e J.
          { exact (ap1_Sigma N (fun _ : set => J) b HbProd). }
          claim Ha1eq: (a 1) = (b 1).
          { exact (HantisymJ (a 1) (b 1) Ha1J Hb1J Hab1 Hba1). }
          claim Haeta: a = (a 0, a 1).
          { exact (setprod_eta N J a HaProd). }
          claim Hbeta: b = (b 0, b 1).
          { exact (setprod_eta N J b HbProd). }
          rewrite Haeta.
			            rewrite Hbeta.
          exact (coords_eq_tuple (a 0) (a 1) (b 0) (b 1) Ha0eq Ha1eq).
      - (** transitive **)
        let a b c.
        assume HaK: a :e K.
        assume HbK: b :e K.
        assume HcK: c :e K.
        assume Hab: (a,b) :e leK.
        assume Hbc: (b,c) :e leK.
        prove (a,c) :e leK.
        apply (SepI (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (a,c)).
        + exact (tuple_2_setprod_by_pair_Sigma K K a c HaK HcK).
        + claim Habp: (b 0) c= (a 0) /\ ((a 1),(b 1)) :e le.
          { exact (pair_order_pred K le a b Hab). }
          claim Hbcp: (c 0) c= (b 0) /\ ((b 1),(c 1)) :e le.
          { exact (pair_order_pred K le b c Hbc). }
          claim Hc0subb0: (c 0) c= (b 0).
          { exact (andEL ((c 0) c= (b 0)) (((b 1),(c 1)) :e le) Hbcp). }
          claim Hb0suba0: (b 0) c= (a 0).
          { exact (andEL ((b 0) c= (a 0)) (((a 1),(b 1)) :e le) Habp). }
          claim Hc0suba0: (c 0) c= (a 0).
          { exact (Subq_tra (c 0) (b 0) (a 0) Hc0subb0 Hb0suba0). }
          claim Hab1: ((a 1),(b 1)) :e le.
          { exact (andER ((b 0) c= (a 0)) (((a 1),(b 1)) :e le) Habp). }
          claim Hbc1: ((b 1),(c 1)) :e le.
          { exact (andER ((c 0) c= (b 0)) (((b 1),(c 1)) :e le) Hbcp). }
          claim HaProd: a :e setprod N J.
          { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) a HaK). }
          claim HbProd: b :e setprod N J.
          { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) b HbK). }
          claim HcProd: c :e setprod N J.
          { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) c HcK). }
          claim Ha1J: a 1 :e J.
          { exact (ap1_Sigma N (fun _ : set => J) a HaProd). }
          claim Hb1J: b 1 :e J.
          { exact (ap1_Sigma N (fun _ : set => J) b HbProd). }
          claim Hc1J: c 1 :e J.
          { exact (ap1_Sigma N (fun _ : set => J) c HcProd). }
          claim Hac1: ((a 1),(c 1)) :e le.
          { exact (HtransJ (a 1) (b 1) (c 1) Ha1J Hb1J Hc1J Hab1 Hbc1). }
          apply andI.
          - rewrite (tuple_2_1_eq a c).
            rewrite (tuple_2_0_eq a c).
            exact Hc0suba0.
          - rewrite (tuple_2_0_eq a c).
            rewrite (tuple_2_1_eq a c).
            exact Hac1.
  - (** upper bound property of K **)
    let a b.
    assume HaK: a :e K.
    assume HbK: b :e K.
    prove exists c:set, c :e K /\ (a,c) :e leK /\ (b,c) :e leK.
    claim HaProd: a :e setprod N J.
    { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) a HaK). }
    claim HbProd: b :e setprod N J.
    { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) b HbK). }
    claim Ha0N: a 0 :e N.
    { exact (ap0_Sigma N (fun _ : set => J) a HaProd). }
    claim Hb0N: b 0 :e N.
    { exact (ap0_Sigma N (fun _ : set => J) b HbProd). }
    claim Ha1J: a 1 :e J.
    { exact (ap1_Sigma N (fun _ : set => J) a HaProd). }
    claim Hb1J: b 1 :e J.
    { exact (ap1_Sigma N (fun _ : set => J) b HbProd). }
    claim Ha0Tx: a 0 :e Tx.
    { exact (SepE1 Tx (fun U0:set => x :e U0) (a 0) Ha0N). }
    claim Hb0Tx: b 0 :e Tx.
    { exact (SepE1 Tx (fun U0:set => x :e U0) (b 0) Hb0N). }
    claim Hxa0: x :e (a 0).
    { exact (SepE2 Tx (fun U0:set => x :e U0) (a 0) Ha0N). }
    claim Hxb0: x :e (b 0).
    { exact (SepE2 Tx (fun U0:set => x :e U0) (b 0) Hb0N). }
    claim HWTx: (a 0) :/\: (b 0) :e Tx.
    { exact (topology_binintersect_closed X Tx (a 0) (b 0) HTx Ha0Tx Hb0Tx). }
    claim HxW: x :e (a 0) :/\: (b 0).
    { exact (binintersectI (a 0) (b 0) x Hxa0 Hxb0). }
    claim HWN: (a 0) :/\: (b 0) :e N.
    { exact (SepI Tx (fun U0:set => x :e U0) ((a 0) :/\: (b 0)) HWTx HxW). }
    claim Hexm: exists m:set, m :e J /\ (a 1, m) :e le /\ (b 1, m) :e le.
    { exact (directed_set_upper_bound_property J le HdirJ (a 1) (b 1) Ha1J Hb1J). }
	    apply Hexm.
	    let m. assume HmPack: m :e J /\ (a 1, m) :e le /\ (b 1, m) :e le.
	    claim Hm_left: m :e J /\ (a 1, m) :e le.
	    { exact (andEL (m :e J /\ (a 1, m) :e le) ((b 1, m) :e le) HmPack). }
	    claim HmJ: m :e J.
	    { exact (andEL (m :e J) ((a 1, m) :e le) Hm_left). }
	    claim Ham: (a 1, m) :e le.
	    { exact (andER (m :e J) ((a 1, m) :e le) Hm_left). }
	    claim Hbm: (b 1, m) :e le.
	    { exact (andER (m :e J /\ (a 1, m) :e le) ((b 1, m) :e le) HmPack). }
    claim Hexj: exists j:set, j :e J /\ (m,j) :e le /\ apply_fun net j :e ((a 0) :/\: (b 0)).
    { exact (Hfreq ((a 0) :/\: (b 0)) HWTx HxW m HmJ). }
    apply Hexj.
    let j. assume HjPack: j :e J /\ (m,j) :e le /\ apply_fun net j :e ((a 0) :/\: (b 0)).
    claim Hj_left: j :e J /\ (m,j) :e le.
    { exact (andEL (j :e J /\ (m,j) :e le) (apply_fun net j :e ((a 0) :/\: (b 0))) HjPack). }
    claim HjJ: j :e J.
    { exact (andEL (j :e J) ((m,j) :e le) Hj_left). }
    claim Hmj: (m,j) :e le.
    { exact (andER (j :e J) ((m,j) :e le) Hj_left). }
    claim HnetjW: apply_fun net j :e ((a 0) :/\: (b 0)).
    { exact (andER (j :e J /\ (m,j) :e le) (apply_fun net j :e ((a 0) :/\: (b 0))) HjPack). }
    claim HcProd: (((a 0) :/\: (b 0)), j) :e setprod N J.
    { exact (tuple_2_setprod_by_pair_Sigma N J ((a 0) :/\: (b 0)) j HWN HjJ). }
    claim Hc_in: apply_fun net ((((a 0) :/\: (b 0)), j) 1) :e (((a 0) :/\: (b 0)), j) 0.
    { rewrite (tuple_2_1_eq ((a 0) :/\: (b 0)) j).
      rewrite (tuple_2_0_eq ((a 0) :/\: (b 0)) j).
      exact HnetjW. }
    claim HcK: (((a 0) :/\: (b 0)), j) :e K.
    { exact (SepI (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) (((a 0) :/\: (b 0)), j) HcProd Hc_in). }
    witness (((a 0) :/\: (b 0)), j).
    apply andI.
    - apply andI.
      + exact HcK.
      + (** (a,c) :e leK **)
        apply (SepI (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (a,(((a 0) :/\: (b 0)), j))).
	        * exact (tuple_2_setprod_by_pair_Sigma K K a (((a 0) :/\: (b 0)), j) HaK HcK).
	        * apply andI.
	          - rewrite (tuple_2_1_eq a (((a 0) :/\: (b 0)), j)) at 1.
	            rewrite (tuple_2_0_eq ((a 0) :/\: (b 0)) j) at 1.
	            rewrite (tuple_2_0_eq a (((a 0) :/\: (b 0)), j)) at 1.
	            exact (binintersect_Subq_1 (a 0) (b 0)).
	          - claim Haj: (a 1, j) :e le.
	            { exact (HtransJ (a 1) m j Ha1J HmJ HjJ Ham Hmj). }
	            rewrite (tuple_2_0_eq a (((a 0) :/\: (b 0)), j)) at 1.
	            rewrite (tuple_2_1_eq a (((a 0) :/\: (b 0)), j)) at 1.
	            rewrite (tuple_2_1_eq ((a 0) :/\: (b 0)) j) at 1.
	            exact Haj.
	    - (** (b,c) :e leK **)
	      apply (SepI (setprod K K) (fun q:set => (q 1) 0 c= (q 0) 0 /\ ((q 0) 1, (q 1) 1) :e le) (b,(((a 0) :/\: (b 0)), j))).
	      + exact (tuple_2_setprod_by_pair_Sigma K K b (((a 0) :/\: (b 0)), j) HbK HcK).
	      + apply andI.
	        - rewrite (tuple_2_1_eq b (((a 0) :/\: (b 0)), j)) at 1.
	          rewrite (tuple_2_0_eq ((a 0) :/\: (b 0)) j) at 1.
	          rewrite (tuple_2_0_eq b (((a 0) :/\: (b 0)), j)) at 1.
	          exact (binintersect_Subq_2 (a 0) (b 0)).
	        - claim Hbj: (b 1, j) :e le.
	          { exact (HtransJ (b 1) m j Hb1J HmJ HjJ Hbm Hmj). }
	          rewrite (tuple_2_0_eq b (((a 0) :/\: (b 0)), j)) at 1.
	          rewrite (tuple_2_1_eq b (((a 0) :/\: (b 0)), j)) at 1.
	          rewrite (tuple_2_1_eq ((a 0) :/\: (b 0)) j) at 1.
	          exact Hbj.
	}

(** sub is total_function_on K -> X **)
claim Htotsub: total_function_on sub K X.
{ claim Hgsub: forall k:set, k :e K -> (fun k0:set => apply_fun net (k0 1)) k :e X.
  { let k. assume HkK: k :e K.
    claim HkProd: k :e setprod N J.
    { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) k HkK). }
    claim Hk1J: k 1 :e J.
    { exact (ap1_Sigma N (fun _ : set => J) k HkProd). }
    exact (Hfunnet (k 1) Hk1J). }
  exact (total_function_on_graph K X (fun k0:set => apply_fun net (k0 1)) Hgsub). }

claim Hgraphsub: functional_graph sub.
{ exact (functional_graph_graph K (fun k0:set => apply_fun net (k0 1))). }

claim Hdomsub: graph_domain_subset sub K.
{ exact (graph_domain_subset_graph K (fun k0:set => apply_fun net (k0 1))). }

(** phi is total_function_on K -> J **)
claim Htotphi: total_function_on phi K J.
{ claim Hgphi: forall k:set, k :e K -> (fun k0:set => k0 1) k :e J.
  { let k. assume HkK: k :e K.
    claim HkProd: k :e setprod N J.
    { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) k HkK). }
    exact (ap1_Sigma N (fun _ : set => J) k HkProd). }
  exact (total_function_on_graph K J (fun k0:set => k0 1) Hgphi). }

claim Hgraphphi: functional_graph phi.
{ exact (functional_graph_graph K (fun k0:set => k0 1)). }

claim Hdomphi: graph_domain_subset phi K.
{ exact (graph_domain_subset_graph K (fun k0:set => k0 1)). }

(** monotonicity of phi with respect to leK and le **)
claim Hmono: forall i j:set, i :e K -> j :e K -> (i,j) :e leK -> (apply_fun phi i, apply_fun phi j) :e le.
{ let i j.
  assume HiK: i :e K.
  assume HjK: j :e K.
  assume Hij: (i,j) :e leK.
  claim Hle: ((i 1),(j 1)) :e le.
  { exact (andER ((j 0) c= (i 0)) (((i 1),(j 1)) :e le) (pair_order_pred K le i j Hij)). }
  rewrite (apply_fun_graph K (fun k0:set => k0 1) i HiK).
  rewrite (apply_fun_graph K (fun k0:set => k0 1) j HjK).
  exact Hle. }

(** cofinality: for each j0 choose (X,j0) **)
claim Hcofinal: forall j0:set, j0 :e J -> exists k:set, k :e K /\ (j0, apply_fun phi k) :e le.
{ let j0. assume Hj0: j0 :e J.
  claim HXTx: X :e Tx.
  { exact (topology_has_X X Tx HTx). }
  claim HXN: X :e N.
  { exact (SepI Tx (fun U0:set => x :e U0) X HXTx HxX). }
  claim Hnetj0X: apply_fun net j0 :e X.
  { exact (Hfunnet j0 Hj0). }
  claim HkProd: (X,j0) :e setprod N J.
  { exact (tuple_2_setprod_by_pair_Sigma N J X j0 HXN Hj0). }
  claim Hk_in: apply_fun net ((X,j0) 1) :e (X,j0) 0.
  { rewrite (tuple_2_1_eq X j0).
    rewrite (tuple_2_0_eq X j0).
    exact Hnetj0X. }
  claim HkK: (X,j0) :e K.
  { exact (SepI (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) (X,j0) HkProd Hk_in). }
  witness (X,j0).
  apply andI.
  - exact HkK.
  - rewrite (apply_fun_graph K (fun k0:set => k0 1) (X,j0) HkK).
    rewrite (tuple_2_1_eq X j0).
    exact (Hrefl j0 Hj0). }

(** value relation: sub k = net (phi k) **)
claim Hvals: forall k:set, k :e K -> apply_fun sub k = apply_fun net (apply_fun phi k).
{ let k. assume HkK: k :e K.
  rewrite (apply_fun_graph K (fun k0:set => apply_fun net (k0 1)) k HkK).
  rewrite (apply_fun_graph K (fun k0:set => k0 1) k HkK).
  reflexivity. }

witness sub.
apply andI.
- (** subnet_of net sub **)
  prove subnet_of net sub.
  prove exists J0 leJ0 K0 leK0 X0 phi0:set,
    directed_set J0 leJ0 /\ directed_set K0 leK0 /\
    total_function_on net J0 X0 /\ functional_graph net /\
    total_function_on sub K0 X0 /\ functional_graph sub /\
    total_function_on phi0 K0 J0 /\ functional_graph phi0 /\
    graph_domain_subset net J0 /\ graph_domain_subset sub K0 /\ graph_domain_subset phi0 K0 /\
    (forall i j:set, i :e K0 -> j :e K0 -> (i,j) :e leK0 ->
      (apply_fun phi0 i, apply_fun phi0 j) :e leJ0) /\
    (forall j:set, j :e J0 -> exists k:set, k :e K0 /\ (j, apply_fun phi0 k) :e leJ0) /\
    (forall k:set, k :e K0 -> apply_fun sub k = apply_fun net (apply_fun phi0 k)).
  witness J.
  witness le.
  witness K.
  witness leK.
  witness X.
  witness phi.
  (** build the left-associated conjunction for subnet_of data **)
  apply and14I.
  - exact HdirJ.
  - exact HdirK.
  - exact Htotnet.
  - exact Hgraphnet.
  - exact Htotsub.
  - exact Hgraphsub.
  - exact Htotphi.
  - exact Hgraphphi.
  - exact Hdomnet.
  - exact Hdomsub.
  - exact Hdomphi.
  - exact Hmono.
  - exact Hcofinal.
  - exact Hvals.
- (** net_converges X Tx sub x **)
  prove net_converges X Tx sub x.
  prove exists J0 le0:set, topology_on X Tx /\ directed_set J0 le0 /\ total_function_on sub J0 X /\ functional_graph sub /\ graph_domain_subset sub J0 /\ x :e X /\
    forall U:set, U :e Tx -> x :e U ->
      exists i0:set, i0 :e J0 /\ forall i:set, i :e J0 -> (i0,i) :e le0 -> apply_fun sub i :e U.
	  witness K.
	  witness leK.
		  apply andI.
		  - (** core data **)
			    prove topology_on X Tx /\ directed_set K leK /\ total_function_on sub K X /\ functional_graph sub /\ graph_domain_subset sub K /\ x :e X.
			    apply and6I.
			    - exact HTx.
			    - exact HdirK.
			    - exact Htotsub.
			    - exact Hgraphsub.
			    - exact Hdomsub.
			    - exact HxX.
		  - (** eventuality from neighborhood shrinking **)
		    let U. assume HU: U :e Tx.
		    assume HxU: x :e U.
	    prove exists i0:set, i0 :e K /\ forall i:set, i :e K -> (i0,i) :e leK -> apply_fun sub i :e U.
    claim HJne: J <> Empty.
    { exact (directed_set_nonempty J le HdirJ). }
    claim Hexj0: exists j0:set, j0 :e J.
    { exact (nonempty_has_element J HJne). }
    apply Hexj0.
    let j0. assume Hj0: j0 :e J.
    claim Hexj: exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
    { exact (Hfreq U HU HxU j0 Hj0). }
	    apply Hexj.
	    let j.
	    assume HjPack: j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
	    claim Hj_left: j :e J /\ (j0,j) :e le.
	    { exact (andEL (j :e J /\ (j0,j) :e le) (apply_fun net j :e U) HjPack). }
	    claim HjJ: j :e J.
	    { exact (andEL (j :e J) ((j0,j) :e le) Hj_left). }
	    claim HnetjU: apply_fun net j :e U.
	    { exact (andER (j :e J /\ (j0,j) :e le) (apply_fun net j :e U) HjPack). }
    claim HUN: U :e N.
    { exact (SepI Tx (fun U0:set => x :e U0) U HU HxU). }
    claim Hi0Prod: (U,j) :e setprod N J.
    { exact (tuple_2_setprod_by_pair_Sigma N J U j HUN HjJ). }
    claim Hi0_in: apply_fun net ((U,j) 1) :e (U,j) 0.
    { rewrite (tuple_2_1_eq U j).
      rewrite (tuple_2_0_eq U j).
      exact HnetjU. }
    claim Hi0K: (U,j) :e K.
    { exact (SepI (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) (U,j) Hi0Prod Hi0_in). }
    witness (U,j).
    apply andI.
    + exact Hi0K.
    + let i. assume HiK: i :e K.
      assume Hi0i: ((U,j),i) :e leK.
      prove apply_fun sub i :e U.
      claim Hiprod: i :e setprod N J.
      { exact (SepE1 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) i HiK). }
      claim Hinet: apply_fun net (i 1) :e i 0.
      { exact (SepE2 (setprod N J) (fun p:set => apply_fun net (p 1) :e p 0) i HiK). }
      claim HsubU: (i 0) c= ((U,j) 0).
      { exact (andEL ((i 0) c= ((U,j) 0)) (((U,j) 1,(i 1)) :e le) (pair_order_pred K le (U,j) i Hi0i)). }
      claim HinetU: apply_fun net (i 1) :e ((U,j) 0).
      { exact (HsubU (apply_fun net (i 1)) Hinet). }
      rewrite (apply_fun_graph K (fun k0:set => apply_fun net (k0 1)) i HiK).
      rewrite <- (tuple_2_0_eq U j).
      exact HinetU.
Qed.

(** from exercises after §29: compactness via nets **) 
(** LATEX VERSION: Compactness characterized by every net having a convergent subnet. **)
		
(** helper: in a compact space, every net has an accumulation point **)
(** LATEX VERSION: Every net in a compact space has an accumulation point. **)
Theorem compact_space_net_has_accumulation_point : forall X Tx net:set,
  compact_space X Tx ->
  net_in_space X net ->
  exists x0:set, accumulation_point_of_net X Tx net x0.
let X Tx net.
assume Hcomp: compact_space X Tx.
assume Hnet: net_in_space X net.
prove exists x0:set, accumulation_point_of_net X Tx net x0.
(** Full proof is by the standard open-cover contradiction argument; we are currently only setting up the canonical witnesses. **)
apply Hnet.
let J. assume Hexle:
  exists le:set, directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.
apply Hexle.
let le. assume Hnetdata:
  directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J.
apply Hnetdata.
assume Hleft Hdomnet.
apply Hleft.
assume Hleft2 Hgraphnet.
apply Hleft2.
assume HdirJ Htotnet.

claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }

(** Standard proof strategy: if there is no accumulation point, pick for each x :e X an open neighborhood Ux and a threshold index jx such that the tail of the net avoids Ux; the chosen neighborhoods form an open cover with no finite subcover, contradicting compactness. **)
apply dneg.
assume Hno: ~(exists x0:set, accumulation_point_of_net X Tx net x0).
prove False.

set Bad := (fun x U j0:set =>
  U :e Tx /\ x :e U /\ j0 :e J /\ forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U)).

claim HexBad: forall x:set, x :e X -> exists U j0:set, Bad x U j0.
{ let x. assume HxX: x :e X.
  claim Hnacc: ~(accumulation_point_of_net X Tx net x).
  { claim Hall: forall x0:set, ~(accumulation_point_of_net X Tx net x0).
    { exact (not_ex_all_demorgan_i (fun x0:set => accumulation_point_of_net X Tx net x0) Hno). }
    exact (Hall x). }
  claim HnotForallU:
    ~(forall U:set, U :e Tx -> x :e U ->
      forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
    { assume HallU:
      forall U:set, U :e Tx -> x :e U ->
        forall j0:set, j0 :e J ->
          exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U.
    apply Hnacc.
    prove exists J0 le0:set,
      topology_on X Tx /\ directed_set J0 le0 /\ total_function_on net J0 X /\ functional_graph net /\ graph_domain_subset net J0 /\ x :e X /\
        forall U:set, U :e Tx -> x :e U ->
          forall j0:set, j0 :e J0 ->
            exists j:set, j :e J0 /\ (j0,j) :e le0 /\ apply_fun net j :e U.
    witness J. witness le.
    apply andI.
    - (** topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J /\ x :e X **)
      apply andI.
      + (** topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net /\ graph_domain_subset net J **)
        apply andI.
        * (** topology_on X Tx /\ directed_set J le /\ total_function_on net J X /\ functional_graph net **)
          apply andI.
          - (** topology_on X Tx /\ directed_set J le /\ total_function_on net J X **)
            apply andI.
            + (** topology_on X Tx /\ directed_set J le **)
              apply andI.
              * exact HTx.
              * exact HdirJ.
            + exact Htotnet.
          - exact Hgraphnet.
        * exact Hdomnet.
      + exact HxX.
    - exact HallU.
  }
  apply (not_all_ex_demorgan_i
           (fun U:set =>
             U :e Tx -> x :e U ->
               forall j0:set, j0 :e J ->
                 exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U)
           HnotForallU).
  let U. assume HnU:
    ~(U :e Tx -> x :e U ->
        forall j0:set, j0 :e J ->
          exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  claim HUa: U :e Tx /\ ~(x :e U ->
    forall j0:set, j0 :e J ->
      exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (not_imp (U :e Tx)
                   (x :e U ->
                     forall j0:set, j0 :e J ->
                       exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U)
                   HnU). }
  claim HUTx: U :e Tx.
  { exact (andEL (U :e Tx)
                 (~(x :e U ->
                   forall j0:set, j0 :e J ->
                     exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 HUa). }
  claim Hn2:
    ~(x :e U ->
      forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (andER (U :e Tx)
                 (~(x :e U ->
                   forall j0:set, j0 :e J ->
                     exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 HUa). }
  claim Hxb:
    x :e U /\
    ~(forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (not_imp (x :e U)
                   (forall j0:set, j0 :e J ->
                     exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U)
                   Hn2). }
  claim HxU: x :e U.
  { exact (andEL (x :e U)
                 (~(forall j0:set, j0 :e J ->
                   exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 Hxb). }
  claim HnForallj0:
    ~(forall j0:set, j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (andER (x :e U)
                 (~(forall j0:set, j0 :e J ->
                   exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 Hxb). }
  apply (not_all_ex_demorgan_i
           (fun j0:set =>
             j0 :e J ->
               exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U)
           HnForallj0).
  let j0. assume Hnj0:
    ~(j0 :e J ->
        exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  claim Hj0a:
    j0 :e J /\
    ~(exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (not_imp (j0 :e J)
                   (exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U)
                   Hnj0). }
  claim Hj0J: j0 :e J.
  { exact (andEL (j0 :e J)
                 (~(exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 Hj0a). }
  claim HnExj:
    ~(exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U).
  { exact (andER (j0 :e J)
                 (~(exists j:set, j :e J /\ (j0,j) :e le /\ apply_fun net j :e U))
                 Hj0a). }
  witness U. witness j0.
  prove ((U :e Tx /\ x :e U) /\ j0 :e J) /\
    forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
  apply andI.
  - (** U :e Tx /\ x :e U /\ j0 :e J **)
    apply andI.
    + (** U :e Tx /\ x :e U **)
      apply andI.
      * exact HUTx.
      * exact HxU.
    + exact Hj0J.
  - (** tail avoids U **)
    let j. assume HjJ: j :e J.
    assume Hj0j: (j0,j) :e le.
    prove ~(apply_fun net j :e U).
    assume HjU: apply_fun net j :e U.
    apply HnExj.
    witness j.
    apply andI.
    - apply andI.
      + exact HjJ.
      + exact Hj0j.
    - exact HjU. }

set pickpair := (fun x:set =>
  Eps_i (fun p:set =>
    p :e setprod Tx J /\ x :e (p 0) /\ (p 1) :e J /\
      forall j:set, j :e J -> ((p 1),j) :e le -> ~(apply_fun net j :e (p 0)))).

set Fam := {(pickpair x) 0|x :e X}.

claim Hcover: open_cover_of X Tx Fam.
{ claim HTsub: Tx c= Power X.
  { exact (topology_sub_Power X Tx HTx). }
  claim HpickBad: forall x:set, x :e X -> Bad x ((pickpair x) 0) ((pickpair x) 1).
  { let x. assume HxX: x :e X.
    claim HexUJ: exists U j0:set, Bad x U j0.
    { exact (HexBad x HxX). }
    apply HexUJ.
    let U. assume Hexj0: exists j0:set, Bad x U j0.
    apply Hexj0.
    let j0. assume Hbad: Bad x U j0.
    claim Hbadleft: (U :e Tx /\ x :e U) /\ j0 :e J.
    { exact (andEL ((U :e Tx /\ x :e U) /\ j0 :e J)
                   (forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                   Hbad). }
    claim HbadUx: U :e Tx /\ x :e U.
    { exact (andEL (U :e Tx /\ x :e U) (j0 :e J) Hbadleft). }
    claim HUTx: U :e Tx.
    { exact (andEL (U :e Tx) (x :e U) HbadUx). }
    claim HxU: x :e U.
    { exact (andER (U :e Tx) (x :e U) HbadUx). }
    claim Hj0J: j0 :e J.
    { exact (andER (U :e Tx /\ x :e U) (j0 :e J) Hbadleft). }
    claim Htail:
      forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
    { exact (andER ((U :e Tx /\ x :e U) /\ j0 :e J)
                   (forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                   Hbad). }
    claim Hp:
      (((U,j0) :e setprod Tx J /\ x :e ((U,j0) 0)) /\ ((U,j0) 1) :e J) /\
        forall j:set, j :e J -> (((U,j0) 1),j) :e le -> ~(apply_fun net j :e ((U,j0) 0)).
    { apply andI.
      - (** ( (U,j0) :e setprod Tx J /\ x :e ((U,j0) 0) ) /\ ((U,j0) 1) :e J **)
        apply andI.
        + (** (U,j0) :e setprod Tx J /\ x :e ((U,j0) 0) **)
          apply andI.
          * exact (tuple_2_setprod_by_pair_Sigma Tx J U j0 HUTx Hj0J).
          * rewrite (tuple_2_0_eq U j0).
            exact HxU.
        + rewrite (tuple_2_1_eq U j0).
          exact Hj0J.
      - (** tail avoids **)
        let j. assume HjJ: j :e J. assume Hj0j: (((U,j0) 1),j) :e le.
        prove ~(apply_fun net j :e ((U,j0) 0)).
        claim Hj0j': (j0,j) :e le.
        { rewrite <- (tuple_2_1_eq U j0).
          exact Hj0j. }
        rewrite (tuple_2_0_eq U j0).
        exact (Htail j HjJ Hj0j'). }
    claim Hprop: Bad x ((pickpair x) 0) ((pickpair x) 1) /\
      pickpair x :e setprod Tx J.
    { claim Hpa: pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0) /\ ((pickpair x) 1) :e J /\
        forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)).
      { exact (Eps_i_ax
                 (fun p:set =>
                   p :e setprod Tx J /\ x :e (p 0) /\ (p 1) :e J /\
                     forall j:set, j :e J -> ((p 1),j) :e le -> ~(apply_fun net j :e (p 0)))
                 (U,j0) Hp). }
      claim HpaL: (pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J.
      { exact (andEL ((pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J)
                     (forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                     Hpa). }
      claim HpaA: pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0).
      { exact (andEL (pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0))
                     (((pickpair x) 1) :e J)
                     HpaL). }
      claim Hpp: pickpair x :e setprod Tx J.
      { exact (andEL (pickpair x :e setprod Tx J)
                     (x :e ((pickpair x) 0))
                     HpaA). }
      claim HUx': ((pickpair x) 0) :e Tx.
      { exact (ap0_Sigma Tx (fun _ : set => J) (pickpair x) Hpp). }
      claim HxU': x :e ((pickpair x) 0).
      { exact (andER (pickpair x :e setprod Tx J)
                     (x :e ((pickpair x) 0))
                     HpaA). }
      claim Hj0': ((pickpair x) 1) :e J.
      { exact (andER (pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0))
                     (((pickpair x) 1) :e J)
                     HpaL). }
      claim Htail':
        forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)).
      { exact (andER ((pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J)
                     (forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                     Hpa). }
      claim Hbad':
        Bad x ((pickpair x) 0) ((pickpair x) 1).
      { exact (andI (((((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J))
                    (forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                    (andI (((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0))
                          (((pickpair x) 1) :e J)
                          (andI (((pickpair x) 0) :e Tx)
                                (x :e ((pickpair x) 0))
                                HUx'
                                HxU')
                          Hj0')
                    Htail'). }
      exact (andI (Bad x ((pickpair x) 0) ((pickpair x) 1))
                  (pickpair x :e setprod Tx J)
                  Hbad'
                  Hpp). }
    exact (andEL (Bad x ((pickpair x) 0) ((pickpair x) 1))
                 (pickpair x :e setprod Tx J)
                 Hprop). }
  prove ((topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam) /\
    (forall U:set, U :e Fam -> U :e Tx).
  apply andI.
  - (** (topology_on X Tx /\ Fam c= Power X) /\ X c= Union Fam **)
    apply andI.
    + (** topology_on X Tx /\ Fam c= Power X **)
      apply andI.
      * exact HTx.
      * (** Fam c= Power X **)
        let U. assume HU: U :e Fam.
        prove U :e Power X.
        apply PowerI.
        let y. assume Hy: y :e U.
        prove y :e X.
        claim Hexx: exists x:set, x :e X /\ U = ((pickpair x) 0).
        { exact (ReplE X (fun x0:set => ((pickpair x0) 0)) U HU). }
        apply Hexx.
        let x. assume HxU:
          x :e X /\ U = ((pickpair x) 0).
        claim HxX: x :e X.
        { exact (andEL (x :e X) (U = ((pickpair x) 0)) HxU). }
        claim HUeq: U = ((pickpair x) 0).
        { exact (andER (x :e X) (U = ((pickpair x) 0)) HxU). }
        claim HUtx: U :e Tx.
        { rewrite HUeq.
          claim HpbL: (((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J.
          { exact (andEL ((((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J)
                         (forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                         (HpickBad x HxX)). }
          claim HpbUx: ((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0).
          { exact (andEL (((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0))
                         (((pickpair x) 1) :e J)
                         HpbL). }
          exact (andEL (((pickpair x) 0) :e Tx)
                       (x :e ((pickpair x) 0))
                       HpbUx). }
        claim HUpow: U :e Power X.
        { exact (HTsub U HUtx). }
        exact (PowerE X U HUpow y Hy).
    + (** X c= Union Fam **)
      let y. assume HyX: y :e X.
      prove y :e Union Fam.
      claim HUy: y :e ((pickpair y) 0).
      { claim HpbL: (((pickpair y) 0) :e Tx /\ y :e ((pickpair y) 0)) /\ ((pickpair y) 1) :e J.
        { exact (andEL ((((pickpair y) 0) :e Tx /\ y :e ((pickpair y) 0)) /\ ((pickpair y) 1) :e J)
                       (forall j:set, j :e J -> (((pickpair y) 1),j) :e le -> ~(apply_fun net j :e ((pickpair y) 0)))
                       (HpickBad y HyX)). }
        claim HpbUx: ((pickpair y) 0) :e Tx /\ y :e ((pickpair y) 0).
        { exact (andEL (((pickpair y) 0) :e Tx /\ y :e ((pickpair y) 0))
                       (((pickpair y) 1) :e J)
                       HpbL). }
        exact (andER (((pickpair y) 0) :e Tx)
                     (y :e ((pickpair y) 0))
                     HpbUx). }
      claim HUyFam: ((pickpair y) 0) :e Fam.
      { exact (ReplI X (fun x0:set => ((pickpair x0) 0)) y HyX). }
      exact (UnionI Fam y ((pickpair y) 0) HUy HUyFam).
  - (** forall U:set, U :e Fam -> U :e Tx **)
    let U. assume HU: U :e Fam.
    prove U :e Tx.
    claim Hexx: exists x:set, x :e X /\ U = ((pickpair x) 0).
    { exact (ReplE X (fun x0:set => ((pickpair x0) 0)) U HU). }
    apply Hexx.
    let x. assume HxU:
      x :e X /\ U = ((pickpair x) 0).
    claim HxX: x :e X.
    { exact (andEL (x :e X) (U = ((pickpair x) 0)) HxU). }
    claim HUeq: U = ((pickpair x) 0).
    { exact (andER (x :e X) (U = ((pickpair x) 0)) HxU). }
    rewrite HUeq.
    claim HpbL: (((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J.
    { exact (andEL ((((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0)) /\ ((pickpair x) 1) :e J)
                   (forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                   (HpickBad x HxX)). }
    claim HpbUx: ((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0).
    { exact (andEL (((pickpair x) 0) :e Tx /\ x :e ((pickpair x) 0))
                   (((pickpair x) 1) :e J)
                   HpbL). }
    exact (andEL (((pickpair x) 0) :e Tx)
                 (x :e ((pickpair x) 0))
                 HpbUx). }

claim HfinFam: has_finite_subcover X Tx Fam.
{ exact (compact_space_subcover_property X Tx Hcomp Fam Hcover). }

claim HnofinFam: ~(has_finite_subcover X Tx Fam).
{ assume Hfin: has_finite_subcover X Tx Fam.
  apply Hfin.
  let G. assume HGpack: G c= Fam /\ finite G /\ X c= Union G.
  claim HGleft: G c= Fam /\ finite G.
  { exact (andEL (G c= Fam /\ finite G)
                 (X c= Union G)
                 HGpack). }
  claim HGsub: G c= Fam.
  { exact (andEL (G c= Fam)
                 (finite G)
                 HGleft). }
  claim HGfin: finite G.
  { exact (andER (G c= Fam)
                 (finite G)
                 HGleft). }
  claim HGcov: X c= Union G.
  { exact (andER (G c= Fam /\ finite G)
                 (X c= Union G)
                 HGpack). }

  claim Hpo: partial_order_on J le.
  { claim Hleft: J <> Empty /\ partial_order_on J le.
    { exact (andEL (J <> Empty /\ partial_order_on J le)
                   (forall a b:set, a :e J -> b :e J ->
                     exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le)
                   HdirJ). }
    exact (andER (J <> Empty) (partial_order_on J le) Hleft). }

	  claim Hrefl: forall a:set, a :e J -> (a,a) :e le.
	  { exact (partial_order_on_refl J le Hpo). }

	  claim Htrans: forall a b c:set, a :e J -> b :e J -> c :e J -> (a,b) :e le -> (b,c) :e le -> (a,c) :e le.
	  { exact (partial_order_on_trans J le Hpo). }

  claim Hpickpair_prop: forall x:set, x :e X ->
    pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0) /\ ((pickpair x) 1) :e J /\
      forall j:set, j :e J -> (((pickpair x) 1),j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)).
  { let x. assume HxX: x :e X.
    claim HexUJ: exists U j0:set, Bad x U j0.
    { exact (HexBad x HxX). }
    apply HexUJ.
    let U. assume Hexj0: exists j0:set, Bad x U j0.
    apply Hexj0.
    let j0. assume Hbad: Bad x U j0.
    claim Hbadleft: (U :e Tx /\ x :e U) /\ j0 :e J.
    { exact (andEL ((U :e Tx /\ x :e U) /\ j0 :e J)
                   (forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                   Hbad). }
    claim HbadUx: U :e Tx /\ x :e U.
    { exact (andEL (U :e Tx /\ x :e U) (j0 :e J) Hbadleft). }
    claim HUTx: U :e Tx.
    { exact (andEL (U :e Tx) (x :e U) HbadUx). }
    claim HxU: x :e U.
    { exact (andER (U :e Tx) (x :e U) HbadUx). }
    claim Hj0J: j0 :e J.
    { exact (andER (U :e Tx /\ x :e U) (j0 :e J) Hbadleft). }
    claim Htail:
      forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
    { exact (andER ((U :e Tx /\ x :e U) /\ j0 :e J)
                   (forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                   Hbad). }
    claim Hp:
      (((U,j0) :e setprod Tx J /\ x :e ((U,j0) 0)) /\ ((U,j0) 1) :e J) /\
        forall j:set, j :e J -> (((U,j0) 1),j) :e le -> ~(apply_fun net j :e ((U,j0) 0)).
    { apply andI.
      - apply andI.
        + apply andI.
          * exact (tuple_2_setprod_by_pair_Sigma Tx J U j0 HUTx Hj0J).
          * rewrite (tuple_2_0_eq U j0).
            exact HxU.
        + rewrite (tuple_2_1_eq U j0).
          exact Hj0J.
      - let j. assume HjJ: j :e J. assume Hj0j: (((U,j0) 1),j) :e le.
        prove ~(apply_fun net j :e ((U,j0) 0)).
        claim Hj0j': (j0,j) :e le.
        { rewrite <- (tuple_2_1_eq U j0).
          exact Hj0j. }
        rewrite (tuple_2_0_eq U j0).
        exact (Htail j HjJ Hj0j'). }
    exact (Eps_i_ax
             (fun p:set =>
               p :e setprod Tx J /\ x :e (p 0) /\ (p 1) :e J /\
                 forall j:set, j :e J -> ((p 1),j) :e le -> ~(apply_fun net j :e (p 0)))
             (U,j0)
             Hp). }

  set P := (fun G0:set =>
    G0 c= Fam ->
    exists j0:set, j0 :e J /\
      forall U:set, U :e G0 ->
        forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U)).

  claim HP0: P Empty.
  { assume _: Empty c= Fam.
    claim HJne: J <> Empty.
    { exact (directed_set_nonempty J le HdirJ). }
    apply (nonempty_has_element J HJne).
    let j0. assume Hj0J: j0 :e J.
    witness j0.
    apply andI.
    - exact Hj0J.
    - let U. assume HU: U :e Empty.
      apply FalseE.
      exact ((EmptyE U) HU). }

  claim HPstep: forall X0 y:set, finite X0 -> y /:e X0 -> P X0 -> P (X0 :\/: {y}).
  { let X0 y.
    assume HX0fin: finite X0.
    assume HyX0: y /:e X0.
    assume IH: P X0.
    assume HsubAll: (X0 :\/: {y}) c= Fam.
    claim HX0sub: X0 c= Fam.
    { let U. assume HU: U :e X0.
      claim HUb: U :e (X0 :\/: {y}).
      { exact (binunionI1 X0 {y} U HU). }
      exact (HsubAll U HUb). }
    claim HyFam: y :e Fam.
    { claim Hyin: y :e (X0 :\/: {y}).
      { exact (binunionI2 X0 {y} y (SingI y)). }
      exact (HsubAll y Hyin). }
    apply (IH HX0sub).
    let jX. assume HjXpack:
      jX :e J /\
        forall U:set, U :e X0 ->
          forall j:set, j :e J -> (jX,j) :e le -> ~(apply_fun net j :e U).
    claim HjXJ: jX :e J.
    { exact (andEL (jX :e J)
                   (forall U:set, U :e X0 -> forall j:set, j :e J -> (jX,j) :e le -> ~(apply_fun net j :e U))
                   HjXpack). }
    claim HtailX0:
      forall U:set, U :e X0 -> forall j:set, j :e J -> (jX,j) :e le -> ~(apply_fun net j :e U).
    { exact (andER (jX :e J)
                   (forall U:set, U :e X0 -> forall j:set, j :e J -> (jX,j) :e le -> ~(apply_fun net j :e U))
                   HjXpack). }
    claim Hexx: exists x:set, x :e X /\ y = ((pickpair x) 0).
    { exact (ReplE X (fun x0:set => ((pickpair x0) 0)) y HyFam). }
    apply Hexx.
    let x. assume Hxpack: x :e X /\ y = ((pickpair x) 0).
    claim HxX: x :e X.
    { exact (andEL (x :e X) (y = ((pickpair x) 0)) Hxpack). }
    claim HyEq: y = ((pickpair x) 0).
    { exact (andER (x :e X) (y = ((pickpair x) 0)) Hxpack). }
    set jY := ((pickpair x) 1).
    claim HjYJ: jY :e J.
    { claim Hpa: pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0) /\ jY :e J /\
        forall j:set, j :e J -> (jY,j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)).
      { exact (Hpickpair_prop x HxX). }
      claim HpaL: (pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ jY :e J.
      { exact (andEL ((pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ jY :e J)
                     (forall j:set, j :e J -> (jY,j) :e le -> ~(apply_fun net j :e ((pickpair x) 0)))
                     Hpa). }
      exact (andER (pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) (jY :e J) HpaL). }
    claim HtailY:
      forall j:set, j :e J -> (jY,j) :e le -> ~(apply_fun net j :e y).
    { let j. assume HjJ: j :e J. assume HjYj: (jY,j) :e le.
      prove ~(apply_fun net j :e y).
      rewrite HyEq.
      claim Hpa: pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0) /\ jY :e J /\
        forall j0:set, j0 :e J -> (jY,j0) :e le -> ~(apply_fun net j0 :e ((pickpair x) 0)).
      { exact (Hpickpair_prop x HxX). }
      exact ((andER ((pickpair x :e setprod Tx J /\ x :e ((pickpair x) 0)) /\ jY :e J)
                    (forall j0:set, j0 :e J -> (jY,j0) :e le -> ~(apply_fun net j0 :e ((pickpair x) 0)))
                    Hpa) j HjJ HjYj). }
    claim Hexub: exists j0:set, j0 :e J /\ (jX,j0) :e le /\ (jY,j0) :e le.
    { exact (directed_set_upper_bound_property J le HdirJ jX jY HjXJ HjYJ). }
    apply Hexub.
    let j0. assume Hj0pack: j0 :e J /\ (jX,j0) :e le /\ (jY,j0) :e le.
    claim Hj0left: j0 :e J /\ (jX,j0) :e le.
    { exact (andEL (j0 :e J /\ (jX,j0) :e le)
                   ((jY,j0) :e le)
                   Hj0pack). }
    claim Hj0J: j0 :e J.
    { exact (andEL (j0 :e J)
                   ((jX,j0) :e le)
                   Hj0left). }
    claim HjXj0: (jX,j0) :e le.
    { exact (andER (j0 :e J)
                   ((jX,j0) :e le)
                   Hj0left). }
    claim HjYj0: (jY,j0) :e le.
    { exact (andER (j0 :e J /\ (jX,j0) :e le)
                   ((jY,j0) :e le)
                   Hj0pack). }
    witness j0.
    apply andI.
    - exact Hj0J.
    - let U. assume HU: U :e (X0 :\/: {y}).
      prove forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
      apply (binunionE' X0 {y} U
               (forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))).
      + assume HUx0: U :e X0.
        let j. assume HjJ: j :e J. assume Hj0j: (j0,j) :e le.
        prove ~(apply_fun net j :e U).
        claim HjXj: (jX,j) :e le.
        { exact (Htrans jX j0 j HjXJ Hj0J HjJ HjXj0 Hj0j). }
        exact (HtailX0 U HUx0 j HjJ HjXj).
      + assume HUy: U :e {y}.
        claim HUeq: U = y.
        { exact (SingE y U HUy). }
        rewrite HUeq.
        let j. assume HjJ: j :e J. assume Hj0j: (j0,j) :e le.
        prove ~(apply_fun net j :e y).
        claim HjYj: (jY,j) :e le.
        { exact (Htrans jY j0 j HjYJ Hj0J HjJ HjYj0 Hj0j). }
        exact (HtailY j HjJ HjYj).
      + exact HU. }

  claim HPG: P G.
  { exact (finite_ind P HP0 HPstep G HGfin). }

  apply (HPG HGsub).
  let j0. assume Hj0pack: j0 :e J /\
    forall U:set, U :e G -> forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
  claim Hj0J: j0 :e J.
  { exact (andEL (j0 :e J)
                 (forall U:set, U :e G -> forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                 Hj0pack). }
  claim HavoidG:
    forall U:set, U :e G -> forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U).
  { exact (andER (j0 :e J)
                 (forall U:set, U :e G -> forall j:set, j :e J -> (j0,j) :e le -> ~(apply_fun net j :e U))
                 Hj0pack). }

  claim HnotUnion: ~(apply_fun net j0 :e Union G).
  { assume Hmem: apply_fun net j0 :e Union G.
    apply (UnionE G (apply_fun net j0) Hmem).
    let U. assume HU: apply_fun net j0 :e U /\ U :e G.
    claim HUin: U :e G.
    { exact (andER (apply_fun net j0 :e U) (U :e G) HU). }
    claim Hrefl0: (j0,j0) :e le.
    { exact (Hrefl j0 Hj0J). }
    exact ((HavoidG U HUin j0 Hj0J Hrefl0) (andEL (apply_fun net j0 :e U) (U :e G) HU)). }

  claim Hnetj0X: apply_fun net j0 :e X.
  { exact (total_function_on_apply_fun_in_Y net J X j0 Htotnet Hj0J). }
  exact (HnotUnion (HGcov (apply_fun net j0) Hnetj0X)). }

exact (HnofinFam HfinFam).
Qed.

(** helper: finite subcollections are directed by inclusion **)
(** LATEX VERSION: (auxiliary) Finite subcollections of S form a directed set under subset inclusion, with upper bound given by union. **)
Theorem finite_subcollections_directed_by_subset : forall S:set,
  directed_set (finite_subcollections S)
    (inclusion_rel (finite_subcollections S)).
let S.
set J := finite_subcollections S.
set le := inclusion_rel J.
prove directed_set J le.
prove (J <> Empty /\ partial_order_on J le) /\
  forall a b:set, a :e J -> b :e J -> exists c:set, c :e J /\ (a,c) :e le /\ (b,c) :e le.
apply andI.
- (** J <> Empty /\ partial_order_on J le **)
  apply andI.
  + (** J <> Empty **)
    assume HJemp: J = Empty.
    claim HEmptyPow: Empty :e Power S.
    { exact (Empty_In_Power S). }
    claim HEmptyFin: finite Empty.
    { exact finite_Empty. }
    claim HEmptyJ: Empty :e J.
    { exact (SepI (Power S) (fun F0:set => finite F0) Empty HEmptyPow HEmptyFin). }
    claim HEmptyIn: Empty :e Empty.
    { rewrite <- HJemp at 2. exact HEmptyJ. }
    exact (EmptyE Empty HEmptyIn).
  + (** partial_order_on J le **)
    prove partial_order_on J le.
    prove relation_on le J /\
      (forall a:set, a :e J -> (a,a) :e le) /\
      (forall a b:set, a :e J -> b :e J -> (a,b) :e le -> (b,a) :e le -> a = b) /\
      (forall a b c:set, a :e J -> b :e J -> c :e J -> (a,b) :e le -> (b,c) :e le -> (a,c) :e le).
    apply andI.
    - (** (relation_on /\ refl) /\ antisym **)
      apply andI.
      + (** relation_on /\ refl **)
        apply andI.
	        - (** relation_on le J **)
	          prove relation_on le J.
	          let a b. assume Hab: (a,b) :e le.
	          prove a :e J /\ b :e J.
	          claim Hprod: (a,b) :e setprod J J.
	          { exact (andEL ((a,b) :e setprod J J) (a c= b) (inclusion_relE J a b Hab)). }
	          claim Ha0: (a,b) 0 :e J.
	          { exact (ap0_Sigma J (fun _ : set => J) (a,b) Hprod). }
	          claim Hb1: (a,b) 1 :e J.
          { exact (ap1_Sigma J (fun _ : set => J) (a,b) Hprod). }
          apply andI.
          + rewrite <- (tuple_2_0_eq a b). exact Ha0.
          + rewrite <- (tuple_2_1_eq a b). exact Hb1.
	        - (** reflexive **)
	          let a. assume HaJ: a :e J.
	          prove (a,a) :e le.
	          apply (inclusion_relI J a a).
	          + exact (tuple_2_setprod_by_pair_Sigma J J a a HaJ HaJ).
	          + exact (Subq_ref a).
      + (** antisymmetric **)
        let a b. assume HaJ: a :e J. assume HbJ: b :e J.
	        assume Hab: (a,b) :e le.
	        assume Hba: (b,a) :e le.
	        prove a = b.
	        claim Habsub: a c= b.
	        { exact (andER ((a,b) :e setprod J J) (a c= b) (inclusion_relE J a b Hab)). }
	        claim Hbasub: b c= a.
	        { exact (andER ((b,a) :e setprod J J) (b c= a) (inclusion_relE J b a Hba)). }
	        apply set_ext.
	        - let x. assume Hx: x :e a. exact (Habsub x Hx).
	        - let x. assume Hx: x :e b. exact (Hbasub x Hx).
    - (** transitive **)
      let a b c.
      assume HaJ: a :e J. assume HbJ: b :e J. assume HcJ: c :e J.
	      assume Hab: (a,b) :e le.
	      assume Hbc: (b,c) :e le.
	      prove (a,c) :e le.
	      claim Habsub: a c= b.
	      { exact (andER ((a,b) :e setprod J J) (a c= b) (inclusion_relE J a b Hab)). }
	      claim Hbcsub: b c= c.
	      { exact (andER ((b,c) :e setprod J J) (b c= c) (inclusion_relE J b c Hbc)). }
	      claim Hacsub: a c= c.
	      { exact (Subq_tra a b c Habsub Hbcsub). }
	      apply (inclusion_relI J a c).
	      + exact (tuple_2_setprod_by_pair_Sigma J J a c HaJ HcJ).
	      + exact Hacsub.
- (** upper bound property **)
  let a b.
  assume HaJ: a :e J.
  assume HbJ: b :e J.
  witness (a :\/: b).
  prove (a :\/: b) :e J /\ (a, a :\/: b) :e le /\ (b, a :\/: b) :e le.
  claim HabJ: (a :\/: b) :e J.
  { claim HaPow: a :e Power S.
    { exact (SepE1 (Power S) (fun F0:set => finite F0) a HaJ). }
    claim HbPow: b :e Power S.
    { exact (SepE1 (Power S) (fun F0:set => finite F0) b HbJ). }
    claim HaSub: a c= S.
    { exact (PowerE S a HaPow). }
    claim HbSub: b c= S.
    { exact (PowerE S b HbPow). }
    claim HabSub: (a :\/: b) c= S.
    { exact (binunion_Subq_min a b S HaSub HbSub). }
    claim HabPow: (a :\/: b) :e Power S.
    { exact (PowerI S (a :\/: b) HabSub). }
    claim HaFin: finite a.
    { exact (SepE2 (Power S) (fun F0:set => finite F0) a HaJ). }
    claim HbFin: finite b.
    { exact (SepE2 (Power S) (fun F0:set => finite F0) b HbJ). }
    claim HabFin: finite (a :\/: b).
    { exact (binunion_finite a HaFin b HbFin). }
    exact (SepI (Power S) (fun F0:set => finite F0) (a :\/: b) HabPow HabFin). }
  (** conjunction is left-associative: (A /\ B) /\ C **)
  apply andI.
  + (** A /\ B **)
    apply andI.
	    - exact HabJ.
	    - (** (a, a :\/: b) :e le **)
	      apply (inclusion_relI J a (a :\/: b)).
	      + exact (tuple_2_setprod_by_pair_Sigma J J a (a :\/: b) HaJ HabJ).
	      + exact (binunion_Subq_1 a b).
	  + (** (b, a :\/: b) :e le **)
	    apply (inclusion_relI J b (a :\/: b)).
	    - exact (tuple_2_setprod_by_pair_Sigma J J b (a :\/: b) HbJ HabJ).
	    - exact (binunion_Subq_2 a b).
Qed.

(** helper: a cover with no finite subcover yields a net with no convergent subnet **)
(** LATEX VERSION: If an open cover has no finite subcover, one can build a net witnessing non-compactness (no convergent subnet). **)
Theorem open_cover_no_finite_subcover_implies_net_counterexample : forall X Tx Fam:set,
  topology_on X Tx ->
  open_cover_of X Tx Fam ->
  ~(has_finite_subcover X Tx Fam) ->
  exists net0:set,
    net_in_space X net0 /\
    (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x)).
let X Tx Fam.
assume HTx: topology_on X Tx.
assume Hcover: open_cover_of X Tx Fam.
assume Hnofin: ~(has_finite_subcover X Tx Fam).
prove exists net0:set,
  net_in_space X net0 /\
  (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x)).
(** Standard construction: index set = finite subcollections of Fam ordered by inclusion; net chooses a point not covered by the finite union. **)
(** NOTE: The robust, order-explicit nonconvergence statement is proved as `open_cover_no_finite_subcover_implies_net_counterexample_witnessed` below. **)

set J := finite_subcollections Fam.
set le := inclusion_rel J.

set pickx := (fun F:set =>
  Eps_i (fun x:set => x :e X /\ ~(x :e Union F))).

set net0 := graph J pickx.

claim Hnet0: net_in_space X net0.
{ prove net_in_space X net0.
  prove exists J0 le0:set, directed_set J0 le0 /\ total_function_on net0 J0 X /\ functional_graph net0 /\ graph_domain_subset net0 J0.
  witness J.
  witness le.
  prove directed_set J le /\ total_function_on net0 J X /\ functional_graph net0 /\ graph_domain_subset net0 J.
  apply andI.
  - prove directed_set J le /\ total_function_on net0 J X /\ functional_graph net0.
    apply andI.
    + prove directed_set J le /\ total_function_on net0 J X.
      apply andI.
      * (** directed_set J le **)
        exact (finite_subcollections_directed_by_subset Fam).
      * (** total_function_on net0 J X **)
        claim Hpick_in: forall F:set, F :e J -> pickx F :e X.
        { let F. assume HFJ: F :e J.
          prove pickx F :e X.
          claim HFpow: F :e Power Fam.
          { exact (SepE1 (Power Fam) (fun F0:set => finite F0) F HFJ). }
          claim HFfin: finite F.
          { exact (SepE2 (Power Fam) (fun F0:set => finite F0) F HFJ). }
          claim HFsub: F c= Fam.
          { exact (PowerE Fam F HFpow). }
          claim Hnotcov: ~(X c= Union F).
          { assume Hcov: X c= Union F.
            apply Hnofin.
            apply (has_finite_subcoverI X Tx Fam F).
            apply andI.
            - apply andI.
              + exact HFsub.
              + exact HFfin.
            - exact Hcov. }
          claim Hexx: exists x:set, x :e X /\ ~(x :e Union F).
          { claim Hex': exists x:set, ~(x :e X -> x :e Union F).
            { exact (not_all_ex_demorgan_i (fun x:set => x :e X -> x :e Union F) Hnotcov). }
            apply Hex'.
            let x. assume Hnx: ~(x :e X -> x :e Union F).
            witness x.
            exact (not_imp (x :e X) (x :e Union F) Hnx). }
          apply Hexx.
          let x. assume Hx: x :e X /\ ~(x :e Union F).
          claim Hprop: pickx F :e X /\ ~(pickx F :e Union F).
          { exact (Eps_i_ax (fun x0:set => x0 :e X /\ ~(x0 :e Union F)) x Hx). }
          exact (andEL (pickx F :e X) (~(pickx F :e Union F)) Hprop). }
        exact (total_function_on_graph J X pickx Hpick_in).
    + (** functional_graph net0 **)
      exact (functional_graph_graph J pickx).
  - (** graph_domain_subset net0 J **)
    exact (graph_domain_subset_graph J pickx).
}

claim Hnosub: forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x).
{ let sub x.
  assume Hsubnet: subnet_of net0 sub.
  prove ~(net_converges X Tx sub x).
  assume Hconv: net_converges X Tx sub x.
  prove False.

  (** unpack subnet witness **)
  apply Hsubnet.
  let Jsub. assume Hex1.
  apply Hex1.
  let leJ. assume Hex2.
  apply Hex2.
  let K. assume Hex3.
  apply Hex3.
  let leK. assume Hex4.
  apply Hex4.
  let X0. assume Hex5.
  apply Hex5.
  let phi. assume Hsubdata.

  apply Hsubdata. assume Hcore Hvals.
  apply Hcore. assume Hcore12 Hcofinal.
  apply Hcore12. assume Hcore11 Hmono.
  apply Hcore11. assume Hcore10 Hdomphi.
  apply Hcore10. assume Hcore9 Hdomsub.
  apply Hcore9. assume Hcore8 Hdomnet.
  apply Hcore8. assume Hcore7 Hgraphphi.
  apply Hcore7. assume Hcore6 Htotphi.
  apply Hcore6. assume Hcore5 Hgraphsub.
  apply Hcore5. assume Hcore4 Htotsub.
  apply Hcore4. assume Hcore3 Hgraphnet.
  apply Hcore3. assume Hcore2 Htotnet.
  apply Hcore2. assume HdirJ HdirK.

  (** show Jsub equals the original index set J for net0 **)
  claim Hdomnet0J: graph_domain_subset net0 J.
  { exact (graph_domain_subset_graph J pickx). }
  claim HJsubSubJ: Jsub c= J.
  { let F. assume HF: F :e Jsub.
    prove F :e J.
    claim Hexy: exists y:set, y :e X0 /\ (F,y) :e net0.
    { exact (andER (function_on net0 Jsub X0)
                   (forall a:set, a :e Jsub -> exists y:set, y :e X0 /\ (a,y) :e net0)
                   Htotnet F HF). }
    apply Hexy.
    let y. assume Hy.
    exact (Hdomnet0J F y (andER (y :e X0) ((F,y) :e net0) Hy)). }
  claim HJSubJsub: J c= Jsub.
  { let F. assume HF: F :e J.
    prove F :e Jsub.
    claim Hpair: (F, pickx F) :e net0.
    { exact (ReplI J (fun F0:set => (F0, pickx F0)) F HF). }
    exact (Hdomnet F (pickx F) Hpair). }
  claim HJeq: Jsub = J.
  { apply set_ext.
    - let z. assume Hz: z :e Jsub.
      exact (HJsubSubJ z Hz).
    - let z. assume Hz: z :e J.
      exact (HJSubJsub z Hz). }

  (** unpack convergence data for sub **)
  apply Hconv.
  let Jc. assume Hexc1.
  apply Hexc1.
  let leC. assume Hcpack.

  apply Hcpack. assume HcCore HcTail.
  apply HcCore. assume HcCore6 HxX.
  apply HcCore6. assume HcCore5 HdomC.
  apply HcCore5. assume HcCore4 HgraphC.
  apply HcCore4. assume HcCore3 HtotC.
  apply HcCore3. assume HcCore2 HdirC.
  apply HcCore2. assume HtopC.

  (** identify convergence domain with K from subnet witness **)
  claim HJcSubK: Jc c= K.
  { let j. assume Hj: j :e Jc.
    prove j :e K.
    claim Hexy: exists y:set, y :e X /\ (j,y) :e sub.
    { exact (andER (function_on sub Jc X)
                   (forall a:set, a :e Jc -> exists y:set, y :e X /\ (a,y) :e sub)
                   HtotC j Hj). }
    apply Hexy.
    let y. assume Hy.
    exact (Hdomsub j y (andER (y :e X) ((j,y) :e sub) Hy)). }
  claim HKSubJc: K c= Jc.
  { let k. assume Hk: k :e K.
    prove k :e Jc.
    claim Hexy: exists y:set, y :e X0 /\ (k,y) :e sub.
    { exact (andER (function_on sub K X0)
                   (forall a:set, a :e K -> exists y:set, y :e X0 /\ (a,y) :e sub)
                   Htotsub k Hk). }
    apply Hexy.
    let y. assume Hy.
    exact (HdomC k y (andER (y :e X0) ((k,y) :e sub) Hy)). }
  claim HJcEq: Jc = K.
  { apply set_ext.
    - let z. assume Hz: z :e Jc.
      exact (HJcSubK z Hz).
    - let z. assume Hz: z :e K.
      exact (HKSubJc z Hz). }

  (** choose U in Fam with x in U **)
  claim HcovX: X c= Union Fam.
  { exact (open_cover_of_covers X Tx Fam Hcover). }
  claim HxUnion: x :e Union Fam.
  { exact (HcovX x HxX). }
  claim HexU: exists U:set, x :e U /\ U :e Fam.
  { exact (UnionE Fam x HxUnion). }
  apply HexU.
  let U.
  assume HU.
  claim HxU: x :e U.
  { exact (andEL (x :e U) (U :e Fam) HU). }
  claim HUFam: U :e Fam.
  { exact (andER (x :e U) (U :e Fam) HU). }
  claim HUopen: U :e Tx.
  { exact (open_cover_of_members_open X Tx Fam U Hcover HUFam). }

  (** convergence tail index i0 for neighborhood U **)
  claim Hexi0Jc: exists i0:set, i0 :e Jc /\
    forall i:set, i :e Jc -> (i0,i) :e leC -> apply_fun sub i :e U.
  { exact (HcTail U HUopen HxU). }
  apply Hexi0Jc.
  let i0.
  assume Hi0pack.
  claim Hi0Jc: i0 :e Jc.
  { exact (andEL (i0 :e Jc) (forall i:set, i :e Jc -> (i0,i) :e leC -> apply_fun sub i :e U) Hi0pack). }
  claim HafterJc:
    forall i:set, i :e Jc -> (i0,i) :e leC -> apply_fun sub i :e U.
  { exact (andER (i0 :e Jc) (forall i:set, i :e Jc -> (i0,i) :e leC -> apply_fun sub i :e U) Hi0pack). }
  claim Hi0K: i0 :e K.
  { exact (HJcSubK i0 Hi0Jc). }
  claim HafterC:
    forall i:set, i :e K -> (i0,i) :e leC -> apply_fun sub i :e U.
  { let i. assume HiK: i :e K.
    assume Hi0i: (i0,i) :e leC.
    claim HiJc: i :e Jc.
    { exact (HKSubJc i HiK). }
    exact (HafterJc i HiJc Hi0i). }

  (** build a finite subcollection containing U **)
  set FU := {U}.
  claim HFUSub: FU c= Fam.
  { let V. assume HV: V :e FU.
    claim HVeq: V = U.
    { exact (SingE U V HV). }
    rewrite HVeq.
    exact HUFam. }
  claim HFUFin: finite FU.
  { exact (Sing_finite U). }
  claim HFUPow: FU :e Power Fam.
  { exact (PowerI Fam FU HFUSub). }
  claim HFUJ: FU :e Jsub.
  { rewrite HJeq.
    exact (SepI (Power Fam) (fun F0:set => finite F0) FU HFUPow HFUFin). }

  (** cofinality gives kU with FU <= phi kU, hence U in phi kU **)
  claim HexkU: exists kU:set, kU :e K /\ (FU, apply_fun phi kU) :e leJ.
  { exact (Hcofinal FU HFUJ). }
  apply HexkU.
  let kU.
  assume HkUpack.
  claim HkUK: kU :e K.
  { exact (andEL (kU :e K) ((FU, apply_fun phi kU) :e leJ) HkUpack). }
  claim HFUle: (FU, apply_fun phi kU) :e leJ.
  { exact (andER (kU :e K) ((FU, apply_fun phi kU) :e leJ) HkUpack). }

  (** kU is a counterexample index: sub(kU) not in U **)
  claim Hsubeq: apply_fun sub kU = apply_fun net0 (apply_fun phi kU).
  { exact (Hvals kU HkUK). }

  (** at this point we need an index k above both i0 and kU and compatible with phi monotonicity **)
  admit. (** FAIL **)
}

witness net0.
apply andI.
- exact Hnet0.
- exact Hnosub.
Qed.

(** helper: witnessed version using explicit index sets and orders **)
(** LATEX VERSION: If an open cover has no finite subcover, one can build a net whose every subnet (with its witnessed directed set) fails to converge. **)
Theorem open_cover_no_finite_subcover_implies_net_counterexample_witnessed :
  forall X Tx Fam:set,
    topology_on X Tx ->
    open_cover_of X Tx Fam ->
    ~(has_finite_subcover X Tx Fam) ->
    exists J le net0:set,
      directed_set J le /\
      total_function_on net0 J X /\ functional_graph net0 /\ graph_domain_subset net0 J /\
      (forall sub K leK phi x:set,
        subnet_of_witness net0 sub J le K leK X phi ->
        ~(net_converges_on X Tx sub K leK x)).
let X Tx Fam.
assume HTx: topology_on X Tx.
assume Hcover: open_cover_of X Tx Fam.
assume Hnofin: ~(has_finite_subcover X Tx Fam).
prove exists J le net0:set,
  directed_set J le /\
  total_function_on net0 J X /\ functional_graph net0 /\ graph_domain_subset net0 J /\
  (forall sub K leK phi x:set,
    subnet_of_witness net0 sub J le K leK X phi ->
    ~(net_converges_on X Tx sub K leK x)).

set J := finite_subcollections Fam.
set le := inclusion_rel J.
set pickx := (fun F:set =>
  Eps_i (fun x:set => x :e X /\ ~(x :e Union F))).
set net0 := graph J pickx.

claim HdirJ: directed_set J le.
{ exact (finite_subcollections_directed_by_subset Fam). }

claim Hpick_spec: forall F:set, F :e J -> pickx F :e X /\ ~(pickx F :e Union F).
{ let F. assume HFJ: F :e J.
  claim HFpow: F :e Power Fam.
  { exact (SepE1 (Power Fam) (fun F0:set => finite F0) F HFJ). }
  claim HFfin: finite F.
  { exact (SepE2 (Power Fam) (fun F0:set => finite F0) F HFJ). }
  claim HFsub: F c= Fam.
  { exact (PowerE Fam F HFpow). }
  claim Hnotcov: ~(X c= Union F).
  { assume Hcov: X c= Union F.
    apply Hnofin.
    apply (has_finite_subcoverI X Tx Fam F).
    apply andI.
    - apply andI.
      + exact HFsub.
      + exact HFfin.
    - exact Hcov. }
  claim Hexx: exists x:set, x :e X /\ ~(x :e Union F).
  { claim Hex': exists x:set, ~(x :e X -> x :e Union F).
    { exact (not_all_ex_demorgan_i (fun x:set => x :e X -> x :e Union F) Hnotcov). }
    apply Hex'.
    let x. assume Hnx: ~(x :e X -> x :e Union F).
    witness x.
    exact (not_imp (x :e X) (x :e Union F) Hnx). }
  apply Hexx.
  let x. assume Hx: x :e X /\ ~(x :e Union F).
  exact (Eps_i_ax (fun x0:set => x0 :e X /\ ~(x0 :e Union F)) x Hx). }

claim Hpick_in: forall F:set, F :e J -> pickx F :e X.
{ let F. assume HFJ: F :e J.
  claim Hspec: pickx F :e X /\ ~(pickx F :e Union F).
  { exact (Hpick_spec F HFJ). }
  exact (andEL (pickx F :e X) (~(pickx F :e Union F)) Hspec). }

claim Htotnet: total_function_on net0 J X.
{ exact (total_function_on_graph J X pickx Hpick_in). }

claim Hgraphnet: functional_graph net0.
{ exact (functional_graph_graph J pickx). }

claim Hdomnet: graph_domain_subset net0 J.
{ exact (graph_domain_subset_graph J pickx). }

witness J.
witness le.
witness net0.
(** conjunction is left-associative: ((((A /\ B) /\ C) /\ D) /\ E) **)
apply andI.
- (** first four conjuncts together: (((A /\ B) /\ C) /\ D) **)
  apply andI.
  + (** (A /\ B) /\ C **)
    apply andI.
    * (** A /\ B **)
      apply andI.
      - exact HdirJ.
      - exact Htotnet.
    * (** C **)
      exact Hgraphnet.
  + (** D **)
    exact Hdomnet.
- (** E: no subnet converges_on **)
  let sub K leK phi x.
  assume Hw: subnet_of_witness net0 sub J le K leK X phi.
  prove ~(net_converges_on X Tx sub K leK x).
  assume Hconv: net_converges_on X Tx sub K leK x.
  prove False.

    (** unpack Hw to obtain K-directedness and phi cofinality/monotonicity and value equation **)
    apply Hw. assume Hwcore Hvals.
    apply Hwcore. assume Hwcore2 Hcofinal.
    apply Hwcore2. assume Hwcore3 Hmono.
    apply Hwcore3. assume Hwcore4 Hdomphi.
    apply Hwcore4. assume Hwcore5 Hgraphphi.
    apply Hwcore5. assume Hwcore6 Htotphi.
    apply Hwcore6. assume Hwcore7 Hdomsub.
    apply Hwcore7. assume Hwcore8 Hgraphsub.
    apply Hwcore8. assume Hwcore9 Htotsub.
    apply Hwcore9. assume Hwcore10 Hdomnet2.
    apply Hwcore10. assume Hwcore11 Hgraphnet2.
    apply Hwcore11. assume Hwcore12 Htotnet2.
    apply Hwcore12. assume HdirJ2 HdirK.

    (** unpack Hconv: tail for every neighborhood **)
    apply Hconv. assume HcCore HcTail.
    apply HcCore. assume HcCore5 HxX.
    apply HcCore5. assume HcCore4 HdomC.
    apply HcCore4. assume HcCore3 HgraphC.
    apply HcCore3. assume HcCore2 HtotC.
    apply HcCore2. assume HTx2 HdirK2.

    (** choose U in Fam with x in U **)
    claim HcovX: X c= Union Fam.
    { exact (open_cover_of_covers X Tx Fam Hcover). }
    claim HxUnion: x :e Union Fam.
    { exact (HcovX x HxX). }
    claim HexU: exists U:set, x :e U /\ U :e Fam.
    { exact (UnionE Fam x HxUnion). }
    apply HexU.
    let U. assume HU.
    claim HxU: x :e U.
    { exact (andEL (x :e U) (U :e Fam) HU). }
    claim HUFam: U :e Fam.
    { exact (andER (x :e U) (U :e Fam) HU). }
    claim HUopen: U :e Tx.
    { exact (open_cover_of_members_open X Tx Fam U Hcover HUFam). }

    (** convergence tail index k0 for neighborhood U **)
    claim Hexk0: exists k0:set, k0 :e K /\
      forall k:set, k :e K -> (k0,k) :e leK -> apply_fun sub k :e U.
    { exact (HcTail U HUopen HxU). }
    apply Hexk0.
    let k0. assume Hk0pack.
    claim Hk0K: k0 :e K.
    { exact (andEL (k0 :e K)
                   (forall k:set, k :e K -> (k0,k) :e leK -> apply_fun sub k :e U)
                   Hk0pack). }
    claim HtailU:
      forall k:set, k :e K -> (k0,k) :e leK -> apply_fun sub k :e U.
    { exact (andER (k0 :e K)
                   (forall k:set, k :e K -> (k0,k) :e leK -> apply_fun sub k :e U)
                   Hk0pack). }

    (** jU = {U} is a finite subcollection, hence in J **)
    set jU := {U}.
    claim HjUsub: jU c= Fam.
    { let V. assume HV: V :e jU.
      claim HVeq: V = U.
      { exact (SingE U V HV). }
      rewrite HVeq.
      exact HUFam. }
    claim HjUpow: jU :e Power Fam.
    { exact (PowerI Fam jU HjUsub). }
    claim HjUfin: finite jU.
    { exact (Sing_finite U). }
    claim HjUJ: jU :e J.
    { exact (SepI (Power Fam) (fun F0:set => finite F0) jU HjUpow HjUfin). }

    (** cofinality gives kU with jU <= phi(kU), hence U in phi(kU) **)
    claim HexkU: exists kU:set, kU :e K /\ (jU, apply_fun phi kU) :e le.
    { exact (Hcofinal jU HjUJ). }
    apply HexkU.
    let kU. assume HkUpack.
    claim HkUK: kU :e K.
    { exact (andEL (kU :e K) ((jU, apply_fun phi kU) :e le) HkUpack). }
    claim HjUle: (jU, apply_fun phi kU) :e le.
    { exact (andER (kU :e K) ((jU, apply_fun phi kU) :e le) HkUpack). }

    (** directedness gives kstar >= k0,kU **)
    claim Hexkstar: exists kstar:set, kstar :e K /\ (k0,kstar) :e leK /\ (kU,kstar) :e leK.
    { apply HdirK2.
      assume _ HdirUB.
      exact (HdirUB k0 kU Hk0K HkUK). }
    apply Hexkstar.
    let kstar. assume Hkstarpack.
    claim Hkstar12: kstar :e K /\ (k0,kstar) :e leK.
    { exact (andEL (kstar :e K /\ (k0,kstar) :e leK)
                   ((kU,kstar) :e leK)
                   Hkstarpack). }
    claim HkUle: (kU,kstar) :e leK.
    { exact (andER (kstar :e K /\ (k0,kstar) :e leK)
                   ((kU,kstar) :e leK)
                   Hkstarpack). }
    claim HkstarK: kstar :e K.
    { exact (andEL (kstar :e K) ((k0,kstar) :e leK) Hkstar12). }
    claim Hk0le: (k0,kstar) :e leK.
    { exact (andER (kstar :e K) ((k0,kstar) :e leK) Hkstar12). }

    (** kstar is in U by tail **)
    claim HsubU: apply_fun sub kstar :e U.
    { exact (HtailU kstar HkstarK Hk0le). }

    (** show U in phi(kstar) using monotonicity and inclusion relation **)
    claim Hphi_kU_J: apply_fun phi kU :e J.
    { exact (total_function_on_apply_fun_in_Y phi K J kU Htotphi HkUK). }
    claim Hphi_kstar_J: apply_fun phi kstar :e J.
    { exact (total_function_on_apply_fun_in_Y phi K J kstar Htotphi HkstarK). }
    claim Hphimon: (apply_fun phi kU, apply_fun phi kstar) :e le.
    { exact (Hmono kU kstar HkUK HkstarK HkUle). }
    claim HjUle2: (jU, apply_fun phi kstar) :e le.
    { exact (directed_set_trans J le HdirJ jU (apply_fun phi kU) (apply_fun phi kstar)
             HjUJ Hphi_kU_J Hphi_kstar_J HjUle Hphimon). }
    claim HjUsubPhi: jU c= apply_fun phi kstar.
    { exact (andER ((jU, apply_fun phi kstar) :e setprod J J) (jU c= apply_fun phi kstar)
            (inclusion_relE J jU (apply_fun phi kstar) HjUle2)). }
    claim HUinPhi: U :e apply_fun phi kstar.
    { apply (HjUsubPhi U).
      exact (SingI U). }

    (** sub(kstar) = net0(phi(kstar)) = pickx(phi(kstar)) **)
    claim Hsubeq: apply_fun sub kstar = apply_fun net0 (apply_fun phi kstar).
    { exact (Hvals kstar HkstarK). }
    claim Hnet0eq: apply_fun net0 (apply_fun phi kstar) = pickx (apply_fun phi kstar).
    { rewrite (apply_fun_graph J pickx (apply_fun phi kstar) Hphi_kstar_J).
      reflexivity. }
    claim HsubisPick: apply_fun sub kstar = pickx (apply_fun phi kstar).
    { rewrite Hsubeq.
      rewrite Hnet0eq.
      reflexivity. }
    claim HpickU: pickx (apply_fun phi kstar) :e U.
    { rewrite <- HsubisPick at 1.
      exact HsubU. }

    (** pickx(phi(kstar)) is not in Union(phi(kstar)), hence not in U **)
    claim HspecStar: pickx (apply_fun phi kstar) :e X /\ ~(pickx (apply_fun phi kstar) :e Union (apply_fun phi kstar)).
    { exact (Hpick_spec (apply_fun phi kstar) Hphi_kstar_J). }
    claim HnotUnion: ~(pickx (apply_fun phi kstar) :e Union (apply_fun phi kstar)).
    { exact (andER (pickx (apply_fun phi kstar) :e X)
                   (~(pickx (apply_fun phi kstar) :e Union (apply_fun phi kstar)))
                   HspecStar). }
    claim HnotU: ~(pickx (apply_fun phi kstar) :e U).
    { assume HmemU: pickx (apply_fun phi kstar) :e U.
      apply HnotUnion.
      exact (UnionI (apply_fun phi kstar) (pickx (apply_fun phi kstar)) U HmemU HUinPhi). }
    exact (HnotU HpickU).
Qed.

Theorem compact_iff_every_net_has_convergent_subnet : forall X Tx:set,
  topology_on X Tx ->
  (compact_space X Tx <-> forall net:set, net_in_space X net -> exists sub x:set, subnet_of net sub /\ net_converges X Tx sub x).
let X Tx.
assume HTx: topology_on X Tx.
prove compact_space X Tx <-> forall net:set, net_in_space X net -> exists sub x:set, subnet_of net sub /\ net_converges X Tx sub x.
apply iffI.
- assume Hcomp: compact_space X Tx.
  prove forall net:set, net_in_space X net -> exists sub x:set, subnet_of net sub /\ net_converges X Tx sub x.
  let net. assume Hnet: net_in_space X net.
  prove exists sub x:set, subnet_of net sub /\ net_converges X Tx sub x.
  claim Hexacc: exists x0:set, accumulation_point_of_net X Tx net x0.
  { exact (compact_space_net_has_accumulation_point X Tx net Hcomp Hnet). }
  apply Hexacc.
  let x0. assume Hacc: accumulation_point_of_net X Tx net x0.
  apply (subnet_converges_to_accumulation X Tx net x0 Hacc).
  let sub. assume Hsub: subnet_of net sub /\ net_converges X Tx sub x0.
  witness sub.
  witness x0.
  exact Hsub.
- assume Hnets: forall net:set, net_in_space X net -> exists sub x:set, subnet_of net sub /\ net_converges X Tx sub x.
  prove topology_on X Tx /\ forall Fam:set, open_cover_of X Tx Fam -> has_finite_subcover X Tx Fam.
  apply andI.
  - exact HTx.
  - let Fam. assume Hcover: open_cover_of X Tx Fam.
    prove has_finite_subcover X Tx Fam.
    apply (xm (has_finite_subcover X Tx Fam)).
    + assume Hfin: has_finite_subcover X Tx Fam.
      exact Hfin.
    + assume Hnofin: ~(has_finite_subcover X Tx Fam).
      apply FalseE.
      claim Hexnet: exists net0:set,
        net_in_space X net0 /\
        (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x)).
      { exact (open_cover_no_finite_subcover_implies_net_counterexample X Tx Fam HTx Hcover Hnofin). }
      apply Hexnet.
      let net0. assume Hnet0pack:
        net_in_space X net0 /\
        (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x)).
      claim Hnet0: net_in_space X net0.
      { exact (andEL (net_in_space X net0)
                     (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x))
                     Hnet0pack). }
      claim Hnosub: forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x).
      { exact (andER (net_in_space X net0)
                     (forall sub x:set, subnet_of net0 sub -> ~(net_converges X Tx sub x))
                     Hnet0pack). }
      apply (Hnets net0 Hnet0).
      let sub. assume Hexx.
      apply Hexx.
      let x. assume Hsubconv: subnet_of net0 sub /\ net_converges X Tx sub x.
      claim Hsub: subnet_of net0 sub.
      { exact (andEL (subnet_of net0 sub) (net_converges X Tx sub x) Hsubconv). }
      claim Hconv: net_converges X Tx sub x.
      { exact (andER (subnet_of net0 sub) (net_converges X Tx sub x) Hsubconv). }
      exact ((Hnosub sub x Hsub) Hconv).
Qed.

(** from §30 Definition 30.1: countable basis at a point / first countable **) 
(** LATEX VERSION: Countable sets and related notions from §30 (countability axioms). **)
Definition countable_set : set -> prop := fun A => countable A.

(** helper: equinumerous sets share countability **)
(** LATEX VERSION: If X and Y are equinumerous (equip), then X is countable iff Y is countable. **)
Theorem equip_countable_set_left : forall X Y:set,
  equip X Y -> countable_set X -> countable_set Y.
let X Y.
assume Heq: equip X Y.
assume HcountX: countable_set X.
prove countable_set Y.
claim Heq_sym: equip Y X.
{ exact (equip_sym X Y Heq). }
claim Hayx: atleastp Y X.
{ exact (equip_atleastp Y X Heq_sym). }
exact (atleastp_tra Y X omega Hayx HcountX).
Qed.

Theorem equip_countable_set_right : forall X Y:set,
  equip X Y -> countable_set Y -> countable_set X.
let X Y.
assume Heq: equip X Y.
assume HcountY: countable_set Y.
exact (equip_countable_set_left Y X (equip_sym X Y Heq) HcountY).
Qed.

(** helper: rationals are countable **)
(** LATEX VERSION: The set of rational numbers is countable. **)
Theorem rational_numbers_countable : countable_set rational_numbers.
prove countable_set rational_numbers.
prove countable rational_numbers.
(** Use equip omega rational_numbers from form100_3 and transfer to atleastp rational_numbers omega. **)
claim Hequip: equip omega rational_numbers.
{ claim HdefQ: rational_numbers = rational.
  { reflexivity. }
  rewrite HdefQ.
  exact form100_3. }
claim Hequip_sym: equip rational_numbers omega.
{ exact (equip_sym omega rational_numbers Hequip). }
exact (equip_atleastp rational_numbers omega Hequip_sym).
Qed.

(** LATEX VERSION: Countable subcollection V of U. **)
Definition countable_subcollection : set -> set -> prop := fun V U => V c= U /\ countable_set V.

(** LATEX VERSION: Countable index set. **)
Definition countable_index_set : set -> prop := fun I => countable_set I.

(** Helper for §30 Theorem 30.2: product topology from a cylinder subbasis. **)
(** LATEX VERSION: The product topology is generated by the cylinder subbasis. **)
Definition countable_product_topology_subbasis : set -> set -> set := fun I Xi =>
  generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).

(** Helper: cylinder family is a subbasis on nonempty products. **)
Theorem product_subbasis_full_subbasis_on : forall I Xi:set,
  I <> Empty ->
  (forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i)) ->
  subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
let I Xi.
assume HIne: I <> Empty.
assume HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
prove subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
prove product_subbasis_full I Xi c= Power (product_space I Xi) /\ Union (product_subbasis_full I Xi) = product_space I Xi.
apply andI.
- (** product_subbasis_full I Xi c= Power (product_space I Xi) **)
  let s. assume Hs: s :e product_subbasis_full I Xi.
  prove s :e Power (product_space I Xi).
  apply PowerI.
  let f. assume Hf: f :e s.
  prove f :e product_space I Xi.
  set F := (fun i:set => {product_cylinder I Xi i U|U :e space_family_topology Xi i}).
  claim HsF: s :e (\/_ i :e I, F i).
  { exact Hs. }
  apply (famunionE_impred I F s HsF (f :e product_space I Xi)).
  let i.
  assume HiI: i :e I.
  assume HsFi: s :e F i.
  claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder I Xi i U.
  { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0) s HsFi). }
  apply HexU.
  let U.
  assume HUand: U :e space_family_topology Xi i /\ s = product_cylinder I Xi i U.
  claim Hseq: s = product_cylinder I Xi i U.
  { exact (andER (U :e space_family_topology Xi i) (s = product_cylinder I Xi i U) HUand). }
  claim HfCyl: f :e product_cylinder I Xi i U.
  { rewrite <- Hseq. exact Hf. }
  exact (SepE1 (product_space I Xi)
               (fun f0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
               f HfCyl).
- (** Union (product_subbasis_full I Xi) = product_space I Xi **)
  apply set_ext.
  + let f. assume HfU: f :e Union (product_subbasis_full I Xi).
    prove f :e product_space I Xi.
    apply (UnionE_impred (product_subbasis_full I Xi) f HfU (f :e product_space I Xi)).
    let s. assume Hfs: f :e s. assume Hs: s :e product_subbasis_full I Xi.
    claim HsPow: s :e Power (product_space I Xi).
    { apply PowerI.
      let g. assume Hg: g :e s.
      prove g :e product_space I Xi.
      set F := (fun i:set => {product_cylinder I Xi i U|U :e space_family_topology Xi i}).
      claim HsF: s :e (\/_ i :e I, F i).
      { exact Hs. }
      apply (famunionE_impred I F s HsF (g :e product_space I Xi)).
      let i.
      assume HiI: i :e I.
      assume HsFi: s :e F i.
      claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder I Xi i U.
      { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0) s HsFi). }
      apply HexU.
      let U.
      assume HUand: U :e space_family_topology Xi i /\ s = product_cylinder I Xi i U.
      claim Hseq: s = product_cylinder I Xi i U.
      { exact (andER (U :e space_family_topology Xi i) (s = product_cylinder I Xi i U) HUand). }
      claim HgCyl: g :e product_cylinder I Xi i U.
      { rewrite <- Hseq. exact Hg. }
      exact (SepE1 (product_space I Xi)
                   (fun f0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                   g HgCyl).
    }
    exact (PowerE (product_space I Xi) s HsPow f Hfs).
  + let f. assume HfX: f :e product_space I Xi.
    prove f :e Union (product_subbasis_full I Xi).
    apply (xm (exists i:set, i :e I)).
    * assume Hexi: exists i:set, i :e I.
      apply Hexi.
      let i. assume HiI: i :e I.
      claim Htopi: topology_on (space_family_set Xi i) (space_family_topology Xi i).
      { exact (HcompTop i HiI). }
      claim Ht1: (((space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i) /\ space_family_set Xi i :e space_family_topology Xi i) /\ (forall UFam :e Power (space_family_topology Xi i), Union UFam :e space_family_topology Xi i)) /\ (forall U :e space_family_topology Xi i, forall V :e space_family_topology Xi i, U :/\: V :e space_family_topology Xi i).
      { exact Htopi. }
      claim Ht2: ((space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i) /\ space_family_set Xi i :e space_family_topology Xi i) /\ (forall UFam :e Power (space_family_topology Xi i), Union UFam :e space_family_topology Xi i).
      { exact (andEL (((space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i) /\ space_family_set Xi i :e space_family_topology Xi i) /\ (forall UFam :e Power (space_family_topology Xi i), Union UFam :e space_family_topology Xi i))
                     (forall U :e space_family_topology Xi i, forall V :e space_family_topology Xi i, U :/\: V :e space_family_topology Xi i)
                     Ht1). }
      claim Ht3: (space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i) /\ space_family_set Xi i :e space_family_topology Xi i.
      { exact (andEL ((space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i) /\ space_family_set Xi i :e space_family_topology Xi i)
                     (forall UFam :e Power (space_family_topology Xi i), Union UFam :e space_family_topology Xi i)
                     Ht2). }
      claim HUopen: space_family_set Xi i :e space_family_topology Xi i.
      { exact (andER (space_family_topology Xi i c= Power (space_family_set Xi i) /\ Empty :e space_family_topology Xi i)
                     (space_family_set Xi i :e space_family_topology Xi i)
                     Ht3). }
      set s := product_cylinder I Xi i (space_family_set Xi i).
      claim HsRepl: s :e {product_cylinder I Xi i U|U :e space_family_topology Xi i}.
      { exact (ReplI (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0)
                     (space_family_set Xi i) HUopen). }
      claim HsSub: s :e product_subbasis_full I Xi.
      { exact (famunionI I (fun i0:set => {product_cylinder I Xi i0 U|U :e space_family_topology Xi i0})
                       i s HiI HsRepl). }
      claim HfProp: total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
                    forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j.
      { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                     (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
                       forall j:set, j :e I -> apply_fun f0 j :e space_family_set Xi j)
                     f HfX). }
      claim HfCoord: forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j.
      { exact (andER (total_function_on f I (space_family_union I Xi) /\ functional_graph f)
                     (forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
                     HfProp). }
      claim Hfi: apply_fun f i :e space_family_set Xi i.
      { exact (HfCoord i HiI). }
      claim HfInS: f :e s.
      { exact (SepI (product_space I Xi)
                    (fun f0:set => i :e I /\ space_family_set Xi i :e space_family_topology Xi i /\ apply_fun f0 i :e space_family_set Xi i)
                    f HfX
                    (andI (i :e I /\ space_family_set Xi i :e space_family_topology Xi i)
                          (apply_fun f i :e space_family_set Xi i)
                          (andI (i :e I) (space_family_set Xi i :e space_family_topology Xi i) HiI HUopen)
                          Hfi)). }
      exact (UnionI (product_subbasis_full I Xi) f s HfInS HsSub).
    * assume Hnex: ~(exists i:set, i :e I).
      prove f :e Union (product_subbasis_full I Xi).
      claim Hall: forall i:set, i /:e I.
      { let i. assume HiI: i :e I.
        prove False.
        apply Hnex.
        witness i.
        exact HiI. }
      claim HIeq: I = Empty.
      { exact (Empty_eq I Hall). }
      claim Hfalse: False.
      { apply HIne. exact HIeq. }
      exact (FalseE Hfalse (f :e Union (product_subbasis_full I Xi))).
Qed.

(** Helper: cartesian product with Empty is Empty. **)
Theorem setprod_Empty_left : forall Y:set, setprod Empty Y = Empty.
let Y.
apply set_ext.
- let p. assume Hp: p :e setprod Empty Y.
  prove p :e Empty.
  claim Hp0: (p 0) :e Empty.
  { exact (ap0_Sigma Empty (fun _:set => Y) p Hp). }
  exact (EmptyE (p 0) Hp0 (p :e Empty)).
- let p. assume Hp: p :e Empty.
  prove p :e setprod Empty Y.
  exact (EmptyE p Hp (p :e setprod Empty Y)).
Qed.

(** Helper: basis on X from the singleton {X}. **)
Theorem basis_on_singleton : forall X:set, basis_on X {X}.
let X.
prove {X} c= Power X
  /\ (forall x :e X, exists b :e {X}, x :e b)
  /\ (forall b1 :e {X}, forall b2 :e {X}, forall x:set,
        x :e b1 -> x :e b2 ->
        exists b3 :e {X}, x :e b3 /\ b3 c= b1 :/\: b2).
apply andI.
- apply andI.
  + (** {X} c= Power X **)
    let b. assume Hb: b :e {X}.
    prove b :e Power X.
    claim HbX: b = X.
    { exact (SingE X b Hb). }
    rewrite HbX.
    exact (Self_In_Power X).
  + (** covering property **)
    let x. assume HxX: x :e X.
    prove exists b :e {X}, x :e b.
    witness X.
    apply andI.
    * exact (SingI X).
    * exact HxX.
- (** intersection property **)
  let b1. assume Hb1: b1 :e {X}.
  let b2. assume Hb2: b2 :e {X}.
  let x. assume Hxb1: x :e b1. assume Hxb2: x :e b2.
  prove exists b3 :e {X}, x :e b3 /\ b3 c= b1 :/\: b2.
  claim Hb1X: b1 = X.
  { exact (SingE X b1 Hb1). }
  claim Hb2X: b2 = X.
  { exact (SingE X b2 Hb2). }
  witness X.
  apply andI.
  + exact (SingI X).
	  + prove x :e X /\ X c= b1 :/\: b2.
	    apply andI.
	    * rewrite <- Hb1X. exact Hxb1.
	    * let y. assume HyX: y :e X.
      prove y :e b1 :/\: b2.
      claim Hyb1: y :e b1.
      { rewrite Hb1X. exact HyX. }
      claim Hyb2: y :e b2.
      { rewrite Hb2X. exact HyX. }
      exact (binintersectI b1 b2 y Hyb1 Hyb2).
Qed.

(** Helper: the product space indexed by Empty has exactly the empty function. **)
Theorem product_space_empty_index : forall Xi:set, product_space Empty Xi = {Empty}.
let Xi.
apply set_ext.
- let f. assume Hf: f :e product_space Empty Xi.
  prove f :e {Empty}.
  claim HfPow: f :e Power (setprod Empty (space_family_union Empty Xi)).
  { exact (SepE1 (Power (setprod Empty (space_family_union Empty Xi)))
                 (fun f0:set => total_function_on f0 Empty (space_family_union Empty Xi) /\ functional_graph f0 /\
                   forall i:set, i :e Empty -> apply_fun f0 i :e space_family_set Xi i)
                 f Hf). }
  claim Heqprod: setprod Empty (space_family_union Empty Xi) = Empty.
  { exact (setprod_Empty_left (space_family_union Empty Xi)). }
	  claim HfPowE: f :e Power Empty.
	  { rewrite <- Heqprod. exact HfPow. }
  claim Hsub: f c= Empty.
  { exact (PowerE Empty f HfPowE). }
  claim Hall: forall x:set, x /:e f.
  { let x. assume Hx: x :e f.
    prove False.
    claim HxE: x :e Empty.
    { exact (Hsub x Hx). }
    exact (EmptyE x HxE False). }
  claim HfEq: f = Empty.
  { exact (Empty_eq f Hall). }
  rewrite HfEq.
  exact (SingI Empty).
- let f. assume Hf: f :e {Empty}.
  prove f :e product_space Empty Xi.
  claim Hfeq: f = Empty.
  { exact (SingE Empty f Hf). }
  rewrite Hfeq.
  claim Hpow: Empty :e Power (setprod Empty (space_family_union Empty Xi)).
  { claim Heqprod: setprod Empty (space_family_union Empty Xi) = Empty.
    { exact (setprod_Empty_left (space_family_union Empty Xi)). }
    rewrite Heqprod.
    exact (Empty_In_Power Empty). }
  claim Htot: total_function_on Empty Empty (space_family_union Empty Xi).
  { claim Hfun: function_on Empty Empty (space_family_union Empty Xi).
    { let x. assume Hx: x :e Empty.
      prove apply_fun Empty x :e space_family_union Empty Xi.
      exact (EmptyE x Hx (apply_fun Empty x :e space_family_union Empty Xi)). }
    claim Htot': forall x:set, x :e Empty -> exists y:set, y :e space_family_union Empty Xi /\ (x,y) :e Empty.
    { let x. assume Hx: x :e Empty.
      prove exists y:set, y :e space_family_union Empty Xi /\ (x,y) :e Empty.
      exact (EmptyE x Hx (exists y:set, y :e space_family_union Empty Xi /\ (x,y) :e Empty)). }
    exact (andI (function_on Empty Empty (space_family_union Empty Xi))
                (forall x:set, x :e Empty -> exists y:set, y :e space_family_union Empty Xi /\ (x,y) :e Empty)
                Hfun
                Htot'). }
  claim Hgraph: functional_graph Empty.
  { let x y1 y2.
    assume H1: (x,y1) :e Empty.
    assume H2: (x,y2) :e Empty.
    exact (EmptyE (x,y1) H1 (y1 = y2)). }
  claim Hcoords: forall i:set, i :e Empty -> apply_fun Empty i :e space_family_set Xi i.
  { let i. assume Hi: i :e Empty.
    prove apply_fun Empty i :e space_family_set Xi i.
    exact (EmptyE i Hi (apply_fun Empty i :e space_family_set Xi i)). }
  claim Hpred: total_function_on Empty Empty (space_family_union Empty Xi) /\ functional_graph Empty /\
    forall i:set, i :e Empty -> apply_fun Empty i :e space_family_set Xi i.
  { apply andI.
    - apply andI.
      + exact Htot.
      + exact Hgraph.
    - exact Hcoords. }
  exact (SepI (Power (setprod Empty (space_family_union Empty Xi)))
              (fun f0:set => total_function_on f0 Empty (space_family_union Empty Xi) /\ functional_graph f0 /\
                forall i:set, i :e Empty -> apply_fun f0 i :e space_family_set Xi i)
              Empty Hpow Hpred).
Qed.

(** Helper: nonempty empty-subbasis gives singleton basis {X}. **)
Theorem basis_of_subbasis_empty_eq : forall X:set,
  X <> Empty ->
  basis_of_subbasis X Empty = {X}.
let X.
assume HXne: X <> Empty.
apply set_ext.
- let b. assume Hb: b :e basis_of_subbasis X Empty.
  prove b :e {X}.
  claim Hbfin: b :e finite_intersections_of X Empty.
  { exact (SepE1 (finite_intersections_of X Empty) (fun b0:set => b0 <> Empty) b Hb). }
  claim HexF: exists F :e finite_subcollections Empty, b = intersection_of_family X F.
  { exact (ReplE (finite_subcollections Empty) (fun F0:set => intersection_of_family X F0) b Hbfin). }
  apply HexF.
  let F. assume HFpair. apply HFpair.
  assume HF: F :e finite_subcollections Empty.
  assume Hbeq: b = intersection_of_family X F.
  claim HFpow: F :e Power Empty.
  { exact (SepE1 (Power Empty) (fun F0:set => finite F0) F HF). }
  claim HFsub: F c= Empty.
  { exact (PowerE Empty F HFpow). }
  claim Hall: forall x:set, x /:e F.
  { let x. assume Hx: x :e F.
    prove False.
    claim HxE: x :e Empty.
    { exact (HFsub x Hx). }
    exact (EmptyE x HxE False). }
  claim HFeq: F = Empty.
  { exact (Empty_eq F Hall). }
  claim HbX: b = X.
  { rewrite Hbeq.
    rewrite HFeq.
    exact (intersection_of_family_empty_eq X). }
  rewrite HbX.
  exact (SingI X).
- let b. assume Hb: b :e {X}.
  prove b :e basis_of_subbasis X Empty.
  claim HbX: b = X.
  { exact (SingE X b Hb). }
  rewrite HbX.
  claim HF: Empty :e finite_subcollections Empty.
  { exact (SepI (Power Empty) (fun F0:set => finite F0)
                Empty (Empty_In_Power Empty) finite_Empty). }
  claim Hfin: intersection_of_family X Empty :e finite_intersections_of X Empty.
  { exact (ReplI (finite_subcollections Empty) (fun F0:set => intersection_of_family X F0) Empty HF). }
  claim HXfin: X :e finite_intersections_of X Empty.
	{ claim Heq: X = intersection_of_family X Empty.
	  { rewrite (intersection_of_family_empty_eq X).
	    reflexivity. }
	  rewrite Heq at 1.
	  exact Hfin. }
  exact (SepI (finite_intersections_of X Empty) (fun b0:set => b0 <> Empty)
              X HXfin HXne).
Qed.

(** Helper for §30 Theorem 30.2: empty-index product topology is a topology. **)
(** LATEX VERSION: The empty product carries the topology generated by the empty cylinder family, which is a topology. **)
Theorem countable_product_topology_subbasis_empty_is_topology : forall Xi:set,
  topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi).
let Xi.
prove topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi).
claim HTdef: countable_product_topology_subbasis Empty Xi =
  generated_topology_from_subbasis (product_space Empty Xi) (product_subbasis_full Empty Xi).
{ reflexivity. }
rewrite HTdef.
				          claim HS0: product_subbasis_full Empty Xi = Empty.
				          { exact (famunion_Empty (fun i:set => {product_cylinder Empty Xi i U|U :e space_family_topology Xi i})). }
				          rewrite HS0.
				          claim HGTS0: generated_topology_from_subbasis (product_space Empty Xi) Empty =
				            generated_topology (product_space Empty Xi) (basis_of_subbasis (product_space Empty Xi) Empty).
				          { reflexivity. }
				          rewrite HGTS0.
				          claim HX0ne: product_space Empty Xi <> Empty.
				          { assume HX0E: product_space Empty Xi = Empty.
				            claim Hem: Empty :e product_space Empty Xi.
				            { rewrite (product_space_empty_index Xi).
    exact (SingI Empty). }
	  claim HemE: Empty :e Empty.
	  { rewrite <- HX0E at 2. exact Hem. }
	  exact (EmptyE Empty HemE False). }
claim HB0eq: basis_of_subbasis (product_space Empty Xi) Empty = {product_space Empty Xi}.
{ exact (basis_of_subbasis_empty_eq (product_space Empty Xi) HX0ne). }
claim HB0: basis_on (product_space Empty Xi) (basis_of_subbasis (product_space Empty Xi) Empty).
{ rewrite HB0eq.
  exact (basis_on_singleton (product_space Empty Xi)). }
exact (lemma_topology_from_basis (product_space Empty Xi) (basis_of_subbasis (product_space Empty Xi) Empty) HB0).
Qed.

(** Helper: power set of a natural has finite size **)
(** LATEX VERSION: For n in omega, Power n is equipotent to 2^n. **)
Theorem equip_Power_nat : forall n:set, nat_p n -> equip (Power n) (exp_nat 2 n).
let n.
assume Hn: nat_p n.
claim Hnn: equip n n.
{ exact (equip_ref n). }
exact (equip_finite_Power n Hn n Hnn).
Qed.

(** helper: image of countable set is countable **)
Theorem countable_image : forall X:set, countable_set X ->
  forall F:set->set, countable_set {F x|x :e X}.
let X.
assume HX: countable_set X.
let F.
prove countable_set {F x|x :e X}.
prove countable {F x|x :e X}.
prove atleastp {F x|x :e X} omega.
prove exists g : set->set, inj {F x|x :e X} omega g.
apply HX.
let h : set->set.
assume Hh: inj X omega h.
set pre : set->set := fun y => Eps_i (fun x => x :e X /\ y = F x).
set g : set->set := fun y => h (pre y).
witness g.
apply (injI {F x|x :e X} omega g).
- let y. assume Hy: y :e {F x|x :e X}.
  prove g y :e omega.
  apply (ReplE_impred X F y Hy).
  let x.
  assume HxX: x :e X.
  assume HyFx: y = F x.
  claim Hpreprop: pre y :e X /\ y = F (pre y).
  { exact (Eps_i_ax (fun x0 => x0 :e X /\ y = F x0) x (andI (x :e X) (y = F x) HxX HyFx)). }
  claim HpreX: pre y :e X.
  { exact (andEL (pre y :e X) (y = F (pre y)) Hpreprop). }
  claim Hhmap: forall u :e X, h u :e omega.
  { exact (andEL (forall u :e X, h u :e omega) (forall u v :e X, h u = h v -> u = v) Hh). }
  claim Hgy: g y = h (pre y).
  { reflexivity. }
  rewrite Hgy.
  exact (Hhmap (pre y) HpreX).
- let y1. assume Hy1: y1 :e {F x|x :e X}.
  let y2. assume Hy2: y2 :e {F x|x :e X}.
  assume Hg: g y1 = g y2.
  prove y1 = y2.
  claim Hhinj: forall u v :e X, h u = h v -> u = v.
  { exact (andER (forall u :e X, h u :e omega) (forall u v :e X, h u = h v -> u = v) Hh). }
  apply (ReplE_impred X F y1 Hy1).
  let x1.
  assume Hx1X: x1 :e X.
  assume Hy1Fx1: y1 = F x1.
  apply (ReplE_impred X F y2 Hy2).
  let x2.
  assume Hx2X: x2 :e X.
  assume Hy2Fx2: y2 = F x2.
  claim Hpre1: pre y1 :e X /\ y1 = F (pre y1).
  { exact (Eps_i_ax (fun x0 => x0 :e X /\ y1 = F x0) x1 (andI (x1 :e X) (y1 = F x1) Hx1X Hy1Fx1)). }
  claim Hpre2: pre y2 :e X /\ y2 = F (pre y2).
  { exact (Eps_i_ax (fun x0 => x0 :e X /\ y2 = F x0) x2 (andI (x2 :e X) (y2 = F x2) Hx2X Hy2Fx2)). }
  claim Hpre1X: pre y1 :e X.
  { exact (andEL (pre y1 :e X) (y1 = F (pre y1)) Hpre1). }
  claim Hpre2X: pre y2 :e X.
  { exact (andEL (pre y2 :e X) (y2 = F (pre y2)) Hpre2). }
  claim Hg1: g y1 = h (pre y1).
  { reflexivity. }
  claim Hg2: g y2 = h (pre y2).
  { reflexivity. }
  claim Heqh: h (pre y1) = h (pre y2).
  { rewrite <- Hg1. rewrite <- Hg2. exact Hg. }
  claim Heqpre: pre y1 = pre y2.
  { exact (Hhinj (pre y1) Hpre1X (pre y2) Hpre2X Heqh). }
  claim Hy1pre: y1 = F (pre y1).
  { exact (andER (pre y1 :e X) (y1 = F (pre y1)) Hpre1). }
  claim Hy2pre: y2 = F (pre y2).
  { exact (andER (pre y2 :e X) (y2 = F (pre y2)) Hpre2). }
  rewrite Hy1pre.
  rewrite Hy2pre.
  rewrite Heqpre.
  reflexivity.
Qed.

(** helper: rational open-interval basis is countable **)
(** LATEX VERSION: The family {(q1,q2) | q1,q2 in Q} of rational open intervals is countable. **)
Theorem rational_open_intervals_basis_countable : countable_set rational_open_intervals_basis.
prove countable_set rational_open_intervals_basis.
set QQ := setprod rational_numbers rational_numbers.
set F : set->set := fun p:set => open_interval (p 0) (p 1).
claim HQ: countable_set rational_numbers.
{ exact rational_numbers_countable. }
claim HQQ: countable_set QQ.
{ exact (setprod_countable rational_numbers rational_numbers HQ HQ). }
claim Himg: countable_set {F p|p :e QQ}.
{ exact (countable_image QQ HQQ F). }
claim Hsub: rational_open_intervals_basis c= {F p|p :e QQ}.
{ let I. assume HI: I :e rational_open_intervals_basis.
  prove I :e {F p|p :e QQ}.
  claim Hexq1: exists q1 :e rational_numbers, I :e {open_interval q1 q2|q2 :e rational_numbers}.
  { exact (famunionE rational_numbers (fun q1:set => {open_interval q1 q2|q2 :e rational_numbers}) I HI). }
  apply Hexq1.
  let q1. assume Hq1pair.
  claim Hq1Q: q1 :e rational_numbers.
  { exact (andEL (q1 :e rational_numbers) (I :e {open_interval q1 q2|q2 :e rational_numbers}) Hq1pair). }
  claim HIRepl: I :e {open_interval q1 q2|q2 :e rational_numbers}.
  { exact (andER (q1 :e rational_numbers) (I :e {open_interval q1 q2|q2 :e rational_numbers}) Hq1pair). }
  claim Hexq2: exists q2 :e rational_numbers, I = open_interval q1 q2.
  { exact (ReplE rational_numbers (fun q2:set => open_interval q1 q2) I HIRepl). }
  apply Hexq2.
  let q2. assume Hq2pair.
  claim Hq2Q: q2 :e rational_numbers.
  { exact (andEL (q2 :e rational_numbers) (I = open_interval q1 q2) Hq2pair). }
  claim HIeq: I = open_interval q1 q2.
  { exact (andER (q2 :e rational_numbers) (I = open_interval q1 q2) Hq2pair). }
  claim HpQQ: (q1,q2) :e QQ.
  { exact (tuple_2_setprod_by_pair_Sigma rational_numbers rational_numbers q1 q2 Hq1Q Hq2Q). }
  claim HFpair: F (q1,q2) = open_interval q1 q2.
  { claim HFdef: F (q1,q2) = open_interval ((q1,q2) 0) ((q1,q2) 1).
    { reflexivity. }
    rewrite HFdef.
    rewrite (tuple_2_0_eq q1 q2).
    rewrite (tuple_2_1_eq q1 q2).
    reflexivity. }
  rewrite HIeq.
  rewrite <- HFpair.
  exact (ReplI QQ F (q1,q2) HpQQ). }
exact (Subq_countable rational_open_intervals_basis {F p|p :e QQ} Himg Hsub).
Qed.

(** Helper: finite subsets of omega are countable as a family **)
(** LATEX VERSION: The collection of all finite subsets of omega is countable. **)
Theorem finite_subcollections_omega_countable : countable (finite_subcollections omega).
prove exists code : set -> set, inj (finite_subcollections omega) omega code.

(** Step 1: countability of Sigma_ n :e omega, Power n **)
set S := Sigma_ n :e omega, Power n.

claim Homega_countable: countable omega.
{ prove exists f : set -> set, inj omega omega f.
	  witness (fun n => n).
	  apply (injI omega omega (fun n => n)).
	  - let n. assume Hn: n :e omega.
	    prove (fun n0:set => n0) n :e omega.
	    exact Hn.
	  - let a. assume Ha: a :e omega.
	    let b. assume Hb: b :e omega.
	    assume Heq: (fun n0:set => n0) a = (fun n0:set => n0) b.
	    prove a = b.
	    exact Heq. }

claim Hpow_countable: forall n:set, n :e omega -> countable (Power n).
{ let n.
  assume Hn: n :e omega.
  prove countable (Power n).
  apply (finite_countable (Power n)).
  prove finite (Power n).
  prove exists m :e omega, equip (Power n) m.
  claim Hn_nat: nat_p n.
  { exact (omega_nat_p n Hn). }
  claim HequipPow: equip (Power n) (exp_nat 2 n).
  { exact (equip_Power_nat n Hn_nat). }
  claim Hpow_nat: nat_p (exp_nat 2 n).
  { exact (exp_nat_p 2 nat_2 n Hn_nat). }
  claim Hpow_omega: (exp_nat 2 n) :e omega.
  { exact (nat_p_omega (exp_nat 2 n) Hpow_nat). }
  witness (exp_nat 2 n).
  apply andI.
  - exact Hpow_omega.
  - exact HequipPow. }

claim HS_countable: countable S.
{ exact (Sigma_countable omega Homega_countable (fun n:set => Power n) Hpow_countable). }

(** Step 2: boundedness of finite subsets of omega **)
claim finite_sub_omega_bounded:
  forall F:set, F c= omega -> finite F -> exists n :e omega, forall m :e F, m :e n.
{ let F.
  assume HFsub: F c= omega.
  assume HFfin: finite F.
  claim Hp0: (Empty c= omega -> exists n :e omega, forall m :e Empty, m :e n).
  { assume Hsub0: Empty c= omega.
    prove exists n :e omega, forall m :e Empty, m :e n.
    witness 0.
    apply andI.
    - exact (nat_p_omega 0 nat_0).
    - let m. assume Hm: m :e Empty.
      apply FalseE.
      exact (EmptyE m Hm). }
  claim Hpstep: forall A y, finite A -> y /:e A ->
    (A c= omega -> exists n :e omega, forall m :e A, m :e n) ->
    (A :\/: {y} c= omega -> exists n0 :e omega, forall m:set, m :e A :\/: {y} -> m :e n0).
  { let A y.
    assume HAfin: finite A.
    assume HyA: y /:e A.
    assume HpA: (A c= omega -> exists n :e omega, forall m :e A, m :e n).
    assume HsubAy: A :\/: {y} c= omega.
    claim HsubA: A c= omega.
    { exact (Subq_tra A (A :\/: {y}) omega (binunion_Subq_1 A {y}) HsubAy). }
    claim Hexn: exists n :e omega, forall m :e A, m :e n.
    { exact (HpA HsubA). }
    apply Hexn.
    let n.
    assume Hnand.
    claim Hn: n :e omega.
    { exact (andEL (n :e omega) (forall m :e A, m :e n) Hnand). }
    claim Hnprop: forall m :e A, m :e n.
    { exact (andER (n :e omega) (forall m :e A, m :e n) Hnand). }
    prove exists n0 :e omega, forall m:set, m :e A :\/: {y} -> m :e n0.
    claim Hy_in_union: y :e A :\/: {y}.
    { apply binunionI2. exact (SingI y). }
    claim Hy_omega: y :e omega.
    { exact (HsubAy y Hy_in_union). }
    claim Hysucc_omega: ordsucc y :e omega.
    { exact (omega_ordsucc y Hy_omega). }
    claim Hn_union_omega: n :\/: ordsucc y :e omega.
    { exact (omega_binunion n (ordsucc y) Hn Hysucc_omega). }
    set n0 := ordsucc (n :\/: ordsucc y).
    claim Hn0_omega: n0 :e omega.
    { exact (omega_ordsucc (n :\/: ordsucc y) Hn_union_omega). }
    witness n0.
    apply andI.
    - exact Hn0_omega.
    - let m. assume Hm: m :e A :\/: {y}.
      prove m :e n0.
      apply (binunionE A {y} m Hm).
      + assume HmA: m :e A.
        claim Hmn: m :e n.
        { exact (Hnprop m HmA). }
        claim HmnU: m :e n :\/: ordsucc y.
        { exact (binunionI1 n (ordsucc y) m Hmn). }
        exact (ordsuccI1 (n :\/: ordsucc y) m HmnU).
      + assume HmY: m :e {y}.
        claim Hmy: m = y.
        { exact (SingE y m HmY). }
        rewrite Hmy.
        claim Hy_in_succ: y :e ordsucc y.
        { exact (ordsuccI2 y). }
        claim Hy_in_U: y :e n :\/: ordsucc y.
        { exact (binunionI2 n (ordsucc y) y Hy_in_succ). }
        exact (ordsuccI1 (n :\/: ordsucc y) y Hy_in_U). }
  claim HpF: (F c= omega -> exists n :e omega, forall m :e F, m :e n).
  { exact (finite_ind (fun A => A c= omega -> exists n :e omega, forall m :e A, m :e n)
                      Hp0 Hpstep F HFfin). }
  apply HpF.
  exact HFsub. }

(** Step 3: build an injection into S and compose with the countable injection of S **)
apply HS_countable.
let codeS : set -> set.
assume HcodeS: inj S omega codeS.
set bound : set -> set := fun F =>
  Eps_i (fun n => n :e omega /\ forall m:set, m :e F -> m :e n).
set emb : set -> set := fun F => (bound F, F).
set code : set -> set := fun F => codeS (emb F).
witness code.

apply (injI (finite_subcollections omega) omega code).
- let F.
  assume HF: F :e finite_subcollections omega.
  prove code F :e omega.
  claim HFpow: F :e Power omega.
  { exact (SepE1 (Power omega) (fun F0:set => finite F0) F HF). }
  claim HFsub: F c= omega.
  { exact (PowerE omega F HFpow). }
  claim HFfin: finite F.
  { exact (SepE2 (Power omega) (fun F0:set => finite F0) F HF). }
  claim Hexb: exists n :e omega, forall m :e F, m :e n.
  { exact (finite_sub_omega_bounded F HFsub HFfin). }
  claim Hboundprop: bound F :e omega /\ forall m:set, m :e F -> m :e bound F.
  { exact (Eps_i_ex (fun n => n :e omega /\ forall m:set, m :e F -> m :e n) Hexb). }
  claim Hbound_omega: bound F :e omega.
  { exact (andEL (bound F :e omega) (forall m:set, m :e F -> m :e bound F) Hboundprop). }
  claim Hbound_sub: forall m:set, m :e F -> m :e bound F.
  { exact (andER (bound F :e omega) (forall m:set, m :e F -> m :e bound F) Hboundprop). }
  claim HFpowB: F :e Power (bound F).
  { claim Hsub: F c= bound F.
    { let m. assume Hm: m :e F.
      exact (Hbound_sub m Hm). }
    exact (PowerI (bound F) F Hsub). }
  claim HembS: emb F :e S.
  { exact (tuple_2_Sigma omega (fun n:set => Power n) (bound F) Hbound_omega F HFpowB). }
  claim Hmap: forall u :e S, codeS u :e omega.
  { exact (andEL (forall u :e S, codeS u :e omega)
                 (forall u v :e S, codeS u = codeS v -> u = v)
                 HcodeS). }
  claim Hdef: code F = codeS (emb F).
  { reflexivity. }
  rewrite Hdef.
  exact (Hmap (emb F) HembS).
- let F1.
  assume HF1: F1 :e finite_subcollections omega.
  let F2.
  assume HF2: F2 :e finite_subcollections omega.
  assume Heq: code F1 = code F2.
  prove F1 = F2.
  claim HF1pow: F1 :e Power omega.
  { exact (SepE1 (Power omega) (fun F0:set => finite F0) F1 HF1). }
  claim HF2pow: F2 :e Power omega.
  { exact (SepE1 (Power omega) (fun F0:set => finite F0) F2 HF2). }
  claim HF1sub: F1 c= omega.
  { exact (PowerE omega F1 HF1pow). }
  claim HF2sub: F2 c= omega.
  { exact (PowerE omega F2 HF2pow). }
  claim HF1fin: finite F1.
  { exact (SepE2 (Power omega) (fun F0:set => finite F0) F1 HF1). }
  claim HF2fin: finite F2.
  { exact (SepE2 (Power omega) (fun F0:set => finite F0) F2 HF2). }
  claim Hexb1: exists n :e omega, forall m :e F1, m :e n.
  { exact (finite_sub_omega_bounded F1 HF1sub HF1fin). }
  claim Hexb2: exists n :e omega, forall m :e F2, m :e n.
  { exact (finite_sub_omega_bounded F2 HF2sub HF2fin). }
  claim Hb1: bound F1 :e omega /\ forall m:set, m :e F1 -> m :e bound F1.
  { exact (Eps_i_ex (fun n => n :e omega /\ forall m:set, m :e F1 -> m :e n) Hexb1). }
  claim Hb2: bound F2 :e omega /\ forall m:set, m :e F2 -> m :e bound F2.
  { exact (Eps_i_ex (fun n => n :e omega /\ forall m:set, m :e F2 -> m :e n) Hexb2). }
  claim Hbound1: bound F1 :e omega.
  { exact (andEL (bound F1 :e omega) (forall m:set, m :e F1 -> m :e bound F1) Hb1). }
  claim Hbound2: bound F2 :e omega.
  { exact (andEL (bound F2 :e omega) (forall m:set, m :e F2 -> m :e bound F2) Hb2). }
  claim HF1powB: F1 :e Power (bound F1).
  { claim Hsub: F1 c= bound F1.
    { let m. assume Hm: m :e F1.
      claim Hsubm: forall m0:set, m0 :e F1 -> m0 :e bound F1.
      { exact (andER (bound F1 :e omega) (forall m0:set, m0 :e F1 -> m0 :e bound F1) Hb1). }
      exact (Hsubm m Hm). }
    exact (PowerI (bound F1) F1 Hsub). }
  claim HF2powB: F2 :e Power (bound F2).
  { claim Hsub: F2 c= bound F2.
    { let m. assume Hm: m :e F2.
      claim Hsubm: forall m0:set, m0 :e F2 -> m0 :e bound F2.
      { exact (andER (bound F2 :e omega) (forall m0:set, m0 :e F2 -> m0 :e bound F2) Hb2). }
      exact (Hsubm m Hm). }
    exact (PowerI (bound F2) F2 Hsub). }
  claim Hemb1: emb F1 :e S.
  { exact (tuple_2_Sigma omega (fun n:set => Power n) (bound F1) Hbound1 F1 HF1powB). }
  claim Hemb2: emb F2 :e S.
  { exact (tuple_2_Sigma omega (fun n:set => Power n) (bound F2) Hbound2 F2 HF2powB). }
  claim Hcodeinj: forall u v :e S, codeS u = codeS v -> u = v.
  { exact (andER (forall u :e S, codeS u :e omega)
                 (forall u v :e S, codeS u = codeS v -> u = v)
                 HcodeS). }
  claim Hdef1: code F1 = codeS (emb F1).
  { reflexivity. }
  claim Hdef2: code F2 = codeS (emb F2).
  { reflexivity. }
  claim HeqS: codeS (emb F1) = codeS (emb F2).
  { rewrite <- Hdef1.
    rewrite <- Hdef2.
    exact Heq. }
  claim HembEq: emb F1 = emb F2.
  { exact (Hcodeinj (emb F1) Hemb1 (emb F2) Hemb2 HeqS). }
  claim HF1Eq: F1 = F2.
  { claim Hemb1def: emb F1 = (bound F1, F1).
    { reflexivity. }
    claim Hemb2def: emb F2 = (bound F2, F2).
    { reflexivity. }
    claim Hproj1: (emb F1) 1 = F1.
    { rewrite Hemb1def.
      exact (tuple_2_1_eq (bound F1) F1). }
    claim Hproj2: (emb F2) 1 = F2.
    { rewrite Hemb2def.
      exact (tuple_2_1_eq (bound F2) F2). }
    claim HapEq: (emb F1) 1 = (emb F2) 1.
    { rewrite HembEq.
      reflexivity. }
    rewrite <- Hproj1.
    rewrite <- Hproj2.
    exact HapEq. }
  exact HF1Eq.
Qed.

(** Helper: finite subcollections of a countable set are countable **)
(** LATEX VERSION: The set of all finite subcollections of a countable set is countable. **)
Theorem finite_subcollections_countable : forall S:set,
  countable_set S -> countable_set (finite_subcollections S).
let S. assume HS: countable_set S.
prove countable_set (finite_subcollections S).
prove countable (finite_subcollections S).
prove exists h : set -> set, inj (finite_subcollections S) omega h.
apply HS.
let f : set -> set.
assume Hf: inj S omega f.
(** It is standard that the family of finite subsets of omega is countable. **)
claim HFinOmega: countable (finite_subcollections omega).
{ exact finite_subcollections_omega_countable. }
apply HFinOmega.
let code : set -> set.
assume Hcode: inj (finite_subcollections omega) omega code.
set ImgF : set -> set := fun F => {f x|x :e F}.
set h : set -> set := fun F => code (ImgF F).
witness h.
apply (injI (finite_subcollections S) omega h).
- let F. assume HF: F :e finite_subcollections S.
  prove h F :e omega.
  claim HFpow: F :e Power S.
  { exact (SepE1 (Power S) (fun F0:set => finite F0) F HF). }
  claim HFfin: finite F.
  { exact (SepE2 (Power S) (fun F0:set => finite F0) F HF). }
  claim Hfmap: forall a :e S, f a :e omega.
  { exact (andEL (forall a :e S, f a :e omega)
                 (forall a b :e S, f a = f b -> a = b)
                 Hf). }
  claim HImgPow: ImgF F :e Power omega.
  { exact (image_In_Power S omega f Hfmap F HFpow). }
  claim HImgFin: finite (ImgF F).
  { exact (Repl_finite f F HFfin). }
  claim HImg: ImgF F :e finite_subcollections omega.
  { exact (SepI (Power omega) (fun F0:set => finite F0) (ImgF F) HImgPow HImgFin). }
  claim Hcodemap: forall u :e finite_subcollections omega, code u :e omega.
  { exact (andEL (forall u :e finite_subcollections omega, code u :e omega)
                 (forall u v :e finite_subcollections omega, code u = code v -> u = v)
                 Hcode). }
  claim Hhdef: h F = code (ImgF F).
  { reflexivity. }
  rewrite Hhdef.
  exact (Hcodemap (ImgF F) HImg).
- let F1. assume HF1: F1 :e finite_subcollections S.
  let F2. assume HF2: F2 :e finite_subcollections S.
  assume Heq: h F1 = h F2.
  prove F1 = F2.
  claim HF1pow: F1 :e Power S.
  { exact (SepE1 (Power S) (fun F0:set => finite F0) F1 HF1). }
  claim HF2pow: F2 :e Power S.
  { exact (SepE1 (Power S) (fun F0:set => finite F0) F2 HF2). }
  claim HF1sub: F1 c= S.
  { exact (PowerE S F1 HF1pow). }
  claim HF2sub: F2 c= S.
  { exact (PowerE S F2 HF2pow). }
  claim Hf_inj: forall a b :e S, f a = f b -> a = b.
  { exact (andER (forall a :e S, f a :e omega)
                 (forall a b :e S, f a = f b -> a = b)
                 Hf). }
  claim Hfmap: forall a :e S, f a :e omega.
  { exact (andEL (forall a :e S, f a :e omega)
                 (forall a b :e S, f a = f b -> a = b)
                 Hf). }
  claim HImg1: ImgF F1 :e finite_subcollections omega.
  { claim HF1fin: finite F1.
    { exact (SepE2 (Power S) (fun F0:set => finite F0) F1 HF1). }
    claim HImgPow: ImgF F1 :e Power omega.
    { exact (image_In_Power S omega f Hfmap F1 HF1pow). }
    claim HImgFin: finite (ImgF F1).
    { exact (Repl_finite f F1 HF1fin). }
    exact (SepI (Power omega) (fun F0:set => finite F0) (ImgF F1) HImgPow HImgFin). }
  claim HImg2: ImgF F2 :e finite_subcollections omega.
  { claim HF2fin: finite F2.
    { exact (SepE2 (Power S) (fun F0:set => finite F0) F2 HF2). }
    claim HImgPow: ImgF F2 :e Power omega.
    { exact (image_In_Power S omega f Hfmap F2 HF2pow). }
    claim HImgFin: finite (ImgF F2).
    { exact (Repl_finite f F2 HF2fin). }
    exact (SepI (Power omega) (fun F0:set => finite F0) (ImgF F2) HImgPow HImgFin). }
  claim Hcodeinj: forall u v :e finite_subcollections omega, code u = code v -> u = v.
  { exact (andER (forall u :e finite_subcollections omega, code u :e omega)
                 (forall u v :e finite_subcollections omega, code u = code v -> u = v)
                 Hcode). }
  claim Hhdef1: h F1 = code (ImgF F1).
  { reflexivity. }
  claim Hhdef2: h F2 = code (ImgF F2).
  { reflexivity. }
  claim HeqImg: ImgF F1 = ImgF F2.
  { apply (Hcodeinj (ImgF F1) HImg1 (ImgF F2) HImg2).
    claim Hcodeeq: code (ImgF F1) = code (ImgF F2).
    { claim Hc1: code (ImgF F1) = h F1.
      { symmetry. exact Hhdef1. }
      claim Hc2: h F2 = code (ImgF F2).
      { exact Hhdef2. }
      claim Hmid: code (ImgF F1) = h F2.
      { exact (eq_i_tra (code (ImgF F1)) (h F1) (h F2) Hc1 Heq). }
      exact (eq_i_tra (code (ImgF F1)) (h F2) (code (ImgF F2)) Hmid Hc2). }
    exact Hcodeeq. }
  apply set_ext.
  + let x. assume Hx1: x :e F1.
    prove x :e F2.
    claim HxS: x :e S.
    { exact (HF1sub x Hx1). }
    claim Hfx1: f x :e ImgF F1.
    { exact (ReplI F1 f x Hx1). }
    claim Hfx2: f x :e ImgF F2.
    { rewrite <- HeqImg. exact Hfx1. }
    apply (ReplE_impred F2 f (f x) Hfx2).
    let y. assume Hy2: y :e F2.
    assume Hfxy: f x = f y.
    claim HyS: y :e S.
    { exact (HF2sub y Hy2). }
    claim Heqxy: x = y.
    { exact (Hf_inj x HxS y HyS Hfxy). }
    rewrite Heqxy.
    exact Hy2.
  + let x. assume Hx2: x :e F2.
    prove x :e F1.
    claim HxS: x :e S.
    { exact (HF2sub x Hx2). }
    claim Hfx2: f x :e ImgF F2.
    { exact (ReplI F2 f x Hx2). }
    claim Hfx1: f x :e ImgF F1.
    { rewrite HeqImg. exact Hfx2. }
    apply (ReplE_impred F1 f (f x) Hfx1).
    let y. assume Hy1: y :e F1.
    assume Hfxy: f x = f y.
    claim HyS: y :e S.
    { exact (HF1sub y Hy1). }
    claim Heqxy: x = y.
    { exact (Hf_inj x HxS y HyS Hfxy). }
    rewrite Heqxy.
    exact Hy1.
Qed.

(** Helper: finite intersections of a countable family form a countable family **)
(** LATEX VERSION: The family of finite intersections of members of a countable family is countable. **)
Theorem finite_intersections_of_countable : forall X S:set,
  countable_set S -> countable_set (finite_intersections_of X S).
let X S. assume HS: countable_set S.
prove countable_set (finite_intersections_of X S).
set FS := finite_subcollections S.
claim HFS: countable_set FS.
{ exact (finite_subcollections_countable S HS). }
exact (countable_image FS HFS (fun F0:set => intersection_of_family X F0)).
Qed.

(** Helper: the basis from a countable subbasis is countable **)
(** LATEX VERSION: If a subbasis is countable, then the associated basis of nonempty finite intersections is countable. **)
Theorem basis_of_subbasis_countable : forall X S:set,
  countable_set S -> countable_set (basis_of_subbasis X S).
let X S. assume HS: countable_set S.
prove countable_set (basis_of_subbasis X S).
claim Hfin: countable_set (finite_intersections_of X S).
{ exact (finite_intersections_of_countable X S HS). }
prove countable (basis_of_subbasis X S).
apply (Subq_countable (basis_of_subbasis X S) (finite_intersections_of X S)).
- exact Hfin.
- let b. assume Hb: b :e basis_of_subbasis X S.
  prove b :e finite_intersections_of X S.
  exact (SepE1 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b Hb).
Qed.
(** LATEX VERSION: Real sequences and uniform metric/topology on R^ω (setup). **)
(** FIXED: real_sequences is the set of total single-valued graphs omega -> R. **)
Definition real_sequences : set :=
  {f :e Power (setprod omega R) | total_function_on f omega R /\ functional_graph f}.

(** helper: extensionality for real_sequences by pointwise apply_fun equality **)
Theorem real_sequences_ext : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  (forall n:set, n :e omega -> apply_fun f n = apply_fun g n) ->
  f = g.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hagree: forall n:set, n :e omega -> apply_fun f n = apply_fun g n.
claim HfPow: f :e Power (setprod omega R).
{ exact (SepE1 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim HgPow: g :e Power (setprod omega R).
{ exact (SepE1 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               g Hg). }
claim HfSub: f c= setprod omega R.
{ exact (PowerE (setprod omega R) f HfPow). }
claim HgSub: g c= setprod omega R.
{ exact (PowerE (setprod omega R) g HgPow). }
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R))
               (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
               g Hg). }
claim Hftot: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Hgtot: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim Hffun: functional_graph f.
{ exact (andER (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Hgfun: functional_graph g.
{ exact (andER (total_function_on g omega R) (functional_graph g) Hgpack). }
claim Hgtot2: forall n:set, n :e omega -> exists y:set, y :e R /\ (n,y) :e g.
{ exact (andER (function_on g omega R)
               (forall x:set, x :e omega -> exists y:set, y :e R /\ (x,y) :e g)
               Hgtot). }
claim Hftot2: forall n:set, n :e omega -> exists y:set, y :e R /\ (n,y) :e f.
{ exact (andER (function_on f omega R)
               (forall x:set, x :e omega -> exists y:set, y :e R /\ (x,y) :e f)
               Hftot). }
apply set_ext.
- let p. assume Hp: p :e f.
  prove p :e g.
  claim HpXY: p :e setprod omega R.
  { exact (HfSub p Hp). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta omega R p HpXY). }
  claim Hp0: p 0 :e omega.
  { exact (ap0_Sigma omega (fun _ : set => R) p HpXY). }
  claim Hp1: p 1 :e R.
  { exact (ap1_Sigma omega (fun _ : set => R) p HpXY). }
  claim Hpair: (p 0, p 1) :e f.
  { rewrite <- Heta.
    exact Hp. }
  claim Happf: apply_fun f (p 0) = (p 1).
  { exact (functional_graph_apply_fun_eq f (p 0) (p 1) Hffun Hpair). }
  claim Hfg: apply_fun f (p 0) = apply_fun g (p 0).
  { exact (Hagree (p 0) Hp0). }
  claim Hgf: apply_fun g (p 0) = apply_fun f (p 0).
  { symmetry.
    exact Hfg. }
  claim Happg: apply_fun g (p 0) = (p 1).
  { rewrite Hgf.
    exact Happf. }
  claim Hexg: exists y:set, (p 0, y) :e g.
  { apply (Hgtot2 (p 0) Hp0).
    let y.
    assume Hy: y :e R /\ (p 0, y) :e g.
    witness y.
    exact (andER (y :e R) ((p 0, y) :e g) Hy). }
  claim Hgpair: (p 0, apply_fun g (p 0)) :e g.
  { exact (apply_fun_in_graph_of_ex g (p 0) Hexg). }
  claim Hpeq: (p 0, apply_fun g (p 0)) = (p 0, p 1).
  { rewrite Happg.
    reflexivity. }
  rewrite Heta.
  rewrite <- Hpeq.
  exact Hgpair.
- let p. assume Hp: p :e g.
  prove p :e f.
  claim HpXY: p :e setprod omega R.
  { exact (HgSub p Hp). }
  claim Heta: p = (p 0, p 1).
  { exact (setprod_eta omega R p HpXY). }
  claim Hp0: p 0 :e omega.
  { exact (ap0_Sigma omega (fun _ : set => R) p HpXY). }
  claim Hp1: p 1 :e R.
  { exact (ap1_Sigma omega (fun _ : set => R) p HpXY). }
  claim Hpair: (p 0, p 1) :e g.
  { rewrite <- Heta.
    exact Hp. }
  claim Happg: apply_fun g (p 0) = (p 1).
  { exact (functional_graph_apply_fun_eq g (p 0) (p 1) Hgfun Hpair). }
  claim Hfg: apply_fun f (p 0) = apply_fun g (p 0).
  { exact (Hagree (p 0) Hp0). }
  claim Happf: apply_fun f (p 0) = (p 1).
  { rewrite Hfg.
    exact Happg. }
  claim Hexf: exists y:set, (p 0, y) :e f.
  { apply (Hftot2 (p 0) Hp0).
    let y.
    assume Hy: y :e R /\ (p 0, y) :e f.
    witness y.
    exact (andER (y :e R) ((p 0, y) :e f) Hy). }
  claim Hfpair: (p 0, apply_fun f (p 0)) :e f.
  { exact (apply_fun_in_graph_of_ex f (p 0) Hexf). }
  claim Hpeq: (p 0, apply_fun f (p 0)) = (p 0, p 1).
  { rewrite Happf.
    reflexivity. }
  rewrite Heta.
  rewrite <- Hpeq.
  exact Hfpair.
Qed.

(** helper: existence of a metric on any set (discrete metric construction) **)
(** LATEX VERSION: Every set admits a metric (e.g. the discrete metric). **)
Theorem exists_metric_on : forall X:set, exists d:set, metric_on X d.
let X.
(** Discrete metric: d(x,y)=0 if x=y, else 1. **)
set g : set -> set := fun p:set => if (p 0 = p 1) then 0 else 1.
set d : set := graph (setprod X X) g.
witness d.
prove metric_on X d.
prove ((((function_on d (setprod X X) R /\
         (forall x y:set, x :e X -> y :e X -> apply_fun d (x,y) = apply_fun d (y,x))) /\
        (forall x:set, x :e X -> apply_fun d (x,x) = 0)) /\
       (forall x y:set, x :e X -> y :e X ->
         ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y))) /\
      (forall x y z:set, x :e X -> y :e X -> z :e X ->
        ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))) (apply_fun d (x,z))))).
apply andI.
- (** left-associative core: ((A /\ B) /\ C) /\ D **)
  apply andI.
  + (** (A /\ B) /\ C **)
    apply andI.
    * (** A /\ B **)
      apply andI.
      - (** function_on d (X×X) R **)
         prove function_on d (setprod X X) R.
         let p. assume Hp: p :e setprod X X.
         prove apply_fun d p :e R.
         rewrite (apply_fun_graph (setprod X X) g p Hp).
         apply (xm (p 0 = p 1) ((if (p 0 = p 1) then 0 else 1) :e R)).
         - assume H01: p 0 = p 1.
           rewrite (If_i_1 (p 0 = p 1) 0 1 H01).
           exact real_0.
         - assume H01n: ~(p 0 = p 1).
           rewrite (If_i_0 (p 0 = p 1) 0 1 H01n).
           exact real_1.
      - (** symmetry **)
         let x y. assume Hx: x :e X. assume Hy: y :e X.
         prove apply_fun d (x,y) = apply_fun d (y,x).
         claim Hxyprod: (x,y) :e setprod X X.
         { exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
         claim Hyxprod: (y,x) :e setprod X X.
         { exact (tuple_2_setprod_by_pair_Sigma X X y x Hy Hx). }
         rewrite (apply_fun_graph (setprod X X) g (x,y) Hxyprod).
         rewrite (apply_fun_graph (setprod X X) g (y,x) Hyxprod).
         apply (xm (x = y)
                   ((if (x,y) 0 = (x,y) 1 then 0 else 1) =
                    (if (y,x) 0 = (y,x) 1 then 0 else 1))).
         - assume Hxy: x = y.
            claim H01: (x,y) 0 = (x,y) 1.
            { rewrite (tuple_2_0_eq x y).
              rewrite (tuple_2_1_eq x y).
              exact Hxy. }
            claim H10: (y,x) 0 = (y,x) 1.
            { rewrite (tuple_2_0_eq y x).
              rewrite (tuple_2_1_eq y x).
              symmetry. exact Hxy. }
            rewrite (If_i_1 ((x,y) 0 = (x,y) 1) 0 1 H01).
            rewrite (If_i_1 ((y,x) 0 = (y,x) 1) 0 1 H10).
            reflexivity.
         - assume HxyN: ~(x = y).
            claim H01n: ~((x,y) 0 = (x,y) 1).
            { assume H01.
              apply HxyN.
              prove x = y.
              claim H0: (x,y) 0 = x.
              { exact (tuple_2_0_eq x y). }
              claim H1: (x,y) 1 = y.
              { exact (tuple_2_1_eq x y). }
              rewrite <- H0 at 1.
              rewrite <- H1 at 2.
              exact H01. }
            claim H10n: ~((y,x) 0 = (y,x) 1).
            { assume H10.
              apply HxyN.
              prove x = y.
              claim Hy0: (y,x) 0 = y.
              { exact (tuple_2_0_eq y x). }
              claim Hx1: (y,x) 1 = x.
              { exact (tuple_2_1_eq y x). }
              rewrite <- Hx1 at 1.
              rewrite <- Hy0 at 2.
              symmetry.
              exact H10. }
            rewrite (If_i_0 ((x,y) 0 = (x,y) 1) 0 1 H01n).
            rewrite (If_i_0 ((y,x) 0 = (y,x) 1) 0 1 H10n).
            reflexivity.
    * (** diagonal zero **)
      let x. assume Hx: x :e X.
      prove apply_fun d (x,x) = 0.
      claim Hxxprod: (x,x) :e setprod X X.
      { exact (tuple_2_setprod_by_pair_Sigma X X x x Hx Hx). }
      rewrite (apply_fun_graph (setprod X X) g (x,x) Hxxprod).
      rewrite (tuple_2_0_eq x x).
      rewrite (tuple_2_1_eq x x).
      claim Hrefl: x = x.
      { reflexivity. }
      rewrite (If_i_1 (x = x) 0 1 Hrefl).
      reflexivity.
  + (** nonneg + identity of indiscernibles **)
    let x y. assume Hx: x :e X. assume Hy: y :e X.
    prove ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y).
    claim Hxyprod: (x,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
    rewrite (apply_fun_graph (setprod X X) g (x,y) Hxyprod).
    apply (xm (x = y) ( ~(Rlt (if (x,y) 0 = (x,y) 1 then 0 else 1) 0) /\
                         ((if (x,y) 0 = (x,y) 1 then 0 else 1) = 0 -> x = y))).
    * assume Hxy: x = y.
      claim H01: (x,y) 0 = (x,y) 1.
      { rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        exact Hxy. }
      rewrite (If_i_1 ((x,y) 0 = (x,y) 1) 0 1 H01).
    apply andI.
      - exact (not_Rlt_refl 0 real_0).
      - assume _. exact Hxy.
    * assume HxyN: ~(x = y).
      claim H01n: ~((x,y) 0 = (x,y) 1).
      { assume H01.
        apply HxyN.
        prove x = y.
        claim H0: (x,y) 0 = x.
        { exact (tuple_2_0_eq x y). }
        claim H1: (x,y) 1 = y.
        { exact (tuple_2_1_eq x y). }
        rewrite <- H0 at 1.
        rewrite <- H1 at 2.
        exact H01. }
      rewrite (If_i_0 ((x,y) 0 = (x,y) 1) 0 1 H01n).
    apply andI.
      - exact (not_Rlt_sym 0 1 Rlt_0_1).
      - assume H10: 1 = 0.
         apply FalseE.
         exact (neq_1_0 H10).
- (** triangle inequality **)
  let x y z. assume Hx: x :e X. assume Hy: y :e X. assume Hz: z :e X.
  prove ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))) (apply_fun d (x,z))).
  claim Hxyprod: (x,y) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
  claim Hyzprod: (y,z) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X y z Hy Hz). }
  claim Hxzprod: (x,z) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x z Hx Hz). }
  rewrite (apply_fun_graph (setprod X X) g (x,y) Hxyprod).
  rewrite (apply_fun_graph (setprod X X) g (y,z) Hyzprod).
  rewrite (apply_fun_graph (setprod X X) g (x,z) Hxzprod).
  apply (xm (x = y) (~(Rlt (add_SNo (if (x,y) 0 = (x,y) 1 then 0 else 1)
                                     (if (y,z) 0 = (y,z) 1 then 0 else 1))
                            (if (x,z) 0 = (x,z) 1 then 0 else 1)))).
  - assume Hxy: x = y.
    claim Hxy01: (x,y) 0 = (x,y) 1.
    { rewrite (tuple_2_0_eq x y).
      rewrite (tuple_2_1_eq x y).
      exact Hxy. }
    rewrite (If_i_1 ((x,y) 0 = (x,y) 1) 0 1 Hxy01).
    apply (xm (y = z) (~(Rlt (add_SNo 0 (if (y,z) 0 = (y,z) 1 then 0 else 1))
                              (if (x,z) 0 = (x,z) 1 then 0 else 1)))).
    - assume Hyz: y = z.
      claim Hyz01: (y,z) 0 = (y,z) 1.
      { rewrite (tuple_2_0_eq y z).
        rewrite (tuple_2_1_eq y z).
        exact Hyz. }
      claim Hxz: x = z.
      { rewrite Hxy. exact Hyz. }
      claim Hxz01: (x,z) 0 = (x,z) 1.
      { rewrite (tuple_2_0_eq x z).
        rewrite (tuple_2_1_eq x z).
        exact Hxz. }
      rewrite (If_i_1 ((y,z) 0 = (y,z) 1) 0 1 Hyz01).
      rewrite (If_i_1 ((x,z) 0 = (x,z) 1) 0 1 Hxz01).
      rewrite (add_SNo_0L 0 SNo_0).
      exact (not_Rlt_refl 0 real_0).
    - assume HyzN: ~(y = z).
      claim Hyz01n: ~((y,z) 0 = (y,z) 1).
      { assume H01.
        apply HyzN.
        prove y = z.
        claim H0: (y,z) 0 = y.
        { exact (tuple_2_0_eq y z). }
        claim H1: (y,z) 1 = z.
        { exact (tuple_2_1_eq y z). }
        rewrite <- H0 at 1.
        rewrite <- H1 at 2.
        exact H01. }
      claim Hxz01n: ~((x,z) 0 = (x,z) 1).
      { assume H01.
        apply HyzN.
        prove y = z.
        rewrite <- Hxy.
        claim H0: (x,z) 0 = x.
        { exact (tuple_2_0_eq x z). }
        claim H1: (x,z) 1 = z.
        { exact (tuple_2_1_eq x z). }
        rewrite <- H0 at 1.
        rewrite <- H1 at 2.
        exact H01. }
      rewrite (If_i_0 ((y,z) 0 = (y,z) 1) 0 1 Hyz01n).
      rewrite (If_i_0 ((x,z) 0 = (x,z) 1) 0 1 Hxz01n).
      rewrite (add_SNo_0L 1 SNo_1).
      exact (not_Rlt_refl 1 real_1).
  - assume HxyN: ~(x = y).
    claim Hxy01n: ~((x,y) 0 = (x,y) 1).
    { assume H01.
      apply HxyN.
      prove x = y.
      claim H0: (x,y) 0 = x.
      { exact (tuple_2_0_eq x y). }
      claim H1: (x,y) 1 = y.
      { exact (tuple_2_1_eq x y). }
      rewrite <- H0 at 1.
      rewrite <- H1 at 2.
      exact H01. }
    rewrite (If_i_0 ((x,y) 0 = (x,y) 1) 0 1 Hxy01n).
    apply (xm (y = z) (~(Rlt (add_SNo 1 (if (y,z) 0 = (y,z) 1 then 0 else 1))
                              (if (x,z) 0 = (x,z) 1 then 0 else 1)))).
    - assume Hyz: y = z.
      claim Hyz01: (y,z) 0 = (y,z) 1.
      { rewrite (tuple_2_0_eq y z).
        rewrite (tuple_2_1_eq y z).
        exact Hyz. }
      claim Hxz01n: ~((x,z) 0 = (x,z) 1).
      { assume H01.
        apply HxyN.
        prove x = y.
        rewrite Hyz.
        claim H0: (x,z) 0 = x.
        { exact (tuple_2_0_eq x z). }
        claim H1: (x,z) 1 = z.
        { exact (tuple_2_1_eq x z). }
        rewrite <- H0 at 1.
        rewrite <- H1 at 2.
        exact H01. }
      rewrite (If_i_1 ((y,z) 0 = (y,z) 1) 0 1 Hyz01).
      rewrite (If_i_0 ((x,z) 0 = (x,z) 1) 0 1 Hxz01n).
      rewrite (add_SNo_0R 1 SNo_1).
      exact (not_Rlt_refl 1 real_1).
    - assume HyzN: ~(y = z).
      claim Hyz01n: ~((y,z) 0 = (y,z) 1).
      { assume H01.
        apply HyzN.
        prove y = z.
        claim H0: (y,z) 0 = y.
        { exact (tuple_2_0_eq y z). }
        claim H1: (y,z) 1 = z.
        { exact (tuple_2_1_eq y z). }
        rewrite <- H0 at 1.
        rewrite <- H1 at 2.
        exact H01. }
      rewrite (If_i_0 ((y,z) 0 = (y,z) 1) 0 1 Hyz01n).
      apply (xm (x = z) (~(Rlt (add_SNo 1 1) (if (x,z) 0 = (x,z) 1 then 0 else 1)))).
      - assume Hxz: x = z.
         claim Hxz01: (x,z) 0 = (x,z) 1.
         { rewrite (tuple_2_0_eq x z).
           rewrite (tuple_2_1_eq x z).
           exact Hxz. }
         rewrite (If_i_1 ((x,z) 0 = (x,z) 1) 0 1 Hxz01).
         rewrite add_SNo_1_1_2.
         claim H0lt2: Rlt 0 2.
         { exact (RltI 0 2 real_0 real_2 SNoLt_0_2). }
         exact (not_Rlt_sym 0 2 H0lt2).
      - assume HxzN: ~(x = z).
         claim Hxz01n: ~((x,z) 0 = (x,z) 1).
         { assume H01.
           apply HxzN.
           prove x = z.
           claim H0: (x,z) 0 = x.
           { exact (tuple_2_0_eq x z). }
           claim H1: (x,z) 1 = z.
           { exact (tuple_2_1_eq x z). }
           rewrite <- H0 at 1.
           rewrite <- H1 at 2.
           exact H01. }
         rewrite (If_i_0 ((x,z) 0 = (x,z) 1) 0 1 Hxz01n).
         rewrite add_SNo_1_1_2.
         claim H12: Rlt 1 2.
         { exact (RltI 1 2 real_1 real_2 SNoLt_1_2). }
         exact (not_Rlt_sym 1 2 H12).
Qed.

(** helper: each component carrier in the constant omega-family is R **)
Theorem space_family_set_const_Romega : forall i:set,
  i :e omega ->
  space_family_set (const_space_family omega R R_standard_topology) i = R.
let i.
assume HiO: i :e omega.
set Xi := const_space_family omega R R_standard_topology.
claim HXi: apply_fun Xi i = (R, R_standard_topology).
{ exact (const_space_family_apply omega R R_standard_topology i HiO). }
prove (apply_fun Xi i) 0 = R.
rewrite HXi.
exact (tuple_2_0_eq R R_standard_topology).
Qed.

(** helper: the carrier union in the constant omega-family is R **)
Theorem space_family_union_const_Romega :
  space_family_union omega (const_space_family omega R R_standard_topology) = R.
set Xi := const_space_family omega R R_standard_topology.
apply set_ext.
- let y.
  assume HyU: y :e space_family_union omega Xi.
  prove y :e R.
  set S := {space_family_set Xi i|i :e omega}.
  apply (UnionE_impred S y HyU (y :e R)).
  let U.
  assume HyUin: y :e U.
  assume HUin: U :e S.
  apply (ReplE_impred omega (fun i:set => space_family_set Xi i) U HUin (y :e R)).
  let i.
  assume HiO: i :e omega.
  assume HUi: U = space_family_set Xi i.
  claim HySf: y :e space_family_set Xi i.
  { prove y :e space_family_set Xi i.
    rewrite <- HUi.
    exact HyUin. }
  rewrite <- (space_family_set_const_Romega i HiO).
  exact HySf.
- let y.
  assume HyR: y :e R.
  prove y :e space_family_union omega Xi.
  set S := {space_family_set Xi i|i :e omega}.
  prove y :e Union S.
  claim H0O: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim HUin: space_family_set Xi 0 :e S.
  { exact (ReplI omega (fun i:set => space_family_set Xi i) 0 H0O). }
  claim HyU0: y :e space_family_set Xi 0.
  { rewrite (space_family_set_const_Romega 0 H0O).
    exact HyR. }
  exact (UnionI S y (space_family_set Xi 0) HyU0 HUin).
Qed.

(** helper: the set of real sequences is the same as R to the omega product space **)
Theorem real_sequences_eq_Romega_space : real_sequences = R_omega_space.
apply set_ext.
- let f.
  assume Hf: f :e real_sequences.
  prove f :e R_omega_space.
  claim Hdef: R_omega_space = product_space omega (const_space_family omega R R_standard_topology).
  { reflexivity. }
  rewrite Hdef.
  prove f :e product_space omega (const_space_family omega R R_standard_topology).
  claim Hproddef: product_space omega (const_space_family omega R R_standard_topology) =
    {f0 :e Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology)))|
       total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
       forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i}.
  { reflexivity. }
  rewrite Hproddef.
  apply (SepI (Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology))))
              (fun f0:set =>
                 total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
                 forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i)
              f).
  - (** membership in Power **)
    claim HfPow: f :e Power (setprod omega R).
    { exact (SepE1 (Power (setprod omega R))
                   (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
                   f
                   Hf). }
    rewrite (space_family_union_const_Romega).
    exact HfPow.
  - (** predicate part **)
    claim Hpack: total_function_on f omega R /\ functional_graph f.
    { exact (SepE2 (Power (setprod omega R))
                   (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
                   f
                   Hf). }
    claim Htot: total_function_on f omega R.
    { exact (andEL (total_function_on f omega R) (functional_graph f) Hpack). }
    claim Hfun: functional_graph f.
    { exact (andER (total_function_on f omega R) (functional_graph f) Hpack). }
    apply andI.
    + apply andI.
      * rewrite (space_family_union_const_Romega).
        exact Htot.
      * exact Hfun.
    + let i.
      assume HiO: i :e omega.
      rewrite (space_family_set_const_Romega i HiO).
      exact (total_function_on_apply_fun_in_Y f omega R i Htot HiO).
- let f.
  assume Hf: f :e R_omega_space.
  prove f :e real_sequences.
  claim Hdef: R_omega_space = product_space omega (const_space_family omega R R_standard_topology).
  { reflexivity. }
  claim Hproddef: product_space omega (const_space_family omega R R_standard_topology) =
    {f0 :e Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology)))|
       total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
       forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i}.
  { reflexivity. }
  claim HfP: f :e {f0 :e Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology)))|
                    total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
                    forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i}.
  { rewrite <- Hproddef.
    rewrite <- Hdef.
    exact Hf. }
  (** unpack product_space membership **)
  claim HfPowU: f :e Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology))).
  { exact (SepE1 (Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology))))
                 (fun f0:set =>
                    total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
                    forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i)
                 f
                 HfP). }
  claim HfPred: total_function_on f omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f /\
                forall i:set, i :e omega -> apply_fun f i :e space_family_set (const_space_family omega R R_standard_topology) i.
  { exact (SepE2 (Power (setprod omega (space_family_union omega (const_space_family omega R R_standard_topology))))
                 (fun f0:set =>
                    total_function_on f0 omega (space_family_union omega (const_space_family omega R R_standard_topology)) /\ functional_graph f0 /\
                    forall i:set, i :e omega -> apply_fun f0 i :e space_family_set (const_space_family omega R R_standard_topology) i)
                 f
                 HfP). }
  set A := total_function_on f omega (space_family_union omega (const_space_family omega R R_standard_topology)).
  set B := functional_graph f.
  set C := forall i:set, i :e omega -> apply_fun f i :e space_family_set (const_space_family omega R R_standard_topology) i.
  claim Hab: A /\ B.
  { exact (andEL (A /\ B) C HfPred). }
  claim HtotU: A.
  { exact (andEL A B Hab). }
  claim Hfun: B.
  { exact (andER A B Hab). }
  (** build real_sequences membership **)
  apply (SepI (Power (setprod omega R))
              (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
              f).
  - rewrite <- (space_family_union_const_Romega).
    exact HfPowU.
	  - apply andI.
	    + rewrite <- (space_family_union_const_Romega).
	      exact HtotU.
	    + exact Hfun.
Qed.

	(** from §20 Definition: uniform metric on R^J (coordinate absolute differences) **)
(** LATEX VERSION: Define d̄(x,y)=min{|x-y|,1} and ρ̄(x,y)=sup{ d̄(xα,yα) | α∈J }. **)
Definition Romega_coord_abs_diff : set -> set -> set -> set := fun f g n =>
  abs_SNo (add_SNo (apply_fun f n) (minus_SNo (apply_fun g n))).

(** from §20 Definition: uniform metric on R^J (clipped coordinate differences) **)
(** LATEX VERSION: Use the bounded metric d̄(x,y)=min{|x-y|,1} on R. **)
Definition Romega_coord_clipped_diff : set -> set -> set -> set := fun f g n =>
  If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.

(** from §20 Definition: uniform metric on R^J (family of clipped differences) **)
(** LATEX VERSION: ρ̄(x,y)=sup{ d̄(xα,yα) | α∈J }. **)
Definition Romega_clipped_diffs : set -> set -> set := fun f g =>
  Repl omega (fun n:set => Romega_coord_clipped_diff f g n).

(** helper: clipped diffs are symmetric **)
Theorem Romega_clipped_diffs_sym : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  Romega_clipped_diffs f g = Romega_clipped_diffs g f.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
apply (ReplEq_ext omega
        (fun n:set => Romega_coord_clipped_diff f g n)
        (fun n:set => Romega_coord_clipped_diff g f n)).
let n.
assume HnO: n :e omega.
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R))
               (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
               g Hg). }
claim Htotf: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Htotg: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HgnR: apply_fun g n :e R.
{ exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
claim HfnS: SNo (apply_fun f n).
{ exact (real_SNo (apply_fun f n) HfnR). }
claim HgnS: SNo (apply_fun g n).
{ exact (real_SNo (apply_fun g n) HgnR). }
claim Habs: Romega_coord_abs_diff f g n = Romega_coord_abs_diff g f n.
{ exact (abs_SNo_dist_swap (apply_fun f n) (apply_fun g n) HfnS HgnS). }
claim Hdef1: Romega_coord_clipped_diff f g n =
  If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
{ reflexivity. }
claim Hdef2: Romega_coord_clipped_diff g f n =
  If_i (Rlt (Romega_coord_abs_diff g f n) 1) (Romega_coord_abs_diff g f n) 1.
{ reflexivity. }
rewrite Hdef1.
rewrite Hdef2.
rewrite Habs.
reflexivity.
Qed.

(** helper: clipped coordinate diff is 0 on the diagonal **)
Theorem Romega_coord_clipped_diff_self_zero : forall f n:set,
  f :e real_sequences ->
  n :e omega ->
  Romega_coord_clipped_diff f f n = 0.
let f n.
assume Hf: f :e real_sequences.
assume HnO: n :e omega.
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Htotf: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HfnS: SNo (apply_fun f n).
{ exact (real_SNo (apply_fun f n) HfnR). }
set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun f n)).
claim Ht0: t = 0.
{ exact (add_SNo_minus_SNo_rinv (apply_fun f n) HfnS). }
claim H0le0: 0 <= 0.
{ exact (SNoLe_ref 0). }
claim Habseq: abs_SNo 0 = 0.
{ exact (nonneg_abs_SNo 0 H0le0). }
claim Habs0: abs_SNo t = 0.
{ rewrite Ht0.
  exact Habseq. }
claim HdefAbs: Romega_coord_abs_diff f f n = abs_SNo t.
{ reflexivity. }
claim HdefClip: Romega_coord_clipped_diff f f n =
  If_i (Rlt (Romega_coord_abs_diff f f n) 1) (Romega_coord_abs_diff f f n) 1.
{ reflexivity. }
rewrite HdefClip.
rewrite HdefAbs.
rewrite Habs0.
rewrite (If_i_1 (Rlt 0 1) 0 1 Rlt_0_1).
reflexivity.
Qed.

(** helper: clipped diffs are {0} on the diagonal **)
Theorem Romega_clipped_diffs_diag_eq_Sing0 : forall f:set,
  f :e real_sequences ->
  Romega_clipped_diffs f f = {0}.
let f.
assume Hf: f :e real_sequences.
apply set_ext.
- let a.
  assume Ha: a :e Romega_clipped_diffs f f.
  prove a :e {0}.
  apply (ReplE_impred omega
                      (fun n:set => Romega_coord_clipped_diff f f n)
                      a
                      Ha
                      (a :e {0})).
  let n.
  assume HnO: n :e omega.
  assume Han: a = Romega_coord_clipped_diff f f n.
  rewrite Han.
  claim Hz: Romega_coord_clipped_diff f f n = 0.
  { exact (Romega_coord_clipped_diff_self_zero f n Hf HnO). }
  rewrite Hz.
  exact (SingI 0).
- let a.
  assume Ha0: a :e {0}.
  prove a :e Romega_clipped_diffs f f.
  claim HaEq: a = 0.
  { exact (SingE 0 a Ha0). }
  rewrite HaEq.
  prove 0 :e Romega_clipped_diffs f f.
  claim H0O: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim Hdef: 0 = Romega_coord_clipped_diff f f 0.
  { rewrite (Romega_coord_clipped_diff_self_zero f 0 Hf H0O).
    reflexivity. }
  rewrite Hdef.
  exact (ReplI omega (fun n:set => Romega_coord_clipped_diff f f n) 0 H0O).
Qed.

(** from §20 Definition: uniform metric on R^J (supremum of clipped coordinate differences) **)
(** LATEX VERSION: Define ρ̄(x,y)=sup{ d̄(xα,yα) | α∈J }. **)
Definition Romega_uniform_metric_value : set -> set -> set := fun f g =>
  Eps_i (fun r:set => R_lub (Romega_clipped_diffs f g) r).

(** helper: clipped diffs are real numbers **)
Theorem Romega_clipped_diffs_in_R : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  forall a:set, a :e Romega_clipped_diffs f g -> a :e R.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
let a.
assume HaA: a :e Romega_clipped_diffs f g.
prove a :e R.
apply (ReplE_impred omega
                    (fun n:set => Romega_coord_clipped_diff f g n)
                    a
                    HaA
                    (a :e R)).
let n.
assume HnO: n :e omega.
assume Han: a = Romega_coord_clipped_diff f g n.
rewrite Han.
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R))
               (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
               g Hg). }
claim Htotf: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Htotg: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HgnR: apply_fun g n :e R.
{ exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
claim HmgnR: minus_SNo (apply_fun g n) :e R.
{ exact (real_minus_SNo (apply_fun g n) HgnR). }
claim HtR: t :e R.
{ exact (real_add_SNo (apply_fun f n) HfnR (minus_SNo (apply_fun g n)) HmgnR). }
claim HabsR: abs_SNo t :e R.
{ apply (xm (0 <= t) (abs_SNo t :e R)).
  - assume H0le: 0 <= t.
    claim Habseq: abs_SNo t = t.
    { exact (nonneg_abs_SNo t H0le). }
    rewrite Habseq.
    exact HtR.
  - assume Hn0le: ~(0 <= t).
    claim HmtR: minus_SNo t :e R.
    { exact (real_minus_SNo t HtR). }
    claim Habseq: abs_SNo t = minus_SNo t.
    { exact (not_nonneg_abs_SNo t Hn0le). }
    rewrite Habseq.
    exact HmtR. }
claim HabsDef: Romega_coord_abs_diff f g n = abs_SNo t.
{ reflexivity. }
claim HabsDiffR: Romega_coord_abs_diff f g n :e R.
{ rewrite HabsDef.
  exact HabsR. }
claim Hdef: Romega_coord_clipped_diff f g n =
  If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
{ reflexivity. }
apply (xm (Rlt (Romega_coord_abs_diff f g n) 1)
          (Romega_coord_clipped_diff f g n :e R)).
- assume Hlt: Rlt (Romega_coord_abs_diff f g n) 1.
  rewrite Hdef.
  rewrite (If_i_1 (Rlt (Romega_coord_abs_diff f g n) 1)
                  (Romega_coord_abs_diff f g n) 1 Hlt).
  exact HabsDiffR.
- assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g n) 1).
  rewrite Hdef.
  rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n) 1)
                  (Romega_coord_abs_diff f g n) 1 Hnlt).
  exact real_1.
Qed.

(** helper: clipped diffs are bounded above in R **)
Theorem Romega_clipped_diffs_bounded : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  exists u:set, u :e R /\ forall a:set, a :e Romega_clipped_diffs f g -> a :e R -> Rle a u.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
witness 1.
apply andI.
- exact real_1.
- let a.
  assume HaA: a :e Romega_clipped_diffs f g.
  assume HaR: a :e R.
  prove Rle a 1.
  apply (RleI a 1 HaR real_1).
  assume Hlt1: Rlt 1 a.
  prove False.
  apply (ReplE_impred omega
                      (fun n:set => Romega_coord_clipped_diff f g n)
                      a
                      HaA
                      False).
  let n.
  assume HnO: n :e omega.
  assume Han: a = Romega_coord_clipped_diff f g n.
  claim Hlt': Rlt 1 (Romega_coord_clipped_diff f g n).
  { rewrite <- Han.
    exact Hlt1. }
  claim Hfpack: total_function_on f omega R /\ functional_graph f.
  { exact (SepE2 (Power (setprod omega R))
                 (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
                 f Hf). }
  claim Hgpack: total_function_on g omega R /\ functional_graph g.
  { exact (SepE2 (Power (setprod omega R))
                 (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
                 g Hg). }
  claim Htotf: total_function_on f omega R.
  { exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
  claim Htotg: total_function_on g omega R.
  { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
  claim HfnR: apply_fun f n :e R.
  { exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
  claim HgnR: apply_fun g n :e R.
  { exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
  set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
  claim HmgnR: minus_SNo (apply_fun g n) :e R.
  { exact (real_minus_SNo (apply_fun g n) HgnR). }
  claim HtR: t :e R.
  { exact (real_add_SNo (apply_fun f n) HfnR (minus_SNo (apply_fun g n)) HmgnR). }
  claim HabsR: abs_SNo t :e R.
  { apply (xm (0 <= t) (abs_SNo t :e R)).
    - assume H0le: 0 <= t.
      claim Habseq: abs_SNo t = t.
      { exact (nonneg_abs_SNo t H0le). }
      rewrite Habseq.
      exact HtR.
    - assume Hn0le: ~(0 <= t).
      claim HmtR: minus_SNo t :e R.
      { exact (real_minus_SNo t HtR). }
      claim Habseq: abs_SNo t = minus_SNo t.
      { exact (not_nonneg_abs_SNo t Hn0le). }
      rewrite Habseq.
      exact HmtR. }
  claim HabsDef: Romega_coord_abs_diff f g n = abs_SNo t.
  { reflexivity. }
  claim HabsDiffR: Romega_coord_abs_diff f g n :e R.
  { rewrite HabsDef.
    exact HabsR. }
  claim Hdef: Romega_coord_clipped_diff f g n =
    If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
  { reflexivity. }
  apply (xm (Rlt (Romega_coord_abs_diff f g n) 1) False).
  - assume Hlt: Rlt (Romega_coord_abs_diff f g n) 1.
    claim Hnlt1abs: ~(Rlt 1 (Romega_coord_abs_diff f g n)).
    { exact (not_Rlt_sym (Romega_coord_abs_diff f g n) 1 Hlt). }
    claim HclEq: Romega_coord_clipped_diff f g n = Romega_coord_abs_diff f g n.
    { rewrite Hdef.
      rewrite (If_i_1 (Rlt (Romega_coord_abs_diff f g n) 1)
                      (Romega_coord_abs_diff f g n) 1 Hlt).
      reflexivity. }
    claim Hlt1abs: Rlt 1 (Romega_coord_abs_diff f g n).
    { rewrite <- HclEq.
      exact Hlt'. }
    exact (Hnlt1abs Hlt1abs).
  - assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g n) 1).
    claim HclEq: Romega_coord_clipped_diff f g n = 1.
    { rewrite Hdef.
      rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n) 1)
                      (Romega_coord_abs_diff f g n) 1 Hnlt).
      reflexivity. }
    claim Hlt11: Rlt 1 1.
    { rewrite <- HclEq at 2.
      exact Hlt'. }
    exact (not_Rlt_refl 1 real_1 Hlt11).
Qed.

(** helper: the chosen uniform metric value is a least upper bound **)
Theorem Romega_uniform_metric_value_is_lub : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  R_lub (Romega_clipped_diffs f g) (Romega_uniform_metric_value f g).
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
set A := Romega_clipped_diffs f g.
set P := (fun r:set => R_lub A r).
claim HAinR: forall a:set, a :e A -> a :e R.
{ exact (Romega_clipped_diffs_in_R f g Hf Hg). }
claim Hub: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
{ exact (Romega_clipped_diffs_bounded f g Hf Hg). }
claim HAnen: exists a0:set, a0 :e A.
{ claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  witness (Romega_coord_clipped_diff f g 0).
  exact (ReplI omega (fun n:set => Romega_coord_clipped_diff f g n) 0 H0omega). }
claim Hex: exists l:set, P l.
{ exact (R_lub_exists A HAnen HAinR Hub). }
exact (Eps_i_ex P Hex).
Qed.

(** helper: each clipped coordinate difference is bounded above by the uniform metric value **)
Theorem Romega_coord_clipped_diff_le_uniform : forall f g i:set,
  f :e real_sequences ->
  g :e real_sequences ->
  i :e omega ->
  Rle (Romega_coord_clipped_diff f g i) (Romega_uniform_metric_value f g).
let f g i.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hi: i :e omega.
set A := Romega_clipped_diffs f g.
set l := Romega_uniform_metric_value f g.
claim Hlub: R_lub A l.
{ exact (Romega_uniform_metric_value_is_lub f g Hf Hg). }
(** extract the upper-bound clause from R_lub **)
set P := l :e R.
set UB := forall a:set, a :e A -> a :e R -> Rle a l.
set MIN := forall u:set, u :e R ->
            (forall a:set, a :e A -> a :e R -> Rle a u) ->
            Rle l u.
claim Hcore: P /\ UB.
{ exact (andEL (P /\ UB) MIN Hlub). }
claim Hub: UB.
{ exact (andER P UB Hcore). }
claim Hai: Romega_coord_clipped_diff f g i :e A.
{ exact (ReplI omega (fun n:set => Romega_coord_clipped_diff f g n) i Hi). }
claim HaiR: Romega_coord_clipped_diff f g i :e R.
{ exact (Romega_clipped_diffs_in_R f g Hf Hg (Romega_coord_clipped_diff f g i) Hai). }
exact (Hub (Romega_coord_clipped_diff f g i) Hai HaiR).
Qed.

(** helper: uniform metric bound implies coordinate clipped bound **)
Theorem Romega_coord_clipped_diff_lt_of_uniform_lt : forall f g i r:set,
  f :e real_sequences ->
  g :e real_sequences ->
  i :e omega ->
  Rlt (Romega_uniform_metric_value f g) r ->
  Rlt (Romega_coord_clipped_diff f g i) r.
let f g i r.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hi: i :e omega.
assume Hlt: Rlt (Romega_uniform_metric_value f g) r.
claim Hle: Rle (Romega_coord_clipped_diff f g i) (Romega_uniform_metric_value f g).
{ exact (Romega_coord_clipped_diff_le_uniform f g i Hf Hg Hi). }
exact (Rle_Rlt_tra_Euclid (Romega_coord_clipped_diff f g i) (Romega_uniform_metric_value f g) r Hle Hlt).
Qed.

(** helper: uniform metric value is symmetric **)
Theorem Romega_uniform_metric_value_sym : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  Romega_uniform_metric_value f g = Romega_uniform_metric_value g f.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
set A := Romega_clipped_diffs f g.
claim HAeq: A = Romega_clipped_diffs g f.
{ exact (Romega_clipped_diffs_sym f g Hf Hg). }
claim Hlub1: R_lub A (Romega_uniform_metric_value f g).
{ exact (Romega_uniform_metric_value_is_lub f g Hf Hg). }
claim Hlub2': R_lub A (Romega_uniform_metric_value g f).
{ rewrite HAeq.
  exact (Romega_uniform_metric_value_is_lub g f Hg Hf). }
exact (R_lub_unique A (Romega_uniform_metric_value f g) (Romega_uniform_metric_value g f) Hlub1 Hlub2').
Qed.

(** helper: uniform metric value is 0 on the diagonal **)
Theorem Romega_uniform_metric_value_self_zero : forall f:set,
  f :e real_sequences ->
  Romega_uniform_metric_value f f = 0.
let f.
assume Hf: f :e real_sequences.
set A := Romega_clipped_diffs f f.
claim HAeq: A = {0}.
{ exact (Romega_clipped_diffs_diag_eq_Sing0 f Hf). }
claim Hlub1: R_lub A (Romega_uniform_metric_value f f).
{ exact (Romega_uniform_metric_value_is_lub f f Hf Hf). }
claim Hlub0: R_lub A 0.
{ rewrite HAeq.
  exact R_lub_Sing0. }
exact (R_lub_unique A (Romega_uniform_metric_value f f) 0 Hlub1 Hlub0).
Qed.

(** helper: uniform metric values are real numbers **)
Theorem Romega_uniform_metric_value_in_R : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  Romega_uniform_metric_value f g :e R.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
exact (R_lub_in_R (Romega_clipped_diffs f g)
                  (Romega_uniform_metric_value f g)
                  (Romega_uniform_metric_value_is_lub f g Hf Hg)).
Qed.

(** helper: uniform metric values are not negative **)
Theorem Romega_uniform_metric_value_nonneg : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  ~(Rlt (Romega_uniform_metric_value f g) 0).
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
set A := Romega_clipped_diffs f g.
set l := Romega_uniform_metric_value f g.
claim HlR: l :e R.
{ exact (Romega_uniform_metric_value_in_R f g Hf Hg). }
claim Hlub: R_lub A l.
{ exact (Romega_uniform_metric_value_is_lub f g Hf Hg). }
claim Hcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
               Hlub). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hcore). }
assume Hl0: Rlt l 0.
prove False.
set a0 := Romega_coord_clipped_diff f g 0.
claim H0O: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim Ha0A: a0 :e A.
{ exact (ReplI omega (fun n:set => Romega_coord_clipped_diff f g n) 0 H0O). }
claim Ha0R: a0 :e R.
{ exact (Romega_clipped_diffs_in_R f g Hf Hg a0 Ha0A). }
claim Ha0S: SNo a0.
{ exact (real_SNo a0 Ha0R). }
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim H0S: SNo 0.
{ exact SNo_0. }
claim H0le0: 0 <= 0.
{ exact (SNoLe_ref 0). }
claim Ha0nonneg: 0 <= a0.
{ set t := add_SNo (apply_fun f 0) (minus_SNo (apply_fun g 0)).
  claim Hfpack: total_function_on f omega R /\ functional_graph f.
  { exact (SepE2 (Power (setprod omega R))
                 (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
                 f Hf). }
  claim Hgpack: total_function_on g omega R /\ functional_graph g.
  { exact (SepE2 (Power (setprod omega R))
                 (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
                 g Hg). }
  claim Htotf: total_function_on f omega R.
  { exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
  claim Htotg: total_function_on g omega R.
  { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
  claim Hf0R: apply_fun f 0 :e R.
  { exact (total_function_on_apply_fun_in_Y f omega R 0 Htotf H0O). }
  claim Hg0R: apply_fun g 0 :e R.
  { exact (total_function_on_apply_fun_in_Y g omega R 0 Htotg H0O). }
  claim HmfR: minus_SNo (apply_fun g 0) :e R.
  { exact (real_minus_SNo (apply_fun g 0) Hg0R). }
  claim HtR: t :e R.
  { exact (real_add_SNo (apply_fun f 0) Hf0R (minus_SNo (apply_fun g 0)) HmfR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HabsNN: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdefAbs: Romega_coord_abs_diff f g 0 = abs_SNo t.
  { reflexivity. }
  claim Hdef: a0 =
    If_i (Rlt (Romega_coord_abs_diff f g 0) 1) (Romega_coord_abs_diff f g 0) 1.
  { reflexivity. }
  rewrite Hdef.
  apply (xm (Rlt (Romega_coord_abs_diff f g 0) 1) (0 <= (If_i (Rlt (Romega_coord_abs_diff f g 0) 1) (Romega_coord_abs_diff f g 0) 1))).
  - assume Hlt: Rlt (Romega_coord_abs_diff f g 0) 1.
    rewrite (If_i_1 (Rlt (Romega_coord_abs_diff f g 0) 1) (Romega_coord_abs_diff f g 0) 1 Hlt).
    rewrite HdefAbs.
    exact HabsNN.
  - assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g 0) 1).
    rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g 0) 1) (Romega_coord_abs_diff f g 0) 1 Hnlt).
    exact (SNoLtLe 0 1 SNoLt_0_1). }
claim Ha0lt0n: ~(a0 < 0).
{ claim Hcase: 0 < a0 \/ 0 = a0.
  { exact (SNoLeE 0 a0 H0S Ha0S Ha0nonneg). }
  assume Ha0lt0: a0 < 0.
  apply (Hcase False).
  - assume H0lta0: 0 < a0.
    claim H00: 0 < 0.
    { exact (SNoLt_tra 0 a0 0 H0S Ha0S H0S H0lta0 Ha0lt0). }
    exact ((SNoLt_irref 0) H00).
  - assume H0eq: 0 = a0.
    claim H00: 0 < 0.
    { rewrite H0eq at 1.
      exact Ha0lt0. }
    exact ((SNoLt_irref 0) H00). }
claim Hl0lt: l < 0.
{ exact (RltE_lt l 0 Hl0). }
claim Hlta0: l < a0.
{ apply (SNoLt_trichotomy_or_impred a0 0 Ha0S H0S (l < a0)).
  - assume Ha0lt0: a0 < 0.
    exact (FalseE (Ha0lt0n Ha0lt0) (l < a0)).
  - assume Ha0eq0: a0 = 0.
    rewrite Ha0eq0.
    exact Hl0lt.
  - assume H0lta0: 0 < a0.
    exact (SNoLt_tra l 0 a0 HlS H0S Ha0S Hl0lt H0lta0). }
claim Hltla0: Rlt l a0.
{ exact (RltI l a0 HlR Ha0R Hlta0). }
claim HRle: Rle a0 l.
{ exact (Hub a0 Ha0A Ha0R). }
exact ((RleE_nlt a0 l HRle) Hltla0).
Qed.

(** helper: clipped coordinate difference is nonnegative **)
Theorem Romega_coord_clipped_diff_nonneg : forall f g n:set,
  f :e real_sequences ->
  g :e real_sequences ->
  n :e omega ->
  0 <= Romega_coord_clipped_diff f g n.
let f g n.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume HnO: n :e omega.
set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R))
               (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
               g Hg). }
claim Htotf: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Htotg: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HgnR: apply_fun g n :e R.
{ exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
claim HmgnR: minus_SNo (apply_fun g n) :e R.
{ exact (real_minus_SNo (apply_fun g n) HgnR). }
claim HtR: t :e R.
{ exact (real_add_SNo (apply_fun f n) HfnR (minus_SNo (apply_fun g n)) HmgnR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HabsNN: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdefAbs: Romega_coord_abs_diff f g n = abs_SNo t.
{ reflexivity. }
claim Hdef: Romega_coord_clipped_diff f g n =
  If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
{ reflexivity. }
rewrite Hdef.
apply (xm (Rlt (Romega_coord_abs_diff f g n) 1)
          (0 <= If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1)).
- assume Hlt: Rlt (Romega_coord_abs_diff f g n) 1.
  rewrite (If_i_1 (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 Hlt).
  rewrite HdefAbs.
  exact HabsNN.
- assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g n) 1).
  rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 Hnlt).
  exact (SNoLtLe 0 1 SNoLt_0_1).
Qed.

(** helper: uniform metric value 0 implies pointwise equality **)
Theorem Romega_uniform_metric_value_eq0_coord_eq : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  Romega_uniform_metric_value f g = 0 ->
  forall n:set, n :e omega -> apply_fun f n = apply_fun g n.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hfg0: Romega_uniform_metric_value f g = 0.
let n.
assume HnO: n :e omega.
set A := Romega_clipped_diffs f g.
set l := Romega_uniform_metric_value f g.
claim HlR: l :e R.
{ exact (Romega_uniform_metric_value_in_R f g Hf Hg). }
claim Hlub: R_lub A l.
{ exact (Romega_uniform_metric_value_is_lub f g Hf Hg). }
claim Hcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
               Hlub). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hcore). }
claim Hub0: forall a:set, a :e A -> a :e R -> Rle a 0.
{ let a0.
  assume Ha0A: a0 :e A.
  assume Ha0R: a0 :e R.
  rewrite <- Hfg0.
  exact (Hub a0 Ha0A Ha0R). }
set a := Romega_coord_clipped_diff f g n.
claim HaA: a :e A.
{ exact (ReplI omega (fun m:set => Romega_coord_clipped_diff f g m) n HnO). }
claim HaR: a :e R.
{ exact (Romega_clipped_diffs_in_R f g Hf Hg a HaA). }
claim HRle: Rle a 0.
{ exact (Hub0 a HaA HaR). }
claim HnRlt0a: ~(Rlt 0 a).
{ exact (RleE_nlt a 0 HRle). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HaNN: 0 <= a.
{ exact (Romega_coord_clipped_diff_nonneg f g n Hf Hg HnO). }
claim Ha0: a = 0.
{ apply (SNoLeE 0 a SNo_0 HaS HaNN (a = 0)).
  - assume H0lta: 0 < a.
    claim HRlt0a: Rlt 0 a.
    { exact (RltI 0 a real_0 HaR H0lta). }
    exact (FalseE (HnRlt0a HRlt0a) (a = 0)).
  - assume H0eq: 0 = a.
    rewrite <- H0eq.
    reflexivity. }
claim HfnR: apply_fun f n :e R.
{ claim Hfpack: total_function_on f omega R /\ functional_graph f.
  { exact (SepE2 (Power (setprod omega R))
                 (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
                 f Hf). }
  claim Htotf: total_function_on f omega R.
  { exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
  exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HgnR: apply_fun g n :e R.
{ claim Hgpack: total_function_on g omega R /\ functional_graph g.
  { exact (SepE2 (Power (setprod omega R))
                 (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
                 g Hg). }
  claim Htotg: total_function_on g omega R.
  { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
  exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
claim HmgnR: minus_SNo (apply_fun g n) :e R.
{ exact (real_minus_SNo (apply_fun g n) HgnR). }
claim HtR: t :e R.
{ exact (real_add_SNo (apply_fun f n) HfnR (minus_SNo (apply_fun g n)) HmgnR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim Habs0: abs_SNo t = 0.
{ claim HdefAbs: Romega_coord_abs_diff f g n = abs_SNo t.
  { reflexivity. }
  claim HdefClip: a = If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
  { reflexivity. }
  claim Ha0if: If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 = 0.
  { rewrite <- HdefClip.
    exact Ha0. }
  apply (xm (Rlt (Romega_coord_abs_diff f g n) 1) (abs_SNo t = 0)).
  - assume Hlt: Rlt (Romega_coord_abs_diff f g n) 1.
    claim Hif: If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 =
               (Romega_coord_abs_diff f g n).
    { exact (If_i_1 (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 Hlt). }
    claim HabsR0: Romega_coord_abs_diff f g n = 0.
    { rewrite <- Hif.
      exact Ha0if. }
    rewrite <- HdefAbs.
    exact HabsR0.
  - assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g n) 1).
    claim Hif: If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 = 1.
    { exact (If_i_0 (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1 Hnlt). }
    claim H10eq: 1 = 0.
    { rewrite <- Hif.
      exact Ha0if. }
    exact (FalseE ((neq_1_0) H10eq) (abs_SNo t = 0)). }
claim Ht0: t = 0.
{ apply (xm (0 <= t) (t = 0)).
  - assume H0le: 0 <= t.
    rewrite <- (nonneg_abs_SNo t H0le).
    exact Habs0.
  - assume Hn0le: ~(0 <= t).
    claim Hm0: minus_SNo t = 0.
    { rewrite <- (not_nonneg_abs_SNo t Hn0le).
      exact Habs0. }
    claim Hsum: add_SNo (minus_SNo t) t = 0.
    { exact (add_SNo_minus_SNo_linv t HtS). }
    claim H0t0: add_SNo 0 t = 0.
    { rewrite <- Hm0 at 1.
      exact Hsum. }
    rewrite <- (add_SNo_0L t HtS).
    exact H0t0. }
claim Htdef: t = add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
{ reflexivity. }
claim Ht0': add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)) = 0.
{ rewrite <- Htdef.
  exact Ht0. }
claim Hrhs0: add_SNo (apply_fun g n) (minus_SNo (apply_fun g n)) = 0.
{ exact (add_SNo_minus_SNo_rinv (apply_fun g n) (real_SNo (apply_fun g n) HgnR)). }
claim Heq: add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)) =
           add_SNo (apply_fun g n) (minus_SNo (apply_fun g n)).
{ rewrite Ht0' at 1.
  rewrite Hrhs0 at 1.
  reflexivity. }
exact (add_SNo_cancel_R (apply_fun f n) (minus_SNo (apply_fun g n)) (apply_fun g n)
                        (real_SNo (apply_fun f n) HfnR)
                        (SNo_minus_SNo (apply_fun g n) (real_SNo (apply_fun g n) HgnR))
                        (real_SNo (apply_fun g n) HgnR)
                        Heq).
Qed.

(** from §20 Definition: uniform metric on R to the omega **)
(** LATEX VERSION: The uniform metric on R^ω is defined by taking the supremum of the clipped coordinate differences. **)
Definition uniform_metric_Romega : set :=
  graph (setprod real_sequences real_sequences)
        (fun p:set => Romega_uniform_metric_value (p 0) (p 1)).

(** helper: uniform_metric_Romega is function_on into R **)
Theorem uniform_metric_Romega_function_on : function_on uniform_metric_Romega (setprod real_sequences real_sequences) R.
let p.
assume Hp: p :e setprod real_sequences real_sequences.
prove apply_fun uniform_metric_Romega p :e R.
claim Happ: apply_fun uniform_metric_Romega p =
  Romega_uniform_metric_value (p 0) (p 1).
{ exact (apply_fun_graph (setprod real_sequences real_sequences)
                         (fun q:set => Romega_uniform_metric_value (q 0) (q 1))
                         p Hp). }
rewrite Happ.
claim Hp0: p 0 :e real_sequences.
{ exact (ap0_Sigma real_sequences (fun _ : set => real_sequences) p Hp). }
claim Hp1: p 1 :e real_sequences.
{ exact (ap1_Sigma real_sequences (fun _ : set => real_sequences) p Hp). }
exact (Romega_uniform_metric_value_in_R (p 0) (p 1) Hp0 Hp1).
Qed.

(** from §20 Definition: uniform topology induced by the uniform metric **)
(** LATEX VERSION: The topology it induces is called the uniform topology. **)
Definition uniform_topology : set := metric_topology real_sequences uniform_metric_Romega.

(** helper: convert SNoLe to Rle on reals **)
Theorem Rle_of_SNoLe : forall a b:set,
  a :e R -> b :e R -> a <= b -> Rle a b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Hab: a <= b.
apply (RleI a b HaR HbR).
assume Hlt: Rlt b a.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Hblta: b < a.
{ exact (RltE_lt b a Hlt). }
claim Haalt: a < a.
{ exact (SNoLeLt_tra a b a HaS HbS HaS Hab Hblta). }
exact ((SNoLt_irref a) Haalt).
Qed.

(** helper: abs upper bound **)
Theorem abs_SNo_upper_bound : forall x:set,
  SNo x -> x <= abs_SNo x.
let x.
assume HxS: SNo x.
apply (xm (0 <= x)).
- assume H0le: 0 <= x.
  rewrite (nonneg_abs_SNo x H0le).
  exact (SNoLe_ref x).
- assume Hn0le: ~(0 <= x).
  rewrite (not_nonneg_abs_SNo x Hn0le).
  claim Hxlt0: x < 0.
  { apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (x < 0)).
    - assume H: x < 0.
      exact H.
    - assume Hx0: x = 0.
      claim H0le0: 0 <= x.
      { rewrite Hx0.
        exact (SNoLe_ref 0). }
      exact (FalseE (Hn0le H0le0) (x < 0)).
    - assume H0ltx: 0 < x.
      claim H0lex: 0 <= x.
      { exact (SNoLtLe 0 x H0ltx). }
      exact (FalseE (Hn0le H0lex) (x < 0)). }
	  claim Hxle0: x <= 0.
	  { exact (SNoLtLe x 0 Hxlt0). }
	  claim H0lemx: 0 <= minus_SNo x.
	  { rewrite <- minus_SNo_0 at 1.
	    exact (minus_SNo_Le_contra x 0 HxS SNo_0 Hxle0). }
	  exact (SNoLe_tra x 0 (minus_SNo x) HxS SNo_0 (SNo_minus_SNo x HxS) Hxle0 H0lemx).
Qed.

(** helper: abs lower bound **)
Theorem abs_SNo_lower_bound : forall x:set,
  SNo x -> minus_SNo (abs_SNo x) <= x.
let x.
assume HxS: SNo x.
apply (xm (0 <= x)).
- assume H0le: 0 <= x.
	  rewrite (nonneg_abs_SNo x H0le).
	  claim Hmxle0: minus_SNo x <= 0.
	  { rewrite <- minus_SNo_0 at 1.
	    exact (minus_SNo_Le_contra 0 x SNo_0 HxS H0le). }
	  exact (SNoLe_tra (minus_SNo x) 0 x (SNo_minus_SNo x HxS) SNo_0 HxS Hmxle0 H0le).
- assume Hn0le: ~(0 <= x).
  rewrite (not_nonneg_abs_SNo x Hn0le).
  rewrite (minus_SNo_invol x HxS).
  exact (SNoLe_ref x).
Qed.

(** helper: abs bound from two-sided bounds **)
Theorem abs_SNo_Le_of_bounds : forall t u:set,
  SNo t -> SNo u -> minus_SNo u <= t -> t <= u -> abs_SNo t <= u.
let t u.
assume HtS: SNo t.
assume HuS: SNo u.
assume Hlo: minus_SNo u <= t.
assume Hhi: t <= u.
apply (xm (0 <= t)).
- assume H0le: 0 <= t.
  rewrite (nonneg_abs_SNo t H0le).
  exact Hhi.
- assume Hn0le: ~(0 <= t).
  rewrite (not_nonneg_abs_SNo t Hn0le).
	  claim Hmtleu: minus_SNo t <= u.
	  { claim HmHlo: minus_SNo t <= minus_SNo (minus_SNo u).
	    { exact (minus_SNo_Le_contra (minus_SNo u) t (SNo_minus_SNo u HuS) HtS Hlo). }
	    rewrite <- (minus_SNo_invol u HuS) at 1.
	    exact HmHlo. }
	  exact Hmtleu.
Qed.

(** helper: abs subadditivity **)
Theorem abs_SNo_subadd : forall x y:set,
  SNo x -> SNo y ->
  abs_SNo (add_SNo x y) <= add_SNo (abs_SNo x) (abs_SNo y).
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
set u := add_SNo (abs_SNo x) (abs_SNo y).
claim HabsxS: SNo (abs_SNo x).
{ exact (SNo_abs_SNo x HxS). }
claim HabsyS: SNo (abs_SNo y).
{ exact (SNo_abs_SNo y HyS). }
claim HuS: SNo u.
{ exact (SNo_add_SNo (abs_SNo x) (abs_SNo y) HabsxS HabsyS). }
claim Hxub: x <= abs_SNo x.
{ exact (abs_SNo_upper_bound x HxS). }
claim Hyub: y <= abs_SNo y.
{ exact (abs_SNo_upper_bound y HyS). }
claim Hhi: add_SNo x y <= u.
{ exact (add_SNo_Le3 x y (abs_SNo x) (abs_SNo y) HxS HyS HabsxS HabsyS Hxub Hyub). }
claim Hxlo: minus_SNo (abs_SNo x) <= x.
{ exact (abs_SNo_lower_bound x HxS). }
claim Hylo: minus_SNo (abs_SNo y) <= y.
{ exact (abs_SNo_lower_bound y HyS). }
claim Hlo': add_SNo (minus_SNo (abs_SNo x)) (minus_SNo (abs_SNo y)) <= add_SNo x y.
{ exact (add_SNo_Le3 (minus_SNo (abs_SNo x)) (minus_SNo (abs_SNo y)) x y
                    (SNo_minus_SNo (abs_SNo x) HabsxS)
                    (SNo_minus_SNo (abs_SNo y) HabsyS)
                    HxS HyS Hxlo Hylo). }
claim Hlo: minus_SNo u <= add_SNo x y.
{ rewrite (minus_add_SNo_distr (abs_SNo x) (abs_SNo y) HabsxS HabsyS).
  exact Hlo'. }
exact (abs_SNo_Le_of_bounds (add_SNo x y) u
                            (SNo_add_SNo x y HxS HyS)
                            HuS
                            Hlo
                            Hhi).
Qed.

(** helper: abs triangle inequality **)
Theorem abs_SNo_triangle : forall a b c:set,
  SNo a -> SNo b -> SNo c ->
  abs_SNo (add_SNo a (minus_SNo c))
  <= add_SNo (abs_SNo (add_SNo a (minus_SNo b))) (abs_SNo (add_SNo b (minus_SNo c))).
let a b c.
assume HaS: SNo a.
assume HbS: SNo b.
assume HcS: SNo c.
set x := add_SNo a (minus_SNo b).
set y := add_SNo b (minus_SNo c).
claim HmaS: SNo (minus_SNo a).
{ exact (SNo_minus_SNo a HaS). }
claim HmbS: SNo (minus_SNo b).
{ exact (SNo_minus_SNo b HbS). }
claim HmcS: SNo (minus_SNo c).
{ exact (SNo_minus_SNo c HcS). }
claim HxS: SNo x.
{ exact (SNo_add_SNo a (minus_SNo b) HaS HmbS). }
claim HyS: SNo y.
{ exact (SNo_add_SNo b (minus_SNo c) HbS HmcS). }
claim HxyS: SNo (add_SNo x y).
{ exact (SNo_add_SNo x y HxS HyS). }
claim HrhsS: SNo (add_SNo (abs_SNo x) (abs_SNo y)).
{ exact (SNo_add_SNo (abs_SNo x) (abs_SNo y) (SNo_abs_SNo x HxS) (SNo_abs_SNo y HyS)). }
claim Hsum: add_SNo x y = add_SNo a (minus_SNo c).
{ claim Hassoc1: add_SNo x y = add_SNo (add_SNo a (minus_SNo b)) (add_SNo b (minus_SNo c)).
  { reflexivity. }
  rewrite Hassoc1.
  rewrite <- (add_SNo_assoc a (minus_SNo b) (add_SNo b (minus_SNo c)) HaS HmbS (SNo_add_SNo b (minus_SNo c) HbS HmcS)).
  rewrite (add_SNo_assoc (minus_SNo b) b (minus_SNo c) HmbS HbS HmcS).
  rewrite (add_SNo_minus_SNo_linv b HbS).
  rewrite (add_SNo_0L (minus_SNo c) HmcS).
  reflexivity. }
rewrite <- Hsum at 1.
exact (abs_SNo_subadd x y HxS HyS).
Qed.

(** helper: SNo is stable under If_i **)
Theorem SNo_If_i : forall P:prop, forall x y:set,
  SNo x -> SNo y -> SNo (If_i P x y).
let P x y.
assume HxS: SNo x.
assume HyS: SNo y.
apply (xm P).
- assume HP.
  rewrite (If_i_1 P x y HP).
  exact HxS.
- assume HnP.
  rewrite (If_i_0 P x y HnP).
  exact HyS.
Qed.

(** helper: coordinate abs differences are reals **)
Theorem Romega_coord_abs_diff_in_R : forall f g n:set,
  f :e real_sequences -> g :e real_sequences -> n :e omega ->
  Romega_coord_abs_diff f g n :e R.
let f g n.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume HnO: n :e omega.
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R))
               (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
               g Hg). }
claim Htotf: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Htotg: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
claim HgnR: apply_fun g n :e R.
{ exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
claim HmgnR: minus_SNo (apply_fun g n) :e R.
{ exact (real_minus_SNo (apply_fun g n) HgnR). }
claim HtR: t :e R.
{ exact (real_add_SNo (apply_fun f n) HfnR (minus_SNo (apply_fun g n)) HmgnR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HabsR: abs_SNo t :e R.
{ apply (xm (0 <= t) (abs_SNo t :e R)).
  - assume H0le: 0 <= t.
    rewrite (nonneg_abs_SNo t H0le).
    exact HtR.
	  - assume Hn0le: ~(0 <= t).
	    rewrite (not_nonneg_abs_SNo t Hn0le).
	    exact (real_minus_SNo t HtR). }
	claim Hdef: Romega_coord_abs_diff f g n = abs_SNo t.
	{ reflexivity. }
	rewrite Hdef.
	exact HabsR.
Qed.

(** helper: clipped function on reals (min with 1) is monotone **)
Theorem Rclip_mono : forall t s:set,
  t :e R -> s :e R -> t <= s ->
  If_i (Rlt t 1) t 1 <= If_i (Rlt s 1) s 1.
let t s.
assume HtR: t :e R.
assume HsR: s :e R.
assume Hts: t <= s.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HsS: SNo s.
{ exact (real_SNo s HsR). }
apply (xm (Rlt t 1)).
- assume Htlt: Rlt t 1.
  claim HtltS: t < 1.
  { exact (RltE_lt t 1 Htlt). }
  rewrite (If_i_1 (Rlt t 1) t 1 Htlt).
  apply (xm (Rlt s 1)).
  + assume Hslt: Rlt s 1.
    rewrite (If_i_1 (Rlt s 1) s 1 Hslt).
    exact Hts.
  + assume Hnsl: ~(Rlt s 1).
    rewrite (If_i_0 (Rlt s 1) s 1 Hnsl).
    exact (SNoLtLe t 1 HtltS).
	- assume Hntl: ~(Rlt t 1).
	  rewrite (If_i_0 (Rlt t 1) t 1 Hntl).
	  apply (xm (Rlt s 1)).
	  + assume Hslt: Rlt s 1.
	    rewrite (If_i_1 (Rlt s 1) s 1 Hslt).
	    claim HsltS: s < 1.
	    { exact (RltE_lt s 1 Hslt). }
	    claim Ht1: t < 1.
	    { exact (SNoLeLt_tra t s 1 HtS HsS SNo_1 Hts HsltS). }
	    claim Htlt: Rlt t 1.
	    { exact (RltI t 1 HtR real_1 Ht1). }
	    exact (FalseE (Hntl Htlt) (1 <= s)).
	  + assume Hnsl: ~(Rlt s 1).
	    rewrite (If_i_0 (Rlt s 1) s 1 Hnsl).
	    exact (SNoLe_ref 1).
Qed.

(** helper: clipped subadditivity for nonnegative reals **)
Theorem Rclip_subadd_nonneg : forall p q:set,
  p :e R -> q :e R ->
  0 <= p -> 0 <= q ->
  If_i (Rlt (add_SNo p q) 1) (add_SNo p q) 1
  <= add_SNo (If_i (Rlt p 1) p 1) (If_i (Rlt q 1) q 1).
let p q.
assume HpR: p :e R.
assume HqR: q :e R.
assume HpNN: 0 <= p.
assume HqNN: 0 <= q.
claim HpS: SNo p.
{ exact (real_SNo p HpR). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim HpplusqS: SNo (add_SNo p q).
{ exact (SNo_add_SNo p q HpS HqS). }
apply (xm (Rlt (add_SNo p q) 1)).
- assume Hlt: Rlt (add_SNo p q) 1.
  rewrite (If_i_1 (Rlt (add_SNo p q) 1) (add_SNo p q) 1 Hlt).
  (** under p+q<1, both p<1 and q<1 **)
  claim Hp1: Rlt p 1.
  { apply (SNoLt_trichotomy_or_impred p 1 HpS SNo_1 (Rlt p 1)).
    - assume Hpl: p < 1.
      exact (RltI p 1 HpR real_1 Hpl).
	    - assume Hpeq: p = 1.
	      claim HsumS: SNo (add_SNo p q).
	      { exact (real_SNo (add_SNo p q) (real_add_SNo p HpR q HqR)). }
	      claim Hsumlt: add_SNo p q < 1.
	      { exact (RltE_lt (add_SNo p q) 1 Hlt). }
	      claim H1lesum: 1 <= add_SNo p q.
	      { rewrite Hpeq.
	        rewrite <- (add_SNo_0R 1 SNo_1) at 1.
	        exact (add_SNo_Le2 1 0 q SNo_1 SNo_0 HqS HqNN). }
	      claim H11: 1 < 1.
	      { exact (SNoLeLt_tra 1 (add_SNo p q) 1 SNo_1 HsumS SNo_1 H1lesum Hsumlt). }
	      exact (FalseE ((SNoLt_irref 1) H11) (Rlt p 1)).
	    - assume H1lp: 1 < p.
	      claim H1lep: 1 <= p.
	      { exact (SNoLtLe 1 p H1lp). }
      claim H1lesum: 1 <= add_SNo p q.
      { claim Hplepq: p <= add_SNo p q.
        { rewrite <- (add_SNo_0R p HpS) at 1.
          exact (add_SNo_Le2 p 0 q HpS SNo_0 HqS HqNN). }
        exact (SNoLe_tra 1 p (add_SNo p q) SNo_1 HpS (SNo_add_SNo p q HpS HqS) H1lep Hplepq). }
      claim Hsumlt: add_SNo p q < 1.
      { exact (RltE_lt (add_SNo p q) 1 Hlt). }
      claim H11: 1 < 1.
      { exact (SNoLeLt_tra 1 (add_SNo p q) 1 SNo_1 (SNo_add_SNo p q HpS HqS) SNo_1 H1lesum Hsumlt). }
      exact (FalseE ((SNoLt_irref 1) H11) (Rlt p 1)). }
  claim Hq1: Rlt q 1.
  { apply (SNoLt_trichotomy_or_impred q 1 HqS SNo_1 (Rlt q 1)).
    - assume Hql: q < 1.
      exact (RltI q 1 HqR real_1 Hql).
	    - assume Hqeq: q = 1.
	      claim HsumS: SNo (add_SNo p q).
	      { exact (real_SNo (add_SNo p q) (real_add_SNo p HpR q HqR)). }
	      claim Hsumlt: add_SNo p q < 1.
	      { exact (RltE_lt (add_SNo p q) 1 Hlt). }
	      claim H1lesum: 1 <= add_SNo p q.
	      { rewrite Hqeq.
	        rewrite (add_SNo_com p 1 HpS SNo_1).
	        rewrite <- (add_SNo_0R 1 SNo_1) at 1.
	        exact (add_SNo_Le2 1 0 p SNo_1 SNo_0 HpS HpNN). }
	      claim H11: 1 < 1.
	      { exact (SNoLeLt_tra 1 (add_SNo p q) 1 SNo_1 HsumS SNo_1 H1lesum Hsumlt). }
	      exact (FalseE ((SNoLt_irref 1) H11) (Rlt q 1)).
	    - assume H1lq: 1 < q.
	      claim H1leq: 1 <= q.
	      { exact (SNoLtLe 1 q H1lq). }
	      claim H1lesum: 1 <= add_SNo p q.
	      { claim Hqlesum: q <= add_SNo p q.
	        { rewrite (add_SNo_com p q HpS HqS).
	          rewrite <- (add_SNo_0R q HqS) at 1.
	          exact (add_SNo_Le2 q 0 p HqS SNo_0 HpS HpNN). }
	        exact (SNoLe_tra 1 q (add_SNo p q) SNo_1 HqS (SNo_add_SNo p q HpS HqS) H1leq Hqlesum). }
	      claim HsumS: SNo (add_SNo p q).
	      { exact (SNo_add_SNo p q HpS HqS). }
	      claim Hsumlt: add_SNo p q < 1.
	      { exact (RltE_lt (add_SNo p q) 1 Hlt). }
	      claim H11: 1 < 1.
	      { exact (SNoLeLt_tra 1 (add_SNo p q) 1 SNo_1 HsumS SNo_1 H1lesum Hsumlt). }
	      exact (FalseE ((SNoLt_irref 1) H11) (Rlt q 1)). }
  rewrite (If_i_1 (Rlt p 1) p 1 Hp1).
  rewrite (If_i_1 (Rlt q 1) q 1 Hq1).
  exact (SNoLe_ref (add_SNo p q)).
- assume Hnlt: ~(Rlt (add_SNo p q) 1).
  rewrite (If_i_0 (Rlt (add_SNo p q) 1) (add_SNo p q) 1 Hnlt).
  (** show 1 <= clip(p)+clip(q) **)
  apply (xm (Rlt p 1)).
  + assume Hp1: Rlt p 1.
    rewrite (If_i_1 (Rlt p 1) p 1 Hp1).
    apply (xm (Rlt q 1)).
    - assume Hq1: Rlt q 1.
      rewrite (If_i_1 (Rlt q 1) q 1 Hq1).
      claim H1le: 1 <= add_SNo p q.
      { apply (SNoLt_trichotomy_or_impred (add_SNo p q) 1 HpplusqS SNo_1 (1 <= add_SNo p q)).
        - assume Hslt: add_SNo p q < 1.
          claim Hr: Rlt (add_SNo p q) 1.
          { exact (RltI (add_SNo p q) 1 (real_add_SNo p HpR q HqR) real_1 Hslt). }
          exact (FalseE (Hnlt Hr) (1 <= add_SNo p q)).
        - assume Heq: add_SNo p q = 1.
          rewrite Heq.
          exact (SNoLe_ref 1).
        - assume H1lt: 1 < add_SNo p q.
          exact (SNoLtLe 1 (add_SNo p q) H1lt). }
      exact H1le.
	    - assume Hnq1: ~(Rlt q 1).
	      rewrite (If_i_0 (Rlt q 1) q 1 Hnq1).
	      (** 1 <= p+1 since p is nonnegative **)
	      rewrite (add_SNo_com p 1 HpS SNo_1).
	      rewrite <- (add_SNo_0R 1 SNo_1) at 1.
	      exact (add_SNo_Le2 1 0 p SNo_1 SNo_0 HpS HpNN).
	  + assume Hnp1: ~(Rlt p 1).
	    rewrite (If_i_0 (Rlt p 1) p 1 Hnp1).
	    claim HclipS: SNo (If_i (Rlt q 1) q 1).
	    { apply (xm (Rlt q 1)).
	      - assume Hq1.
	        rewrite (If_i_1 (Rlt q 1) q 1 Hq1).
	        exact HqS.
	      - assume Hnq1.
	        rewrite (If_i_0 (Rlt q 1) q 1 Hnq1).
	        exact SNo_1. }
	    claim HclipNN: 0 <= If_i (Rlt q 1) q 1.
	    { apply (xm (Rlt q 1)).
	      - assume Hq1.
	        rewrite (If_i_1 (Rlt q 1) q 1 Hq1).
	        exact HqNN.
	      - assume Hnq1.
	        rewrite (If_i_0 (Rlt q 1) q 1 Hnq1).
	        exact (SNoLtLe 0 1 SNoLt_0_1). }
	    rewrite <- (add_SNo_0R 1 SNo_1) at 1.
	    exact (add_SNo_Le2 1 0 (If_i (Rlt q 1) q 1) SNo_1 SNo_0 HclipS HclipNN).
Qed.

(** helper: coordinate abs triangle for real sequences **)
Theorem Romega_coord_abs_diff_triangle : forall f g h n:set,
  f :e real_sequences -> g :e real_sequences -> h :e real_sequences ->
  n :e omega ->
  Romega_coord_abs_diff f h n <= add_SNo (Romega_coord_abs_diff f g n) (Romega_coord_abs_diff g h n).
let f g h n.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hh: h :e real_sequences.
assume HnO: n :e omega.
claim Hfpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R)) (fun f0:set => total_function_on f0 omega R /\ functional_graph f0) f Hf). }
claim Hgpack: total_function_on g omega R /\ functional_graph g.
{ exact (SepE2 (Power (setprod omega R)) (fun g0:set => total_function_on g0 omega R /\ functional_graph g0) g Hg). }
claim Hhpack: total_function_on h omega R /\ functional_graph h.
{ exact (SepE2 (Power (setprod omega R)) (fun h0:set => total_function_on h0 omega R /\ functional_graph h0) h Hh). }
claim Hftot: total_function_on f omega R.
{ exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
claim Hgtot: total_function_on g omega R.
{ exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
claim Hhtot: total_function_on h omega R.
{ exact (andEL (total_function_on h omega R) (functional_graph h) Hhpack). }
claim HfnR: apply_fun f n :e R.
{ exact (total_function_on_apply_fun_in_Y f omega R n Hftot HnO). }
claim HgnR: apply_fun g n :e R.
{ exact (total_function_on_apply_fun_in_Y g omega R n Hgtot HnO). }
claim HhnR: apply_fun h n :e R.
{ exact (total_function_on_apply_fun_in_Y h omega R n Hhtot HnO). }
claim HfnS: SNo (apply_fun f n).
{ exact (real_SNo (apply_fun f n) HfnR). }
claim HgnS: SNo (apply_fun g n).
{ exact (real_SNo (apply_fun g n) HgnR). }
claim HhnS: SNo (apply_fun h n).
{ exact (real_SNo (apply_fun h n) HhnR). }
set a := apply_fun f n.
set b := apply_fun g n.
set c := apply_fun h n.
claim HdefL: Romega_coord_abs_diff f h n = abs_SNo (add_SNo a (minus_SNo c)).
{ reflexivity. }
claim HdefR1: Romega_coord_abs_diff f g n = abs_SNo (add_SNo a (minus_SNo b)).
{ reflexivity. }
claim HdefR2: Romega_coord_abs_diff g h n = abs_SNo (add_SNo b (minus_SNo c)).
{ reflexivity. }
rewrite HdefL.
rewrite HdefR1.
rewrite HdefR2.
exact (abs_SNo_triangle a b c HfnS HgnS HhnS).
Qed.

(** helper: coordinate clipped triangle for real sequences **)
Theorem Romega_coord_clipped_diff_triangle : forall f g h n:set,
  f :e real_sequences -> g :e real_sequences -> h :e real_sequences ->
  n :e omega ->
  Romega_coord_clipped_diff f h n <= add_SNo (Romega_coord_clipped_diff f g n) (Romega_coord_clipped_diff g h n).
let f g h n.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hh: h :e real_sequences.
assume HnO: n :e omega.
set r := Romega_coord_abs_diff f h n.
set p := Romega_coord_abs_diff f g n.
set q := Romega_coord_abs_diff g h n.
claim HrR: r :e R.
{ exact (Romega_coord_abs_diff_in_R f h n Hf Hh HnO). }
claim HpR: p :e R.
{ exact (Romega_coord_abs_diff_in_R f g n Hf Hg HnO). }
claim HqR: q :e R.
{ exact (Romega_coord_abs_diff_in_R g h n Hg Hh HnO). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HpS: SNo p.
{ exact (real_SNo p HpR). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim HabsTri: r <= add_SNo p q.
{ exact (Romega_coord_abs_diff_triangle f g h n Hf Hg Hh HnO). }
claim HppNN: 0 <= p.
{ set t := add_SNo (apply_fun f n) (minus_SNo (apply_fun g n)).
  claim HtS: SNo t.
  { claim HtR: t :e R.
    { claim Ht1R: apply_fun f n :e R.
      { claim Hfpack: total_function_on f omega R /\ functional_graph f.
        { exact (SepE2 (Power (setprod omega R)) (fun f0:set => total_function_on f0 omega R /\ functional_graph f0) f Hf). }
        claim Htotf: total_function_on f omega R.
        { exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
        exact (total_function_on_apply_fun_in_Y f omega R n Htotf HnO). }
      claim Ht2R: minus_SNo (apply_fun g n) :e R.
      { claim Hgpack: total_function_on g omega R /\ functional_graph g.
        { exact (SepE2 (Power (setprod omega R)) (fun g0:set => total_function_on g0 omega R /\ functional_graph g0) g Hg). }
        claim Htotg: total_function_on g omega R.
        { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
        claim HgnR: apply_fun g n :e R.
        { exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
        exact (real_minus_SNo (apply_fun g n) HgnR). }
      exact (real_add_SNo (apply_fun f n) Ht1R (minus_SNo (apply_fun g n)) Ht2R). }
    exact (real_SNo t HtR). }
  claim Hdef: p = abs_SNo t.
  { reflexivity. }
  rewrite Hdef.
  exact (abs_SNo_nonneg t HtS). }
claim HqqNN: 0 <= q.
{ set t := add_SNo (apply_fun g n) (minus_SNo (apply_fun h n)).
  claim HtS: SNo t.
  { claim HtR: t :e R.
    { claim Ht1R: apply_fun g n :e R.
      { claim Hgpack: total_function_on g omega R /\ functional_graph g.
        { exact (SepE2 (Power (setprod omega R)) (fun g0:set => total_function_on g0 omega R /\ functional_graph g0) g Hg). }
        claim Htotg: total_function_on g omega R.
        { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
        exact (total_function_on_apply_fun_in_Y g omega R n Htotg HnO). }
      claim Ht2R: minus_SNo (apply_fun h n) :e R.
      { claim Hhpack: total_function_on h omega R /\ functional_graph h.
        { exact (SepE2 (Power (setprod omega R)) (fun h0:set => total_function_on h0 omega R /\ functional_graph h0) h Hh). }
        claim Htoth: total_function_on h omega R.
        { exact (andEL (total_function_on h omega R) (functional_graph h) Hhpack). }
        claim HhnR: apply_fun h n :e R.
        { exact (total_function_on_apply_fun_in_Y h omega R n Htoth HnO). }
        exact (real_minus_SNo (apply_fun h n) HhnR). }
      exact (real_add_SNo (apply_fun g n) Ht1R (minus_SNo (apply_fun h n)) Ht2R). }
    exact (real_SNo t HtR). }
  claim Hdef: q = abs_SNo t.
  { reflexivity. }
  rewrite Hdef.
  exact (abs_SNo_nonneg t HtS). }
claim HdefL: Romega_coord_clipped_diff f h n = If_i (Rlt r 1) r 1.
{ reflexivity. }
claim HdefR1: Romega_coord_clipped_diff f g n = If_i (Rlt p 1) p 1.
{ reflexivity. }
claim HdefR2: Romega_coord_clipped_diff g h n = If_i (Rlt q 1) q 1.
{ reflexivity. }
rewrite HdefL.
rewrite HdefR1.
rewrite HdefR2.
claim Hmono: If_i (Rlt r 1) r 1 <= If_i (Rlt (add_SNo p q) 1) (add_SNo p q) 1.
{ exact (Rclip_mono r (add_SNo p q) HrR (real_add_SNo p HpR q HqR) HabsTri). }
claim Hsub: If_i (Rlt (add_SNo p q) 1) (add_SNo p q) 1 <= add_SNo (If_i (Rlt p 1) p 1) (If_i (Rlt q 1) q 1).
{ exact (Rclip_subadd_nonneg p q HpR HqR HppNN HqqNN). }
exact (SNoLe_tra (If_i (Rlt r 1) r 1)
                 (If_i (Rlt (add_SNo p q) 1) (add_SNo p q) 1)
                 (add_SNo (If_i (Rlt p 1) p 1) (If_i (Rlt q 1) q 1))
                 (SNo_If_i (Rlt r 1) r 1 HrS SNo_1)
                 (SNo_If_i (Rlt (add_SNo p q) 1) (add_SNo p q) 1 (SNo_add_SNo p q HpS HqS) SNo_1)
                 (SNo_add_SNo (If_i (Rlt p 1) p 1) (If_i (Rlt q 1) q 1)
                              (SNo_If_i (Rlt p 1) p 1 HpS SNo_1)
                              (SNo_If_i (Rlt q 1) q 1 HqS SNo_1))
                 Hmono
                 Hsub).
Qed.

(** helper: uniform metric value triangle inequality **)
Theorem Romega_uniform_metric_value_triangle : forall x y z:set,
  x :e real_sequences -> y :e real_sequences -> z :e real_sequences ->
  ~(Rlt (add_SNo (Romega_uniform_metric_value x y) (Romega_uniform_metric_value y z))
        (Romega_uniform_metric_value x z)).
let x y z.
assume Hx: x :e real_sequences.
assume Hy: y :e real_sequences.
assume Hz: z :e real_sequences.
set A := Romega_clipped_diffs x z.
set l := Romega_uniform_metric_value x z.
set u := add_SNo (Romega_uniform_metric_value x y) (Romega_uniform_metric_value y z).
claim Hlub: R_lub A l.
{ exact (Romega_uniform_metric_value_is_lub x z Hx Hz). }
claim HlR: l :e R.
{ exact (R_lub_in_R A l Hlub). }
claim HuR: u :e R.
{ exact (real_add_SNo (Romega_uniform_metric_value x y)
                      (Romega_uniform_metric_value_in_R x y Hx Hy)
                      (Romega_uniform_metric_value y z)
                      (Romega_uniform_metric_value_in_R y z Hy Hz)). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a u.
{ let a. assume HaA: a :e A. assume HaR: a :e R.
  apply (ReplE_impred omega (fun n:set => Romega_coord_clipped_diff x z n) a HaA (Rle a u)).
  let n. assume HnO: n :e omega.
  assume Haeq: a = Romega_coord_clipped_diff x z n.
  rewrite Haeq.
  set axz := Romega_coord_clipped_diff x z n.
  set axy := Romega_coord_clipped_diff x y n.
  set ayz := Romega_coord_clipped_diff y z n.
  claim HaxzLe: axz <= add_SNo axy ayz.
  { exact (Romega_coord_clipped_diff_triangle x y z n Hx Hy Hz HnO). }
  claim HaxzR: axz :e R.
  { exact (Romega_clipped_diffs_in_R x z Hx Hz axz (ReplI omega (fun k:set => Romega_coord_clipped_diff x z k) n HnO)). }
  claim HaxyR: axy :e R.
  { exact (Romega_clipped_diffs_in_R x y Hx Hy axy (ReplI omega (fun k:set => Romega_coord_clipped_diff x y k) n HnO)). }
  claim HayzR: ayz :e R.
  { exact (Romega_clipped_diffs_in_R y z Hy Hz ayz (ReplI omega (fun k:set => Romega_coord_clipped_diff y z k) n HnO)). }
  claim HsumR: add_SNo axy ayz :e R.
  { exact (real_add_SNo axy HaxyR ayz HayzR). }
  claim H1: Rle axz (add_SNo axy ayz).
  { exact (Rle_of_SNoLe axz (add_SNo axy ayz) HaxzR HsumR HaxzLe). }
  claim Hlubxy: R_lub (Romega_clipped_diffs x y) (Romega_uniform_metric_value x y).
  { exact (Romega_uniform_metric_value_is_lub x y Hx Hy). }
  claim Hlubyz: R_lub (Romega_clipped_diffs y z) (Romega_uniform_metric_value y z).
  { exact (Romega_uniform_metric_value_is_lub y z Hy Hz). }
  claim Hxyub: forall b:set, b :e Romega_clipped_diffs x y -> b :e R -> Rle b (Romega_uniform_metric_value x y).
  { exact (andER ((Romega_uniform_metric_value x y) :e R)
                 (forall b:set, b :e Romega_clipped_diffs x y -> b :e R -> Rle b (Romega_uniform_metric_value x y))
                 (andEL (((Romega_uniform_metric_value x y) :e R) /\
                         forall b:set, b :e Romega_clipped_diffs x y -> b :e R -> Rle b (Romega_uniform_metric_value x y))
                        (forall uu:set, uu :e R -> (forall b:set, b :e Romega_clipped_diffs x y -> b :e R -> Rle b uu) -> Rle (Romega_uniform_metric_value x y) uu)
                        Hlubxy)). }
  claim Hyzub: forall b:set, b :e Romega_clipped_diffs y z -> b :e R -> Rle b (Romega_uniform_metric_value y z).
  { exact (andER ((Romega_uniform_metric_value y z) :e R)
                 (forall b:set, b :e Romega_clipped_diffs y z -> b :e R -> Rle b (Romega_uniform_metric_value y z))
                 (andEL (((Romega_uniform_metric_value y z) :e R) /\
                         forall b:set, b :e Romega_clipped_diffs y z -> b :e R -> Rle b (Romega_uniform_metric_value y z))
                        (forall uu:set, uu :e R -> (forall b:set, b :e Romega_clipped_diffs y z -> b :e R -> Rle b uu) -> Rle (Romega_uniform_metric_value y z) uu)
                        Hlubyz)). }
  claim Haxyub: Rle axy (Romega_uniform_metric_value x y).
  { exact (Hxyub axy (ReplI omega (fun k:set => Romega_coord_clipped_diff x y k) n HnO) HaxyR). }
  claim Hayzub: Rle ayz (Romega_uniform_metric_value y z).
  { exact (Hyzub ayz (ReplI omega (fun k:set => Romega_coord_clipped_diff y z k) n HnO) HayzR). }
  claim H2a: Rle (add_SNo axy ayz) (add_SNo axy (Romega_uniform_metric_value y z)).
  { exact (Rle_add_SNo_2 axy ayz (Romega_uniform_metric_value y z) HaxyR HayzR (Romega_uniform_metric_value_in_R y z Hy Hz) Hayzub). }
	  claim H2b': Rle (add_SNo (Romega_uniform_metric_value y z) axy) (add_SNo (Romega_uniform_metric_value y z) (Romega_uniform_metric_value x y)).
	  { exact (Rle_add_SNo_2 (Romega_uniform_metric_value y z) axy (Romega_uniform_metric_value x y)
	                         (Romega_uniform_metric_value_in_R y z Hy Hz)
	                         HaxyR
	                         (Romega_uniform_metric_value_in_R x y Hx Hy)
	                         Haxyub). }
	  claim H2b: Rle (add_SNo axy (Romega_uniform_metric_value y z)) (add_SNo (Romega_uniform_metric_value x y) (Romega_uniform_metric_value y z)).
	  { claim HcomL: add_SNo axy (Romega_uniform_metric_value y z) = add_SNo (Romega_uniform_metric_value y z) axy.
	    { exact (add_SNo_com axy (Romega_uniform_metric_value y z)
	                         (real_SNo axy HaxyR)
	                         (real_SNo (Romega_uniform_metric_value y z) (Romega_uniform_metric_value_in_R y z Hy Hz))). }
	    claim HcomR: add_SNo (Romega_uniform_metric_value x y) (Romega_uniform_metric_value y z)
	                  = add_SNo (Romega_uniform_metric_value y z) (Romega_uniform_metric_value x y).
	    { exact (add_SNo_com (Romega_uniform_metric_value x y) (Romega_uniform_metric_value y z)
	                         (real_SNo (Romega_uniform_metric_value x y) (Romega_uniform_metric_value_in_R x y Hx Hy))
	                         (real_SNo (Romega_uniform_metric_value y z) (Romega_uniform_metric_value_in_R y z Hy Hz))). }
	    rewrite HcomL.
	    rewrite HcomR.
	    exact H2b'. }
  claim H2: Rle (add_SNo axy ayz) u.
  { exact (Rle_tra (add_SNo axy ayz) (add_SNo axy (Romega_uniform_metric_value y z)) u H2a H2b). }
  exact (Rle_tra axz (add_SNo axy ayz) u H1 H2). }
claim Hmin: forall uu:set, uu :e R -> (forall a:set, a :e A -> a :e R -> Rle a uu) -> Rle l uu.
{ exact (andER ((l :e R) /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall uu:set, uu :e R -> (forall a:set, a :e A -> a :e R -> Rle a uu) -> Rle l uu)
               Hlub). }
claim Hle: Rle l u.
{ exact (Hmin u HuR Hub). }
exact (RleE_nlt l u Hle).
Qed.

(** helper: uniform_metric_Romega satisfies metric_on (pending full proof) **)
(** LATEX VERSION: The uniform metric on R^ω is a metric on the set of real sequences. **)
Theorem uniform_metric_Romega_is_metric : metric_on real_sequences uniform_metric_Romega.
prove metric_on real_sequences uniform_metric_Romega.
prove ((((function_on uniform_metric_Romega (setprod real_sequences real_sequences) R /\
         (forall x y:set, x :e real_sequences -> y :e real_sequences ->
            apply_fun uniform_metric_Romega (x,y) = apply_fun uniform_metric_Romega (y,x))) /\
        (forall x:set, x :e real_sequences -> apply_fun uniform_metric_Romega (x,x) = 0)) /\
       (forall x y:set, x :e real_sequences -> y :e real_sequences ->
          ~(Rlt (apply_fun uniform_metric_Romega (x,y)) 0)
          /\ (apply_fun uniform_metric_Romega (x,y) = 0 -> x = y))) /\
      (forall x y z:set, x :e real_sequences -> y :e real_sequences -> z :e real_sequences ->
         ~(Rlt (add_SNo (apply_fun uniform_metric_Romega (x,y)) (apply_fun uniform_metric_Romega (y,z)))
               (apply_fun uniform_metric_Romega (x,z))))).
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - exact uniform_metric_Romega_function_on.
      - let x y.
        assume Hx: x :e real_sequences.
        assume Hy: y :e real_sequences.
        claim Hxyprod: (x,y) :e setprod real_sequences real_sequences.
        { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x y Hx Hy). }
        claim Hyxprod: (y,x) :e setprod real_sequences real_sequences.
        { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences y x Hy Hx). }
        rewrite (apply_fun_graph (setprod real_sequences real_sequences)
                                 (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
                                 (x,y)
                                 Hxyprod).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        rewrite (apply_fun_graph (setprod real_sequences real_sequences)
                                 (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
                                 (y,x)
                                 Hyxprod).
        rewrite (tuple_2_0_eq y x).
        rewrite (tuple_2_1_eq y x).
        exact (Romega_uniform_metric_value_sym x y Hx Hy).
    * let x.
      assume Hx: x :e real_sequences.
      claim Hxxprod: (x,x) :e setprod real_sequences real_sequences.
      { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x x Hx Hx). }
      rewrite (apply_fun_graph (setprod real_sequences real_sequences)
                               (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
                               (x,x)
                               Hxxprod).
      rewrite (tuple_2_0_eq x x).
      rewrite (tuple_2_1_eq x x).
      exact (Romega_uniform_metric_value_self_zero x Hx).
  + let x y.
    assume Hx: x :e real_sequences.
    assume Hy: y :e real_sequences.
    prove ~(Rlt (apply_fun uniform_metric_Romega (x,y)) 0) /\ (apply_fun uniform_metric_Romega (x,y) = 0 -> x = y).
    apply andI.
    * claim Hxyprod: (x,y) :e setprod real_sequences real_sequences.
      { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x y Hx Hy). }
      rewrite (apply_fun_graph (setprod real_sequences real_sequences)
                               (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
                               (x,y)
                               Hxyprod).
      rewrite (tuple_2_0_eq x y).
	      rewrite (tuple_2_1_eq x y).
	      exact (Romega_uniform_metric_value_nonneg x y Hx Hy).
	    * assume H0: apply_fun uniform_metric_Romega (x,y) = 0.
	      claim Hxyprod: (x,y) :e setprod real_sequences real_sequences.
	      { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x y Hx Hy). }
	      claim Happ: apply_fun uniform_metric_Romega (x,y) = Romega_uniform_metric_value x y.
	      { rewrite (apply_fun_graph (setprod real_sequences real_sequences)
	                                 (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
	                                 (x,y)
	                                 Hxyprod).
	        rewrite (tuple_2_0_eq x y).
	        rewrite (tuple_2_1_eq x y).
	        reflexivity. }
	      claim Hval0: Romega_uniform_metric_value x y = 0.
	      { rewrite <- Happ.
	        exact H0. }
	      claim Hcoord: forall n:set, n :e omega -> apply_fun x n = apply_fun y n.
	      { let n.
	        assume HnO: n :e omega.
	        exact (Romega_uniform_metric_value_eq0_coord_eq x y Hx Hy Hval0 n HnO). }
		      exact (real_sequences_ext x y Hx Hy Hcoord).
	- let x y z.
	  assume Hx: x :e real_sequences.
	  assume Hy: y :e real_sequences.
	  assume Hz: z :e real_sequences.
	  claim Hxyprod: (x,y) :e setprod real_sequences real_sequences.
	  { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x y Hx Hy). }
	  claim Hyzprod: (y,z) :e setprod real_sequences real_sequences.
	  { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences y z Hy Hz). }
	  claim Hxzprod: (x,z) :e setprod real_sequences real_sequences.
	  { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences x z Hx Hz). }
	  rewrite (apply_fun_graph (setprod real_sequences real_sequences)
	                           (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
	                           (x,y)
	                           Hxyprod).
	  rewrite (tuple_2_0_eq x y).
	  rewrite (tuple_2_1_eq x y).
	  rewrite (apply_fun_graph (setprod real_sequences real_sequences)
	                           (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
	                           (y,z)
	                           Hyzprod).
	  rewrite (tuple_2_0_eq y z).
	  rewrite (tuple_2_1_eq y z).
	  rewrite (apply_fun_graph (setprod real_sequences real_sequences)
	                           (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
	                           (x,z)
	                           Hxzprod).
	  rewrite (tuple_2_0_eq x z).
	  rewrite (tuple_2_1_eq x z).
	  exact (Romega_uniform_metric_value_triangle x y z Hx Hy Hz).
Qed.

(** helper: uniform topology is a topology **)
(** LATEX VERSION: The uniform metric on real sequences induces a topology. **)
Theorem uniform_topology_is_topology : topology_on real_sequences uniform_topology.
prove topology_on real_sequences uniform_topology.
claim Hdef: uniform_topology = metric_topology real_sequences uniform_metric_Romega.
{ reflexivity. }
rewrite Hdef.
exact (metric_topology_is_topology real_sequences uniform_metric_Romega uniform_metric_Romega_is_metric).
Qed.

(** helper: uniform_topology is also a topology on R^omega (since real_sequences = R^omega) **)
Theorem uniform_topology_is_topology_on_Romega_space : topology_on R_omega_space uniform_topology.
prove topology_on R_omega_space uniform_topology.
rewrite <- (real_sequences_eq_Romega_space).
exact uniform_topology_is_topology.
Qed.



(** from §20 Theorem 20.4: compare uniform topology with product/box topology on R^J **)
(** LATEX VERSION: The uniform topology is finer than the product topology and coarser than the box topology. **)
Definition Romega_product_topology_on_real_sequences : set :=
  subspace_topology R_omega_space
    (product_topology_full omega (const_space_family omega R R_standard_topology))
    real_sequences.

(** from §20 Theorem 20.4: compare uniform topology with product/box topology on R^J **)
(** LATEX VERSION: The uniform topology is finer than the product topology and coarser than the box topology. **)
Definition Romega_box_topology_on_real_sequences : set :=
  subspace_topology R_omega_space
    (box_topology omega (const_space_family omega R R_standard_topology))
    real_sequences.

(** helper: the subspace topologies on real_sequences are the whole-space topologies, since real_sequences = R^omega **)
Theorem Romega_product_topology_on_real_sequences_eq :
  Romega_product_topology_on_real_sequences = R_omega_product_topology.
prove Romega_product_topology_on_real_sequences = R_omega_product_topology.
set Xi := const_space_family omega R R_standard_topology.
set T := product_topology_full omega Xi.
claim HTdef: R_omega_product_topology = T.
{ reflexivity. }
rewrite HTdef.
claim HdefL: Romega_product_topology_on_real_sequences = subspace_topology R_omega_space T real_sequences.
{ reflexivity. }
rewrite HdefL.
rewrite (real_sequences_eq_Romega_space).
claim HT: topology_on R_omega_space T.
{ rewrite <- HTdef.
  exact Romega_product_topology_is_topology. }
exact (subspace_topology_whole R_omega_space T HT).
Qed.

Theorem uniform_topology_finer_than_product_and_coarser_than_box :
  finer_than uniform_topology Romega_product_topology_on_real_sequences /\
  coarser_than uniform_topology Romega_box_topology_on_real_sequences.
prove finer_than uniform_topology Romega_product_topology_on_real_sequences /\
  coarser_than uniform_topology Romega_box_topology_on_real_sequences.
apply andI.
- (** product opens are uniform-open (uniform is finer than product) **)
  prove finer_than uniform_topology Romega_product_topology_on_real_sequences.
  rewrite (Romega_product_topology_on_real_sequences_eq).
  (** remaining goal: R_omega_product_topology c= uniform_topology **)
  prove R_omega_product_topology c= uniform_topology.
  set Xi0 := const_space_family omega R R_standard_topology.
  set X := product_space omega Xi0.
  set S := product_subbasis_full omega Xi0.
  claim HXeq: X = R_omega_space.
  { reflexivity. }
  claim HSsub: subbasis_on X S.
  { claim H0O: 0 :e omega.
    { exact (nat_p_omega 0 nat_0). }
    claim Hone: omega <> Empty.
    { exact (elem_implies_nonempty omega 0 H0O). }
    claim Hcomp: forall i:set, i :e omega -> topology_on (space_family_set Xi0 i) (space_family_topology Xi0 i).
    { let i. assume HiO: i :e omega.
      claim HXi: apply_fun Xi0 i = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology i HiO). }
      claim Hset: space_family_set Xi0 i = R.
      { claim Hdef: space_family_set Xi0 i = (apply_fun Xi0 i) 0.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_0_eq R R_standard_topology). }
      claim Htop: space_family_topology Xi0 i = R_standard_topology.
      { claim Hdef: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_1_eq R R_standard_topology). }
      rewrite Hset.
      rewrite Htop.
      exact R_standard_topology_is_topology_local. }
    exact (product_subbasis_full_subbasis_on omega Xi0 Hone Hcomp). }
  claim HtopU: topology_on X uniform_topology.
  { rewrite HXeq.
    exact uniform_topology_is_topology_on_Romega_space. }
  claim HSinc: S c= uniform_topology.
  { let s. assume HsS: s :e S.
    prove s :e uniform_topology.
    apply (famunionE_impred omega
            (fun j:set => {product_cylinder omega Xi0 j U|U :e space_family_topology Xi0 j})
            s HsS
            (s :e uniform_topology)).
    let j. assume HjO: j :e omega.
    assume Hsj: s :e {product_cylinder omega Xi0 j U|U :e space_family_topology Xi0 j}.
    apply (ReplE_impred (space_family_topology Xi0 j)
            (fun U0:set => product_cylinder omega Xi0 j U0)
            s Hsj
            (s :e uniform_topology)).
    let U0.
    assume HU0Top: U0 :e space_family_topology Xi0 j.
    assume Hseq: s = product_cylinder omega Xi0 j U0.
    rewrite Hseq.
    (** reduce the component topology to R_standard_topology **)
    claim HtopEq: space_family_topology Xi0 j = R_standard_topology.
    { claim HXi: apply_fun Xi0 j = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology j HjO). }
      claim Hdef: space_family_topology Xi0 j = (apply_fun Xi0 j) 1.
      { reflexivity. }
      rewrite Hdef.
      rewrite HXi.
      exact (tuple_2_1_eq R R_standard_topology). }
    claim HU0std: U0 :e R_standard_topology.
    { rewrite <- HtopEq.
      exact HU0Top. }
    (** show cylinder is open in the uniform metric topology **)
    set X0 := real_sequences.
    set d := uniform_metric_Romega.
    set C := product_cylinder omega Xi0 j U0.
    set B := famunion X0 (fun x0:set => {open_ball X0 d x0 r|r :e R, Rlt 0 r}).
    claim HTdef: uniform_topology = generated_topology X0 B.
    { reflexivity. }
    rewrite HTdef.
    prove C :e generated_topology X0 B.
    claim Hgendef: generated_topology X0 B =
      {U1 :e Power X0 | forall x :e U1, exists b :e B, x :e b /\ b c= U1}.
    { reflexivity. }
    rewrite Hgendef.
    apply SepI.
    - (** C is a subset of real_sequences **)
      apply PowerI.
      let f. assume HfC: f :e C.
      claim HfRomega: f :e R_omega_space.
      { exact (SepE1 R_omega_space
               (fun f0:set => j :e omega /\ U0 :e space_family_topology Xi0 j /\ apply_fun f0 j :e U0)
               f HfC). }
      prove f :e X0.
      rewrite real_sequences_eq_Romega_space.
      exact HfRomega.
	    - (** neighborhood condition for generated_topology: use a uniform open ball inside the cylinder **)
	      let f. assume HfC: f :e C.
	      (** choose an interval neighborhood of the j-th coordinate inside U0, then a uniform radius r>0 forcing the j-th coordinate to stay inside it **)
	      claim HfX0: f :e X0.
	      { claim HfRomega: f :e R_omega_space.
	        { exact (SepE1 R_omega_space
	                 (fun f0:set => j :e omega /\ U0 :e space_family_topology Xi0 j /\ apply_fun f0 j :e U0)
	                 f HfC). }
	        rewrite real_sequences_eq_Romega_space.
	        exact HfRomega. }
	      claim Hcore: j :e omega /\ U0 :e space_family_topology Xi0 j /\ apply_fun f j :e U0.
	      { exact (SepE2 R_omega_space
	               (fun f0:set => j :e omega /\ U0 :e space_family_topology Xi0 j /\ apply_fun f0 j :e U0)
	               f HfC). }
	      claim Hcore1: j :e omega /\ U0 :e space_family_topology Xi0 j.
	      { exact (andEL (j :e omega /\ U0 :e space_family_topology Xi0 j) (apply_fun f j :e U0) Hcore). }
	      claim HfjU0: apply_fun f j :e U0.
	      { exact (andER (j :e omega /\ U0 :e space_family_topology Xi0 j) (apply_fun f j :e U0) Hcore). }
	      claim HjO': j :e omega.
	      { exact (andEL (j :e omega) (U0 :e space_family_topology Xi0 j) Hcore1). }
	      claim HU0Top': U0 :e space_family_topology Xi0 j.
	      { exact (andER (j :e omega) (U0 :e space_family_topology Xi0 j) Hcore1). }
	      claim HU0std': U0 :e R_standard_topology.
	      { rewrite <- HtopEq.
	        exact HU0Top'. }
	      (** unpack U0 openness in R_standard_topology = generated_topology R R_standard_basis **)
	      claim HU0prop: forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0.
	      { exact (SepE2 (Power R)
	               (fun U1 : set => forall x0 :e U1, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U1)
	               U0 HU0std'). }
	      apply (HU0prop (apply_fun f j) HfjU0).
	      let I0. assume HI0pair.
	      claim HI0basis: I0 :e R_standard_basis.
	      { exact (andEL (I0 :e R_standard_basis) ((apply_fun f j) :e I0 /\ I0 c= U0) HI0pair). }
	      claim HI0prop: (apply_fun f j) :e I0 /\ I0 c= U0.
	      { exact (andER (I0 :e R_standard_basis) ((apply_fun f j) :e I0 /\ I0 c= U0) HI0pair). }
	      claim HfjI0: (apply_fun f j) :e I0.
	      { exact (andEL ((apply_fun f j) :e I0) (I0 c= U0) HI0prop). }
	      claim HI0sub: I0 c= U0.
	      { exact (andER ((apply_fun f j) :e I0) (I0 c= U0) HI0prop). }
	      (** destruct I0 as an open interval (a0,b0) **)
	      claim Hexa0: exists a0 :e R, I0 :e {open_interval a0 b0|b0 :e R}.
	      { exact (famunionE R (fun a0:set => {open_interval a0 b0|b0 :e R}) I0 HI0basis). }
	      apply Hexa0.
	      let a0. assume Ha0pair.
	      claim Ha0R: a0 :e R.
	      { exact (andEL (a0 :e R) (I0 :e {open_interval a0 b0|b0 :e R}) Ha0pair). }
	      claim HI0fam: I0 :e {open_interval a0 b0|b0 :e R}.
	      { exact (andER (a0 :e R) (I0 :e {open_interval a0 b0|b0 :e R}) Ha0pair). }
	      claim Hexb0: exists b0 :e R, I0 = open_interval a0 b0.
	      { exact (ReplE R (fun b00:set => open_interval a0 b00) I0 HI0fam). }
	      apply Hexb0.
	      let b0. assume Hb0pair.
	      claim Hb0R: b0 :e R.
	      { exact (andEL (b0 :e R) (I0 = open_interval a0 b0) Hb0pair). }
	      claim HI0eq: I0 = open_interval a0 b0.
	      { exact (andER (b0 :e R) (I0 = open_interval a0 b0) Hb0pair). }
	      (** set x = f(j) and extract a0 < x < b0 **)
	      claim HfjR: apply_fun f j :e R.
	      { claim Hfpack: total_function_on f omega R /\ functional_graph f.
	        { exact (SepE2 (Power (setprod omega R))
	                 (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
	                 f HfX0). }
	        claim Htotf: total_function_on f omega R.
	        { exact (andEL (total_function_on f omega R) (functional_graph f) Hfpack). }
	        exact (total_function_on_apply_fun_in_Y f omega R j Htotf HjO'). }
		      claim HfjInInt: apply_fun f j :e open_interval a0 b0.
		      { rewrite <- HI0eq.
		        exact HfjI0. }
	      claim HintPred: Rlt a0 (apply_fun f j) /\ Rlt (apply_fun f j) b0.
	      { exact (SepE2 R (fun z : set => Rlt a0 z /\ Rlt z b0) (apply_fun f j) HfjInInt). }
	      claim Ha0x: Rlt a0 (apply_fun f j).
	      { exact (andEL (Rlt a0 (apply_fun f j)) (Rlt (apply_fun f j) b0) HintPred). }
	      claim Hxb0: Rlt (apply_fun f j) b0.
	      { exact (andER (Rlt a0 (apply_fun f j)) (Rlt (apply_fun f j) b0) HintPred). }
	      (** define the positive gaps da = x-a0 and db = b0-x **)
	      set da := add_SNo (apply_fun f j) (minus_SNo a0).
	      set db := add_SNo b0 (minus_SNo (apply_fun f j)).
	      claim Ha0S: SNo a0.
	      { exact (real_SNo a0 Ha0R). }
	      claim Hb0S: SNo b0.
	      { exact (real_SNo b0 Hb0R). }
	      claim HxS: SNo (apply_fun f j).
	      { exact (real_SNo (apply_fun f j) HfjR). }
	      claim Hm_a0R: minus_SNo a0 :e R.
	      { exact (real_minus_SNo a0 Ha0R). }
	      claim Hm_xR: minus_SNo (apply_fun f j) :e R.
	      { exact (real_minus_SNo (apply_fun f j) HfjR). }
	      claim HdaR: da :e R.
	      { exact (real_add_SNo (apply_fun f j) HfjR (minus_SNo a0) Hm_a0R). }
	      claim HdbR: db :e R.
	      { exact (real_add_SNo b0 Hb0R (minus_SNo (apply_fun f j)) Hm_xR). }
	      claim Ha0xlt: a0 < apply_fun f j.
	      { exact (RltE_lt a0 (apply_fun f j) Ha0x). }
	      claim Hxb0lt: apply_fun f j < b0.
	      { exact (RltE_lt (apply_fun f j) b0 Hxb0). }
	      claim H0da_lt: 0 < da.
	      { claim H0a0eq: add_SNo 0 a0 = a0.
	        { exact (add_SNo_0L a0 Ha0S). }
	        claim H0a0ltx: add_SNo 0 a0 < apply_fun f j.
	        { rewrite H0a0eq at 1.
	          exact Ha0xlt. }
	        exact (add_SNo_minus_Lt2b (apply_fun f j) a0 0 HxS Ha0S SNo_0 H0a0ltx). }
	      claim H0db_lt: 0 < db.
	      { claim H0xeq: add_SNo 0 (apply_fun f j) = apply_fun f j.
	        { exact (add_SNo_0L (apply_fun f j) HxS). }
	        claim H0xltb0: add_SNo 0 (apply_fun f j) < b0.
	        { rewrite H0xeq at 1.
	          exact Hxb0lt. }
	        exact (add_SNo_minus_Lt2b b0 (apply_fun f j) 0 Hb0S HxS SNo_0 H0xltb0). }
	      claim H0da: Rlt 0 da.
	      { exact (RltI 0 da real_0 HdaR H0da_lt). }
	      claim H0db: Rlt 0 db.
	      { exact (RltI 0 db real_0 HdbR H0db_lt). }
	      (** choose r3 < da and r3 < db, then r < r3 and r < 1 **)
	      apply (exists_eps_lt_two_pos_Euclid da db HdaR HdbR H0da H0db).
	      let r3. assume Hr3pack.
	      claim Hr3pair1: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 da.
	      { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 da) (Rlt r3 db) Hr3pack). }
	      claim Hr3db: Rlt r3 db.
	      { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 da) (Rlt r3 db) Hr3pack). }
	      claim Hr3pair0: r3 :e R /\ Rlt 0 r3.
	      { exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 da) Hr3pair1). }
	      claim Hr3da: Rlt r3 da.
	      { exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 da) Hr3pair1). }
	      claim Hr3R: r3 :e R.
	      { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3pair0). }
	      claim Hr3pos: Rlt 0 r3.
	      { exact (andER (r3 :e R) (Rlt 0 r3) Hr3pair0). }
	      apply (exists_eps_lt_two_pos_Euclid r3 1 Hr3R real_1 Hr3pos Rlt_0_1).
	      let r. assume Hrpack.
	      claim Hrpair1: (r :e R /\ Rlt 0 r) /\ Rlt r r3.
	      { exact (andEL ((r :e R /\ Rlt 0 r) /\ Rlt r r3) (Rlt r 1) Hrpack). }
	      claim Hr1: Rlt r 1.
	      { exact (andER ((r :e R /\ Rlt 0 r) /\ Rlt r r3) (Rlt r 1) Hrpack). }
	      claim Hrpair0: r :e R /\ Rlt 0 r.
	      { exact (andEL (r :e R /\ Rlt 0 r) (Rlt r r3) Hrpair1). }
	      claim Hrr3: Rlt r r3.
	      { exact (andER (r :e R /\ Rlt 0 r) (Rlt r r3) Hrpair1). }
	      claim HrR: r :e R.
	      { exact (andEL (r :e R) (Rlt 0 r) Hrpair0). }
	      claim Hrpos: Rlt 0 r.
	      { exact (andER (r :e R) (Rlt 0 r) Hrpair0). }
	      claim Hrda: Rlt r da.
	      { exact (Rlt_tra r r3 da Hrr3 Hr3da). }
	      claim Hrdb: Rlt r db.
	      { exact (Rlt_tra r r3 db Hrr3 Hr3db). }
	      (** define the neighborhood ball around f **)
	      set ball := open_ball X0 d f r.
	      witness ball.
	      apply andI.
	      - (** ball is in B **)
	        prove ball :e B.
	        claim Hball_in_rfam: ball :e {open_ball X0 d f rr|rr :e R, Rlt 0 rr}.
	        { exact (ReplSepI R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball X0 d f rr) r HrR Hrpos). }
	        exact (famunionI X0 (fun x0:set => {open_ball X0 d x0 rr|rr :e R, Rlt 0 rr})
	               f ball HfX0 Hball_in_rfam).
	      - apply andI.
	        + (** f is in its ball **)
	          exact (center_in_open_ball X0 d f r uniform_metric_Romega_is_metric HfX0 Hrpos).
	        + (** the ball is contained in the cylinder **)
	          prove ball c= C.
	          let g. assume Hgball: g :e ball.
	          claim HgX0: g :e X0.
	          { exact (open_ballE1 X0 d f r g Hgball). }
	          claim Hltfg: Rlt (apply_fun d (f,g)) r.
	          { exact (open_ballE2 X0 d f r g Hgball). }
		          (** convert metric value to Romega_uniform_metric_value f g **)
		          claim Hpfg: (f,g) :e setprod real_sequences real_sequences.
		          { exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences f g HfX0 HgX0). }
		          claim Happ0: apply_fun d (f,g) =
		            Romega_uniform_metric_value ((f,g) 0) ((f,g) 1).
		          { exact (apply_fun_graph (setprod real_sequences real_sequences)
		                   (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
		                   (f,g) Hpfg). }
		          claim Hp0: (f,g) 0 = f.
		          { exact (tuple_2_0_eq f g). }
		          claim Hp1: (f,g) 1 = g.
		          { exact (tuple_2_1_eq f g). }
		          claim Happ: apply_fun d (f,g) = Romega_uniform_metric_value f g.
		          { rewrite Happ0.
		            rewrite Hp0.
		            rewrite Hp1.
		            reflexivity. }
	          claim HltU: Rlt (Romega_uniform_metric_value f g) r.
	          { rewrite <- Happ.
	            exact Hltfg. }
	          (** bound the j-th clipped coordinate difference **)
	          claim Hclip: Rlt (Romega_coord_clipped_diff f g j) r.
	          { exact (Romega_coord_clipped_diff_lt_of_uniform_lt f g j r HfX0 HgX0 HjO' HltU). }
	          (** since r<1, clipped diff < r forces abs diff < r **)
	          claim Habs: Rlt (Romega_coord_abs_diff f g j) r.
	          { set A := Romega_coord_abs_diff f g j.
	            claim HdefClip: Romega_coord_clipped_diff f g j =
	              If_i (Rlt A 1) A 1.
	            { reflexivity. }
		            apply (xm (Rlt A 1) (Rlt A r)).
		            - assume Halt1: Rlt A 1.
		              claim HclipEq: Romega_coord_clipped_diff f g j = A.
		              { rewrite HdefClip.
		                rewrite (If_i_1 (Rlt A 1) A 1 Halt1).
		                reflexivity. }
		              rewrite <- HclipEq at 1.
		              exact Hclip.
	            - assume Hnalt1: ~(Rlt A 1).
	              claim Hcl1: Romega_coord_clipped_diff f g j = 1.
	              { rewrite HdefClip.
	                rewrite (If_i_0 (Rlt A 1) A 1 Hnalt1).
	                reflexivity. }
	              claim H1ltr: Rlt 1 r.
	              { rewrite <- Hcl1 at 1.
	                exact Hclip. }
	              prove Rlt A r.
	              exact (FalseE ((not_Rlt_sym r 1 Hr1) H1ltr) (Rlt A r)).
	          }
	          (** derive bounds on g(j) from abs(f(j)-g(j)) < r **)
	          claim HfjR2: apply_fun f j :e R.
	          { exact HfjR. }
	          claim HgjR: apply_fun g j :e R.
	          { claim Hgpack: total_function_on g omega R /\ functional_graph g.
	            { exact (SepE2 (Power (setprod omega R))
	                     (fun g0:set => total_function_on g0 omega R /\ functional_graph g0)
	                     g HgX0). }
	            claim Htotg: total_function_on g omega R.
	            { exact (andEL (total_function_on g omega R) (functional_graph g) Hgpack). }
	            exact (total_function_on_apply_fun_in_Y g omega R j Htotg HjO'). }
	          claim HrS: SNo r.
	          { exact (real_SNo r HrR). }
	          claim HtS: SNo (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))).
	          { exact (SNo_add_SNo (apply_fun f j) (minus_SNo (apply_fun g j)) HxS
	                    (SNo_minus_SNo (apply_fun g j) (real_SNo (apply_fun g j) HgjR))). }
	          claim Hrposlt: 0 < r.
	          { exact (RltE_lt 0 r Hrpos). }
	          claim Hablt: abs_SNo (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))) < r.
	          { exact (RltE_lt (Romega_coord_abs_diff f g j) r Habs). }
	          claim Hxg_lt: add_SNo (apply_fun f j) (minus_SNo (apply_fun g j)) < r.
	          { exact (abs_SNo_lt_imp_lt (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))) r
	                    HtS HrS Hrposlt Hablt). }
	          claim Hg_x_lt: minus_SNo (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))) < r.
	          { exact (abs_SNo_lt_imp_neg_lt (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))) r
	                    HtS HrS Hrposlt Hablt). }
	          (** show x-r < g(j) **)
	          claim Hx_lt_rg: apply_fun f j < add_SNo r (apply_fun g j).
	          { exact (add_SNo_minus_Lt1 (apply_fun f j) (apply_fun g j) r
	                    HxS (real_SNo (apply_fun g j) HgjR) HrS Hxg_lt). }
		          claim Hx_lt_gr: apply_fun f j < add_SNo (apply_fun g j) r.
		          { rewrite (add_SNo_com (apply_fun g j) r (real_SNo (apply_fun g j) HgjR) HrS).
		            exact Hx_lt_rg. }
	          claim Hxmr_lt_g: add_SNo (apply_fun f j) (minus_SNo r) < apply_fun g j.
	          { exact (add_SNo_minus_Lt1b (apply_fun f j) r (apply_fun g j)
	                    HxS HrS (real_SNo (apply_fun g j) HgjR) Hx_lt_gr). }
		          (** show g(j) < x+r **)
		          claim Hg_lt_rx: apply_fun g j < add_SNo r (apply_fun f j).
		          { claim HgjS: SNo (apply_fun g j).
		            { exact (real_SNo (apply_fun g j) HgjR). }
		            claim HabsSwap: abs_SNo (add_SNo (apply_fun f j) (minus_SNo (apply_fun g j))) =
		              abs_SNo (add_SNo (apply_fun g j) (minus_SNo (apply_fun f j))).
		            { exact (abs_SNo_dist_swap (apply_fun f j) (apply_fun g j) HxS HgjS). }
		            claim Hab2: abs_SNo (add_SNo (apply_fun g j) (minus_SNo (apply_fun f j))) < r.
		            { rewrite <- HabsSwap.
		              exact Hablt. }
		            claim Ht2S: SNo (add_SNo (apply_fun g j) (minus_SNo (apply_fun f j))).
		            { exact (SNo_add_SNo (apply_fun g j) (minus_SNo (apply_fun f j)) HgjS
		                      (SNo_minus_SNo (apply_fun f j) HxS)). }
		            claim Hgmx_lt: add_SNo (apply_fun g j) (minus_SNo (apply_fun f j)) < r.
		            { exact (abs_SNo_lt_imp_lt (add_SNo (apply_fun g j) (minus_SNo (apply_fun f j))) r
		                      Ht2S HrS Hrposlt Hab2). }
		            exact (add_SNo_minus_Lt1 (apply_fun g j) (apply_fun f j) r
		                      HgjS HxS HrS Hgmx_lt). }
		  claim Hg_lt_xr: apply_fun g j < add_SNo (apply_fun f j) r.
		  { rewrite (add_SNo_com (apply_fun f j) r HxS HrS).
		    exact Hg_lt_rx. }
	          (** relate r<da and r<db to interval bounds for g(j) **)
	          claim Hrda_lt: r < da.
	          { exact (RltE_lt r da Hrda). }
	          claim Hrdb_lt: r < db.
	          { exact (RltE_lt r db Hrdb). }
	          claim Harltx: add_SNo a0 r < apply_fun f j.
	          { claim Hra_lt_x: add_SNo r a0 < apply_fun f j.
	            { exact (add_SNo_minus_Lt2 (apply_fun f j) a0 r HxS Ha0S HrS Hrda_lt). }
	            rewrite (add_SNo_com a0 r Ha0S HrS) at 1.
	            exact Hra_lt_x. }
	          claim Ha0_lt_xmr: a0 < add_SNo (apply_fun f j) (minus_SNo r).
	          { exact (add_SNo_minus_Lt2b (apply_fun f j) r a0 HxS HrS Ha0S Harltx). }
		          claim Hb0gt_xpr: add_SNo (apply_fun f j) r < b0.
		          { claim Hxr_lt_b: add_SNo r (apply_fun f j) < b0.
		            { exact (add_SNo_minus_Lt2 b0 (apply_fun f j) r Hb0S HxS HrS Hrdb_lt). }
		            rewrite (add_SNo_com (apply_fun f j) r HxS HrS) at 1.
		            exact Hxr_lt_b. }
	          (** now show g(j) is in the open interval and hence in U0 **)
	          claim Hagj: a0 < apply_fun g j.
	          { exact (SNoLt_tra a0 (add_SNo (apply_fun f j) (minus_SNo r)) (apply_fun g j)
	                    Ha0S (SNo_add_SNo (apply_fun f j) (minus_SNo r) HxS (SNo_minus_SNo r HrS))
	                    (real_SNo (apply_fun g j) HgjR)
	                    Ha0_lt_xmr Hxmr_lt_g). }
	          claim Hgjb: apply_fun g j < b0.
	          { exact (SNoLt_tra (apply_fun g j) (add_SNo (apply_fun f j) r) b0
	                    (real_SNo (apply_fun g j) HgjR)
	                    (SNo_add_SNo (apply_fun f j) r HxS HrS)
	                    Hb0S
	                    Hg_lt_xr Hb0gt_xpr). }
	          claim HRlt_a0gj: Rlt a0 (apply_fun g j).
	          { exact (RltI a0 (apply_fun g j) Ha0R HgjR Hagj). }
	          claim HRlt_gjb0: Rlt (apply_fun g j) b0.
	          { exact (RltI (apply_fun g j) b0 HgjR Hb0R Hgjb). }
	          claim HgInInt: apply_fun g j :e open_interval a0 b0.
	          { exact (SepI R (fun z : set => Rlt a0 z /\ Rlt z b0) (apply_fun g j) HgjR
	                   (andI (Rlt a0 (apply_fun g j)) (Rlt (apply_fun g j) b0) HRlt_a0gj HRlt_gjb0)). }
	          claim HgI0: apply_fun g j :e I0.
	          { rewrite HI0eq.
	            exact HgInInt. }
	          claim HgjU0: apply_fun g j :e U0.
	          { exact (HI0sub (apply_fun g j) HgI0). }
		          (** finally, g is in the cylinder C **)
		          prove g :e C.
		          claim HCdef: C =
		            {f0 :e product_space omega Xi0 | j :e omega /\ U0 :e space_family_topology Xi0 j /\ apply_fun f0 j :e U0}.
		          { reflexivity. }
		          rewrite HCdef.
		          apply SepI.
		          - (** g is a real sequence, hence in the product space **)
		            claim HXdef: X = product_space omega Xi0.
		            { reflexivity. }
		            rewrite <- HXdef.
		            rewrite <- HXeq.
		            rewrite <- real_sequences_eq_Romega_space.
		            exact HgX0.
		          - (** predicate: j∈omega and U0 open and g(j)∈U0 **)
		            claim Hleft: j :e omega /\ U0 :e space_family_topology Xi0 j.
		            { exact (andI (j :e omega) (U0 :e space_family_topology Xi0 j) HjO' HU0Top'). }
		            exact (andI (j :e omega /\ U0 :e space_family_topology Xi0 j) (apply_fun g j :e U0) Hleft HgjU0).
		  }
  claim Hmin: finer_than uniform_topology (generated_topology_from_subbasis X S).
  { exact (topology_generated_by_basis_is_minimal X S uniform_topology HSsub HtopU HSinc). }
  claim Hinc: generated_topology_from_subbasis X S c= uniform_topology.
  { exact Hmin. }
  claim HdefProd: R_omega_product_topology = generated_topology_from_subbasis X S.
  { reflexivity. }
  let U.
  assume HU: U :e R_omega_product_topology.
  prove U :e uniform_topology.
  claim HUgen: U :e generated_topology_from_subbasis X S.
  { rewrite <- HdefProd.
    exact HU. }
  exact (Hinc U HUgen).
	- (** uniform-open sets are box-open (uniform is coarser than box) **)
	  prove coarser_than uniform_topology Romega_box_topology_on_real_sequences.
	  (** remaining goal: uniform_topology c= Romega_box_topology_on_real_sequences **)
	  prove uniform_topology c= Romega_box_topology_on_real_sequences.
	  set Xi0 := const_space_family omega R R_standard_topology.
	  set X0 := real_sequences.
	  set d := uniform_metric_Romega.
	  set Bballs := famunion X0 (fun x0:set => {open_ball X0 d x0 rr|rr :e R, Rlt 0 rr}).
	  set BoxT := box_topology omega Xi0.
	  set BoxB := box_basis omega Xi0.
		  claim HBoxRefine: forall c x r:set,
		    c :e X0 -> x :e X0 -> r :e R -> Rlt 0 r ->
		    x :e open_ball X0 d c r ->
		    exists bb:set, bb :e BoxB /\ x :e bb /\ bb c= open_ball X0 d c r.
		  { let c x r.
		    assume HcX0: c :e X0.
		    assume HxX0: x :e X0.
		    assume HrR: r :e R.
		    assume Hrpos: Rlt 0 r.
		    assume Hxin: x :e open_ball X0 d c r.
		    claim Hm: metric_on X0 d.
		    { exact uniform_metric_Romega_is_metric. }
		    claim Href: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X0 d x s c= open_ball X0 d c r.
		    { exact (open_ball_refine_center X0 d c x r Hm HcX0 HxX0 HrR Hrpos Hxin). }
		    apply Href.
		    let s. assume HsPack.
		    claim HsPair: s :e R /\ Rlt 0 s.
		    { exact (andEL (s :e R /\ Rlt 0 s) (open_ball X0 d x s c= open_ball X0 d c r) HsPack). }
		    claim HsR: s :e R.
		    { exact (andEL (s :e R) (Rlt 0 s) HsPair). }
		    claim Hspos: Rlt 0 s.
		    { exact (andER (s :e R) (Rlt 0 s) HsPair). }
		    claim HsSub: open_ball X0 d x s c= open_ball X0 d c r.
		    { exact (andER (s :e R /\ Rlt 0 s) (open_ball X0 d x s c= open_ball X0 d c r) HsPack). }
		    claim Hexeps: exists eps:set, eps :e R /\ Rlt 0 eps /\ Rlt eps s /\ Rlt eps 1.
		    { exact (exists_eps_lt_two_pos_Euclid s 1 HsR real_1 Hspos Rlt_0_1). }
		    apply Hexeps.
		    let eps. assume HepsPack.
		    claim HepsCore: (eps :e R /\ Rlt 0 eps) /\ Rlt eps s.
		    { exact (andEL ((eps :e R /\ Rlt 0 eps) /\ Rlt eps s) (Rlt eps 1) HepsPack). }
		    claim Hepslt1: Rlt eps 1.
		    { exact (andER ((eps :e R /\ Rlt 0 eps) /\ Rlt eps s) (Rlt eps 1) HepsPack). }
		    claim HepsPair: eps :e R /\ Rlt 0 eps.
		    { exact (andEL (eps :e R /\ Rlt 0 eps) (Rlt eps s) HepsCore). }
		    claim HepsltS: Rlt eps s.
		    { exact (andER (eps :e R /\ Rlt 0 eps) (Rlt eps s) HepsCore). }
		    claim HepsR: eps :e R.
		    { exact (andEL (eps :e R) (Rlt 0 eps) HepsPair). }
		    claim Hepspos: Rlt 0 eps.
		    { exact (andER (eps :e R) (Rlt 0 eps) HepsPair). }
		
		    set Ufun := graph omega (fun i:set =>
		      open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
		                    (add_SNo (apply_fun x i) eps)).
		    set bb := {f :e product_space omega Xi0 | forall i:set, i :e omega -> apply_fun f i :e apply_fun Ufun i}.
		    witness bb.
		    apply andI.
		    - prove bb :e BoxB /\ x :e bb.
		      apply andI.
		      + (** bb :e BoxB **)
		        prove bb :e BoxB.
		        claim HBoxBdef: BoxB = box_basis omega Xi0.
		        { reflexivity. }
		        rewrite HBoxBdef.
		        claim HBoxBasisDef: box_basis omega Xi0 =
		          {B :e Power (product_space omega Xi0) |
		            exists U:set, total_function_on U omega (topology_family_union omega Xi0) /\ functional_graph U /\
		              (forall i:set, i :e omega -> apply_fun U i :e space_family_topology Xi0 i) /\
		              B = {f :e product_space omega Xi0 | forall i:set, i :e omega -> apply_fun f i :e apply_fun U i}}.
		        { reflexivity. }
		        rewrite HBoxBasisDef.
		      claim HbbPow: bb :e Power (product_space omega Xi0).
		      { apply PowerI.
		        let f. assume Hfbb: f :e bb.
		        exact (SepE1 (product_space omega Xi0)
		                     (fun f0:set => forall i:set, i :e omega -> apply_fun f0 i :e apply_fun Ufun i)
		                     f Hfbb). }
		      apply (SepI (Power (product_space omega Xi0))
		                  (fun B:set =>
		                    exists U:set, total_function_on U omega (topology_family_union omega Xi0) /\ functional_graph U /\
		                      (forall i:set, i :e omega -> apply_fun U i :e space_family_topology Xi0 i) /\
		                      B = {f :e product_space omega Xi0 | forall i:set, i :e omega -> apply_fun f i :e apply_fun U i})
		                  bb HbbPow).
		      witness Ufun.
			      (** prove ((A /\ B) /\ C) /\ D with left-assoc /\ **)
			      apply andI.
			      - apply andI.
			        + apply andI.
			          * (** total_function_on **)
			             prove total_function_on Ufun omega (topology_family_union omega Xi0).
			             apply (total_function_on_graph omega (topology_family_union omega Xi0)
			                     (fun i:set => open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                                 (add_SNo (apply_fun x i) eps))).
			             let i. assume HiO: i :e omega.
			             prove open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                 (add_SNo (apply_fun x i) eps)
			                   :e topology_family_union omega Xi0.
			             claim HXiTop: space_family_topology Xi0 i = R_standard_topology.
			             { claim Hdef0: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
			               { reflexivity. }
			               rewrite Hdef0.
			               rewrite (const_space_family_apply omega R R_standard_topology i HiO).
			               exact (tuple_2_1_eq R R_standard_topology). }
			             claim HxiR: apply_fun x i :e R.
			             { claim HxRomega: x :e R_omega_space.
			               { rewrite <- real_sequences_eq_Romega_space.
			                 exact HxX0. }
			               exact (Romega_coord_in_R x i HxRomega HiO). }
			             claim HmepsR: minus_SNo eps :e R.
			             { exact (real_minus_SNo eps HepsR). }
			             claim HaR: add_SNo (apply_fun x i) (minus_SNo eps) :e R.
			             { exact (real_add_SNo (apply_fun x i) HxiR (minus_SNo eps) HmepsR). }
			             claim HbR: add_SNo (apply_fun x i) eps :e R.
			             { exact (real_add_SNo (apply_fun x i) HxiR eps HepsR). }
			             claim HintervalTop: open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                                (add_SNo (apply_fun x i) eps)
			                     :e space_family_topology Xi0 i.
			             { rewrite HXiTop.
			               exact (open_interval_in_R_standard_topology_endpoints
			                      (add_SNo (apply_fun x i) (minus_SNo eps))
			                      (add_SNo (apply_fun x i) eps)
			                      HaR HbR). }
			             claim HTiFam: space_family_topology Xi0 i :e {space_family_topology Xi0 j|j :e omega}.
			             { exact (ReplI omega (fun j:set => space_family_topology Xi0 j) i HiO). }
			             claim HtuDef: topology_family_union omega Xi0 = Union {space_family_topology Xi0 j|j :e omega}.
			             { reflexivity. }
			             rewrite HtuDef.
			             exact (UnionI {space_family_topology Xi0 j|j :e omega}
			                           (open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                          (add_SNo (apply_fun x i) eps))
			                           (space_family_topology Xi0 i)
			                           HintervalTop
			                           HTiFam).
			          * (** functional_graph **)
			             exact (functional_graph_graph omega (fun i:set => open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                                                    (add_SNo (apply_fun x i) eps))).
			          + (** forall i, apply_fun Ufun i in space_family_topology **)
			            let i. assume HiO: i :e omega.
			            claim HappU: apply_fun Ufun i =
			              open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                            (add_SNo (apply_fun x i) eps).
		            { exact (apply_fun_graph omega
		                       (fun j:set => open_interval (add_SNo (apply_fun x j) (minus_SNo eps))
		                                                   (add_SNo (apply_fun x j) eps))
		                       i HiO). }
		            rewrite HappU.
		            claim HXiTop: space_family_topology Xi0 i = R_standard_topology.
		            { claim Hdef0: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
		              { reflexivity. }
		              rewrite Hdef0.
		              rewrite (const_space_family_apply omega R R_standard_topology i HiO).
		              exact (tuple_2_1_eq R R_standard_topology). }
		            rewrite HXiTop.
		            claim HxiR: apply_fun x i :e R.
		            { claim HxRomega: x :e R_omega_space.
		              { rewrite <- real_sequences_eq_Romega_space.
		                exact HxX0. }
		              exact (Romega_coord_in_R x i HxRomega HiO). }
		            claim HmepsR: minus_SNo eps :e R.
		            { exact (real_minus_SNo eps HepsR). }
		            claim HaR: add_SNo (apply_fun x i) (minus_SNo eps) :e R.
		            { exact (real_add_SNo (apply_fun x i) HxiR (minus_SNo eps) HmepsR). }
		            claim HbR: add_SNo (apply_fun x i) eps :e R.
		            { exact (real_add_SNo (apply_fun x i) HxiR eps HepsR). }
		            exact (open_interval_in_R_standard_topology_endpoints
		                    (add_SNo (apply_fun x i) (minus_SNo eps))
		                    (add_SNo (apply_fun x i) eps)
		                    HaR HbR).
			      - (** bb definition matches **)
			        reflexivity.
		      + (** x :e bb **)
		        prove x :e bb.
		        apply SepI.
		        * (** x in product_space omega Xi0 **)
		          prove x :e product_space omega Xi0.
		          claim HxRomega: x :e R_omega_space.
		          { rewrite <- real_sequences_eq_Romega_space.
		            exact HxX0. }
		          exact HxRomega.
		        * (** coord membership **)
		          let i. assume HiO: i :e omega.
		          prove apply_fun x i :e apply_fun Ufun i.
		          claim HappU: apply_fun Ufun i =
		            open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
		                          (add_SNo (apply_fun x i) eps).
		          { exact (apply_fun_graph omega
		                     (fun j:set => open_interval (add_SNo (apply_fun x j) (minus_SNo eps))
		                                                 (add_SNo (apply_fun x j) eps))
		                     i HiO). }
		          rewrite HappU.
		          (** x(i) is in its own interval of radius eps **)
		          claim HxiR: apply_fun x i :e R.
		          { claim HxRomega: x :e R_omega_space.
		            { rewrite <- real_sequences_eq_Romega_space.
		              exact HxX0. }
		            exact (Romega_coord_in_R x i HxRomega HiO). }
		          claim HxiS: SNo (apply_fun x i).
		          { exact (real_SNo (apply_fun x i) HxiR). }
		          claim HepsS: SNo eps.
		          { exact (real_SNo eps HepsR). }
		          claim HmepsS: SNo (minus_SNo eps).
		          { exact (SNo_minus_SNo eps HepsS). }
		          claim Hlt1: add_SNo (apply_fun x i) (minus_SNo eps) < apply_fun x i.
		          { rewrite <- (add_SNo_0R (apply_fun x i) HxiS) at 2.
		            claim HepsPosS: 0 < eps.
		            { exact (RltE_lt 0 eps Hepspos). }
		            claim HepsNegS: minus_SNo eps < 0.
		            { claim Htmp: minus_SNo eps < minus_SNo 0.
		              { exact (minus_SNo_Lt_contra 0 eps SNo_0 HepsS HepsPosS). }
		              claim Htmp2: minus_SNo eps < 0.
		              { rewrite <- minus_SNo_0.
		                exact Htmp. }
		              exact Htmp2. }
		            exact (add_SNo_Lt2 (apply_fun x i) (minus_SNo eps) 0 HxiS HmepsS SNo_0 HepsNegS). }
		          claim Hlt2: apply_fun x i < add_SNo (apply_fun x i) eps.
		          { rewrite <- (add_SNo_0R (apply_fun x i) HxiS) at 1.
		            exact (add_SNo_Lt2 (apply_fun x i) 0 eps HxiS SNo_0 HepsS (RltE_lt 0 eps Hepspos)). }
		          claim Hlt1R: Rlt (add_SNo (apply_fun x i) (minus_SNo eps)) (apply_fun x i).
		          { exact (RltI (add_SNo (apply_fun x i) (minus_SNo eps)) (apply_fun x i)
		                       (real_add_SNo (apply_fun x i) HxiR (minus_SNo eps) (real_minus_SNo eps HepsR))
		                       HxiR Hlt1). }
			          claim Hlt2R: Rlt (apply_fun x i) (add_SNo (apply_fun x i) eps).
			          { exact (RltI (apply_fun x i) (add_SNo (apply_fun x i) eps)
			                       HxiR
			                       (real_add_SNo (apply_fun x i) HxiR eps HepsR)
			                       Hlt2). }
			          claim HinterDef: open_interval (add_SNo (apply_fun x i) (minus_SNo eps))
			                                  (add_SNo (apply_fun x i) eps)
			            = {x0 :e R|Rlt (add_SNo (apply_fun x i) (minus_SNo eps)) x0 /\
			                       Rlt x0 (add_SNo (apply_fun x i) eps)}.
			          { reflexivity. }
			          rewrite HinterDef.
			          apply SepI.
			          - exact HxiR.
			          - exact (andI (Rlt (add_SNo (apply_fun x i) (minus_SNo eps)) (apply_fun x i))
			                        (Rlt (apply_fun x i) (add_SNo (apply_fun x i) eps))
			                        Hlt1R
			                        Hlt2R).
		    - (** bb subset ball around c **)
		      prove bb c= open_ball X0 d c r.
		        claim HballSub: open_ball X0 d x s c= open_ball X0 d c r.
		        { exact HsSub. }
		        apply (Subq_tra bb (open_ball X0 d x s) (open_ball X0 d c r)).
		        * (** bb subset open_ball x s **)
		          prove bb c= open_ball X0 d x s.
		          let f. assume Hfbb: f :e bb.
		          claim HfProd: f :e product_space omega Xi0.
		          { exact (SepE1 (product_space omega Xi0)
		                   (fun f0:set => forall i:set, i :e omega -> apply_fun f0 i :e apply_fun Ufun i)
		                   f Hfbb). }
		          claim HfX0: f :e X0.
		          { prove f :e real_sequences.
		            rewrite real_sequences_eq_Romega_space.
		            exact HfProd. }
		          prove f :e open_ball X0 d x s.
		          claim HxfProd: (x,f) :e setprod X0 X0.
		          { exact (tuple_2_setprod_by_pair_Sigma X0 X0 x f HxX0 HfX0). }
		          claim HdfEq: apply_fun d (x,f) = Romega_uniform_metric_value x f.
		          { rewrite (apply_fun_graph (setprod real_sequences real_sequences)
		                                     (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
		                                     (x,f)
		                                     HxfProd).
		            rewrite (tuple_2_0_eq x f).
		            rewrite (tuple_2_1_eq x f).
		            reflexivity. }
		          apply (open_ballI X0 d x s f HfX0).
		          rewrite HdfEq.
		          claim Hle: Rle (Romega_uniform_metric_value x f) eps.
		          { set A := Romega_clipped_diffs x f.
		            set l := Romega_uniform_metric_value x f.
		            claim Hlub: R_lub A l.
		            { exact (Romega_uniform_metric_value_is_lub x f HxX0 HfX0). }
		            claim Hmin: forall u:set, u :e R ->
		              (forall a:set, a :e A -> a :e R -> Rle a u) ->
		              Rle l u.
		            { exact (andER (l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l))
		                           (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
		                           Hlub). }
		            claim Hub: forall a:set, a :e A -> a :e R -> Rle a eps.
		            { let a. assume HaA: a :e A. assume HaR: a :e R.
		              apply (ReplE omega (fun n:set => Romega_coord_clipped_diff x f n) a HaA).
		              let n. assume HnAnd.
		              apply HnAnd.
		              assume HnO: n :e omega.
		              assume HaEq: a = Romega_coord_clipped_diff x f n.
		              rewrite HaEq.
		              claim HfCoord: apply_fun f n :e apply_fun Ufun n.
		              { exact ((SepE2 (product_space omega Xi0)
		                       (fun f0:set => forall i:set, i :e omega -> apply_fun f0 i :e apply_fun Ufun i)
		                       f Hfbb) n HnO). }
		              claim HappU: apply_fun Ufun n =
		                open_interval (add_SNo (apply_fun x n) (minus_SNo eps))
		                              (add_SNo (apply_fun x n) eps).
		              { exact (apply_fun_graph omega
		                         (fun j:set => open_interval (add_SNo (apply_fun x j) (minus_SNo eps))
		                                                     (add_SNo (apply_fun x j) eps))
		                         n HnO). }
		              claim HfnIn: apply_fun f n :e open_interval (add_SNo (apply_fun x n) (minus_SNo eps))
		                                                      (add_SNo (apply_fun x n) eps).
		              { rewrite <- HappU.
		                exact HfCoord. }
		              claim HfnR: apply_fun f n :e R.
		              { claim HfRomega: f :e R_omega_space.
		                { exact HfProd. }
		                exact (Romega_coord_in_R f n HfRomega HnO). }
		              claim HxnR: apply_fun x n :e R.
		              { claim HxRomega: x :e R_omega_space.
		                { rewrite <- real_sequences_eq_Romega_space.
		                  exact HxX0. }
		                exact (Romega_coord_in_R x n HxRomega HnO). }
		              claim HfiS: SNo (apply_fun f n).
		              { exact (real_SNo (apply_fun f n) HfnR). }
		              claim HxiS: SNo (apply_fun x n).
		              { exact (real_SNo (apply_fun x n) HxnR). }
		              claim HepsS: SNo eps.
		              { exact (real_SNo eps HepsR). }
		              claim HmepsS: SNo (minus_SNo eps).
		              { exact (SNo_minus_SNo eps HepsS). }
		              claim HloHi: Rlt (add_SNo (apply_fun x n) (minus_SNo eps)) (apply_fun f n) /\
		                           Rlt (apply_fun f n) (add_SNo (apply_fun x n) eps).
		              { exact (SepE2 R
		                       (fun x0:set => Rlt (add_SNo (apply_fun x n) (minus_SNo eps)) x0 /\
		                                    Rlt x0 (add_SNo (apply_fun x n) eps))
		                       (apply_fun f n)
		                       HfnIn). }
		              claim HloR: Rlt (add_SNo (apply_fun x n) (minus_SNo eps)) (apply_fun f n).
		              { exact (andEL (Rlt (add_SNo (apply_fun x n) (minus_SNo eps)) (apply_fun f n))
		                             (Rlt (apply_fun f n) (add_SNo (apply_fun x n) eps))
		                             HloHi). }
		              claim HhiR: Rlt (apply_fun f n) (add_SNo (apply_fun x n) eps).
		              { exact (andER (Rlt (add_SNo (apply_fun x n) (minus_SNo eps)) (apply_fun f n))
		                             (Rlt (apply_fun f n) (add_SNo (apply_fun x n) eps))
		                             HloHi). }
		              claim Hlo: add_SNo (apply_fun x n) (minus_SNo eps) < apply_fun f n.
		              { exact (RltE_lt (add_SNo (apply_fun x n) (minus_SNo eps)) (apply_fun f n) HloR). }
		              claim Hhi: apply_fun f n < add_SNo (apply_fun x n) eps.
		              { exact (RltE_lt (apply_fun f n) (add_SNo (apply_fun x n) eps) HhiR). }
		              set t := add_SNo (apply_fun x n) (minus_SNo (apply_fun f n)).
		              claim HtR: t :e R.
		              { exact (real_add_SNo (apply_fun x n) HxnR (minus_SNo (apply_fun f n))
		                      (real_minus_SNo (apply_fun f n) HfnR)). }
		              claim HtS: SNo t.
		              { exact (real_SNo t HtR). }
		              claim Htlt: t < eps.
		              { claim Hxlt2: apply_fun x n < add_SNo (apply_fun f n) eps.
		                { exact (add_SNo_minus_Lt1 (apply_fun x n) eps (apply_fun f n) HxiS HepsS HfiS Hlo). }
		                claim Hxlt3: apply_fun x n < add_SNo eps (apply_fun f n).
		                { rewrite (add_SNo_com eps (apply_fun f n) HepsS HfiS) at 1.
		                  exact Hxlt2. }
		                exact (add_SNo_minus_Lt1b (apply_fun x n) (apply_fun f n) eps HxiS HfiS HepsS Hxlt3). }
		              claim Htgt: minus_SNo eps < t.
			              {
		                claim Hflt2: add_SNo (apply_fun f n) (minus_SNo eps) < apply_fun x n.
		                { exact (add_SNo_minus_Lt1b (apply_fun f n) eps (apply_fun x n) HfiS HepsS HxiS Hhi). }
		                claim Hflt3: add_SNo (minus_SNo eps) (apply_fun f n) < apply_fun x n.
		                { rewrite (add_SNo_com (minus_SNo eps) (apply_fun f n) HmepsS HfiS) at 1.
		                  exact Hflt2. }
		                exact (add_SNo_minus_Lt2b (apply_fun x n) (apply_fun f n) (minus_SNo eps)
		                        HxiS HfiS HmepsS Hflt3). }
		              claim HtLe: t <= eps.
		              { exact (SNoLtLe t eps Htlt). }
		              claim HmEpsLe: minus_SNo eps <= t.
		              { exact (SNoLtLe (minus_SNo eps) t Htgt). }
		              claim HabLe: abs_SNo t <= eps.
		              { exact (abs_SNo_Le_of_bounds t eps HtS HepsS HmEpsLe HtLe). }
		              claim HabsR: abs_SNo t :e R.
		              { apply (xm (0 <= t)).
		                - assume H0le: 0 <= t.
		                  rewrite (nonneg_abs_SNo t H0le).
		                  exact HtR.
		                - assume Hn0le: ~(0 <= t).
		                  claim HmtR: minus_SNo t :e R.
		                  { exact (real_minus_SNo t HtR). }
		                  rewrite (not_nonneg_abs_SNo t Hn0le).
		                  exact HmtR. }
		              claim HabsLeR: Rle (abs_SNo t) eps.
		              { exact (Rle_of_SNoLe (abs_SNo t) eps HabsR HepsR HabLe). }
		              claim HabsLt1: Rlt (abs_SNo t) 1.
		              { exact (Rle_Rlt_tra_Euclid (abs_SNo t) eps 1 HabsLeR Hepslt1). }
		              claim HcdDef: Romega_coord_clipped_diff x f n =
		                If_i (Rlt (Romega_coord_abs_diff x f n) 1) (Romega_coord_abs_diff x f n) 1.
		              { reflexivity. }
		              claim HabsDef2: Romega_coord_abs_diff x f n = abs_SNo t.
		              { reflexivity. }
		              rewrite HcdDef.
		              rewrite HabsDef2.
		              rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 HabsLt1).
		              exact HabsLeR. }
		            exact (Hmin eps HepsR Hub). }
		          exact (Rle_Rlt_tra_Euclid (Romega_uniform_metric_value x f) eps s Hle HepsltS).
		        * exact (HballSub).
		  }
		  let U. assume HU: U :e uniform_topology.
		  prove U :e Romega_box_topology_on_real_sequences.
	  claim HUdef: uniform_topology = generated_topology X0 Bballs.
	  { reflexivity. }
	  claim HUgen: U :e generated_topology X0 Bballs.
	  { rewrite <- HUdef.
	    exact HU. }
	  claim HUpow: U :e Power X0.
	  { exact (SepE1 (Power X0)
	           (fun U0 : set => forall x0 :e U0, exists b :e Bballs, x0 :e b /\ b c= U0)
	           U HUgen). }
	  claim HUprop: forall x0 :e U, exists b :e Bballs, x0 :e b /\ b c= U.
	  { exact (SepE2 (Power X0)
	           (fun U0 : set => forall x0 :e U0, exists b :e Bballs, x0 :e b /\ b c= U0)
	           U HUgen). }
	  claim HUsub: U c= X0.
	  { exact (PowerE X0 U HUpow). }
		  (** It suffices to show U is a box-open set in the whole-space box topology, since real_sequences = R^omega. **)
		  claim HBoxPow: U :e Power (product_space omega Xi0).
		  { claim HXeq: R_omega_space = product_space omega Xi0.
		    { reflexivity. }
		    rewrite <- HXeq.
		    rewrite <- real_sequences_eq_Romega_space.
		    exact HUpow. }
	  claim HBoxProp: forall x0 :e U, exists b0 :e BoxB, x0 :e b0 /\ b0 c= U.
	  { let x0. assume Hx0U: x0 :e U.
	    apply (HUprop x0 Hx0U).
	    let b. assume Hbpair.
	    claim HbB: b :e Bballs.
	    { exact (andEL (b :e Bballs) (x0 :e b /\ b c= U) Hbpair). }
	    claim Hbprop: x0 :e b /\ b c= U.
	    { exact (andER (b :e Bballs) (x0 :e b /\ b c= U) Hbpair). }
	    claim Hx0b: x0 :e b.
	    { exact (andEL (x0 :e b) (b c= U) Hbprop). }
	    claim HbsubU: b c= U.
	    { exact (andER (x0 :e b) (b c= U) Hbprop). }
	    (** destruct b as an open ball around some center c with radius r>0 **)
	    apply (famunionE_impred X0 (fun c:set => {open_ball X0 d c rr|rr :e R, Rlt 0 rr}) b HbB
	            (exists b0 :e BoxB, x0 :e b0 /\ b0 c= U)).
	    let c. assume HcX0: c :e X0.
	    assume Hbin: b :e {open_ball X0 d c rr|rr :e R, Rlt 0 rr}.
	    apply (ReplSepE_impred R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball X0 d c rr)
	            b Hbin
	            (exists b0 :e BoxB, x0 :e b0 /\ b0 c= U)).
	    let r. assume HrR: r :e R.
	    assume Hrpos: Rlt 0 r.
		    assume Hbeq: b = open_ball X0 d c r.
		    claim Hx0inball: x0 :e open_ball X0 d c r.
		    { rewrite <- Hbeq.
		      exact Hx0b. }
		    apply (HBoxRefine c x0 r HcX0 (HUsub x0 Hx0U) HrR Hrpos Hx0inball).
		    let bb. assume Hbbpack.
		    claim Hbbpair1: bb :e BoxB /\ x0 :e bb.
		    { exact (andEL (bb :e BoxB /\ x0 :e bb) (bb c= open_ball X0 d c r) Hbbpack). }
		    claim HbbB: bb :e BoxB.
		    { exact (andEL (bb :e BoxB) (x0 :e bb) Hbbpair1). }
		    claim Hx0bb: x0 :e bb.
		    { exact (andER (bb :e BoxB) (x0 :e bb) Hbbpair1). }
		    claim HbbsubBall: bb c= open_ball X0 d c r.
		    { exact (andER (bb :e BoxB /\ x0 :e bb) (bb c= open_ball X0 d c r) Hbbpack). }
	    claim HballsubU: open_ball X0 d c r c= U.
	    { rewrite <- Hbeq.
	      exact HbsubU. }
	    claim HbbsubU: bb c= U.
	    { exact (Subq_tra bb (open_ball X0 d c r) U HbbsubBall HballsubU). }
	    witness bb.
	    apply andI.
	    - exact HbbB.
	    - apply andI.
	      + exact Hx0bb.
	      + exact HbbsubU. }
		  (** show U is open in the box topology on the whole product space **)
		  claim HUinBoxT: U :e BoxT.
		  { claim HBoxDef: BoxT =
		      generated_topology (product_space omega Xi0) BoxB.
		    { reflexivity. }
		    rewrite HBoxDef.
		    claim HgenDef: generated_topology (product_space omega Xi0) BoxB =
		      {U0 :e Power (product_space omega Xi0) |
		        forall x0 :e U0, exists b0 :e BoxB, x0 :e b0 /\ b0 c= U0}.
		    { reflexivity. }
		    rewrite HgenDef.
		    apply SepI.
		    - exact HBoxPow.
		    - exact HBoxProp. }
		  (** conclude U is open in the subspace topology on real_sequences (whole space) **)
			  prove U :e subspace_topology R_omega_space BoxT real_sequences.
			  claim HsubDef: subspace_topology R_omega_space BoxT real_sequences =
			    {U0 :e Power real_sequences | exists V :e BoxT, U0 = V :/\: real_sequences}.
			  { reflexivity. }
			  rewrite HsubDef.
			  claim Hexists: exists V :e BoxT, U = V :/\: real_sequences.
			  { witness U.
			    apply andI.
			    - exact HUinBoxT.
			    - claim HIntEq: U :/\: real_sequences = U.
			      { exact (binintersect_Subq_eq_1 U real_sequences HUsub). }
			      rewrite HIntEq.
			      reflexivity. }
			  exact (SepI (Power real_sequences)
			              (fun U0:set => exists V :e BoxT, U0 = V :/\: real_sequences)
			              U
			              HUpow
			              Hexists).
	Qed.

(** from §20 Theorem 20.5: product topology on R^omega is induced by a metric **)
(** LATEX VERSION: Define D(x,y)=sup{ min(|x_i-y_i|,1) / i }. Then D induces the product topology on R^omega. **)
Definition R_bounded_distance : set -> set -> set := fun a b =>
  If_i (Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1)
       (abs_SNo (add_SNo a (minus_SNo b)))
       1.

(** helper: bounded metric on R as a graph **)
Definition R_bounded_metric : set :=
  graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).

(** helper: compute apply_fun of bounded metric graph (early helper for later sections) **)
Theorem R_bounded_metric_apply_early : forall x y:set,
  x :e R -> y :e R ->
  apply_fun R_bounded_metric (x,y) = R_bounded_distance x y.
let x y.
assume Hx: x :e R.
assume Hy: y :e R.
claim Hxy: (x,y) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)) (x,y) Hxy).
rewrite (tuple_2_0_eq x y).
rewrite (tuple_2_1_eq x y).
reflexivity.
Qed.

(** helper: bounded distance is symmetric **)
Theorem R_bounded_distance_sym : forall a b:set,
  a :e R -> b :e R -> R_bounded_distance a b = R_bounded_distance b a.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim Habs: abs_SNo (add_SNo a (minus_SNo b)) = abs_SNo (add_SNo b (minus_SNo a)).
{ exact (abs_SNo_dist_swap a b HaS HbS). }
claim Hab: R_bounded_distance a b =
  If_i (Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1)
       (abs_SNo (add_SNo a (minus_SNo b)))
       1.
{ reflexivity. }
claim Hba: R_bounded_distance b a =
  If_i (Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1)
       (abs_SNo (add_SNo b (minus_SNo a)))
       1.
{ reflexivity. }
rewrite Hab.
rewrite Hba.
apply (xm (Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1)).
- assume Hlt: Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1.
  claim Hlt2: Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1.
  { prove Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1.
    rewrite <- Habs.
    exact Hlt. }
  rewrite (If_i_1 (Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1)
                  (abs_SNo (add_SNo a (minus_SNo b)))
                  1
                  Hlt).
  rewrite (If_i_1 (Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1)
                  (abs_SNo (add_SNo b (minus_SNo a)))
                  1
                  Hlt2).
  rewrite <- Habs.
  reflexivity.
- assume Hnlt: ~(Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1).
  claim Hnlt2: ~(Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1).
  { assume Hlt2: Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1.
    claim Hlt1: Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1.
    { prove Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1.
      rewrite Habs.
      exact Hlt2. }
    exact (Hnlt Hlt1). }
  rewrite (If_i_0 (Rlt (abs_SNo (add_SNo a (minus_SNo b))) 1)
                  (abs_SNo (add_SNo a (minus_SNo b)))
                  1
                  Hnlt).
  rewrite (If_i_0 (Rlt (abs_SNo (add_SNo b (minus_SNo a))) 1)
                  (abs_SNo (add_SNo b (minus_SNo a)))
                  1
                  Hnlt2).
  reflexivity.
Qed.

(** helper: bounded distance of a point to itself is 0 **)
Theorem R_bounded_distance_self_zero : forall a:set,
  a :e R -> R_bounded_distance a a = 0.
let a.
assume HaR: a :e R.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
set t := add_SNo a (minus_SNo a).
claim Ht0: t = 0.
{ exact (add_SNo_minus_SNo_rinv a HaS). }
claim H0le0: 0 <= 0.
{ exact (SNoLe_ref 0). }
claim Habseq: abs_SNo 0 = 0.
{ exact (nonneg_abs_SNo 0 H0le0). }
claim Habs0: abs_SNo t = 0.
{ rewrite Ht0.
  exact Habseq. }
claim Hdef: R_bounded_distance a a =
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
rewrite Hdef.
rewrite Habs0.
rewrite (If_i_1 (Rlt 0 1) 0 1 Rlt_0_1).
reflexivity.
Qed.

(** helper: bounded distance is nonnegative **)
Theorem R_bounded_distance_nonneg : forall a b:set,
  a :e R -> b :e R -> 0 <= R_bounded_distance a b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
claim HbM: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
set t := add_SNo a (minus_SNo b).
claim HtR: t :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HbM). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HabsNN: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim Hdef: R_bounded_distance a b =
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
rewrite Hdef.
apply (xm (Rlt (abs_SNo t) 1)
          (0 <= If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1)).
- assume Hlt: Rlt (abs_SNo t) 1.
  rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hlt).
  exact HabsNN.
- assume Hnlt: ~(Rlt (abs_SNo t) 1).
  rewrite (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnlt).
  exact (SNoLtLe 0 1 SNoLt_0_1).
Qed.

(** helper: a positive surreal is not zero **)
Theorem SNo_pos_ne0 : forall x:set,
  SNo x -> 0 < x -> x <> 0.
let x.
assume HxS: SNo x.
assume Hpos: 0 < x.
assume Heq: x = 0.
claim H00: 0 < 0.
{ rewrite <- Heq at 2.
  exact Hpos. }
exact ((SNoLt_irref 0) H00).
Qed.

(** helper: absolute value equals zero implies the input is zero **)
Theorem abs_SNo_eq0 : forall x:set,
  SNo x -> abs_SNo x = 0 -> x = 0.
let x.
assume HxS: SNo x.
assume Habs0: abs_SNo x = 0.
apply (xm (0 <= x) (x = 0)).
- assume H0le: 0 <= x.
  rewrite <- (nonneg_abs_SNo x H0le).
  exact Habs0.
- assume Hn0le: ~(0 <= x).
  claim Hm0: minus_SNo x = 0.
  { rewrite <- (not_nonneg_abs_SNo x Hn0le).
    exact Habs0. }
  claim Hsum: add_SNo (minus_SNo x) x = 0.
  { exact (add_SNo_minus_SNo_linv x HxS). }
  claim H0x0: add_SNo 0 x = 0.
  { rewrite <- Hm0 at 1.
    exact Hsum. }
  rewrite <- (add_SNo_0L x HxS).
  exact H0x0.
Qed.

(** helper: bounded distance equals zero implies equality **)
Theorem R_bounded_distance_eq0 : forall a b:set,
  a :e R -> b :e R -> R_bounded_distance a b = 0 -> a = b.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
assume Hbd0: R_bounded_distance a b = 0.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
set t := add_SNo a (minus_SNo b).
claim HtR: t :e R.
{ claim HmbR: minus_SNo b :e R.
  { exact (real_minus_SNo b HbR). }
  exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim Hdef: R_bounded_distance a b =
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
claim Hif0: If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1 = 0.
{ rewrite <- Hdef.
  exact Hbd0. }
apply (xm (Rlt (abs_SNo t) 1) (a = b)).
- assume Hlt: Rlt (abs_SNo t) 1.
  claim Ht0: t = 0.
  { claim Habs0: abs_SNo t = 0.
    { rewrite <- (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hlt).
      exact Hif0. }
    exact (abs_SNo_eq0 t HtS Habs0). }
  claim Ht0': add_SNo a (minus_SNo b) = 0.
  { exact Ht0. }
  claim Hstep: add_SNo (add_SNo a (minus_SNo b)) b = b.
  { rewrite Ht0' at 1.
    rewrite (add_SNo_0L b HbS).
    reflexivity. }
  rewrite <- (add_SNo_0R a HaS) at 1.
  rewrite <- (add_SNo_minus_SNo_linv b HbS) at 1.
  rewrite (add_SNo_assoc a (minus_SNo b) b
                         HaS (SNo_minus_SNo b HbS) HbS) at 1.
  exact Hstep.
- assume Hnlt: ~(Rlt (abs_SNo t) 1).
  claim H10eq: 1 = 0.
  { rewrite <- (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnlt).
    exact Hif0. }
  claim H10: 1 <> 0.
  { exact neq_1_0. }
  exact (FalseE (H10 H10eq) (a = b)).
Qed.

(** helper: bounded distance is always <= 1 **)
Theorem R_bounded_distance_le_1 : forall a b:set,
  a :e R -> b :e R -> Rle (R_bounded_distance a b) 1.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
set t := add_SNo a (minus_SNo b).
claim HmbR: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
claim HtR: t :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HabsR: abs_SNo t :e R.
{ apply (xm (0 <= t)).
  - assume H0le: 0 <= t.
    claim Habseq: abs_SNo t = t.
    { exact (nonneg_abs_SNo t H0le). }
    rewrite Habseq.
    exact HtR.
  - assume Hn0le: ~(0 <= t).
    claim HmtR: minus_SNo t :e R.
    { exact (real_minus_SNo t HtR). }
    claim Habseq: abs_SNo t = minus_SNo t.
    { exact (not_nonneg_abs_SNo t Hn0le). }
    rewrite Habseq.
    exact HmtR. }
claim HdistR: R_bounded_distance a b :e R.
{ claim Hdef: R_bounded_distance a b =
    If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
  { reflexivity. }
  apply (xm (Rlt (abs_SNo t) 1)).
  - assume Hlt: Rlt (abs_SNo t) 1.
    rewrite Hdef.
    rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hlt).
    exact HabsR.
  - assume Hnlt: ~(Rlt (abs_SNo t) 1).
    rewrite Hdef.
    rewrite (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnlt).
    exact real_1. }
apply (RleI (R_bounded_distance a b) 1 HdistR real_1).
prove ~(Rlt 1 (R_bounded_distance a b)).
claim Hdef: R_bounded_distance a b =
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
apply (xm (Rlt (abs_SNo t) 1)).
- assume Hlt: Rlt (abs_SNo t) 1.
  rewrite Hdef.
  rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hlt).
  exact (not_Rlt_sym (abs_SNo t) 1 Hlt).
- assume Hnlt: ~(Rlt (abs_SNo t) 1).
  rewrite Hdef.
  rewrite (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnlt).
  exact (not_Rlt_refl 1 real_1).
Qed.

(** helper: abs of a real is real **)
Theorem abs_SNo_in_R : forall x:set, x :e R -> abs_SNo x :e R.
let x.
assume HxR: x :e R.
apply (xm (0 <= x)).
- assume H0le: 0 <= x.
  claim Habseq: abs_SNo x = x.
  { exact (nonneg_abs_SNo x H0le). }
  rewrite Habseq.
  exact HxR.
- assume Hn0le: ~(0 <= x).
  claim HmxR: minus_SNo x :e R.
  { exact (real_minus_SNo x HxR). }
  claim Habseq: abs_SNo x = minus_SNo x.
  { exact (not_nonneg_abs_SNo x Hn0le). }
  rewrite Habseq.
  exact HmxR.
Qed.

(** helper: bounded distance is a real number **)
Theorem R_bounded_distance_in_R : forall a b:set,
  a :e R -> b :e R -> R_bounded_distance a b :e R.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
set t := add_SNo a (minus_SNo b).
claim HmbR: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
claim HtR: t :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim Hor:
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1 = abs_SNo t \/
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1 = 1.
{ exact (If_i_or (Rlt (abs_SNo t) 1) (abs_SNo t) 1). }
claim Hdef: R_bounded_distance a b =
  If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
rewrite Hdef.
apply Hor.
- assume Heq: If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1 = abs_SNo t.
  rewrite Heq.
  exact HabsR.
- assume Heq: If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1 = 1.
  rewrite Heq.
  exact real_1.
Qed.

(** helper: bounded distance satisfies triangle inequality (SNoLe form) **)
Theorem R_bounded_distance_triangle_Le : forall a b c:set,
  a :e R -> b :e R -> c :e R ->
  R_bounded_distance a c <= add_SNo (R_bounded_distance a b) (R_bounded_distance b c).
let a b c.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
set tab := add_SNo a (minus_SNo b).
set tbc := add_SNo b (minus_SNo c).
set tac := add_SNo a (minus_SNo c).
claim HmbR: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
claim HmcR: minus_SNo c :e R.
{ exact (real_minus_SNo c HcR). }
claim HtabR: tab :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HtbcR: tbc :e R.
{ exact (real_add_SNo b HbR (minus_SNo c) HmcR). }
claim HtacR: tac :e R.
{ exact (real_add_SNo a HaR (minus_SNo c) HmcR). }
claim HtabS: SNo tab.
{ exact (real_SNo tab HtabR). }
claim HtbcS: SNo tbc.
{ exact (real_SNo tbc HtbcR). }
claim HtacS: SNo tac.
{ exact (real_SNo tac HtacR). }
set pab := abs_SNo tab.
set pbc := abs_SNo tbc.
set pac := abs_SNo tac.
claim HpabR: pab :e R.
{ exact (abs_SNo_in_R tab HtabR). }
claim HpbcR: pbc :e R.
{ exact (abs_SNo_in_R tbc HtbcR). }
claim HpacR: pac :e R.
{ exact (abs_SNo_in_R tac HtacR). }
claim HpabS: SNo pab.
{ exact (real_SNo pab HpabR). }
claim HpbcS: SNo pbc.
{ exact (real_SNo pbc HpbcR). }
claim HpacS: SNo pac.
{ exact (real_SNo pac HpacR). }
claim HpabNN: 0 <= pab.
{ exact (abs_SNo_nonneg tab HtabS). }
claim HpbcNN: 0 <= pbc.
{ exact (abs_SNo_nonneg tbc HtbcS). }
claim HabsTri: pac <= add_SNo pab pbc.
{ exact (abs_SNo_triangle a b c HaS HbS HcS). }
claim Hmono: If_i (Rlt pac 1) pac 1 <= If_i (Rlt (add_SNo pab pbc) 1) (add_SNo pab pbc) 1.
{ exact (Rclip_mono pac (add_SNo pab pbc) HpacR (real_add_SNo pab HpabR pbc HpbcR) HabsTri). }
claim Hsub: If_i (Rlt (add_SNo pab pbc) 1) (add_SNo pab pbc) 1
             <= add_SNo (If_i (Rlt pab 1) pab 1) (If_i (Rlt pbc 1) pbc 1).
{ exact (Rclip_subadd_nonneg pab pbc HpabR HpbcR HpabNN HpbcNN). }
claim HdefAC: R_bounded_distance a c = If_i (Rlt pac 1) pac 1.
{ reflexivity. }
claim HdefAB: R_bounded_distance a b = If_i (Rlt pab 1) pab 1.
{ reflexivity. }
claim HdefBC: R_bounded_distance b c = If_i (Rlt pbc 1) pbc 1.
{ reflexivity. }
rewrite HdefAC.
rewrite HdefAB.
rewrite HdefBC.
exact (SNoLe_tra (If_i (Rlt pac 1) pac 1)
                 (If_i (Rlt (add_SNo pab pbc) 1) (add_SNo pab pbc) 1)
                 (add_SNo (If_i (Rlt pab 1) pab 1) (If_i (Rlt pbc 1) pbc 1))
                 (SNo_If_i (Rlt pac 1) pac 1 HpacS SNo_1)
                 (SNo_If_i (Rlt (add_SNo pab pbc) 1) (add_SNo pab pbc) 1 (SNo_add_SNo pab pbc HpabS HpbcS) SNo_1)
                 (SNo_add_SNo (If_i (Rlt pab 1) pab 1) (If_i (Rlt pbc 1) pbc 1)
                              (SNo_If_i (Rlt pab 1) pab 1 HpabS SNo_1)
                              (SNo_If_i (Rlt pbc 1) pbc 1 HpbcS SNo_1))
                 Hmono
                 Hsub).
Qed.

(** from §20 Theorem 20.5: the D metric on R^ω (scaled bounded coordinate differences) **)
(** LATEX VERSION: Define D(x,y)=sup{ d̄(x_i,y_i)/i }. **)
Definition Romega_D_scaled_diffs : set -> set -> set := fun x y =>
  Repl omega
       (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i))).

(** helper: scaled diffs are symmetric **)
Theorem Romega_D_scaled_diffs_sym : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  Romega_D_scaled_diffs x y = Romega_D_scaled_diffs y x.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
apply (ReplEq_ext omega
        (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
        (fun i:set => mul_SNo (R_bounded_distance (apply_fun y i) (apply_fun x i)) (inv_nat (ordsucc i)))).
let i.
assume HiO: i :e omega.
claim HxiR: apply_fun x i :e R.
{ exact (Romega_coord_in_R x i Hx HiO). }
claim HyiR: apply_fun y i :e R.
{ exact (Romega_coord_in_R y i Hy HiO). }
claim Hbd: R_bounded_distance (apply_fun x i) (apply_fun y i) =
           R_bounded_distance (apply_fun y i) (apply_fun x i).
{ exact (R_bounded_distance_sym (apply_fun x i) (apply_fun y i) HxiR HyiR). }
rewrite Hbd.
reflexivity.
Qed.

(** helper: diagonal scaled diffs are all 0 **)
Theorem Romega_D_scaled_diffs_diag_subset0 : forall x:set,
  x :e R_omega_space ->
  Romega_D_scaled_diffs x x c= {0}.
let x.
assume Hx: x :e R_omega_space.
let a.
assume Ha: a :e Romega_D_scaled_diffs x x.
prove a :e {0}.
apply (ReplE_impred omega
                    (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun x i)) (inv_nat (ordsucc i)))
                    a
                    Ha
                    (a :e {0})).
let i.
assume HiO: i :e omega.
assume Hai: a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun x i)) (inv_nat (ordsucc i)).
rewrite Hai.
claim HxiR: apply_fun x i :e R.
{ exact (Romega_coord_in_R x i Hx HiO). }
claim Hbd0: R_bounded_distance (apply_fun x i) (apply_fun x i) = 0.
{ exact (R_bounded_distance_self_zero (apply_fun x i) HxiR). }
rewrite Hbd0.
claim HSi: ordsucc i :e omega.
{ exact (omega_ordsucc i HiO). }
claim HinvR: inv_nat (ordsucc i) :e R.
{ exact (inv_nat_real (ordsucc i) HSi). }
claim HinvS: SNo (inv_nat (ordsucc i)).
{ exact (real_SNo (inv_nat (ordsucc i)) HinvR). }
rewrite (mul_SNo_zeroL (inv_nat (ordsucc i)) HinvS).
exact (SingI 0).
Qed.

(** helper: diagonal scaled diffs are exactly {0} **)
Theorem Romega_D_scaled_diffs_diag_eq_Sing0 : forall x:set,
  x :e R_omega_space ->
  Romega_D_scaled_diffs x x = {0}.
let x.
assume Hx: x :e R_omega_space.
apply set_ext.
- exact (Romega_D_scaled_diffs_diag_subset0 x Hx).
- let a.
  assume Ha0: a :e {0}.
  prove a :e Romega_D_scaled_diffs x x.
  claim HaEq: a = 0.
  { exact (SingE 0 a Ha0). }
  rewrite HaEq.
  prove 0 :e Romega_D_scaled_diffs x x.
  claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  claim HxiR: apply_fun x 0 :e R.
  { exact (Romega_coord_in_R x 0 Hx H0omega). }
  claim Hbd0: R_bounded_distance (apply_fun x 0) (apply_fun x 0) = 0.
  { exact (R_bounded_distance_self_zero (apply_fun x 0) HxiR). }
  claim H10: ordsucc 0 :e omega.
  { exact (omega_ordsucc 0 H0omega). }
  claim HinvR: inv_nat (ordsucc 0) :e R.
  { exact (inv_nat_real (ordsucc 0) H10). }
  claim HinvS: SNo (inv_nat (ordsucc 0)).
  { exact (real_SNo (inv_nat (ordsucc 0)) HinvR). }
  claim Hdef: 0 = mul_SNo (R_bounded_distance (apply_fun x 0) (apply_fun x 0)) (inv_nat (ordsucc 0)).
  { rewrite Hbd0.
    rewrite (mul_SNo_zeroL (inv_nat (ordsucc 0)) HinvS).
    reflexivity. }
  rewrite Hdef.
  exact (ReplI omega
               (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun x i)) (inv_nat (ordsucc i)))
               0
               H0omega).
Qed.

(** from §20 Theorem 20.5: D(x,y) is the supremum of the scaled bounded coordinate differences **)
(** LATEX VERSION: D(x,y)=sup{ d̄(x_i,y_i)/i }. **)
Definition Romega_D_metric_value : set -> set -> set := fun x y =>
  Eps_i (fun r:set => R_lub (Romega_D_scaled_diffs x y) r).

(** helper: reciprocal of a natural is <= 1 **)
Theorem inv_nat_Rle_1 : forall n:set, n :e omega :\: {0} -> Rle (inv_nat n) 1.
let n.
assume HnIn: n :e omega :\: {0}.
claim HnO: n :e omega.
{ exact (setminusE1 omega {0} n HnIn). }
claim Hnnot0: n /:e {0}.
{ exact (setminusE2 omega {0} n HnIn). }
claim Hnneq0: n <> 0.
{ assume Hn0: n = 0.
  claim Hnin0: n :e {0}.
  { rewrite Hn0. exact (SingI 0). }
  exact (Hnnot0 Hnin0). }
claim HinvR: inv_nat n :e R.
{ exact (inv_nat_real n HnO). }
apply (RleI (inv_nat n) 1 HinvR real_1).
prove ~(Rlt 1 (inv_nat n)).
assume Hlt: Rlt 1 (inv_nat n).
claim HltS: 1 < inv_nat n.
{ exact (RltE_lt 1 (inv_nat n) Hlt). }
claim HnS: SNo n.
{ exact (omega_SNo n HnO). }
claim HinvS: SNo (inv_nat n).
{ exact (SNo_recip_SNo n HnS). }
claim HnNat: nat_p n.
{ exact (omega_nat_p n HnO). }
claim HnOrd: ordinal n.
{ exact (nat_p_ordinal n HnNat). }
claim H1Ord: ordinal 1.
{ exact (nat_p_ordinal 1 nat_1). }
claim HnCase: n = 0 \/ exists k:set, nat_p k /\ n = ordsucc k.
{ exact (nat_inv n HnNat). }
claim Hexk: exists k:set, nat_p k /\ n = ordsucc k.
{ apply (HnCase (exists k:set, nat_p k /\ n = ordsucc k)).
  - assume Hn0: n = 0.
    apply FalseE.
    exact (Hnneq0 Hn0).
  - assume H. exact H. }
apply Hexk.
let k.
assume Hkconj.
claim HkNat: nat_p k.
{ exact (andEL (nat_p k) (n = ordsucc k) Hkconj). }
claim Hneq: n = ordsucc k.
{ exact (andER (nat_p k) (n = ordsucc k) Hkconj). }
claim HkOrd: ordinal k.
{ exact (nat_p_ordinal k HkNat). }
claim H0ltn: 0 < n.
{ rewrite Hneq.
  exact (ordinal_ordsucc_pos k HkOrd). }
claim HmulLt: mul_SNo n 1 < mul_SNo n (inv_nat n).
{ exact (pos_mul_SNo_Lt n 1 (inv_nat n) HnS H0ltn SNo_1 HinvS HltS). }
claim Hmul1: mul_SNo n 1 = n.
{ exact (mul_SNo_oneR n HnS). }
claim HmulInv: mul_SNo n (inv_nat n) = 1.
{ exact (recip_SNo_invR n HnS Hnneq0). }
claim Hnlt1: n < 1.
{ rewrite <- Hmul1.
  rewrite <- HmulInv at 2.
  exact HmulLt. }
claim HnIn1: n :e 1.
{ exact (ordinal_SNoLt_In n 1 HnOrd H1Ord Hnlt1). }
claim Hcase1: n :e 0 \/ n = 0.
{ exact (ordsuccE 0 n HnIn1). }
claim Hn0: n = 0.
{ apply (Hcase1 (n = 0)).
  - assume HnIn0: n :e 0.
    exact (EmptyE n HnIn0 (n = 0)).
  - assume H. exact H. }
exact (Hnneq0 Hn0).
Qed.

(** helper: scaled diffs are real numbers **)
Theorem Romega_D_scaled_diffs_in_R : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  forall a:set, a :e Romega_D_scaled_diffs x y -> a :e R.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
let a.
	assume Ha: a :e Romega_D_scaled_diffs x y.
	prove a :e R.
	apply (ReplE omega
	             (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
	             a
	             Ha).
	let i.
	assume Hiconj.
	claim HiO: i :e omega.
	{ exact (andEL (i :e omega)
	               (a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
	               Hiconj). }
	claim Hai: a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)).
	{ exact (andER (i :e omega)
	               (a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
	               Hiconj). }
	claim HxiR: apply_fun x i :e R.
	{ exact (Romega_coord_in_R x i Hx HiO). }
	claim HyiR: apply_fun y i :e R.
	{ exact (Romega_coord_in_R y i Hy HiO). }
	claim HbdR: R_bounded_distance (apply_fun x i) (apply_fun y i) :e R.
	{ exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun y i) HxiR HyiR). }
	claim HSi: ordsucc i :e omega.
	{ exact (omega_ordsucc i HiO). }
	claim HinvR: inv_nat (ordsucc i) :e R.
	{ exact (inv_nat_real (ordsucc i) HSi). }
	claim HmulR: mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)) :e R.
	{ exact (real_mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) HbdR
	                      (inv_nat (ordsucc i)) HinvR). }
	rewrite Hai.
	exact HmulR.
Qed.

(** helper: scaled diffs are bounded above in R **)
Theorem Romega_D_scaled_diffs_bounded : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  exists u:set, u :e R /\ forall a:set, a :e Romega_D_scaled_diffs x y -> a :e R -> Rle a u.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
witness 1.
apply andI.
- exact real_1.
- let a.
	  assume HaA: a :e Romega_D_scaled_diffs x y.
	  assume HaR: a :e R.
	  prove Rle a 1.
	  apply (ReplE_impred omega
	                      (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
	                      a
	                      HaA
	                      (Rle a 1)).
	  let i.
	  assume HiO: i :e omega.
	  assume Hai: a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)).
	  rewrite Hai.
	  set bd := R_bounded_distance (apply_fun x i) (apply_fun y i).
	  set inv := inv_nat (ordsucc i).
	  claim HSi: ordsucc i :e omega.
	  { exact (omega_ordsucc i HiO). }
	  claim HsuccNotIn0: ordsucc i /:e {0}.
	  { assume Hin0: ordsucc i :e {0}.
	    claim Heq: ordsucc i = 0.
	    { exact (SingE 0 (ordsucc i) Hin0). }
	    exact (neq_ordsucc_0 i Heq). }
	  claim HiIn: ordsucc i :e omega :\: {0}.
	  { exact (setminusI omega {0} (ordsucc i) HSi HsuccNotIn0). }
	  claim HxiR: apply_fun x i :e R.
	  { exact (Romega_coord_in_R x i Hx HiO). }
	  claim HyiR: apply_fun y i :e R.
	  { exact (Romega_coord_in_R y i Hy HiO). }
	  claim HbdR: bd :e R.
	  { exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun y i) HxiR HyiR). }
	  claim HinvR: inv :e R.
	  { exact (inv_nat_real (ordsucc i) HSi). }
	  claim HmulR: mul_SNo bd inv :e R.
	  { exact (real_mul_SNo bd HbdR inv HinvR). }
  apply (RleI (mul_SNo bd inv) 1 HmulR real_1).
  assume Hlt1: Rlt 1 (mul_SNo bd inv).
  prove False.
  claim H1lt: 1 < mul_SNo bd inv.
  { exact (RltE_lt 1 (mul_SNo bd inv) Hlt1). }
  claim HbdRle1: Rle bd 1.
  { exact (R_bounded_distance_le_1 (apply_fun x i) (apply_fun y i) HxiR HyiR). }
	  claim HinvRle1: Rle inv 1.
	  { exact (inv_nat_Rle_1 (ordsucc i) HiIn). }
  claim HbdS: SNo bd.
  { exact (real_SNo bd HbdR). }
  claim HinvS: SNo inv.
  { exact (real_SNo inv HinvR). }
  claim HmulS: SNo (mul_SNo bd inv).
  { exact (real_SNo (mul_SNo bd inv) HmulR). }
	  claim H0ltInvR: Rlt 0 inv.
	  { exact (inv_nat_pos (ordsucc i) HiIn). }
  claim H0ltInv: 0 < inv.
  { exact (RltE_lt 0 inv H0ltInvR). }
  claim H0leInv: 0 <= inv.
  { exact (SNoLtLe 0 inv H0ltInv). }
  claim HbdLe1: bd <= 1.
  { apply (SNoLt_trichotomy_or_impred bd 1 HbdS SNo_1 (bd <= 1)).
    - assume Hlt: bd < 1.
      exact (SNoLtLe bd 1 Hlt).
    - assume Heq: bd = 1.
      rewrite Heq.
      exact (SNoLe_ref 1).
    - assume H1ltbd: 1 < bd.
      apply FalseE.
      claim HbdRlt: Rlt 1 bd.
      { exact (RltI 1 bd real_1 HbdR H1ltbd). }
      exact ((RleE_nlt bd 1 HbdRle1) HbdRlt). }
  claim HinvLe1: inv <= 1.
  { apply (SNoLt_trichotomy_or_impred inv 1 HinvS SNo_1 (inv <= 1)).
    - assume Hlt: inv < 1.
      exact (SNoLtLe inv 1 Hlt).
    - assume Heq: inv = 1.
      rewrite Heq.
      exact (SNoLe_ref 1).
    - assume H1ltinv: 1 < inv.
      apply FalseE.
      claim HinvRlt: Rlt 1 inv.
      { exact (RltI 1 inv real_1 HinvR H1ltinv). }
      exact ((RleE_nlt inv 1 HinvRle1) HinvRlt). }
  claim HmulLeInv: mul_SNo bd inv <= inv.
  { exact (mul_SNo_Le1_nonneg_Le bd inv HbdS HinvS HbdLe1 H0leInv). }
  claim HmulLe1: mul_SNo bd inv <= 1.
  { exact (SNoLe_tra (mul_SNo bd inv) inv 1 HmulS HinvS SNo_1 HmulLeInv HinvLe1). }
  claim Hcase: mul_SNo bd inv < 1 \/ mul_SNo bd inv = 1.
  { exact (SNoLeE (mul_SNo bd inv) 1 HmulS SNo_1 HmulLe1). }
  apply (Hcase False).
  - assume HmulLt1: mul_SNo bd inv < 1.
    claim H11: 1 < 1.
    { exact (SNoLt_tra 1 (mul_SNo bd inv) 1 SNo_1 HmulS SNo_1 H1lt HmulLt1). }
    exact ((SNoLt_irref 1) H11).
  - assume HmulEq1: mul_SNo bd inv = 1.
    claim H11: 1 < 1.
    { rewrite <- HmulEq1 at 2.
      exact H1lt. }
    exact ((SNoLt_irref 1) H11).
Qed.

(** helper: the chosen D value is a least upper bound **)
Theorem Romega_D_metric_value_is_lub : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  R_lub (Romega_D_scaled_diffs x y) (Romega_D_metric_value x y).
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
set A := Romega_D_scaled_diffs x y.
set P := (fun r:set => R_lub A r).
claim HAinR: forall a:set, a :e A -> a :e R.
{ exact (Romega_D_scaled_diffs_in_R x y Hx Hy). }
claim Hub: exists u:set, u :e R /\ forall a:set, a :e A -> a :e R -> Rle a u.
{ exact (Romega_D_scaled_diffs_bounded x y Hx Hy). }
claim HAnen: exists a0:set, a0 :e A.
{ claim H0omega: 0 :e omega.
  { exact (nat_p_omega 0 nat_0). }
  witness (mul_SNo (R_bounded_distance (apply_fun x 0) (apply_fun y 0)) (inv_nat (ordsucc 0))).
  exact (ReplI omega
               (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
               0
               H0omega). }
claim Hex: exists l:set, P l.
{ exact (R_lub_exists A HAnen HAinR Hub). }
exact (Eps_i_ex P Hex).
Qed.

(** helper: D metric value is symmetric **)
Theorem Romega_D_metric_value_sym : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  Romega_D_metric_value x y = Romega_D_metric_value y x.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
set A := Romega_D_scaled_diffs x y.
claim HAeq: A = Romega_D_scaled_diffs y x.
{ exact (Romega_D_scaled_diffs_sym x y Hx Hy). }
claim Hlub1: R_lub A (Romega_D_metric_value x y).
{ exact (Romega_D_metric_value_is_lub x y Hx Hy). }
claim Hlub2': R_lub A (Romega_D_metric_value y x).
{ rewrite HAeq.
  exact (Romega_D_metric_value_is_lub y x Hy Hx). }
exact (R_lub_unique A (Romega_D_metric_value x y) (Romega_D_metric_value y x) Hlub1 Hlub2').
Qed.

(** helper: D metric value is 0 on the diagonal **)
Theorem Romega_D_metric_value_self_zero : forall x:set,
  x :e R_omega_space ->
  Romega_D_metric_value x x = 0.
let x.
assume Hx: x :e R_omega_space.
set A := Romega_D_scaled_diffs x x.
claim HAeq: A = {0}.
{ exact (Romega_D_scaled_diffs_diag_eq_Sing0 x Hx). }
claim Hlub1: R_lub A (Romega_D_metric_value x x).
{ exact (Romega_D_metric_value_is_lub x x Hx Hx). }
claim Hlub0: R_lub A 0.
{ rewrite HAeq.
  exact R_lub_Sing0. }
exact (R_lub_unique A (Romega_D_metric_value x x) 0 Hlub1 Hlub0).
Qed.

(** helper: D metric values are real numbers **)
Theorem Romega_D_metric_value_in_R : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  Romega_D_metric_value x y :e R.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
exact (R_lub_in_R (Romega_D_scaled_diffs x y)
                  (Romega_D_metric_value x y)
                  (Romega_D_metric_value_is_lub x y Hx Hy)).
Qed.

(** helper: D metric values are not negative **)
Theorem Romega_D_metric_value_nonneg : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  ~(Rlt (Romega_D_metric_value x y) 0).
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
set A := Romega_D_scaled_diffs x y.
set l := Romega_D_metric_value x y.
claim HlR: l :e R.
{ exact (Romega_D_metric_value_in_R x y Hx Hy). }
claim Hlub: R_lub A l.
{ exact (Romega_D_metric_value_is_lub x y Hx Hy). }
claim Hcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
               Hlub). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hcore). }
assume Hl0: Rlt l 0.
prove False.
set a1 := mul_SNo (R_bounded_distance (apply_fun x 0) (apply_fun y 0)) (inv_nat (ordsucc 0)).
claim H0omega: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim Ha1A: a1 :e A.
{ exact (ReplI omega
               (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
               0
               H0omega). }
claim HxiR: apply_fun x 0 :e R.
{ exact (Romega_coord_in_R x 0 Hx H0omega). }
claim HyiR: apply_fun y 0 :e R.
{ exact (Romega_coord_in_R y 0 Hy H0omega). }
claim HbdR: R_bounded_distance (apply_fun x 0) (apply_fun y 0) :e R.
{ exact (R_bounded_distance_in_R (apply_fun x 0) (apply_fun y 0) HxiR HyiR). }
claim H1omega: ordsucc 0 :e omega.
{ exact (omega_ordsucc 0 H0omega). }
claim H1not0: ordsucc 0 /:e {0}.
{ assume H1: ordsucc 0 :e {0}.
  claim Heq: ordsucc 0 = 0.
  { exact (SingE 0 (ordsucc 0) H1). }
  exact (neq_ordsucc_0 0 Heq). }
claim H1In: ordsucc 0 :e omega :\: {0}.
{ exact (setminusI omega {0} (ordsucc 0) H1omega H1not0). }
claim HinvR: inv_nat (ordsucc 0) :e R.
{ exact (inv_nat_real (ordsucc 0) H1omega). }
claim Ha1R: a1 :e R.
{ exact (real_mul_SNo (R_bounded_distance (apply_fun x 0) (apply_fun y 0)) HbdR
                      (inv_nat (ordsucc 0)) HinvR). }
claim Ha1S: SNo a1.
{ exact (real_SNo a1 Ha1R). }
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim H0S: SNo 0.
{ exact SNo_0. }
claim HbdS: SNo (R_bounded_distance (apply_fun x 0) (apply_fun y 0)).
{ exact (real_SNo (R_bounded_distance (apply_fun x 0) (apply_fun y 0)) HbdR). }
claim HinvS: SNo (inv_nat (ordsucc 0)).
{ exact (real_SNo (inv_nat (ordsucc 0)) HinvR). }
claim HbdNN: 0 <= R_bounded_distance (apply_fun x 0) (apply_fun y 0).
{ exact (R_bounded_distance_nonneg (apply_fun x 0) (apply_fun y 0) HxiR HyiR). }
claim HinvPosR: Rlt 0 (inv_nat (ordsucc 0)).
{ exact (inv_nat_pos (ordsucc 0) H1In). }
claim HinvPos: 0 < inv_nat (ordsucc 0).
{ exact (RltE_lt 0 (inv_nat (ordsucc 0)) HinvPosR). }
claim HinvNN: 0 <= inv_nat (ordsucc 0).
{ exact (SNoLtLe 0 (inv_nat (ordsucc 0)) HinvPos). }
claim Ha1nonneg: 0 <= a1.
{ exact (mul_SNo_nonneg_nonneg (R_bounded_distance (apply_fun x 0) (apply_fun y 0))
                               (inv_nat (ordsucc 0))
                               HbdS HinvS
                               HbdNN HinvNN). }
claim Ha1lt0n: ~(a1 < 0).
{ claim Hcase: 0 < a1 \/ 0 = a1.
  { exact (SNoLeE 0 a1 H0S Ha1S Ha1nonneg). }
  assume Ha1lt0: a1 < 0.
  apply (Hcase False).
  - assume H0lta1: 0 < a1.
    claim H00: 0 < 0.
    { exact (SNoLt_tra 0 a1 0 H0S Ha1S H0S H0lta1 Ha1lt0). }
    exact ((SNoLt_irref 0) H00).
  - assume H0eq: 0 = a1.
    claim H00: 0 < 0.
    { rewrite H0eq at 1.
      exact Ha1lt0. }
    exact ((SNoLt_irref 0) H00). }
claim Hl0lt: l < 0.
{ exact (RltE_lt l 0 Hl0). }
claim Hlta1: l < a1.
{ apply (SNoLt_trichotomy_or_impred a1 0 Ha1S H0S (l < a1)).
  - assume Ha1lt0: a1 < 0.
    exact (FalseE (Ha1lt0n Ha1lt0) (l < a1)).
  - assume Ha1eq0: a1 = 0.
    rewrite Ha1eq0.
    exact Hl0lt.
  - assume H0lta1: 0 < a1.
    exact (SNoLt_tra l 0 a1 HlS H0S Ha1S Hl0lt H0lta1). }
claim Hltla1: Rlt l a1.
{ exact (RltI l a1 HlR Ha1R Hlta1). }
claim HRle: Rle a1 l.
{ exact (Hub a1 Ha1A Ha1R). }
exact ((RleE_nlt a1 l HRle) Hltla1).
Qed.

(** helper: D metric value 0 implies coordinate agreement (for positive indices) **)
Theorem Romega_D_metric_value_eq0_coord_eq : forall x y:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  Romega_D_metric_value x y = 0 ->
  forall i:set, i :e omega -> apply_fun x i = apply_fun y i.
let x y.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
assume Hxy0: Romega_D_metric_value x y = 0.
let i.
assume HiO: i :e omega.
set A := Romega_D_scaled_diffs x y.
set l := Romega_D_metric_value x y.
claim HlR: l :e R.
{ exact (Romega_D_metric_value_in_R x y Hx Hy). }
claim Hlub: R_lub A l.
{ exact (Romega_D_metric_value_is_lub x y Hx Hy). }
claim Hcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
               Hlub). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hcore). }
claim Hub0: forall a:set, a :e A -> a :e R -> Rle a 0.
{ let a0.
  assume Ha0A: a0 :e A.
  assume Ha0R: a0 :e R.
  rewrite <- Hxy0.
  exact (Hub a0 Ha0A Ha0R). }
set bd := R_bounded_distance (apply_fun x i) (apply_fun y i).
set inv := inv_nat (ordsucc i).
set a := mul_SNo bd inv.
claim HaA: a :e A.
{ exact (ReplI omega
               (fun j:set => mul_SNo (R_bounded_distance (apply_fun x j) (apply_fun y j)) (inv_nat (ordsucc j)))
               i
               HiO). }
claim HxiR: apply_fun x i :e R.
{ exact (Romega_coord_in_R x i Hx HiO). }
claim HyiR: apply_fun y i :e R.
{ exact (Romega_coord_in_R y i Hy HiO). }
claim HbdR: bd :e R.
{ exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun y i) HxiR HyiR). }
claim HinvR: inv :e R.
{ exact (inv_nat_real (ordsucc i) (omega_ordsucc i HiO)). }
claim HaR: a :e R.
{ exact (real_mul_SNo bd HbdR inv HinvR). }
claim HRle: Rle a 0.
{ exact (Hub0 a HaA HaR). }
claim HnRlt0a: ~(Rlt 0 a).
{ exact (RleE_nlt a 0 HRle). }
claim HbdS: SNo bd.
{ exact (real_SNo bd HbdR). }
claim HinvS: SNo inv.
{ exact (real_SNo inv HinvR). }
claim HbdNN: 0 <= bd.
{ exact (R_bounded_distance_nonneg (apply_fun x i) (apply_fun y i) HxiR HyiR). }
claim HinvPosR: Rlt 0 inv.
{ claim HsuccO: ordsucc i :e omega.
  { exact (omega_ordsucc i HiO). }
  claim HsuccNotIn0: ordsucc i /:e {0}.
  { assume Hin0: ordsucc i :e {0}.
    claim Heq: ordsucc i = 0.
    { exact (SingE 0 (ordsucc i) Hin0). }
    exact (neq_ordsucc_0 i Heq). }
  claim HsuccIn: ordsucc i :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc i) HsuccO HsuccNotIn0). }
  exact (inv_nat_pos (ordsucc i) HsuccIn). }
claim HinvPos: 0 < inv.
{ exact (RltE_lt 0 inv HinvPosR). }
claim HinvNN: 0 <= inv.
{ exact (SNoLtLe 0 inv HinvPos). }
claim HaNN: 0 <= a.
{ exact (mul_SNo_nonneg_nonneg bd inv HbdS HinvS HbdNN HinvNN). }
claim Ha0: a = 0.
{ apply (SNoLeE 0 a SNo_0 (real_SNo a HaR) HaNN (a = 0)).
  - assume H0lta: 0 < a.
    claim HRlt0a: Rlt 0 a.
    { exact (RltI 0 a real_0 HaR H0lta). }
    exact (FalseE (HnRlt0a HRlt0a) (a = 0)).
  - assume H0eq: 0 = a.
    rewrite <- H0eq.
    reflexivity. }
claim Hadef: a = mul_SNo bd inv.
{ reflexivity. }
claim Hbdinv0: mul_SNo bd inv = 0.
{ rewrite <- Hadef.
  exact Ha0. }
claim HinvNe0: inv <> 0.
{ exact (SNo_pos_ne0 inv HinvS HinvPos). }
claim Hinvbd0: mul_SNo inv bd = 0.
{ rewrite (mul_SNo_com inv bd HinvS HbdS) at 1.
  exact Hbdinv0. }
claim Hinv0: mul_SNo inv 0 = 0.
{ exact (mul_SNo_zeroR inv HinvS). }
claim Hinvbd_eq: mul_SNo inv bd = mul_SNo inv 0.
{ rewrite Hinvbd0.
  rewrite Hinv0.
  reflexivity. }
claim H0S: SNo 0.
{ exact SNo_0. }
claim Hbd0: bd = 0.
{ exact (mul_SNo_nonzero_cancel inv bd 0 HinvS HinvNe0 HbdS H0S Hinvbd_eq). }
exact (R_bounded_distance_eq0 (apply_fun x i) (apply_fun y i) HxiR HyiR Hbd0).
Qed.

(** helper: D metric value is an upper bound for each scaled coordinate distance **)
Theorem Romega_D_metric_value_ub_scaled : forall x y i:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  i :e omega ->
  Rle (mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)))
      (Romega_D_metric_value x y).
let x y i.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
assume HiO: i :e omega.
set A := Romega_D_scaled_diffs x y.
set l := Romega_D_metric_value x y.
claim Hlub: R_lub A l.
{ exact (Romega_D_metric_value_is_lub x y Hx Hy). }
claim Hcore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andEL (l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle l u)
               Hlub). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a l.
{ exact (andER (l :e R) (forall a:set, a :e A -> a :e R -> Rle a l) Hcore). }
set a := mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)).
claim HaA: a :e A.
{ exact (ReplI omega
               (fun j:set => mul_SNo (R_bounded_distance (apply_fun x j) (apply_fun y j)) (inv_nat (ordsucc j)))
               i
               HiO). }
claim HxiR: apply_fun x i :e R.
{ exact (Romega_coord_in_R x i Hx HiO). }
claim HyiR: apply_fun y i :e R.
{ exact (Romega_coord_in_R y i Hy HiO). }
claim HbdR: R_bounded_distance (apply_fun x i) (apply_fun y i) :e R.
{ exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun y i) HxiR HyiR). }
claim HsuccO: ordsucc i :e omega.
{ exact (omega_ordsucc i HiO). }
claim HinvR: inv_nat (ordsucc i) :e R.
{ exact (inv_nat_real (ordsucc i) HsuccO). }
claim HaR: a :e R.
{ exact (real_mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) HbdR
                      (inv_nat (ordsucc i)) HinvR). }
exact (Hub a HaA HaR).
Qed.

(** helper: if the D metric value is < r, then each scaled coordinate term is < r **)
Theorem Romega_D_metric_value_lt_implies_scaled_lt : forall x y i r:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  i :e omega ->
  Rlt (Romega_D_metric_value x y) r ->
  Rlt (mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i))) r.
let x y i r.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
assume HiO: i :e omega.
assume Hlt: Rlt (Romega_D_metric_value x y) r.
set a := mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun y i)) (inv_nat (ordsucc i)).
claim Hale: Rle a (Romega_D_metric_value x y).
{ exact (Romega_D_metric_value_ub_scaled x y i Hx Hy HiO). }
exact (Rle_Rlt_tra a (Romega_D_metric_value x y) r Hale Hlt).
Qed.

(** helper: bounded distance < r with r < 1 implies abs(a-b) < r **)
Theorem R_bounded_distance_lt_lt1_imp_abs_lt : forall a b r:set,
  a :e R ->
  b :e R ->
  r :e R ->
  Rlt r 1 ->
  Rlt (R_bounded_distance a b) r ->
  abs_SNo (add_SNo a (minus_SNo b)) < r.
let a b r.
assume HaR: a :e R.
assume HbR: b :e R.
assume HrR: r :e R.
assume Hrlt1: Rlt r 1.
assume Hlt: Rlt (R_bounded_distance a b) r.
set t := add_SNo a (minus_SNo b).
claim HmbR: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
claim HtR: t :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim Hbddef: R_bounded_distance a b = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
claim HIfRlt: Rlt (If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1) r.
{ rewrite <- Hbddef.
  exact Hlt. }
apply (xm (Rlt (abs_SNo t) 1)).
- assume Hablt1: Rlt (abs_SNo t) 1.
  claim HabRlt: Rlt (abs_SNo t) r.
  { rewrite <- (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hablt1).
    exact HIfRlt. }
  exact (RltE_lt (abs_SNo t) r HabRlt).
- assume Hnablt1: ~(Rlt (abs_SNo t) 1).
  claim H1lt: Rlt 1 r.
  { rewrite <- (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnablt1).
    exact HIfRlt. }
  claim Hrr: Rlt r r.
  { exact (Rlt_tra r 1 r Hrlt1 H1lt). }
  exact (FalseE ((not_Rlt_refl r HrR) Hrr) (abs_SNo t < r)).
Qed.

(** helper: abs(a-b) < r with r < 1 gives bounded distance < r **)
Theorem abs_lt_lt1_imp_R_bounded_distance_lt : forall a b r:set,
  a :e R ->
  b :e R ->
  r :e R ->
  Rlt r 1 ->
  abs_SNo (add_SNo a (minus_SNo b)) < r ->
  Rlt (R_bounded_distance a b) r.
let a b r.
assume HaR: a :e R.
assume HbR: b :e R.
assume HrR: r :e R.
assume Hrlt1: Rlt r 1.
assume Habslt: abs_SNo (add_SNo a (minus_SNo b)) < r.
prove Rlt (R_bounded_distance a b) r.
set t := add_SNo a (minus_SNo b).
claim HmbR: minus_SNo b :e R.
{ exact (real_minus_SNo b HbR). }
claim HtR: t :e R.
{ exact (real_add_SNo a HaR (minus_SNo b) HmbR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabRlt: Rlt (abs_SNo t) r.
{ exact (RltI (abs_SNo t) r HabsR HrR Habslt). }
claim Hablt1: Rlt (abs_SNo t) 1.
{ exact (Rlt_tra (abs_SNo t) r 1 HabRlt Hrlt1). }
claim Hbddef: R_bounded_distance a b = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
{ reflexivity. }
rewrite Hbddef.
rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hablt1).
exact HabRlt.
Qed.

(** helper: D metric bound gives coordinate abs difference bound for a fixed index **)
Theorem Romega_D_metric_coord_abs_lt : forall x y i delta:set,
  x :e R_omega_space ->
  y :e R_omega_space ->
  i :e omega ->
  delta :e R ->
  Rlt 0 delta ->
  Rlt delta 1 ->
  Rlt (Romega_D_metric_value x y) (mul_SNo delta (inv_nat (ordsucc i))) ->
  abs_SNo (add_SNo (apply_fun x i) (minus_SNo (apply_fun y i))) < delta.
let x y i delta.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
assume HiO: i :e omega.
assume HdR: delta :e R.
assume Hdpos: Rlt 0 delta.
assume Hdlt1: Rlt delta 1.
assume Hlt: Rlt (Romega_D_metric_value x y) (mul_SNo delta (inv_nat (ordsucc i))).
set xi := apply_fun x i.
set yi := apply_fun y i.
set bd := R_bounded_distance xi yi.
set inv := inv_nat (ordsucc i).
claim HxiR: xi :e R.
{ exact (Romega_coord_in_R x i Hx HiO). }
claim HyiR: yi :e R.
{ exact (Romega_coord_in_R y i Hy HiO). }
claim HbdR: bd :e R.
{ exact (R_bounded_distance_in_R xi yi HxiR HyiR). }
claim HsuccO: ordsucc i :e omega.
{ exact (omega_ordsucc i HiO). }
claim HinvR: inv :e R.
{ exact (inv_nat_real (ordsucc i) HsuccO). }
claim HinvNot0: ordsucc i /:e {0}.
{ assume Hi0: ordsucc i :e {0}.
  claim Heq0: ordsucc i = 0.
  { exact (SingE 0 (ordsucc i) Hi0). }
  exact (neq_ordsucc_0 i Heq0). }
claim HinvIn: ordsucc i :e omega :\: {0}.
{ exact (setminusI omega {0} (ordsucc i) HsuccO HinvNot0). }
claim HinvPosR: Rlt 0 inv.
{ exact (inv_nat_pos (ordsucc i) HinvIn). }
claim HinvPos: 0 < inv.
{ exact (RltE_lt 0 inv HinvPosR). }
claim HbdS: SNo bd.
{ exact (real_SNo bd HbdR). }
claim HdS: SNo delta.
{ exact (real_SNo delta HdR). }
claim HinvS: SNo inv.
{ exact (real_SNo inv HinvR). }
claim Hscaledlt: Rlt (mul_SNo bd inv) (mul_SNo delta inv).
{ exact (Romega_D_metric_value_lt_implies_scaled_lt x y i (mul_SNo delta inv) Hx Hy HiO Hlt). }
claim HscaledltS: mul_SNo bd inv < mul_SNo delta inv.
{ exact (RltE_lt (mul_SNo bd inv) (mul_SNo delta inv) Hscaledlt). }
claim Hbdlt: bd < delta.
{ apply (SNoLt_trichotomy_or_impred bd delta HbdS HdS (bd < delta)).
  - assume Hc: bd < delta.
    exact Hc.
  - assume Hc: bd = delta.
    claim Heqmul: mul_SNo bd inv = mul_SNo delta inv.
    { rewrite Hc.
      reflexivity. }
    claim Hbad: mul_SNo bd inv < mul_SNo bd inv.
    { rewrite Heqmul at 2.
      exact HscaledltS. }
    exact (FalseE ((SNoLt_irref (mul_SNo bd inv)) Hbad) (bd < delta)).
  - assume Hc: delta < bd.
    claim Hmul: mul_SNo delta inv < mul_SNo bd inv.
    { exact (pos_mul_SNo_Lt' delta bd inv HdS HbdS HinvS HinvPos Hc). }
    claim Hbad: mul_SNo delta inv < mul_SNo delta inv.
    { exact (SNoLt_tra (mul_SNo delta inv) (mul_SNo bd inv) (mul_SNo delta inv)
                      (SNo_mul_SNo delta inv HdS HinvS)
                      (SNo_mul_SNo bd inv HbdS HinvS)
                      (SNo_mul_SNo delta inv HdS HinvS)
                      Hmul
                      HscaledltS). }
    exact (FalseE ((SNoLt_irref (mul_SNo delta inv)) Hbad) (bd < delta)). }
claim HbdRlt: Rlt bd delta.
{ exact (RltI bd delta HbdR HdR Hbdlt). }
set t := add_SNo xi (minus_SNo yi).
exact (R_bounded_distance_lt_lt1_imp_abs_lt xi yi delta HxiR HyiR HdR Hdlt1 HbdRlt).
Qed.

(** helper: division by n equals inv_nat n when numerator is 1 **)
Theorem div_SNo_1_eq_inv_nat : forall n:set,
  SNo n -> div_SNo 1 n = inv_nat n.
let n.
assume HnS: SNo n.
prove div_SNo 1 n = inv_nat n.
claim Hdivdef: div_SNo 1 n = mul_SNo 1 (recip_SNo n).
{ reflexivity. }
rewrite Hdivdef.
rewrite (mul_SNo_oneL (recip_SNo n) (SNo_recip_SNo n HnS)).
claim Hinvdef: inv_nat n = recip_SNo n.
{ reflexivity. }
rewrite Hinvdef.
reflexivity.
Qed.

(** helper: inv_nat 1 = 1 **)
Theorem inv_nat_1_eq_1 : inv_nat 1 = 1.
prove inv_nat 1 = 1.
claim H1neq0: 1 <> 0.
{ exact neq_1_0. }
claim Hmul: mul_SNo 1 (inv_nat 1) = 1.
{ exact (recip_SNo_invR 1 SNo_1 H1neq0). }
rewrite <- (mul_SNo_oneL (inv_nat 1) (SNo_recip_SNo 1 SNo_1)) at 1.
exact Hmul.
Qed.

(** helper: for i<j in omega, inv_nat (i+1) is larger than inv_nat (j+1) **)
Theorem inv_nat_ordsucc_antitone : forall i j:set,
  i :e omega -> j :e omega -> i :e j ->
  Rlt (inv_nat (ordsucc j)) (inv_nat (ordsucc i)).
let i j.
assume HiO: i :e omega.
assume HjO: j :e omega.
assume Hij: i :e j.
set mi := ordsucc i.
set mj := ordsucc j.
claim HiOrd: ordinal i.
{ exact (ordinal_Hered omega omega_ordinal i HiO). }
claim HjOrd: ordinal j.
{ exact (ordinal_Hered omega omega_ordinal j HjO). }
claim Hijlt: i < j.
{ exact (ordinal_In_SNoLt j HjOrd i Hij). }
claim HiS: SNo i.
{ exact (omega_SNo i HiO). }
claim HjS: SNo j.
{ exact (omega_SNo j HjO). }
claim HmiS: SNo mi.
{ exact (omega_SNo mi (omega_ordsucc i HiO)). }
claim HmjS: SNo mj.
{ exact (omega_SNo mj (omega_ordsucc j HjO)). }
claim Hsucclt: mi < mj.
{ prove mi < mj.
  rewrite <- (add_SNo_1_ordsucc i HiO).
  rewrite <- (add_SNo_1_ordsucc j HjO).
  exact (add_SNo_Lt1 i 1 j HiS SNo_1 HjS Hijlt). }
claim HmiNot0: mi <> 0.
{ exact (neq_ordsucc_0 i). }
claim HmjNot0: mj <> 0.
{ exact (neq_ordsucc_0 j). }
claim HinvmiR: inv_nat mi :e R.
{ exact (inv_nat_real mi (omega_ordsucc i HiO)). }
claim HinvmiS: SNo (inv_nat mi).
{ exact (real_SNo (inv_nat mi) HinvmiR). }
claim HmiNotIn0: mi /:e {0}.
{ assume Hmi0: mi :e {0}.
  claim Heq0: mi = 0.
  { exact (SingE 0 mi Hmi0). }
  exact (HmiNot0 Heq0). }
claim HmiIn: mi :e omega :\: {0}.
{ exact (setminusI omega {0} mi (omega_ordsucc i HiO) HmiNotIn0). }
claim HinvmiPosR: Rlt 0 (inv_nat mi).
{ exact (inv_nat_pos mi HmiIn). }
claim HinvmiPos: 0 < inv_nat mi.
{ exact (RltE_lt 0 (inv_nat mi) HinvmiPosR). }
claim HmulLt: mul_SNo (inv_nat mi) mi < mul_SNo (inv_nat mi) mj.
{ exact (pos_mul_SNo_Lt (inv_nat mi) mi mj HinvmiS HinvmiPos HmiS HmjS Hsucclt). }
claim HmulEq: mul_SNo (inv_nat mi) mi = 1.
{ prove mul_SNo (inv_nat mi) mi = 1.
  rewrite (mul_SNo_com (inv_nat mi) mi HinvmiS HmiS).
  claim Hinvdef: inv_nat mi = recip_SNo mi.
  { reflexivity. }
  rewrite Hinvdef.
  exact (recip_SNo_invR mi HmiS HmiNot0). }
claim HoneLt: 1 < mul_SNo (inv_nat mi) mj.
{ rewrite <- HmulEq at 1.
  exact HmulLt. }
claim Hmjpos: 0 < mj.
{ exact (ordinal_ordsucc_pos j HjOrd). }
claim HdivLt: div_SNo 1 mj < inv_nat mi.
{ exact (div_SNo_pos_LtL 1 mj (inv_nat mi) SNo_1 HmjS HinvmiS Hmjpos HoneLt). }
claim HdivEq: div_SNo 1 mj = inv_nat mj.
{ exact (div_SNo_1_eq_inv_nat mj HmjS). }
claim HinvLtS: inv_nat mj < inv_nat mi.
{ rewrite <- HdivEq.
  exact HdivLt. }
claim HinvmiInR: inv_nat mi :e R.
{ exact HinvmiR. }
claim HinvMjR: inv_nat mj :e R.
{ exact (inv_nat_real mj (omega_ordsucc j HjO)). }
exact (RltI (inv_nat mj) (inv_nat mi) HinvMjR HinvmiInR HinvLtS).
Qed.

(** helper: inv_nat 2 is strictly below 1 **)
Theorem inv_nat_2_lt_1 : Rlt (inv_nat 2) 1.
prove Rlt (inv_nat 2) 1.
claim H0o: 0 :e omega.
{ exact (nat_p_omega 0 nat_0). }
claim H1o: 1 :e omega.
{ exact (nat_p_omega 1 nat_1). }
claim H0in1: 0 :e 1.
{ exact In_0_1. }
claim Hlt: Rlt (inv_nat (ordsucc 1)) (inv_nat (ordsucc 0)).
{ exact (inv_nat_ordsucc_antitone 0 1 H0o H1o H0in1). }
claim Hs0: ordsucc 0 = 1.
{ claim Heq: add_SNo 0 1 = ordsucc 0.
  { exact (add_SNo_1_ordsucc 0 H0o). }
  claim Heq01: add_SNo 0 1 = 1.
  { exact (add_SNo_0L 1 SNo_1). }
  prove ordsucc 0 = 1.
  rewrite <- Heq.
  rewrite Heq01.
  reflexivity. }
claim Hs1: ordsucc 1 = 2.
{ claim Heq: add_SNo 1 1 = ordsucc 1.
  { exact (add_SNo_1_ordsucc 1 H1o). }
  prove ordsucc 1 = 2.
  rewrite <- Heq.
  rewrite add_SNo_1_1_2.
  reflexivity. }
rewrite <- inv_nat_1_eq_1 at 2.
rewrite <- Hs1 at 1.
rewrite <- Hs0 at 2.
exact Hlt.
Qed.

(** helper: given r>0, some inv_nat (n+1) is below r **)
Theorem exists_inv_nat_ordsucc_lt : forall r:set,
  r :e R -> Rlt 0 r ->
  exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) r.
let r.
assume HrR: r :e R.
assume HrposR: Rlt 0 r.
set rinv := recip_SNo r.
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim Hrpos: 0 < r.
{ exact (RltE_lt 0 r HrposR). }
claim HrinvR: rinv :e R.
{ exact (real_recip_SNo r HrR). }
claim HrinvS: SNo rinv.
{ exact (real_SNo rinv HrinvR). }
claim HrinvPos: 0 < rinv.
{ exact (recip_SNo_of_pos_is_pos r HrS Hrpos). }
claim HrinvNN: 0 <= rinv.
{ exact (SNoLtLe 0 rinv HrinvPos). }
claim Hexn: exists n :e omega, n <= rinv /\ rinv < ordsucc n.
{ exact (nonneg_real_nat_interval rinv HrinvR HrinvNN). }
apply Hexn.
let n. assume Hnconj.
claim HnO: n :e omega.
{ exact (andEL (n :e omega) (n <= rinv /\ rinv < ordsucc n) Hnconj). }
claim Hnrest: n <= rinv /\ rinv < ordsucc n.
{ exact (andER (n :e omega) (n <= rinv /\ rinv < ordsucc n) Hnconj). }
claim HrinvLt: rinv < ordsucc n.
{ exact (andER (n <= rinv) (rinv < ordsucc n) Hnrest). }
claim HnOrd: ordinal n.
{ exact (ordinal_Hered omega omega_ordinal n HnO). }
claim HNpos: 0 < ordsucc n.
{ exact (ordinal_ordsucc_pos n HnOrd). }
claim HNinO: ordsucc n :e omega.
{ exact (omega_ordsucc n HnO). }
claim HNS: SNo (ordsucc n).
{ exact (omega_SNo (ordsucc n) HNinO). }
claim HmulLt: mul_SNo r rinv < mul_SNo r (ordsucc n).
{ exact (pos_mul_SNo_Lt r rinv (ordsucc n) HrS Hrpos HrinvS HNS HrinvLt). }
claim Hrne0: r <> 0.
{ exact (SNo_pos_ne0 r HrS Hrpos). }
claim HmulEq: mul_SNo r rinv = 1.
{ prove mul_SNo r rinv = 1.
  claim Hrinvdef: rinv = recip_SNo r.
  { reflexivity. }
  rewrite Hrinvdef.
  exact (recip_SNo_invR r HrS Hrne0). }
claim HoneLt: 1 < mul_SNo r (ordsucc n).
{ rewrite <- HmulEq at 1.
  exact HmulLt. }
claim HdivLt: div_SNo 1 (ordsucc n) < r.
{ exact (div_SNo_pos_LtL 1 (ordsucc n) r SNo_1 HNS HrS HNpos HoneLt). }
claim HdivEq: div_SNo 1 (ordsucc n) = inv_nat (ordsucc n).
{ exact (div_SNo_1_eq_inv_nat (ordsucc n) HNS). }
claim HinvLtS: inv_nat (ordsucc n) < r.
{ rewrite <- HdivEq.
  exact HdivLt. }
claim HinvR: inv_nat (ordsucc n) :e R.
{ exact (inv_nat_real (ordsucc n) HNinO). }
witness n.
apply andI.
- exact HnO.
- exact (RltI (inv_nat (ordsucc n)) r HinvR HrR HinvLtS).
Qed.

(** helper: D metric value satisfies triangle inequality **)
Theorem Romega_D_metric_value_triangle : forall x y z:set,
  x :e R_omega_space -> y :e R_omega_space -> z :e R_omega_space ->
  ~(Rlt (add_SNo (Romega_D_metric_value x y) (Romega_D_metric_value y z))
        (Romega_D_metric_value x z)).
let x y z.
assume Hx: x :e R_omega_space.
assume Hy: y :e R_omega_space.
assume Hz: z :e R_omega_space.
set A := Romega_D_scaled_diffs x z.
set l := Romega_D_metric_value x z.
set u := add_SNo (Romega_D_metric_value x y) (Romega_D_metric_value y z).
claim Hlub: R_lub A l.
{ exact (Romega_D_metric_value_is_lub x z Hx Hz). }
claim HuR: u :e R.
{ exact (real_add_SNo (Romega_D_metric_value x y)
                      (Romega_D_metric_value_in_R x y Hx Hy)
                      (Romega_D_metric_value y z)
                      (Romega_D_metric_value_in_R y z Hy Hz)). }
claim Hub: forall a:set, a :e A -> a :e R -> Rle a u.
{ let a. assume HaA: a :e A. assume HaR: a :e R.
  apply (ReplE_impred omega
                      (fun i:set => mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun z i)) (inv_nat (ordsucc i)))
                      a
                      HaA
                      (Rle a u)).
  let i. assume HiO: i :e omega.
  assume Hai: a = mul_SNo (R_bounded_distance (apply_fun x i) (apply_fun z i)) (inv_nat (ordsucc i)).
  rewrite Hai.
  set inv := inv_nat (ordsucc i).
  set bd_xz := R_bounded_distance (apply_fun x i) (apply_fun z i).
  set bd_xy := R_bounded_distance (apply_fun x i) (apply_fun y i).
  set bd_yz := R_bounded_distance (apply_fun y i) (apply_fun z i).
  set sxz := mul_SNo bd_xz inv.
  set sxy := mul_SNo bd_xy inv.
  set syz := mul_SNo bd_yz inv.
  claim HxiR: apply_fun x i :e R.
  { exact (Romega_coord_in_R x i Hx HiO). }
  claim HyiR: apply_fun y i :e R.
  { exact (Romega_coord_in_R y i Hy HiO). }
  claim HziR: apply_fun z i :e R.
  { exact (Romega_coord_in_R z i Hz HiO). }
  claim HinvO: ordsucc i :e omega.
  { exact (omega_ordsucc i HiO). }
  claim HinvNot0: ordsucc i /:e {0}.
  { assume Hin0: ordsucc i :e {0}.
    claim Heq: ordsucc i = 0.
    { exact (SingE 0 (ordsucc i) Hin0). }
    exact (neq_ordsucc_0 i Heq). }
  claim HinvIn: ordsucc i :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc i) HinvO HinvNot0). }
  claim HinvR: inv :e R.
  { exact (inv_nat_real (ordsucc i) HinvO). }
  claim HinvS: SNo inv.
  { exact (real_SNo inv HinvR). }
  claim HinvPosR: Rlt 0 inv.
  { exact (inv_nat_pos (ordsucc i) HinvIn). }
  claim HinvPos: 0 < inv.
  { exact (RltE_lt 0 inv HinvPosR). }
  claim HinvNN: 0 <= inv.
  { exact (SNoLtLe 0 inv HinvPos). }
  claim HbdxzR: bd_xz :e R.
  { exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun z i) HxiR HziR). }
  claim HbdxyR: bd_xy :e R.
  { exact (R_bounded_distance_in_R (apply_fun x i) (apply_fun y i) HxiR HyiR). }
  claim HbdyzR: bd_yz :e R.
  { exact (R_bounded_distance_in_R (apply_fun y i) (apply_fun z i) HyiR HziR). }
  claim HbdxzS: SNo bd_xz.
  { exact (real_SNo bd_xz HbdxzR). }
  claim HbdxyS: SNo bd_xy.
  { exact (real_SNo bd_xy HbdxyR). }
  claim HbdyzS: SNo bd_yz.
  { exact (real_SNo bd_yz HbdyzR). }
  claim HbdTri: bd_xz <= add_SNo bd_xy bd_yz.
  { exact (R_bounded_distance_triangle_Le (apply_fun x i) (apply_fun y i) (apply_fun z i) HxiR HyiR HziR). }
  claim HmulLe: mul_SNo bd_xz inv <= mul_SNo (add_SNo bd_xy bd_yz) inv.
  { exact (nonneg_mul_SNo_Le' bd_xz (add_SNo bd_xy bd_yz) inv
                             HbdxzS
                             (SNo_add_SNo bd_xy bd_yz HbdxyS HbdyzS)
                             HinvS
                             HinvNN
                             HbdTri). }
  claim HmulEq: mul_SNo (add_SNo bd_xy bd_yz) inv = add_SNo (mul_SNo bd_xy inv) (mul_SNo bd_yz inv).
  { exact (mul_SNo_distrR bd_xy bd_yz inv HbdxyS HbdyzS HinvS). }
  claim HsxzLe: sxz <= add_SNo sxy syz.
  { rewrite <- HmulEq.
    exact HmulLe. }
  claim HsxzR: sxz :e R.
  { exact (real_mul_SNo bd_xz HbdxzR inv HinvR). }
  claim HsumR: add_SNo sxy syz :e R.
  { exact (real_add_SNo sxy (real_mul_SNo bd_xy HbdxyR inv HinvR) syz (real_mul_SNo bd_yz HbdyzR inv HinvR)). }
  claim H1: Rle sxz (add_SNo sxy syz).
  { exact (Rle_of_SNoLe sxz (add_SNo sxy syz) HsxzR HsumR HsxzLe). }
  claim Hlubxy: R_lub (Romega_D_scaled_diffs x y) (Romega_D_metric_value x y).
  { exact (Romega_D_metric_value_is_lub x y Hx Hy). }
  claim Hlubyz: R_lub (Romega_D_scaled_diffs y z) (Romega_D_metric_value y z).
  { exact (Romega_D_metric_value_is_lub y z Hy Hz). }
  claim Hxyub: forall b:set, b :e Romega_D_scaled_diffs x y -> b :e R -> Rle b (Romega_D_metric_value x y).
  { exact (andER ((Romega_D_metric_value x y) :e R)
                 (forall b:set, b :e Romega_D_scaled_diffs x y -> b :e R -> Rle b (Romega_D_metric_value x y))
                 (andEL (((Romega_D_metric_value x y) :e R) /\
                         forall b:set, b :e Romega_D_scaled_diffs x y -> b :e R -> Rle b (Romega_D_metric_value x y))
                        (forall uu:set, uu :e R -> (forall b:set, b :e Romega_D_scaled_diffs x y -> b :e R -> Rle b uu) -> Rle (Romega_D_metric_value x y) uu)
                        Hlubxy)). }
  claim Hyzub: forall b:set, b :e Romega_D_scaled_diffs y z -> b :e R -> Rle b (Romega_D_metric_value y z).
  { exact (andER ((Romega_D_metric_value y z) :e R)
                 (forall b:set, b :e Romega_D_scaled_diffs y z -> b :e R -> Rle b (Romega_D_metric_value y z))
                 (andEL (((Romega_D_metric_value y z) :e R) /\
                         forall b:set, b :e Romega_D_scaled_diffs y z -> b :e R -> Rle b (Romega_D_metric_value y z))
                        (forall uu:set, uu :e R -> (forall b:set, b :e Romega_D_scaled_diffs y z -> b :e R -> Rle b uu) -> Rle (Romega_D_metric_value y z) uu)
                        Hlubyz)). }
  claim HsxyA: sxy :e Romega_D_scaled_diffs x y.
  { exact (ReplI omega (fun j:set => mul_SNo (R_bounded_distance (apply_fun x j) (apply_fun y j)) (inv_nat (ordsucc j))) i HiO). }
  claim HsyzA: syz :e Romega_D_scaled_diffs y z.
  { exact (ReplI omega (fun j:set => mul_SNo (R_bounded_distance (apply_fun y j) (apply_fun z j)) (inv_nat (ordsucc j))) i HiO). }
  claim HsxyR: sxy :e R.
  { exact (real_mul_SNo bd_xy HbdxyR inv HinvR). }
  claim HsyzR: syz :e R.
  { exact (real_mul_SNo bd_yz HbdyzR inv HinvR). }
  claim Hsxyub: Rle sxy (Romega_D_metric_value x y).
  { exact (Hxyub sxy HsxyA HsxyR). }
  claim Hsyzub: Rle syz (Romega_D_metric_value y z).
  { exact (Hyzub syz HsyzA HsyzR). }
  claim H2a: Rle (add_SNo sxy syz) (add_SNo sxy (Romega_D_metric_value y z)).
  { exact (Rle_add_SNo_2 sxy syz (Romega_D_metric_value y z)
                         HsxyR HsyzR (Romega_D_metric_value_in_R y z Hy Hz)
                         Hsyzub). }
  claim H2b': Rle (add_SNo (Romega_D_metric_value y z) sxy) (add_SNo (Romega_D_metric_value y z) (Romega_D_metric_value x y)).
  { exact (Rle_add_SNo_2 (Romega_D_metric_value y z) sxy (Romega_D_metric_value x y)
                         (Romega_D_metric_value_in_R y z Hy Hz)
                         HsxyR
                         (Romega_D_metric_value_in_R x y Hx Hy)
                         Hsxyub). }
  claim H2b: Rle (add_SNo sxy (Romega_D_metric_value y z)) u.
  { claim HcomL: add_SNo sxy (Romega_D_metric_value y z) = add_SNo (Romega_D_metric_value y z) sxy.
    { exact (add_SNo_com sxy (Romega_D_metric_value y z)
                         (real_SNo sxy HsxyR)
                         (real_SNo (Romega_D_metric_value y z) (Romega_D_metric_value_in_R y z Hy Hz))). }
    claim HcomR: u = add_SNo (Romega_D_metric_value y z) (Romega_D_metric_value x y).
    { exact (add_SNo_com (Romega_D_metric_value x y) (Romega_D_metric_value y z)
                         (real_SNo (Romega_D_metric_value x y) (Romega_D_metric_value_in_R x y Hx Hy))
                         (real_SNo (Romega_D_metric_value y z) (Romega_D_metric_value_in_R y z Hy Hz))). }
    rewrite HcomL.
    rewrite HcomR.
    exact H2b'. }
  claim H2: Rle (add_SNo sxy syz) u.
  { exact (Rle_tra (add_SNo sxy syz) (add_SNo sxy (Romega_D_metric_value y z)) u H2a H2b). }
  exact (Rle_tra sxz (add_SNo sxy syz) u H1 H2). }
claim Hmin: forall uu:set, uu :e R -> (forall a:set, a :e A -> a :e R -> Rle a uu) -> Rle l uu.
{ exact (andER ((l :e R) /\ forall a:set, a :e A -> a :e R -> Rle a l)
               (forall uu:set, uu :e R -> (forall a:set, a :e A -> a :e R -> Rle a uu) -> Rle l uu)
               Hlub). }
claim Hle: Rle l u.
{ exact (Hmin u HuR Hub). }
exact (RleE_nlt l u Hle).
Qed.

(** from §20 Theorem 20.5: the D metric graph on R^ω × R^ω **)
(** LATEX VERSION: Then D is a metric that induces the product topology on R^ω. **)
Definition Romega_D_metric : set :=
  graph (setprod R_omega_space R_omega_space)
        (fun p:set => Romega_D_metric_value (p 0) (p 1)).

(** helper: D metric is function_on into R **)
Theorem Romega_D_metric_function_on :
  function_on Romega_D_metric (setprod R_omega_space R_omega_space) R.
let p.
assume Hp: p :e setprod R_omega_space R_omega_space.
prove apply_fun Romega_D_metric p :e R.
claim Happ: apply_fun Romega_D_metric p =
  Romega_D_metric_value (p 0) (p 1).
{ exact (apply_fun_graph (setprod R_omega_space R_omega_space)
                         (fun q:set => Romega_D_metric_value (q 0) (q 1))
                         p Hp). }
rewrite Happ.
claim Hp0: p 0 :e R_omega_space.
{ exact (ap0_Sigma R_omega_space (fun _ : set => R_omega_space) p Hp). }
claim Hp1: p 1 :e R_omega_space.
{ exact (ap1_Sigma R_omega_space (fun _ : set => R_omega_space) p Hp). }
exact (Romega_D_metric_value_in_R (p 0) (p 1) Hp0 Hp1).
Qed.

(** from §20 Theorem 20.5: the product topology on R^ω is induced by the D metric **)
(** LATEX VERSION: Then D is a metric that induces the product topology on R^ω. **)
Definition Romega_D_metric_topology : set := metric_topology R_omega_space Romega_D_metric.

(** helper: open balls in the D metric are open in the product topology **)
(** LATEX VERSION: For the D metric on R to the omega, every open ball is open in the product topology. **)
Theorem Romega_D_metric_open_ball_in_product_topology : forall x r:set,
  metric_on R_omega_space Romega_D_metric ->
  x :e R_omega_space -> r :e R -> Rlt 0 r ->
  open_ball R_omega_space Romega_D_metric x r :e R_omega_product_topology.
let x r.
assume Hm: metric_on R_omega_space Romega_D_metric.
assume Hx: x :e R_omega_space.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
set Xi0 := const_space_family omega R R_standard_topology.
set S := product_subbasis_full omega Xi0.
claim Hdef: R_omega_product_topology = generated_topology_from_subbasis R_omega_space S.
{ reflexivity. }
rewrite Hdef.
(** TODO: show the D-metric open ball is open in the generated topology from the cylinder subbasis **)
(** Strategy: use the basis_of_subbasis neighborhood characterization and Romega_D_metric_coord_abs_lt to build a finite cylinder neighborhood inside the ball. **)
set X := R_omega_space.
set d := Romega_D_metric.
set B := basis_of_subbasis X S.
claim HTdef: generated_topology_from_subbasis X S = generated_topology X B.
{ reflexivity. }
rewrite HTdef.
claim Hgendef: generated_topology X B =
  {U0 :e Power X | forall y :e U0, exists b :e B, y :e b /\ b c= U0}.
{ reflexivity. }
rewrite Hgendef.
apply SepI.
- (** open_ball subset X **)
  exact (PowerI X (open_ball X d x r) (open_ball_subset_X X d x r)).
- let y. assume Hy: y :e open_ball X d x r.
  prove exists b :e B, y :e b /\ b c= open_ball X d x r.
  (** TODO: choose a finite-intersection cylinder neighborhood b around y, using the D-metric bound and Romega_D_metric_coord_abs_lt **)
  claim HyX: y :e X.
  { exact (open_ballE1 X d x r y Hy). }
  claim Hxyprod: (x,y) :e setprod X X.
  { exact (tuple_2_setprod_by_pair_Sigma X X x y Hx HyX). }
  claim Hdapp: apply_fun d (x,y) = Romega_D_metric_value x y.
  { rewrite (apply_fun_graph (setprod X X)
                             (fun p:set => Romega_D_metric_value (p 0) (p 1))
                             (x,y)
                             Hxyprod).
    rewrite (tuple_2_0_eq x y).
    rewrite (tuple_2_1_eq x y).
    reflexivity. }
  claim Hltball: Rlt (apply_fun d (x,y)) r.
  { exact (open_ballE2 X d x r y Hy). }
  claim Hltval: Rlt (Romega_D_metric_value x y) r.
  { rewrite <- Hdapp.
    exact Hltball. }
  (** Build a finite cylinder neighborhood around y using a small eps. **)
  claim HexF: exists F:set,
    (F :e finite_subcollections S /\ y :e intersection_of_family X F)
    /\ intersection_of_family X F c= open_ball X d x r.
  { set dxy := apply_fun d (x,y).
    claim Hfun: function_on d (setprod X X) R.
    { exact (metric_on_function_on X d Hm). }
    claim HdxyR: dxy :e R.
    { exact (Hfun (x,y) Hxyprod). }
    claim HdxyS: SNo dxy.
    { exact (real_SNo dxy HdxyR). }
    claim HrS: SNo r.
    { exact (real_SNo r HrR). }
    set gap := add_SNo r (minus_SNo dxy).
    claim HgapR: gap :e R.
    { exact (real_add_SNo r HrR (minus_SNo dxy) (real_minus_SNo dxy HdxyR)). }
    claim HgapPos: Rlt 0 gap.
    { claim HmdxyS: SNo (minus_SNo dxy).
      { exact (SNo_minus_SNo dxy HdxyS). }
      claim HdxyltS: dxy < r.
      { exact (RltE_lt dxy r Hltball). }
      claim Hlt': add_SNo (minus_SNo dxy) dxy < add_SNo (minus_SNo dxy) r.
      { exact (add_SNo_Lt2 (minus_SNo dxy) dxy r HmdxyS HdxyS HrS HdxyltS). }
      claim H0eq: add_SNo (minus_SNo dxy) dxy = 0.
      { exact (add_SNo_minus_SNo_linv dxy HdxyS). }
      claim Hcom: add_SNo (minus_SNo dxy) r = gap.
      { claim Hcom0: add_SNo (minus_SNo dxy) r = add_SNo r (minus_SNo dxy).
        { exact (add_SNo_com (minus_SNo dxy) r HmdxyS HrS). }
        rewrite Hcom0.
        reflexivity. }
	      claim HgapPosS: 0 < gap.
	      { rewrite <- H0eq at 1.
	        rewrite <- Hcom.
	        exact Hlt'. }
      exact (RltI 0 gap real_0 HgapR HgapPosS). }
    claim H1R: 1 :e R.
    { exact real_1. }
    claim H1pos: Rlt 0 1.
    { exact Rlt_0_1. }
    claim Hexeps: exists eps:set,
      eps :e R /\ Rlt 0 eps /\ Rlt eps gap /\ Rlt eps 1 /\ Rlt eps 1 /\ Rlt eps 1.
    { exact (exists_eps_lt_four_pos_Euclid gap 1 1 1 HgapR H1R H1R H1R HgapPos H1pos H1pos H1pos). }
    apply Hexeps.
    let eps. assume Hepsconj.
    claim HepsTop: ((((eps :e R /\ Rlt 0 eps) /\ Rlt eps gap) /\ Rlt eps 1) /\ Rlt eps 1) /\ Rlt eps 1.
    { exact Hepsconj. }
    claim HepsTop1: (((eps :e R /\ Rlt 0 eps) /\ Rlt eps gap) /\ Rlt eps 1) /\ Rlt eps 1.
    { apply HepsTop. assume H1 H2. exact H1. }
    claim HepsTop2: ((eps :e R /\ Rlt 0 eps) /\ Rlt eps gap) /\ Rlt eps 1.
    { apply HepsTop1. assume H1 H2. exact H1. }
    claim HepsTop3: (eps :e R /\ Rlt 0 eps) /\ Rlt eps gap.
    { apply HepsTop2. assume H1 H2. exact H1. }
    claim HepsPair: eps :e R /\ Rlt 0 eps.
    { apply HepsTop3. assume H1 H2. exact H1. }
    claim HepsR: eps :e R.
    { apply HepsPair. assume H1 H2. exact H1. }
    claim HepsPos: Rlt 0 eps.
    { apply HepsPair. assume H1 H2. exact H2. }
    claim HepsLtGap: Rlt eps gap.
    { apply HepsTop3. assume H1 H2. exact H2. }
    claim HepsLt1: Rlt eps 1.
    { apply HepsTop2. assume H1 H2. exact H2. }
    (** choose N so that inv_nat (N+1) < eps **)
    claim HexN: exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) eps.
    { exact (exists_inv_nat_ordsucc_lt eps HepsR HepsPos). }
    apply HexN.
    let N. assume HNpair.
    claim HNO: N :e omega.
    { exact (andEL (N :e omega) (Rlt (inv_nat (ordsucc N)) eps) HNpair). }
    claim HinvNLt: Rlt (inv_nat (ordsucc N)) eps.
    { exact (andER (N :e omega) (Rlt (inv_nat (ordsucc N)) eps) HNpair). }
    set I := ordsucc N.
    claim HIO: I :e omega.
    { exact (omega_ordsucc N HNO). }
    claim HIcOmega: I c= omega.
    { exact (ordinal_ordsucc_In_Subq omega omega_ordinal N HNO). }
    (** define cylinders for indices in I with radius eps around y_i **)
    set cyl := (fun i:set =>
      product_cylinder omega Xi0 i
        (open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
                       (add_SNo (apply_fun y i) eps))).
    set F := Repl I cyl.
    witness F.
    apply andI.
	    - (** F is a finite subcollection of the subbasis and y lies in its intersection **)
	      apply andI.
	      + (** F :e finite_subcollections S **)
	        claim HFdef: finite_subcollections S = {F0 :e Power S|finite F0}.
	        { reflexivity. }
	        rewrite HFdef.
	        apply SepI.
	        * (** F :e Power S **)
	          apply PowerI.
	          let s. assume HsF: s :e F.
	          prove s :e S.
          claim Hexi: exists i:set, i :e I /\ s = cyl i.
          { exact (ReplE I cyl s HsF). }
          apply Hexi.
          let i. assume Hiconj.
          claim HiI: i :e I.
          { exact (andEL (i :e I) (s = cyl i) Hiconj). }
          claim Hseq: s = cyl i.
          { exact (andER (i :e I) (s = cyl i) Hiconj). }
          rewrite Hseq.
          claim HiO: i :e omega.
          { exact (HIcOmega i HiI). }
          set Ui := open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
                                  (add_SNo (apply_fun y i) eps).
	          claim HUiTop: Ui :e R_standard_topology.
	          { (** Ui is a standard open interval, hence open **)
            claim HyiR: apply_fun y i :e R.
            { exact (Romega_coord_in_R y i HyX HiO). }
            claim HyiS: SNo (apply_fun y i).
            { exact (real_SNo (apply_fun y i) HyiR). }
            claim HepsS: SNo eps.
            { exact (real_SNo eps HepsR). }
            claim HmeiR: minus_SNo eps :e R.
            { exact (real_minus_SNo eps HepsR). }
            claim HaR: add_SNo (apply_fun y i) (minus_SNo eps) :e R.
            { exact (real_add_SNo (apply_fun y i) HyiR (minus_SNo eps) HmeiR). }
            claim HbR: add_SNo (apply_fun y i) eps :e R.
            { exact (real_add_SNo (apply_fun y i) HyiR eps HepsR). }
	            claim HbStd: Ui :e R_standard_basis.
	            { exact (famunionI R (fun a0:set => {open_interval a0 b|b :e R})
	                              (add_SNo (apply_fun y i) (minus_SNo eps)) Ui HaR
	                              (ReplI R (fun b1:set => open_interval (add_SNo (apply_fun y i) (minus_SNo eps)) b1)
	                                     (add_SNo (apply_fun y i) eps) HbR)). }
	            claim HPow: Ui :e Power R.
	            { claim HUiEq: Ui = open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
	                                             (add_SNo (apply_fun y i) eps).
	              { reflexivity. }
	              rewrite HUiEq.
	              exact (PowerI R
	                           (open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
	                                          (add_SNo (apply_fun y i) eps))
	                           (open_interval_Subq_R (add_SNo (apply_fun y i) (minus_SNo eps))
	                                                 (add_SNo (apply_fun y i) eps))). }
	            exact (generated_topology_contains_elem R R_standard_basis Ui HPow HbStd). }
          claim HcylIn: product_cylinder omega Xi0 i Ui :e S.
          { claim HTi: space_family_topology Xi0 i = R_standard_topology.
            { claim Hdef0: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
              { reflexivity. }
              rewrite Hdef0.
              rewrite (const_space_family_apply omega R R_standard_topology i HiO).
              exact (tuple_2_1_eq R R_standard_topology). }
            claim HUiIn: Ui :e space_family_topology Xi0 i.
            { rewrite HTi.
              exact HUiTop. }
            exact (famunionI omega
                             (fun j:set => {product_cylinder omega Xi0 j U0|U0 :e space_family_topology Xi0 j})
                             i
                             (product_cylinder omega Xi0 i Ui)
                             HiO
                             (ReplI (space_family_topology Xi0 i)
                                    (fun U0:set => product_cylinder omega Xi0 i U0)
                                    Ui
                                    HUiIn)). }
          exact HcylIn.
        * (** finite F **)
          claim HINat: nat_p I.
          { exact (omega_nat_p I HIO). }
          claim HIfin: finite I.
          { exact (nat_finite I HINat). }
          exact (Repl_finite cyl I HIfin).
	      + (** y :e intersection_of_family X F **)
	        claim HinterDef: intersection_of_family X F = {x0 :e X|forall U:set, U :e F -> x0 :e U}.
	        { reflexivity. }
	        rewrite HinterDef.
	        apply SepI.
	        * exact HyX.
	        * let U0. assume HU0: U0 :e F.
	          prove y :e U0.
          claim Hexi: exists i:set, i :e I /\ U0 = cyl i.
          { exact (ReplE I cyl U0 HU0). }
          apply Hexi.
          let i. assume Hiconj.
          claim HiI: i :e I.
          { exact (andEL (i :e I) (U0 = cyl i) Hiconj). }
          claim HU0eq: U0 = cyl i.
          { exact (andER (i :e I) (U0 = cyl i) Hiconj). }
          rewrite HU0eq.
	          claim HiO: i :e omega.
	          { exact (HIcOmega i HiI). }
	          set Ui := open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
	                                  (add_SNo (apply_fun y i) eps).
	          claim HCdef: cyl i =
	            {f0 :e product_space omega Xi0 |
	              i :e omega /\ Ui :e space_family_topology Xi0 i /\ apply_fun f0 i :e Ui}.
	          { reflexivity. }
	          rewrite HCdef.
		          apply SepI.
		          - exact HyX.
		          - (** i :e omega /\ Ui :e space_family_topology Xi0 i /\ apply_fun y i :e Ui **)
		            prove i :e omega /\ Ui :e space_family_topology Xi0 i /\ apply_fun y i :e Ui.
			          claim HUiTop: Ui :e R_standard_topology.
			          { (** Ui is a standard open interval **)
		              claim HyiR: apply_fun y i :e R.
		              { exact (Romega_coord_in_R y i HyX HiO). }
		              claim HmeiR: minus_SNo eps :e R.
		              { exact (real_minus_SNo eps HepsR). }
		              claim HaR: add_SNo (apply_fun y i) (minus_SNo eps) :e R.
		              { exact (real_add_SNo (apply_fun y i) HyiR (minus_SNo eps) HmeiR). }
		              claim HbR: add_SNo (apply_fun y i) eps :e R.
		              { exact (real_add_SNo (apply_fun y i) HyiR eps HepsR). }
			              claim HbStd: Ui :e R_standard_basis.
			              { exact (famunionI R (fun a0:set => {open_interval a0 b|b :e R})
			                                (add_SNo (apply_fun y i) (minus_SNo eps)) Ui HaR
			                                (ReplI R (fun b1:set => open_interval (add_SNo (apply_fun y i) (minus_SNo eps)) b1)
			                                       (add_SNo (apply_fun y i) eps) HbR)). }
			              claim HPow: Ui :e Power R.
			              { claim HUiEq: Ui = open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
			                                               (add_SNo (apply_fun y i) eps).
			                { reflexivity. }
			                rewrite HUiEq.
			                exact (PowerI R
			                             (open_interval (add_SNo (apply_fun y i) (minus_SNo eps))
			                                            (add_SNo (apply_fun y i) eps))
			                             (open_interval_Subq_R (add_SNo (apply_fun y i) (minus_SNo eps))
			                                                   (add_SNo (apply_fun y i) eps))). }
			              exact (generated_topology_contains_elem R R_standard_basis Ui HPow HbStd). }
		            claim HTi: space_family_topology Xi0 i = R_standard_topology.
		            { claim Hdef0: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
		              { reflexivity. }
		              rewrite Hdef0.
		              rewrite (const_space_family_apply omega R R_standard_topology i HiO).
		              exact (tuple_2_1_eq R R_standard_topology). }
		            claim HUiIn: Ui :e space_family_topology Xi0 i.
		            { rewrite HTi.
		              exact HUiTop. }
		            claim HyUi: apply_fun y i :e Ui.
		            { claim HyiR: apply_fun y i :e R.
		              { exact (Romega_coord_in_R y i HyX HiO). }
		              claim HyiS: SNo (apply_fun y i).
		              { exact (real_SNo (apply_fun y i) HyiR). }
		              claim HepsS: SNo eps.
		              { exact (real_SNo eps HepsR). }
		              claim HmepsS: SNo (minus_SNo eps).
		              { exact (SNo_minus_SNo eps HepsS). }
		              claim Hlt1: add_SNo (apply_fun y i) (minus_SNo eps) < apply_fun y i.
		              { rewrite <- (add_SNo_0R (apply_fun y i) HyiS) at 2.
		                claim HepsPosS: 0 < eps.
		                { exact (RltE_lt 0 eps HepsPos). }
		                claim HepsNegS: minus_SNo eps < 0.
		                { claim Htmp: minus_SNo eps < minus_SNo 0.
		                  { exact (minus_SNo_Lt_contra 0 eps SNo_0 HepsS HepsPosS). }
		                  claim Htmp2: minus_SNo eps < 0.
		                  { rewrite <- minus_SNo_0.
		                    exact Htmp. }
		                  exact Htmp2. }
		                exact (add_SNo_Lt2 (apply_fun y i) (minus_SNo eps) 0 HyiS HmepsS SNo_0 HepsNegS). }
		              claim Hlt2: apply_fun y i < add_SNo (apply_fun y i) eps.
		              { rewrite <- (add_SNo_0R (apply_fun y i) HyiS) at 1.
		                exact (add_SNo_Lt2 (apply_fun y i) 0 eps HyiS SNo_0 HepsS (RltE_lt 0 eps HepsPos)). }
		              claim Hlt1R: Rlt (add_SNo (apply_fun y i) (minus_SNo eps)) (apply_fun y i).
		              { exact (RltI (add_SNo (apply_fun y i) (minus_SNo eps)) (apply_fun y i)
		                           (real_add_SNo (apply_fun y i) HyiR (minus_SNo eps) (real_minus_SNo eps HepsR))
		                           HyiR
		                           Hlt1). }
		              claim Hlt2R: Rlt (apply_fun y i) (add_SNo (apply_fun y i) eps).
		              { exact (RltI (apply_fun y i) (add_SNo (apply_fun y i) eps)
		                           HyiR
		                           (real_add_SNo (apply_fun y i) HyiR eps HepsR)
		                           Hlt2). }
		              claim HinterDef: Ui = {x0 :e R | Rlt (add_SNo (apply_fun y i) (minus_SNo eps)) x0 /\ Rlt x0 (add_SNo (apply_fun y i) eps)}.
		              { reflexivity. }
		              rewrite HinterDef.
		              exact (SepI R
		                          (fun x0:set =>
		                            Rlt (add_SNo (apply_fun y i) (minus_SNo eps)) x0 /\
		                            Rlt x0 (add_SNo (apply_fun y i) eps))
		                          (apply_fun y i)
		                          HyiR
		                          (andI (Rlt (add_SNo (apply_fun y i) (minus_SNo eps)) (apply_fun y i))
		                                (Rlt (apply_fun y i) (add_SNo (apply_fun y i) eps))
		                                Hlt1R
		                                Hlt2R)). }
		            claim Hleft: i :e omega /\ Ui :e space_family_topology Xi0 i.
		            { exact (andI (i :e omega) (Ui :e space_family_topology Xi0 i) HiO HUiIn). }
		            exact (andI (i :e omega /\ Ui :e space_family_topology Xi0 i) (apply_fun y i :e Ui) Hleft HyUi).
	    - (** intersection subset open_ball **)
	      prove intersection_of_family X F c= open_ball X d x r.
	      let z. assume HzInt: z :e intersection_of_family X F.
	      prove z :e open_ball X d x r.
	      (** unfold intersection_of_family to get z :e X and membership in all cylinders in F **)
	      claim HinterDefZ: intersection_of_family X F = {x0 :e X|forall U:set, U :e F -> x0 :e U}.
	      { reflexivity. }
	      claim HzInt0: z :e {x0 :e X|forall U:set, U :e F -> x0 :e U}.
	      { rewrite <- HinterDefZ.
	        exact HzInt. }
	      claim HzX: z :e X.
	      { exact (SepE1 X (fun x0:set => forall U:set, U :e F -> x0 :e U) z HzInt0). }
	      claim HzAll: forall U:set, U :e F -> z :e U.
	      { exact (SepE2 X (fun x0:set => forall U:set, U :e F -> x0 :e U) z HzInt0). }
	      (** triangle inequality: d(x,z) <= d(x,y)+d(y,z) **)
	      claim Htri: Rle (apply_fun d (x,z)) (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))).
	      { exact (metric_triangle_Rle X d x y z Hm Hx HyX HzX). }
	      (** bound d(y,z) by eps and then use eps < gap = r-d(x,y) **)
	      claim Hyzprod: (y,z) :e setprod X X.
	      { exact (tuple_2_setprod_by_pair_Sigma X X y z HyX HzX). }
	      claim Hxyprod2: (x,y) :e setprod X X.
	      { exact (tuple_2_setprod_by_pair_Sigma X X x y Hx HyX). }
	      claim Hfun: function_on d (setprod X X) R.
	      { exact (metric_on_function_on X d Hm). }
	      claim HdxyR: apply_fun d (x,y) :e R.
	      { exact (Hfun (x,y) Hxyprod2). }
	      claim HdyzR: apply_fun d (y,z) :e R.
	      { exact (Hfun (y,z) Hyzprod). }
	      claim HdxyEq: apply_fun d (x,y) = Romega_D_metric_value x y.
	      { rewrite (apply_fun_graph (setprod X X)
	                                 (fun p:set => Romega_D_metric_value (p 0) (p 1))
	                                 (x,y)
	                                 Hxyprod2).
	        rewrite (tuple_2_0_eq x y).
	        rewrite (tuple_2_1_eq x y).
	        reflexivity. }
	      claim HdyzEq: apply_fun d (y,z) = Romega_D_metric_value y z.
	      { rewrite (apply_fun_graph (setprod X X)
	                                 (fun p:set => Romega_D_metric_value (p 0) (p 1))
	                                 (y,z)
	                                 Hyzprod).
	        rewrite (tuple_2_0_eq y z).
	        rewrite (tuple_2_1_eq y z).
	        reflexivity. }
	      (** show d(y,z) <= eps by lub upper bound property **)
	      claim HdyzLe: Rle (apply_fun d (y,z)) eps.
	      { rewrite HdyzEq.
	        set A := Romega_D_scaled_diffs y z.
	        set l := Romega_D_metric_value y z.
	        claim Hlub: R_lub A l.
	        { exact (Romega_D_metric_value_is_lub y z HyX HzX). }
	        claim HlubCore: l :e R /\ forall a:set, a :e A -> a :e R -> Rle a l.
	        { exact (andEL (l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l))
	                       (forall u:set, u :e R ->
	                         (forall a:set, a :e A -> a :e R -> Rle a u) ->
	                         Rle l u)
	                       Hlub). }
	        claim HlubMin: forall u:set, u :e R ->
	          (forall a:set, a :e A -> a :e R -> Rle a u) ->
	          Rle l u.
	        { exact (andER (l :e R /\ (forall a:set, a :e A -> a :e R -> Rle a l))
	                       (forall u:set, u :e R ->
	                         (forall a:set, a :e A -> a :e R -> Rle a u) ->
	                         Rle l u)
	                       Hlub). }
	        claim Hub: forall a:set, a :e A -> a :e R -> Rle a eps.
	        { let a. assume HaA: a :e A. assume HaR: a :e R.
	          apply (ReplE_impred omega
	                  (fun i0:set => mul_SNo (R_bounded_distance (apply_fun y i0) (apply_fun z i0)) (inv_nat (ordsucc i0)))
	                  a
	                  HaA
	                  (Rle a eps)).
	          let i0. assume Hi0O: i0 :e omega.
	          assume Hai0: a = mul_SNo (R_bounded_distance (apply_fun y i0) (apply_fun z i0)) (inv_nat (ordsucc i0)).
	          rewrite Hai0.
	          apply (xm (i0 :e I)).
	          - assume Hi0I: i0 :e I.
	            (** z lies in the cylinder around y_i0, so its i0-coordinate is eps-close to y_i0 **)
	            set yi := apply_fun y i0.
	            set zi := apply_fun z i0.
	            set Ui0 := open_interval (add_SNo yi (minus_SNo eps)) (add_SNo yi eps).
	            set bd := R_bounded_distance yi zi.
	            set inv := inv_nat (ordsucc i0).
	            claim HyiR: yi :e R.
	            { exact (Romega_coord_in_R y i0 HyX Hi0O). }
	            claim HziR: zi :e R.
	            { exact (Romega_coord_in_R z i0 HzX Hi0O). }
	            claim HyiS: SNo yi.
	            { exact (real_SNo yi HyiR). }
	            claim HziS: SNo zi.
	            { exact (real_SNo zi HziR). }
	            claim HepsS: SNo eps.
	            { exact (real_SNo eps HepsR). }
	            claim HbdR: bd :e R.
	            { exact (R_bounded_distance_in_R yi zi HyiR HziR). }
	            claim HbdS: SNo bd.
	            { exact (real_SNo bd HbdR). }
	            claim HSi0: ordsucc i0 :e omega.
	            { exact (omega_ordsucc i0 Hi0O). }
	            claim HinvR: inv :e R.
	            { exact (inv_nat_real (ordsucc i0) HSi0). }
	            claim HinvS: SNo inv.
	            { exact (real_SNo inv HinvR). }
	            claim HmulR: mul_SNo bd inv :e R.
	            { exact (real_mul_SNo bd HbdR inv HinvR). }
	            claim HmulS: SNo (mul_SNo bd inv).
	            { exact (real_SNo (mul_SNo bd inv) HmulR). }
	            (** obtain zi in Ui0 from cylinder membership **)
	            claim HcylInF: cyl i0 :e F.
	            { claim HFdef: F = Repl I cyl.
	              { reflexivity. }
	              rewrite HFdef.
	              exact (ReplI I cyl i0 Hi0I). }
	            claim HzCyl: z :e cyl i0.
	            { exact (HzAll (cyl i0) HcylInF). }
	            claim HzCyl0: z :e product_cylinder omega Xi0 i0 Ui0.
	            { prove z :e product_cylinder omega Xi0 i0 Ui0.
	              claim HcylEq: cyl i0 = product_cylinder omega Xi0 i0 Ui0.
	              { reflexivity. }
	              rewrite <- HcylEq.
	              exact HzCyl. }
	            claim HzCylConj: i0 :e omega /\ Ui0 :e space_family_topology Xi0 i0 /\ apply_fun z i0 :e Ui0.
	            { exact (SepE2 (product_space omega Xi0)
	                           (fun f0:set => i0 :e omega /\ Ui0 :e space_family_topology Xi0 i0 /\ apply_fun f0 i0 :e Ui0)
	                           z
	                           HzCyl0). }
	            claim HziUi0: zi :e Ui0.
	            { apply HzCylConj.
	              assume Htmp HziUi0.
	              exact HziUi0. }
	            (** turn Ui0 membership into bounds **)
	            claim HUi0Def: Ui0 = {x0 :e R | Rlt (add_SNo yi (minus_SNo eps)) x0 /\ Rlt x0 (add_SNo yi eps)}.
	            { reflexivity. }
	            claim HziUi0': zi :e {x0 :e R | Rlt (add_SNo yi (minus_SNo eps)) x0 /\ Rlt x0 (add_SNo yi eps)}.
	            { rewrite <- HUi0Def.
	              exact HziUi0. }
	            claim HziConj: Rlt (add_SNo yi (minus_SNo eps)) zi /\ Rlt zi (add_SNo yi eps).
	            { exact (SepE2 R (fun x0:set => Rlt (add_SNo yi (minus_SNo eps)) x0 /\ Rlt x0 (add_SNo yi eps)) zi HziUi0'). }
	            claim HleftR: Rlt (add_SNo yi (minus_SNo eps)) zi.
	            { exact (andEL (Rlt (add_SNo yi (minus_SNo eps)) zi) (Rlt zi (add_SNo yi eps)) HziConj). }
	            claim HrightR: Rlt zi (add_SNo yi eps).
	            { exact (andER (Rlt (add_SNo yi (minus_SNo eps)) zi) (Rlt zi (add_SNo yi eps)) HziConj). }
	            claim HyimepsR: add_SNo yi (minus_SNo eps) :e R.
	            { exact (real_add_SNo yi HyiR (minus_SNo eps) (real_minus_SNo eps HepsR)). }
	            claim HyiepsR: add_SNo yi eps :e R.
	            { exact (real_add_SNo yi HyiR eps HepsR). }
	            claim HyimepsS: SNo (add_SNo yi (minus_SNo eps)).
	            { exact (real_SNo (add_SNo yi (minus_SNo eps)) HyimepsR). }
	            claim HyiepsS: SNo (add_SNo yi eps).
	            { exact (real_SNo (add_SNo yi eps) HyiepsR). }
	            claim HleftS: add_SNo yi (minus_SNo eps) < zi.
	            { exact (RltE_lt (add_SNo yi (minus_SNo eps)) zi HleftR). }
	            claim HrightS: zi < add_SNo yi eps.
	            { exact (RltE_lt zi (add_SNo yi eps) HrightR). }
	            set t := add_SNo yi (minus_SNo zi).
	            claim HtR: t :e R.
	            { exact (real_add_SNo yi HyiR (minus_SNo zi) (real_minus_SNo zi HziR)). }
	            claim HtS: SNo t.
	            { exact (real_SNo t HtR). }
	            (** derive bounds: -eps < t < eps **)
	            claim HmYiS: SNo (minus_SNo yi).
	            { exact (SNo_minus_SNo yi HyiS). }
	            claim HmZiS: SNo (minus_SNo zi).
	            { exact (SNo_minus_SNo zi HziS). }
	            claim HmepsS: SNo (minus_SNo eps).
	            { exact (SNo_minus_SNo eps HepsS). }
	            (** from zi < yi+eps get -eps < yi-zi **)
	            claim HdiffLt1: add_SNo (minus_SNo yi) zi < add_SNo (minus_SNo yi) (add_SNo yi eps).
	            { exact (add_SNo_Lt2 (minus_SNo yi) zi (add_SNo yi eps) HmYiS HziS HyiepsS HrightS). }
	            claim HdiffLt2: add_SNo zi (minus_SNo yi) < eps.
	            { prove add_SNo zi (minus_SNo yi) < eps.
	              rewrite <- (add_SNo_com (minus_SNo yi) zi HmYiS HziS) at 1.
	              claim HRhs: add_SNo (minus_SNo yi) (add_SNo yi eps) = eps.
	              { claim Hassoc: add_SNo (minus_SNo yi) (add_SNo yi eps) = add_SNo (add_SNo (minus_SNo yi) yi) eps.
	                { exact (add_SNo_assoc (minus_SNo yi) yi eps HmYiS HyiS HepsS). }
	                rewrite Hassoc.
	                rewrite (add_SNo_minus_SNo_linv yi HyiS).
	                rewrite (add_SNo_0L eps HepsS).
	                reflexivity. }
	              rewrite <- HRhs.
	              exact HdiffLt1. }
	            claim HmDiff: minus_SNo eps < minus_SNo (add_SNo zi (minus_SNo yi)).
	            { exact (minus_SNo_Lt_contra (add_SNo zi (minus_SNo yi)) eps
	                                        (SNo_add_SNo zi (minus_SNo yi) HziS HmYiS)
	                                        HepsS
	                                        HdiffLt2). }
	            claim HmDiffEq: minus_SNo (add_SNo zi (minus_SNo yi)) = t.
	            { rewrite (minus_add_SNo_distr zi (minus_SNo yi) HziS HmYiS).
	              rewrite (minus_SNo_invol yi HyiS).
	              rewrite (add_SNo_com (minus_SNo zi) yi HmZiS HyiS).
	              reflexivity. }
	            claim HloLt: minus_SNo eps < t.
	            { rewrite <- HmDiffEq.
	              exact HmDiff. }
	            (** from yi-eps < zi get t < eps **)
	            claim HdiffLt3: add_SNo (minus_SNo yi) (add_SNo yi (minus_SNo eps)) < add_SNo (minus_SNo yi) zi.
	            { exact (add_SNo_Lt2 (minus_SNo yi) (add_SNo yi (minus_SNo eps)) zi
	                                HmYiS HyimepsS HziS HleftS). }
	            claim HdiffLt4: minus_SNo eps < add_SNo zi (minus_SNo yi).
	            { prove minus_SNo eps < add_SNo zi (minus_SNo yi).
	              rewrite <- (add_SNo_com (minus_SNo yi) zi HmYiS HziS).
	              claim HLhs: add_SNo (minus_SNo yi) (add_SNo yi (minus_SNo eps)) = minus_SNo eps.
	              { claim Hassoc2: add_SNo (minus_SNo yi) (add_SNo yi (minus_SNo eps)) = add_SNo (add_SNo (minus_SNo yi) yi) (minus_SNo eps).
	                { exact (add_SNo_assoc (minus_SNo yi) yi (minus_SNo eps) HmYiS HyiS HmepsS). }
	                rewrite Hassoc2.
	                rewrite (add_SNo_minus_SNo_linv yi HyiS).
	                rewrite (add_SNo_0L (minus_SNo eps) HmepsS).
	                reflexivity. }
	              rewrite <- HLhs at 1.
	              exact HdiffLt3. }
	            claim HtLt: t < eps.
	            { rewrite <- HmDiffEq.
	              rewrite <- (minus_SNo_invol eps HepsS).
	              exact (minus_SNo_Lt_contra (minus_SNo eps) (add_SNo zi (minus_SNo yi))
	                                        HmepsS
	                                        (SNo_add_SNo zi (minus_SNo yi) HziS HmYiS)
	                                        HdiffLt4). }
	            claim Hlo: minus_SNo eps <= t.
	            { exact (SNoLtLe (minus_SNo eps) t HloLt). }
	            claim Hhi: t <= eps.
	            { exact (SNoLtLe t eps HtLt). }
	            claim HabsLe: abs_SNo t <= eps.
	            { exact (abs_SNo_Le_of_bounds t eps HtS HepsS Hlo Hhi). }
	            claim HabsR: abs_SNo t :e R.
	            { exact (abs_SNo_in_R t HtR). }
	            claim HabsS: SNo (abs_SNo t).
	            { exact (SNo_abs_SNo t HtS). }
	            (** bd = abs t since abs t < 1 **)
	            claim HepsLt1S: eps < 1.
	            { exact (RltE_lt eps 1 HepsLt1). }
	            claim HabsLt1S: abs_SNo t < 1.
	            { exact (SNoLeLt_tra (abs_SNo t) eps 1 HabsS HepsS SNo_1 HabsLe HepsLt1S). }
	            claim HabsLt1R: Rlt (abs_SNo t) 1.
	            { exact (RltI (abs_SNo t) 1 HabsR real_1 HabsLt1S). }
	            claim HbdEq: bd = abs_SNo t.
	            { claim HbdDef: bd =
	                If_i (Rlt (abs_SNo (add_SNo yi (minus_SNo zi))) 1)
	                     (abs_SNo (add_SNo yi (minus_SNo zi)))
	                     1.
	              { reflexivity. }
	              rewrite HbdDef.
	              rewrite (If_i_1 (Rlt (abs_SNo (add_SNo yi (minus_SNo zi))) 1)
	                              (abs_SNo (add_SNo yi (minus_SNo zi)))
	                              1
	                              HabsLt1R).
	              reflexivity. }
	            claim HbdLe: bd <= eps.
	            { rewrite HbdEq.
	              exact HabsLe. }
	            (** inv <= 1 and inv >= 0 **)
	            claim HsuccNotIn0: ordsucc i0 /:e {0}.
	            { assume Hin0: ordsucc i0 :e {0}.
	              claim Heq0: ordsucc i0 = 0.
	              { exact (SingE 0 (ordsucc i0) Hin0). }
	              exact (neq_ordsucc_0 i0 Heq0). }
	            claim HiIn: ordsucc i0 :e omega :\: {0}.
	            { exact (setminusI omega {0} (ordsucc i0) HSi0 HsuccNotIn0). }
	            claim HinvRle1: Rle inv 1.
	            { exact (inv_nat_Rle_1 (ordsucc i0) HiIn). }
	            claim HinvLe1: inv <= 1.
	            { apply (SNoLt_trichotomy_or_impred inv 1 HinvS SNo_1 (inv <= 1)).
	              - assume Hlt: inv < 1.
	                exact (SNoLtLe inv 1 Hlt).
	              - assume Heq: inv = 1.
	                rewrite Heq.
	                exact (SNoLe_ref 1).
	              - assume H1lt: 1 < inv.
	                apply FalseE.
	                claim HinvRlt: Rlt 1 inv.
	                { exact (RltI 1 inv real_1 HinvR H1lt). }
	                exact ((RleE_nlt inv 1 HinvRle1) HinvRlt). }
	            claim HinvPosR: Rlt 0 inv.
	            { exact (inv_nat_pos (ordsucc i0) HiIn). }
	            claim HinvPosS: 0 < inv.
	            { exact (RltE_lt 0 inv HinvPosR). }
	            claim HinvNN: 0 <= inv.
	            { exact (SNoLtLe 0 inv HinvPosS). }
	            claim HbdNN: 0 <= bd.
	            { exact (R_bounded_distance_nonneg yi zi HyiR HziR). }
	            claim HmulLe: mul_SNo bd inv <= eps.
	            { claim HmulLe': mul_SNo bd inv <= mul_SNo eps 1.
	              { exact (nonneg_mul_SNo_Le2 bd inv eps 1 HbdS HinvS HepsS SNo_1 HbdNN HinvNN HbdLe HinvLe1). }
	              prove mul_SNo bd inv <= eps.
	              rewrite <- (mul_SNo_oneR eps HepsS).
	              exact HmulLe'. }
	            exact (Rle_of_SNoLe (mul_SNo bd inv) eps HmulR HepsR HmulLe).
	          - assume Hnot: ~(i0 :e I).
	            (** for i0 outside I, inv_nat(ordsucc i0) is small enough so the scaled diff is <= eps **)
	            set yi := apply_fun y i0.
	            set zi := apply_fun z i0.
	            set bd := R_bounded_distance yi zi.
	            set inv := inv_nat (ordsucc i0).
	            claim HyiR: yi :e R.
	            { exact (Romega_coord_in_R y i0 HyX Hi0O). }
	            claim HziR: zi :e R.
	            { exact (Romega_coord_in_R z i0 HzX Hi0O). }
	            claim HyiS: SNo yi.
	            { exact (real_SNo yi HyiR). }
	            claim HziS: SNo zi.
	            { exact (real_SNo zi HziR). }
	            claim HbdR: bd :e R.
	            { exact (R_bounded_distance_in_R yi zi HyiR HziR). }
	            claim HbdS: SNo bd.
	            { exact (real_SNo bd HbdR). }
	            claim HSi0: ordsucc i0 :e omega.
	            { exact (omega_ordsucc i0 Hi0O). }
	            claim HinvR: inv :e R.
	            { exact (inv_nat_real (ordsucc i0) HSi0). }
	            claim HinvS: SNo inv.
	            { exact (real_SNo inv HinvR). }
	            claim HmulR: mul_SNo bd inv :e R.
	            { exact (real_mul_SNo bd HbdR inv HinvR). }
	            (** show inv < eps using antitonicity, since i0 is outside I = ordsucc N **)
	            claim Hi0Ord: ordinal i0.
	            { exact (ordinal_Hered omega omega_ordinal i0 Hi0O). }
	            claim HIdef0: I = ordsucc N.
	            { reflexivity. }
	            claim HNOrd: ordinal N.
	            { exact (ordinal_Hered omega omega_ordinal N HNO). }
	            claim HIOrd: ordinal I.
	            { rewrite HIdef0.
	              exact (ordinal_ordsucc N HNOrd). }
	            claim Hcases: i0 :e I \/ I c= i0.
	            { exact (ordinal_In_Or_Subq i0 I Hi0Ord HIOrd). }
	            claim HIc: I c= i0.
	            { apply (Hcases (I c= i0)).
	              - assume Hi0InI: i0 :e I.
	                apply FalseE.
	                exact (Hnot Hi0InI).
	              - assume Hsub: I c= i0.
	                exact Hsub. }
	            claim HNInI: N :e I.
	            { rewrite HIdef0.
	              exact (ordsuccI2 N). }
	            claim HNi0: N :e i0.
	            { exact (HIc N HNInI). }
	            claim HinvLtN: Rlt (inv_nat (ordsucc i0)) (inv_nat (ordsucc N)).
	            { exact (inv_nat_ordsucc_antitone N i0 HNO Hi0O HNi0). }
	            claim HinvLt: Rlt (inv_nat (ordsucc i0)) eps.
	            { exact (Rlt_tra (inv_nat (ordsucc i0)) (inv_nat (ordsucc N)) eps HinvLtN HinvNLt). }
	            claim HepsS: SNo eps.
	            { exact (real_SNo eps HepsR). }
	            claim HinvLtS: inv < eps.
	            { exact (RltE_lt inv eps HinvLt). }
	            claim HinvLe: inv <= eps.
	            { exact (SNoLtLe inv eps HinvLtS). }
	            (** bound mul by inv since bd <= 1 **)
	            claim HbdLe1R: Rle bd 1.
	            { exact (R_bounded_distance_le_1 yi zi HyiR HziR). }
	            claim HbdLe1: bd <= 1.
	            { apply (SNoLt_trichotomy_or_impred bd 1 HbdS SNo_1 (bd <= 1)).
	              - assume Hlt: bd < 1.
	                exact (SNoLtLe bd 1 Hlt).
	              - assume Heq: bd = 1.
	                rewrite Heq.
	                exact (SNoLe_ref 1).
	              - assume H1lt: 1 < bd.
	                apply FalseE.
	                claim HbdRlt: Rlt 1 bd.
	                { exact (RltI 1 bd real_1 HbdR H1lt). }
	                exact ((RleE_nlt bd 1 HbdLe1R) HbdRlt). }
	            claim HinvPosR: Rlt 0 inv.
	            { set mi := ordsucc i0.
	              claim HmiNotIn0: mi /:e {0}.
	              { assume Hin0: mi :e {0}.
	                claim Heq0: mi = 0.
	                { exact (SingE 0 mi Hin0). }
	                exact (neq_ordsucc_0 i0 Heq0). }
	              claim HmiIn: mi :e omega :\: {0}.
	              { exact (setminusI omega {0} mi HSi0 HmiNotIn0). }
	              exact (inv_nat_pos mi HmiIn). }
	            claim HinvPosS: 0 < inv.
	            { exact (RltE_lt 0 inv HinvPosR). }
	            claim HinvNN: 0 <= inv.
	            { exact (SNoLtLe 0 inv HinvPosS). }
	            claim HmulLeInv: mul_SNo bd inv <= inv.
	            { exact (mul_SNo_Le1_nonneg_Le bd inv HbdS HinvS HbdLe1 HinvNN). }
	            claim HmulS: SNo (mul_SNo bd inv).
	            { exact (real_SNo (mul_SNo bd inv) HmulR). }
	            claim HmulLe: mul_SNo bd inv <= eps.
	            { exact (SNoLe_tra (mul_SNo bd inv) inv eps HmulS HinvS HepsS HmulLeInv HinvLe). }
	            exact (Rle_of_SNoLe (mul_SNo bd inv) eps HmulR HepsR HmulLe). }
	        claim Hle': Rle l eps.
	        { exact (HlubMin eps HepsR Hub). }
	        exact Hle'. }
	      claim HsumLe: Rle (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
	                       (add_SNo (apply_fun d (x,y)) eps).
	      { exact (Rle_add_SNo_2 (apply_fun d (x,y)) (apply_fun d (y,z)) eps HdxyR HdyzR HepsR HdyzLe). }
	      (** show d(x,y) + eps < r using eps < gap and (d(x,y)+gap)=r **)
	      claim HgapLt: Rlt eps gap.
	      { exact HepsLtGap. }
	      claim HsumLt': Rlt (add_SNo (apply_fun d (x,y)) eps) r.
	      { claim HdxyS: SNo (apply_fun d (x,y)).
	        { exact (real_SNo (apply_fun d (x,y)) HdxyR). }
	        claim HepsS: SNo eps.
	        { exact (real_SNo eps HepsR). }
	        claim HrS: SNo r.
	        { exact (real_SNo r HrR). }
	        claim HgapR: gap :e R.
	        { exact (RltE_right eps gap HgapLt). }
	        claim HgapS: SNo gap.
	        { exact (real_SNo gap HgapR). }
	        claim HepsltgapS: eps < gap.
	        { exact (RltE_lt eps gap HgapLt). }
	        claim HsumLtS: add_SNo (apply_fun d (x,y)) eps < add_SNo (apply_fun d (x,y)) gap.
	        { exact (add_SNo_Lt2 (apply_fun d (x,y)) eps gap HdxyS HepsS HgapS HepsltgapS). }
	        claim HgapDef: gap = add_SNo r (minus_SNo (apply_fun d (x,y))).
	        { reflexivity. }
	        claim HsumEq: add_SNo (apply_fun d (x,y)) gap = r.
	        { rewrite HgapDef.
	          claim HmdxyS: SNo (minus_SNo (apply_fun d (x,y))).
	          { exact (SNo_minus_SNo (apply_fun d (x,y)) HdxyS). }
	          rewrite (add_SNo_assoc (apply_fun d (x,y)) r (minus_SNo (apply_fun d (x,y)))
	                               HdxyS HrS HmdxyS).
	          claim Hcom: add_SNo (apply_fun d (x,y)) r = add_SNo r (apply_fun d (x,y)).
	          { exact (add_SNo_com (apply_fun d (x,y)) r HdxyS HrS). }
	          rewrite Hcom at 1.
	          rewrite <- (add_SNo_assoc r (apply_fun d (x,y)) (minus_SNo (apply_fun d (x,y)))
	                                HrS HdxyS HmdxyS).
	          rewrite (add_SNo_minus_SNo_rinv (apply_fun d (x,y)) HdxyS).
	          rewrite (add_SNo_0R r HrS).
	          reflexivity. }
	        claim HsumLtS2: add_SNo (apply_fun d (x,y)) eps < r.
	        { rewrite <- HsumEq.
	          exact HsumLtS. }
	        claim HsumR: add_SNo (apply_fun d (x,y)) eps :e R.
	        { exact (real_add_SNo (apply_fun d (x,y)) HdxyR eps HepsR). }
	        exact (RltI (add_SNo (apply_fun d (x,y)) eps) r HsumR HrR HsumLtS2). }
	      claim HsumLt: Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))) r.
	      { exact (Rle_Rlt_tra (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
	                           (add_SNo (apply_fun d (x,y)) eps)
	                           r
	                           HsumLe
	                           HsumLt'). }
	      claim HdxzLt: Rlt (apply_fun d (x,z)) r.
	      { exact (Rle_Rlt_tra (apply_fun d (x,z))
	                           (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
	                           r
	                           Htri
	                           HsumLt). }
	      exact (open_ballI X d x r z HzX HdxzLt). }
  apply HexF.
  let F. assume HFcore.
  claim HFleft: F :e finite_subcollections S /\ y :e intersection_of_family X F.
  { apply HFcore.
    assume HFleft HFsub.
    exact HFleft. }
  claim HFsub: intersection_of_family X F c= open_ball X d x r.
  { apply HFcore.
    assume HFleft HFsub.
    exact HFsub. }
  claim HF: F :e finite_subcollections S.
  { apply HFleft.
    assume HF HyIn.
    exact HF. }
  claim HyIn: y :e intersection_of_family X F.
  { apply HFleft.
    assume HF HyIn.
    exact HyIn. }
  witness (intersection_of_family X F).
  apply andI.
  - prove intersection_of_family X F :e B.
	    claim Hnon: intersection_of_family X F <> Empty.
	    { assume Heq: intersection_of_family X F = Empty.
	      prove False.
	      claim HyE: y :e Empty.
	      { rewrite <- Heq.
	        exact HyIn. }
	      exact (EmptyE y HyE). }
    exact (finite_intersection_in_basis X S F HF Hnon).
  - apply andI.
    + exact HyIn.
    + exact HFsub.
Qed.

(** helper: cylinder subbasis sets are open in the D metric topology **)
(** LATEX VERSION: For the D metric, each cylinder set fixing one coordinate to be in an open interval is D-metric-open. **)
Theorem Romega_product_cylinder_in_D_metric_topology : forall i U:set,
  metric_on R_omega_space Romega_D_metric ->
  i :e omega -> U :e R_standard_topology ->
  product_cylinder omega (const_space_family omega R R_standard_topology) i U :e Romega_D_metric_topology.
let i U.
assume Hm: metric_on R_omega_space Romega_D_metric.
assume Hi: i :e omega.
assume HU: U :e R_standard_topology.
set Xi0 := const_space_family omega R R_standard_topology.
set C := product_cylinder omega Xi0 i U.
set X := R_omega_space.
set d := Romega_D_metric.
claim HXeq: X = product_space omega Xi0.
{ reflexivity. }
set Tm := metric_topology X d.
set B := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
claim HTm: topology_on X Tm.
{ exact (metric_topology_is_topology X d Hm). }
prove C :e Tm.
claim HTdef: Tm = generated_topology X B.
{ reflexivity. }
rewrite HTdef.
prove C :e generated_topology X B.
claim Hgendef: generated_topology X B =
  {U0 :e Power X | forall x :e U0, exists b :e B, x :e b /\ b c= U0}.
{ reflexivity. }
rewrite Hgendef.
apply SepI.
- prove C :e Power X.
  apply PowerI.
  let f. assume HfC: f :e C.
  prove f :e X.
  rewrite HXeq.
  exact (SepE1 (product_space omega Xi0)
               (fun g0:set => i :e omega /\ U :e space_family_topology Xi0 i /\ apply_fun g0 i :e U)
               f HfC).
- let f. assume HfC: f :e C.
  prove exists b :e B, f :e b /\ b c= C.
  claim HfX: f :e X.
  { rewrite HXeq.
    exact (SepE1 (product_space omega Xi0)
                 (fun g0:set => i :e omega /\ U :e space_family_topology Xi0 i /\ apply_fun g0 i :e U)
                 f HfC). }
  claim Hfprop: i :e omega /\ U :e space_family_topology Xi0 i /\ apply_fun f i :e U.
  { exact (SepE2 (product_space omega Xi0)
                 (fun g0:set => i :e omega /\ U :e space_family_topology Xi0 i /\ apply_fun g0 i :e U)
                 f HfC). }
  claim Hcore: i :e omega /\ U :e space_family_topology Xi0 i.
  { exact (andEL (i :e omega /\ U :e space_family_topology Xi0 i) (apply_fun f i :e U) Hfprop). }
  claim HfiU: apply_fun f i :e U.
  { exact (andER (i :e omega /\ U :e space_family_topology Xi0 i) (apply_fun f i :e U) Hfprop). }
  claim HUpow: U :e Power R.
  { exact (SepE1 (Power R)
                 (fun U0:set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                 U HU). }
  claim HUneigh: forall x0 :e U, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U.
  { exact (SepE2 (Power R)
                 (fun U0:set => forall x0 :e U0, exists b0 :e R_standard_basis, x0 :e b0 /\ b0 c= U0)
                 U HU). }
  claim Hexb0: exists b0 :e R_standard_basis, apply_fun f i :e b0 /\ b0 c= U.
  { exact (HUneigh (apply_fun f i) HfiU). }
  apply Hexb0.
  let b0. assume Hb0pair. apply Hb0pair.
  assume Hb0Std: b0 :e R_standard_basis.
  assume Hb0prop: apply_fun f i :e b0 /\ b0 c= U.
  claim Hxib0: apply_fun f i :e b0.
  { exact (andEL (apply_fun f i :e b0) (b0 c= U) Hb0prop). }
  claim Hb0subU: b0 c= U.
  { exact (andER (apply_fun f i :e b0) (b0 c= U) Hb0prop). }
  claim Hexa: exists a :e R, b0 :e {open_interval a b|b :e R}.
  { exact (famunionE R (fun a0:set => {open_interval a0 b|b :e R}) b0 Hb0Std). }
  apply Hexa.
  let a. assume Hapair. apply Hapair.
  assume HaR: a :e R.
  assume Hb0fam: b0 :e {open_interval a b|b :e R}.
  claim Hexb: exists b :e R, b0 = open_interval a b.
  { exact (ReplE R (fun b1:set => open_interval a b1) b0 Hb0fam). }
  apply Hexb.
  let b. assume Hbpair. apply Hbpair.
  assume HbR: b :e R.
  assume Hb0eq: b0 = open_interval a b.
  claim Hxib0': apply_fun f i :e open_interval a b.
  { rewrite <- Hb0eq.
    exact Hxib0. }
  claim Hxiprop: Rlt a (apply_fun f i) /\ Rlt (apply_fun f i) b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) (apply_fun f i) Hxib0'). }
  claim Hailt: Rlt a (apply_fun f i).
  { exact (andEL (Rlt a (apply_fun f i)) (Rlt (apply_fun f i) b) Hxiprop). }
  claim Hiltb: Rlt (apply_fun f i) b.
  { exact (andER (Rlt a (apply_fun f i)) (Rlt (apply_fun f i) b) Hxiprop). }
  claim HexBall: exists r0:set, r0 :e R /\ Rlt 0 r0 /\ open_ball X d f r0 c= C.
  { (** choose r0 so that the i coordinate stays in open_interval a b (hence in U) **)
    set xi := apply_fun f i.
    claim HxiR: xi :e R.
    { exact (Romega_coord_in_R f i HfX Hi). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim HxiS: SNo xi.
    { exact (real_SNo xi HxiR). }
    set m1 := add_SNo xi (minus_SNo a).
    set m2 := add_SNo b (minus_SNo xi).
    claim Hm1R: m1 :e R.
    { exact (real_add_SNo xi HxiR (minus_SNo a) (real_minus_SNo a HaR)). }
	    claim Hm2R: m2 :e R.
	    { exact (real_add_SNo b HbR (minus_SNo xi) (real_minus_SNo xi HxiR)). }
	    claim Hm1pos: Rlt 0 m1.
	    { claim Haxlt: a < xi.
	      { exact (RltE_lt a xi Hailt). }
	      claim Hm1posS: 0 < m1.
	      { claim HmaS: SNo (minus_SNo a).
	        { exact (SNo_minus_SNo a HaS). }
	        claim Hlt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) xi.
	        { exact (add_SNo_Lt2 (minus_SNo a) a xi HmaS HaS HxiS Haxlt). }
	        claim H0eq: add_SNo (minus_SNo a) a = 0.
	        { exact (add_SNo_minus_SNo_linv a HaS). }
	        claim Hm1eq: add_SNo (minus_SNo a) xi = m1.
	        { claim Hcom: add_SNo (minus_SNo a) xi = add_SNo xi (minus_SNo a).
	          { exact (add_SNo_com (minus_SNo a) xi HmaS HxiS). }
	          rewrite Hcom.
	          reflexivity. }
	        rewrite <- H0eq at 1.
	        rewrite <- Hm1eq at 1.
	        exact Hlt. }
	      exact (RltI 0 m1 real_0 Hm1R Hm1posS). }
	    claim Hm2pos: Rlt 0 m2.
	    { claim Hxblt: xi < b.
	      { exact (RltE_lt xi b Hiltb). }
	      claim Hm2posS: 0 < m2.
	      { claim HmxiS: SNo (minus_SNo xi).
	        { exact (SNo_minus_SNo xi HxiS). }
	        claim Hlt: add_SNo (minus_SNo xi) xi < add_SNo (minus_SNo xi) b.
	        { exact (add_SNo_Lt2 (minus_SNo xi) xi b HmxiS HxiS HbS Hxblt). }
	        claim H0eq: add_SNo (minus_SNo xi) xi = 0.
	        { exact (add_SNo_minus_SNo_linv xi HxiS). }
	        claim Hm2eq: add_SNo (minus_SNo xi) b = m2.
	        { claim Hcom: add_SNo (minus_SNo xi) b = add_SNo b (minus_SNo xi).
	          { exact (add_SNo_com (minus_SNo xi) b HmxiS HbS). }
	          rewrite Hcom.
	          reflexivity. }
	        rewrite <- H0eq at 1.
	        rewrite <- Hm2eq at 1.
	        exact Hlt. }
	      exact (RltI 0 m2 real_0 Hm2R Hm2posS). }
    claim H1R: 1 :e R.
    { exact real_1. }
    claim H1pos: Rlt 0 1.
    { exact Rlt_0_1. }
    claim Hexr3: exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 m1 /\ Rlt r3 m2 /\ Rlt r3 1 /\ Rlt r3 1.
    { exact (exists_eps_lt_four_pos_Euclid m1 m2 1 1 Hm1R Hm2R H1R H1R Hm1pos Hm2pos H1pos H1pos). }
	    apply Hexr3.
	    let r3.
	    assume Hr3conj: r3 :e R /\ Rlt 0 r3 /\ Rlt r3 m1 /\ Rlt r3 m2 /\ Rlt r3 1 /\ Rlt r3 1.
	    claim Hr3top: ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) /\ Rlt r3 1) /\ Rlt r3 1.
	    { exact Hr3conj. }
	    claim Hr3top1: (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2) /\ Rlt r3 1.
	    { apply Hr3top.
	      assume Hr3top1 Hr3lt1b.
	      exact Hr3top1. }
	    claim Hr3top2: ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1) /\ Rlt r3 m2.
	    { apply Hr3top1.
	      assume Hr3top2 Hr3lt1.
	      exact Hr3top2. }
	    claim Hr3top3: (r3 :e R /\ Rlt 0 r3) /\ Rlt r3 m1.
	    { apply Hr3top2.
	      assume Hr3top3 Hr3m2.
	      exact Hr3top3. }
	    claim Hr3pair: r3 :e R /\ Rlt 0 r3.
	    { apply Hr3top3.
	      assume Hr3pair Hr3m1.
	      exact Hr3pair. }
	    claim Hr3R: r3 :e R.
	    { apply Hr3pair.
	      assume Hr3R Hr3pos.
	      exact Hr3R. }
	    claim Hr3pos: Rlt 0 r3.
	    { apply Hr3pair.
	      assume Hr3R Hr3pos.
	      exact Hr3pos. }
	    claim Hr3lt1b: Rlt r3 1.
	    { apply Hr3top.
	      assume Hr3top1 Hr3lt1b.
	      exact Hr3lt1b. }
	    claim Hr3lt1: Rlt r3 1.
	    { apply Hr3top1.
	      assume Hr3top2 Hr3lt1.
	      exact Hr3lt1. }
	    claim Hr3m2lt: Rlt r3 m2.
	    { apply Hr3top2.
	      assume Hr3top3 Hr3m2lt.
	      exact Hr3m2lt. }
	    claim Hr3m1lt: Rlt r3 m1.
	    { apply Hr3top3.
	      assume Hr3pair Hr3m1lt.
	      exact Hr3m1lt. }
	    set inv := inv_nat (ordsucc i).
	    claim Hisuc: ordsucc i :e omega.
	    { exact (omega_ordsucc i Hi). }
	    claim HsuccNotIn0: ordsucc i /:e {0}.
	    { assume Hin0: ordsucc i :e {0}.
	      claim Heq: ordsucc i = 0.
	      { exact (SingE 0 (ordsucc i) Hin0). }
	      exact (neq_ordsucc_0 i Heq). }
	    claim HiIn: ordsucc i :e omega :\: {0}.
	    { exact (setminusI omega {0} (ordsucc i) Hisuc HsuccNotIn0). }
	    claim HinvR: inv :e R.
	    { exact (inv_nat_real (ordsucc i) Hisuc). }
	    claim HinvPosR: Rlt 0 inv.
	    { exact (inv_nat_pos (ordsucc i) HiIn). }
	    set r0 := mul_SNo r3 inv.
	    claim Hr0R: r0 :e R.
	    { exact (real_mul_SNo r3 Hr3R inv HinvR). }
	    claim Hr0pos: Rlt 0 r0.
	    { claim Hr3S: SNo r3.
	      { exact (real_SNo r3 Hr3R). }
	      claim HinvS: SNo inv.
	      { exact (real_SNo inv HinvR). }
	      claim Hr3posS: 0 < r3.
	      { exact (RltE_lt 0 r3 Hr3pos). }
	      claim HinvPosS: 0 < inv.
	      { exact (RltE_lt 0 inv HinvPosR). }
	      claim Hr0posS: 0 < r0.
	      { exact (mul_SNo_pos_pos r3 inv Hr3S HinvS Hr3posS HinvPosS). }
	      exact (RltI 0 r0 real_0 Hr0R Hr0posS). }
    witness r0.
	    apply andI.
	    - apply andI.
	      + exact Hr0R.
	      + exact Hr0pos.
	    - (** open_ball subset cylinder **)
	      let g. assume Hgball: g :e open_ball X d f r0.
	      prove g :e C.
	      claim HgX: g :e X.
	      { exact (open_ballE1 X d f r0 g Hgball). }
	      claim Hgprod: g :e product_space omega Xi0.
	      { rewrite <- HXeq.
	        exact HgX. }
	      claim HCdef: C =
	        {f0 :e product_space omega Xi0 |
	          (i :e omega /\ U :e space_family_topology Xi0 i) /\ apply_fun f0 i :e U}.
	      { reflexivity. }
		      rewrite HCdef.
		      apply SepI.
		      - exact Hgprod.
			      - (** show (i :e omega /\ U :e space_family_topology Xi0 i) /\ apply_fun g i :e U **)
			        prove (i :e omega /\ U :e space_family_topology Xi0 i) /\ apply_fun g i :e U.
			        claim Hleft: i :e omega /\ U :e space_family_topology Xi0 i.
			        { apply andI.
			          - exact Hi.
			          - claim HTi: space_family_topology Xi0 i = R_standard_topology.
			            { claim Hdef: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
			              { reflexivity. }
			              rewrite Hdef.
			              rewrite (const_space_family_apply omega R R_standard_topology i Hi).
			              exact (tuple_2_1_eq R R_standard_topology). }
			            rewrite HTi.
			            exact HU. }
			        apply (andI (i :e omega /\ U :e space_family_topology Xi0 i) (apply_fun g i :e U)).
			        - exact Hleft.
			        - (** reduce to showing the i-th coordinate stays in the interval neighborhood b0 c= U **)
			          claim HgiR: apply_fun g i :e R.
			          { exact (Romega_coord_in_R g i HgX Hi). }
			          claim Hfgprod: (f,g) :e setprod X X.
			          { exact (tuple_2_setprod_by_pair_Sigma X X f g HfX HgX). }
			          claim Hdapp: apply_fun d (f,g) = Romega_D_metric_value f g.
			          { rewrite (apply_fun_graph (setprod X X)
			                                     (fun p:set => Romega_D_metric_value (p 0) (p 1))
			                                     (f,g)
			                                     Hfgprod).
			            rewrite (tuple_2_0_eq f g).
			            rewrite (tuple_2_1_eq f g).
			            reflexivity. }
			          claim Hltball: Rlt (apply_fun d (f,g)) r0.
			          { exact (open_ballE2 X d f r0 g Hgball). }
			          claim Hltval: Rlt (Romega_D_metric_value f g) r0.
			          { rewrite <- Hdapp.
			            exact Hltball. }
				          claim Habfg: abs_SNo (add_SNo xi (minus_SNo (apply_fun g i))) < r3.
				          { claim Hr0eq: r0 = mul_SNo r3 (inv_nat (ordsucc i)).
				            { reflexivity. }
				            claim Hltval2: Rlt (Romega_D_metric_value f g) (mul_SNo r3 (inv_nat (ordsucc i))).
				            { rewrite <- Hr0eq.
				              exact Hltval. }
				            exact (Romega_D_metric_coord_abs_lt f g i r3 HfX HgX Hi Hr3R Hr3pos Hr3lt1 Hltval2). }
				          claim Hgib: apply_fun g i :e open_interval a b.
				          { set t := add_SNo xi (minus_SNo (apply_fun g i)).
				            claim Hr3S: SNo r3.
				            { exact (real_SNo r3 Hr3R). }
				            claim Hr3posS: 0 < r3.
				            { exact (RltE_lt 0 r3 Hr3pos). }
				            claim Hm1S: SNo m1.
				            { exact (real_SNo m1 Hm1R). }
				            claim Hm2S: SNo m2.
				            { exact (real_SNo m2 Hm2R). }
				            claim Hr3m1ltS: r3 < m1.
				            { exact (RltE_lt r3 m1 Hr3m1lt). }
				            claim Hr3m2ltS: r3 < m2.
				            { exact (RltE_lt r3 m2 Hr3m2lt). }
				            claim HgiS: SNo (apply_fun g i).
				            { exact (real_SNo (apply_fun g i) HgiR). }
				            claim HmtS: SNo (minus_SNo (apply_fun g i)).
				            { exact (SNo_minus_SNo (apply_fun g i) HgiS). }
				            claim HtS: SNo t.
				            { exact (SNo_add_SNo xi (minus_SNo (apply_fun g i)) HxiS HmtS). }
				            claim Htlt: t < r3.
				            { exact (abs_SNo_lt_imp_lt t r3 HtS Hr3S Hr3posS Habfg). }
				            claim Hmtlt: minus_SNo t < r3.
				            { exact (abs_SNo_lt_imp_neg_lt t r3 HtS Hr3S Hr3posS Habfg). }
				            claim HinterDef: open_interval a b = {x0 :e R | Rlt a x0 /\ Rlt x0 b}.
				            { reflexivity. }
				            rewrite HinterDef.
				            apply SepI.
				            - exact HgiR.
				            - prove Rlt a (apply_fun g i) /\ Rlt (apply_fun g i) b.
				              apply andI.
				              + (** a < g_i from xi - g_i < r3 < xi - a **)
				                prove Rlt a (apply_fun g i).
				                claim Htltm1: t < m1.
				                { exact (SNoLt_tra t r3 m1 HtS Hr3S Hm1S Htlt Hr3m1ltS). }
				                claim HmaS: SNo (minus_SNo a).
				                { exact (SNo_minus_SNo a HaS). }
				                claim Htdef: t = add_SNo xi (minus_SNo (apply_fun g i)).
				                { reflexivity. }
				                claim Hm1def: m1 = add_SNo xi (minus_SNo a).
				                { reflexivity. }
				                claim Htltm1': add_SNo xi (minus_SNo (apply_fun g i)) < add_SNo xi (minus_SNo a).
				                { rewrite <- Htdef.
				                  rewrite <- Hm1def.
				                  exact Htltm1. }
				                claim Hneglt: minus_SNo (apply_fun g i) < minus_SNo a.
				                { exact (add_SNo_Lt2_cancel xi (minus_SNo (apply_fun g i)) (minus_SNo a)
				                                          HxiS HmtS HmaS Htltm1'). }
				                claim Hnegneg: minus_SNo (minus_SNo a) < minus_SNo (minus_SNo (apply_fun g i)).
				                { exact (minus_SNo_Lt_contra (minus_SNo (apply_fun g i)) (minus_SNo a) HmtS HmaS Hneglt). }
				                claim Hainv: minus_SNo (minus_SNo a) = a.
				                { exact (minus_SNo_invol a HaS). }
				                claim Hgiinv: minus_SNo (minus_SNo (apply_fun g i)) = apply_fun g i.
				                { exact (minus_SNo_invol (apply_fun g i) HgiS). }
				                claim HaltS: a < apply_fun g i.
				                { rewrite <- Hainv at 1.
				                  rewrite <- Hgiinv.
				                  exact Hnegneg. }
				                exact (RltI a (apply_fun g i) HaR HgiR HaltS).
				              + (** g_i < b from g_i - xi < r3 < b - xi **)
				                prove Rlt (apply_fun g i) b.
				                claim Hmtltm2: minus_SNo t < m2.
				                { exact (SNoLt_tra (minus_SNo t) r3 m2
				                                   (SNo_minus_SNo t HtS) Hr3S Hm2S
				                                   Hmtlt Hr3m2ltS). }
				                claim HmxiS: SNo (minus_SNo xi).
				                { exact (SNo_minus_SNo xi HxiS). }
				                claim Hm2def: m2 = add_SNo b (minus_SNo xi).
				                { reflexivity. }
				                claim Hnegtdistr: minus_SNo t = add_SNo (minus_SNo xi) (minus_SNo (minus_SNo (apply_fun g i))).
				                { exact (minus_add_SNo_distr xi (minus_SNo (apply_fun g i)) HxiS HmtS). }
				                claim Hgiinv2: minus_SNo (minus_SNo (apply_fun g i)) = apply_fun g i.
				                { exact (minus_SNo_invol (apply_fun g i) HgiS). }
				                claim Hnegteq: minus_SNo t = add_SNo (minus_SNo xi) (apply_fun g i).
				                { rewrite <- Hgiinv2 at 2.
				                  exact Hnegtdistr. }
				                claim Hnegteq2: add_SNo (apply_fun g i) (minus_SNo xi) = minus_SNo t.
				                { claim Hcom: add_SNo (minus_SNo xi) (apply_fun g i) = add_SNo (apply_fun g i) (minus_SNo xi).
				                  { exact (add_SNo_com (minus_SNo xi) (apply_fun g i) HmxiS HgiS). }
				                  rewrite <- Hcom.
				                  rewrite <- Hnegteq.
				                  reflexivity. }
				                claim Hineq: add_SNo (apply_fun g i) (minus_SNo xi) < add_SNo b (minus_SNo xi).
				                { rewrite Hnegteq2.
				                  rewrite <- Hm2def.
				                  exact Hmtltm2. }
				                claim HltS: apply_fun g i < b.
				                { exact (add_SNo_Lt1_cancel (apply_fun g i) (minus_SNo xi) b HgiS HmxiS HbS Hineq). }
				                exact (RltI (apply_fun g i) b HgiR HbR HltS). }
			          claim HgiB0: apply_fun g i :e b0.
			          { rewrite Hb0eq.
			            exact Hgib. }
			          exact (Hb0subU (apply_fun g i) HgiB0). }
  apply HexBall.
  let r0. assume Hr0pair.
  apply Hr0pair.
  assume Hr0left Hr0sub.
  apply Hr0left.
  assume Hr0R Hr0pos.
  set bset := open_ball X d f r0.
  witness bset.
  apply andI.
  - prove bset :e B.
    claim HbIn: bset :e {open_ball X d f r|r :e R, Rlt 0 r}.
    { exact (ReplSepI R (fun r:set => Rlt 0 r) (fun r:set => open_ball X d f r) r0 Hr0R Hr0pos). }
    exact (famunionI X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) f bset HfX HbIn).
  - apply andI.
    + prove f :e bset.
      exact (center_in_open_ball X d f r0 Hm HfX Hr0pos).
    + exact Hr0sub.
Qed.

Theorem Romega_D_metric_induces_product_topology :
  metric_on R_omega_space Romega_D_metric /\
  Romega_D_metric_topology = R_omega_product_topology.
prove metric_on R_omega_space Romega_D_metric /\
  Romega_D_metric_topology = R_omega_product_topology.
claim Hm: metric_on R_omega_space Romega_D_metric.
{ (** metric_on part (partial) **)
  prove metric_on R_omega_space Romega_D_metric.
  prove ((((function_on Romega_D_metric (setprod R_omega_space R_omega_space) R /\
           (forall x y:set, x :e R_omega_space -> y :e R_omega_space ->
              apply_fun Romega_D_metric (x,y) = apply_fun Romega_D_metric (y,x))) /\
          (forall x:set, x :e R_omega_space -> apply_fun Romega_D_metric (x,x) = 0)) /\
         (forall x y:set, x :e R_omega_space -> y :e R_omega_space ->
            ~(Rlt (apply_fun Romega_D_metric (x,y)) 0)
            /\ (apply_fun Romega_D_metric (x,y) = 0 -> x = y))) /\
        (forall x y z:set, x :e R_omega_space -> y :e R_omega_space -> z :e R_omega_space ->
           ~(Rlt (add_SNo (apply_fun Romega_D_metric (x,y)) (apply_fun Romega_D_metric (y,z)))
                 (apply_fun Romega_D_metric (x,z))))).
  apply andI.
  + apply andI.
    * apply andI.
      - apply andI.
        { exact Romega_D_metric_function_on. }
        { let x y.
          assume Hx: x :e R_omega_space.
          assume Hy: y :e R_omega_space.
          claim Hxyprod: (x,y) :e setprod R_omega_space R_omega_space.
          { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x y Hx Hy). }
          claim Hyxprod: (y,x) :e setprod R_omega_space R_omega_space.
          { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space y x Hy Hx). }
          rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                                   (fun p:set => Romega_D_metric_value (p 0) (p 1))
                                   (x,y)
                                   Hxyprod).
          rewrite (tuple_2_0_eq x y).
          rewrite (tuple_2_1_eq x y).
          rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                                   (fun p:set => Romega_D_metric_value (p 0) (p 1))
                                   (y,x)
                                   Hyxprod).
          rewrite (tuple_2_0_eq y x).
          rewrite (tuple_2_1_eq y x).
          exact (Romega_D_metric_value_sym x y Hx Hy). }
      - let x.
        assume Hx: x :e R_omega_space.
        claim Hxxprod: (x,x) :e setprod R_omega_space R_omega_space.
        { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x x Hx Hx). }
        rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                                 (fun p:set => Romega_D_metric_value (p 0) (p 1))
                                 (x,x)
                                 Hxxprod).
        rewrite (tuple_2_0_eq x x).
	        rewrite (tuple_2_1_eq x x).
	        exact (Romega_D_metric_value_self_zero x Hx).
	    * let x y.
	      assume Hx: x :e R_omega_space.
	      assume Hy: y :e R_omega_space.
	      apply andI.
	      { claim Hxyprod: (x,y) :e setprod R_omega_space R_omega_space.
	        { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x y Hx Hy). }
	        rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
	                                 (fun p:set => Romega_D_metric_value (p 0) (p 1))
	                                 (x,y)
	                                 Hxyprod).
	        rewrite (tuple_2_0_eq x y).
		        rewrite (tuple_2_1_eq x y).
		        exact (Romega_D_metric_value_nonneg x y Hx Hy). }
		      { assume H0: apply_fun Romega_D_metric (x,y) = 0.
		        claim Hxyprod: (x,y) :e setprod R_omega_space R_omega_space.
		        { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x y Hx Hy). }
		        claim Happ: apply_fun Romega_D_metric (x,y) = Romega_D_metric_value x y.
		        { rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
		                                   (fun p:set => Romega_D_metric_value (p 0) (p 1))
		                                   (x,y)
		                                   Hxyprod).
		          rewrite (tuple_2_0_eq x y).
		          rewrite (tuple_2_1_eq x y).
		          reflexivity. }
		        claim Hval0: Romega_D_metric_value x y = 0.
		        { rewrite <- Happ.
		          exact H0. }
			        claim Hcoord: forall i:set, i :e omega -> apply_fun x i = apply_fun y i.
			        { let i.
			          assume HiO: i :e omega.
			          exact (Romega_D_metric_value_eq0_coord_eq x y Hx Hy Hval0 i HiO). }
			        prove x = y.
			        set Xi0 := const_space_family omega R R_standard_topology.
			        set U0 := space_family_union omega Xi0.
			        claim HxPow: x :e Power (setprod omega U0).
			        { exact (SepE1 (Power (setprod omega U0))
			                       (fun f0:set => (total_function_on f0 omega U0 /\ functional_graph f0) /\
			                         forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi0 j)
			                       x
			                       Hx). }
			        claim HyPow: y :e Power (setprod omega U0).
			        { exact (SepE1 (Power (setprod omega U0))
			                       (fun f0:set => (total_function_on f0 omega U0 /\ functional_graph f0) /\
			                         forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi0 j)
			                       y
			                       Hy). }
			        claim HxSub: x c= setprod omega U0.
			        { exact (PowerE (setprod omega U0) x HxPow). }
			        claim HySub: y c= setprod omega U0.
			        { exact (PowerE (setprod omega U0) y HyPow). }
			        claim HxPack: (total_function_on x omega U0 /\ functional_graph x) /\
			                      forall j:set, j :e omega -> apply_fun x j :e space_family_set Xi0 j.
			        { exact (SepE2 (Power (setprod omega U0))
			                       (fun f0:set => (total_function_on f0 omega U0 /\ functional_graph f0) /\
			                         forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi0 j)
			                       x
			                       Hx). }
			        claim HyPack: (total_function_on y omega U0 /\ functional_graph y) /\
			                      forall j:set, j :e omega -> apply_fun y j :e space_family_set Xi0 j.
			        { exact (SepE2 (Power (setprod omega U0))
			                       (fun f0:set => (total_function_on f0 omega U0 /\ functional_graph f0) /\
			                         forall j:set, j :e omega -> apply_fun f0 j :e space_family_set Xi0 j)
			                       y
			                       Hy). }
			        claim HxCore: total_function_on x omega U0 /\ functional_graph x.
			        { exact (andEL (total_function_on x omega U0 /\ functional_graph x)
			                       (forall j:set, j :e omega -> apply_fun x j :e space_family_set Xi0 j)
			                       HxPack). }
			        claim HyCore: total_function_on y omega U0 /\ functional_graph y.
			        { exact (andEL (total_function_on y omega U0 /\ functional_graph y)
			                       (forall j:set, j :e omega -> apply_fun y j :e space_family_set Xi0 j)
			                       HyPack). }
			        claim HxTot: total_function_on x omega U0.
			        { exact (andEL (total_function_on x omega U0) (functional_graph x) HxCore). }
			        claim HxFG: functional_graph x.
			        { exact (andER (total_function_on x omega U0) (functional_graph x) HxCore). }
			        claim HyTot: total_function_on y omega U0.
			        { exact (andEL (total_function_on y omega U0) (functional_graph y) HyCore). }
			        claim HyFG: functional_graph y.
			        { exact (andER (total_function_on y omega U0) (functional_graph y) HyCore). }
			        apply set_ext.
			        - let p. assume Hp: p :e x.
			          prove p :e y.
			          claim HpXY: p :e setprod omega U0.
			          { exact (HxSub p Hp). }
			          claim Heta: p = (p 0, p 1).
			          { exact (setprod_eta omega U0 p HpXY). }
			          claim Hp0: p 0 :e omega.
			          { exact (ap0_Sigma omega (fun _ : set => U0) p HpXY). }
			          claim Hp1: p 1 :e U0.
			          { exact (ap1_Sigma omega (fun _ : set => U0) p HpXY). }
			          claim Hpair: (p 0, p 1) :e x.
			          { rewrite <- Heta.
			            exact Hp. }
			          claim Happx: apply_fun x (p 0) = (p 1).
			          { exact (functional_graph_apply_fun_eq x (p 0) (p 1) HxFG Hpair). }
			          claim Hxy: apply_fun y (p 0) = apply_fun x (p 0).
			          { symmetry.
			            exact (Hcoord (p 0) Hp0). }
			          claim Happy: apply_fun y (p 0) = (p 1).
			          { rewrite Hxy.
			            exact Happx. }
			          claim Hypair: (p 0, apply_fun y (p 0)) :e y.
			          { exact (total_function_on_apply_fun_in_graph y omega U0 (p 0) HyTot Hp0). }
			          claim Hpeq: (p 0, apply_fun y (p 0)) = (p 0, p 1).
			          { rewrite Happy.
			            reflexivity. }
			          rewrite Heta.
			          rewrite <- Hpeq.
			          exact Hypair.
			        - let p. assume Hp: p :e y.
			          prove p :e x.
			          claim HpXY: p :e setprod omega U0.
			          { exact (HySub p Hp). }
			          claim Heta: p = (p 0, p 1).
			          { exact (setprod_eta omega U0 p HpXY). }
			          claim Hp0: p 0 :e omega.
			          { exact (ap0_Sigma omega (fun _ : set => U0) p HpXY). }
			          claim Hp1: p 1 :e U0.
			          { exact (ap1_Sigma omega (fun _ : set => U0) p HpXY). }
			          claim Hpair: (p 0, p 1) :e y.
			          { rewrite <- Heta.
			            exact Hp. }
			          claim Happy: apply_fun y (p 0) = (p 1).
			          { exact (functional_graph_apply_fun_eq y (p 0) (p 1) HyFG Hpair). }
			          claim Hyx: apply_fun x (p 0) = apply_fun y (p 0).
			          { exact (Hcoord (p 0) Hp0). }
			          claim Happx: apply_fun x (p 0) = (p 1).
			          { rewrite Hyx.
			            exact Happy. }
			          claim Hxpair: (p 0, apply_fun x (p 0)) :e x.
			          { exact (total_function_on_apply_fun_in_graph x omega U0 (p 0) HxTot Hp0). }
			          claim Hpeq: (p 0, apply_fun x (p 0)) = (p 0, p 1).
			          { rewrite Happx.
			            reflexivity. }
			          rewrite Heta.
			          rewrite <- Hpeq.
			          exact Hxpair. }
				  + let x y z.
				    assume Hx: x :e R_omega_space.
				    assume Hy: y :e R_omega_space.
				    assume Hz: z :e R_omega_space.
				    claim Hxyprod: (x,y) :e setprod R_omega_space R_omega_space.
				    { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x y Hx Hy). }
				    claim Hyzprod: (y,z) :e setprod R_omega_space R_omega_space.
				    { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space y z Hy Hz). }
				    claim Hxzprod: (x,z) :e setprod R_omega_space R_omega_space.
				    { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space x z Hx Hz). }
				    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
				                             (fun p:set => Romega_D_metric_value (p 0) (p 1))
				                             (x,y)
				                             Hxyprod).
				    rewrite (tuple_2_0_eq x y).
				    rewrite (tuple_2_1_eq x y).
				    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
				                             (fun p:set => Romega_D_metric_value (p 0) (p 1))
				                             (y,z)
				                             Hyzprod).
				    rewrite (tuple_2_0_eq y z).
				    rewrite (tuple_2_1_eq y z).
				    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
				                             (fun p:set => Romega_D_metric_value (p 0) (p 1))
				                             (x,z)
				                             Hxzprod).
				    rewrite (tuple_2_0_eq x z).
				    rewrite (tuple_2_1_eq x z).
				    exact (Romega_D_metric_value_triangle x y z Hx Hy Hz).
}
apply andI.
- exact Hm.
- (** topology equality part **)
  prove Romega_D_metric_topology = R_omega_product_topology.
  apply set_ext.
  + let U. assume HU: U :e Romega_D_metric_topology.
    prove U :e R_omega_product_topology.
    set X := R_omega_space.
    set d := Romega_D_metric.
    set B := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
    claim HTprod: topology_on X R_omega_product_topology.
    { exact Romega_product_topology_is_topology. }
    claim Hballsub: forall b :e B, b :e R_omega_product_topology.
    { let b. assume HbB: b :e B.
      apply (famunionE_impred X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) b HbB
             (b :e R_omega_product_topology)).
      let x0. assume Hx0X: x0 :e X.
      assume HbIn: b :e {open_ball X d x0 r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x0 r0) b HbIn
             (b :e R_omega_product_topology)).
      let r0. assume Hr0R: r0 :e R.
      assume Hr0pos: Rlt 0 r0.
      assume Hbeq: b = open_ball X d x0 r0.
      rewrite Hbeq.
      exact (Romega_D_metric_open_ball_in_product_topology x0 r0 Hm Hx0X Hr0R Hr0pos). }
    claim Hfiner: finer_than R_omega_product_topology (generated_topology X B).
    { exact (generated_topology_finer_weak X B R_omega_product_topology HTprod Hballsub). }
    claim Hinc: generated_topology X B c= R_omega_product_topology.
    { exact Hfiner. }
    claim Hdef: Romega_D_metric_topology = generated_topology X B.
    { reflexivity. }
    claim HUgen: U :e generated_topology X B.
    { rewrite <- Hdef.
      exact HU. }
    exact (Hinc U HUgen).
  + let U. assume HU: U :e R_omega_product_topology.
    prove U :e Romega_D_metric_topology.
    set X := R_omega_space.
    set d := Romega_D_metric.
    set Xi0 := const_space_family omega R R_standard_topology.
    set S := product_subbasis_full omega Xi0.
    claim HdefProd: R_omega_product_topology = generated_topology_from_subbasis X S.
    { reflexivity. }
    claim Hone: omega <> Empty.
    { claim H0o: 0 :e omega.
      { exact (nat_p_omega 0 nat_0). }
      exact (elem_implies_nonempty omega 0 H0o). }
    claim Hcomp: forall i:set, i :e omega -> topology_on (space_family_set Xi0 i) (space_family_topology Xi0 i).
    { let i. assume Hi: i :e omega.
      claim HXi: apply_fun Xi0 i = (R, R_standard_topology).
      { exact (const_space_family_apply omega R R_standard_topology i Hi). }
      claim Hset: space_family_set Xi0 i = R.
      { claim Hdef: space_family_set Xi0 i = (apply_fun Xi0 i) 0.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_0_eq R R_standard_topology). }
      claim Htop: topology_on R R_standard_topology.
      { exact R_standard_topology_is_topology. }
      rewrite Hset.
      claim HtopEq: space_family_topology Xi0 i = R_standard_topology.
      { claim Hdef: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_1_eq R R_standard_topology). }
      rewrite HtopEq.
      exact Htop. }
    claim HSsub: subbasis_on X S.
    { exact (product_subbasis_full_subbasis_on omega Xi0 Hone Hcomp). }
    claim HTm: topology_on X Romega_D_metric_topology.
    { exact (metric_topology_is_topology X d Hm). }
    claim HSc: S c= Romega_D_metric_topology.
    { let s. assume HsS: s :e S.
      prove s :e Romega_D_metric_topology.
      apply (famunionE_impred omega (fun i:set => {product_cylinder omega Xi0 i U|U :e space_family_topology Xi0 i})
              s HsS (s :e Romega_D_metric_topology)).
      let i. assume Hi: i :e omega.
      assume Hsi: s :e {product_cylinder omega Xi0 i U|U :e space_family_topology Xi0 i}.
      apply (ReplE_impred (space_family_topology Xi0 i) (fun U0:set => product_cylinder omega Xi0 i U0) s Hsi).
      let U0. assume HU0Top: U0 :e space_family_topology Xi0 i.
      assume Hseq: s = product_cylinder omega Xi0 i U0.
      rewrite Hseq.
      claim HtopEq: space_family_topology Xi0 i = R_standard_topology.
      { claim HXi: apply_fun Xi0 i = (R, R_standard_topology).
        { exact (const_space_family_apply omega R R_standard_topology i Hi). }
        claim Hdef: space_family_topology Xi0 i = (apply_fun Xi0 i) 1.
        { reflexivity. }
        rewrite Hdef.
        rewrite HXi.
        exact (tuple_2_1_eq R R_standard_topology). }
      claim HU0std: U0 :e R_standard_topology.
      { rewrite <- HtopEq.
        exact HU0Top. }
      exact (Romega_product_cylinder_in_D_metric_topology i U0 Hm Hi HU0std). }
    claim Hmin: finer_than Romega_D_metric_topology (generated_topology_from_subbasis X S).
    { exact (topology_generated_by_basis_is_minimal X S Romega_D_metric_topology HSsub HTm HSc). }
    claim Hinc: generated_topology_from_subbasis X S c= Romega_D_metric_topology.
    { exact Hmin. }
    claim HUgen: U :e generated_topology_from_subbasis X S.
    { rewrite <- HdefProd.
      exact HU. }
    exact (Hinc U HUgen).
 	Qed.



(** LATEX VERSION: Open cover and Lindelöf space definitions. **)
Definition open_cover : set -> set -> set -> prop :=
  fun X Tx U => (forall u:set, u :e U -> u :e Tx) /\ covers X U.

(** helper: open cover members are subsets of X **)
(** LATEX VERSION: If U is an open cover of X in Tx, then U ⊂ P(X). **)
Theorem open_cover_family_sub : forall X Tx U:set,
  topology_on X Tx ->
  open_cover X Tx U ->
  U c= Power X.
let X Tx U.
assume HTx: topology_on X Tx.
assume Hcover: open_cover X Tx U.
prove U c= Power X.
let u. assume HuU: u :e U.
prove u :e Power X.
claim HuTx: u :e Tx.
{ exact (andEL (forall u0:set, u0 :e U -> u0 :e Tx) (covers X U) Hcover u HuU). }
exact (topology_subset_axiom X Tx HTx u HuTx).
Qed.
Definition Lindelof_space : set -> set -> prop :=
  fun X Tx => topology_on X Tx /\ forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
(** LATEX VERSION: Sorgenfrey line and its lower limit topology. **)
Definition Sorgenfrey_line : set := R.
Definition Sorgenfrey_topology : set := R_lower_limit_topology.

(** helper: the Sorgenfrey (lower limit) topology on R is Hausdorff **)
(** LATEX VERSION: The Sorgenfrey line is Hausdorff; distinct points can be separated by half-open intervals. **)
Theorem R_lower_limit_topology_Hausdorff : Hausdorff_space R R_lower_limit_topology.
prove Hausdorff_space R R_lower_limit_topology.
prove topology_on R R_lower_limit_topology /\
  forall x1 x2:set, x1 :e R -> x2 :e R -> x1 <> x2 ->
    exists U V:set, U :e R_lower_limit_topology /\ V :e R_lower_limit_topology /\
      x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact R_lower_limit_topology_is_topology.
- let x1 x2.
  assume Hx1R: x1 :e R.
  assume Hx2R: x2 :e R.
  assume Hneq: x1 <> x2.
  prove exists U V:set, U :e R_lower_limit_topology /\ V :e R_lower_limit_topology /\
    x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  claim Hx1S: SNo x1.
  { exact (real_SNo x1 Hx1R). }
  claim Hx2S: SNo x2.
  { exact (real_SNo x2 Hx2R). }
  apply (SNoLt_trichotomy_or_impred x1 x2 Hx1S Hx2S
    (exists U V:set, U :e R_lower_limit_topology /\ V :e R_lower_limit_topology /\
      x1 :e U /\ x2 :e V /\ U :/\: V = Empty)).
  - assume Hlt: x1 < x2.
    set U := halfopen_interval_left x1 x2.
    set b := add_SNo x2 1.
    claim HbR: b :e R.
    { exact (real_add_SNo x2 Hx2R 1 real_1). }
    set V := halfopen_interval_left x2 b.
    witness U.
    witness V.
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x1 x2 Hx1R Hx2R). }
    claim HVopen: V :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x2 b Hx2R HbR). }
    claim Hx1U: x1 :e U.
    { prove x1 :e {x :e R | ~(Rlt x x1) /\ Rlt x x2}.
      apply SepI.
      - exact Hx1R.
      - exact (andI (~(Rlt x1 x1)) (Rlt x1 x2)
                    (not_Rlt_refl x1 Hx1R)
                    (RltI x1 x2 Hx1R Hx2R Hlt)). }
    claim Hx2ltb: x2 < b.
    { claim H0lt1: 0 < 1.
      { exact SNoLt_0_1. }
      claim Hx20: add_SNo x2 0 = x2.
      { exact (add_SNo_0R x2 Hx2S). }
      claim Hx2lt: add_SNo x2 0 < add_SNo x2 1.
      { exact (add_SNo_Lt2 x2 0 1 Hx2S SNo_0 SNo_1 H0lt1). }
      prove x2 < b.
      (** b = add_SNo x2 1; rewrite the goal to use Hx2lt **)
      rewrite <- Hx20 at 1.
      exact Hx2lt. }
    claim Hx2V: x2 :e V.
    { prove x2 :e {x :e R | ~(Rlt x x2) /\ Rlt x b}.
      apply SepI.
      - exact Hx2R.
      - exact (andI (~(Rlt x2 x2)) (Rlt x2 b)
                    (not_Rlt_refl x2 Hx2R)
                    (RltI x2 b Hx2R HbR Hx2ltb)). }
    claim HUVempty: U :/\: V = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e U :/\: V.
      prove z :e Empty.
      claim HzU: z :e U.
      { exact (binintersectE1 U V z Hz). }
      claim HzV: z :e V.
      { exact (binintersectE2 U V z Hz). }
      claim HzUprop: ~(Rlt z x1) /\ Rlt z x2.
      { exact (SepE2 R (fun x:set => ~(Rlt x x1) /\ Rlt x x2) z HzU). }
      claim HzVprop: ~(Rlt z x2) /\ Rlt z b.
      { exact (SepE2 R (fun x:set => ~(Rlt x x2) /\ Rlt x b) z HzV). }
      claim Hzltx2: Rlt z x2.
      { exact (andER (~(Rlt z x1)) (Rlt z x2) HzUprop). }
      claim Hznltx2: ~(Rlt z x2).
      { exact (andEL (~(Rlt z x2)) (Rlt z b) HzVprop). }
      apply FalseE.
      exact (Hznltx2 Hzltx2). }
    apply and5I.
    - exact HUopen.
    - exact HVopen.
    - exact Hx1U.
    - exact Hx2V.
    - exact HUVempty.
  - assume Heq: x1 = x2.
    apply FalseE.
    exact (Hneq Heq).
  - assume Hgt: x2 < x1.
    (** symmetric, swapping x1 and x2 **)
    set U := halfopen_interval_left x2 x1.
    set b := add_SNo x1 1.
    claim HbR: b :e R.
    { exact (real_add_SNo x1 Hx1R 1 real_1). }
    set V := halfopen_interval_left x1 b.
    witness V.
    witness U.
    claim HVopen: V :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x1 b Hx1R HbR). }
    claim HUopen: U :e R_lower_limit_topology.
    { exact (halfopen_interval_left_in_R_lower_limit_topology x2 x1 Hx2R Hx1R). }
    claim Hx2U: x2 :e U.
    { prove x2 :e {x :e R | ~(Rlt x x2) /\ Rlt x x1}.
      apply SepI.
      - exact Hx2R.
      - exact (andI (~(Rlt x2 x2)) (Rlt x2 x1)
                    (not_Rlt_refl x2 Hx2R)
                    (RltI x2 x1 Hx2R Hx1R Hgt)). }
    claim Hx1ltb: x1 < b.
    { claim H0lt1: 0 < 1.
      { exact SNoLt_0_1. }
      claim Hx10: add_SNo x1 0 = x1.
      { exact (add_SNo_0R x1 Hx1S). }
      claim Hx1lt: add_SNo x1 0 < add_SNo x1 1.
      { exact (add_SNo_Lt2 x1 0 1 Hx1S SNo_0 SNo_1 H0lt1). }
      prove x1 < b.
      (** b = add_SNo x1 1; rewrite the goal to use Hx1lt **)
      rewrite <- Hx10 at 1.
      exact Hx1lt. }
    claim Hx1V: x1 :e V.
    { prove x1 :e {x :e R | ~(Rlt x x1) /\ Rlt x b}.
      apply SepI.
      - exact Hx1R.
      - exact (andI (~(Rlt x1 x1)) (Rlt x1 b)
                    (not_Rlt_refl x1 Hx1R)
                    (RltI x1 b Hx1R HbR Hx1ltb)). }
    claim HUVempty: V :/\: U = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e V :/\: U.
      prove z :e Empty.
      claim HzV: z :e V.
      { exact (binintersectE1 V U z Hz). }
      claim HzU: z :e U.
      { exact (binintersectE2 V U z Hz). }
      claim HzVprop: ~(Rlt z x1) /\ Rlt z b.
      { exact (SepE2 R (fun x:set => ~(Rlt x x1) /\ Rlt x b) z HzV). }
      claim HzUprop: ~(Rlt z x2) /\ Rlt z x1.
      { exact (SepE2 R (fun x:set => ~(Rlt x x2) /\ Rlt x x1) z HzU). }
      claim Hzltx1: Rlt z x1.
      { exact (andER (~(Rlt z x2)) (Rlt z x1) HzUprop). }
      claim Hznltx1: ~(Rlt z x1).
      { exact (andEL (~(Rlt z x1)) (Rlt z b) HzVprop). }
      apply FalseE.
      exact (Hznltx1 Hzltx1). }
    apply and5I.
    - exact HVopen.
    - exact HUopen.
    - exact Hx1V.
    - exact Hx2U.
    - exact HUVempty.
Qed.

(** helper: Sorgenfrey_line is Hausdorff **)
(** LATEX VERSION: The Sorgenfrey line (R_l) is Hausdorff. **)
Theorem Sorgenfrey_line_Hausdorff : Hausdorff_space Sorgenfrey_line Sorgenfrey_topology.
prove Hausdorff_space Sorgenfrey_line Sorgenfrey_topology.
exact R_lower_limit_topology_Hausdorff.
Qed.


(** LATEX VERSION: Countable basis at x (Definition 30.1). **)
(** FIXED: countable_basis_at uses a countable local basis B c= Tx at x, not a global basis_on X B; avoids collapsing first countable into second countable. **)
Definition countable_basis_at : set -> set -> set -> prop := fun X Tx x =>
  topology_on X Tx /\ x :e X /\
  exists B:set, B c= Tx /\ countable_set B /\
    (forall b:set, b :e B -> x :e b) /\
    (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).

(** from §30 Definition 30.1: first-countable space **) 
(** LATEX VERSION: First countable means each point has a countable neighborhood basis. **)
Definition first_countable_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\ forall x:set, x :e X -> countable_basis_at X Tx x.

(** helper: monotonicity of metric open balls in the radius **)
Theorem open_ball_radius_mono : forall X d x r1 r2:set,
  Rlt r1 r2 -> open_ball X d x r1 c= open_ball X d x r2.
let X d x r1 r2.
assume Hr: Rlt r1 r2.
let y. assume Hy: y :e open_ball X d x r1.
prove y :e open_ball X d x r2.
claim HyX: y :e X.
{ exact (open_ballE1 X d x r1 y Hy). }
claim Hdlt: Rlt (apply_fun d (x,y)) r1.
{ exact (open_ballE2 X d x r1 y Hy). }
claim Hdlt2: Rlt (apply_fun d (x,y)) r2.
{ exact (Rlt_tra (apply_fun d (x,y)) r1 r2 Hdlt Hr). }
exact (open_ballI X d x r2 y HyX Hdlt2).
Qed.

(** helper: metric topology is first countable **)
Theorem metric_topology_first_countable : forall X d:set,
  metric_on X d -> first_countable_space X (metric_topology X d).
let X d.
assume Hm: metric_on X d.
prove first_countable_space X (metric_topology X d).
prove topology_on X (metric_topology X d) /\
  forall x:set, x :e X -> countable_basis_at X (metric_topology X d) x.
apply andI.
- exact (metric_topology_is_topology X d Hm).
- let x. assume Hx: x :e X.
  prove countable_basis_at X (metric_topology X d) x.
  prove topology_on X (metric_topology X d) /\ x :e X /\
    exists B:set, B c= metric_topology X d /\ countable_set B /\
      (forall b:set, b :e B -> x :e b) /\
      (forall U:set, U :e metric_topology X d -> x :e U -> exists b:set, b :e B /\ b c= U).
  apply and3I.
  * exact (metric_topology_is_topology X d Hm).
  * exact Hx.
  * set B := {open_ball X d x (inv_nat (ordsucc n))|n :e omega}.
    witness B.
    apply and4I.
    + (** B c= metric_topology X d **)
      let b. assume Hb: b :e B.
      prove b :e metric_topology X d.
      apply (ReplE_impred omega (fun n:set => open_ball X d x (inv_nat (ordsucc n))) b Hb).
      let n. assume HnOmega: n :e omega.
      assume HbEq: b = open_ball X d x (inv_nat (ordsucc n)).
      rewrite HbEq.
      claim HsuccOmega: ordsucc n :e omega.
      { exact (omega_ordsucc n HnOmega). }
      claim HsuccNonzero: ordsucc n :e omega :\: {0}.
      { apply setminusI.
        - exact HsuccOmega.
        - assume Hmem0: ordsucc n :e {0}.
          claim Heq0: ordsucc n = 0.
          { exact (SingE 0 (ordsucc n) Hmem0). }
          exact (neq_ordsucc_0 n Heq0). }
      claim HinvR: inv_nat (ordsucc n) :e R.
      { exact (inv_nat_real (ordsucc n) HsuccOmega). }
      claim HinvPos: Rlt 0 (inv_nat (ordsucc n)).
      { exact (inv_nat_pos (ordsucc n) HsuccNonzero). }
      exact (open_ball_in_metric_topology X d x (inv_nat (ordsucc n)) Hm Hx HinvPos).
    + (** countable_set B **)
      claim HomegaCount: countable_set omega.
      { prove countable_set omega.
        prove countable omega.
        exact (Subq_atleastp omega omega (Subq_ref omega)). }
      exact (countable_image omega HomegaCount (fun n:set => open_ball X d x (inv_nat (ordsucc n)))).
    + (** every b in B contains x **)
      let b. assume Hb: b :e B.
      prove x :e b.
      apply (ReplE_impred omega (fun n:set => open_ball X d x (inv_nat (ordsucc n))) b Hb).
      let n. assume HnOmega: n :e omega.
      assume HbEq: b = open_ball X d x (inv_nat (ordsucc n)).
      rewrite HbEq.
      claim HsuccOmega: ordsucc n :e omega.
      { exact (omega_ordsucc n HnOmega). }
      claim HsuccNonzero: ordsucc n :e omega :\: {0}.
      { apply setminusI.
        - exact HsuccOmega.
        - assume Hmem0: ordsucc n :e {0}.
          claim Heq0: ordsucc n = 0.
          { exact (SingE 0 (ordsucc n) Hmem0). }
          exact (neq_ordsucc_0 n Heq0). }
      claim HinvR: inv_nat (ordsucc n) :e R.
      { exact (inv_nat_real (ordsucc n) HsuccOmega). }
      claim HinvPos: Rlt 0 (inv_nat (ordsucc n)).
      { exact (inv_nat_pos (ordsucc n) HsuccNonzero). }
      exact (center_in_open_ball X d x (inv_nat (ordsucc n)) Hm Hx HinvPos).
	    + (** local refinement: for any open U containing x, find b in B with b c= U **)
	      let U. assume HU: U :e metric_topology X d.
	      assume HxU: x :e U.
	      prove exists b:set, b :e B /\ b c= U.
	      (** get a ball around x contained in U **)
	      claim Hex: exists r :e R, Rlt 0 r /\ open_ball X d x r c= U.
	      { set B0 := famunion X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r}).
	        claim Hdef: metric_topology X d = generated_topology X B0.
	        { reflexivity. }
	        claim HUgen: U :e generated_topology X B0.
	        { prove U :e generated_topology X B0.
	          rewrite <- Hdef.
	          exact HU. }
	        claim HUcond: forall y :e U, exists b0 :e B0, y :e b0 /\ b0 c= U.
	        { exact (SepE2 (Power X)
	                       (fun U0:set => forall y:set, y :e U0 -> exists b0 :e B0, y :e b0 /\ b0 c= U0)
	                       U HUgen). }
	        claim Hexb0: exists b0 :e B0, x :e b0 /\ b0 c= U.
	        { exact (HUcond x HxU). }
	        apply Hexb0.
	        let b0. assume Hb0pair.
	        claim Hb0B0: b0 :e B0.
	        { exact (andEL (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair). }
	        claim Hxinb0: x :e b0.
	        { exact (andEL (x :e b0) (b0 c= U) (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
	        claim Hb0sub: b0 c= U.
	        { exact (andER (x :e b0) (b0 c= U) (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
	        apply (famunionE_impred X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r})
	                                b0 Hb0B0
	                                (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
	        let c. assume HcX: c :e X.
	        assume Hb0In: b0 :e {open_ball X d c r|r :e R, Rlt 0 r}.
	        apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0)
	                                b0 Hb0In
	                                (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
	        let r0. assume Hr0R: r0 :e R.
	        assume Hr0pos: Rlt 0 r0.
	        assume Hb0eq: b0 = open_ball X d c r0.
	        claim HxinBall: x :e open_ball X d c r0.
	        { rewrite <- Hb0eq.
	          exact Hxinb0. }
	        claim HballsubU: open_ball X d c r0 c= U.
	        { prove open_ball X d c r0 c= U.
	          rewrite <- Hb0eq.
	          exact Hb0sub. }
	        claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r0.
	        { exact (open_ball_refine_center X d c x r0 Hm HcX Hx Hr0R Hr0pos HxinBall). }
	        apply Hexs.
	        let s. assume Hs.
	        claim HsRpos: s :e R /\ Rlt 0 s.
	        { exact (andEL (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
	        claim HsR: s :e R.
	        { exact (andEL (s :e R) (Rlt 0 s) HsRpos). }
	        claim Hspos: Rlt 0 s.
	        { exact (andER (s :e R) (Rlt 0 s) HsRpos). }
	        claim HsubBall: open_ball X d x s c= open_ball X d c r0.
	        { exact (andER (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
	        claim HsubU: open_ball X d x s c= U.
	        { exact (Subq_tra (open_ball X d x s) (open_ball X d c r0) U HsubBall HballsubU). }
	        witness s.
	        apply andI.
	        - exact HsR.
	        - apply andI.
	          + exact Hspos.
	          + exact HsubU. }
	      apply Hex.
	      let r. assume Hrp: r :e R /\ (Rlt 0 r /\ open_ball X d x r c= U).
	      claim HrR: r :e R.
	      { exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrp). }
      claim Hrprop: Rlt 0 r /\ open_ball X d x r c= U.
      { exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrp). }
      claim H0lt: Rlt 0 r.
      { exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
      claim Hballsub: open_ball X d x r c= U.
      { exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
      (** pick N with inv_nat (N+1) < r and use radius monotonicity **)
      claim HexN: exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) r.
      { exact (exists_inv_nat_ordsucc_lt r HrR H0lt). }
      apply HexN.
      let N. assume HNpair: N :e omega /\ Rlt (inv_nat (ordsucc N)) r.
      claim HNomega: N :e omega.
      { exact (andEL (N :e omega) (Rlt (inv_nat (ordsucc N)) r) HNpair). }
      claim HinvLt: Rlt (inv_nat (ordsucc N)) r.
      { exact (andER (N :e omega) (Rlt (inv_nat (ordsucc N)) r) HNpair). }
      witness (open_ball X d x (inv_nat (ordsucc N))).
      apply andI.
      - exact (ReplI omega (fun n:set => open_ball X d x (inv_nat (ordsucc n))) N HNomega).
      - claim HsSubS: open_ball X d x (inv_nat (ordsucc N)) c= open_ball X d x r.
        { exact (open_ball_radius_mono X d x (inv_nat (ordsucc N)) r HinvLt). }
        exact (Subq_tra (open_ball X d x (inv_nat (ordsucc N))) (open_ball X d x r) U HsSubS Hballsub).
Qed.

(** helper: uniform topology is first countable **)
Theorem uniform_topology_first_countable : first_countable_space real_sequences uniform_topology.
exact (metric_topology_first_countable real_sequences uniform_metric_Romega uniform_metric_Romega_is_metric).
Qed.

(** helper: countable local basis at a point in a nonempty countable product of first-countable spaces **)
(** LATEX VERSION: The usual product argument produces a countable neighborhood basis at a point. **)
Theorem product_countable_basis_at_point_if_components_first_countable : forall I Xi f:set,
  countable_index_set I ->
  I <> Empty ->
  (forall i:set, i :e I -> first_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
  f :e product_space I Xi ->
  countable_basis_at (product_space I Xi) (countable_product_topology_subbasis I Xi) f.
let I Xi f.
assume HIcount.
assume HIn0.
assume Hcomp.
assume Hf.
prove countable_basis_at (product_space I Xi) (countable_product_topology_subbasis I Xi) f.
set X := product_space I Xi.
set Tx := countable_product_topology_subbasis I Xi.
set Sfull := product_subbasis_full I Xi.
claim Hfprop: total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
              forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i.
{ exact (SepE2 (Power (setprod I (space_family_union I Xi)))
               (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
                 forall i:set, i :e I -> apply_fun f0 i :e space_family_set Xi i)
               f
               Hf). }
claim Hcompf: forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i.
{ exact (andER (total_function_on f I (space_family_union I Xi) /\ functional_graph f)
               (forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i)
               Hfprop). }
claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume HiI: i :e I.
  exact (andEL (topology_on (space_family_set Xi i) (space_family_topology Xi i))
               (forall x:set, x :e space_family_set Xi i -> countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) x)
               (Hcomp i HiI)). }
claim HSfull: subbasis_on X Sfull.
{ exact (product_subbasis_full_subbasis_on I Xi HIn0 HcompTop). }
claim HBasisFull: basis_on X (basis_of_subbasis X Sfull).
{ exact (finite_intersections_basis_of_subbasis X Sfull HSfull). }
claim HTprod: topology_on X Tx.
{ claim HTdef: Tx = generated_topology_from_subbasis X Sfull.
  { reflexivity. }
  rewrite HTdef.
  exact (topology_from_subbasis_is_topology X Sfull HSfull). }

set Bsel : set -> set := fun i =>
  Eps_i (fun B0:set =>
    B0 c= space_family_topology Xi i /\ countable_set B0 /\
      (forall b:set, b :e B0 -> apply_fun f i :e b) /\
      (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e B0 /\ b c= U)).

claim HBsel: forall i:set, i :e I ->
  (Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i) /\
    (forall b:set, b :e (Bsel i) -> apply_fun f i :e b) /\
    (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e (Bsel i) /\ b c= U).
{ let i. assume HiI: i :e I.
  claim Hfc_i: first_countable_space (space_family_set Xi i) (space_family_topology Xi i).
  { exact (Hcomp i HiI). }
  claim Hcb_all: forall x:set, x :e space_family_set Xi i ->
    countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) x.
  { exact (andER (topology_on (space_family_set Xi i) (space_family_topology Xi i))
                 (forall x:set, x :e space_family_set Xi i -> countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) x)
                 Hfc_i). }
  claim Hfi: apply_fun f i :e space_family_set Xi i.
  { exact (Hcompf i HiI). }
  claim Hcbi: countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) (apply_fun f i).
  { exact (Hcb_all (apply_fun f i) Hfi). }
  claim HexB0: exists B0:set,
    B0 c= space_family_topology Xi i /\ countable_set B0 /\
      (forall b:set, b :e B0 -> apply_fun f i :e b) /\
      (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e B0 /\ b c= U).
  { exact (andER (topology_on (space_family_set Xi i) (space_family_topology Xi i) /\ apply_fun f i :e space_family_set Xi i)
                 (exists B0:set,
                   B0 c= space_family_topology Xi i /\ countable_set B0 /\
                     (forall b:set, b :e B0 -> apply_fun f i :e b) /\
                     (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e B0 /\ b c= U))
                 Hcbi). }
  apply HexB0.
  let B0. assume HB0.
  exact (Eps_i_ax (fun B1:set =>
      B1 c= space_family_topology Xi i /\ countable_set B1 /\
        (forall b:set, b :e B1 -> apply_fun f i :e b) /\
        (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e B1 /\ b c= U))
    B0 HB0). }

set Ssmall : set := \/_ i :e I, {product_cylinder I Xi i U|U :e Bsel i}.
set FSsmall := finite_subcollections Ssmall.
set B : set := {intersection_of_family X F0|F0 :e FSsmall}.

claim HSsmall_count: countable_set Ssmall.
{ claim HIc: countable I.
  { exact HIcount. }
  claim HBsel_count: forall i:set, i :e I -> countable (Bsel i).
  { let i. assume HiI: i :e I.
    claim HBi: (Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i) /\
      (forall b:set, b :e (Bsel i) -> apply_fun f i :e b) /\
      (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e (Bsel i) /\ b c= U).
    { exact (HBsel i HiI). }
    claim Hcore: ((Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i)) /\
      (forall b:set, b :e (Bsel i) -> apply_fun f i :e b).
    { exact (andEL (((Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i)) /\
                    (forall b:set, b :e (Bsel i) -> apply_fun f i :e b))
                   (forall U:set, U :e space_family_topology Xi i -> apply_fun f i :e U -> exists b:set, b :e (Bsel i) /\ b c= U)
                   HBi). }
    claim Hpair: (Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i).
    { exact (andEL ((Bsel i) c= space_family_topology Xi i /\ countable_set (Bsel i))
                   (forall b:set, b :e (Bsel i) -> apply_fun f i :e b)
                   Hcore). }
    exact (andER ((Bsel i) c= space_family_topology Xi i) (countable_set (Bsel i)) Hpair). }
  claim HSig: countable (Sigma_ i :e I, Bsel i).
  { exact (Sigma_countable I HIc Bsel HBsel_count). }
  claim HSig_set: countable_set (Sigma_ i :e I, Bsel i).
  { exact HSig. }
  set F : set -> set := fun p => product_cylinder I Xi (p 0) (p 1).
  set Img := {F p|p :e Sigma_ i :e I, Bsel i}.
  claim HImg_count: countable_set Img.
  { exact (countable_image (Sigma_ i :e I, Bsel i) HSig_set F). }
  apply (Subq_countable Ssmall Img).
  - exact HImg_count.
  - let s. assume Hs: s :e Ssmall.
    prove s :e Img.
    apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s Hs).
    let i0. assume Hi0I: i0 :e I.
    assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
    apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
    let U0. assume HU0B: U0 :e Bsel i0.
    assume HsEq: s = product_cylinder I Xi i0 U0.
    claim HpSig: (i0,U0) :e Sigma_ i :e I, Bsel i.
    { exact (tuple_2_Sigma I Bsel i0 Hi0I U0 HU0B). }
    claim HFp: F (i0,U0) = product_cylinder I Xi i0 U0.
    { claim HFdef: F (i0,U0) = product_cylinder I Xi ((i0,U0) 0) ((i0,U0) 1).
      { reflexivity. }
      rewrite HFdef.
      rewrite (tuple_2_0_eq i0 U0).
      rewrite (tuple_2_1_eq i0 U0).
      reflexivity. }
    rewrite HsEq.
    rewrite <- HFp.
    exact (ReplI (Sigma_ i :e I, Bsel i) F (i0,U0) HpSig). }

claim HFSsmall: countable_set FSsmall.
{ exact (finite_subcollections_countable Ssmall HSsmall_count). }
claim HBcount: countable_set B.
{ exact (countable_image FSsmall HFSsmall (fun F0:set => intersection_of_family X F0)). }

claim HSsmall_in_Tx: forall s:set, s :e Ssmall -> s :e Tx.
{ let s. assume Hs: s :e Ssmall.
  apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s Hs).
  let i0. assume Hi0I: i0 :e I.
  assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
  apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
  let U0. assume HU0B: U0 :e Bsel i0.
  assume HsEq: s = product_cylinder I Xi i0 U0.
  claim HBU0: (Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0) /\
    (forall b:set, b :e (Bsel i0) -> apply_fun f i0 :e b) /\
    (forall V:set, V :e space_family_topology Xi i0 -> apply_fun f i0 :e V -> exists b:set, b :e (Bsel i0) /\ b c= V).
  { exact (HBsel i0 Hi0I). }
  claim Hcore: ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
    (forall b:set, b :e (Bsel i0) -> apply_fun f i0 :e b).
  { exact (andEL (((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
                  (forall b:set, b :e (Bsel i0) -> apply_fun f i0 :e b))
                 (forall V:set, V :e space_family_topology Xi i0 -> apply_fun f i0 :e V -> exists b:set, b :e (Bsel i0) /\ b c= V)
                 HBU0). }
  claim HsubTop: (Bsel i0) c= space_family_topology Xi i0.
  { exact (andEL ((Bsel i0) c= space_family_topology Xi i0)
                 (countable_set (Bsel i0))
                 (andEL ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
                        (forall b:set, b :e (Bsel i0) -> apply_fun f i0 :e b)
                        Hcore)). }
  claim HU0Top: U0 :e space_family_topology Xi i0.
  { exact (HsubTop U0 HU0B). }
  set cyl := product_cylinder I Xi i0 U0.
  claim HcylSfull: cyl :e Sfull.
  { exact (famunionI I (fun i1:set => {product_cylinder I Xi i1 U|U :e space_family_topology Xi i1})
                   i0 cyl Hi0I (ReplI (space_family_topology Xi i0) (fun U:set => product_cylinder I Xi i0 U) U0 HU0Top)). }
  claim HfiU0: apply_fun f i0 :e U0.
  { exact ((andER ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
                  (forall b:set, b :e (Bsel i0) -> apply_fun f i0 :e b)
                  Hcore) U0 HU0B). }
  claim HfCyl: f :e cyl.
  { exact (SepI X (fun f0:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e U0)
               f Hf (andI (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun f i0 :e U0)
                        (andI (i0 :e I) (U0 :e space_family_topology Xi i0) Hi0I HU0Top) HfiU0)). }
  claim HcylNe: cyl <> Empty.
  { assume HCeq: cyl = Empty.
    claim HfEmp: f :e Empty.
    { rewrite <- HCeq. exact HfCyl. }
    exact (EmptyE f HfEmp False). }
  claim HcylInBasis: cyl :e basis_of_subbasis X Sfull.
  { exact (subbasis_elem_in_basis X Sfull cyl HSfull HcylSfull HcylNe). }
  claim HcylOpen: cyl :e generated_topology X (basis_of_subbasis X Sfull).
  { exact (generated_topology_contains_basis X (basis_of_subbasis X Sfull) HBasisFull cyl HcylInBasis). }
  claim HTdef: Tx = generated_topology X (basis_of_subbasis X Sfull).
  { reflexivity. }
  rewrite HTdef.
  rewrite HsEq.
  claim HcylDef: cyl = product_cylinder I Xi i0 U0.
  { reflexivity. }
  rewrite <- HcylDef.
  exact HcylOpen. }

prove topology_on X Tx /\ f :e X /\
  exists B0:set, B0 c= Tx /\ countable_set B0 /\
    (forall b:set, b :e B0 -> f :e b) /\
    (forall U:set, U :e Tx -> f :e U -> exists b:set, b :e B0 /\ b c= U).
apply andI.
 - apply andI.
   + exact HTprod.
   + exact Hf.
 - witness B.
   prove B c= Tx /\ countable_set B /\
     (forall b:set, b :e B -> f :e b) /\
     (forall U:set, U :e Tx -> f :e U -> exists b:set, b :e B /\ b c= U).
   apply andI.
   - apply andI.
     + (** B c= Tx and countable_set B **)
       apply andI.
       * let b. assume Hb: b :e B.
         prove b :e Tx.
         apply (ReplE_impred FSsmall (fun F0:set => intersection_of_family X F0) b Hb).
         let F0. assume HF0: F0 :e FSsmall.
         assume HbEq: b = intersection_of_family X F0.
         claim HF0pow: F0 :e Power Ssmall.
         { exact (SepE1 (Power Ssmall) (fun F1:set => finite F1) F0 HF0). }
         claim HF0subS: F0 c= Ssmall.
         { exact (PowerE Ssmall F0 HF0pow). }
         claim HF0fin: finite F0.
         { exact (SepE2 (Power Ssmall) (fun F1:set => finite F1) F0 HF0). }
         claim HF0subT: F0 c= Tx.
         { let s. assume HsF0: s :e F0.
           claim HsS: s :e Ssmall.
           { exact (HF0subS s HsF0). }
           exact (HSsmall_in_Tx s HsS). }
         claim HF0PowT: F0 :e Power Tx.
         { apply PowerI. exact HF0subT. }
         claim Hinter: intersection_of_family X F0 :e Tx.
         { exact (finite_intersection_in_topology X Tx F0 HTprod HF0PowT HF0fin). }
         rewrite HbEq.
         exact Hinter.
       * exact HBcount.
     + (** every b in B contains f **)
       let b. assume Hb: b :e B.
       prove f :e b.
       apply (ReplE_impred FSsmall (fun F0:set => intersection_of_family X F0) b Hb).
       let F0. assume HF0: F0 :e FSsmall.
       assume HbEq: b = intersection_of_family X F0.
       claim HF0pow: F0 :e Power Ssmall.
       { exact (SepE1 (Power Ssmall) (fun F1:set => finite F1) F0 HF0). }
       claim HF0subS: F0 c= Ssmall.
       { exact (PowerE Ssmall F0 HF0pow). }
       rewrite HbEq.
       claim Hprop: forall s:set, s :e F0 -> f :e s.
       { let s. assume HsF0: s :e F0.
         claim HsS: s :e Ssmall.
         { exact (HF0subS s HsF0). }
         apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s HsS).
         let i0. assume Hi0I: i0 :e I.
         assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
         apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
         let U0. assume HU0B: U0 :e Bsel i0.
         assume HsEq: s = product_cylinder I Xi i0 U0.
         claim HBU0: (Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0) /\
           (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0) /\
           (forall V:set, V :e space_family_topology Xi i0 -> apply_fun f i0 :e V -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= V).
         { exact (HBsel i0 Hi0I). }
         claim Hcore: ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
           (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0).
         { exact (andEL (((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
                         (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0))
                        (forall V:set, V :e space_family_topology Xi i0 -> apply_fun f i0 :e V -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= V)
                        HBU0). }
         claim HU0Top: U0 :e space_family_topology Xi i0.
         { exact ((andEL ((Bsel i0) c= space_family_topology Xi i0) (countable_set (Bsel i0))
                         (andEL ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
                                (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0)
                                Hcore)) U0 HU0B). }
         claim HfiU0: apply_fun f i0 :e U0.
         { exact ((andER ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
                         (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0)
                         Hcore) U0 HU0B). }
         rewrite HsEq.
         exact (SepI X (fun f0:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e U0)
                  f Hf (andI (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun f i0 :e U0)
                           (andI (i0 :e I) (U0 :e space_family_topology Xi i0) Hi0I HU0Top)
                           HfiU0)). }
       exact (SepI X (fun x0:set => forall U:set, U :e F0 -> x0 :e U) f Hf Hprop).
   - (** neighborhood refinement **)
     let U. assume HU: U :e Tx.
     assume HfU: f :e U.
     prove exists b:set, b :e B /\ b c= U.
      claim HTdef: Tx = generated_topology X (basis_of_subbasis X Sfull).
      { reflexivity. }
      claim HUgen: U :e generated_topology X (basis_of_subbasis X Sfull).
      { rewrite <- HTdef. exact HU. }
      claim HUlocal: forall x :e U, exists b0 :e basis_of_subbasis X Sfull, x :e b0 /\ b0 c= U.
      { exact (SepE2 (Power X)
                     (fun U0:set => forall x0 :e U0, exists b0 :e basis_of_subbasis X Sfull, x0 :e b0 /\ b0 c= U0)
                     U HUgen). }
      claim Hexb0: exists b0 :e basis_of_subbasis X Sfull, f :e b0 /\ b0 c= U.
      { exact (HUlocal f HfU). }
      apply Hexb0.
      let b0. assume Hb0pair.
      claim Hb0B: b0 :e basis_of_subbasis X Sfull.
      { exact (andEL (b0 :e basis_of_subbasis X Sfull) (f :e b0 /\ b0 c= U) Hb0pair). }
      claim Hb0prop: f :e b0 /\ b0 c= U.
      { exact (andER (b0 :e basis_of_subbasis X Sfull) (f :e b0 /\ b0 c= U) Hb0pair). }
      claim Hfb0: f :e b0.
      { exact (andEL (f :e b0) (b0 c= U) Hb0prop). }
      claim Hb0subU: b0 c= U.
      { exact (andER (f :e b0) (b0 c= U) Hb0prop). }
      claim Hb0fin: b0 :e finite_intersections_of X Sfull.
      { exact (SepE1 (finite_intersections_of X Sfull) (fun b1:set => b1 <> Empty) b0 Hb0B). }
      claim HexF0: exists F0 :e finite_subcollections Sfull, b0 = intersection_of_family X F0.
      { exact (ReplE (finite_subcollections Sfull) (fun F0:set => intersection_of_family X F0) b0 Hb0fin). }
      apply HexF0.
      let F0. assume HF0pair.
      claim HF0: F0 :e finite_subcollections Sfull.
      { exact (andEL (F0 :e finite_subcollections Sfull) (b0 = intersection_of_family X F0) HF0pair). }
      claim Hb0eq: b0 = intersection_of_family X F0.
      { exact (andER (F0 :e finite_subcollections Sfull) (b0 = intersection_of_family X F0) HF0pair). }
      claim HF0pow: F0 :e Power Sfull.
      { exact (SepE1 (Power Sfull) (fun F1:set => finite F1) F0 HF0). }
      claim HF0sub: F0 c= Sfull.
      { exact (PowerE Sfull F0 HF0pow). }
      claim HF0fin: finite F0.
      { exact (SepE2 (Power Sfull) (fun F1:set => finite F1) F0 HF0). }
      claim HfIntF0: f :e intersection_of_family X F0.
      { rewrite <- Hb0eq. exact Hfb0. }

      set p : set -> prop := fun F:set =>
        F c= Sfull -> f :e intersection_of_family X F ->
          exists G:set, G :e finite_subcollections Ssmall /\
            f :e intersection_of_family X G /\ intersection_of_family X G c= intersection_of_family X F.

      claim HpEmpty: p Empty.
      { prove Empty c= Sfull -> f :e intersection_of_family X Empty ->
          exists G:set, G :e finite_subcollections Ssmall /\
            f :e intersection_of_family X G /\ intersection_of_family X G c= intersection_of_family X Empty.
        assume Hsub0. assume Hf0.
        witness Empty.
        apply andI.
        - apply andI.
          + claim HEmptyPow: Empty :e Power Ssmall.
            { apply PowerI.
              let x. assume Hx: x :e Empty.
              exact (EmptyE x Hx (x :e Ssmall)). }
            exact (SepI (Power Ssmall) (fun F1:set => finite F1) Empty HEmptyPow finite_Empty).
          + exact Hf0.
        - exact (Subq_ref (intersection_of_family X Empty)). }

      claim HpStep: forall F y:set, finite F -> y /:e F -> p F -> p (F :\/: {y}).
      { let F y. assume HFfin: finite F. assume HyNot: y /:e F. assume HpF: p F.
        prove p (F :\/: {y}).
        assume HsubFY: (F :\/: {y}) c= Sfull.
        assume HfIntFY: f :e intersection_of_family X (F :\/: {y}).
        claim HsubF: F c= Sfull.
        { let s. assume HsF: s :e F.
          exact (HsubFY s (binunionI1 F {y} s HsF)). }
        claim HySfull: y :e Sfull.
        { exact (HsubFY y (binunionI2 F {y} y (SingI y))). }
        claim HfInY: f :e y.
        { claim Hall: forall U0:set, U0 :e (F :\/: {y}) -> f :e U0.
          { exact (SepE2 X (fun x0:set => forall U0:set, U0 :e (F :\/: {y}) -> x0 :e U0) f HfIntFY). }
          exact (Hall y (binunionI2 F {y} y (SingI y))). }
        claim HfIntF: f :e intersection_of_family X F.
        { claim HpropF: forall s:set, s :e F -> f :e s.
          { let s. assume HsF: s :e F.
            claim HsFY: s :e (F :\/: {y}).
            { exact (binunionI1 F {y} s HsF). }
            exact ((SepE2 X (fun x0:set => forall U0:set, U0 :e (F :\/: {y}) -> x0 :e U0) f HfIntFY) s HsFY). }
          exact (SepI X (fun x0:set => forall U0:set, U0 :e F -> x0 :e U0) f Hf HpropF). }
        claim HexG0: exists G0:set, G0 :e finite_subcollections Ssmall /\
          f :e intersection_of_family X G0 /\ intersection_of_family X G0 c= intersection_of_family X F.
        { exact (HpF HsubF HfIntF). }
        apply HexG0.
        let G0. assume HG0pair.
        claim HG0core: G0 :e finite_subcollections Ssmall /\ f :e intersection_of_family X G0.
        { exact (andEL (G0 :e finite_subcollections Ssmall /\ f :e intersection_of_family X G0)
                       (intersection_of_family X G0 c= intersection_of_family X F)
                       HG0pair). }
        claim HG0: G0 :e finite_subcollections Ssmall.
        { exact (andEL (G0 :e finite_subcollections Ssmall) (f :e intersection_of_family X G0) HG0core). }
        claim HfIntG0: f :e intersection_of_family X G0.
        { exact (andER (G0 :e finite_subcollections Ssmall) (f :e intersection_of_family X G0) HG0core). }
        claim HG0sub: intersection_of_family X G0 c= intersection_of_family X F.
        { exact (andER (G0 :e finite_subcollections Ssmall /\ f :e intersection_of_family X G0)
                       (intersection_of_family X G0 c= intersection_of_family X F)
                       HG0pair). }

        claim HexRef: exists y0:set, y0 :e Ssmall /\ y0 c= y /\ f :e y0.
        { apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e space_family_topology Xi i0}) y HySfull).
          let i0. assume Hi0I: i0 :e I.
          assume HyFi0: y :e {product_cylinder I Xi i0 U|U :e space_family_topology Xi i0}.
          apply (ReplE_impred (space_family_topology Xi i0) (fun U0:set => product_cylinder I Xi i0 U0) y HyFi0).
          let V0. assume HV0Top: V0 :e space_family_topology Xi i0.
          assume HyEq: y = product_cylinder I Xi i0 V0.
          claim HfCyl: f :e product_cylinder I Xi i0 V0.
          { rewrite <- HyEq. exact HfInY. }
          claim HfiV0: apply_fun f i0 :e V0.
          { exact (andER (i0 :e I /\ V0 :e space_family_topology Xi i0)
                         (apply_fun f i0 :e V0)
                         (SepE2 X (fun f0:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e V0) f HfCyl)). }
          claim HBi0: (Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0) /\
            (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0) /\
            (forall U0:set, U0 :e space_family_topology Xi i0 -> apply_fun f i0 :e U0 -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= U0).
          { exact (HBsel i0 Hi0I). }
          claim Href_i0: forall U0:set, U0 :e space_family_topology Xi i0 -> apply_fun f i0 :e U0 -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= U0.
          { exact (andER (((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
                          (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0))
                         (forall U0:set, U0 :e space_family_topology Xi i0 -> apply_fun f i0 :e U0 -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= U0)
                         HBi0). }
          claim Hexb0: exists b0:set, b0 :e (Bsel i0) /\ b0 c= V0.
          { exact (Href_i0 V0 HV0Top HfiV0). }
	          apply Hexb0.
	          let b0. assume Hb0pair.
	          claim Hb0B: b0 :e (Bsel i0).
	          { exact (andEL (b0 :e (Bsel i0)) (b0 c= V0) Hb0pair). }
	          claim Hb0sub: b0 c= V0.
	          { exact (andER (b0 :e (Bsel i0)) (b0 c= V0) Hb0pair). }
	          claim Hcore_i0: ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
	            (forall b1:set, b1 :e (Bsel i0) -> apply_fun f i0 :e b1).
	          { exact (andEL (((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0)) /\
	                          (forall b0:set, b0 :e (Bsel i0) -> apply_fun f i0 :e b0))
	                         (forall U0:set, U0 :e space_family_topology Xi i0 -> apply_fun f i0 :e U0 -> exists b0:set, b0 :e (Bsel i0) /\ b0 c= U0)
	                         HBi0). }
	          claim HsubTop: (Bsel i0) c= space_family_topology Xi i0.
	          { exact (andEL ((Bsel i0) c= space_family_topology Xi i0)
	                         (countable_set (Bsel i0))
	                         (andEL ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
	                                (forall b1:set, b1 :e (Bsel i0) -> apply_fun f i0 :e b1)
	                                Hcore_i0)). }
	          claim Hb0Top: b0 :e space_family_topology Xi i0.
	          { exact (HsubTop b0 Hb0B). }
	          claim Hforallb: forall b1:set, b1 :e (Bsel i0) -> apply_fun f i0 :e b1.
	          { exact (andER ((Bsel i0) c= space_family_topology Xi i0 /\ countable_set (Bsel i0))
	                         (forall b1:set, b1 :e (Bsel i0) -> apply_fun f i0 :e b1)
	                         Hcore_i0). }
	          claim Hfb0: apply_fun f i0 :e b0.
	          { exact (Hforallb b0 Hb0B). }
	          set y0 := product_cylinder I Xi i0 b0.
	          witness y0.
	          apply andI.
	          - apply andI.
	            + exact (famunionI I (fun i1:set => {product_cylinder I Xi i1 U|U :e Bsel i1})
	                         i0 y0 Hi0I (ReplI (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) b0 Hb0B)).
	            + let g. assume Hg: g :e y0.
	              prove g :e y.
	              claim HgCyl: g :e product_cylinder I Xi i0 b0.
	              { exact Hg. }
	              claim Hgprop: i0 :e I /\ b0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e b0.
	              { exact (SepE2 X (fun g0:set => i0 :e I /\ b0 :e space_family_topology Xi i0 /\ apply_fun g0 i0 :e b0) g HgCyl). }
	              claim Hgi0: apply_fun g i0 :e b0.
	              { exact (andER (i0 :e I /\ b0 :e space_family_topology Xi i0) (apply_fun g i0 :e b0) Hgprop). }
	              claim Hgi0V0: apply_fun g i0 :e V0.
	              { exact (Hb0sub (apply_fun g i0) Hgi0). }
	              rewrite HyEq.
	              exact (SepI X (fun g0:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun g0 i0 :e V0)
	                       g (SepE1 X (fun g0:set => i0 :e I /\ b0 :e space_family_topology Xi i0 /\ apply_fun g0 i0 :e b0) g HgCyl)
	                       (andI (i0 :e I /\ V0 :e space_family_topology Xi i0) (apply_fun g i0 :e V0)
	                            (andI (i0 :e I) (V0 :e space_family_topology Xi i0) Hi0I HV0Top) Hgi0V0)).
	          - exact (SepI X (fun f0:set => i0 :e I /\ b0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e b0)
	                   f Hf (andI (i0 :e I /\ b0 :e space_family_topology Xi i0) (apply_fun f i0 :e b0)
	                            (andI (i0 :e I) (b0 :e space_family_topology Xi i0) Hi0I Hb0Top)
	                            Hfb0)). }
 

        apply HexRef.
        let y0. assume Hy0pair.
        claim Hy0S: y0 :e Ssmall.
        { claim Hy0core: (y0 :e Ssmall /\ y0 c= y).
          { exact (andEL (y0 :e Ssmall /\ y0 c= y) (f :e y0) Hy0pair). }
          exact (andEL (y0 :e Ssmall) (y0 c= y) Hy0core). }
        claim Hy0suby: y0 c= y.
        { claim Hy0core: (y0 :e Ssmall /\ y0 c= y).
          { exact (andEL (y0 :e Ssmall /\ y0 c= y) (f :e y0) Hy0pair). }
          exact (andER (y0 :e Ssmall) (y0 c= y) Hy0core). }
        claim Hfy0: f :e y0.
        { exact (andER (y0 :e Ssmall /\ y0 c= y) (f :e y0) Hy0pair). }

        set G := G0 :\/: {y0}.
        witness G.
        apply andI.
        - apply andI.
          + (** G in finite_subcollections Ssmall **)
            claim HG0pow: G0 :e Power Ssmall.
            { exact (SepE1 (Power Ssmall) (fun F1:set => finite F1) G0 HG0). }
            claim HG0subS: G0 c= Ssmall.
            { exact (PowerE Ssmall G0 HG0pow). }
            claim HG0fin: finite G0.
            { exact (SepE2 (Power Ssmall) (fun F1:set => finite F1) G0 HG0). }
            claim HGsub: G c= Ssmall.
            { let s. assume HsG: s :e G.
              apply (binunionE' G0 {y0} s (s :e Ssmall)).
              - assume HsG0: s :e G0.
                exact (HG0subS s HsG0).
              - assume Hsy0: s :e {y0}.
                rewrite (SingE y0 s Hsy0).
                exact Hy0S.
              - exact HsG. }
            claim HGpow: G :e Power Ssmall.
            { apply PowerI. exact HGsub. }
	            claim HGfin: finite G.
	            { exact (adjoin_finite G0 y0 HG0fin). }
	            exact (SepI (Power Ssmall) (fun F1:set => finite F1) G HGpow HGfin).
	          + (** f in intersection_of_family X G **)
	            claim HpropG: forall s:set, s :e G -> f :e s.
	            { let s. assume HsG: s :e G.
	              apply (binunionE' G0 {y0} s (f :e s)).
	              - assume HsG0: s :e G0.
	                exact ((SepE2 X (fun x0:set => forall U0:set, U0 :e G0 -> x0 :e U0) f HfIntG0) s HsG0).
	              - assume Hsy0: s :e {y0}.
	                rewrite (SingE y0 s Hsy0).
	                exact Hfy0.
	              - exact HsG. }
	            exact (SepI X (fun x0:set => forall U0:set, U0 :e G -> x0 :e U0) f Hf HpropG).
	        - (** inclusion: intersection_of_family X G c= intersection_of_family X (F :\/: {y}) **)
	          let z. assume Hz: z :e intersection_of_family X G.
	          prove z :e intersection_of_family X (F :\/: {y}).
	          claim HzX: z :e X.
	          { exact (SepE1 X (fun x0:set => forall U0:set, U0 :e G -> x0 :e U0) z Hz). }
	          claim HzG: forall U0:set, U0 :e G -> z :e U0.
	          { exact (SepE2 X (fun x0:set => forall U0:set, U0 :e G -> x0 :e U0) z Hz). }
	          claim HzG0: z :e intersection_of_family X G0.
	          { claim HzG0prop: forall s:set, s :e G0 -> z :e s.
	            { let s. assume HsG0: s :e G0.
	              exact (HzG s (binunionI1 G0 {y0} s HsG0)). }
	            exact (SepI X (fun x0:set => forall U0:set, U0 :e G0 -> x0 :e U0) z HzX HzG0prop). }
	          claim HzF: z :e intersection_of_family X F.
	          { exact (HG0sub z HzG0). }
	          claim Hzy0: z :e y0.
	          { exact (HzG y0 (binunionI2 G0 {y0} y0 (SingI y0))). }
	          claim Hzy: z :e y.
	          { exact (Hy0suby z Hzy0). }
	          claim HzFYprop: forall s:set, s :e (F :\/: {y}) -> z :e s.
	          { let s. assume HsFY: s :e (F :\/: {y}).
	            apply (binunionE' F {y} s (z :e s)).
	            - assume HsF: s :e F.
	              exact ((SepE2 X (fun x0:set => forall U0:set, U0 :e F -> x0 :e U0) z HzF) s HsF).
	            - assume Hsy: s :e {y}.
	              rewrite (SingE y s Hsy).
	              exact Hzy.
	            - exact HsFY. }
		          exact (SepI X (fun x0:set => forall U0:set, U0 :e (F :\/: {y}) -> x0 :e U0) z HzX HzFYprop).
	      }

	      claim Hpref: p F0.
	      { exact (finite_ind p HpEmpty HpStep F0 HF0fin). }
      claim HexG: exists G:set, G :e finite_subcollections Ssmall /\
        f :e intersection_of_family X G /\ intersection_of_family X G c= intersection_of_family X F0.
      { exact (Hpref HF0sub HfIntF0). }
      apply HexG.
      let G. assume HGpair.
      claim HGcore: G :e finite_subcollections Ssmall /\ f :e intersection_of_family X G.
      { exact (andEL (G :e finite_subcollections Ssmall /\ f :e intersection_of_family X G)
                     (intersection_of_family X G c= intersection_of_family X F0)
                     HGpair). }
      claim HG: G :e finite_subcollections Ssmall.
      { exact (andEL (G :e finite_subcollections Ssmall) (f :e intersection_of_family X G) HGcore). }
      claim HGsub: intersection_of_family X G c= intersection_of_family X F0.
      { exact (andER (G :e finite_subcollections Ssmall /\ f :e intersection_of_family X G)
                     (intersection_of_family X G c= intersection_of_family X F0)
                     HGpair). }
      set b := intersection_of_family X G.
      witness b.
      apply andI.
      - exact (ReplI FSsmall (fun F1:set => intersection_of_family X F1) G HG).
      - let z. assume Hz: z :e b.
        prove z :e U.
        claim HzF0: z :e intersection_of_family X F0.
        { exact (HGsub z Hz). }
        claim Hzb0: z :e b0.
        { rewrite Hb0eq.
          exact HzF0. }
        exact (Hb0subU z Hzb0).
Qed.

(** helper: any convergent sequence yields closure membership **) 
(** LATEX VERSION: If a sequence in A converges to x, then x is in the closure of A (no countability needed). **)
Theorem convergent_sequence_implies_closure : forall X Tx A x:set,
  topology_on X Tx ->
  A c= X ->
  (exists seq:set, sequence_in seq A /\ converges_to X Tx seq x) ->
  x :e closure_of X Tx A.
let X Tx A x.
assume HTx: topology_on X Tx.
assume HAsub: A c= X.
assume Hseq: exists seq:set, sequence_in seq A /\ converges_to X Tx seq x.
prove x :e closure_of X Tx A.
apply Hseq.
let seq. assume Hseqpair.
claim Hseqin: sequence_in seq A.
{ exact (andEL (sequence_in seq A) (converges_to X Tx seq x) Hseqpair). }
claim Hconv: converges_to X Tx seq x.
{ exact (andER (sequence_in seq A) (converges_to X Tx seq x) Hseqpair). }
claim HxX: x :e X.
{ claim Hleft: (topology_on X Tx /\ sequence_on seq X) /\ x :e X.
  { exact (andEL ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
                 (forall U:set, U :e Tx -> x :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
                 Hconv). }
  exact (andER (topology_on X Tx /\ sequence_on seq X) (x :e X) Hleft). }
claim Hcliff: x :e closure_of X Tx A <-> (forall U :e Tx, x :e U -> U :/\: A <> Empty).
{ exact (closure_characterization X Tx A x HTx HxX). }
apply (iffER (x :e closure_of X Tx A) (forall U :e Tx, x :e U -> U :/\: A <> Empty) Hcliff).
prove forall U :e Tx, x :e U -> U :/\: A <> Empty.
let U. assume HU: U :e Tx. assume HxU: x :e U.
claim Hevent: exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
{ claim Htail0: forall V:set, V :e Tx -> x :e V ->
    exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e V.
  { exact (andER ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
                 (forall V:set, V :e Tx -> x :e V -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e V)
                 Hconv). }
  exact (Htail0 U HU HxU). }
apply Hevent.
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
claim Htail: forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
{ exact (andER (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
claim HyU: apply_fun seq N :e U.
{ exact (Htail N HNomega (Subq_ref N)). }
claim HyA: apply_fun seq N :e A.
{ exact (Hseqin N HNomega). }
prove U :/\: A <> Empty.
assume HUAEq: U :/\: A = Empty.
claim HyUA: apply_fun seq N :e U :/\: A.
{ exact (binintersectI U A (apply_fun seq N) HyU HyA). }
claim HyEmp: apply_fun seq N :e Empty.
{ rewrite <- HUAEq. exact HyUA. }
exact (EmptyE (apply_fun seq N) HyEmp False).
Qed.

(** helper: equip preserves finiteness **) 
(** LATEX VERSION: If X is equip to Y and Y is finite, then X is finite. **)
Theorem equip_finite_transfer : forall X Y:set,
  equip X Y -> finite Y -> finite X.
let X Y.
assume Heq: equip X Y.
assume Hfin: finite Y.
prove finite X.
prove exists n :e omega, equip X n.
apply Hfin.
let n. assume Hpair: n :e omega /\ equip Y n.
claim Hn: n :e omega.
{ exact (andEL (n :e omega) (equip Y n) Hpair). }
claim HeqYn: equip Y n.
{ exact (andER (n :e omega) (equip Y n) Hpair). }
claim HeqXn: equip X n.
{ exact (equip_tra X Y n Heq HeqYn). }
witness n.
apply andI.
- exact Hn.
- exact HeqXn.
Qed.

(** helper: injection gives equip with its image **)
(** LATEX VERSION: An injection f:X→Y is a bijection from X onto its image f[X]. **)
Theorem inj_equip_image : forall X Y:set, forall f:set->set,
  inj X Y f -> equip X {f x|x :e X}.
let X Y f.
assume Hinj: inj X Y f.
prove equip X {f x|x :e X}.
prove exists g : set -> set, bij X {f x|x :e X} g.
witness f.
prove bij X {f x|x :e X} f.
prove ((forall u :e X, f u :e {f x|x :e X}) /\
       (forall u v :e X, f u = f v -> u = v)) /\
      (forall w :e {f x|x :e X}, exists u :e X, f u = w).
apply andI.
- (** (forall u, f u in image) /\ injective **)
  apply andI.
  + let u. assume Hu: u :e X.
    exact (ReplI X (fun x0:set => f x0) u Hu).
  + exact (andER (forall x :e X, f x :e Y)
                 (forall x z :e X, f x = f z -> x = z)
                 Hinj).
- (** surjective onto the image **)
  let w. assume Hw: w :e {f x|x :e X}.
  prove exists u :e X, f u = w.
  apply (ReplE_impred X (fun x0:set => f x0) w Hw
                      (exists u :e X, f u = w)).
  let u. assume HuX: u :e X.
  assume Hweq: w = f u.
  witness u.
  apply andI.
  + exact HuX.
  + rewrite <- Hweq.
    reflexivity.
Qed.

(** helper: injection into a finite ordinal implies finiteness **) 
(** LATEX VERSION: If X injects into a finite set, then X is finite. **)
Theorem inj_into_finite_nat : forall X n:set, forall f:set->set,
  nat_p n -> inj X n f -> finite X.
let X n f.
assume Hnat: nat_p n.
assume Hinj: inj X n f.
prove finite X.
set Img := {f x|x :e X}.
claim Heq: equip X Img.
{ exact (inj_equip_image X n f Hinj). }
claim Hsub: Img c= n.
{ let y. assume Hy: y :e Img.
  prove y :e n.
  apply (ReplE_impred X (fun x0:set => f x0) y Hy (y :e n)).
  let x. assume Hx: x :e X.
  assume Hyx: y = f x.
  claim Hcod: forall u :e X, f u :e n.
  { exact (andEL (forall u :e X, f u :e n)
                 (forall u v :e X, f u = f v -> u = v)
                 Hinj). }
  rewrite Hyx.
  exact (Hcod x Hx). }
claim Hfinn: finite n.
{ exact (nat_finite n Hnat). }
claim HfinImg: finite Img.
{ exact (Subq_finite n Hfinn Img Hsub). }
exact (equip_finite_transfer X Img Heq HfinImg).
Qed.

(** from §30 Theorem 30.1(a): sequences and closure in first-countable spaces **) 
(** LATEX VERSION: If X is first countable, then x is in cl(A) iff there exists a sequence in A converging to x. **)
Theorem first_countable_sequences_detect_closure : forall X Tx A x:set,
  first_countable_space X Tx ->
  A c= X ->
  (x :e closure_of X Tx A <->
    exists seq:set, sequence_in seq A /\ converges_to X Tx seq x).
let X Tx A x.
assume Hfc: first_countable_space X Tx.
assume HAsub: A c= X.
prove x :e closure_of X Tx A <->
  exists seq:set, sequence_in seq A /\ converges_to X Tx seq x.
apply iffI.
- (** closure -> existence of convergent sequence (needs first countability) **)
  assume Hxcl: x :e closure_of X Tx A.
  prove exists seq:set, sequence_in seq A /\ converges_to X Tx seq x.
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall x0:set, x0 :e X -> countable_basis_at X Tx x0)
                 Hfc). }
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x Hxcl). }
  claim Hbas_all: forall x0:set, x0 :e X -> countable_basis_at X Tx x0.
  { exact (andER (topology_on X Tx)
                 (forall x0:set, x0 :e X -> countable_basis_at X Tx x0)
                 Hfc). }
  claim Hbas: countable_basis_at X Tx x.
  { exact (Hbas_all x HxX). }
  (** Unpack the countable local basis B at x, then choose a decreasing neighborhood base and points of A in each neighborhood. **)
  claim HBex: exists B:set,
    B c= Tx /\ countable_set B /\
      (forall b:set, b :e B -> x :e b) /\
      (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
  { claim Hpack: (topology_on X Tx /\ x :e X) /\
      exists B:set, B c= Tx /\ countable_set B /\
        (forall b:set, b :e B -> x :e b) /\
        (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
    { exact Hbas. }
    exact (andER (topology_on X Tx /\ x :e X)
                 (exists B:set, B c= Tx /\ countable_set B /\
                   (forall b:set, b :e B -> x :e b) /\
                   (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U))
                 Hpack). }
  claim Hclprop: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
  { exact (SepE2 X (fun x0:set => forall U0:set, U0 :e Tx -> x0 :e U0 -> U0 :/\: A <> Empty) x Hxcl). }
  apply HBex.
  let B.
  assume HB: B c= Tx /\ countable_set B /\
      (forall b:set, b :e B -> x :e b) /\
      (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
  claim HBCD: (B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b).
  { exact (andEL ((B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b))
                 (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U)
                 HB). }
  claim HAB: B c= Tx /\ countable_set B.
  { exact (andEL (B c= Tx /\ countable_set B)
                 (forall b:set, b :e B -> x :e b)
                 HBCD). }
  claim HBsubTx: B c= Tx.
  { exact (andEL (B c= Tx) (countable_set B) HAB). }
  claim HcountB: countable_set B.
  { exact (andER (B c= Tx) (countable_set B) HAB). }
  claim Hx_in_B: forall b:set, b :e B -> x :e b.
  { exact (andER (B c= Tx /\ countable_set B)
                 (forall b:set, b :e B -> x :e b)
                 HBCD). }
  claim HrefB: forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U.
  { exact (andER ((B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b))
                 (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U)
                 HB). }
  apply HcountB.
  let code. assume Hcodeinj: inj B omega code.
  claim Hcode_cod: forall b :e B, code b :e omega.
  { exact (andEL (forall b :e B, code b :e omega)
                 (forall b1 b2 :e B, code b1 = code b2 -> b1 = b2)
                 Hcodeinj). }
  claim Hcode_inj: forall b1 b2 :e B, code b1 = code b2 -> b1 = b2.
  { exact (andER (forall b :e B, code b :e omega)
                 (forall b1 b2 :e B, code b1 = code b2 -> b1 = b2)
                 Hcodeinj). }
  set F := (fun n:set => {b :e B | code b :e ordsucc n}).
  set Ubase := (fun n:set => intersection_of_family X (F n)).
  claim HUinfo: forall n:set, n :e omega ->
    (Ubase n :e Tx /\ x :e Ubase n) /\ Ubase n :/\: A <> Empty.
  { let n. assume HnO: n :e omega.
    prove (Ubase n :e Tx /\ x :e Ubase n) /\ Ubase n :/\: A <> Empty.
    claim HnNat: nat_p n.
    { exact (omega_nat_p n HnO). }
    claim HsuccNat: nat_p (ordsucc n).
    { exact (nat_ordsucc n HnNat). }
    claim HFsubB: F n c= B.
    { let b. assume Hb: b :e F n.
      exact (SepE1 B (fun b0:set => code b0 :e ordsucc n) b Hb). }
    claim HFsubTx: F n c= Tx.
    { let b. assume Hb: b :e F n.
      claim HbB: b :e B.
      { exact (HFsubB b Hb). }
      exact (HBsubTx b HbB). }
    claim HFpow: F n :e Power Tx.
    { exact (PowerI Tx (F n) HFsubTx). }
    claim HinjFn: inj (F n) (ordsucc n) code.
    { apply injI.
      - let b. assume Hb: b :e F n.
        exact (SepE2 B (fun b0:set => code b0 :e ordsucc n) b Hb).
      - let b1. assume Hb1: b1 :e F n.
        let b2. assume Hb2: b2 :e F n.
        assume Heq: code b1 = code b2.
        claim Hb1B: b1 :e B.
        { exact (HFsubB b1 Hb1). }
        claim Hb2B: b2 :e B.
        { exact (HFsubB b2 Hb2). }
        exact (Hcode_inj b1 Hb1B b2 Hb2B Heq). }
    claim HFin: finite (F n).
    { exact (inj_into_finite_nat (F n) (ordsucc n) code HsuccNat HinjFn). }
    claim HUinTx: Ubase n :e Tx.
    { exact (finite_intersection_in_topology X Tx (F n) HTx HFpow HFin). }
    claim HxU: x :e Ubase n.
    { prove x :e intersection_of_family X (F n).
      claim HxAll: forall U:set, U :e F n -> x :e U.
      { let T. assume HT: T :e F n.
        claim HTB: T :e B.
        { exact (HFsubB T HT). }
        exact (Hx_in_B T HTB). }
      exact (SepI X (fun z:set => forall U:set, U :e F n -> z :e U) x HxX HxAll). }
    claim Hne: Ubase n :/\: A <> Empty.
    { exact (Hclprop (Ubase n) HUinTx HxU). }
    apply andI.
    - apply andI.
      + exact HUinTx.
      + exact HxU.
    - exact Hne. }
	  set pick := (fun n:set => Eps_i (fun y:set => y :e (Ubase n :/\: A))).
	  set seq := graph omega pick.
	  claim Hseqdef: seq = graph omega pick.
	  { reflexivity. }
	  witness seq.
	  apply andI.
	  - (** sequence_in seq A **)
	    prove sequence_in seq A.
	    prove function_on seq omega A.
		    let n. assume HnO: n :e omega.
		    prove apply_fun seq n :e A.
		    claim Happ: apply_fun seq n = pick n.
		    { rewrite Hseqdef.
		      exact (apply_fun_graph omega pick n HnO). }
		    rewrite Happ.
		    claim HUA: (Ubase n :e Tx /\ x :e Ubase n) /\ Ubase n :/\: A <> Empty.
		    { exact (HUinfo n HnO). }
    claim Hne: Ubase n :/\: A <> Empty.
    { exact (andER (Ubase n :e Tx /\ x :e Ubase n) (Ubase n :/\: A <> Empty) HUA). }
    claim Hex: exists y:set, y :e (Ubase n :/\: A).
    { exact (nonempty_has_element (Ubase n :/\: A) Hne). }
    claim Hpickin: pick n :e (Ubase n :/\: A).
    { exact (Eps_i_ex (fun y:set => y :e (Ubase n :/\: A)) Hex). }
    exact (binintersectE2 (Ubase n) A (pick n) Hpickin).
  - (** converges_to X Tx seq x **)
    prove converges_to X Tx seq x.
    prove (topology_on X Tx /\ sequence_on seq X) /\ x :e X /\
      forall V:set, V :e Tx -> x :e V ->
        exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e V.
    apply andI.
    + (** (topology_on /\ sequence_on) /\ x:e X **)
      apply andI.
      * (** topology_on /\ sequence_on **)
        apply andI.
        { exact HTx. }
	        { prove sequence_on seq X.
	          let n. assume HnO: n :e omega.
	          prove apply_fun seq n :e X.
	          claim Happ: apply_fun seq n = pick n.
	          { rewrite Hseqdef.
	            exact (apply_fun_graph omega pick n HnO). }
	          rewrite Happ.
	          claim HUA: (Ubase n :e Tx /\ x :e Ubase n) /\ Ubase n :/\: A <> Empty.
	          { exact (HUinfo n HnO). }
          claim Hne: Ubase n :/\: A <> Empty.
          { exact (andER (Ubase n :e Tx /\ x :e Ubase n) (Ubase n :/\: A <> Empty) HUA). }
          claim Hex: exists y:set, y :e (Ubase n :/\: A).
          { exact (nonempty_has_element (Ubase n :/\: A) Hne). }
          claim Hpickin: pick n :e (Ubase n :/\: A).
          { exact (Eps_i_ex (fun y:set => y :e (Ubase n :/\: A)) Hex). }
          claim HpickU: pick n :e Ubase n.
          { exact (binintersectE1 (Ubase n) A (pick n) Hpickin). }
          exact (SepE1 X (fun y:set => forall T:set, T :e (F n) -> y :e T) (pick n) HpickU). }
      * exact HxX.
    + (** tail condition **)
      let V. assume HV: V :e Tx. assume HxV: x :e V.
      claim Hexb: exists b:set, b :e B /\ b c= V.
      { exact (HrefB V HV HxV). }
      apply Hexb.
      let b0. assume Hb0pair.
      claim Hb0B: b0 :e B.
      { exact (andEL (b0 :e B) (b0 c= V) Hb0pair). }
      claim Hb0subV: b0 c= V.
      { exact (andER (b0 :e B) (b0 c= V) Hb0pair). }
      set N := ordsucc (code b0).
      witness N.
      apply andI.
      * (** N :e omega **)
        claim Hcodeb0: code b0 :e omega.
        { exact (Hcode_cod b0 Hb0B). }
        exact (omega_ordsucc (code b0) Hcodeb0).
      * (** eventually in V **)
	        let n. assume HnO: n :e omega. assume HNsub: N c= n.
	        prove apply_fun seq n :e V.
	        claim Happ: apply_fun seq n = pick n.
	        { rewrite Hseqdef.
	          exact (apply_fun_graph omega pick n HnO). }
	        rewrite Happ.
	        (** show pick n is in Ubase n and Ubase n c= b0 c= V **)
	        claim HUA: (Ubase n :e Tx /\ x :e Ubase n) /\ Ubase n :/\: A <> Empty.
	        { exact (HUinfo n HnO). }
        claim Hne: Ubase n :/\: A <> Empty.
        { exact (andER (Ubase n :e Tx /\ x :e Ubase n) (Ubase n :/\: A <> Empty) HUA). }
        claim Hex: exists y:set, y :e (Ubase n :/\: A).
        { exact (nonempty_has_element (Ubase n :/\: A) Hne). }
        claim Hpickin: pick n :e (Ubase n :/\: A).
        { exact (Eps_i_ex (fun y:set => y :e (Ubase n :/\: A)) Hex). }
        claim HpickU: pick n :e Ubase n.
        { exact (binintersectE1 (Ubase n) A (pick n) Hpickin). }
        claim Hcode_in_N: code b0 :e N.
        { exact (ordsuccI2 (code b0)). }
        claim Hcode_in_n: code b0 :e n.
        { exact (HNsub (code b0) Hcode_in_N). }
        claim Hcode_in_succn: code b0 :e ordsucc n.
        { exact (ordsuccI1 n (code b0) Hcode_in_n). }
        claim Hb0Fn: b0 :e F n.
        { exact (SepI B (fun b:set => code b :e ordsucc n) b0 Hb0B Hcode_in_succn). }
        claim HUnsubb0: Ubase n c= b0.
        { let z. assume Hz: z :e Ubase n.
          prove z :e b0.
          claim Hall: forall T:set, T :e F n -> z :e T.
          { exact (SepE2 X (fun z0:set => forall T:set, T :e F n -> z0 :e T) z Hz). }
          exact (Hall b0 Hb0Fn). }
        claim Hzb0: pick n :e b0.
        { exact (HUnsubb0 (pick n) HpickU). }
        exact (Hb0subV (pick n) Hzb0).
- (** existence of convergent sequence -> closure (general) **)
  assume Hseq: exists seq:set, sequence_in seq A /\ converges_to X Tx seq x.
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx) (forall x0:set, x0 :e X -> countable_basis_at X Tx x0) Hfc). }
  exact (convergent_sequence_implies_closure X Tx A x HTx HAsub Hseq).
Qed.

(** from §30 Theorem 30.1(b): sequences and continuity in first-countable spaces **)
(** LATEX VERSION: Sequential criterion for continuity in first-countable spaces. **)
(** FIXED: Correct convergence target and image limit: if x_n converges to x then f(x_n) converges to f(x). **)
Theorem first_countable_sequences_detect_continuity : forall X Tx Y Ty f:set,
  topology_on X Tx -> topology_on Y Ty ->
  (continuous_map X Tx Y Ty f ->
    forall x seq:set, sequence_on seq X -> converges_to X Tx seq x -> converges_to Y Ty (map_sequence f seq) (apply_fun f x)).
let X Tx Y Ty f.
assume HTx: topology_on X Tx.
assume HTy: topology_on Y Ty.
prove continuous_map X Tx Y Ty f ->
    forall x seq:set, sequence_on seq X -> converges_to X Tx seq x -> converges_to Y Ty (map_sequence f seq) (apply_fun f x).
assume Hcont: continuous_map X Tx Y Ty f.
let x seq.
assume Hseqon: sequence_on seq X.
assume Hconv: converges_to X Tx seq x.
prove converges_to Y Ty (map_sequence f seq) (apply_fun f x).
claim Hcont_left: (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hcont). }
claim Hfun: function_on f X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y) Hcont_left). }
claim Hpre: forall V:set, V :e Ty -> preimage_of X f V :e Tx.
{ exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
               (forall V:set, V :e Ty -> preimage_of X f V :e Tx)
               Hcont). }
claim Hconv_left: (topology_on X Tx /\ sequence_on seq X) /\ x :e X.
{ exact (andEL ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
               (forall U:set, U :e Tx -> x :e U -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)
               Hconv). }
claim HxX: x :e X.
{ exact (andER (topology_on X Tx /\ sequence_on seq X) (x :e X) Hconv_left). }
claim HfxY: apply_fun f x :e Y.
{ exact (Hfun x HxX). }
prove topology_on Y Ty /\ sequence_on (map_sequence f seq) Y /\ apply_fun f x :e Y /\
      forall V:set, V :e Ty -> apply_fun f x :e V ->
        exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun (map_sequence f seq) n :e V.
apply andI.
- (** left: (topology_on Y Ty /\ sequence_on ...) /\ apply_fun f x :e Y **)
  apply andI.
  + (** topology_on Y Ty /\ sequence_on (map_sequence f seq) Y **)
    apply andI.
    * exact HTy.
    * prove sequence_on (map_sequence f seq) Y.
      let n. assume Hn: n :e omega.
      prove apply_fun (map_sequence f seq) n :e Y.
      claim HseqnX: apply_fun seq n :e X.
      { exact (Hseqon n Hn). }
      claim Hcomp: apply_fun (map_sequence f seq) n = apply_fun f (apply_fun seq n).
      { exact (compose_fun_apply omega seq f n Hn). }
      rewrite Hcomp.
      exact (Hfun (apply_fun seq n) HseqnX).
  + exact HfxY.
- (** right: neighborhood condition **)
  let V. assume HV: V :e Ty. assume HfxV: apply_fun f x :e V.
  set U := preimage_of X f V.
  claim HUDef: U = preimage_of X f V.
  { reflexivity. }
  claim HUopen: U :e Tx.
  { rewrite HUDef. exact (Hpre V HV). }
  claim HxU: x :e U.
  { rewrite HUDef.
    exact (SepI X (fun x0:set => apply_fun f x0 :e V) x HxX HfxV). }
  claim Htail0: forall W:set, W :e Tx -> x :e W ->
    exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e W.
  { exact (andER ((topology_on X Tx /\ sequence_on seq X) /\ x :e X)
                 (forall W:set, W :e Tx -> x :e W -> exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e W)
                 Hconv). }
  claim Hevent: exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  { exact (Htail0 U HUopen HxU). }
  apply Hevent.
  let N. assume HNpair.
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
  claim Htail: forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  { exact (andER (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
  witness N.
  apply andI.
  + exact HNomega.
  + let n. assume Hn: n :e omega. assume HNsub: N c= n.
    claim HseqnU: apply_fun seq n :e U.
    { exact (Htail n Hn HNsub). }
    claim HseqnU0: apply_fun seq n :e preimage_of X f V.
    { rewrite <- HUDef. exact HseqnU. }
    claim HfnV: apply_fun f (apply_fun seq n) :e V.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e V) (apply_fun seq n) HseqnU0). }
    claim Hcomp: apply_fun (map_sequence f seq) n = apply_fun f (apply_fun seq n).
    { exact (compose_fun_apply omega seq f n Hn). }
    rewrite Hcomp.
    exact HfnV.
Qed.

(** from §30 Definition: second-countable space **) 
(** LATEX VERSION: Second countable means existence of a countable basis for the topology. **)
Definition second_countable_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\ exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.

(** helper: second countable implies first countable **)
Theorem second_countable_implies_first_countable : forall X Tx:set,
  second_countable_space X Tx -> first_countable_space X Tx.
let X Tx.
assume Hscc: second_countable_space X Tx.
prove first_countable_space X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
prove topology_on X Tx /\ forall x:set, x :e X -> countable_basis_at X Tx x.
apply andI.
- exact HTx.
- let x. assume HxX: x :e X.
  prove countable_basis_at X Tx x.
  prove topology_on X Tx /\ x :e X /\
    exists B0:set, B0 c= Tx /\ countable_set B0 /\
      (forall b:set, b :e B0 -> x :e b) /\
      (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B0 /\ b c= U).
  apply and3I.
  * exact HTx.
  * exact HxX.
  * apply HexB.
    let B. assume HBpair.
    set B0 := {b :e B|x :e b}.
    witness B0.
    claim HBmid: (basis_on X B /\ countable_set B) /\ basis_generates X B Tx.
    { exact HBpair. }
    claim HBasisCount: basis_on X B /\ countable_set B.
    { exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
    claim HBgener: basis_generates X B Tx.
    { exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
    claim HBasis: basis_on X B.
    { exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
    claim HBcount: countable_set B.
    { exact (andER (basis_on X B) (countable_set B) HBasisCount). }
    claim HgenEq: generated_topology X B = Tx.
    { exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
    claim HBsubPow: B c= Power X.
    { exact (basis_on_sub_Power X B HBasis). }
    apply and4I.
    + (** B0 c= Tx **)
      let u. assume Hu0: u :e B0.
      prove u :e Tx.
      claim HuB: u :e B.
      { exact (SepE1 B (fun b0:set => x :e b0) u Hu0). }
      claim HuPow: u :e Power X.
      { exact (HBsubPow u HuB). }
      claim Husub: u c= X.
      { exact (PowerE X u HuPow). }
	      claim HuTop: u :e generated_topology X B.
	      { exact (generated_topology_contains_elem X B u HuPow HuB). }
      rewrite <- HgenEq.
      exact HuTop.
    + (** countable_set B0 **)
      claim HB0sub: B0 c= B.
      { let u. assume Hu0: u :e B0.
        exact (SepE1 B (fun b0:set => x :e b0) u Hu0). }
      exact (Subq_countable B0 B HBcount HB0sub).
    + (** every b in B0 contains x **)
      let u. assume Hu0: u :e B0.
      exact (SepE2 B (fun b0:set => x :e b0) u Hu0).
    + (** local refinement property **)
      let U. assume HU: U :e Tx.
      assume HxU: x :e U.
      prove exists b:set, b :e B0 /\ b c= U.
      claim HUtop: U :e generated_topology X B.
      { rewrite HgenEq.
        exact HU. }
      claim Hexb2: exists b:set, b :e B /\ x :e b /\ b c= U.
      { apply (generated_topology_local_refine X B U x HUtop HxU).
        let b. assume Hbpair.
        witness b.
        claim HbB: b :e B.
        { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
        claim Hbrest: x :e b /\ b c= U.
        { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
        claim Hxb: x :e b.
        { exact (andEL (x :e b) (b c= U) Hbrest). }
        claim Hbsub: b c= U.
        { exact (andER (x :e b) (b c= U) Hbrest). }
        apply andI.
        - apply andI.
          + exact HbB.
          + exact Hxb.
        - exact Hbsub. }
      apply Hexb2.
      let b. assume Hbpair.
      claim Hbpair1: b :e B /\ x :e b.
      { exact (andEL (b :e B /\ x :e b) (b c= U) Hbpair). }
      claim Hbsub: b c= U.
      { exact (andER (b :e B /\ x :e b) (b c= U) Hbpair). }
      claim HbB: b :e B.
      { exact (andEL (b :e B) (x :e b) Hbpair1). }
      claim Hxb: x :e b.
      { exact (andER (b :e B) (x :e b) Hbpair1). }
      witness b.
      apply andI.
      - exact (SepI B (fun b0:set => x :e b0) b HbB Hxb).
      - exact Hbsub.
Qed.

(** helper: R is second countable in the standard topology **)
(** LATEX VERSION: The real line with its standard topology has a countable basis. **)
Theorem R_standard_topology_second_countable : second_countable_space R R_standard_topology.
prove second_countable_space R R_standard_topology.
prove topology_on R R_standard_topology /\
  exists B:set, basis_on R B /\ countable_set B /\ basis_generates R B R_standard_topology.
apply andI.
- exact R_standard_topology_is_topology.
- witness rational_open_intervals_basis.
  prove basis_on R rational_open_intervals_basis /\ countable_set rational_open_intervals_basis /\
    basis_generates R rational_open_intervals_basis R_standard_topology.
  (** left-associative conjunction: (basis_on /\ countable_set) /\ basis_generates **)
  apply andI.
  * (** basis_on /\ countable_set **)
    apply andI.
    + claim HBgenerates: basis_on R rational_open_intervals_basis /\
        generated_topology R rational_open_intervals_basis = R_standard_topology.
      { exact ex13_8a_rational_intervals_basis_standard. }
      exact (andEL (basis_on R rational_open_intervals_basis)
                   (generated_topology R rational_open_intervals_basis = R_standard_topology)
                   HBgenerates).
    + exact rational_open_intervals_basis_countable.
  * (** basis_generates **)
    prove basis_generates R rational_open_intervals_basis R_standard_topology.
    exact ex13_8a_rational_intervals_basis_standard.
Qed.

(** from §30 Example 1: R^n has countable basis **) 
(** LATEX VERSION: Euclidean spaces have a countable basis, hence are second countable. **)
Theorem euclidean_spaces_second_countable : forall n:set,
  n :e omega ->
  second_countable_space (euclidean_space n) (euclidean_topology n).
let n.
assume Hn: n :e omega.
prove second_countable_space (euclidean_space n) (euclidean_topology n).
(** We show second countability by exhibiting a countable subbasis of cylinders built from a countable basis of R. **)
set Xi := const_space_family n R R_standard_topology.
set Xprod := product_space n Xi.
set Tfull := countable_product_topology_subbasis n Xi.
set B0 := rational_open_intervals_basis.
set Ssmall := \/_ i :e n, {product_cylinder n Xi i U|U :e B0}.

(** First show euclidean_space/topology agree with the product-space presentation. **)
claim HXeq: euclidean_space n = Xprod.
{ reflexivity. }
claim HTeq: euclidean_topology n = Tfull.
{ reflexivity. }
rewrite HXeq.
rewrite HTeq.

(** Case split on n=Empty (empty product space). **)
apply (xm (n = Empty)).
- assume Hn0: n = Empty.
  rewrite Hn0.
  set Xi0 := const_space_family Empty R R_standard_topology.
  set X0 := product_space Empty Xi0.
  set T0 := countable_product_topology_subbasis Empty Xi0.
  prove second_countable_space X0 T0.
  prove topology_on X0 T0 /\
    exists B:set, basis_on X0 B /\ countable_set B /\ basis_generates X0 B T0.
  apply andI.
  * exact (countable_product_topology_subbasis_empty_is_topology Xi0).
  * witness (Sing X0).
    prove basis_on X0 (Sing X0) /\ countable_set (Sing X0) /\ basis_generates X0 (Sing X0) T0.
    apply andI.
    + apply andI.
      - exact (basis_on_singleton X0).
      - exact (finite_countable (Sing X0) (Sing_finite X0)).
    + prove basis_generates X0 (Sing X0) T0.
      prove basis_on X0 (Sing X0) /\ generated_topology X0 (Sing X0) = T0.
      apply andI.
      - exact (basis_on_singleton X0).
      - (** Both sides are generated topologies; they coincide for the empty product. **)
        claim HTdef: T0 = generated_topology_from_subbasis X0 (product_subbasis_full Empty Xi0).
        { reflexivity. }
        rewrite HTdef.
        claim HS0: product_subbasis_full Empty Xi0 = Empty.
        { exact (famunion_Empty (fun i:set => {product_cylinder Empty Xi0 i U|U :e space_family_topology Xi0 i})). }
        rewrite HS0.
        claim HTsub0: generated_topology_from_subbasis X0 Empty =
          generated_topology X0 (basis_of_subbasis X0 Empty).
        { reflexivity. }
        rewrite HTsub0.
        (** basis_of_subbasis X0 Empty = {X0} and generated_topology X0 {X0} equals the singleton topology **)
        claim HB0: basis_of_subbasis X0 Empty = {X0}.
        { claim HX0ne: X0 <> Empty.
          { assume HX0E: X0 = Empty.
            claim HX0eq: X0 = {Empty}.
            { exact (product_space_empty_index Xi0). }
            claim Hem: Empty :e X0.
            { rewrite HX0eq.
              exact (SingI Empty). }
            claim HemE: Empty :e Empty.
            { rewrite <- HX0E at 2.
              exact Hem. }
            exact (EmptyE Empty HemE False). }
          exact (basis_of_subbasis_empty_eq X0 HX0ne). }
        rewrite HB0.
        claim HSing: (Sing X0) = {X0}.
        { reflexivity. }
        rewrite HSing.
        reflexivity.
- assume HnNe: ~(n = Empty).
  (** Show n is countable (as a subset of omega). **)
  claim HnSub: n c= omega.
  { exact (omega_TransSet n Hn). }
  claim HnCount: countable_set n.
  { exact (Subq_atleastp n omega HnSub). }

  (** Component topology facts for the constant family Xi. **)
	  claim HcompTop: forall i:set, i :e n -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
	  { let i. assume Hi: i :e n.
	    claim HXi: apply_fun Xi i = (R, R_standard_topology).
	    { exact (const_space_family_apply n R R_standard_topology i Hi). }
	    claim HXset: space_family_set Xi i = R.
	    { claim HXset_def: space_family_set Xi i = (apply_fun Xi i) 0.
	      { reflexivity. }
	      rewrite HXset_def.
	      rewrite HXi.
	      rewrite (tuple_2_0_eq R R_standard_topology).
	      reflexivity. }
	    claim HXtop: space_family_topology Xi i = R_standard_topology.
	    { claim HXtop_def: space_family_topology Xi i = (apply_fun Xi i) 1.
	      { reflexivity. }
	      rewrite HXtop_def.
	      rewrite HXi.
	      rewrite (tuple_2_1_eq R R_standard_topology).
	      reflexivity. }
	    rewrite HXset.
	    rewrite HXtop.
	    exact R_standard_topology_is_topology. }

  (** Subbasis_on for the restricted cylinder family Ssmall. **)
  claim HSsmall: subbasis_on Xprod Ssmall.
  { prove Ssmall c= Power Xprod /\ Union Ssmall = Xprod.
    apply andI.
    - let s. assume Hs: s :e Ssmall.
      prove s :e Power Xprod.
      apply PowerI.
      let f. assume Hf: f :e s.
      prove f :e Xprod.
      set F := (fun i:set => {product_cylinder n Xi i U|U :e B0}).
      claim HsF: s :e (\/_ i :e n, F i).
      { exact Hs. }
      apply (famunionE_impred n F s HsF (f :e Xprod)).
      let i.
      assume HiN: i :e n.
      assume HsFi: s :e F i.
      claim HexU: exists U :e B0, s = product_cylinder n Xi i U.
      { exact (ReplE B0 (fun U0:set => product_cylinder n Xi i U0) s HsFi). }
      apply HexU.
      let U.
      assume HUand: U :e B0 /\ s = product_cylinder n Xi i U.
      claim Hseq: s = product_cylinder n Xi i U.
      { exact (andER (U :e B0) (s = product_cylinder n Xi i U) HUand). }
      claim HfCyl: f :e product_cylinder n Xi i U.
      { rewrite <- Hseq.
        exact Hf. }
      (** f :e product_cylinder ... implies f :e product_space ... **)
      exact (SepE1 (product_space n Xi)
                  (fun f0:set => i :e n /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                  f
                  HfCyl).
    - apply set_ext.
      + let f. assume Hf: f :e Union Ssmall.
        prove f :e Xprod.
        apply (UnionE_impred Ssmall f Hf).
        let s. assume Hfs: f :e s. assume HsS: s :e Ssmall.
        set F := (fun i:set => {product_cylinder n Xi i U|U :e B0}).
        claim HsF: s :e (\/_ i :e n, F i).
        { exact HsS. }
        apply (famunionE_impred n F s HsF (f :e Xprod)).
        let i.
        assume HiN: i :e n.
        assume HsFi: s :e F i.
        claim HexU: exists U :e B0, s = product_cylinder n Xi i U.
        { exact (ReplE B0 (fun U0:set => product_cylinder n Xi i U0) s HsFi). }
        apply HexU.
        let U.
        assume HUand: U :e B0 /\ s = product_cylinder n Xi i U.
        claim HsEq: s = product_cylinder n Xi i U.
        { exact (andER (U :e B0) (s = product_cylinder n Xi i U) HUand). }
        claim HfCyl: f :e product_cylinder n Xi i U.
        { rewrite <- HsEq.
          exact Hfs. }
        exact (SepE1 (product_space n Xi)
                    (fun f0:set => i :e n /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                    f
                    HfCyl).
      + let f. assume Hf: f :e Xprod.
        prove f :e Union Ssmall.
        (** pick some i0 :e n, then a basis element around f i0 **)
        claim Hexi0: exists i0:set, i0 :e n.
        { exact (nonempty_has_element n HnNe). }
        apply Hexi0.
        let i0. assume Hi0: i0 :e n.
	        set x0 := apply_fun f i0.
	        (** x0 is in the i0 component set = R **)
	        claim Hx0R: x0 :e space_family_set Xi i0.
	        { claim Hfpack: (total_function_on f n (space_family_union n Xi) /\ functional_graph f) /\
	              forall i:set, i :e n -> apply_fun f i :e space_family_set Xi i.
	          { exact (SepE2 (Power (setprod n (space_family_union n Xi)))
	                         (fun f0:set => (total_function_on f0 n (space_family_union n Xi) /\ functional_graph f0) /\
	                           forall i:set, i :e n -> apply_fun f0 i :e space_family_set Xi i)
	                         f
	                         Hf). }
	          claim Hcoords: forall i:set, i :e n -> apply_fun f i :e space_family_set Xi i.
	          { exact (andER (total_function_on f n (space_family_union n Xi) /\ functional_graph f)
	                         (forall i:set, i :e n -> apply_fun f i :e space_family_set Xi i)
	                         Hfpack). }
	          exact (Hcoords i0 Hi0). }
        (** rewrite component set to R using const_space_family_apply **)
        claim HXi0: apply_fun Xi i0 = (R, R_standard_topology).
        { exact (const_space_family_apply n R R_standard_topology i0 Hi0). }
        claim HXset0: space_family_set Xi i0 = R.
        { claim HXset_def: space_family_set Xi i0 = (apply_fun Xi i0) 0.
          { reflexivity. }
          rewrite HXset_def.
          rewrite HXi0.
          rewrite (tuple_2_0_eq R R_standard_topology).
          reflexivity. }
        claim Hx0Rstd: x0 :e R.
        { rewrite <- HXset0.
          exact Hx0R. }
        claim HB0cover: forall x :e R, exists b :e B0, x :e b.
        { claim HBasisStd: basis_on R B0 /\ generated_topology R B0 = R_standard_topology.
          { exact ex13_8a_rational_intervals_basis_standard. }
          claim HBasis0: basis_on R B0.
          { exact (andEL (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd). }
          exact (basis_on_cover R B0 HBasis0). }
        claim Hexb: exists b :e B0, x0 :e b.
        { exact (HB0cover x0 Hx0Rstd). }
        apply Hexb.
        let b. assume Hbpair: b :e B0 /\ x0 :e b.
        claim HbB0: b :e B0.
        { exact (andEL (b :e B0) (x0 :e b) Hbpair). }
        claim Hx0b: x0 :e b.
        { exact (andER (b :e B0) (x0 :e b) Hbpair). }
        set s0 := product_cylinder n Xi i0 b.
        claim Hs0S: s0 :e Ssmall.
        { set F := (fun i:set => {product_cylinder n Xi i U|U :e B0}).
          prove s0 :e (\/_ i :e n, F i).
          exact (famunionI n F i0 s0 Hi0
                 (ReplI B0 (fun U0:set => product_cylinder n Xi i0 U0) b HbB0)). }
        prove f :e Union Ssmall.
        apply (UnionI Ssmall f s0).
	        - (** f :e s0 **)
	          prove f :e product_cylinder n Xi i0 b.
	          claim Hcyl_def: product_cylinder n Xi i0 b =
	            {f0 :e product_space n Xi | i0 :e n /\ b :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e b}.
	          { reflexivity. }
	          rewrite Hcyl_def.
	          apply (SepI (product_space n Xi)
	                      (fun f0:set => i0 :e n /\ b :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e b)
	                      f
	                      Hf).
	          apply andI.
	          + (** i0 :e n /\ b :e space_family_topology Xi i0 **)
	            apply andI.
	            * exact Hi0.
	            * (** b is open in the i0 topology **)
	              claim HBasisStd: basis_on R B0 /\ generated_topology R B0 = R_standard_topology.
	              { exact ex13_8a_rational_intervals_basis_standard. }
	              claim HbInStd: b :e R_standard_topology.
	              { rewrite <- (andER (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd).
	                claim HBasis0: basis_on R B0.
	                { exact (andEL (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd). }
	                exact (generated_topology_contains_basis R B0 HBasis0 b HbB0). }
	              claim HXtop0: space_family_topology Xi i0 = R_standard_topology.
	              { claim HXtop_def: space_family_topology Xi i0 = (apply_fun Xi i0) 1.
	                { reflexivity. }
	                rewrite HXtop_def.
	                rewrite HXi0.
	                rewrite (tuple_2_1_eq R R_standard_topology).
	                reflexivity. }
	              rewrite HXtop0.
	              exact HbInStd.
	          + exact Hx0b.
        - exact Hs0S. }

  (** Ssmall is countable. **)
  claim HSsmall_count: countable_set Ssmall.
  { prove countable_set Ssmall.
    set Bsel : set -> set := fun _ : set => B0.
    claim HB0count: countable_set B0.
    { exact rational_open_intervals_basis_countable. }
    claim HSigma: countable (Sigma_ i :e n, Bsel i).
    { apply (Sigma_countable n HnCount Bsel).
      let i. assume Hi: i :e n.
      exact HB0count. }
    set Fp : set -> set := fun p:set => product_cylinder n Xi (p 0) (p 1).
    claim Himg: countable_set {Fp p|p :e Sigma_ i :e n, Bsel i}.
    { exact (countable_image (Sigma_ i :e n, Bsel i) HSigma Fp). }
    claim Hsub: Ssmall c= {Fp p|p :e Sigma_ i :e n, Bsel i}.
    { let s. assume Hs: s :e Ssmall.
      prove s :e {Fp p|p :e Sigma_ i :e n, Bsel i}.
      set Fam := (fun i:set => {product_cylinder n Xi i U|U :e B0}).
      claim HsFam: s :e (\/_ i :e n, Fam i).
      { exact Hs. }
      apply (famunionE_impred n Fam s HsFam (s :e {Fp p|p :e Sigma_ i :e n, Bsel i})).
      let i. assume Hi: i :e n.
      assume HsFi: s :e Fam i.
      claim HexU: exists U :e B0, s = product_cylinder n Xi i U.
      { exact (ReplE B0 (fun U0:set => product_cylinder n Xi i U0) s HsFi). }
      apply HexU.
      let U.
      assume HUand: U :e B0 /\ s = product_cylinder n Xi i U.
      claim HU: U :e B0.
      { exact (andEL (U :e B0) (s = product_cylinder n Xi i U) HUand). }
      claim HsEq: s = product_cylinder n Xi i U.
      { exact (andER (U :e B0) (s = product_cylinder n Xi i U) HUand). }
      claim HpSig: (i,U) :e Sigma_ i0 :e n, Bsel i0.
      { exact (tuple_2_Sigma n Bsel i Hi U HU). }
      claim HFp: Fp (i,U) = product_cylinder n Xi i U.
      { claim HFdef: Fp (i,U) = product_cylinder n Xi ((i,U) 0) ((i,U) 1).
        { reflexivity. }
        rewrite HFdef.
        rewrite (tuple_2_0_eq i U).
        rewrite (tuple_2_1_eq i U).
        reflexivity. }
      rewrite HsEq.
      rewrite <- HFp.
      exact (ReplI (Sigma_ i0 :e n, Bsel i0) Fp (i,U) HpSig). }
    exact (Subq_countable Ssmall {Fp p|p :e Sigma_ i :e n, Bsel i} Himg Hsub). }

  (** Use the countable subbasis Ssmall to produce a countable basis. **)
  claim HTfull_top: topology_on Xprod Tfull.
  { exact (topology_from_subbasis_is_topology Xprod (product_subbasis_full n Xi)
           (product_subbasis_full_subbasis_on n Xi HnNe HcompTop)). }

  (** Show the generated topology from Ssmall coincides with Tfull. **)
  claim HTeq2: generated_topology_from_subbasis Xprod Ssmall = Tfull.
  { apply set_ext.
    - let U. assume HU: U :e generated_topology_from_subbasis Xprod Ssmall.
      prove U :e Tfull.
      claim HSfull: subbasis_on Xprod (product_subbasis_full n Xi).
      { exact (product_subbasis_full_subbasis_on n Xi HnNe HcompTop). }
      claim HSsmall_sub: Ssmall c= product_subbasis_full n Xi.
      { let s. assume Hs: s :e Ssmall.
        prove s :e product_subbasis_full n Xi.
        set Fam := (fun i:set => {product_cylinder n Xi i U0|U0 :e B0}).
        claim HsFam: s :e (\/_ i :e n, Fam i).
        { exact Hs. }
        apply (famunionE_impred n Fam s HsFam (s :e product_subbasis_full n Xi)).
        let i. assume Hi: i :e n.
        assume HsFi: s :e Fam i.
        claim HexU: exists U0 :e B0, s = product_cylinder n Xi i U0.
        { exact (ReplE B0 (fun U0:set => product_cylinder n Xi i U0) s HsFi). }
        apply HexU.
        let U0.
        assume HUand: U0 :e B0 /\ s = product_cylinder n Xi i U0.
        claim HU0: U0 :e B0.
        { exact (andEL (U0 :e B0) (s = product_cylinder n Xi i U0) HUand). }
        claim HsEq: s = product_cylinder n Xi i U0.
        { exact (andER (U0 :e B0) (s = product_cylinder n Xi i U0) HUand). }
        rewrite HsEq.
        (** show U0 is open in the i-th topology, hence this cylinder lies in the full subbasis **)
        claim HBasisStd: basis_on R B0 /\ generated_topology R B0 = R_standard_topology.
        { exact ex13_8a_rational_intervals_basis_standard. }
        claim HBasis0: basis_on R B0.
        { exact (andEL (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd). }
        claim HU0std: U0 :e R_standard_topology.
        { rewrite <- (andER (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd).
          exact (generated_topology_contains_basis R B0 HBasis0 U0 HU0). }
        claim HXi_i: apply_fun Xi i = (R, R_standard_topology).
        { exact (const_space_family_apply n R R_standard_topology i Hi). }
        claim HXtopi: space_family_topology Xi i = R_standard_topology.
        { claim HXtop_def: space_family_topology Xi i = (apply_fun Xi i) 1.
          { reflexivity. }
          rewrite HXtop_def.
          rewrite HXi_i.
          rewrite (tuple_2_1_eq R R_standard_topology).
          reflexivity. }
        claim HU0top: U0 :e space_family_topology Xi i.
        { rewrite HXtopi.
          exact HU0std. }
        (** cylinder is in the family {product_cylinder ... i U|U :e Ti} **)
        set Ffull := (fun j:set => {product_cylinder n Xi j Uj|Uj :e space_family_topology Xi j}).
        prove product_cylinder n Xi i U0 :e (\/_ j :e n, Ffull j).
        exact (famunionI n Ffull i (product_cylinder n Xi i U0) Hi
               (ReplI (space_family_topology Xi i) (fun Uj:set => product_cylinder n Xi i Uj) U0 HU0top)). }
      claim HTsub: topology_on Xprod Tfull.
      { exact HTfull_top. }
      claim HSsmall_in_Tfull: Ssmall c= Tfull.
      { let s. assume Hs: s :e Ssmall.
        exact (subbasis_elem_open_in_generated_from_subbasis Xprod (product_subbasis_full n Xi) s
               (product_subbasis_full_subbasis_on n Xi HnNe HcompTop) (HSsmall_sub s Hs)). }
      claim Hinc: generated_topology_from_subbasis Xprod Ssmall c= Tfull.
      { exact (topology_generated_by_basis_is_minimal Xprod Ssmall Tfull HSsmall HTsub HSsmall_in_Tfull). }
      exact (Hinc U HU).
	    - let U. assume HU: U :e Tfull.
	      prove U :e generated_topology_from_subbasis Xprod Ssmall.
	      (** Show the full cylinder subbasis is contained in the topology generated by the restricted cylinders. **)
	      set Tsmall := generated_topology_from_subbasis Xprod Ssmall.
	      claim HTsmall: topology_on Xprod Tsmall.
	      { exact (topology_from_subbasis_is_topology Xprod Ssmall HSsmall). }
	      claim HSfull: subbasis_on Xprod (product_subbasis_full n Xi).
	      { exact (product_subbasis_full_subbasis_on n Xi HnNe HcompTop). }
	      claim HSubFull: product_subbasis_full n Xi c= Tsmall.
	      { let s. assume Hs: s :e product_subbasis_full n Xi.
	        prove s :e Tsmall.
	        set Ffull := (fun i:set => {product_cylinder n Xi i U0|U0 :e space_family_topology Xi i}).
	        claim HsF: s :e (\/_ i :e n, Ffull i).
	        { exact Hs. }
	        apply (famunionE_impred n Ffull s HsF (s :e Tsmall)).
	        let i.
	        assume Hi: i :e n.
	        assume HsFi: s :e Ffull i.
	        claim HexU0: exists U0 :e space_family_topology Xi i, s = product_cylinder n Xi i U0.
	        { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder n Xi i U0) s HsFi). }
	        apply HexU0.
	        let U0.
	        assume HU0and: U0 :e space_family_topology Xi i /\ s = product_cylinder n Xi i U0.
	        claim HU0top: U0 :e space_family_topology Xi i.
	        { exact (andEL (U0 :e space_family_topology Xi i) (s = product_cylinder n Xi i U0) HU0and). }
	        claim HsEq: s = product_cylinder n Xi i U0.
	        { exact (andER (U0 :e space_family_topology Xi i) (s = product_cylinder n Xi i U0) HU0and). }
	        rewrite HsEq.
	        (** Express the cylinder as a union of cylinders over the countable basis B0 refining U0. **)
	        set Fam := {b :e B0|b c= U0}.
	        set UFam := {product_cylinder n Xi i b|b :e Fam}.
	        claim HUFamSub: UFam c= Tsmall.
	        { let c. assume Hc: c :e UFam.
	          prove c :e Tsmall.
	          claim Hexb: exists b :e Fam, c = product_cylinder n Xi i b.
	          { exact (ReplE Fam (fun b0:set => product_cylinder n Xi i b0) c Hc). }
		          apply Hexb.
		          let b. assume Hbpair.
		          claim HbFam: b :e Fam.
		          { exact (andEL (b :e Fam) (c = product_cylinder n Xi i b) Hbpair). }
		          claim HcEq: c = product_cylinder n Xi i b.
		          { exact (andER (b :e Fam) (c = product_cylinder n Xi i b) Hbpair). }
		          rewrite HcEq.
		          claim HbB0: b :e B0.
		          { exact (SepE1 B0 (fun b0:set => b0 c= U0) b HbFam). }
	          claim HcSsmall: product_cylinder n Xi i b :e Ssmall.
	          { set F := (fun j:set => {product_cylinder n Xi j Uj|Uj :e B0}).
	            prove product_cylinder n Xi i b :e (\/_ j :e n, F j).
	            exact (famunionI n F i (product_cylinder n Xi i b) Hi
	                   (ReplI B0 (fun Uj:set => product_cylinder n Xi i Uj) b HbB0)). }
	          exact (subbasis_elem_open_in_generated_from_subbasis Xprod Ssmall (product_cylinder n Xi i b) HSsmall HcSsmall). }
	        claim HcylEq: product_cylinder n Xi i U0 = Union UFam.
	        { apply set_ext.
	          - let f. assume Hf: f :e product_cylinder n Xi i U0.
	            prove f :e Union UFam.
	            claim HfX: f :e Xprod.
	            { exact (SepE1 Xprod
	                            (fun f0:set => i :e n /\ U0 :e space_family_topology Xi i /\ apply_fun f0 i :e U0)
	                            f
	                            Hf). }
	            claim Hpred: (i :e n /\ U0 :e space_family_topology Xi i) /\ apply_fun f i :e U0.
	            { exact (SepE2 Xprod
	                           (fun f0:set => i :e n /\ U0 :e space_family_topology Xi i /\ apply_fun f0 i :e U0)
	                           f
	                           Hf). }
	            claim Hiu: i :e n /\ U0 :e space_family_topology Xi i.
	            { exact (andEL (i :e n /\ U0 :e space_family_topology Xi i) (apply_fun f i :e U0) Hpred). }
	            claim HiN: i :e n.
	            { exact (andEL (i :e n) (U0 :e space_family_topology Xi i) Hiu). }
	            claim HU0top2: U0 :e space_family_topology Xi i.
	            { exact (andER (i :e n) (U0 :e space_family_topology Xi i) Hiu). }
	            claim HfiU0: apply_fun f i :e U0.
	            { exact (andER (i :e n /\ U0 :e space_family_topology Xi i) (apply_fun f i :e U0) Hpred). }
	            (** Identify the i-th topology as the standard topology on R. **)
	            claim HXi_i: apply_fun Xi i = (R, R_standard_topology).
	            { exact (const_space_family_apply n R R_standard_topology i HiN). }
	            claim HXtopi: space_family_topology Xi i = R_standard_topology.
	            { claim HXtop_def: space_family_topology Xi i = (apply_fun Xi i) 1.
	              { reflexivity. }
	              rewrite HXtop_def.
	              rewrite HXi_i.
	              rewrite (tuple_2_1_eq R R_standard_topology).
	              reflexivity. }
	            claim HU0std: U0 :e R_standard_topology.
	            { rewrite <- HXtopi.
	              exact HU0top2. }
	            claim HBasisStd: basis_on R B0 /\ generated_topology R B0 = R_standard_topology.
	            { exact ex13_8a_rational_intervals_basis_standard. }
	            claim HU0gen: U0 :e generated_topology R B0.
	            { rewrite (andER (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd).
	              exact HU0std. }
	            (** Choose b :e B0 with f i :e b and b c= U0. **)
	            claim HU0loc: forall x :e U0, exists b :e B0, x :e b /\ b c= U0.
	            { exact (SepE2 (Power R)
	                           (fun U:set => forall x0 :e U, exists b :e B0, x0 :e b /\ b c= U)
	                           U0
	                           HU0gen). }
	            claim Hexb: exists b :e B0, apply_fun f i :e b /\ b c= U0.
	            { exact (HU0loc (apply_fun f i) HfiU0). }
	            apply Hexb.
	            let b. assume Hbpair.
	            claim HbB0: b :e B0.
	            { exact (andEL (b :e B0) (apply_fun f i :e b /\ b c= U0) Hbpair). }
	            claim Hbib: apply_fun f i :e b /\ b c= U0.
	            { exact (andER (b :e B0) (apply_fun f i :e b /\ b c= U0) Hbpair). }
	            claim Hfib: apply_fun f i :e b.
	            { exact (andEL (apply_fun f i :e b) (b c= U0) Hbib). }
	            claim HbSub: b c= U0.
	            { exact (andER (apply_fun f i :e b) (b c= U0) Hbib). }
	            claim HbFam: b :e Fam.
	            { exact (SepI B0 (fun b0:set => b0 c= U0) b HbB0 HbSub). }
	            set c := product_cylinder n Xi i b.
	            claim HcUFam: c :e UFam.
	            { exact (ReplI Fam (fun b0:set => product_cylinder n Xi i b0) b HbFam). }
	            apply (UnionI UFam f c).
	            + (** f :e c **)
	              prove f :e product_cylinder n Xi i b.
	              claim Hcyl_def: product_cylinder n Xi i b =
	                {f0 :e Xprod | i :e n /\ b :e space_family_topology Xi i /\ apply_fun f0 i :e b}.
	              { reflexivity. }
	              rewrite Hcyl_def.
	              apply (SepI Xprod
	                          (fun f0:set => i :e n /\ b :e space_family_topology Xi i /\ apply_fun f0 i :e b)
	                          f
	                          HfX).
	              claim Hleft: i :e n /\ b :e space_family_topology Xi i.
	              { claim HbStd: b :e R_standard_topology.
	                { rewrite <- (andER (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd).
	                  claim HBasis0: basis_on R B0.
	                  { exact (andEL (basis_on R B0) (generated_topology R B0 = R_standard_topology) HBasisStd). }
	                  exact (generated_topology_contains_basis R B0 HBasis0 b HbB0). }
	                claim HbTop: b :e space_family_topology Xi i.
	                { rewrite HXtopi.
	                  exact HbStd. }
	                exact (andI (i :e n) (b :e space_family_topology Xi i) HiN HbTop). }
	              exact (andI (i :e n /\ b :e space_family_topology Xi i) (apply_fun f i :e b) Hleft Hfib).
	            + exact HcUFam.
	          - let f. assume Hf: f :e Union UFam.
	            prove f :e product_cylinder n Xi i U0.
	            apply (UnionE_impred UFam f Hf).
	            let c. assume Hfc: f :e c. assume Hc: c :e UFam.
	            claim Hexb: exists b :e Fam, c = product_cylinder n Xi i b.
	            { exact (ReplE Fam (fun b0:set => product_cylinder n Xi i b0) c Hc). }
	            apply Hexb.
	            let b. assume Hbpair.
	            claim HbFam: b :e Fam.
	            { exact (andEL (b :e Fam) (c = product_cylinder n Xi i b) Hbpair). }
	            claim HcEq: c = product_cylinder n Xi i b.
	            { exact (andER (b :e Fam) (c = product_cylinder n Xi i b) Hbpair). }
	            claim HbSub: b c= U0.
	            { exact (SepE2 B0 (fun b0:set => b0 c= U0) b HbFam). }
	            claim HfCyl: f :e product_cylinder n Xi i b.
	            { rewrite <- HcEq.
	              exact Hfc. }
	            claim Hpredb: (i :e n /\ b :e space_family_topology Xi i) /\ apply_fun f i :e b.
	            { exact (SepE2 Xprod
	                           (fun f0:set => i :e n /\ b :e space_family_topology Xi i /\ apply_fun f0 i :e b)
	                           f
	                           HfCyl). }
	            claim Hiu: i :e n /\ b :e space_family_topology Xi i.
	            { exact (andEL (i :e n /\ b :e space_family_topology Xi i) (apply_fun f i :e b) Hpredb). }
	            claim HiN: i :e n.
	            { exact (andEL (i :e n) (b :e space_family_topology Xi i) Hiu). }
	            claim Hfib: apply_fun f i :e b.
	            { exact (andER (i :e n /\ b :e space_family_topology Xi i) (apply_fun f i :e b) Hpredb). }
	            claim HfiU0: apply_fun f i :e U0.
	            { exact (HbSub (apply_fun f i) Hfib). }
	            claim HfX: f :e Xprod.
	            { exact (SepE1 Xprod
	                            (fun f0:set => i :e n /\ b :e space_family_topology Xi i /\ apply_fun f0 i :e b)
	                            f
	                            HfCyl). }
	            claim HcylU0_def: product_cylinder n Xi i U0 =
	              {f0 :e Xprod | i :e n /\ U0 :e space_family_topology Xi i /\ apply_fun f0 i :e U0}.
	            { reflexivity. }
	            rewrite HcylU0_def.
	            apply (SepI Xprod
	                        (fun f0:set => i :e n /\ U0 :e space_family_topology Xi i /\ apply_fun f0 i :e U0)
	                        f
	                        HfX).
	            claim Hleft: i :e n /\ U0 :e space_family_topology Xi i.
	            { exact (andI (i :e n) (U0 :e space_family_topology Xi i) HiN HU0top). }
	            exact (andI (i :e n /\ U0 :e space_family_topology Xi i) (apply_fun f i :e U0) Hleft HfiU0). }
	        (** Union UFam is open in Tsmall, hence the cylinder is open in Tsmall. **)
	        claim HUFamSub2: UFam c= Tsmall.
	        { let c. assume Hc: c :e UFam.
	          exact (HUFamSub c Hc). }
	        claim HUnionOpen: Union UFam :e Tsmall.
	        { exact (topology_union_closed Xprod Tsmall UFam HTsmall HUFamSub2). }
	        rewrite HcylEq.
	        exact HUnionOpen. }
	      claim Hinc: generated_topology_from_subbasis Xprod (product_subbasis_full n Xi) c= Tsmall.
	      { exact (topology_generated_by_basis_is_minimal Xprod (product_subbasis_full n Xi) Tsmall HSfull HTsmall HSubFull). }
	      exact (Hinc U HU). }

  (** Conclude second countability using the countable basis basis_of_subbasis Xprod Ssmall. **)
  prove topology_on Xprod Tfull /\
    exists B:set, basis_on Xprod B /\ countable_set B /\ basis_generates Xprod B Tfull.
  apply andI.
  - exact HTfull_top.
  - witness (basis_of_subbasis Xprod Ssmall).
    prove basis_on Xprod (basis_of_subbasis Xprod Ssmall) /\ countable_set (basis_of_subbasis Xprod Ssmall) /\
      basis_generates Xprod (basis_of_subbasis Xprod Ssmall) Tfull.
    apply andI.
    + apply andI.
      * exact (finite_intersections_basis_of_subbasis Xprod Ssmall HSsmall).
      * exact (basis_of_subbasis_countable Xprod Ssmall HSsmall_count).
    + prove basis_generates Xprod (basis_of_subbasis Xprod Ssmall) Tfull.
      prove basis_on Xprod (basis_of_subbasis Xprod Ssmall) /\ generated_topology Xprod (basis_of_subbasis Xprod Ssmall) = Tfull.
      apply andI.
      * exact (finite_intersections_basis_of_subbasis Xprod Ssmall HSsmall).
      * claim HTsub: generated_topology_from_subbasis Xprod Ssmall =
          generated_topology Xprod (basis_of_subbasis Xprod Ssmall).
        { reflexivity. }
        rewrite <- HTsub.
        exact HTeq2.
Qed.

(** from §30 Example 2: uniform topology on R^omega not second countable **) 
(** LATEX VERSION: The uniform topology on the space of real sequences is first countable but not second countable. **)
Definition discrete_subspace : set -> set -> set -> prop := fun X Tx A =>
  A c= X /\
  (forall a:set, a :e A -> exists U:set, U :e Tx /\ U :/\: A = {a}).

(** from §30 Example 2: second countable implies discrete subspaces countable **) 
(** LATEX VERSION: In a second-countable space, every discrete subspace is countable. **)
Theorem second_countable_discrete_subspace_countable : forall X Tx A:set,
  second_countable_space X Tx ->
  discrete_subspace X Tx A ->
  countable_set A.
let X Tx A.
assume Hsc: second_countable_space X Tx.
assume Hdisc: discrete_subspace X Tx A.
prove countable_set A.
claim HAcX: A c= X.
{ exact (andEL (A c= X) (forall a:set, a :e A -> exists U:set, U :e Tx /\ U :/\: A = {a}) Hdisc). }
claim HdiscU: forall a:set, a :e A -> exists U:set, U :e Tx /\ U :/\: A = {a}.
{ exact (andER (A c= X) (forall a:set, a :e A -> exists U:set, U :e Tx /\ U :/\: A = {a}) Hdisc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx) (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx) Hsc). }
apply HexB.
let B. assume HBpair.
claim HBasisCount: basis_on X B /\ countable_set B.
{ exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBpair). }
claim HBasis: basis_on X B.
{ exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
claim HBcount: countable_set B.
{ exact (andER (basis_on X B) (countable_set B) HBasisCount). }
claim HBgener: basis_generates X B Tx.
{ exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBpair). }
claim HTxeq: generated_topology X B = Tx.
{ exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
set pick := (fun a:set =>
  Eps_i (fun b:set => b :e B /\
    exists U:set, U :e Tx /\ (U :/\: A = {a} /\ (a :e b /\ b c= U)))).
claim HpickP: forall a:set, a :e A ->
  (fun b:set => b :e B /\ exists U:set, U :e Tx /\ (U :/\: A = {a} /\ (a :e b /\ b c= U))) (pick a).
{ let a. assume Ha: a :e A.
  prove (fun b:set => b :e B /\ exists U:set, U :e Tx /\ (U :/\: A = {a} /\ (a :e b /\ b c= U))) (pick a).
  claim HexU: exists U:set, U :e Tx /\ U :/\: A = {a}.
  { exact (HdiscU a Ha). }
  apply HexU.
  let U. assume HUpair.
  claim HU: U :e Tx.
  { exact (andEL (U :e Tx) (U :/\: A = {a}) HUpair). }
  claim HUA: U :/\: A = {a}.
  { exact (andER (U :e Tx) (U :/\: A = {a}) HUpair). }
  claim HUinGen: U :e generated_topology X B.
  { rewrite HTxeq.
    exact HU. }
  claim HUbasis: forall x :e U, exists b :e B, x :e b /\ b c= U.
  { exact (SepE2 (Power X) (fun U0:set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0) U HUinGen). }
  claim HainUA: a :e U :/\: A.
  { rewrite HUA.
    exact (SingI a). }
  claim HaU: a :e U.
  { exact (binintersectE1 U A a HainUA). }
  claim Hexb: exists b :e B, a :e b /\ b c= U.
  { exact (HUbasis a HaU). }
  apply Hexb.
  let b. assume Hbpair2.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (a :e b /\ b c= U) Hbpair2). }
  claim Habsub: a :e b /\ b c= U.
  { exact (andER (b :e B) (a :e b /\ b c= U) Hbpair2). }
  claim Hab: a :e b.
  { exact (andEL (a :e b) (b c= U) Habsub). }
  claim HbsubU: b c= U.
  { exact (andER (a :e b) (b c= U) Habsub). }
  claim Hwit0: b :e B /\ exists U0:set, U0 :e Tx /\ (U0 :/\: A = {a} /\ (a :e b /\ b c= U0)).
  { apply andI.
    - exact HbB.
    - witness U.
      apply andI.
      + exact HU.
      + apply andI.
        * exact HUA.
        * apply andI.
          { exact Hab. }
          { exact HbsubU. } }
  exact (Eps_i_ax (fun b0:set => b0 :e B /\
    exists U0:set, U0 :e Tx /\ (U0 :/\: A = {a} /\ (a :e b0 /\ b0 c= U0))) b Hwit0). }
claim HinjAB: inj A B pick.
{ prove (forall a :e A, pick a :e B) /\ (forall a0 a1 :e A, pick a0 = pick a1 -> a0 = a1).
  apply andI.
  - let a. assume Ha: a :e A.
    prove pick a :e B.
    claim Hp: (fun b:set => b :e B /\ exists U:set, U :e Tx /\ (U :/\: A = {a} /\ (a :e b /\ b c= U))) (pick a).
    { exact (HpickP a Ha). }
    exact (andEL (pick a :e B)
                 (exists U:set, U :e Tx /\ (U :/\: A = {a} /\ (a :e pick a /\ pick a c= U)))
                 Hp).
  - let a0. assume Ha0: a0 :e A.
    let a1. assume Ha1: a1 :e A.
    assume Heq: pick a0 = pick a1.
    prove a0 = a1.
    claim Hp0: (fun b:set => b :e B /\ exists U:set, U :e Tx /\ (U :/\: A = {a0} /\ (a0 :e b /\ b c= U))) (pick a0).
    { exact (HpickP a0 Ha0). }
    claim Hp1: (fun b:set => b :e B /\ exists U:set, U :e Tx /\ (U :/\: A = {a1} /\ (a1 :e b /\ b c= U))) (pick a1).
    { exact (HpickP a1 Ha1). }
    claim Hex0: exists U:set, U :e Tx /\ (U :/\: A = {a0} /\ (a0 :e pick a0 /\ pick a0 c= U)).
    { exact (andER (pick a0 :e B)
                   (exists U:set, U :e Tx /\ (U :/\: A = {a0} /\ (a0 :e pick a0 /\ pick a0 c= U)))
                   Hp0). }
    claim Hex1: exists U:set, U :e Tx /\ (U :/\: A = {a1} /\ (a1 :e pick a1 /\ pick a1 c= U)).
    { exact (andER (pick a1 :e B)
                   (exists U:set, U :e Tx /\ (U :/\: A = {a1} /\ (a1 :e pick a1 /\ pick a1 c= U)))
                   Hp1). }
    claim Ha1inpick1: a1 :e pick a1.
    { apply Hex1.
      let U1. assume HU1pair.
      claim HU1rest: U1 :/\: A = {a1} /\ (a1 :e pick a1 /\ pick a1 c= U1).
      { exact (andER (U1 :e Tx) (U1 :/\: A = {a1} /\ (a1 :e pick a1 /\ pick a1 c= U1)) HU1pair). }
      exact (andEL (a1 :e pick a1) (pick a1 c= U1)
                   (andER (U1 :/\: A = {a1}) (a1 :e pick a1 /\ pick a1 c= U1) HU1rest)). }
    claim Ha1inpick0: a1 :e pick a0.
    { rewrite Heq.
      exact Ha1inpick1. }
    apply Hex0.
    let U0. assume HU0pair.
    claim HU0: U0 :e Tx.
    { exact (andEL (U0 :e Tx) (U0 :/\: A = {a0} /\ (a0 :e pick a0 /\ pick a0 c= U0)) HU0pair). }
    claim HU0rest: U0 :/\: A = {a0} /\ (a0 :e pick a0 /\ pick a0 c= U0).
    { exact (andER (U0 :e Tx) (U0 :/\: A = {a0} /\ (a0 :e pick a0 /\ pick a0 c= U0)) HU0pair). }
    claim HU0eq: U0 :/\: A = {a0}.
    { exact (andEL (U0 :/\: A = {a0}) (a0 :e pick a0 /\ pick a0 c= U0) HU0rest). }
    claim HsubU0: pick a0 c= U0.
    { exact (andER (a0 :e pick a0) (pick a0 c= U0)
                   (andER (U0 :/\: A = {a0}) (a0 :e pick a0 /\ pick a0 c= U0) HU0rest)). }
    claim Ha1U0: a1 :e U0.
    { exact (HsubU0 a1 Ha1inpick0). }
    claim Ha1UA: a1 :e U0 :/\: A.
    { exact (binintersectI U0 A a1 Ha1U0 Ha1). }
    claim Ha1sing: a1 :e {a0}.
    { rewrite <- HU0eq.
      exact Ha1UA. }
    symmetry.
    exact (singleton_elem a1 a0 Ha1sing). }
prove atleastp A omega.
apply atleastp_tra A B omega.
- prove atleastp A B.
  prove exists f : set -> set, inj A B f.
  witness pick.
  exact HinjAB.
- exact HBcount.
Qed.

(** from §30 Example 2: the subspace of binary sequences **) 
(** LATEX VERSION: Let A⊂R^ω be the set of all sequences of 0s and 1s; it is uncountable. **)
Definition binary_sequences_Romega : set :=
  {f :e real_sequences | forall n:set, n :e omega -> apply_fun f n :e {0,1}}.

(** from §30 Example 2: uncountability of the binary sequences subset **) 
(** LATEX VERSION: The set of binary sequences is uncountable because Power omega injects into it via characteristic functions. **)
Theorem binary_sequences_Romega_uncountable : ~ countable_set binary_sequences_Romega.
prove ~ countable_set binary_sequences_Romega.
assume Hcount: countable_set binary_sequences_Romega.
apply Hcount.
let g. assume Hg: inj binary_sequences_Romega omega g.
set F := (fun A:set => graph omega (fun n:set => if n :e A then 1 else 0)).
claim HF_inj: inj (Power omega) binary_sequences_Romega F.
{ prove (forall A :e Power omega, F A :e binary_sequences_Romega) /\
    (forall A B :e Power omega, F A = F B -> A = B).
  apply andI.
  - let A. assume HA: A :e Power omega.
    prove F A :e binary_sequences_Romega.
    apply (SepI real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) (F A)).
	    + (** F A :e real_sequences **)
	      set h := (fun n:set => if n :e A then 1 else 0).
	      claim Hsub: graph omega h c= setprod omega R.
      { let p. assume Hp: p :e graph omega h.
        prove p :e setprod omega R.
        apply (ReplE_impred omega (fun i:set => (i, h i)) p Hp (p :e setprod omega R)).
        let i. assume Hi: i :e omega. assume Hpdef: p = (i, h i).
        rewrite Hpdef.
        claim HhiR: h i :e R.
        { apply (xm (i :e A) (h i :e R)).
          - assume HiA: i :e A.
            claim Heq: h i = 1.
            { exact (If_i_1 (i :e A) 1 0 HiA). }
            rewrite Heq.
            exact real_1.
          - assume HniA: ~(i :e A).
            claim Heq: h i = 0.
            { exact (If_i_0 (i :e A) 1 0 HniA). }
            rewrite Heq.
            exact real_0. }
        exact (tuple_2_setprod_by_pair_Sigma omega R i (h i) Hi HhiR). }
	      claim Hpow: graph omega h :e Power (setprod omega R).
	      { exact (PowerI (setprod omega R) (graph omega h) Hsub). }
	      claim Htot: total_function_on (graph omega h) omega R.
	      { prove function_on (graph omega h) omega R /\
	          forall i:set, i :e omega -> exists y:set, y :e R /\ (i,y) :e (graph omega h).
	        apply andI.
	        - let i. assume Hi: i :e omega.
	          prove apply_fun (graph omega h) i :e R.
	          claim Happ: apply_fun (graph omega h) i = h i.
	          { exact (apply_fun_graph omega h i Hi). }
	          rewrite Happ.
	          apply (xm (i :e A) (h i :e R)).
	          + assume HiA: i :e A.
	            claim Heq: h i = 1.
	            { exact (If_i_1 (i :e A) 1 0 HiA). }
	            rewrite Heq.
	            exact real_1.
	          + assume HniA: ~(i :e A).
	            claim Heq: h i = 0.
	            { exact (If_i_0 (i :e A) 1 0 HniA). }
	            rewrite Heq.
	            exact real_0.
	        - let i. assume Hi: i :e omega.
	          witness (h i).
	          prove (h i :e R /\ (i, h i) :e graph omega h).
	          apply andI.
	          + apply (xm (i :e A) (h i :e R)).
	            * assume HiA: i :e A.
	              claim Heq: h i = 1.
	              { exact (If_i_1 (i :e A) 1 0 HiA). }
	              rewrite Heq.
	              exact real_1.
	            * assume HniA: ~(i :e A).
	              claim Heq: h i = 0.
	              { exact (If_i_0 (i :e A) 1 0 HniA). }
	              rewrite Heq.
	              exact real_0.
	          + exact (ReplI omega (fun k:set => (k, h k)) i Hi).
	      }
	      claim Hfg: functional_graph (graph omega h).
	      { exact (functional_graph_graph omega h). }
	      exact (SepI (Power (setprod omega R))
	                  (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
	                  (graph omega h)
	                  Hpow
	                  (andI (total_function_on (graph omega h) omega R)
	                        (functional_graph (graph omega h))
	                        Htot Hfg)).
	    + (** values lie in {0,1} **)
	      let n. assume Hn: n :e omega.
	      prove apply_fun (F A) n :e {0,1}.
      claim Happ: apply_fun (F A) n = if n :e A then 1 else 0.
      { exact (apply_fun_graph omega (fun k:set => if k :e A then 1 else 0) n Hn). }
      rewrite Happ.
      apply (xm (n :e A) ((if n :e A then 1 else 0) :e {0,1})).
      * assume HnA: n :e A.
        rewrite (If_i_1 (n :e A) 1 0 HnA).
        exact (UPairI2 0 1).
      * assume HnnotA: ~(n :e A).
        rewrite (If_i_0 (n :e A) 1 0 HnnotA).
        exact (UPairI1 0 1).
  - let A. assume HA: A :e Power omega.
    let B. assume HB: B :e Power omega.
    assume Heq: F A = F B.
    prove A = B.
    apply set_ext.
    + let n. assume HnA: n :e A.
      prove n :e B.
      apply (xm (n :e B) (n :e B)).
      * assume HnB: n :e B.
        exact HnB.
      * assume HnnotB: ~(n :e B).
        claim HnO: n :e omega.
        { exact (PowerE omega A HA n HnA). }
        claim HAval: apply_fun (F A) n = 1.
        { claim HFdef: F A = graph omega (fun k:set => if k :e A then 1 else 0).
          { reflexivity. }
          rewrite HFdef.
          rewrite (apply_fun_graph omega (fun k:set => if k :e A then 1 else 0) n HnO).
          rewrite (If_i_1 (n :e A) 1 0 HnA).
          reflexivity. }
        claim HBval: apply_fun (F B) n = 0.
        { claim HFdef: F B = graph omega (fun k:set => if k :e B then 1 else 0).
          { reflexivity. }
          rewrite HFdef.
          rewrite (apply_fun_graph omega (fun k:set => if k :e B then 1 else 0) n HnO).
          rewrite (If_i_0 (n :e B) 1 0 HnnotB).
          reflexivity. }
        claim HappEq: apply_fun (F A) n = apply_fun (F B) n.
        { rewrite Heq.
          reflexivity. }
        claim H1: 1 = apply_fun (F B) n.
        { rewrite <- HappEq.
          symmetry.
          exact HAval. }
        claim Hcontra: 1 = 0.
        { rewrite <- HBval at 2.
          exact H1. }
        claim H01: 0 = 1.
        { symmetry. exact Hcontra. }
        exact (FalseE (neq_0_1 H01) (n :e B)). 
    + let n. assume HnB: n :e B.
      prove n :e A.
      apply (xm (n :e A) (n :e A)).
      * assume HnA: n :e A.
        exact HnA.
      * assume HnnotA: ~(n :e A).
        claim HnO: n :e omega.
        { exact (PowerE omega B HB n HnB). }
        claim HBval: apply_fun (F B) n = 1.
        { claim HFdef: F B = graph omega (fun k:set => if k :e B then 1 else 0).
          { reflexivity. }
          rewrite HFdef.
          rewrite (apply_fun_graph omega (fun k:set => if k :e B then 1 else 0) n HnO).
          rewrite (If_i_1 (n :e B) 1 0 HnB).
          reflexivity. }
        claim HAval: apply_fun (F A) n = 0.
        { claim HFdef: F A = graph omega (fun k:set => if k :e A then 1 else 0).
          { reflexivity. }
          rewrite HFdef.
          rewrite (apply_fun_graph omega (fun k:set => if k :e A then 1 else 0) n HnO).
          rewrite (If_i_0 (n :e A) 1 0 HnnotA).
          reflexivity. }
        claim HappEqAB: apply_fun (F A) n = apply_fun (F B) n.
        { rewrite Heq.
          reflexivity. }
        claim HappEq: apply_fun (F B) n = apply_fun (F A) n.
        { symmetry.
          exact HappEqAB. }
        claim H1: 1 = apply_fun (F A) n.
        { rewrite <- HappEq.
          symmetry.
          exact HBval. }
        claim Hcontra: 1 = 0.
        { rewrite <- HAval at 2.
          exact H1. }
        claim H01: 0 = 1.
        { symmetry. exact Hcontra. }
        exact (FalseE (neq_0_1 H01) (n :e A)). }
set h := (fun A:set => g (F A)).
claim HinjPow: inj (Power omega) omega h.
{ exact (inj_comp (Power omega) binary_sequences_Romega omega F g HF_inj Hg). }
exact (form100_22_v2 h HinjPow).
Qed.

(** from §30 Example 2: discreteness of binary sequences in the uniform topology **) 
(** LATEX VERSION: In the uniform metric, any two distinct binary sequences have distance 1, hence the subspace is discrete. **)
(** helper: unpack real_sequences membership **)
Theorem real_sequences_in_Power_setprod : forall f:set,
  f :e real_sequences -> f :e Power (setprod omega R).
let f. assume Hf: f :e real_sequences.
exact (SepE1 (Power (setprod omega R))
             (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
             f Hf).
Qed.

Theorem real_sequences_total : forall f:set,
  f :e real_sequences -> total_function_on f omega R.
let f. assume Hf: f :e real_sequences.
claim Hpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
exact (andEL (total_function_on f omega R) (functional_graph f) Hpack).
Qed.

Theorem real_sequences_functional : forall f:set,
  f :e real_sequences -> functional_graph f.
let f. assume Hf: f :e real_sequences.
claim Hpack: total_function_on f omega R /\ functional_graph f.
{ exact (SepE2 (Power (setprod omega R))
               (fun f0:set => total_function_on f0 omega R /\ functional_graph f0)
               f Hf). }
exact (andER (total_function_on f omega R) (functional_graph f) Hpack).
Qed.

(** helper: distinct sequences differ at some coordinate **)
Theorem real_sequences_neq_exists_coord : forall f g:set,
  f :e real_sequences ->
  g :e real_sequences ->
  f <> g ->
  exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n.
let f g.
assume Hf: f :e real_sequences.
assume Hg: g :e real_sequences.
assume Hneq: f <> g.
apply (xm (exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n)
          (exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n)).
- assume Hex.
  exact Hex.
- assume Hnot: ~ (exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n).
  claim Heqpt: forall n:set, n :e omega -> apply_fun f n = apply_fun g n.
  { let n. assume Hn: n :e omega.
    apply (xm (apply_fun f n = apply_fun g n) (apply_fun f n = apply_fun g n)).
    - assume Heq. exact Heq.
    - assume Hneqval: ~(apply_fun f n = apply_fun g n).
      claim Hex: exists k:set, k :e omega /\ apply_fun f k <> apply_fun g k.
      { witness n.
        apply andI.
        - exact Hn.
        - assume Heq.
          exact (Hneqval Heq). }
      exact (FalseE (Hnot Hex) (apply_fun f n = apply_fun g n)). }
  claim Hpowf: f :e Power (setprod omega R).
  { exact (real_sequences_in_Power_setprod f Hf). }
  claim Hpowg: g :e Power (setprod omega R).
  { exact (real_sequences_in_Power_setprod g Hg). }
  claim Hsubf: f c= setprod omega R.
  { exact (PowerE (setprod omega R) f Hpowf). }
  claim Hsubg: g c= setprod omega R.
  { exact (PowerE (setprod omega R) g Hpowg). }
  claim Htotf: total_function_on f omega R.
  { exact (real_sequences_total f Hf). }
  claim Htotg: total_function_on g omega R.
  { exact (real_sequences_total g Hg). }
  claim Hfunf: functional_graph f.
  { exact (real_sequences_functional f Hf). }
  claim Hfung: functional_graph g.
  { exact (real_sequences_functional g Hg). }
  claim Hsub_fg: f c= g.
  { let p. assume Hp: p :e f.
    prove p :e g.
    claim HpProd: p :e setprod omega R.
    { exact (Hsubf p Hp). }
    apply (Sigma_E omega (fun _ : set => R) p HpProd).
    let n.
    assume Hn_pair.
    apply Hn_pair.
    assume Hn: n :e omega.
    assume Hrest.
    apply Hrest.
    let y.
    assume Hy_pair.
    apply Hy_pair.
    assume Hy: y :e R.
    assume Hpdef.
    claim HpdefT: p = (n,y).
    { rewrite <- (tuple_pair n y) at 1.
      exact Hpdef. }
    rewrite HpdefT.
    claim Hpf: (n,y) :e f.
    { rewrite <- HpdefT.
      exact Hp. }
    claim Happf: apply_fun f n = y.
    { exact (functional_graph_apply_fun_eq f n y Hfunf Hpf). }
    claim Happg: apply_fun g n = y.
    { rewrite <- Happf.
      symmetry.
      exact (Heqpt n Hn). }
    claim Hpg: (n, apply_fun g n) :e g.
    { exact (total_function_on_apply_fun_in_graph g omega R n Htotg Hn). }
    claim HtupEq: (n, apply_fun g n) = (n,y).
    { rewrite Happg.
      reflexivity. }
    rewrite <- HtupEq.
    exact Hpg. }
  claim Hsub_gf: g c= f.
  { let p. assume Hp: p :e g.
    prove p :e f.
    claim HpProd: p :e setprod omega R.
    { exact (Hsubg p Hp). }
    apply (Sigma_E omega (fun _ : set => R) p HpProd).
    let n.
    assume Hn_pair.
    apply Hn_pair.
    assume Hn: n :e omega.
    assume Hrest.
    apply Hrest.
    let y.
    assume Hy_pair.
    apply Hy_pair.
    assume Hy: y :e R.
    assume Hpdef.
    claim HpdefT: p = (n,y).
    { rewrite <- (tuple_pair n y) at 1.
      exact Hpdef. }
    rewrite HpdefT.
    claim Hpg: (n,y) :e g.
    { rewrite <- HpdefT.
      exact Hp. }
    claim Happg: apply_fun g n = y.
    { exact (functional_graph_apply_fun_eq g n y Hfung Hpg). }
    claim Happf: apply_fun f n = y.
    { rewrite <- Happg.
      exact (Heqpt n Hn). }
    claim Hpf: (n, apply_fun f n) :e f.
    { exact (total_function_on_apply_fun_in_graph f omega R n Htotf Hn). }
    claim HtupEq: (n, apply_fun f n) = (n,y).
    { rewrite Happf.
      reflexivity. }
    rewrite <- HtupEq.
    exact Hpf. }
  claim Heq: f = g.
  { exact (set_ext f g Hsub_fg Hsub_gf). }
  exact (FalseE (Hneq Heq) (exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n)).
Qed.

(** helper: R_eq_of_not_Rlt, Rle_antisym, R_lub_unique moved earlier **)

(** helper: distance 1 between distinct binary sequences (intended property of the uniform metric) **)
(** LATEX VERSION: For a≠b in {0,1}^ω, one has \\bar\\rho(a,b)=1. **)
Theorem uniform_metric_Romega_binary_dist_1 : forall f g:set,
  f :e binary_sequences_Romega ->
  g :e binary_sequences_Romega ->
  f <> g ->
  apply_fun uniform_metric_Romega (f,g) = 1.
let f g.
assume Hf: f :e binary_sequences_Romega.
assume Hg: g :e binary_sequences_Romega.
assume Hneq: f <> g.
claim HfX: f :e real_sequences.
{ exact (SepE1 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) f Hf). }
claim HgX: g :e real_sequences.
{ exact (SepE1 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) g Hg). }
claim Hpair: (f,g) :e setprod real_sequences real_sequences.
{ exact (tuple_2_setprod_by_pair_Sigma real_sequences real_sequences f g HfX HgX). }
rewrite (apply_fun_graph (setprod real_sequences real_sequences)
                         (fun p:set => Romega_uniform_metric_value (p 0) (p 1))
                         (f,g) Hpair).
claim H0: (f,g) 0 = f.
{ exact (tuple_2_0_eq f g). }
claim H1: (f,g) 1 = g.
{ exact (tuple_2_1_eq f g). }
rewrite H0 at 1.
rewrite H1 at 1.
set A := Romega_clipped_diffs f g.
set P := (fun r:set => R_lub A r).
claim Hdef: Romega_uniform_metric_value f g = Eps_i P.
{ reflexivity. }
rewrite Hdef.
claim Hlub1: R_lub A 1.
{ prove (1 :e R /\ (forall a:set, a :e A -> a :e R -> Rle a 1)) /\
        (forall u:set, u :e R -> (forall a:set, a :e A -> a :e R -> Rle a u) -> Rle 1 u).
  apply andI.
  - apply andI.
    + exact real_1.
    + let a. assume Ha: a :e A.
      assume HaR: a :e R.
      prove Rle a 1.
      apply (ReplE_impred omega (fun n:set => Romega_coord_clipped_diff f g n) a Ha (Rle a 1)).
      let n. assume Hn: n :e omega.
      assume Haeq: a = Romega_coord_clipped_diff f g n.
      rewrite Haeq.
      apply (xm (Rlt (Romega_coord_abs_diff f g n) 1)
                (Rle (Romega_coord_clipped_diff f g n) 1)).
      * assume Hlt: Rlt (Romega_coord_abs_diff f g n) 1.
        claim Hdefc: Romega_coord_clipped_diff f g n =
          If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
        { reflexivity. }
        rewrite Hdefc.
        rewrite (If_i_1 (Rlt (Romega_coord_abs_diff f g n) 1)
                        (Romega_coord_abs_diff f g n) 1 Hlt).
        exact (Rlt_implies_Rle (Romega_coord_abs_diff f g n) 1 Hlt).
      * assume Hnlt: ~(Rlt (Romega_coord_abs_diff f g n) 1).
        claim Hdefc: Romega_coord_clipped_diff f g n =
          If_i (Rlt (Romega_coord_abs_diff f g n) 1) (Romega_coord_abs_diff f g n) 1.
        { reflexivity. }
        rewrite Hdefc.
        rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n) 1)
                        (Romega_coord_abs_diff f g n) 1 Hnlt).
        exact (Rle_refl 1 real_1).
  - let u. assume HuR: u :e R.
    assume Hub: forall a:set, a :e A -> a :e R -> Rle a u.
    prove Rle 1 u.
    claim Hexn: exists n:set, n :e omega /\ apply_fun f n <> apply_fun g n.
    { exact (real_sequences_neq_exists_coord f g HfX HgX Hneq). }
    set n0 := Eps_i (fun n:set => n :e omega /\ apply_fun f n <> apply_fun g n).
    claim Hn0: n0 :e omega /\ apply_fun f n0 <> apply_fun g n0.
    { exact (Eps_i_ex (fun n:set => n :e omega /\ apply_fun f n <> apply_fun g n) Hexn). }
    claim Hn0O: n0 :e omega.
    { exact (andEL (n0 :e omega) (apply_fun f n0 <> apply_fun g n0) Hn0). }
    claim Hn0neq: apply_fun f n0 <> apply_fun g n0.
    { exact (andER (n0 :e omega) (apply_fun f n0 <> apply_fun g n0) Hn0). }
    claim Hfvals: forall n:set, n :e omega -> apply_fun f n :e {0,1}.
    { exact (SepE2 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) f Hf). }
    claim Hgvals: forall n:set, n :e omega -> apply_fun g n :e {0,1}.
    { exact (SepE2 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) g Hg). }
    claim Hf0: apply_fun f n0 :e {0,1}.
    { exact (Hfvals n0 Hn0O). }
    claim Hg0: apply_fun g n0 :e {0,1}.
    { exact (Hgvals n0 Hn0O). }
    claim Hclip1: Romega_coord_clipped_diff f g n0 = 1.
    { (** case split on the two binary values **)
      apply (UPairE (apply_fun f n0) 0 1 Hf0).
      - assume Hfn0: apply_fun f n0 = 0.
        apply (UPairE (apply_fun g n0) 0 1 Hg0).
        + assume Hgn0: apply_fun g n0 = 0.
          claim Heq: apply_fun f n0 = apply_fun g n0.
          { rewrite Hfn0. rewrite Hgn0. reflexivity. }
          exact (FalseE (Hn0neq Heq) (Romega_coord_clipped_diff f g n0 = 1)).
	        + assume Hgn1: apply_fun g n0 = 1.
	          (** abs(0-1)=1, so the clipped value is 1 **)
	          claim Habs: Romega_coord_abs_diff f g n0 = 1.
	          { claim Hdefabs: Romega_coord_abs_diff f g n0 =
	              abs_SNo (add_SNo (apply_fun f n0) (minus_SNo (apply_fun g n0))).
	            { reflexivity. }
	            rewrite Hdefabs.
	            rewrite Hfn0.
	            rewrite Hgn1.
	            rewrite (add_SNo_0L (minus_SNo 1) (SNo_minus_SNo 1 SNo_1)).
	            rewrite (abs_SNo_minus 1 SNo_1).
	            rewrite (pos_abs_SNo 1 SNoLt_0_1).
	            reflexivity. }
	          claim Hnlt: ~(Rlt (Romega_coord_abs_diff f g n0) 1).
	          { rewrite Habs.
	            exact (not_Rlt_refl 1 real_1). }
	          claim Hdefc: Romega_coord_clipped_diff f g n0 =
	            If_i (Rlt (Romega_coord_abs_diff f g n0) 1) (Romega_coord_abs_diff f g n0) 1.
	          { reflexivity. }
	          rewrite Hdefc.
	          rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n0) 1)
	                          (Romega_coord_abs_diff f g n0) 1 Hnlt).
	          reflexivity.
      - assume Hfn1: apply_fun f n0 = 1.
        apply (UPairE (apply_fun g n0) 0 1 Hg0).
	        + assume Hgn0: apply_fun g n0 = 0.
	          claim Habs: Romega_coord_abs_diff f g n0 = 1.
	          { claim Hdefabs: Romega_coord_abs_diff f g n0 =
	              abs_SNo (add_SNo (apply_fun f n0) (minus_SNo (apply_fun g n0))).
	            { reflexivity. }
	            rewrite Hdefabs.
	            rewrite Hfn1.
	            rewrite Hgn0.
	            rewrite minus_SNo_0.
	            rewrite (add_SNo_0R 1 SNo_1).
	            rewrite (pos_abs_SNo 1 SNoLt_0_1).
	            reflexivity. }
	          claim Hnlt: ~(Rlt (Romega_coord_abs_diff f g n0) 1).
	          { rewrite Habs.
	            exact (not_Rlt_refl 1 real_1). }
	          claim Hdefc: Romega_coord_clipped_diff f g n0 =
	            If_i (Rlt (Romega_coord_abs_diff f g n0) 1) (Romega_coord_abs_diff f g n0) 1.
	          { reflexivity. }
	          rewrite Hdefc.
	          rewrite (If_i_0 (Rlt (Romega_coord_abs_diff f g n0) 1)
	                          (Romega_coord_abs_diff f g n0) 1 Hnlt).
	          reflexivity.
        + assume Hgn1: apply_fun g n0 = 1.
          claim Heq: apply_fun f n0 = apply_fun g n0.
          { rewrite Hfn1. rewrite Hgn1. reflexivity. }
          exact (FalseE (Hn0neq Heq) (Romega_coord_clipped_diff f g n0 = 1)). }
    claim H1inA: 1 :e A.
    { claim Hin: Romega_coord_clipped_diff f g n0 :e A.
      { exact (ReplI omega (fun n:set => Romega_coord_clipped_diff f g n) n0 Hn0O). }
      rewrite <- Hclip1 at 1.
      exact Hin. }
    exact (Hub 1 H1inA real_1). }
claim Hex: exists r:set, P r.
{ witness 1.
  exact Hlub1. }
claim HlubChosen: P (Eps_i P).
{ exact (Eps_i_ex P Hex). }
exact (R_lub_unique A (Eps_i P) 1 HlubChosen Hlub1).
Qed.

Theorem binary_sequences_Romega_discrete_in_uniform_topology :
  discrete_subspace real_sequences uniform_topology binary_sequences_Romega.
prove discrete_subspace real_sequences uniform_topology binary_sequences_Romega.
prove binary_sequences_Romega c= real_sequences /\
  (forall a:set, a :e binary_sequences_Romega ->
    exists U:set, U :e uniform_topology /\ U :/\: binary_sequences_Romega = {a}).
apply andI.
- (** subset **)
  let f. assume Hf: f :e binary_sequences_Romega.
  prove f :e real_sequences.
  exact (SepE1 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) f Hf).
- (** isolate each point by an open ball of radius 1 **)
  let a. assume Ha: a :e binary_sequences_Romega.
  set U := open_ball real_sequences uniform_metric_Romega a 1.
  witness U.
  prove U :e uniform_topology /\ U :/\: binary_sequences_Romega = {a}.
  apply andI.
  + (** U is open **)
    claim HaX: a :e real_sequences.
    { exact (SepE1 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) a Ha). }
    claim H0lt1: Rlt 0 1.
    { exact Rlt_0_1. }
    exact (open_ball_in_metric_topology real_sequences uniform_metric_Romega a 1
              uniform_metric_Romega_is_metric HaX H0lt1).
  + (** U ∩ A = {a} **)
    apply set_ext.
    - let f. assume HfUA: f :e U :/\: binary_sequences_Romega.
      prove f :e {a}.
      claim HfU: f :e U.
      { exact (binintersectE1 U binary_sequences_Romega f HfUA). }
      claim HfA: f :e binary_sequences_Romega.
      { exact (binintersectE2 U binary_sequences_Romega f HfUA). }
      claim Hdistlt: Rlt (apply_fun uniform_metric_Romega (a,f)) 1.
      { exact (open_ballE2 real_sequences uniform_metric_Romega a 1 f HfU). }
      apply (xm (f = a) (f :e {a})).
      * assume Hfa: f = a.
        rewrite Hfa.
        exact (SingI a).
      * assume Hfna: ~(f = a).
        claim Hdist1: apply_fun uniform_metric_Romega (a,f) = 1.
        { apply (uniform_metric_Romega_binary_dist_1 a f Ha HfA).
          assume Heq: a = f.
          apply Hfna.
          symmetry.
          exact Heq. }
        claim Hbad: Rlt 1 1.
        { rewrite <- Hdist1 at 1.
          exact Hdistlt. }
        exact (FalseE ((not_Rlt_refl 1 real_1) Hbad) (f :e {a})).
    - let f. assume Hf: f :e {a}.
      prove f :e U :/\: binary_sequences_Romega.
      claim Hfa: f = a.
      { exact (singleton_elem f a Hf). }
      rewrite Hfa.
      apply (binintersectI U binary_sequences_Romega a).
      * (** a :e U **)
        claim HaX: a :e real_sequences.
        { exact (SepE1 real_sequences (fun f0:set => forall n:set, n :e omega -> apply_fun f0 n :e {0,1}) a Ha). }
        claim H0lt1: Rlt 0 1.
        { exact Rlt_0_1. }
        exact (center_in_open_ball real_sequences uniform_metric_Romega a 1
                uniform_metric_Romega_is_metric HaX H0lt1).
      * exact Ha.
Qed.



Theorem Romega_uniform_first_not_second_countable :
  first_countable_space real_sequences uniform_topology /\
  ~ second_countable_space real_sequences uniform_topology.
prove first_countable_space real_sequences uniform_topology /\ ~ second_countable_space real_sequences uniform_topology.
apply andI.
- exact uniform_topology_first_countable.
- assume Hsc: second_countable_space real_sequences uniform_topology.
  prove False.
  claim Hdisc: discrete_subspace real_sequences uniform_topology binary_sequences_Romega.
  { exact binary_sequences_Romega_discrete_in_uniform_topology. }
  claim Hcount: countable_set binary_sequences_Romega.
  { exact (second_countable_discrete_subspace_countable real_sequences uniform_topology binary_sequences_Romega Hsc Hdisc). }
  exact (binary_sequences_Romega_uncountable Hcount).
Qed.

(** from §30 Theorem 30.2: countability axioms preserved by subspaces and countable products **)
(** LATEX VERSION: First/second countability are inherited by subspaces and countable products (Theorem 30.2). **)
(** FIXED: Product clauses quantify i only over i:e I (not all sets). **) 
Theorem countability_axioms_subspace_product : forall X Tx:set,
  topology_on X Tx ->
  (forall A:set, A c= X -> first_countable_space X Tx -> first_countable_space A (subspace_topology X Tx A)) /\
  (forall A:set, A c= X -> second_countable_space X Tx -> second_countable_space A (subspace_topology X Tx A)) /\
  (forall I Xi:set, countable_index_set I ->
    (forall i:set, i :e I -> first_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
    first_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi)) /\
  (forall I Xi:set, countable_index_set I ->
    (forall i:set, i :e I -> second_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
    second_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi)).
let X Tx.
assume HTx: topology_on X Tx.
prove (forall A:set, A c= X -> first_countable_space X Tx -> first_countable_space A (subspace_topology X Tx A)) /\
  (forall A:set, A c= X -> second_countable_space X Tx -> second_countable_space A (subspace_topology X Tx A)) /\
  (forall I Xi:set, countable_index_set I ->
    (forall i:set, i :e I -> first_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
    first_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi)) /\
  (forall I Xi:set, countable_index_set I ->
    (forall i:set, i :e I -> second_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
    second_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi)).
apply andI.
- (** first three clauses **)
  apply andI.
  + (** first two clauses **)
    apply andI.
    * (** first countable preserved by subspaces **)
      let A. assume HA: A c= X.
      assume Hfc: first_countable_space X Tx.
      prove first_countable_space A (subspace_topology X Tx A).
      claim HtopSub: topology_on A (subspace_topology X Tx A).
      { exact (subspace_topology_is_topology X Tx A HTx HA). }
      claim HfcTop: topology_on X Tx.
      { exact (andEL (topology_on X Tx) (forall x:set, x :e X -> countable_basis_at X Tx x) Hfc). }
      claim HfcAt: forall x:set, x :e X -> countable_basis_at X Tx x.
      { exact (andER (topology_on X Tx) (forall x:set, x :e X -> countable_basis_at X Tx x) Hfc). }
      prove topology_on A (subspace_topology X Tx A) /\
           forall x:set, x :e A -> countable_basis_at A (subspace_topology X Tx A) x.
      apply andI.
      { exact HtopSub. }
      { let x. assume HxA: x :e A.
        prove countable_basis_at A (subspace_topology X Tx A) x.
        claim HxX: x :e X.
        { exact (HA x HxA). }
        claim Hcbx: countable_basis_at X Tx x.
        { exact (HfcAt x HxX). }
        claim Hcbx_left: (topology_on X Tx /\ x :e X) /\ exists Bx:set,
          Bx c= Tx /\ countable_set Bx /\ (forall b:set, b :e Bx -> x :e b) /\
          (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U).
        { exact Hcbx. }
        claim HexBx: exists Bx:set,
          Bx c= Tx /\ countable_set Bx /\ (forall b:set, b :e Bx -> x :e b) /\
          (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U).
        { exact (andER (topology_on X Tx /\ x :e X)
                       (exists Bx:set, Bx c= Tx /\ countable_set Bx /\ (forall b:set, b :e Bx -> x :e b) /\
                                        (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U))
                       Hcbx_left). }
        prove topology_on A (subspace_topology X Tx A) /\ x :e A /\
          exists BxA:set,
            BxA c= subspace_topology X Tx A /\ countable_set BxA /\
              (forall b:set, b :e BxA -> x :e b) /\
              (forall U0:set, U0 :e subspace_topology X Tx A -> x :e U0 -> exists b:set, b :e BxA /\ b c= U0).
        apply andI.
        - apply andI.
          + exact HtopSub.
          + exact HxA.
        - apply HexBx.
            let Bx. assume HBxpair.
            claim Htmp1: (Bx c= Tx /\ countable_set Bx) /\ (forall b:set, b :e Bx -> x :e b).
            { exact (andEL ((Bx c= Tx /\ countable_set Bx) /\ (forall b:set, b :e Bx -> x :e b))
                           (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U)
                           HBxpair). }
            claim HBxref: forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U.
            { exact (andER ((Bx c= Tx /\ countable_set Bx) /\ (forall b:set, b :e Bx -> x :e b))
                           (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e Bx /\ b c= U)
                           HBxpair). }
            claim Htmp2: Bx c= Tx /\ countable_set Bx.
            { exact (andEL (Bx c= Tx /\ countable_set Bx)
                           (forall b:set, b :e Bx -> x :e b)
                           Htmp1). }
            claim HBxmem: forall b:set, b :e Bx -> x :e b.
            { exact (andER (Bx c= Tx /\ countable_set Bx)
                           (forall b:set, b :e Bx -> x :e b)
                           Htmp1). }
            claim HBxsub: Bx c= Tx.
            { exact (andEL (Bx c= Tx) (countable_set Bx) Htmp2). }
            claim HBxcount: countable_set Bx.
            { exact (andER (Bx c= Tx) (countable_set Bx) Htmp2). }
            set BxA := {b :/\: A | b :e Bx}.
            witness BxA.
            apply andI.
            - (** left: (subset and countable) and neighborhood membership **)
              apply andI.
              + (** subset and countable_set **)
                apply andI.
                * prove BxA c= subspace_topology X Tx A.
                  let c. assume Hc: c :e BxA.
                  prove c :e subspace_topology X Tx A.
                  apply (ReplE_impred Bx (fun b0:set => b0 :/\: A) c Hc).
                  let b. assume HbBx: b :e Bx. assume Hceq: c = b :/\: A.
                  claim HbTx: b :e Tx.
                  { exact (HBxsub b HbBx). }
                  claim HcPowA: c :e Power A.
                  { apply PowerI A c.
                    let y. assume Hyc: y :e c.
                    claim HybA: y :e b :/\: A.
                    { rewrite <- Hceq. exact Hyc. }
                    exact (binintersectE2 b A y HybA). }
                  claim HcProp: exists V :e Tx, c = V :/\: A.
                  { witness b.
                    apply andI.
                    - exact HbTx.
                    - exact Hceq. }
                  exact (SepI (Power A) (fun U0:set => exists V :e Tx, U0 = V :/\: A) c HcPowA HcProp).
                * exact (countable_image Bx HBxcount (fun b0:set => b0 :/\: A)).
              + (** each element contains x **)
                let c. assume Hc: c :e BxA.
                prove x :e c.
                apply (ReplE_impred Bx (fun b0:set => b0 :/\: A) c Hc).
                let b. assume HbBx: b :e Bx. assume Hceq: c = b :/\: A.
                claim Hxb: x :e b.
                { exact (HBxmem b HbBx). }
                claim HxBA: x :e b :/\: A.
                { exact (binintersectI b A x Hxb HxA). }
                rewrite Hceq.
                exact HxBA.
            - (** refinement for subspace neighborhoods **)
              let U0.
              assume HU0: U0 :e subspace_topology X Tx A.
              assume HxU0: x :e U0.
              claim HU0prop: exists V :e Tx, U0 = V :/\: A.
              { exact (SepE2 (Power A) (fun U1:set => exists V :e Tx, U1 = V :/\: A) U0 HU0). }
              apply HU0prop.
              let V. assume HVpair.
              claim HVTx: V :e Tx.
              { exact (andEL (V :e Tx) (U0 = V :/\: A) HVpair). }
              claim HU0eq: U0 = V :/\: A.
              { exact (andER (V :e Tx) (U0 = V :/\: A) HVpair). }
              claim HxVA: x :e V :/\: A.
              { rewrite <- HU0eq. exact HxU0. }
              claim HxV: x :e V.
              { exact (binintersectE1 V A x HxVA). }
              claim Hexb: exists b:set, b :e Bx /\ b c= V.
              { exact (HBxref V HVTx HxV). }
              apply Hexb.
              let b. assume Hbpair3.
              claim HbBx: b :e Bx.
              { exact (andEL (b :e Bx) (b c= V) Hbpair3). }
              claim HbsubV: b c= V.
              { exact (andER (b :e Bx) (b c= V) Hbpair3). }
              set c := b :/\: A.
              witness c.
              apply andI.
              - prove c :e BxA.
                exact (ReplI Bx (fun b0:set => b0 :/\: A) b HbBx).
              - prove c c= U0.
                let y. assume Hyc: y :e c.
                claim Hyb: y :e b.
                { exact (binintersectE1 b A y Hyc). }
                claim HyA: y :e A.
                { exact (binintersectE2 b A y Hyc). }
                claim HyV: y :e V.
                { exact (HbsubV y Hyb). }
                claim HyVA: y :e V :/\: A.
                { exact (binintersectI V A y HyV HyA). }
                rewrite HU0eq.
                exact HyVA.
      }
    * (** second countable preserved by subspaces **)
      let A. assume HA: A c= X.
      assume Hsc: second_countable_space X Tx.
      prove second_countable_space A (subspace_topology X Tx A).
      claim HtopSub: topology_on A (subspace_topology X Tx A).
      { exact (subspace_topology_is_topology X Tx A HTx HA). }
      claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
      { exact (andER (topology_on X Tx) (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx) Hsc). }
      apply HexB.
      let B. assume HBpair.
      claim HBmid: (basis_on X B /\ countable_set B) /\ basis_generates X B Tx.
      { exact HBpair. }
      claim HBasisCount: basis_on X B /\ countable_set B.
      { exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
      claim HBgener: basis_generates X B Tx.
      { exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
      claim HBasis: basis_on X B.
      { exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
      claim HBcount: countable_set B.
      { exact (andER (basis_on X B) (countable_set B) HBasisCount). }
      claim HgenEq: generated_topology X B = Tx.
      { exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
      claim HBgen: basis_on X B /\ generated_topology X B = Tx.
      { apply andI.
        - exact HBasis.
        - exact HgenEq. }
      claim HsubB: basis_on A {b :/\: A | b :e B} /\ generated_topology A {b :/\: A | b :e B} = subspace_topology X Tx A.
      { exact (subspace_basis X Tx A B HTx HA HBgen). }
      claim HBsubA: basis_on A {b :/\: A | b :e B}.
      { exact (andEL (basis_on A {b :/\: A | b :e B})
                     (generated_topology A {b :/\: A | b :e B} = subspace_topology X Tx A)
                     HsubB). }
      claim HgenSubEq: generated_topology A {b :/\: A | b :e B} = subspace_topology X Tx A.
      { exact (andER (basis_on A {b :/\: A | b :e B})
                     (generated_topology A {b :/\: A | b :e B} = subspace_topology X Tx A)
                     HsubB). }
      prove topology_on A (subspace_topology X Tx A) /\
           exists B0:set, basis_on A B0 /\ countable_set B0 /\ basis_generates A B0 (subspace_topology X Tx A).
      apply andI.
      { exact HtopSub. }
      { witness {b :/\: A | b :e B}.
        apply andI.
        - (** basis_on and countable_set **)
          apply andI.
          + exact HBsubA.
          + exact (countable_image B HBcount (fun b0:set => b0 :/\: A)).
        - (** basis_generates **)
          prove basis_on A {b :/\: A | b :e B} /\
                generated_topology A {b :/\: A | b :e B} = subspace_topology X Tx A.
          apply andI.
          + exact HBsubA.
          + exact HgenSubEq. }
	  + (** first countable for countable products **)
	    let I Xi.
	    assume HIcount: countable_index_set I.
	    assume Hcomp: forall i:set, i :e I -> first_countable_space (space_family_set Xi i) (space_family_topology Xi i).
	    prove first_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi).
	    prove topology_on (countable_product_space I Xi) (countable_product_topology_subbasis I Xi) /\
	         forall f:set, f :e countable_product_space I Xi -> countable_basis_at (countable_product_space I Xi) (countable_product_topology_subbasis I Xi) f.
	    apply andI.
		    - (** topology_on for product **)
		      apply (xm (I = Empty)).
		      + assume HI0: I = Empty.
		        rewrite HI0.
		        exact (countable_product_topology_subbasis_empty_is_topology Xi).
		      + assume HIn0: ~(I = Empty).
		        claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
		        { let i. assume HiI: i :e I.
		          exact (andEL (topology_on (space_family_set Xi i) (space_family_topology Xi i))
		                       (forall x:set, x :e space_family_set Xi i -> countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) x)
		                       (Hcomp i HiI)). }
		        claim HS: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
		        { exact (product_subbasis_full_subbasis_on I Xi HIn0 HcompTop). }
		        claim HB: basis_on (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)).
		        { exact (finite_intersections_basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi) HS). }
		        exact (lemma_topology_from_basis (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)) HB).
		    - (** local countable basis at points **)
		      let f. assume Hf: f :e countable_product_space I Xi.
		      prove countable_basis_at (countable_product_space I Xi) (countable_product_topology_subbasis I Xi) f.
		      apply (xm (I = Empty)).
		      + assume HI0: I = Empty.
		        claim Hf0: f :e product_space Empty Xi.
		        { rewrite <- HI0. exact Hf. }
		        rewrite HI0.
		        prove countable_basis_at (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) f.
		        claim HT0: topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi).
		        { exact (countable_product_topology_subbasis_empty_is_topology Xi). }
			        prove topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) /\ f :e product_space Empty Xi /\
			          exists B:set, B c= countable_product_topology_subbasis Empty Xi /\ countable_set B /\
			            (forall b:set, b :e B -> f :e b) /\
			            (forall U:set, U :e countable_product_topology_subbasis Empty Xi -> f :e U -> exists b:set, b :e B /\ b c= U).
			        apply andI.
			        - apply andI.
			          + exact HT0.
			          + exact Hf0.
			        - witness (Sing (product_space Empty Xi)).
			          prove ((Sing (product_space Empty Xi) c= countable_product_topology_subbasis Empty Xi /\ countable_set (Sing (product_space Empty Xi))) /\
			            (forall b:set, b :e Sing (product_space Empty Xi) -> f :e b)) /\
			              (forall U:set, U :e countable_product_topology_subbasis Empty Xi -> f :e U -> exists b:set, b :e Sing (product_space Empty Xi) /\ b c= U).
			          apply andI.
			          - apply andI.
			            + (** B c= Tx and countable_set **)
			              apply andI.
			              - (** B c= Tx **)
			                let b. assume Hb: b :e Sing (product_space Empty Xi).
			                prove b :e countable_product_topology_subbasis Empty Xi.
			                claim HbX0: b = product_space Empty Xi.
			                { exact (SingE (product_space Empty Xi) b Hb). }
			                rewrite HbX0.
			                exact (topology_has_X (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) HT0).
			              - (** countable_set B **)
			                exact (finite_countable (Sing (product_space Empty Xi)) (Sing_finite (product_space Empty Xi))).
			            + (** every b in B contains f **)
			              let b. assume Hb: b :e Sing (product_space Empty Xi).
			              prove f :e b.
			              claim HbX0: b = product_space Empty Xi.
			              { exact (SingE (product_space Empty Xi) b Hb). }
			              rewrite HbX0.
			              exact Hf0.
			          - (** neighborhood refinement **)
			            let U. assume HU: U :e countable_product_topology_subbasis Empty Xi.
			            assume HfU: f :e U.
			            prove exists b:set, b :e Sing (product_space Empty Xi) /\ b c= U.
			            witness (product_space Empty Xi).
			            apply andI.
			            + exact (SingI (product_space Empty Xi)).
			            + claim HX0eq: product_space Empty Xi = {Empty}.
			              { exact (product_space_empty_index Xi). }
			              claim Hf0eq: f = Empty.
			              { apply (SingE Empty f).
			                rewrite <- HX0eq.
			                exact Hf0. }
			              let y. assume HyX0: y :e product_space Empty Xi.
			              prove y :e U.
			              claim Hy0: y = Empty.
			              { apply (SingE Empty y).
			                rewrite <- HX0eq.
			                exact HyX0. }
			              rewrite Hy0.
			              rewrite <- Hf0eq.
			              exact HfU.
			      + assume HIn0: ~(I = Empty).
			        prove countable_basis_at (countable_product_space I Xi) (countable_product_topology_subbasis I Xi) f.
			        (** Expand the definition; only the existence of a countable local base is postponed. **)
			        claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
			        { let i. assume HiI: i :e I.
			          exact (andEL (topology_on (space_family_set Xi i) (space_family_topology Xi i))
			                       (forall x:set, x :e space_family_set Xi i -> countable_basis_at (space_family_set Xi i) (space_family_topology Xi i) x)
			                       (Hcomp i HiI)). }
			        claim HS: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
			        { exact (product_subbasis_full_subbasis_on I Xi HIn0 HcompTop). }
			        claim HB: basis_on (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)).
			        { exact (finite_intersections_basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi) HS). }
			        claim HTprod: topology_on (product_space I Xi) (countable_product_topology_subbasis I Xi).
			        { exact (lemma_topology_from_basis (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)) HB). }
			        prove topology_on (product_space I Xi) (countable_product_topology_subbasis I Xi) /\ f :e product_space I Xi /\
			          exists B:set, B c= countable_product_topology_subbasis I Xi /\ countable_set B /\
			            (forall b:set, b :e B -> f :e b) /\
			            (forall U:set, U :e countable_product_topology_subbasis I Xi -> f :e U -> exists b:set, b :e B /\ b c= U).
				        apply andI.
				        - apply andI.
				          + exact HTprod.
				          + exact Hf.
				        - claim Hcb: countable_basis_at (product_space I Xi) (countable_product_topology_subbasis I Xi) f.
				          { exact (product_countable_basis_at_point_if_components_first_countable I Xi f HIcount HIn0 Hcomp Hf). }
				          exact (andER (topology_on (product_space I Xi) (countable_product_topology_subbasis I Xi) /\ f :e product_space I Xi)
				                       (exists B:set, B c= countable_product_topology_subbasis I Xi /\ countable_set B /\
				                         (forall b:set, b :e B -> f :e b) /\
				                         (forall U:set, U :e countable_product_topology_subbasis I Xi -> f :e U -> exists b:set, b :e B /\ b c= U))
				                       Hcb).
		- (** second countable for countable products **)
		  let I Xi.
		  assume HIcount: countable_index_set I.
		  assume Hcomp: forall i:set, i :e I -> second_countable_space (space_family_set Xi i) (space_family_topology Xi i).
		  prove second_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi).
	  prove topology_on (countable_product_space I Xi) (countable_product_topology_subbasis I Xi) /\
	       exists B:set, basis_on (countable_product_space I Xi) B /\ countable_set B /\ basis_generates (countable_product_space I Xi) B (countable_product_topology_subbasis I Xi).
	  apply andI.
		  - (** topology_on for product **)
		    apply (xm (I = Empty)).
		    + assume HI0: I = Empty.
		      rewrite HI0.
		      exact (countable_product_topology_subbasis_empty_is_topology Xi).
		    + assume HIn0: ~(I = Empty).
		      claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
		      { let i. assume HiI: i :e I.
		        exact (andEL (topology_on (space_family_set Xi i) (space_family_topology Xi i))
		                     (exists B0:set, basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i))
		                     (Hcomp i HiI)). }
		      claim HS: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
		      { exact (product_subbasis_full_subbasis_on I Xi HIn0 HcompTop). }
		      claim HB: basis_on (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)).
		      { exact (finite_intersections_basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi) HS). }
		      exact (lemma_topology_from_basis (product_space I Xi) (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)) HB).
		  - (** existence of countable basis **)
			    apply (xm (I = Empty)).
			    + assume HI0: I = Empty.
			      rewrite HI0.
			      witness (Sing (product_space Empty Xi)).
			      apply andI.
			      - apply andI.
			        + exact (basis_on_singleton (product_space Empty Xi)).
			        + exact (finite_countable (Sing (product_space Empty Xi)) (Sing_finite (product_space Empty Xi))).
			      - (** basis_generates **)
			        prove basis_on (product_space Empty Xi) {product_space Empty Xi} /\
			          generated_topology (product_space Empty Xi) {product_space Empty Xi} = countable_product_topology_subbasis Empty Xi.
			        apply andI.
			        + exact (basis_on_singleton (product_space Empty Xi)).
			        + claim HTdef: countable_product_topology_subbasis Empty Xi =
			            generated_topology_from_subbasis (product_space Empty Xi) (product_subbasis_full Empty Xi).
			          { reflexivity. }
			          rewrite HTdef.
				          claim HS0: product_subbasis_full Empty Xi = Empty.
				          { exact (famunion_Empty (fun i:set => {product_cylinder Empty Xi i U|U :e space_family_topology Xi i})). }
				          rewrite HS0.
				          claim HGTS0: generated_topology_from_subbasis (product_space Empty Xi) Empty =
				            generated_topology (product_space Empty Xi) (basis_of_subbasis (product_space Empty Xi) Empty).
				          { reflexivity. }
				          rewrite HGTS0.
				          claim HX0ne: product_space Empty Xi <> Empty.
				          { assume HX0E: product_space Empty Xi = Empty.
				            claim Hem: Empty :e product_space Empty Xi.
			            { rewrite (product_space_empty_index Xi).
			              exact (SingI Empty). }
			            claim HemE: Empty :e Empty.
			            { rewrite <- HX0E at 2. exact Hem. }
			            exact (EmptyE Empty HemE False). }
			          claim HB0eq: basis_of_subbasis (product_space Empty Xi) Empty = {product_space Empty Xi}.
			          { exact (basis_of_subbasis_empty_eq (product_space Empty Xi) HX0ne). }
			          rewrite HB0eq.
			          reflexivity.
					    + assume HIn0: ~(I = Empty).
					      set Bsel : set->set := fun i =>
					        Eps_i (fun B0:set =>
					          basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i)).
					      set Ssmall : set := \/_ i :e I, {product_cylinder I Xi i U|U :e Bsel i}.
					      claim HBsel: forall i:set, i :e I ->
					        basis_on (space_family_set Xi i) (Bsel i) /\ countable_set (Bsel i) /\ basis_generates (space_family_set Xi i) (Bsel i) (space_family_topology Xi i).
					      { let i. assume HiI: i :e I.
					        claim HexB0: exists B0:set, basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i).
					        { exact (andER (topology_on (space_family_set Xi i) (space_family_topology Xi i))
					                      (exists B0:set, basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i))
					                      (Hcomp i HiI)). }
					        apply HexB0.
					        let B0. assume HB0: basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i).
					        exact (Eps_i_ax (fun B1:set => basis_on (space_family_set Xi i) B1 /\ countable_set B1 /\ basis_generates (space_family_set Xi i) B1 (space_family_topology Xi i)) B0 HB0). }
					      claim HSsmall: subbasis_on (product_space I Xi) Ssmall.
					      { prove Ssmall c= Power (product_space I Xi) /\ Union Ssmall = product_space I Xi.
					        apply andI.
					        - let s. assume Hs: s :e Ssmall.
					          prove s :e Power (product_space I Xi).
					          apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s Hs).
					          let i0. assume Hi0I. assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
					          apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
					          let U0. assume HU0B: U0 :e Bsel i0.
					          assume HsEq: s = product_cylinder I Xi i0 U0.
					          rewrite HsEq.
					          apply PowerI.
					          let f0. assume Hf0: f0 :e product_cylinder I Xi i0 U0.
					          exact (SepE1 (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0) f0 Hf0).
					        - apply set_ext.
					          + let f0. assume Hf0: f0 :e Union Ssmall.
					            prove f0 :e product_space I Xi.
					            apply UnionE_impred Ssmall f0 Hf0.
					            let s. assume Hf0s: f0 :e s. assume Hs: s :e Ssmall.
						            apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s Hs).
						            let i0. assume Hi0I. assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
						            apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
						            let U0. assume HU0B: U0 :e Bsel i0.
						            assume HsEq: s = product_cylinder I Xi i0 U0.
						            claim HsPow: s :e Power (product_space I Xi).
						            { rewrite HsEq.
						              apply PowerI.
						              let f1. assume Hf1: f1 :e product_cylinder I Xi i0 U0.
						              exact (SepE1 (product_space I Xi) (fun f2:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f2 i0 :e U0) f1 Hf1). }
						            claim HsSub: s c= product_space I Xi.
						            { exact (PowerE (product_space I Xi) s HsPow). }
						            exact (HsSub f0 Hf0s).
					          + let f0. assume Hf0: f0 :e product_space I Xi.
					            prove f0 :e Union Ssmall.
					            claim Hexi: exists i0:set, i0 :e I.
					            { exact (nonempty_has_element I HIn0). }
					            apply Hexi.
					            let i0. assume Hi0I: i0 :e I.
					            claim HBsel_i0c: basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0).
					            { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                           (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                           (HBsel i0 Hi0I)). }
					            claim HBsel_i0: basis_on (space_family_set Xi i0) (Bsel i0).
					            { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0))
					                           (countable_set (Bsel i0))
					                           HBsel_i0c). }
					            claim HBcover: forall x :e space_family_set Xi i0, exists b :e Bsel i0, x :e b.
					            { exact (andER (Bsel i0 c= Power (space_family_set Xi i0))
					                           (forall x :e space_family_set Xi i0, exists b :e Bsel i0, x :e b)
					                           (andEL (Bsel i0 c= Power (space_family_set Xi i0) /\ (forall x :e space_family_set Xi i0, exists b :e Bsel i0, x :e b))
					                                  (forall b1 :e Bsel i0, forall b2 :e Bsel i0, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e Bsel i0, x :e b3 /\ b3 c= b1 :/\: b2)
					                                  HBsel_i0)). }
					            claim Hf0prop: total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
					                           forall i:set, i :e I -> apply_fun f0 i :e space_family_set Xi i.
					            { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
					                         (fun f1:set => total_function_on f1 I (space_family_union I Xi) /\ functional_graph f1 /\
					                           forall i:set, i :e I -> apply_fun f1 i :e space_family_set Xi i)
					                         f0 Hf0). }
					            claim Hcompf0: forall i:set, i :e I -> apply_fun f0 i :e space_family_set Xi i.
					            { exact (andER (total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0)
					                           (forall i:set, i :e I -> apply_fun f0 i :e space_family_set Xi i)
					                           Hf0prop). }
					            claim Hfi0: apply_fun f0 i0 :e space_family_set Xi i0.
					            { exact (Hcompf0 i0 Hi0I). }
					            apply (HBcover (apply_fun f0 i0) Hfi0).
					            let U0. assume HU0pair.
					            claim HU0B: U0 :e Bsel i0.
					            { exact (andEL (U0 :e Bsel i0) (apply_fun f0 i0 :e U0) HU0pair). }
					            claim Hfi0U0: apply_fun f0 i0 :e U0.
					            { exact (andER (U0 :e Bsel i0) (apply_fun f0 i0 :e U0) HU0pair). }
					            claim HBgen_i0: basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0).
					            { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                           (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                           (HBsel i0 Hi0I)). }
					            claim HTeq: generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0.
					            { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0))
					                           (generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0)
					                           HBgen_i0). }
					            claim HU0Gen: U0 :e generated_topology (space_family_set Xi i0) (Bsel i0).
					            { exact (generated_topology_contains_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0 U0 HU0B). }
					            claim HU0Top: U0 :e space_family_topology Xi i0.
					            { rewrite <- HTeq. exact HU0Gen. }
					            set C0 : set := product_cylinder I Xi i0 U0.
					            claim Hf0C0: f0 :e C0.
					            { exact (SepI (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0)
					                         f0 Hf0 (andI (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun f0 i0 :e U0)
					                                      (andI (i0 :e I) (U0 :e space_family_topology Xi i0) Hi0I HU0Top) Hfi0U0)). }
					            claim HC0in: C0 :e Ssmall.
					            { exact (famunionI I (fun i1:set => {product_cylinder I Xi i1 U|U :e Bsel i1})
					                             i0 C0 Hi0I (ReplI (Bsel i0) (fun U:set => product_cylinder I Xi i0 U) U0 HU0B)). }
					            exact (UnionI Ssmall f0 C0 Hf0C0 HC0in). }
					      witness (basis_of_subbasis (product_space I Xi) Ssmall).
					      apply andI.
					      - (** basis_on and countable_set **)
					        apply andI.
					        + claim HS: subbasis_on (product_space I Xi) Ssmall.
					          { exact HSsmall. }
					          exact (finite_intersections_basis_of_subbasis (product_space I Xi) Ssmall HS).
						        + (** countable_set of basis_of_subbasis from a countable subbasis **)
						          claim HSsmall_count: countable_set Ssmall.
						          { (** show Ssmall is an image of a countable dependent sum **)
						            claim HIc: countable I.
						            { exact HIcount. }
						            claim HBsel_count: forall i:set, i :e I -> countable (Bsel i).
						            { let i. assume HiI: i :e I.
						              claim HBi: basis_on (space_family_set Xi i) (Bsel i) /\ countable_set (Bsel i).
						              { exact (andEL (basis_on (space_family_set Xi i) (Bsel i) /\ countable_set (Bsel i))
						                             (basis_generates (space_family_set Xi i) (Bsel i) (space_family_topology Xi i))
						                             (HBsel i HiI)). }
						              exact (andER (basis_on (space_family_set Xi i) (Bsel i))
						                           (countable_set (Bsel i))
						                           HBi). }
						            claim HSig: countable (Sigma_ i :e I, Bsel i).
						            { exact (Sigma_countable I HIc Bsel HBsel_count). }
						            claim HSig_set: countable_set (Sigma_ i :e I, Bsel i).
						            { exact HSig. }
						            set F : set -> set := fun p => product_cylinder I Xi (p 0) (p 1).
						            set Img := {F p|p :e Sigma_ i :e I, Bsel i}.
						            claim HImg_count: countable_set Img.
						            { exact (countable_image (Sigma_ i :e I, Bsel i) HSig_set F). }
						            apply (Subq_countable Ssmall Img).
						            - exact HImg_count.
						            - let s. assume Hs: s :e Ssmall.
						              prove s :e Img.
						              apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U|U :e Bsel i0}) s Hs).
						              let i0. assume Hi0I: i0 :e I.
						              assume HsFi0: s :e {product_cylinder I Xi i0 U|U :e Bsel i0}.
						              apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
						              let U0. assume HU0B: U0 :e Bsel i0.
						              assume HsEq: s = product_cylinder I Xi i0 U0.
							              claim HpSig: (i0,U0) :e Sigma_ i :e I, Bsel i.
							              { exact (tuple_2_Sigma I Bsel i0 Hi0I U0 HU0B). }
							              claim HFp: F (i0,U0) = product_cylinder I Xi i0 U0.
							              { claim HFdef: F (i0,U0) = product_cylinder I Xi ((i0,U0) 0) ((i0,U0) 1).
							                { reflexivity. }
							                rewrite HFdef.
							                rewrite (tuple_2_0_eq i0 U0).
							                rewrite (tuple_2_1_eq i0 U0).
							                reflexivity. }
							              rewrite HsEq.
							              rewrite <- HFp.
							              exact (ReplI (Sigma_ i :e I, Bsel i) F (i0,U0) HpSig). }
						          exact (basis_of_subbasis_countable (product_space I Xi) Ssmall HSsmall_count).
					      - (** basis_generates **)
					        prove basis_on (product_space I Xi) (basis_of_subbasis (product_space I Xi) Ssmall) /\
					          generated_topology (product_space I Xi) (basis_of_subbasis (product_space I Xi) Ssmall) = countable_product_topology_subbasis I Xi.
					        apply andI.
					        + claim HS: subbasis_on (product_space I Xi) Ssmall.
					          { exact HSsmall. }
					          exact (finite_intersections_basis_of_subbasis (product_space I Xi) Ssmall HS).
					        + (** generated_topology equality with cylinder subbasis **)
					          claim HGTSsmall: generated_topology_from_subbasis (product_space I Xi) Ssmall =
					            generated_topology (product_space I Xi) (basis_of_subbasis (product_space I Xi) Ssmall).
					          { reflexivity. }
					          rewrite <- HGTSsmall.
					          claim HcompTop2: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
					          { let i. assume HiI: i :e I.
					            exact (andEL (topology_on (space_family_set Xi i) (space_family_topology Xi i))
					                         (exists B0:set, basis_on (space_family_set Xi i) B0 /\ countable_set B0 /\ basis_generates (space_family_set Xi i) B0 (space_family_topology Xi i))
					                         (Hcomp i HiI)). }
					          claim HSfull: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
					          { exact (product_subbasis_full_subbasis_on I Xi HIn0 HcompTop2). }
					          claim HTdef: countable_product_topology_subbasis I Xi =
					            generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					          { reflexivity. }
					          rewrite HTdef.
					          (** Compare generated topologies from the two subbases Ssmall and product_subbasis_full **)
					          apply set_ext.
					          + let U. assume HU: U :e generated_topology_from_subbasis (product_space I Xi) Ssmall.
					            prove U :e generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					            claim HTfull: topology_on (product_space I Xi)
					              (generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi)).
					            { exact (topology_from_subbasis_is_topology (product_space I Xi) (product_subbasis_full I Xi) HSfull). }
					            claim HBfull: basis_on (product_space I Xi)
					              (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi)).
					            { exact (finite_intersections_basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi) HSfull). }
					            claim HSsmall_sub_Tfull: Ssmall c=
					              generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					            { let s. assume Hs: s :e Ssmall.
					              prove s :e generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					              apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U0|U0 :e Bsel i0}) s Hs).
					              let i0. assume Hi0I. assume HsFi0: s :e {product_cylinder I Xi i0 U0|U0 :e Bsel i0}.
					              apply (ReplE_impred (Bsel i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
					              let U0. assume HU0B: U0 :e Bsel i0.
					              assume HsEq: s = product_cylinder I Xi i0 U0.
					              claim HBsel_i0c: basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0).
					              { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                             (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                             (HBsel i0 Hi0I)). }
					              claim HBsel_i0: basis_on (space_family_set Xi i0) (Bsel i0).
					              { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0))
					                             (countable_set (Bsel i0))
					                             HBsel_i0c). }
					              claim HBgen_i0: basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0).
					              { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                             (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                             (HBsel i0 Hi0I)). }
					              claim HTeq_i0: generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0.
					              { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0))
					                             (generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0)
					                             HBgen_i0). }
					              claim HU0Gen: U0 :e generated_topology (space_family_set Xi i0) (Bsel i0).
					              { exact (generated_topology_contains_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0 U0 HU0B). }
					              claim HU0Top: U0 :e space_family_topology Xi i0.
					              { rewrite <- HTeq_i0. exact HU0Gen. }
					              claim HsSfull: s :e product_subbasis_full I Xi.
					              { rewrite HsEq.
					                exact (famunionI I (fun i1:set => {product_cylinder I Xi i1 U|U :e space_family_topology Xi i1})
					                         i0 (product_cylinder I Xi i0 U0) Hi0I
					                         (ReplI (space_family_topology Xi i0) (fun U:set => product_cylinder I Xi i0 U) U0 HU0Top)). }
					              apply (xm (s = Empty)).
					              - assume HsE: s = Empty.
					                rewrite HsE.
					                exact (topology_has_empty (product_space I Xi)
					                      (generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi)) HTfull).
					              - assume HsNE: ~(s = Empty).
					                claim HsBasis: s :e basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					                { exact (subbasis_elem_in_basis (product_space I Xi) (product_subbasis_full I Xi) s HSfull HsSfull HsNE). }
					                exact (basis_in_generated (product_space I Xi)
					                      (basis_of_subbasis (product_space I Xi) (product_subbasis_full I Xi))
					                      s HBfull HsBasis).
					            }
					            claim Hinc: generated_topology_from_subbasis (product_space I Xi) Ssmall c=
					              generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					            { exact (topology_generated_by_basis_is_minimal (product_space I Xi) Ssmall
					                      (generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi))
					                      HSsmall HTfull HSsmall_sub_Tfull). }
					            exact (Hinc U HU).
					          + let U. assume HU: U :e generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi).
					            prove U :e generated_topology_from_subbasis (product_space I Xi) Ssmall.
					            claim HTsmall: topology_on (product_space I Xi)
					              (generated_topology_from_subbasis (product_space I Xi) Ssmall).
					            { exact (topology_from_subbasis_is_topology (product_space I Xi) Ssmall HSsmall). }
					            claim HSfull_sub_Tsmall: product_subbasis_full I Xi c=
					              generated_topology_from_subbasis (product_space I Xi) Ssmall.
					            { let s. assume HsSfull: s :e product_subbasis_full I Xi.
					              prove s :e generated_topology_from_subbasis (product_space I Xi) Ssmall.
					              set Bsm := basis_of_subbasis (product_space I Xi) Ssmall.
					              claim HBsmBasis: basis_on (product_space I Xi) Bsm.
					              { exact (finite_intersections_basis_of_subbasis (product_space I Xi) Ssmall HSsmall). }
					              claim HGTS: generated_topology_from_subbasis (product_space I Xi) Ssmall =
					                generated_topology (product_space I Xi) Bsm.
					              { reflexivity. }
					              rewrite HGTS.
					              (** Destructure s as a cylinder at some coordinate **)
					              apply (famunionE_impred I (fun i0:set => {product_cylinder I Xi i0 U0|U0 :e space_family_topology Xi i0}) s HsSfull).
					              let i0. assume Hi0I. assume HsFi0: s :e {product_cylinder I Xi i0 U0|U0 :e space_family_topology Xi i0}.
					              apply (ReplE_impred (space_family_topology Xi i0) (fun U0:set => product_cylinder I Xi i0 U0) s HsFi0).
					              let U0. assume HU0Top: U0 :e space_family_topology Xi i0.
					              assume HsEq: s = product_cylinder I Xi i0 U0.
					              (** Represent U0 as union of basis elements from Bsel i0 **)
					              claim HBsel_i0c: basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0).
					              { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                             (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                             (HBsel i0 Hi0I)). }
					              claim HBsel_i0: basis_on (space_family_set Xi i0) (Bsel i0).
					              { exact (andEL (basis_on (space_family_set Xi i0) (Bsel i0))
					                             (countable_set (Bsel i0))
					                             HBsel_i0c). }
					              claim HBgen_i0: basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0).
					              { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
					                             (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
					                             (HBsel i0 Hi0I)). }
					              claim HTeq_i0: generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0.
					              { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0))
					                             (generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0)
					                             HBgen_i0). }
					              claim HU0Gen: U0 :e generated_topology (space_family_set Xi i0) (Bsel i0).
					              { rewrite HTeq_i0. exact HU0Top. }
					              claim HTgen: topology_on (space_family_set Xi i0) (generated_topology (space_family_set Xi i0) (Bsel i0)).
					              { exact (lemma_topology_from_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0). }
					              claim HU0open: open_in (space_family_set Xi i0) (generated_topology (space_family_set Xi i0) (Bsel i0)) U0.
					              { exact (andI (topology_on (space_family_set Xi i0) (generated_topology (space_family_set Xi i0) (Bsel i0)))
					                           (U0 :e generated_topology (space_family_set Xi i0) (Bsel i0))
					                           HTgen HU0Gen). }
					              claim HexFam: exists Fam :e Power (Bsel i0), Union Fam = U0.
					              { exact (open_sets_as_unions_of_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0 U0 HU0open). }
					              apply HexFam.
					              let Fam. assume HFampair.
					              claim HFamPow: Fam :e Power (Bsel i0).
					              { exact (andEL (Fam :e Power (Bsel i0)) (Union Fam = U0) HFampair). }
					              claim HUnionFam: Union Fam = U0.
					              { exact (andER (Fam :e Power (Bsel i0)) (Union Fam = U0) HFampair). }
					              claim HFamSub: Fam c= Bsel i0.
					              { exact (PowerE (Bsel i0) Fam HFamPow). }
					              set FamCyl := {product_cylinder I Xi i0 V|V :e Fam}.
					              claim HUnionCyl: Union FamCyl = product_cylinder I Xi i0 U0.
					              { apply set_ext.
					                - let f. assume HfU: f :e Union FamCyl.
					                  prove f :e product_cylinder I Xi i0 U0.
					                  apply (UnionE_impred FamCyl f HfU).
					                  let c. assume Hfc: f :e c. assume Hc: c :e FamCyl.
					                  apply (ReplE_impred Fam (fun V0:set => product_cylinder I Xi i0 V0) c Hc).
					                  let V0. assume HV0Fam: V0 :e Fam.
					                  assume HcEq: c = product_cylinder I Xi i0 V0.
					                  claim HV0B: V0 :e Bsel i0.
					                  { exact (HFamSub V0 HV0Fam). }
					                  claim HV0subU0: V0 c= U0.
					                  { let x. assume HxV0: x :e V0.
					                    claim HxUF: x :e Union Fam.
					                    { exact (UnionI Fam x V0 HxV0 HV0Fam). }
						                    rewrite <- HUnionFam.
						                    exact HxUF. }
					                  claim HfCylV0: f :e product_cylinder I Xi i0 V0.
					                  { rewrite <- HcEq. exact Hfc. }
					                  claim HfX: f :e product_space I Xi.
					                  { exact (SepE1 (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0) f HfCylV0). }
					                  claim Hfcond: (i0 :e I /\ V0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e V0.
					                  { exact (SepE2 (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0) f HfCylV0). }
					                  claim Hfi0V0: apply_fun f i0 :e V0.
					                  { exact (andER (i0 :e I /\ V0 :e space_family_topology Xi i0) (apply_fun f i0 :e V0) Hfcond). }
						                  claim Hfi0U0: apply_fun f i0 :e U0.
						                  { exact (HV0subU0 (apply_fun f i0) Hfi0V0). }
						                  claim HpredU0: (i0 :e I /\ U0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e U0.
						                  { apply andI.
						                    - apply andI.
						                      + exact Hi0I.
						                      + exact HU0Top.
						                    - exact Hfi0U0. }
						                  exact (SepI (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0)
						                             f HfX HpredU0).
					                - let f. assume HfC: f :e product_cylinder I Xi i0 U0.
					                  prove f :e Union FamCyl.
					                  claim Hfcond: (i0 :e I /\ U0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e U0.
					                  { exact (SepE2 (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0) f HfC). }
					                  claim Hfi0U0: apply_fun f i0 :e U0.
					                  { exact (andER (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun f i0 :e U0) Hfcond). }
					                  claim Hfi0UF: apply_fun f i0 :e Union Fam.
					                  { rewrite HUnionFam. exact Hfi0U0. }
					                  apply (UnionE_impred Fam (apply_fun f i0) Hfi0UF).
					                  let V0. assume Hfi0V0: apply_fun f i0 :e V0. assume HV0Fam: V0 :e Fam.
					                  set C0 := product_cylinder I Xi i0 V0.
					                  claim HC0Fam: C0 :e FamCyl.
					                  { exact (ReplI Fam (fun V1:set => product_cylinder I Xi i0 V1) V0 HV0Fam). }
						                  claim HfC0: f :e C0.
						                  { claim HfX: f :e product_space I Xi.
						                    { exact (SepE1 (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0) f HfC). }
						                    claim HV0B: V0 :e Bsel i0.
						                    { exact (HFamSub V0 HV0Fam). }
						                    claim HBgen_i0T: basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0).
						                    { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0) /\ countable_set (Bsel i0))
						                                   (basis_generates (space_family_set Xi i0) (Bsel i0) (space_family_topology Xi i0))
						                                   (HBsel i0 Hi0I)). }
						                    claim HTeq2: generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0.
						                    { exact (andER (basis_on (space_family_set Xi i0) (Bsel i0))
						                                   (generated_topology (space_family_set Xi i0) (Bsel i0) = space_family_topology Xi i0)
						                                   HBgen_i0T). }
						                    claim HV0Gen: V0 :e generated_topology (space_family_set Xi i0) (Bsel i0).
						                    { exact (generated_topology_contains_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0 V0 HV0B). }
						                    claim HV0Top: V0 :e space_family_topology Xi i0.
						                    { rewrite <- HTeq2. exact HV0Gen. }
						                    claim HpredV0: (i0 :e I /\ V0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e V0.
						                    { apply andI.
						                      - apply andI.
						                        + exact Hi0I.
						                        + exact HV0Top.
						                      - exact Hfi0V0. }
						                    exact (SepI (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0)
						                               f HfX HpredV0). }
					                  exact (UnionI FamCyl f C0 HfC0 HC0Fam). }
						              (** Restrict to nonempty cylinders to get a family of basis elements **)
						              set FamCylN := {c :e FamCyl|c <> Empty}.
						              claim HFamCylNPow: FamCylN :e Power Bsm.
						              { claim HFamCylNsub: FamCylN c= Bsm.
						                { let c. assume HcN: c :e FamCylN.
						                  prove c :e Bsm.
						                  claim HcFam: c :e FamCyl.
						                  { exact (SepE1 FamCyl (fun c0:set => c0 <> Empty) c HcN). }
						                  claim HcNe: c <> Empty.
						                  { exact (SepE2 FamCyl (fun c0:set => c0 <> Empty) c HcN). }
						                  apply (ReplE_impred Fam (fun V0:set => product_cylinder I Xi i0 V0) c HcFam).
						                  let V0. assume HV0Fam: V0 :e Fam.
						                  assume HcEq: c = product_cylinder I Xi i0 V0.
						                  claim HV0B: V0 :e Bsel i0.
						                  { exact (HFamSub V0 HV0Fam). }
						                  claim HC0in: product_cylinder I Xi i0 V0 :e Ssmall.
						                  { exact (famunionI I (fun i1:set => {product_cylinder I Xi i1 U|U :e Bsel i1})
						                           i0 (product_cylinder I Xi i0 V0) Hi0I
						                           (ReplI (Bsel i0) (fun U:set => product_cylinder I Xi i0 U) V0 HV0B)). }
						                  claim HC0S: c :e Ssmall.
						                  { rewrite HcEq. exact HC0in. }
						                  exact (subbasis_elem_in_basis (product_space I Xi) Ssmall c HSsmall HC0S HcNe). }
						                exact (PowerI Bsm FamCylN HFamCylNsub). }
					              claim HUnionN: Union FamCylN = Union FamCyl.
					              { apply set_ext.
					                - let f. assume HfUN: f :e Union FamCylN.
					                  prove f :e Union FamCyl.
					                  apply (UnionE_impred FamCylN f HfUN).
					                  let c. assume Hfc: f :e c. assume HcN: c :e FamCylN.
					                  claim HcFam: c :e FamCyl.
					                  { exact (SepE1 FamCyl (fun c0:set => c0 <> Empty) c HcN). }
					                  exact (UnionI FamCyl f c Hfc HcFam).
					                - let f. assume HfU: f :e Union FamCyl.
					                  prove f :e Union FamCylN.
					                  apply (UnionE_impred FamCyl f HfU).
					                  let c. assume Hfc: f :e c. assume HcFam: c :e FamCyl.
						                  claim HcNe: c <> Empty.
						                  { assume HcE: c = Empty.
						                    claim Hbad: f :e Empty.
						                    { rewrite <- HcE. exact Hfc. }
						                    exact (EmptyE f Hbad False). }
					                  claim HcN: c :e FamCylN.
					                  { exact (SepI FamCyl (fun c0:set => c0 <> Empty) c HcFam HcNe). }
					                  exact (UnionI FamCylN f c Hfc HcN). }
							              claim HopenS: open_in (product_space I Xi) (generated_topology (product_space I Xi) Bsm) s.
							              { apply (basis_generates_open_sets (product_space I Xi) Bsm HBsmBasis s).
							                witness FamCylN.
							                apply andI.
							                - exact HFamCylNPow.
							                - apply set_ext.
							                  + let f. assume HfU: f :e Union FamCylN.
							                    prove f :e s.
							                    apply (UnionE_impred FamCylN f HfU).
							                    let c. assume Hfc: f :e c. assume HcN: c :e FamCylN.
							                    claim HcFam: c :e FamCyl.
							                    { exact (SepE1 FamCyl (fun c0:set => c0 <> Empty) c HcN). }
							                    apply (ReplE_impred Fam (fun V0:set => product_cylinder I Xi i0 V0) c HcFam).
							                    let V0. assume HV0Fam: V0 :e Fam.
							                    assume HcEq: c = product_cylinder I Xi i0 V0.
							                    claim HV0subU0: V0 c= U0.
							                    { let x. assume HxV0: x :e V0.
							                      claim HxUF: x :e Union Fam.
							                      { exact (UnionI Fam x V0 HxV0 HV0Fam). }
							                      rewrite <- HUnionFam.
							                      exact HxUF. }
							                    claim HfCylV0: f :e product_cylinder I Xi i0 V0.
							                    { rewrite <- HcEq. exact Hfc. }
							                    claim HfX: f :e product_space I Xi.
							                    { exact (SepE1 (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0) f HfCylV0). }
							                    claim Hfcond: (i0 :e I /\ V0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e V0.
							                    { exact (SepE2 (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0) f HfCylV0). }
							                    claim Hfi0V0: apply_fun f i0 :e V0.
							                    { exact (andER (i0 :e I /\ V0 :e space_family_topology Xi i0) (apply_fun f i0 :e V0) Hfcond). }
							                    claim Hfi0U0: apply_fun f i0 :e U0.
							                    { exact (HV0subU0 (apply_fun f i0) Hfi0V0). }
							                    claim HpredU0: (i0 :e I /\ U0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e U0.
							                    { apply andI.
							                      - apply andI.
							                        + exact Hi0I.
							                        + exact HU0Top.
							                      - exact Hfi0U0. }
							                    rewrite HsEq.
							                    exact (SepI (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0)
							                               f HfX HpredU0).
							                  + let f. assume HfS: f :e s.
							                    prove f :e Union FamCylN.
							                    claim HfCylU0: f :e product_cylinder I Xi i0 U0.
							                    { rewrite <- HsEq. exact HfS. }
							                    claim Hfcond: (i0 :e I /\ U0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e U0.
							                    { exact (SepE2 (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0) f HfCylU0). }
							                    claim Hfi0U0: apply_fun f i0 :e U0.
							                    { exact (andER (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun f i0 :e U0) Hfcond). }
							                    claim Hfi0UF: apply_fun f i0 :e Union Fam.
							                    { rewrite HUnionFam. exact Hfi0U0. }
							                    apply (UnionE_impred Fam (apply_fun f i0) Hfi0UF).
							                    let V0. assume Hfi0V0: apply_fun f i0 :e V0. assume HV0Fam: V0 :e Fam.
							                    set C0 := product_cylinder I Xi i0 V0.
							                    claim HC0Fam: C0 :e FamCyl.
							                    { exact (ReplI Fam (fun V1:set => product_cylinder I Xi i0 V1) V0 HV0Fam). }
							                    claim HfC0: f :e C0.
							                    { claim HfX: f :e product_space I Xi.
							                      { exact (SepE1 (product_space I Xi) (fun f1:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e U0) f HfCylU0). }
								                      claim HpredV0: (i0 :e I /\ V0 :e space_family_topology Xi i0) /\ apply_fun f i0 :e V0.
								                      { apply andI.
								                        - apply andI.
								                          + exact Hi0I.
								                          + claim HV0B: V0 :e Bsel i0.
								                            { exact (HFamSub V0 HV0Fam). }
								                            claim HV0Gen: V0 :e generated_topology (space_family_set Xi i0) (Bsel i0).
								                            { exact (generated_topology_contains_basis (space_family_set Xi i0) (Bsel i0) HBsel_i0 V0 HV0B). }
								                            claim HV0Top: V0 :e space_family_topology Xi i0.
								                            { rewrite <- HTeq_i0. exact HV0Gen. }
								                            exact HV0Top.
								                        - exact Hfi0V0. }
							                      exact (SepI (product_space I Xi) (fun f1:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f1 i0 :e V0)
							                                 f HfX HpredV0). }
							                    claim HC0ne: C0 <> Empty.
							                    { assume HC0E: C0 = Empty.
							                      claim Hbad: f :e Empty.
							                      { rewrite <- HC0E. exact HfC0. }
							                      exact (EmptyE f Hbad False). }
							                    claim HC0N: C0 :e FamCylN.
							                    { exact (SepI FamCyl (fun c0:set => c0 <> Empty) C0 HC0Fam HC0ne). }
							                    exact (UnionI FamCylN f C0 HfC0 HC0N). }
					              exact (andER (topology_on (product_space I Xi) (generated_topology (product_space I Xi) Bsm))
					                           (s :e generated_topology (product_space I Xi) Bsm)
					                           HopenS). }
					            claim Hinc: generated_topology_from_subbasis (product_space I Xi) (product_subbasis_full I Xi) c=
					              generated_topology_from_subbasis (product_space I Xi) Ssmall.
					            { exact (topology_generated_by_basis_is_minimal (product_space I Xi) (product_subbasis_full I Xi)
					                      (generated_topology_from_subbasis (product_space I Xi) Ssmall)
					                      HSfull HTsmall HSfull_sub_Tsmall). }
					            exact (Hinc U HU).
Qed.

(** from §30 Definition: dense subset **) 
(** LATEX VERSION: A is dense in X if its closure equals X. **)
Definition dense_in : set -> set -> set -> prop := fun A X Tx => closure_of X Tx A = X.

(** Helper: density is preserved by supersets **)
(** LATEX VERSION: If A is dense in X and A ⊆ B ⊆ X, then B is dense in X. **)
Theorem dense_in_superset : forall A B X Tx:set,
  topology_on X Tx ->
  A c= B -> B c= X ->
  dense_in A X Tx ->
  dense_in B X Tx.
let A B X Tx.
assume HTx: topology_on X Tx.
assume HAB: A c= B.
assume HBX: B c= X.
assume HdA: dense_in A X Tx.
prove dense_in B X Tx.
prove closure_of X Tx B = X.
apply set_ext.
- (** closure(B) ⊆ X **)
  exact (closure_in_space X Tx B HTx).
- (** X ⊆ closure(B) because closure(A)=X and closure(A)⊆closure(B) **)
  let x. assume HxX: x :e X.
  prove x :e closure_of X Tx B.
  claim HclMono: closure_of X Tx A c= closure_of X Tx B.
  { exact (closure_monotone X Tx A B HTx HAB HBX). }
  claim HdAeq: closure_of X Tx A = X.
  { exact HdA. }
  claim HxclA: x :e closure_of X Tx A.
  { rewrite HdAeq.
    exact HxX. }
  exact (HclMono x HxclA).
Qed.

(** from §30 Theorem 30.3(a): countable basis implies Lindelöf **) 
(** LATEX VERSION: A second-countable space is Lindelöf (every open cover has countable subcover). **)
Theorem countable_basis_implies_Lindelof : forall X Tx:set,
  topology_on X Tx ->
  second_countable_space X Tx ->
  forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
let X Tx.
assume HTx: topology_on X Tx.
assume Hscc: second_countable_space X Tx.
let U.
assume HU: open_cover X Tx U.
prove exists V:set, countable_subcollection V U /\ covers X V.
claim HUopen: forall u:set, u :e U -> u :e Tx.
{ exact (andEL (forall u:set, u :e U -> u :e Tx) (covers X U) HU). }
claim HUcov: covers X U.
{ exact (andER (forall u:set, u :e U -> u :e Tx) (covers X U) HU). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx) (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx) Hscc). }
apply HexB.
let B. assume HBpair.
claim HBmid: (basis_on X B /\ countable_set B) /\ basis_generates X B Tx.
{ exact HBpair. }
claim HBasisCount: basis_on X B /\ countable_set B.
{ exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
claim HBgener: basis_generates X B Tx.
{ exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
claim HBasis: basis_on X B.
{ exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
claim HBcount: countable_set B.
{ exact (andER (basis_on X B) (countable_set B) HBasisCount). }
claim HgenEq: generated_topology X B = Tx.
{ exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
(** basis elements that refine the cover **)
set B0 := {b :e B | exists u:set, u :e U /\ b c= u}.
set choose : set->set := fun b => Eps_i (fun u => u :e U /\ b c= u).
set V := {choose b|b :e B0}.
witness V.
apply andI.
- (** V is a countable subcollection of U **)
  prove countable_subcollection V U.
  prove V c= U /\ countable_set V.
  apply andI.
  + (** V c= U **)
    let v. assume Hv: v :e V.
    prove v :e U.
    apply (ReplE_impred B0 choose v Hv).
    let b.
    assume Hb0: b :e B0.
    assume HvEq: v = choose b.
    claim Hb0prop: exists u:set, u :e U /\ b c= u.
    { exact (SepE2 B (fun b0:set => exists u:set, u :e U /\ b0 c= u) b Hb0). }
    apply Hb0prop.
    let u.
    assume Hupair: u :e U /\ b c= u.
    claim Hchooseprop: choose b :e U /\ b c= choose b.
    { exact (Eps_i_ax (fun u0 => u0 :e U /\ b c= u0) u Hupair). }
    claim HchooseU: choose b :e U.
    { exact (andEL (choose b :e U) (b c= choose b) Hchooseprop). }
    rewrite HvEq.
    exact HchooseU.
  + (** countable_set V **)
    claim HB0sub: B0 c= B.
    { let b. assume Hb0: b :e B0.
      exact (SepE1 B (fun b0:set => exists u:set, u :e U /\ b0 c= u) b Hb0). }
    claim HB0count: countable_set B0.
    { exact (Subq_countable B0 B HBcount HB0sub). }
    exact (countable_image B0 HB0count choose).
- (** V covers X **)
  prove covers X V.
  let x. assume HxX: x :e X.
  apply (HUcov x HxX).
  let u. assume Hupair.
  claim HuU: u :e U.
  { exact (andEL (u :e U) (x :e u) Hupair). }
  claim Hxu: x :e u.
  { exact (andER (u :e U) (x :e u) Hupair). }
  claim HuTx: u :e Tx.
  { exact (HUopen u HuU). }
  claim HuGen: u :e generated_topology X B.
  { rewrite HgenEq. exact HuTx. }
  claim Href: forall z :e u, exists b :e B, z :e b /\ b c= u.
  { exact (SepE2 (Power X) (fun U0:set => forall z :e U0, exists b :e B, z :e b /\ b c= U0) u HuGen). }
  claim Hexb: exists b :e B, x :e b /\ b c= u.
  { exact (Href x Hxu). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= u) Hbpair). }
  claim Hbprop: x :e b /\ b c= u.
  { exact (andER (b :e B) (x :e b /\ b c= u) Hbpair). }
  claim Hxb: x :e b.
  { exact (andEL (x :e b) (b c= u) Hbprop). }
  claim Hbsubu: b c= u.
  { exact (andER (x :e b) (b c= u) Hbprop). }
  claim Hb0: b :e B0.
  { apply (SepI B (fun b0:set => exists u0:set, u0 :e U /\ b0 c= u0) b HbB).
    witness u.
    apply andI.
    - exact HuU.
    - exact Hbsubu. }
  claim Hchooseprop: choose b :e U /\ b c= choose b.
  { exact (Eps_i_ax (fun u0 => u0 :e U /\ b c= u0) u (andI (u :e U) (b c= u) HuU Hbsubu)). }
  claim Hbsubchoose: b c= choose b.
  { exact (andER (choose b :e U) (b c= choose b) Hchooseprop). }
  claim Hxchoose: x :e choose b.
  { exact (Hbsubchoose x Hxb). }
  witness choose b.
  apply andI.
  + exact (ReplI B0 choose b Hb0).
  + exact Hxchoose.
Qed.

(** helper: second countable spaces are Lindelof spaces **)
Theorem second_countable_implies_Lindelof_space : forall X Tx:set,
  second_countable_space X Tx -> Lindelof_space X Tx.
let X Tx.
assume Hscc: second_countable_space X Tx.
prove Lindelof_space X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
prove topology_on X Tx /\ forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
apply andI.
- exact HTx.
- let U. assume HU: open_cover X Tx U.
  exact (countable_basis_implies_Lindelof X Tx HTx Hscc U HU).
Qed.

(** from §30 Theorem 30.3(b): countable basis yields countable dense subset **) 
(** LATEX VERSION: Second-countable spaces are separable (have countable dense subset). **)
Theorem countable_basis_implies_separable : forall X Tx:set,
  topology_on X Tx ->
  second_countable_space X Tx ->
  exists D:set, countable_set D /\ dense_in D X Tx.
let X Tx.
assume HTx: topology_on X Tx.
assume Hscc: second_countable_space X Tx.
prove exists D:set, countable_set D /\ dense_in D X Tx.
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx) (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx) Hscc). }
apply HexB.
let B. assume HBpair.
claim HBmid: (basis_on X B /\ countable_set B) /\ basis_generates X B Tx.
{ exact HBpair. }
claim HBasisCount: basis_on X B /\ countable_set B.
{ exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
claim HBgener: basis_generates X B Tx.
{ exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBmid). }
claim HBasis: basis_on X B.
{ exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
claim HBcount: countable_set B.
{ exact (andER (basis_on X B) (countable_set B) HBasisCount). }
claim HgenEq: generated_topology X B = Tx.
{ exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
(** pick one point from each nonempty basis element **)
set B1 := {b :e B | b <> Empty}.
set pick : set->set := fun b => Eps_i (fun x => x :e b).
set D := {pick b|b :e B1}.
witness D.
apply andI.
- (** D is countable **)
  prove countable_set D.
  claim HB1sub: B1 c= B.
  { let b. assume Hb1: b :e B1.
    exact (SepE1 B (fun b0:set => b0 <> Empty) b Hb1). }
  claim HB1count: countable_set B1.
  { exact (Subq_countable B1 B HBcount HB1sub). }
  exact (countable_image B1 HB1count pick).
- (** D is dense: closure_of X Tx D = X **)
  prove dense_in D X Tx.
  prove closure_of X Tx D = X.
  apply set_ext.
  + (** closure ⊆ X **)
    exact (closure_in_space X Tx D HTx).
  + (** X ⊆ closure **)
    let x. assume HxX: x :e X.
    prove x :e closure_of X Tx D.
    claim Hcliff: x :e closure_of X Tx D <-> (forall U :e Tx, x :e U -> U :/\: D <> Empty).
    { exact (closure_characterization X Tx D x HTx HxX). }
    claim Hneigh: forall U :e Tx, x :e U -> U :/\: D <> Empty.
    { let U. assume HU: U :e Tx. assume HxU: x :e U.
    claim HUgen: U :e generated_topology X B.
    { rewrite HgenEq. exact HU. }
    claim Href: forall z :e U, exists b :e B, z :e b /\ b c= U.
    { exact (SepE2 (Power X) (fun U0:set => forall z :e U0, exists b :e B, z :e b /\ b c= U0) U HUgen). }
    claim Hexb: exists b :e B, x :e b /\ b c= U.
    { exact (Href x HxU). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbB: b :e B.
    { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hbprop: x :e b /\ b c= U.
    { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
    claim Hxb: x :e b.
    { exact (andEL (x :e b) (b c= U) Hbprop). }
    claim HbsubU: b c= U.
    { exact (andER (x :e b) (b c= U) Hbprop). }
    claim Hbne: b <> Empty.
    { assume HbE: b = Empty.
      claim HxEmp: x :e Empty.
      { rewrite <- HbE. exact Hxb. }
      exact (EmptyE x HxEmp False). }
    claim Hb1: b :e B1.
    { exact (SepI B (fun b0:set => b0 <> Empty) b HbB Hbne). }
    claim Hpickb: pick b :e b.
    { exact (Eps_i_ax (fun x0 => x0 :e b) x Hxb). }
    claim HpickU: pick b :e U.
    { exact (HbsubU (pick b) Hpickb). }
    claim HpickD: pick b :e D.
    { exact (ReplI B1 pick b Hb1). }
    prove U :/\: D <> Empty.
    assume HUD: U :/\: D = Empty.
    claim Hwd: pick b :e U :/\: D.
    { exact (binintersectI U D (pick b) HpickU HpickD). }
    claim HwdE: pick b :e Empty.
    { rewrite <- HUD. exact Hwd. }
    exact (EmptyE (pick b) HwdE False).
    }
    exact (iffER (x :e closure_of X Tx D) (forall U :e Tx, x :e U -> U :/\: D <> Empty) Hcliff Hneigh).
Qed.

(** from §30 Example 3: Sorgenfrey line countability properties **) 
(** LATEX VERSION: Sorgenfrey line is first countable, separable, Lindelöf, but not second countable. **)
(** helper: Sorgenfrey line is first countable (countable local basis [x,x+eps_n)) **)
Theorem Sorgenfrey_line_first_countable :
  first_countable_space Sorgenfrey_line Sorgenfrey_topology.
prove first_countable_space Sorgenfrey_line Sorgenfrey_topology.
prove topology_on Sorgenfrey_line Sorgenfrey_topology /\
  forall x:set, x :e Sorgenfrey_line -> countable_basis_at Sorgenfrey_line Sorgenfrey_topology x.
apply andI.
- (** topology_on **)
  exact R_lower_limit_topology_is_topology.
- let x. assume HxR: x :e Sorgenfrey_line.
  prove countable_basis_at Sorgenfrey_line Sorgenfrey_topology x.
  set Tx := R_lower_limit_topology.
  set Bx := Repl omega (fun N0:set => halfopen_interval_left x (add_SNo x (eps_ N0))).
  prove topology_on Sorgenfrey_line Tx /\ x :e Sorgenfrey_line /\
    exists B:set, B c= Tx /\ countable_set B /\
      (forall b:set, b :e B -> x :e b) /\
      (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
  apply andI.
  - (** topology_on /\ x:eX **)
    apply andI.
    + exact R_lower_limit_topology_is_topology.
    + exact HxR.
  - witness Bx.
    apply andI.
    - (** Bx c= Tx /\ countable_set Bx /\ forall b∈Bx, x∈b **)
      apply andI.
      + (** Bx c= Tx /\ countable_set Bx **)
        apply andI.
        * (** Bx c= Tx **)
          let b. assume Hb: b :e Bx.
          prove b :e Tx.
          claim HexN: exists N :e omega, b = halfopen_interval_left x (add_SNo x (eps_ N)).
          { exact (ReplE omega (fun N0:set => halfopen_interval_left x (add_SNo x (eps_ N0))) b Hb). }
          apply HexN.
          let N. assume HNpair.
          claim HNomega: N :e omega.
          { exact (andEL (N :e omega) (b = halfopen_interval_left x (add_SNo x (eps_ N))) HNpair). }
          claim HbEq: b = halfopen_interval_left x (add_SNo x (eps_ N)).
          { exact (andER (N :e omega) (b = halfopen_interval_left x (add_SNo x (eps_ N))) HNpair). }
          claim HxS: SNo x.
          { exact (real_SNo x HxR). }
          claim HepsR: eps_ N :e R.
          { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
          claim HepsS: SNo (eps_ N).
          { exact (real_SNo (eps_ N) HepsR). }
          claim HxplusR: add_SNo x (eps_ N) :e R.
          { exact (real_add_SNo x HxR (eps_ N) HepsR). }
          claim HxplusS: SNo (add_SNo x (eps_ N)).
          { exact (real_SNo (add_SNo x (eps_ N)) HxplusR). }
          claim HxltS: x < add_SNo x (eps_ N).
          { exact (add_SNo_eps_Lt x HxS N HNomega). }
          claim Hxlt: Rlt x (add_SNo x (eps_ N)).
          { exact (RltI x (add_SNo x (eps_ N)) HxR HxplusR HxltS). }
          rewrite HbEq.
          exact (halfopen_interval_left_in_R_lower_limit_topology x (add_SNo x (eps_ N)) HxR HxplusR).
        * (** countable_set Bx **)
          claim HomegaCount: countable_set omega.
          { exact (Subq_atleastp omega omega (Subq_ref omega)). }
          exact (countable_image omega HomegaCount (fun N0:set => halfopen_interval_left x (add_SNo x (eps_ N0)))).
      + (** forall b∈Bx, x∈b **)
        let b. assume Hb: b :e Bx.
        prove x :e b.
        claim HexN: exists N :e omega, b = halfopen_interval_left x (add_SNo x (eps_ N)).
        { exact (ReplE omega (fun N0:set => halfopen_interval_left x (add_SNo x (eps_ N0))) b Hb). }
        apply HexN.
        let N. assume HNpair.
        claim HNomega: N :e omega.
        { exact (andEL (N :e omega) (b = halfopen_interval_left x (add_SNo x (eps_ N))) HNpair). }
        claim HbEq: b = halfopen_interval_left x (add_SNo x (eps_ N)).
        { exact (andER (N :e omega) (b = halfopen_interval_left x (add_SNo x (eps_ N))) HNpair). }
        claim HxS: SNo x.
        { exact (real_SNo x HxR). }
        claim HepsR: eps_ N :e R.
        { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
        claim HxplusR: add_SNo x (eps_ N) :e R.
        { exact (real_add_SNo x HxR (eps_ N) HepsR). }
        claim HxltS: x < add_SNo x (eps_ N).
        { exact (add_SNo_eps_Lt x HxS N HNomega). }
        claim Hxlt: Rlt x (add_SNo x (eps_ N)).
        { exact (RltI x (add_SNo x (eps_ N)) HxR HxplusR HxltS). }
        rewrite HbEq.
        exact (halfopen_interval_left_leftmem x (add_SNo x (eps_ N)) Hxlt).
    - (** local refinement **)
      let U. assume HU: U :e Tx.
      assume HxU: x :e U.
      prove exists b:set, b :e Bx /\ b c= U.
      (** rewrite Tx as generated_topology R R_lower_limit_basis **)
      claim HTdef: Tx = generated_topology R R_lower_limit_basis.
      { reflexivity. }
      claim HUgen: U :e generated_topology R R_lower_limit_basis.
      { rewrite <- HTdef. exact HU. }
      claim Hloc: forall y0 :e U, exists b0 :e R_lower_limit_basis, y0 :e b0 /\ b0 c= U.
      { exact (SepE2 (Power R)
                     (fun U0:set => forall y1 :e U0, exists b0 :e R_lower_limit_basis, y1 :e b0 /\ b0 c= U0)
                     U
                     HUgen). }
      claim Hexb0: exists b0 :e R_lower_limit_basis, x :e b0 /\ b0 c= U.
      { exact (Hloc x HxU). }
      apply Hexb0.
      let b0. assume Hb0pair.
      claim Hb0B: b0 :e R_lower_limit_basis.
      { exact (andEL (b0 :e R_lower_limit_basis) (x :e b0 /\ b0 c= U) Hb0pair). }
      claim Hb0prop: x :e b0 /\ b0 c= U.
      { exact (andER (b0 :e R_lower_limit_basis) (x :e b0 /\ b0 c= U) Hb0pair). }
      claim Hxb0: x :e b0.
      { exact (andEL (x :e b0) (b0 c= U) Hb0prop). }
      claim Hb0subU: b0 c= U.
      { exact (andER (x :e b0) (b0 c= U) Hb0prop). }
      (** destruct b0 = [a,b) **)
      claim Hexa : exists a :e R, b0 :e {halfopen_interval_left a b|b :e R}.
      { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) b0 Hb0B). }
      apply Hexa.
      let a. assume Hapair. apply Hapair.
      assume HaR: a :e R.
      assume Hb0fam: b0 :e {halfopen_interval_left a b|b :e R}.
      claim Hexb : exists b :e R, b0 = halfopen_interval_left a b.
      { exact (ReplE R (fun b1:set => halfopen_interval_left a b1) b0 Hb0fam). }
      apply Hexb.
      let b. assume Hbpair. apply Hbpair.
      assume HbR: b :e R.
      assume Hb0eq: b0 = halfopen_interval_left a b.
      claim HxIn: x :e halfopen_interval_left a b.
      { rewrite <- Hb0eq. exact Hxb0. }
      claim HxProp: ~(Rlt x a) /\ Rlt x b.
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) x HxIn). }
      claim Hnltxa: ~(Rlt x a).
      { exact (andEL (~(Rlt x a)) (Rlt x b) HxProp). }
      claim Hxltb: Rlt x b.
      { exact (andER (~(Rlt x a)) (Rlt x b) HxProp). }
      claim Hax: Rle a x.
      { exact (RleI a x HaR HxR Hnltxa). }
      claim Hab: Rlt a b.
      { exact (Rle_Rlt_tra a x b Hax Hxltb). }
      (** choose N with eps_N < b-x **)
      set d := add_SNo b (minus_SNo x).
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HbS: SNo b.
      { exact (real_SNo b HbR). }
      claim HmxS: SNo (minus_SNo x).
      { exact (SNo_minus_SNo x HxS). }
      claim HdR: d :e R.
      { exact (real_add_SNo b HbR (minus_SNo x) (real_minus_SNo x HxR)). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      claim HxltbS: x < b.
      { exact (RltE_lt x b Hxltb). }
      claim HdposS: 0 < d.
      { exact (SNoLt_minus_pos x b HxS HbS HxltbS). }
      claim Hdpos: Rlt 0 d.
      { exact (RltI 0 d real_0 HdR HdposS). }
      claim HexN: exists N :e omega, eps_ N < d.
      { exact (exists_eps_lt_pos d HdR Hdpos). }
      apply HexN.
      let N. assume HNpair.
      claim HNomega: N :e omega.
      { exact (andEL (N :e omega) (eps_ N < d) HNpair). }
      claim HepsLtD: eps_ N < d.
      { exact (andER (N :e omega) (eps_ N < d) HNpair). }
      set b1 := add_SNo x (eps_ N).
      set V := halfopen_interval_left x b1.
      witness V.
      apply andI.
      - (** V :e Bx **)
        claim HVeq: V = halfopen_interval_left x (add_SNo x (eps_ N)).
        { reflexivity. }
        rewrite HVeq.
        exact (ReplI omega (fun N0:set => halfopen_interval_left x (add_SNo x (eps_ N0))) N HNomega).
      - (** V c= U **)
        let z. assume HzV: z :e V.
        prove z :e U.
        (** show V c= b0 and use b0 c= U **)
        claim HepsR: eps_ N :e R.
        { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
        claim HepsS: SNo (eps_ N).
        { exact (real_SNo (eps_ N) HepsR). }
        claim Hb1R: b1 :e R.
        { exact (real_add_SNo x HxR (eps_ N) HepsR). }
        claim Hb1S: SNo b1.
        { exact (real_SNo b1 Hb1R). }
        claim Hxltb1S: x < b1.
        { exact (add_SNo_eps_Lt x HxS N HNomega). }
        claim Hxltb1: Rlt x b1.
        { exact (RltI x b1 HxR Hb1R Hxltb1S). }
        (** b1 < b since eps_N < b-x **)
        claim HxplusLt: add_SNo x (eps_ N) < add_SNo x d.
        { exact (add_SNo_Lt2 x (eps_ N) d HxS HepsS HdS HepsLtD). }
	        claim HxdEq: add_SNo x d = b.
	        { rewrite (add_SNo_assoc x b (minus_SNo x) HxS HbS HmxS).
	          rewrite (add_SNo_com x b HxS HbS).
	          rewrite <- (add_SNo_assoc b x (minus_SNo x) HbS HxS HmxS).
	          rewrite (add_SNo_minus_SNo_rinv x HxS).
	          exact (add_SNo_0R b HbS). }
	        claim Hb1ltbS: b1 < b.
	        { rewrite <- HxdEq.
	          exact HxplusLt. }
        claim Hb1ltb: Rlt b1 b.
        { exact (RltI b1 b Hb1R HbR Hb1ltbS). }
        (** z in V gives z:eR, ~(z<x), z<b1 **)
        claim HzR: z :e R.
        { exact (SepE1 R (fun z0:set => ~(Rlt z0 x) /\ Rlt z0 b1) z HzV). }
        claim HzProp: ~(Rlt z x) /\ Rlt z b1.
        { exact (SepE2 R (fun z0:set => ~(Rlt z0 x) /\ Rlt z0 b1) z HzV). }
        claim Hnltzx: ~(Rlt z x).
        { exact (andEL (~(Rlt z x)) (Rlt z b1) HzProp). }
        claim Hzltb1: Rlt z b1.
        { exact (andER (~(Rlt z x)) (Rlt z b1) HzProp). }
        claim Hxz: Rle x z.
        { exact (RleI x z HxR HzR Hnltzx). }
	        claim Haz: Rle a z.
	        { exact (Rle_tra a x z Hax Hxz). }
	        claim Hnltza: ~(Rlt z a).
	        { exact (RleE_nlt a z Haz). }
        claim Hzltb: Rlt z b.
        { exact (Rlt_tra z b1 b Hzltb1 Hb1ltb). }
        claim HzInb0: z :e halfopen_interval_left a b.
        { exact (SepI R (fun z0:set => ~(Rlt z0 a) /\ Rlt z0 b) z HzR (andI (~(Rlt z a)) (Rlt z b) Hnltza Hzltb)). }
	        claim HzInU: z :e U.
	        { claim HzInb0': z :e b0.
	          { rewrite Hb0eq.
	            exact HzInb0. }
	          exact (Hb0subU z HzInb0'). }
        exact HzInU.
Qed.

(** helper: rational numbers are dense in the Sorgenfrey line **)
Theorem Sorgenfrey_line_rationals_dense :
  dense_in rational_numbers Sorgenfrey_line Sorgenfrey_topology.
prove dense_in rational_numbers Sorgenfrey_line Sorgenfrey_topology.
prove closure_of Sorgenfrey_line Sorgenfrey_topology rational_numbers = Sorgenfrey_line.
apply set_ext.
- (** closure subset X **)
  exact (closure_in_space Sorgenfrey_line Sorgenfrey_topology rational_numbers R_lower_limit_topology_is_topology).
- (** X subset closure **)
  let x. assume HxR: x :e Sorgenfrey_line.
  prove x :e closure_of Sorgenfrey_line Sorgenfrey_topology rational_numbers.
  claim Hcliff: x :e closure_of Sorgenfrey_line Sorgenfrey_topology rational_numbers
    <-> (forall U :e Sorgenfrey_topology, x :e U -> U :/\: rational_numbers <> Empty).
  { exact (closure_characterization Sorgenfrey_line Sorgenfrey_topology rational_numbers x
                                  R_lower_limit_topology_is_topology
                                  HxR). }
  apply (iffER (x :e closure_of Sorgenfrey_line Sorgenfrey_topology rational_numbers)
               (forall U :e Sorgenfrey_topology, x :e U -> U :/\: rational_numbers <> Empty)
               Hcliff).
  prove forall U :e Sorgenfrey_topology, x :e U -> U :/\: rational_numbers <> Empty.
  let U. assume HU: U :e Sorgenfrey_topology.
  assume HxU: x :e U.
  (** pick a basis neighborhood b0=[a,b) with x∈b0 ⊂ U **)
  claim HTdef: Sorgenfrey_topology = generated_topology R R_lower_limit_basis.
  { reflexivity. }
  claim HUgen: U :e generated_topology R R_lower_limit_basis.
  { rewrite <- HTdef. exact HU. }
  claim Hloc: forall y0 :e U, exists b0 :e R_lower_limit_basis, y0 :e b0 /\ b0 c= U.
  { exact (SepE2 (Power R)
                 (fun U0:set => forall y1 :e U0, exists b0 :e R_lower_limit_basis, y1 :e b0 /\ b0 c= U0)
                 U
                 HUgen). }
  claim Hexb0: exists b0 :e R_lower_limit_basis, x :e b0 /\ b0 c= U.
  { exact (Hloc x HxU). }
  apply Hexb0.
  let b0. assume Hb0pair. apply Hb0pair.
  assume Hb0B: b0 :e R_lower_limit_basis.
  assume Hb0prop: x :e b0 /\ b0 c= U.
  claim Hxb0: x :e b0.
  { exact (andEL (x :e b0) (b0 c= U) Hb0prop). }
  claim Hb0subU: b0 c= U.
  { exact (andER (x :e b0) (b0 c= U) Hb0prop). }
  (** destruct b0 = [a,b) **)
  claim Hexa : exists a :e R, b0 :e {halfopen_interval_left a b|b :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 b|b :e R}) b0 Hb0B). }
  apply Hexa.
  let a. assume Hapair. apply Hapair.
  assume HaR: a :e R.
  assume Hb0fam: b0 :e {halfopen_interval_left a b|b :e R}.
  claim Hexb : exists b :e R, b0 = halfopen_interval_left a b.
  { exact (ReplE R (fun b1:set => halfopen_interval_left a b1) b0 Hb0fam). }
  apply Hexb.
  let b. assume Hbpair. apply Hbpair.
  assume HbR: b :e R.
  assume Hb0eq: b0 = halfopen_interval_left a b.
  claim HxIn: x :e halfopen_interval_left a b.
  { rewrite <- Hb0eq. exact Hxb0. }
  claim HxProp: ~(Rlt x a) /\ Rlt x b.
  { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ Rlt x0 b) x HxIn). }
  claim Hnltxa: ~(Rlt x a).
  { exact (andEL (~(Rlt x a)) (Rlt x b) HxProp). }
  claim Hxltb: Rlt x b.
  { exact (andER (~(Rlt x a)) (Rlt x b) HxProp). }
  claim Hax: Rle a x.
  { exact (RleI a x HaR HxR Hnltxa). }
  claim Hab: Rlt a b.
  { exact (Rle_Rlt_tra a x b Hax Hxltb). }
  (** pick rational q with a < q < b **)
  apply (rational_dense_between_reals a b HaR HbR Hab).
  let q. assume Hqpair.
  claim HqQ: q :e rational_numbers.
  { exact (andEL (q :e rational_numbers) (Rlt a q /\ Rlt q b) Hqpair). }
  claim HqProp: Rlt a q /\ Rlt q b.
  { exact (andER (q :e rational_numbers) (Rlt a q /\ Rlt q b) Hqpair). }
  claim Haq: Rlt a q.
  { exact (andEL (Rlt a q) (Rlt q b) HqProp). }
  claim Hqb: Rlt q b.
  { exact (andER (Rlt a q) (Rlt q b) HqProp). }
  claim HqR: q :e R.
  { exact (rational_numbers_in_R q HqQ). }
  claim Hnltqa: ~(Rlt q a).
  { exact (not_Rlt_sym a q Haq). }
  claim HqInb0: q :e halfopen_interval_left a b.
  { exact (SepI R (fun z0:set => ~(Rlt z0 a) /\ Rlt z0 b) q HqR (andI (~(Rlt q a)) (Rlt q b) Hnltqa Hqb)). }
  claim HqInU: q :e U.
  { claim HqInb0': q :e b0.
    { rewrite Hb0eq.
      exact HqInb0. }
    exact (Hb0subU q HqInb0'). }
  prove U :/\: rational_numbers <> Empty.
  assume HUQ: U :/\: rational_numbers = Empty.
  claim HqUA: q :e U :/\: rational_numbers.
  { exact (binintersectI U rational_numbers q HqInU HqQ). }
  claim HqEmp: q :e Empty.
  { rewrite <- HUQ. exact HqUA. }
    exact (EmptyE q HqEmp False).
Qed.

(** helper: disjoint nonempty open families are countable in a space with countable dense subset **)
(** LATEX VERSION: In a space with a countable dense subset D, any pairwise disjoint family of nonempty open sets is countable. **)
Theorem disjoint_open_family_countable_of_dense : forall X Tx D Fam:set,
  topology_on X Tx ->
  dense_in D X Tx ->
  countable_set D ->
  Fam c= Tx ->
  (forall U:set, U :e Fam -> U <> Empty) ->
  pairwise_disjoint Fam ->
  countable_set Fam.
let X Tx D Fam.
assume HTx: topology_on X Tx.
assume Hdense: dense_in D X Tx.
assume HcountD: countable_set D.
assume HFamSub: Fam c= Tx.
assume Hne: forall U:set, U :e Fam -> U <> Empty.
assume Hdisj: pairwise_disjoint Fam.
prove countable_set Fam.

claim dense_meets_nonempty_open: forall U:set,
  U :e Tx -> U <> Empty -> exists d:set, d :e D /\ d :e U.
{ let U. assume HUopen: U :e Tx. assume HUne: U <> Empty.
  claim Hexx: exists x:set, x :e U.
  { exact (nonempty_has_element U HUne). }
  set x0 := Eps_i (fun x:set => x :e U).
  claim Hx0U: x0 :e U.
  { exact (Eps_i_ex (fun x:set => x :e U) Hexx). }
  claim HUSubX: U c= X.
  { exact (topology_elem_subset X Tx U HTx HUopen). }
  claim Hx0X: x0 :e X.
  { exact (HUSubX x0 Hx0U). }
  claim HclEq: closure_of X Tx D = X.
  { exact Hdense. }
  claim Hx0cl: x0 :e closure_of X Tx D.
  { rewrite HclEq. exact Hx0X. }
  claim Hcliff: x0 :e closure_of X Tx D <-> (forall W :e Tx, x0 :e W -> W :/\: D <> Empty).
  { exact (closure_characterization X Tx D x0 HTx Hx0X). }
  claim Hneigh: forall W :e Tx, x0 :e W -> W :/\: D <> Empty.
  { exact (iffEL (x0 :e closure_of X Tx D)
                 (forall W :e Tx, x0 :e W -> W :/\: D <> Empty)
                 Hcliff
                 Hx0cl). }
  claim HUDne: U :/\: D <> Empty.
  { exact (Hneigh U HUopen Hx0U). }
  claim HexUD: exists d:set, d :e U :/\: D.
  { exact (nonempty_has_element (U :/\: D) HUDne). }
  apply HexUD.
  let d. assume HdUD: d :e U :/\: D.
  witness d.
  apply andI.
  - exact (binintersectE2 U D d HdUD).
  - exact (binintersectE1 U D d HdUD). }

(** pick a dense point in each open set of Fam **)
set pick := (fun U:set => Eps_i (fun d:set => d :e D /\ d :e U)).

claim Hpick_in_D: forall U:set, U :e Fam -> pick U :e D.
{ let U. assume HUfam: U :e Fam.
  claim HUopen: U :e Tx.
  { exact (HFamSub U HUfam). }
  claim HUne: U <> Empty.
  { exact (Hne U HUfam). }
  claim Hexd: exists d:set, d :e D /\ d :e U.
  { exact (dense_meets_nonempty_open U HUopen HUne). }
  apply Hexd.
  let d. assume Hdpair: d :e D /\ d :e U.
  claim HpickProp: pick U :e D /\ pick U :e U.
  { exact (Eps_i_ax (fun d0:set => d0 :e D /\ d0 :e U) d Hdpair). }
  exact (andEL (pick U :e D) (pick U :e U) HpickProp). }

claim Hpick_in_U: forall U:set, U :e Fam -> pick U :e U.
{ let U. assume HUfam: U :e Fam.
  claim HUopen: U :e Tx.
  { exact (HFamSub U HUfam). }
  claim HUne: U <> Empty.
  { exact (Hne U HUfam). }
  claim Hexd: exists d:set, d :e D /\ d :e U.
  { exact (dense_meets_nonempty_open U HUopen HUne). }
  apply Hexd.
  let d. assume Hdpair: d :e D /\ d :e U.
  claim HpickProp: pick U :e D /\ pick U :e U.
  { exact (Eps_i_ax (fun d0:set => d0 :e D /\ d0 :e U) d Hdpair). }
  exact (andER (pick U :e D) (pick U :e U) HpickProp). }

claim HinjFamD: atleastp Fam D.
{ prove exists f:set -> set, inj Fam D f.
  witness pick.
  apply (injI Fam D pick).
  - let U. assume HUfam: U :e Fam.
    exact (Hpick_in_D U HUfam).
  - let U1. assume HU1: U1 :e Fam.
    let U2. assume HU2: U2 :e Fam.
    assume Heq: pick U1 = pick U2.
    prove U1 = U2.
    apply (dneg (U1 = U2)).
    assume Hneq: ~(U1 = U2).
    prove False.
    claim Hinter: U1 :/\: U2 = Empty.
    { exact (Hdisj U1 U2 HU1 HU2 Hneq). }
    claim HpickU1: pick U1 :e U1.
    { exact (Hpick_in_U U1 HU1). }
    claim HpickU2: pick U1 :e U2.
    { rewrite Heq.
      exact (Hpick_in_U U2 HU2). }
    claim Hpt: pick U1 :e U1 :/\: U2.
    { exact (binintersectI U1 U2 (pick U1) HpickU1 HpickU2). }
    claim Hbad: pick U1 :e Empty.
    { rewrite <- Hinter. exact Hpt. }
    exact (EmptyE (pick U1) Hbad False). 
}

exact (atleastp_tra Fam D omega HinjFamD HcountD).
Qed.

(** helper: Sorgenfrey line is not second countable **)
Theorem Sorgenfrey_line_not_second_countable :
  ~ second_countable_space Sorgenfrey_line Sorgenfrey_topology.
assume Hsc : second_countable_space Sorgenfrey_line Sorgenfrey_topology.
prove False.
claim HexB: exists B:set, basis_on Sorgenfrey_line B /\ countable_set B /\ basis_generates Sorgenfrey_line B Sorgenfrey_topology.
{ exact (andER (topology_on Sorgenfrey_line Sorgenfrey_topology)
               (exists B:set, basis_on Sorgenfrey_line B /\ countable_set B /\ basis_generates Sorgenfrey_line B Sorgenfrey_topology)
               Hsc). }
apply HexB.
let B. assume HBpair.
claim HBasisCount: basis_on Sorgenfrey_line B /\ countable_set B.
{ exact (andEL (basis_on Sorgenfrey_line B /\ countable_set B) (basis_generates Sorgenfrey_line B Sorgenfrey_topology) HBpair). }
claim HBasis: basis_on Sorgenfrey_line B.
{ exact (andEL (basis_on Sorgenfrey_line B) (countable_set B) HBasisCount). }
claim HBcount: countable_set B.
{ exact (andER (basis_on Sorgenfrey_line B) (countable_set B) HBasisCount). }
claim HBgener: basis_generates Sorgenfrey_line B Sorgenfrey_topology.
{ exact (andER (basis_on Sorgenfrey_line B /\ countable_set B) (basis_generates Sorgenfrey_line B Sorgenfrey_topology) HBpair). }
claim HTxeq: generated_topology Sorgenfrey_line B = Sorgenfrey_topology.
{ exact (andER (basis_on Sorgenfrey_line B) (generated_topology Sorgenfrey_line B = Sorgenfrey_topology) HBgener). }

set pick := (fun x:set =>
  Eps_i (fun b:set => b :e B /\ x :e b /\ b c= halfopen_interval_left x (add_SNo x 1))).

claim HpickP: forall x:set, x :e Sorgenfrey_line ->
  (fun b:set => b :e B /\ x :e b /\ b c= halfopen_interval_left x (add_SNo x 1)) (pick x).
{ let x. assume HxX: x :e Sorgenfrey_line.
  prove (fun b:set => b :e B /\ x :e b /\ b c= halfopen_interval_left x (add_SNo x 1)) (pick x).
  claim HxR: x :e R.
  { exact HxX. }
  claim Hx1R: add_SNo x 1 :e R.
  { exact (real_add_SNo x HxR 1 real_1). }
  set U := halfopen_interval_left x (add_SNo x 1).
  claim HUDef: U = halfopen_interval_left x (add_SNo x 1).
  { reflexivity. }
  claim HUopen: U :e Sorgenfrey_topology.
  { exact (halfopen_interval_left_in_R_lower_limit_topology x (add_SNo x 1) HxR Hx1R). }
  claim HUgen: U :e generated_topology Sorgenfrey_line B.
  { rewrite HTxeq.
    exact HUopen. }
  claim HUbasis: forall z :e U, exists b :e B, z :e b /\ b c= U.
  { exact (SepE2 (Power Sorgenfrey_line)
                 (fun U0:set => forall z0 :e U0, exists b0 :e B, z0 :e b0 /\ b0 c= U0)
                 U
                 HUgen). }
  claim HxU: x :e U.
  { rewrite HUDef.
    claim HUeq: halfopen_interval_left x (add_SNo x 1)
      = {z :e R|~(Rlt z x) /\ Rlt z (add_SNo x 1)}.
    { reflexivity. }
    rewrite HUeq.
    apply (SepI R (fun z:set => ~(Rlt z x) /\ Rlt z (add_SNo x 1)) x HxR).
    apply andI.
    - exact (not_Rlt_refl x HxR).
    - claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim Htmp: add_SNo x 0 < add_SNo x 1.
      { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
      claim Hlt: x < add_SNo x 1.
      { prove x < add_SNo x 1.
        rewrite <- (add_SNo_0R x HxS) at 1.
        exact Htmp. }
      exact (RltI x (add_SNo x 1) HxR Hx1R Hlt). }
  claim Hexb: exists b :e B, x :e b /\ b c= U.
  { exact (HUbasis x HxU). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hbprop: x :e b /\ b c= U.
  { exact (andER (b :e B) (x :e b /\ b c= U) Hbpair). }
  claim Hxb: x :e b.
  { exact (andEL (x :e b) (b c= U) Hbprop). }
  claim Hbsub: b c= U.
  { exact (andER (x :e b) (b c= U) Hbprop). }
  claim Hwit0: b :e B /\ x :e b /\ b c= halfopen_interval_left x (add_SNo x 1).
  { apply andI.
    - apply andI.
      + exact HbB.
      + exact Hxb.
    - rewrite <- HUDef.
      exact Hbsub. }
  exact (Eps_i_ax (fun b0:set => b0 :e B /\ x :e b0 /\ b0 c= halfopen_interval_left x (add_SNo x 1)) b Hwit0). }

claim HinjRB: inj R B pick.
{ claim H1: forall x :e R, pick x :e B.
  { let x. assume HxR: x :e R.
    prove pick x :e B.
    claim Hp: (fun b:set => b :e B /\ x :e b /\ b c= halfopen_interval_left x (add_SNo x 1)) (pick x).
    { exact (HpickP x HxR). }
    apply Hp.
    assume Hcore Hsub.
    apply Hcore.
    assume HpB HxIn.
    exact HpB. }
  claim H2: forall x0 x1 :e R, pick x0 = pick x1 -> x0 = x1.
  { let x0. assume Hx0R: x0 :e R.
    let x1. assume Hx1R: x1 :e R.
    assume Heq: pick x0 = pick x1.
    prove x0 = x1.
    claim Hp0: (fun b:set => b :e B /\ x0 :e b /\ b c= halfopen_interval_left x0 (add_SNo x0 1)) (pick x0).
    { exact (HpickP x0 Hx0R). }
    claim Hp1: (fun b:set => b :e B /\ x1 :e b /\ b c= halfopen_interval_left x1 (add_SNo x1 1)) (pick x1).
    { exact (HpickP x1 Hx1R). }
    claim Hx0in0: x0 :e pick x0.
    { apply Hp0.
      assume Hcore0 Hsub0.
      apply Hcore0.
      assume Hp0B Hx0in.
      exact Hx0in. }
    claim Hsub1: pick x1 c= halfopen_interval_left x1 (add_SNo x1 1).
    { apply Hp1.
      assume Hcore1 Hsub1.
      exact Hsub1. }
    claim Hx0in1: x0 :e pick x1.
    { rewrite <- Heq.
      exact Hx0in0. }
    claim Hx0U1: x0 :e halfopen_interval_left x1 (add_SNo x1 1).
    { exact (Hsub1 x0 Hx0in1). }
    claim HU1prop: ~(Rlt x0 x1) /\ Rlt x0 (add_SNo x1 1).
    { exact (SepE2 R (fun z:set => ~(Rlt z x1) /\ Rlt z (add_SNo x1 1)) x0 Hx0U1). }
    claim Hnlt01: ~(Rlt x0 x1).
    { exact (andEL (~(Rlt x0 x1)) (Rlt x0 (add_SNo x1 1)) HU1prop). }
    claim Hx0S: SNo x0.
    { exact (real_SNo x0 Hx0R). }
    claim Hx1S: SNo x1.
    { exact (real_SNo x1 Hx1R). }
    apply (SNoLt_trichotomy_or_impred x0 x1 Hx0S Hx1S (x0 = x1)).
    - assume Hlt: x0 < x1.
      prove x0 = x1.
      claim H01: Rlt x0 x1.
      { exact (RltI x0 x1 Hx0R Hx1R Hlt). }
      exact (FalseE (Hnlt01 H01) (x0 = x1)).
    - assume Heq01: x0 = x1.
      exact Heq01.
    - assume Hlt: x1 < x0.
      prove x0 = x1.
      claim Hx1in1: x1 :e pick x1.
      { apply Hp1.
        assume Hcore1 Hsub1.
        apply Hcore1.
        assume Hp1B Hx1in.
        exact Hx1in. }
      claim Hsub0: pick x0 c= halfopen_interval_left x0 (add_SNo x0 1).
      { apply Hp0.
        assume Hcore0 Hsub0.
        exact Hsub0. }
      claim Hx1in0: x1 :e pick x0.
      { rewrite Heq.
        exact Hx1in1. }
      claim Hx1U0: x1 :e halfopen_interval_left x0 (add_SNo x0 1).
      { exact (Hsub0 x1 Hx1in0). }
      claim HU0prop: ~(Rlt x1 x0) /\ Rlt x1 (add_SNo x0 1).
      { exact (SepE2 R (fun z:set => ~(Rlt z x0) /\ Rlt z (add_SNo x0 1)) x1 Hx1U0). }
      claim Hnlt10: ~(Rlt x1 x0).
      { exact (andEL (~(Rlt x1 x0)) (Rlt x1 (add_SNo x0 1)) HU0prop). }
      claim H10: Rlt x1 x0.
      { exact (RltI x1 x0 Hx1R Hx0R Hlt). }
      exact (FalseE (Hnlt10 H10) (x0 = x1)). }
  exact (injI R B pick H1 H2). }

claim HinjRBp: atleastp R B.
{ prove exists f:set -> set, inj R B f.
  witness pick.
  exact HinjRB. }
claim HcountB: atleastp B omega.
{ exact HBcount. }
claim HcountR: atleastp R omega.
{ exact (atleastp_tra R B omega HinjRBp HcountB). }
claim HdefR: R = real.
{ reflexivity. }
claim Hcount_real: atleastp real omega.
{ rewrite <- HdefR.
  exact HcountR. }
exact (form100_22_real_uncountable_atleastp Hcount_real).
Qed.

(** helper: Sorgenfrey line is Lindelöf **)
(** LATEX VERSION: The Sorgenfrey line is Lindelöf. **)
Theorem Sorgenfrey_line_Lindelof : Lindelof_space Sorgenfrey_line Sorgenfrey_topology.
prove Lindelof_space Sorgenfrey_line Sorgenfrey_topology.
prove topology_on Sorgenfrey_line Sorgenfrey_topology /\
  forall U:set, open_cover Sorgenfrey_line Sorgenfrey_topology U ->
    exists V:set, countable_subcollection V U /\ covers Sorgenfrey_line V.
apply andI.
- exact R_lower_limit_topology_is_topology.
- let U.
  assume HU: open_cover Sorgenfrey_line Sorgenfrey_topology U.
  claim HUopen: forall u:set, u :e U -> u :e Sorgenfrey_topology.
  { exact (andEL (forall u0:set, u0 :e U -> u0 :e Sorgenfrey_topology)
                 (covers Sorgenfrey_line U)
                 HU). }
  claim HUcov: covers Sorgenfrey_line U.
  { exact (andER (forall u0:set, u0 :e U -> u0 :e Sorgenfrey_topology)
                 (covers Sorgenfrey_line U)
                 HU). }

  (** local refinement: each cover element around x contains a basis element around x **)
  claim Hcover_refines_basis: forall x:set, x :e Sorgenfrey_line ->
    exists u:set, u :e U /\ x :e u /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= u.
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim Hexu: exists u:set, u :e U /\ x :e u.
    { exact (HUcov x HxR). }
    set u0 := Eps_i (fun u:set => u :e U /\ x :e u).
    claim Hu0spec: u0 :e U /\ x :e u0.
    { exact (Eps_i_ex (fun u:set => u :e U /\ x :e u) Hexu). }
    claim Hu0U: u0 :e U.
    { exact (andEL (u0 :e U) (x :e u0) Hu0spec). }
    claim Hxu0: x :e u0.
    { exact (andER (u0 :e U) (x :e u0) Hu0spec). }
    claim Hu0Top: u0 :e generated_topology R R_lower_limit_basis.
    { exact (HUopen u0 Hu0U). }
    claim Hu0Prop: forall y:set, y :e u0 ->
      exists b :e R_lower_limit_basis, y :e b /\ b c= u0.
    { let y. assume Hy: y :e u0.
      exact (generated_topology_local_refine R R_lower_limit_basis u0 y Hu0Top Hy). }
    claim Hexb: exists b :e R_lower_limit_basis, x :e b /\ b c= u0.
    { exact (Hu0Prop x Hxu0). }
    witness u0.
    apply andI.
    - apply andI.
      + exact Hu0U.
      + exact Hxu0.
    - exact Hexb. }

  (** refinement to a half-open interval with left endpoint x **)
  claim Hcover_refines_halfopen_at_x: forall x:set, x :e Sorgenfrey_line ->
    exists u:set, u :e U /\ x :e u /\
      exists bb :e R, Rlt x bb /\ halfopen_interval_left x bb c= u.
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim Hexu: exists u:set, u :e U /\ x :e u /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= u.
    { exact (Hcover_refines_basis x HxR). }
    apply Hexu.
    let u0. assume Hu0spec.
    apply Hu0spec.
    assume Hu0left Hexb.
    apply Hu0left.
    assume Hu0U Hxu0.
    apply Hexb.
    let b0. assume Hb0spec.
    apply Hb0spec.
    assume Hb0B Hb0rest.
    apply Hb0rest.
    assume Hxb0 Hb0subU0.

    (** b0 is of the form [a,bb) **)
    claim Hexa: exists a :e R, b0 :e {halfopen_interval_left a bb|bb :e R}.
    { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 bb|bb :e R}) b0 Hb0B). }
    apply Hexa.
    let a. assume Hapair.
    claim HaR: a :e R.
    { exact (andEL (a :e R) (b0 :e {halfopen_interval_left a bb|bb :e R}) Hapair). }
    claim Hb0fam: b0 :e {halfopen_interval_left a bb|bb :e R}.
    { exact (andER (a :e R) (b0 :e {halfopen_interval_left a bb|bb :e R}) Hapair). }
    claim Hexbb: exists bb :e R, b0 = halfopen_interval_left a bb.
    { exact (ReplE R (fun bb0:set => halfopen_interval_left a bb0) b0 Hb0fam). }
    apply Hexbb.
    let bb. assume Hbbpair.
    claim HbbR: bb :e R.
    { exact (andEL (bb :e R) (b0 = halfopen_interval_left a bb) Hbbpair). }
    claim Hb0eq: b0 = halfopen_interval_left a bb.
    { exact (andER (bb :e R) (b0 = halfopen_interval_left a bb) Hbbpair). }
    claim Hxb0ab: x :e halfopen_interval_left a bb.
    { rewrite <- Hb0eq.
      exact Hxb0. }
    claim Hxprop: ~(Rlt x a) /\ Rlt x bb.
    { exact (SepE2 R (fun t:set => ~(Rlt t a) /\ Rlt t bb) x Hxb0ab). }
    claim Hxnltxa: ~(Rlt x a).
    { exact (andEL (~(Rlt x a)) (Rlt x bb) Hxprop). }
    claim Hxltbb: Rlt x bb.
    { exact (andER (~(Rlt x a)) (Rlt x bb) Hxprop). }
    claim Hax: Rle a x.
    { exact (RleI a x HaR HxR Hxnltxa). }

    set b1 := halfopen_interval_left x bb.
    claim Hb1subb0: b1 c= halfopen_interval_left a bb.
    { exact (halfopen_interval_left_leftmonotone a x bb HaR HxR HbbR Hax). }
    claim Hb1subU: b1 c= u0.
    { let y. assume Hy: y :e b1.
      claim Hyb0: y :e halfopen_interval_left a bb.
      { exact (Hb1subb0 y Hy). }
      claim Hyinb0: y :e b0.
      { rewrite Hb0eq.
        exact Hyb0. }
      exact (Hb0subU0 y Hyinb0). }

    witness u0.
    apply andI.
    - apply andI.
      + exact Hu0U.
      + exact Hxu0.
    - witness bb.
      apply andI.
      + exact HbbR.
      + apply andI.
        * exact Hxltbb.
        * exact Hb1subU. }

  (** Lindelof subcover extraction for the lower limit topology (Sorgenfrey line). **)
  (** LATEX VERSION: Example 3 (Sorgenfrey line is Lindelöf): build open-interval core C and show R\\C countable via rationals, then cover C using second countability of the standard topology. **)

  (** Step 1: choose, for each x, a cover element and a half-open basis interval inside it. **)
  set Uof := fun x:set =>
    Eps_i (fun u:set => u :e U /\ x :e u /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= u).
  claim HUof_spec: forall x:set, x :e Sorgenfrey_line ->
    (Uof x :e U /\ x :e Uof x) /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x.
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim Hex: exists u:set, u :e U /\ x :e u /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= u.
    { exact (Hcover_refines_basis x HxR). }
    apply Hex.
    let u0. assume Hu0spec.
    claim HUsel: (Uof x :e U /\ x :e Uof x) /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x.
    { exact (Eps_i_ax (fun u:set => u :e U /\ x :e u /\
        exists b :e R_lower_limit_basis, x :e b /\ b c= u) u0 Hu0spec). }
    exact HUsel. }

  set Bof := fun x:set =>
    Eps_i (fun b:set => b :e R_lower_limit_basis /\ x :e b /\ b c= Uof x).
  claim HBof_spec: forall x:set, x :e Sorgenfrey_line ->
    (Bof x :e R_lower_limit_basis /\ x :e Bof x) /\ Bof x c= Uof x.
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim HUtrip: (Uof x :e U /\ x :e Uof x) /\
      exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x.
    { exact (HUof_spec x HxR). }
    claim Hexb: exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x.
    { exact (andER (Uof x :e U /\ x :e Uof x)
                   (exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x)
                   HUtrip). }
    apply Hexb.
    let b0. assume Hb0pair.
    claim Hb0B: b0 :e R_lower_limit_basis.
    { exact (andEL (b0 :e R_lower_limit_basis) (x :e b0 /\ b0 c= Uof x) Hb0pair). }
    claim Hb0rest: x :e b0 /\ b0 c= Uof x.
    { exact (andER (b0 :e R_lower_limit_basis) (x :e b0 /\ b0 c= Uof x) Hb0pair). }
    claim Hxb0: x :e b0.
    { exact (andEL (x :e b0) (b0 c= Uof x) Hb0rest). }
    claim Hb0subU: b0 c= Uof x.
    { exact (andER (x :e b0) (b0 c= Uof x) Hb0rest). }
    exact (Eps_i_ax (fun b:set => b :e R_lower_limit_basis /\ x :e b /\ b c= Uof x)
                    b0 (andI (b0 :e R_lower_limit_basis /\ x :e b0)
                             (b0 c= Uof x)
                             (andI (b0 :e R_lower_limit_basis) (x :e b0) Hb0B Hxb0)
                             Hb0subU)). }

  (** Step 2: extract endpoints for the chosen basis interval Bof x = [Aof x, BBof x). **)
  set Aof := fun x:set =>
    Eps_i (fun a:set => a :e R /\ Bof x :e {halfopen_interval_left a bb|bb :e R}).
  claim HAof_spec: forall x:set, x :e Sorgenfrey_line ->
    Aof x :e R /\ Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}.
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim HBleft: Bof x :e R_lower_limit_basis /\ x :e Bof x.
    { exact (andEL (Bof x :e R_lower_limit_basis /\ x :e Bof x)
                   (Bof x c= Uof x)
                   (HBof_spec x HxR)). }
    claim HbB: Bof x :e R_lower_limit_basis.
    { exact (andEL (Bof x :e R_lower_limit_basis) (x :e Bof x) HBleft). }
    claim Hexa: exists a :e R, Bof x :e {halfopen_interval_left a bb|bb :e R}.
    { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 bb|bb :e R}) (Bof x) HbB). }
    apply Hexa.
    let a. assume Hapair.
    claim HaR: a :e R.
    { exact (andEL (a :e R) (Bof x :e {halfopen_interval_left a bb|bb :e R}) Hapair). }
    claim HbFam: Bof x :e {halfopen_interval_left a bb|bb :e R}.
    { exact (andER (a :e R) (Bof x :e {halfopen_interval_left a bb|bb :e R}) Hapair). }
    exact (Eps_i_ax (fun a0:set => a0 :e R /\ Bof x :e {halfopen_interval_left a0 bb|bb :e R})
                    a (andI (a :e R) (Bof x :e {halfopen_interval_left a bb|bb :e R}) HaR HbFam)). }

  set BBof := fun x:set =>
    Eps_i (fun bb:set => bb :e R /\ Bof x = halfopen_interval_left (Aof x) bb).
  claim HBBof_spec: forall x:set, x :e Sorgenfrey_line ->
    BBof x :e R /\ Bof x = halfopen_interval_left (Aof x) (BBof x).
  { let x. assume HxR: x :e Sorgenfrey_line.
    claim HA: Aof x :e R /\ Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}.
    { exact (HAof_spec x HxR). }
    claim HBfam: Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}.
    { exact (andER (Aof x :e R) (Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}) HA). }
    claim Hexbb: exists bb :e R, Bof x = halfopen_interval_left (Aof x) bb.
    { exact (ReplE R (fun bb0:set => halfopen_interval_left (Aof x) bb0) (Bof x) HBfam). }
    apply Hexbb.
    let bb. assume Hbbpair.
    claim HbbR: bb :e R.
    { exact (andEL (bb :e R) (Bof x = halfopen_interval_left (Aof x) bb) Hbbpair). }
    claim HbEq: Bof x = halfopen_interval_left (Aof x) bb.
    { exact (andER (bb :e R) (Bof x = halfopen_interval_left (Aof x) bb) Hbbpair). }
    exact (Eps_i_ax (fun bb0:set => bb0 :e R /\ Bof x = halfopen_interval_left (Aof x) bb0)
                    bb (andI (bb :e R) (Bof x = halfopen_interval_left (Aof x) bb) HbbR HbEq)). }

  set Iof := fun x:set => open_interval (Aof x) (BBof x).
  set FamI := {Iof x|x :e Sorgenfrey_line}.
  set C := Union FamI.
  set D := Sorgenfrey_line :\: C.

  (** Step 3: R\\C is countable by injecting into rational_numbers via x |-> q_x in (x,BBof x). **)
  set q_of := fun x:set =>
    Eps_i (fun q:set => q :e rational_numbers /\ q :e open_interval x (BBof x)).

  claim HD_left_endpoint: forall x:set, x :e D -> Aof x = x.
  { let x. assume HxD: x :e D.
    claim HxR: x :e Sorgenfrey_line.
    { exact (setminusE1 Sorgenfrey_line C x HxD). }
    claim HxnotC: ~(x :e C).
    { exact (setminusE2 Sorgenfrey_line C x HxD). }
    claim HBspec: Bof x :e R_lower_limit_basis /\ x :e Bof x /\ Bof x c= Uof x.
    { exact (HBof_spec x HxR). }
    claim HBleft0: Bof x :e R_lower_limit_basis /\ x :e Bof x.
    { exact (andEL (Bof x :e R_lower_limit_basis /\ x :e Bof x)
                   (Bof x c= Uof x)
                   HBspec). }
    claim HxB: x :e Bof x.
    { exact (andER (Bof x :e R_lower_limit_basis) (x :e Bof x) HBleft0). }
    claim Hbbpair: BBof x :e R /\ Bof x = halfopen_interval_left (Aof x) (BBof x).
    { exact (HBBof_spec x HxR). }
    claim HbbR: BBof x :e R.
    { exact (andEL (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) Hbbpair). }
    claim HbEq: Bof x = halfopen_interval_left (Aof x) (BBof x).
    { exact (andER (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) Hbbpair). }
    claim HxHalf: x :e halfopen_interval_left (Aof x) (BBof x).
    { rewrite <- HbEq. exact HxB. }
    claim HxProp: ~(Rlt x (Aof x)) /\ Rlt x (BBof x).
    { exact (SepE2 R (fun t:set => ~(Rlt t (Aof x)) /\ Rlt t (BBof x)) x HxHalf). }
    claim Hxnltxa: ~(Rlt x (Aof x)).
    { exact (andEL (~(Rlt x (Aof x))) (Rlt x (BBof x)) HxProp). }
    claim Hxltbb: Rlt x (BBof x).
    { exact (andER (~(Rlt x (Aof x))) (Rlt x (BBof x)) HxProp). }

    (** x not in its own open interval Iof x, since Iof x ⊂ C **)
    claim HIofsubC: Iof x c= C.
    { let y. assume Hy: y :e Iof x.
      apply (UnionI FamI y (Iof x)).
      - exact Hy.
      - exact (ReplI Sorgenfrey_line (fun z:set => Iof z) x HxR). }
    claim HxnotIof: ~(x :e Iof x).
    { assume HxI: x :e Iof x.
      exact (HxnotC (HIofsubC x HxI)). }
    claim HxnotOpen: ~(x :e open_interval (Aof x) (BBof x)).
    { exact HxnotIof. }
    claim Hnltax: ~(Rlt (Aof x) x).
    { assume Halt: Rlt (Aof x) x.
      claim HxinOpen: x :e open_interval (Aof x) (BBof x).
      { exact (SepI R (fun t:set => Rlt (Aof x) t /\ Rlt t (BBof x)) x HxR (andI (Rlt (Aof x) x) (Rlt x (BBof x)) Halt Hxltbb)). }
      exact (HxnotOpen HxinOpen). }
    claim HaR: Aof x :e R.
    { exact (andEL (Aof x :e R) (Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}) (HAof_spec x HxR)). }
    exact (R_eq_of_not_Rlt (Aof x) x HaR HxR Hnltax Hxnltxa). }

  claim Hq_of_spec: forall x:set, x :e D ->
    q_of x :e rational_numbers /\ q_of x :e open_interval x (BBof x).
  { let x. assume HxD: x :e D.
    claim HxR: x :e Sorgenfrey_line.
    { exact (setminusE1 Sorgenfrey_line C x HxD). }
    claim Hbpair: BBof x :e R /\ Bof x = halfopen_interval_left (Aof x) (BBof x).
    { exact (HBBof_spec x HxR). }
    claim HbbR: BBof x :e R.
    { exact (andEL (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) Hbpair). }
    claim HBspec: Bof x :e R_lower_limit_basis /\ x :e Bof x /\ Bof x c= Uof x.
    { exact (HBof_spec x HxR). }
    claim HBleft0: Bof x :e R_lower_limit_basis /\ x :e Bof x.
    { exact (andEL (Bof x :e R_lower_limit_basis /\ x :e Bof x)
                   (Bof x c= Uof x)
                   HBspec). }
    claim HxB: x :e Bof x.
    { exact (andER (Bof x :e R_lower_limit_basis) (x :e Bof x) HBleft0). }
    claim HbEq: Bof x = halfopen_interval_left (Aof x) (BBof x).
    { exact (andER (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) Hbpair). }
    claim HxHalf: x :e halfopen_interval_left (Aof x) (BBof x).
    { rewrite <- HbEq. exact HxB. }
    claim HxProp: ~(Rlt x (Aof x)) /\ Rlt x (BBof x).
    { exact (SepE2 R (fun t:set => ~(Rlt t (Aof x)) /\ Rlt t (BBof x)) x HxHalf). }
    claim Hxltbb: Rlt x (BBof x).
    { exact (andER (~(Rlt x (Aof x))) (Rlt x (BBof x)) HxProp). }
    (** pick a rational between x and BBof x **)
    claim Hexq0: exists q :e rational_numbers, Rlt x q /\ Rlt q (BBof x).
    { exact (rational_dense_between_reals x (BBof x) HxR HbbR Hxltbb). }
    apply Hexq0.
    let q. assume Hqpair.
    claim HqQ: q :e rational_numbers.
    { exact (andEL (q :e rational_numbers) (Rlt x q /\ Rlt q (BBof x)) Hqpair). }
    claim Hqprop: Rlt x q /\ Rlt q (BBof x).
    { exact (andER (q :e rational_numbers) (Rlt x q /\ Rlt q (BBof x)) Hqpair). }
    claim HqIn: q :e open_interval x (BBof x).
    { claim Hdef: open_interval x (BBof x) = {t :e R|Rlt x t /\ Rlt t (BBof x)}.
      { reflexivity. }
      rewrite Hdef.
      exact (SepI R (fun t:set => Rlt x t /\ Rlt t (BBof x)) q (rational_numbers_Subq_R q HqQ) Hqprop). }
    exact (Eps_i_ax (fun q0:set => q0 :e rational_numbers /\ q0 :e open_interval x (BBof x))
                    q (andI (q :e rational_numbers) (q :e open_interval x (BBof x)) HqQ HqIn)). }

  claim Hq_inj: inj D rational_numbers q_of.
  { prove inj D rational_numbers q_of.
    prove (forall x :e D, q_of x :e rational_numbers) /\
          (forall x y :e D, q_of x = q_of y -> x = y).
    apply andI.
    - let x. assume HxD: x :e D.
      exact (andEL (q_of x :e rational_numbers)
                   (q_of x :e open_interval x (BBof x))
                   (Hq_of_spec x HxD)).
    - let x. assume HxD: x :e D.
      let y. assume HyD: y :e D.
      assume Heq: q_of x = q_of y.
      (** compare x and y using trichotomy on reals **)
      claim HxR: x :e R.
      { exact (setminusE1 Sorgenfrey_line C x HxD). }
      claim HyR: y :e R.
      { exact (setminusE1 Sorgenfrey_line C y HyD). }
      claim HxS: SNo x.
      { exact (real_SNo x HxR). }
      claim HyS: SNo y.
      { exact (real_SNo y HyR). }
      apply (SNoLt_trichotomy_or_impred x y HxS HyS (x = y)).
      + assume Hxy: x < y.
        claim HxyR: Rlt x y.
        { exact (RltI x y HxR HyR Hxy). }
        claim HxA: Aof x = x.
        { exact (HD_left_endpoint x HxD). }
        claim HyA: Aof y = y.
        { exact (HD_left_endpoint y HyD). }
        claim Hqxp: q_of x :e open_interval x (BBof x).
        { exact (andER (q_of x :e rational_numbers)
                       (q_of x :e open_interval x (BBof x))
                       (Hq_of_spec x HxD)). }
        claim Hqyp: q_of y :e open_interval y (BBof y).
        { exact (andER (q_of y :e rational_numbers)
                       (q_of y :e open_interval y (BBof y))
                       (Hq_of_spec y HyD)). }
        claim HqInR: q_of x :e R.
        { exact (rational_numbers_Subq_R (q_of x)
                (andEL (q_of x :e rational_numbers)
                       (q_of x :e open_interval x (BBof x))
                       (Hq_of_spec x HxD))). }
        (** q_of x < y < q_of y, hence q_of x <> q_of y contradicting Heq **)
        claim Hqxb: Rlt x (q_of x) /\ Rlt (q_of x) (BBof x).
        { exact (SepE2 R (fun t:set => Rlt x t /\ Rlt t (BBof x)) (q_of x) Hqxp). }
        claim Hqxlty: Rlt (q_of x) y.
        { (** show BBof x <= y because y not in open_interval x (BBof x) **)
          claim HyNotC: ~(y :e C).
          { exact (setminusE2 Sorgenfrey_line C y HyD). }
          claim HIofsubC: Iof x c= C.
          { let t. assume Ht: t :e Iof x.
            apply (UnionI FamI t (Iof x)).
            - exact Ht.
            - exact (ReplI Sorgenfrey_line (fun z:set => Iof z) x HxR). }
          claim HyNotIof: ~(y :e Iof x).
          { assume HyI: y :e Iof x.
            exact (HyNotC (HIofsubC y HyI)). }
          claim HyNotOpen: ~(y :e open_interval (Aof x) (BBof x)).
          { exact HyNotIof. }
          claim Hnlt: ~(Rlt y (BBof x)).
          { assume Hyltbb: Rlt y (BBof x).
            claim HyIn: y :e open_interval x (BBof x).
            { exact (SepI R (fun t:set => Rlt x t /\ Rlt t (BBof x)) y HyR (andI (Rlt x y) (Rlt y (BBof x)) HxyR Hyltbb)). }
            claim HyIn2: y :e open_interval (Aof x) (BBof x).
            { rewrite HxA.
              exact HyIn. }
            exact (HyNotOpen HyIn2). }
          claim HbbR: BBof x :e R.
          { exact (andEL (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) (HBBof_spec x HxR)). }
          claim HbbLe: Rle (BBof x) y.
          { exact (RleI (BBof x) y HbbR HyR Hnlt). }
          exact (Rlt_Rle_tra (q_of x) (BBof x) y
                             (andER (Rlt x (q_of x)) (Rlt (q_of x) (BBof x)) Hqxb)
                             HbbLe). }
        claim Hyltqy: Rlt y (q_of y).
        { exact (andEL (Rlt y (q_of y)) (Rlt (q_of y) (BBof y))
                       (SepE2 R (fun t:set => Rlt y t /\ Rlt t (BBof y)) (q_of y) Hqyp)). }
        claim Hqxltyq: Rlt (q_of x) (q_of y).
        { exact (Rlt_tra (q_of x) y (q_of y) Hqxlty Hyltqy). }
        prove x = y.
        apply FalseE.
        claim HqxQ: q_of x :e rational_numbers.
        { exact (andEL (q_of x :e rational_numbers)
                       (q_of x :e open_interval x (BBof x))
                       (Hq_of_spec x HxD)). }
        claim HqxR0: q_of x :e R.
        { exact (rational_numbers_Subq_R (q_of x) HqxQ). }
        claim Hqxx: Rlt (q_of x) (q_of x).
        { rewrite Heq at 2.
          exact Hqxltyq. }
        exact ((not_Rlt_refl (q_of x) HqxR0) Hqxx).
      + assume HxyEq: x = y.
        exact HxyEq.
      + assume Hyx: y < x.
        claim HyxR: Rlt y x.
        { exact (RltI y x HyR HxR Hyx). }
        claim Hqyp: q_of y :e open_interval y (BBof y).
        { exact (andER (q_of y :e rational_numbers)
                       (q_of y :e open_interval y (BBof y))
                       (Hq_of_spec y HyD)). }
        claim Hqxp: q_of x :e open_interval x (BBof x).
        { exact (andER (q_of x :e rational_numbers)
                       (q_of x :e open_interval x (BBof x))
                       (Hq_of_spec x HxD)). }
        claim Hqyb: Rlt y (q_of y) /\ Rlt (q_of y) (BBof y).
        { exact (SepE2 R (fun t:set => Rlt y t /\ Rlt t (BBof y)) (q_of y) Hqyp). }
        claim Hqyltx: Rlt (q_of y) x.
        { (** show BBof y <= x because x not in open_interval y (BBof y) **)
          claim HxNotC: ~(x :e C).
          { exact (setminusE2 Sorgenfrey_line C x HxD). }
          claim HIofsubC: Iof y c= C.
          { let t. assume Ht: t :e Iof y.
            apply (UnionI FamI t (Iof y)).
            - exact Ht.
            - exact (ReplI Sorgenfrey_line (fun z:set => Iof z) y HyR). }
          claim HxNotIof: ~(x :e Iof y).
          { assume HxI: x :e Iof y.
            exact (HxNotC (HIofsubC x HxI)). }
          claim HxNotOpen: ~(x :e open_interval (Aof y) (BBof y)).
          { exact HxNotIof. }
          claim HyA: Aof y = y.
          { exact (HD_left_endpoint y HyD). }
          claim Hnlt: ~(Rlt x (BBof y)).
          { assume Hxltbb: Rlt x (BBof y).
            claim HxIn: x :e open_interval y (BBof y).
            { exact (SepI R (fun t:set => Rlt y t /\ Rlt t (BBof y)) x HxR (andI (Rlt y x) (Rlt x (BBof y)) HyxR Hxltbb)). }
            claim HxIn2: x :e open_interval (Aof y) (BBof y).
            { rewrite HyA.
              exact HxIn. }
            exact (HxNotOpen HxIn2). }
          claim HbbR: BBof y :e R.
          { exact (andEL (BBof y :e R) (Bof y = halfopen_interval_left (Aof y) (BBof y)) (HBBof_spec y HyR)). }
          claim HbbLe: Rle (BBof y) x.
          { exact (RleI (BBof y) x HbbR HxR Hnlt). }
          exact (Rlt_Rle_tra (q_of y) (BBof y) x
                             (andER (Rlt y (q_of y)) (Rlt (q_of y) (BBof y)) Hqyb)
                             HbbLe). }
        claim Hxltqx: Rlt x (q_of x).
        { exact (andEL (Rlt x (q_of x)) (Rlt (q_of x) (BBof x))
                       (SepE2 R (fun t:set => Rlt x t /\ Rlt t (BBof x)) (q_of x) Hqxp)). }
        claim Hqyltqx: Rlt (q_of y) (q_of x).
        { exact (Rlt_tra (q_of y) x (q_of x) Hqyltx Hxltqx). }
        prove x = y.
        apply FalseE.
        claim HqxQ: q_of x :e rational_numbers.
        { exact (andEL (q_of x :e rational_numbers)
                       (q_of x :e open_interval x (BBof x))
                       (Hq_of_spec x HxD)). }
        claim HqxR0: q_of x :e R.
        { exact (rational_numbers_Subq_R (q_of x) HqxQ). }
        claim Hqxx: Rlt (q_of x) (q_of x).
        { rewrite Heq at 1.
          exact Hqyltqx. }
        exact ((not_Rlt_refl (q_of x) HqxR0) Hqxx). }

  claim HDcount: countable_set D.
  { claim HeqImg: equip D {q_of x|x :e D}.
    { exact (inj_equip_image D rational_numbers q_of Hq_inj). }
    claim HimgSub: {q_of x|x :e D} c= rational_numbers.
    { let q. assume Hq: q :e {q_of x|x :e D}.
      apply (ReplE_impred D (fun x0:set => q_of x0) q Hq (q :e rational_numbers)).
      let x. assume HxD: x :e D.
      assume Heq: q = q_of x.
      rewrite Heq.
      exact (andEL (q_of x :e rational_numbers)
                   (q_of x :e open_interval x (BBof x))
                   (Hq_of_spec x HxD)). }
    claim HimgCount: countable_set {q_of x|x :e D}.
    { exact (Subq_countable {q_of x|x :e D} rational_numbers rational_numbers_countable HimgSub). }
    exact (equip_countable_set_right D {q_of x|x :e D} HeqImg HimgCount). }

  (** Build countable subcollection of U covering D by x |-> Uof x **)
  set V0 := {Uof x|x :e D}.
  claim HV0subU: V0 c= U.
  { let v. assume Hv: v :e V0.
    apply (ReplE_impred D (fun x0:set => Uof x0) v Hv (v :e U)).
    let x. assume HxD: x :e D.
    assume HvEq: v = Uof x.
    claim HxR: x :e Sorgenfrey_line.
    { exact (setminusE1 Sorgenfrey_line C x HxD). }
    rewrite HvEq.
    claim HUleft: Uof x :e U /\ x :e Uof x.
    { exact (andEL (Uof x :e U /\ x :e Uof x)
                   (exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x)
                   (HUof_spec x HxR)). }
    exact (andEL (Uof x :e U) (x :e Uof x) HUleft). }
  claim HV0count: countable_set V0.
  { exact (countable_image D HDcount (fun x0:set => Uof x0)). }
  claim HV0coversD: covers D V0.
  { let x. assume HxD: x :e D.
    witness (Uof x).
    apply andI.
    - exact (ReplI D (fun x0:set => Uof x0) x HxD).
    - claim HxR: x :e Sorgenfrey_line.
      { exact (setminusE1 Sorgenfrey_line C x HxD). }
      claim HUleft: Uof x :e U /\ x :e Uof x.
      { exact (andEL (Uof x :e U /\ x :e Uof x)
                     (exists b :e R_lower_limit_basis, x :e b /\ b c= Uof x)
                     (HUof_spec x HxR)). }
      exact (andER (Uof x :e U) (x :e Uof x) HUleft). }

  (** Step 4: Cover C using second countability of R in the standard topology. **)
  set FamC := {Iof x :/\: C|x :e Sorgenfrey_line}.
  claim HFamC_cover: open_cover C (subspace_topology R R_standard_topology C) FamC.
  { prove open_cover C (subspace_topology R R_standard_topology C) FamC.
    prove (forall u:set, u :e FamC -> u :e subspace_topology R R_standard_topology C) /\ covers C FamC.
    apply andI.
    - let u. assume Hu: u :e FamC.
      apply (ReplE_impred Sorgenfrey_line (fun x0:set => Iof x0 :/\: C) u Hu (u :e subspace_topology R R_standard_topology C)).
      let x. assume HxR: x :e Sorgenfrey_line.
      assume Hueq: u = Iof x :/\: C.
      claim HxR0: x :e Sorgenfrey_line.
      { exact HxR. }
      claim HbbR: BBof x :e R.
      { exact (andEL (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) (HBBof_spec x HxR0)). }
      claim HaR: Aof x :e R.
      { exact (andEL (Aof x :e R) (Bof x :e {halfopen_interval_left (Aof x) bb|bb :e R}) (HAof_spec x HxR0)). }
	      claim HBspec: (Bof x :e R_lower_limit_basis /\ x :e Bof x) /\ Bof x c= Uof x.
	      { exact (HBof_spec x HxR0). }
	      claim HBleft: Bof x :e R_lower_limit_basis /\ x :e Bof x.
	      { exact (andEL (Bof x :e R_lower_limit_basis /\ x :e Bof x)
	                     (Bof x c= Uof x)
	                     HBspec). }
	      claim HxB: x :e Bof x.
	      { exact (andER (Bof x :e R_lower_limit_basis) (x :e Bof x) HBleft). }
      claim HbEq: Bof x = halfopen_interval_left (Aof x) (BBof x).
      { exact (andER (BBof x :e R) (Bof x = halfopen_interval_left (Aof x) (BBof x)) (HBBof_spec x HxR0)). }
      claim HxHalf: x :e halfopen_interval_left (Aof x) (BBof x).
      { rewrite <- HbEq. exact HxB. }
      claim HxProp: ~(Rlt x (Aof x)) /\ Rlt x (BBof x).
      { exact (SepE2 R (fun t:set => ~(Rlt t (Aof x)) /\ Rlt t (BBof x)) x HxHalf). }
      claim Hxnlt: ~(Rlt x (Aof x)).
      { exact (andEL (~(Rlt x (Aof x))) (Rlt x (BBof x)) HxProp). }
      claim Hxlt: Rlt x (BBof x).
      { exact (andER (~(Rlt x (Aof x))) (Rlt x (BBof x)) HxProp). }
      claim Hax: Rle (Aof x) x.
      { exact (RleI (Aof x) x HaR HxR0 Hxnlt). }
      claim Hab: Rlt (Aof x) (BBof x).
      { exact (Rle_Rlt_tra (Aof x) x (BBof x) Hax Hxlt). }
      claim HopenI: open_interval (Aof x) (BBof x) :e R_standard_topology.
      { exact (open_interval_in_R_standard_topology (Aof x) (BBof x) Hab). }
      rewrite Hueq.
      exact (subspace_topologyI R R_standard_topology C (Iof x) HopenI).
    - (** covers C FamC **)
      let y. assume HyC: y :e C.
      apply (UnionE_impred FamI y HyC (exists u:set, u :e FamC /\ y :e u)).
      let W. assume HyW: y :e W.
      assume HWFam: W :e FamI.
      apply (ReplE_impred Sorgenfrey_line (fun x0:set => Iof x0) W HWFam (exists u:set, u :e FamC /\ y :e u)).
      let x. assume HxR: x :e Sorgenfrey_line.
      assume HWeq: W = Iof x.
      witness (Iof x :/\: C).
      apply andI.
      + exact (ReplI Sorgenfrey_line (fun z:set => Iof z :/\: C) x HxR).
      + apply binintersectI.
        * rewrite <- HWeq. exact HyW.
        * exact HyC. }

  claim HCsubR: C c= R.
  { let y. assume Hy: y :e C.
    apply (UnionE_impred FamI y Hy (y :e R)).
    let W. assume HyW: y :e W.
    assume HW: W :e FamI.
    apply (ReplE_impred Sorgenfrey_line (fun x0:set => Iof x0) W HW (y :e R)).
    let x. assume HxR: x :e Sorgenfrey_line.
    assume HWeq: W = Iof x.
    claim HyI: y :e Iof x.
    { rewrite <- HWeq.
      exact HyW. }
    exact (open_interval_Subq_R (Aof x) (BBof x) y HyI). }

  claim HtopCstd: topology_on C (subspace_topology R R_standard_topology C).
  { exact (subspace_topology_is_topology R R_standard_topology C R_standard_topology_is_topology HCsubR). }
	  claim HsecCstd: second_countable_space C (subspace_topology R R_standard_topology C).
	  { (** extract the second clause from countability_axioms_subspace_product **)
	    claim Hcap: (((forall A:set, A c= R -> first_countable_space R R_standard_topology ->
	                     first_countable_space A (subspace_topology R R_standard_topology A)) /\
	                    (forall A:set, A c= R -> second_countable_space R R_standard_topology ->
	                     second_countable_space A (subspace_topology R R_standard_topology A))) /\
	                   (forall I Xi:set, countable_index_set I ->
	                     (forall i:set, i :e I -> first_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
	                     first_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi))) /\
	                  (forall I Xi:set, countable_index_set I ->
	                    (forall i:set, i :e I -> second_countable_space (space_family_set Xi i) (space_family_topology Xi i)) ->
	                    second_countable_space (countable_product_space I Xi) (countable_product_topology_subbasis I Xi)).
	    { exact (countability_axioms_subspace_product R R_standard_topology R_standard_topology_is_topology). }
	    claim Hcc: (forall A:set, A c= R -> second_countable_space R R_standard_topology ->
	                  second_countable_space A (subspace_topology R R_standard_topology A)).
	    { apply Hcap.
	      assume Hsubprod1 Hprod2.
	      apply Hsubprod1.
	      assume Hsub Hprod1.
	      apply Hsub.
	      assume Hfc_sub Hsc_sub.
	      exact Hsc_sub. }
	    exact (Hcc C HCsubR R_standard_topology_second_countable). }

  claim HexW: exists W:set, countable_subcollection W FamC /\ covers C W.
  { exact (countable_basis_implies_Lindelof C (subspace_topology R R_standard_topology C) HtopCstd HsecCstd FamC HFamC_cover). }
  apply HexW.
  let W. assume HWpair.
  claim HWsub: countable_subcollection W FamC.
  { exact (andEL (countable_subcollection W FamC) (covers C W) HWpair). }
  claim HWcov: covers C W.
  { exact (andER (countable_subcollection W FamC) (covers C W) HWpair). }
  claim HWcount: countable_set W.
  { exact (andER (W c= FamC) (countable_set W) HWsub). }

  set pickx := fun w:set => Eps_i (fun x:set => x :e Sorgenfrey_line /\ w = Iof x :/\: C).
  claim Hpickx_spec: forall w:set, w :e W ->
    pickx w :e Sorgenfrey_line /\ w = Iof (pickx w) :/\: C.
  { let w. assume HwW: w :e W.
    claim HwFamC: w :e FamC.
    { exact ((andEL (W c= FamC) (countable_set W) HWsub) w HwW). }
    claim Hexx: exists x:set, x :e Sorgenfrey_line /\ w = Iof x :/\: C.
    { apply (ReplE_impred Sorgenfrey_line (fun x0:set => Iof x0 :/\: C) w HwFamC
                          (exists x:set, x :e Sorgenfrey_line /\ w = Iof x :/\: C)).
      let x. assume HxR: x :e Sorgenfrey_line.
      assume Hweq: w = Iof x :/\: C.
      witness x.
      apply andI.
      - exact HxR.
      - exact Hweq. }
    apply Hexx.
    let x. assume Hxpair.
    exact (Eps_i_ax (fun x0:set => x0 :e Sorgenfrey_line /\ w = Iof x0 :/\: C) x Hxpair). }

  set V1 := {Uof (pickx w)|w :e W}.
  claim HV1subU: V1 c= U.
  { let v. assume Hv: v :e V1.
    apply (ReplE_impred W (fun w0:set => Uof (pickx w0)) v Hv (v :e U)).
    let w. assume HwW: w :e W.
    assume HvEq: v = Uof (pickx w).
	    claim HxR: pickx w :e Sorgenfrey_line.
	    { exact (andEL (pickx w :e Sorgenfrey_line) (w = Iof (pickx w) :/\: C) (Hpickx_spec w HwW)). }
	    rewrite HvEq.
	    claim HUleft: Uof (pickx w) :e U /\ pickx w :e Uof (pickx w).
	    { exact (andEL
	              (Uof (pickx w) :e U /\ pickx w :e Uof (pickx w))
	              (exists b :e R_lower_limit_basis, pickx w :e b /\ b c= Uof (pickx w))
	              (HUof_spec (pickx w) HxR)). }
	    exact (andEL (Uof (pickx w) :e U) (pickx w :e Uof (pickx w)) HUleft). }
  claim HV1count: countable_set V1.
  { exact (countable_image W HWcount (fun w0:set => Uof (pickx w0))). }

  claim HV1coversC: covers C V1.
  { let y. assume HyC: y :e C.
    apply (HWcov y HyC).
    let w. assume Hwpair.
    claim HwW: w :e W.
    { exact (andEL (w :e W) (y :e w) Hwpair). }
    claim Hyw: y :e w.
    { exact (andER (w :e W) (y :e w) Hwpair). }
    claim Hxpair: pickx w :e Sorgenfrey_line /\ w = Iof (pickx w) :/\: C.
    { exact (Hpickx_spec w HwW). }
    claim HxR: pickx w :e Sorgenfrey_line.
    { exact (andEL (pickx w :e Sorgenfrey_line) (w = Iof (pickx w) :/\: C) Hxpair). }
    claim Hweq: w = Iof (pickx w) :/\: C.
    { exact (andER (pickx w :e Sorgenfrey_line) (w = Iof (pickx w) :/\: C) Hxpair). }
    claim HyInI: y :e Iof (pickx w).
    { claim Hyw2: y :e Iof (pickx w) :/\: C.
      { rewrite <- Hweq.
        exact Hyw. }
      exact (binintersectE1 (Iof (pickx w)) C y Hyw2). }
    (** open interval subset of chosen cover element Uof (pickx w) **)
    claim HsubIU: Iof (pickx w) c= Uof (pickx w).
    { let t. assume HtI: t :e Iof (pickx w).
      claim Hbbpair: BBof (pickx w) :e R /\ Bof (pickx w) = halfopen_interval_left (Aof (pickx w)) (BBof (pickx w)).
      { exact (HBBof_spec (pickx w) HxR). }
      claim HbEq: Bof (pickx w) = halfopen_interval_left (Aof (pickx w)) (BBof (pickx w)).
      { exact (andER (BBof (pickx w) :e R) (Bof (pickx w) = halfopen_interval_left (Aof (pickx w)) (BBof (pickx w))) Hbbpair). }
	      claim HBspec: (Bof (pickx w) :e R_lower_limit_basis /\ pickx w :e Bof (pickx w)) /\ Bof (pickx w) c= Uof (pickx w).
	      { exact (HBof_spec (pickx w) HxR). }
	      claim HBsub: Bof (pickx w) c= Uof (pickx w).
	      { exact (andER
	                (Bof (pickx w) :e R_lower_limit_basis /\ pickx w :e Bof (pickx w))
	                (Bof (pickx w) c= Uof (pickx w))
	                HBspec). }
      claim HopenSubHalf: open_interval (Aof (pickx w)) (BBof (pickx w)) c= halfopen_interval_left (Aof (pickx w)) (BBof (pickx w)).
      { let z. assume HzI: z :e open_interval (Aof (pickx w)) (BBof (pickx w)).
        claim HzR: z :e R.
        { exact (SepE1 R (fun t:set => Rlt (Aof (pickx w)) t /\ Rlt t (BBof (pickx w))) z HzI). }
        claim Hzprop: Rlt (Aof (pickx w)) z /\ Rlt z (BBof (pickx w)).
        { exact (SepE2 R (fun t:set => Rlt (Aof (pickx w)) t /\ Rlt t (BBof (pickx w))) z HzI). }
        claim Hza: Rlt (Aof (pickx w)) z.
        { exact (andEL (Rlt (Aof (pickx w)) z) (Rlt z (BBof (pickx w))) Hzprop). }
        claim Hzb: Rlt z (BBof (pickx w)).
        { exact (andER (Rlt (Aof (pickx w)) z) (Rlt z (BBof (pickx w))) Hzprop). }
        claim Hnlt: ~(Rlt z (Aof (pickx w))).
        { exact (not_Rlt_sym (Aof (pickx w)) z Hza). }
        exact (SepI R (fun t:set => ~(Rlt t (Aof (pickx w))) /\ Rlt t (BBof (pickx w))) z HzR (andI (~(Rlt z (Aof (pickx w)))) (Rlt z (BBof (pickx w))) Hnlt Hzb)). }
      claim HtHalf: t :e halfopen_interval_left (Aof (pickx w)) (BBof (pickx w)).
      { exact (HopenSubHalf t HtI). }
      claim HtB: t :e Bof (pickx w).
      { rewrite HbEq. exact HtHalf. }
      exact (HBsub t HtB). }
    witness (Uof (pickx w)).
    apply andI.
    - exact (ReplI W (fun w0:set => Uof (pickx w0)) w HwW).
    - exact (HsubIU y HyInI). }

  (** Step 5: combine the two countable subcollections covering D and C **)
  set V := V0 :\/: V1.
  witness V.
  apply andI.
  - prove countable_subcollection V U.
    prove V c= U /\ countable_set V.
    apply andI.
    + (** V c= U **)
      let v. assume HvV: v :e V.
      apply (binunionE' V0 V1 v (v :e U)).
      * assume Hv0: v :e V0.
        exact (HV0subU v Hv0).
      * assume Hv1: v :e V1.
        exact (HV1subU v Hv1).
      * exact HvV.
    + (** countable_set V **)
      exact (binunion_countable V0 V1 HV0count HV1count).
  - (** V covers Sorgenfrey_line **)
    prove covers Sorgenfrey_line V.
    let x. assume HxR: x :e Sorgenfrey_line.
    apply (xm (x :e C)).
    + assume HxC: x :e C.
      apply (HV1coversC x HxC).
      let u. assume Hupair.
      witness u.
      apply andI.
      * apply binunionI2. exact (andEL (u :e V1) (x :e u) Hupair).
      * exact (andER (u :e V1) (x :e u) Hupair).
    + assume HxnotC: ~(x :e C).
      claim HxD: x :e D.
      { exact (setminusI Sorgenfrey_line C x HxR HxnotC). }
      apply (HV0coversD x HxD).
      let u. assume Hupair.
      witness u.
      apply andI.
      * apply binunionI1. exact (andEL (u :e V0) (x :e u) Hupair).
      * exact (andER (u :e V0) (x :e u) Hupair).
Qed.

Theorem Sorgenfrey_line_countability :
  first_countable_space Sorgenfrey_line Sorgenfrey_topology /\
  dense_in rational_numbers Sorgenfrey_line Sorgenfrey_topology /\
  Lindelof_space Sorgenfrey_line Sorgenfrey_topology /\
  ~ second_countable_space Sorgenfrey_line Sorgenfrey_topology.
prove first_countable_space Sorgenfrey_line Sorgenfrey_topology /\
  dense_in rational_numbers Sorgenfrey_line Sorgenfrey_topology /\
  Lindelof_space Sorgenfrey_line Sorgenfrey_topology /\
  ~ second_countable_space Sorgenfrey_line Sorgenfrey_topology.
apply andI.
- (** first_countable /\ dense_in /\ Lindelof **)
  apply andI.
  + (** first_countable /\ dense_in **)
    apply andI.
    * exact Sorgenfrey_line_first_countable.
    * exact Sorgenfrey_line_rationals_dense.
  + (** Lindelof_space Sorgenfrey_line Sorgenfrey_topology **)
    exact Sorgenfrey_line_Lindelof.
- (** not second countable **)
  exact Sorgenfrey_line_not_second_countable.
Qed.

(** placeholders for later refinement of product/separation constructions **) 
(** LATEX VERSION: Sorgenfrey plane topology = product of two Sorgenfrey lines. **)
Definition Sorgenfrey_plane_topology : set :=
  product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.

(** LATEX VERSION: D = set of points in R_l^2 with rational coordinates. **)
Definition Sorgenfrey_plane_rational_points : set :=
  setprod rational_numbers rational_numbers.

(** helper: D is countable **)
Theorem Sorgenfrey_plane_rational_points_countable :
  countable_set Sorgenfrey_plane_rational_points.
prove countable_set Sorgenfrey_plane_rational_points.
prove countable Sorgenfrey_plane_rational_points.
claim HQ: countable rational_numbers.
{ exact rational_numbers_countable. }
exact (setprod_countable rational_numbers rational_numbers HQ HQ).
Qed.

(** helper: D is dense in the Sorgenfrey plane **)
Theorem Sorgenfrey_plane_rational_points_dense :
  dense_in Sorgenfrey_plane_rational_points
           (setprod Sorgenfrey_line Sorgenfrey_line)
           Sorgenfrey_plane_topology.
prove dense_in Sorgenfrey_plane_rational_points
           (setprod Sorgenfrey_line Sorgenfrey_line)
           Sorgenfrey_plane_topology.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
set D := Sorgenfrey_plane_rational_points.
set B := product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.

claim HTline: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HTx: topology_on X Tx.
{ claim Hdef: Tx = product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
  { reflexivity. }
  rewrite Hdef.
  exact (product_topology_is_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HTline HTline). }

prove closure_of X Tx D = X.
apply set_ext.
- exact (closure_in_space X Tx D HTx).
- let p. assume HpX: p :e X.
  prove p :e closure_of X Tx D.
  claim Hcliff: p :e closure_of X Tx D
    <-> (forall U :e Tx, p :e U -> U :/\: D <> Empty).
  { exact (closure_characterization X Tx D p HTx HpX). }
  apply (iffER (p :e closure_of X Tx D)
               (forall U :e Tx, p :e U -> U :/\: D <> Empty)
               Hcliff).
  prove forall U :e Tx, p :e U -> U :/\: D <> Empty.
  let U. assume HU: U :e Tx. assume HpU: p :e U.
  claim Hb0: exists b0 :e B, p :e b0 /\ b0 c= U.
  { (** rewrite U :e Tx as U :e generated_topology X B and apply local refinement **)
    claim HdefT: Tx = generated_topology X B.
    { reflexivity. }
    claim HUgen: U :e generated_topology X B.
    { rewrite <- HdefT.
      exact HU. }
    exact (generated_topology_local_refine X B U p HUgen HpU). }
  apply Hb0.
  let b0. assume Hb0pair.
  claim Hb0B: b0 :e B.
  { exact (andEL (b0 :e B) (p :e b0 /\ b0 c= U) Hb0pair). }
  claim Hb0prop: p :e b0 /\ b0 c= U.
  { exact (andER (b0 :e B) (p :e b0 /\ b0 c= U) Hb0pair). }
  claim Hpb0: p :e b0.
  { exact (andEL (p :e b0) (b0 c= U) Hb0prop). }
  claim Hb0subU: b0 c= U.
  { exact (andER (p :e b0) (b0 c= U) Hb0prop). }
  (** destruct b0 as a rectangle_set U0 V0 **)
  claim HexU0: exists U0 :e Sorgenfrey_topology, b0 :e {rectangle_set U0 V|V :e Sorgenfrey_topology}.
  { exact (famunionE Sorgenfrey_topology (fun U0:set => {rectangle_set U0 V|V :e Sorgenfrey_topology}) b0 Hb0B). }
  apply HexU0.
  let U0. assume HU0pair.
  claim HU0open: U0 :e Sorgenfrey_topology.
  { exact (andEL (U0 :e Sorgenfrey_topology) (b0 :e {rectangle_set U0 V|V :e Sorgenfrey_topology}) HU0pair). }
  claim Hb0fam: b0 :e {rectangle_set U0 V|V :e Sorgenfrey_topology}.
  { exact (andER (U0 :e Sorgenfrey_topology) (b0 :e {rectangle_set U0 V|V :e Sorgenfrey_topology}) HU0pair). }
  claim HexV0: exists V0 :e Sorgenfrey_topology, b0 = rectangle_set U0 V0.
  { exact (ReplE Sorgenfrey_topology (fun V0:set => rectangle_set U0 V0) b0 Hb0fam). }
  apply HexV0.
  let V0. assume HV0pair.
  claim HV0open: V0 :e Sorgenfrey_topology.
  { exact (andEL (V0 :e Sorgenfrey_topology) (b0 = rectangle_set U0 V0) HV0pair). }
  claim Hb0eq: b0 = rectangle_set U0 V0.
  { exact (andER (V0 :e Sorgenfrey_topology) (b0 = rectangle_set U0 V0) HV0pair). }
  (** p has coordinates in U0 and V0 **)
  claim HpUV: p :e setprod U0 V0.
  { rewrite <- (rectangle_set_def U0 V0).
    rewrite <- Hb0eq.
    exact Hpb0. }
  claim Hp0U0: proj0 p :e U0.
  { exact (proj0_Sigma U0 (fun _ : set => V0) p HpUV). }
  claim Hp1V0: proj1 p :e V0.
  { exact (proj1_Sigma U0 (fun _ : set => V0) p HpUV). }
  (** each nonempty open factor meets Q **)
  claim HU0ne: U0 <> Empty.
  { exact (elem_implies_nonempty U0 (proj0 p) Hp0U0). }
  claim HV0ne: V0 <> Empty.
  { exact (elem_implies_nonempty V0 (proj1 p) Hp1V0). }
  claim HQdense: closure_of Sorgenfrey_line Sorgenfrey_topology rational_numbers = Sorgenfrey_line.
  { exact Sorgenfrey_line_rationals_dense. }
  claim HU0meet: U0 :/\: rational_numbers <> Empty.
  { exact (dense_in_meets_nonempty_open rational_numbers Sorgenfrey_line Sorgenfrey_topology U0
                                       HTline HQdense HU0open HU0ne). }
  claim HV0meet: V0 :/\: rational_numbers <> Empty.
  { exact (dense_in_meets_nonempty_open rational_numbers Sorgenfrey_line Sorgenfrey_topology V0
                                       HTline HQdense HV0open HV0ne). }
  claim Hexq1: exists q1:set, q1 :e U0 :/\: rational_numbers.
  { exact (nonempty_has_element (U0 :/\: rational_numbers) HU0meet). }
  claim Hexq2: exists q2:set, q2 :e V0 :/\: rational_numbers.
  { exact (nonempty_has_element (V0 :/\: rational_numbers) HV0meet). }
  apply Hexq1.
  let q1. assume Hq1: q1 :e U0 :/\: rational_numbers.
  apply Hexq2.
  let q2. assume Hq2: q2 :e V0 :/\: rational_numbers.
  claim Hq1U0: q1 :e U0.
  { exact (binintersectE1 U0 rational_numbers q1 Hq1). }
  claim Hq1Q: q1 :e rational_numbers.
  { exact (binintersectE2 U0 rational_numbers q1 Hq1). }
  claim Hq2V0: q2 :e V0.
  { exact (binintersectE1 V0 rational_numbers q2 Hq2). }
  claim Hq2Q: q2 :e rational_numbers.
  { exact (binintersectE2 V0 rational_numbers q2 Hq2). }
  (** build a rational point in b0 ⊂ U **)
  set r := (q1,q2).
  claim HrB0: r :e b0.
  { rewrite Hb0eq.
    exact (tuple_2_rectangle_set U0 V0 q1 q2 Hq1U0 Hq2V0). }
  claim HrU: r :e U.
  { exact (Hb0subU r HrB0). }
  claim HrD: r :e D.
  { exact (tuple_2_setprod_by_pair_Sigma rational_numbers rational_numbers q1 q2 Hq1Q Hq2Q). }
  apply (elem_implies_nonempty (U :/\: D) r).
  exact (binintersectI U D r HrU HrD).
Qed.
(** LATEX VERSION: One-point sets closed predicate (T1-like helper). **)
Definition one_point_sets_closed : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\ forall x:set, x :e X -> closed_in X Tx {x}.

(** helper: metric spaces satisfy one_point_sets_closed in the metric topology **)
(** LATEX VERSION: In a metric space, singletons are closed (metric spaces are T1). **)
Theorem metric_topology_one_point_sets_closed : forall X d:set,
  metric_on X d ->
  one_point_sets_closed X (metric_topology X d).
let X d.
assume Hm: metric_on X d.
prove one_point_sets_closed X (metric_topology X d).
prove topology_on X (metric_topology X d) /\ forall x:set, x :e X -> closed_in X (metric_topology X d) {x}.
apply andI.
- exact (metric_topology_is_topology X d Hm).
- let x. assume HxX: x :e X.
  prove closed_in X (metric_topology X d) {x}.
  set U := X :\: {x}.
  claim HsingSub: {x} c= X.
  { exact (singleton_subset x X HxX). }
  claim HUsub: U c= X.
  { apply setminus_Subq. }
  (** show U is open in the metric topology by local-ball refinement **)
	  claim HUopen: U :e metric_topology X d.
	  { set B := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
	    claim HUbasis: U :e generated_topology X B.
	    { claim HUprop: forall y :e U, exists b :e B, y :e b /\ b c= U.
	      { let y. assume HyU: y :e U.
	        prove exists b :e B, y :e b /\ b c= U.
	        claim HyX: y :e X.
	        { exact (setminusE1 X {x} y HyU). }
	        claim Hynot: y /:e {x}.
	        { exact (setminusE2 X {x} y HyU). }
	        claim Hneq: ~(y = x).
	        { assume Heq: y = x.
	          apply Hynot.
	          rewrite Heq.
	          exact (SingI x). }
	        claim Hrpos: Rlt 0 (apply_fun d (y,x)).
	        { exact (metric_on_pos_of_neq X d y x Hm HyX HxX Hneq). }
	        witness (open_ball X d y (apply_fun d (y,x))).
	        apply andI.
	        - (** ball is in the basic family B **)
	          claim HrR: apply_fun d (y,x) :e R.
	          { claim Hfun: function_on d (setprod X X) R.
	            { exact (metric_on_function_on X d Hm). }
	            claim HyxIn: (y,x) :e setprod X X.
	            { exact (tuple_2_setprod_by_pair_Sigma X X y x HyX HxX). }
	            exact (Hfun (y,x) HyxIn). }
	          claim HballIn: open_ball X d y (apply_fun d (y,x)) :e {open_ball X d y r|r :e R, Rlt 0 r}.
	          { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d y r0)
	                            (apply_fun d (y,x)) HrR Hrpos). }
	          exact (famunionI X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) y
	                           (open_ball X d y (apply_fun d (y,x))) HyX HballIn).
	        - apply andI.
	          + (** y is in its own ball **)
	            exact (center_in_open_ball X d y (apply_fun d (y,x)) Hm HyX Hrpos).
	          + (** the ball avoids x, hence is included in U = X\\{x} **)
	            let z. assume Hz: z :e open_ball X d y (apply_fun d (y,x)).
	            prove z :e U.
	            claim HzX: z :e X.
	            { exact (open_ballE1 X d y (apply_fun d (y,x)) z Hz). }
	            claim Hznotsing: z /:e {x}.
	            { assume Hzsing: z :e {x}.
	              claim Hzeq: z = x.
	              { exact (SingE x z Hzsing). }
	              claim Hxball: x :e open_ball X d y (apply_fun d (y,x)).
	              { rewrite <- Hzeq at 1.
	                exact Hz. }
	              claim Hlt: Rlt (apply_fun d (y,x)) (apply_fun d (y,x)).
	              { exact (open_ballE2 X d y (apply_fun d (y,x)) x Hxball). }
	              apply FalseE.
	              exact ((not_Rlt_refl (apply_fun d (y,x)) (RltE_right 0 (apply_fun d (y,x)) Hrpos)) Hlt). }
	            exact (setminusI X {x} z HzX Hznotsing). }
	      exact (SepI (Power X)
	                  (fun U0:set => forall y :e U0, exists b :e B, y :e b /\ b c= U0)
	                  U
	                  (PowerI X U HUsub)
	                  HUprop). }
    rewrite <- (metric_topology_generated_by_balls X d Hm).
    exact HUbasis. }
  claim HclosedComp: closed_in X (metric_topology X d) (X :\: U).
  { exact (closed_of_open_complement X (metric_topology X d) U (metric_topology_is_topology X d Hm) HUopen). }
  claim Heq: X :\: U = {x}.
  { claim HUdef: U = X :\: {x}.
    { reflexivity. }
    rewrite HUdef.
    exact (setminus_setminus_eq X {x} HsingSub). }
  rewrite <- Heq.
  exact HclosedComp.
Qed.

(** from §31 Definition: regular and normal spaces **)
(** LATEX VERSION: Regular space: points and closed sets can be separated by disjoint open sets. **)
Definition regular_space : set -> set -> prop := fun X Tx =>
  one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.

(** LATEX VERSION: Normal space: disjoint closed sets can be separated by disjoint opens. **)
Definition normal_space : set -> set -> prop := fun X Tx =>
  one_point_sets_closed X Tx /\
  forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.

(** helper: normal spaces carry a topology **)
Theorem normal_space_topology_on : forall X Tx:set,
  normal_space X Tx ->
  topology_on X Tx.
let X Tx.
assume Hnorm: normal_space X Tx.
prove topology_on X Tx.
claim Hone: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
               Hnorm). }
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X -> closed_in X Tx {x})
             Hone).
Qed.

(** helper: regular spaces carry a topology **)
Theorem regular_space_topology_on : forall X Tx:set,
  regular_space X Tx ->
  topology_on X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
prove topology_on X Tx.
claim Hone: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X -> closed_in X Tx {x})
             Hone).
Qed.

(** Helper: discrete topology is normal **)
Theorem discrete_normal_space : forall X:set,
  normal_space X (discrete_topology X).
let X.
prove normal_space X (discrete_topology X).
claim HTx: topology_on X (discrete_topology X).
{ exact (discrete_topology_on X). }
prove one_point_sets_closed X (discrete_topology X) /\
  forall A B:set, closed_in X (discrete_topology X) A -> closed_in X (discrete_topology X) B -> A :/\: B = Empty ->
    exists U V:set, U :e discrete_topology X /\ V :e discrete_topology X /\ A c= U /\ B c= V /\ U :/\: V = Empty.
apply andI.
- (** one_point_sets_closed **)
  prove topology_on X (discrete_topology X) /\ forall x:set, x :e X -> closed_in X (discrete_topology X) {x}.
  apply andI.
  - exact HTx.
  - let x. assume HxX: x :e X.
    prove closed_in X (discrete_topology X) {x}.
    set U := X :\: {x}.
    claim HUsub: U c= X.
    { apply setminus_Subq. }
    claim HUopen: U :e discrete_topology X.
    { exact (discrete_open_all X U HUsub). }
    claim HclosedComp: closed_in X (discrete_topology X) (X :\: U).
    { exact (closed_of_open_complement X (discrete_topology X) U HTx HUopen). }
    claim HsingSub: {x} c= X.
    { exact (singleton_subset x X HxX). }
    claim Heq: X :\: U = {x}.
    { claim HUdef: U = X :\: {x}.
      { reflexivity. }
      rewrite HUdef.
      exact (setminus_setminus_eq X {x} HsingSub). }
    rewrite <- Heq.
    exact HclosedComp.
- (** separation of disjoint closed sets **)
  let A B.
  assume HA: closed_in X (discrete_topology X) A.
  assume HB: closed_in X (discrete_topology X) B.
  assume Hdisj: A :/\: B = Empty.
  prove exists U V:set,
    U :e discrete_topology X /\ V :e discrete_topology X /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  witness A.
  witness B.
  claim HAsub: A c= X.
  { exact (closed_in_subset X (discrete_topology X) A HA). }
  claim HBsub: B c= X.
  { exact (closed_in_subset X (discrete_topology X) B HB). }
  claim HAopen: A :e discrete_topology X.
  { exact (discrete_open_all X A HAsub). }
  claim HBopen: B :e discrete_topology X.
  { exact (discrete_open_all X B HBsub). }
  apply andI.
  - prove ((A :e discrete_topology X /\ B :e discrete_topology X) /\ A c= A) /\ B c= B.
    apply andI.
    + prove (A :e discrete_topology X /\ B :e discrete_topology X) /\ A c= A.
      apply andI.
      * apply andI.
        - exact HAopen.
        - exact HBopen.
      * exact (Subq_ref A).
    + exact (Subq_ref B).
  - exact Hdisj.
Qed.

(** from §31: regular implies Hausdorff, normal implies regular **)
(** LATEX VERSION: It is clear that a regular space is Hausdorff, and that a normal space is regular. **)
Theorem regular_space_implies_Hausdorff : forall X Tx:set,
  regular_space X Tx -> Hausdorff_space X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
prove Hausdorff_space X Tx.
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim Hsing: forall x:set, x :e X -> closed_in X Tx {x}.
{ exact (andER (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim HSepReg:
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
prove topology_on X Tx /\
      forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
        exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact HTx.
- let x1 x2.
  assume Hx1X: x1 :e X.
  assume Hx2X: x2 :e X.
  assume Hneq: x1 <> x2.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  claim Hcl: closed_in X Tx {x2}.
  { exact (Hsing x2 Hx2X). }
  claim Hx1not: x1 /:e {x2}.
  { assume Hx1in: x1 :e {x2}.
    claim Heq: x1 = x2.
    { exact (SingE x2 x1 Hx1in). }
    exact (Hneq Heq). }
  claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty.
  { exact (HSepReg x1 Hx1X {x2} Hcl Hx1not). }
  set U0 := Eps_i (fun U:set => exists V:set,
    U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty).
  claim HU0ex: exists V:set,
    U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty.
  { exact (Eps_i_ex (fun U:set => exists V:set,
      U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty) Hex). }
  set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty).
  claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ x1 :e U0 /\ {x2} c= V0 /\ U0 :/\: V0 = Empty.
  { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty)
                    HU0ex). }
  claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0).
  { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim HdisjUV: U0 :/\: V0 = Empty.
  { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0).
  { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0)
                 ({x2} c= V0)
                 H1234). }
  claim H12: (U0 :e Tx /\ V0 :e Tx).
  { exact (andEL (U0 :e Tx /\ V0 :e Tx) (x1 :e U0) H123). }
  claim HUx1: x1 :e U0.
  { exact (andER (U0 :e Tx /\ V0 :e Tx) (x1 :e U0) H123). }
  claim HVsub: {x2} c= V0.
  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) ({x2} c= V0) H1234). }
  claim Hx2V0: x2 :e V0.
  { apply HVsub. exact (SingI x2). }
  witness U0.
  witness V0.
  apply and5I.
  - exact (andEL (U0 :e Tx) (V0 :e Tx) H12).
  - exact (andER (U0 :e Tx) (V0 :e Tx) H12).
  - exact HUx1.
  - exact Hx2V0.
  - exact HdisjUV.
Qed.

Theorem normal_space_implies_regular : forall X Tx:set,
  normal_space X Tx -> regular_space X Tx.
let X Tx.
assume Hnorm: normal_space X Tx.
prove regular_space X Tx.
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
               Hnorm). }
claim Hsing: forall x:set, x :e X -> closed_in X Tx {x}.
{ exact (andER (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim HSepNorm:
  forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed X Tx)
               (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
               Hnorm). }
prove one_point_sets_closed X Tx /\
      forall x:set, x :e X ->
        forall F:set, closed_in X Tx F -> x /:e F ->
          exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- exact HT1.
- let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  claim Hclx: closed_in X Tx {x}.
  { exact (Hsing x HxX). }
  claim Hdisj: {x} :/\: F = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e {x} :/\: F.
    prove z :e Empty.
    claim Hz1: z :e {x}.
    { exact (binintersectE1 {x} F z Hz). }
    claim Hz2: z :e F.
    { exact (binintersectE2 {x} F z Hz). }
    claim Hzx: z = x.
    { exact (SingE x z Hz1). }
    claim HxinF: x :e F.
    { rewrite <- Hzx. exact Hz2. }
    apply FalseE.
    exact (HxnotF HxinF). }
  claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ {x} c= U /\ F c= V /\ U :/\: V = Empty.
  { exact (HSepNorm {x} F Hclx HFcl Hdisj). }
  set U0 := Eps_i (fun U:set => exists V:set,
    U :e Tx /\ V :e Tx /\ {x} c= U /\ F c= V /\ U :/\: V = Empty).
  claim HU0ex: exists V:set,
    U0 :e Tx /\ V :e Tx /\ {x} c= U0 /\ F c= V /\ U0 :/\: V = Empty.
  { exact (Eps_i_ex (fun U:set => exists V:set,
      U :e Tx /\ V :e Tx /\ {x} c= U /\ F c= V /\ U :/\: V = Empty) Hex). }
  set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ {x} c= U0 /\ F c= V /\ U0 :/\: V = Empty).
  claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ {x} c= U0 /\ F c= V0 /\ U0 :/\: V0 = Empty.
  { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ {x} c= U0 /\ F c= V /\ U0 :/\: V = Empty)
                    HU0ex). }
  claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0) /\ F c= V0).
  { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0) /\ F c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim HdisjUV: U0 :/\: V0 = Empty.
  { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0) /\ F c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0).
  { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0)
                 (F c= V0)
                 H1234). }
  claim H12: (U0 :e Tx /\ V0 :e Tx).
  { exact (andEL (U0 :e Tx /\ V0 :e Tx) ({x} c= U0) H123). }
  claim Hsubx: {x} c= U0.
  { exact (andER (U0 :e Tx /\ V0 :e Tx) ({x} c= U0) H123). }
  claim HFsub: F c= V0.
  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ {x} c= U0) (F c= V0) H1234). }
  claim HxU0: x :e U0.
  { apply Hsubx. exact (SingI x). }
  witness U0.
  witness V0.
  apply and5I.
  - exact (andEL (U0 :e Tx) (V0 :e Tx) H12).
  - exact (andER (U0 :e Tx) (V0 :e Tx) H12).
  - exact HxU0.
  - exact HFsub.
  - exact HdisjUV.
Qed.

(** LATEX VERSION: Families of Hausdorff/regular/completely regular spaces (helpers). **)
Definition Hausdorff_spaces_family : set -> set -> prop := fun I Xi =>
  forall i:set, i :e I -> Hausdorff_space (product_component Xi i) (product_component_topology Xi i).
Definition regular_spaces_family : set -> set -> prop := fun I Xi =>
  forall i:set, i :e I -> regular_space (product_component Xi i) (product_component_topology Xi i).
(** LATEX VERSION: Uncountable set helper. **)
Definition uncountable_set : set -> prop := fun X => ~ countable_set X.
(** LATEX VERSION: Well-ordered set helper. **)
(** NOTE: In this development, “well-ordered set with the order topology” is modeled by an ordinal carrier with order_rel given by membership; we package the needed side-conditions explicitly. **)
Definition well_ordered_set : set -> prop := fun X =>
  ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R.

(** helper: extract ordinal from well_ordered_set **)
Theorem well_ordered_set_is_ordinal : forall X:set,
  well_ordered_set X -> ordinal X.
let X.
assume Hwo: well_ordered_set X.
set T0 := ordinal X /\ X <> R.
set T1 := T0 /\ X <> rational_numbers.
set T2 := T1 /\ X <> setprod 2 omega.
set T3 := T2 /\ X <> setprod R R.
claim HT3: T3.
{ exact Hwo. }
claim HT2: T2.
{ exact (andEL T2 (X <> setprod R R) HT3). }
claim HT1: T1.
{ exact (andEL T1 (X <> setprod 2 omega) HT2). }
claim HT0: T0.
{ exact (andEL T0 (X <> rational_numbers) HT1). }
exact (andEL (ordinal X) (X <> R) HT0).
Qed.

(** helper: membership implies order_rel on well_ordered_set carriers **)
Theorem mem_implies_order_rel_well_ordered : forall X a b:set,
  well_ordered_set X -> a :e b -> order_rel X a b.
let X a b.
assume Hwo: well_ordered_set X.
assume Hab: a :e b.
prove order_rel X a b.
set T0 := ordinal X /\ X <> R.
set T1 := T0 /\ X <> rational_numbers.
set T2 := T1 /\ X <> setprod 2 omega.
set T3 := T2 /\ X <> setprod R R.
claim HT3: T3.
{ exact Hwo. }
claim HT2: T2.
{ exact (andEL T2 (X <> setprod R R) HT3). }
claim HneqRR: X <> setprod R R.
{ exact (andER T2 (X <> setprod R R) HT3). }
claim HT1: T1.
{ exact (andEL T1 (X <> setprod 2 omega) HT2). }
claim Hneq2omega: X <> setprod 2 omega.
{ exact (andER T1 (X <> setprod 2 omega) HT2). }
claim HT0: T0.
{ exact (andEL T0 (X <> rational_numbers) HT1). }
claim HneqRat: X <> rational_numbers.
{ exact (andER T0 (X <> rational_numbers) HT1). }
claim Hord: ordinal X.
{ exact (andEL (ordinal X) (X <> R) HT0). }
claim HneqR: X <> R.
{ exact (andER (ordinal X) (X <> R) HT0). }

(** unfold order_rel at the ordinal disjunct and inject into the rightmost case **)
prove (X = R /\ Rlt a b)
  \/
  (X = rational_numbers /\ Rlt a b)
  \/
  (X = omega /\ a :e b)
  \/
  (X = omega :\: {0} /\ a :e b)
  \/
  (X = setprod 2 omega /\
   exists i m j n:set,
     (i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n))))
  \/
  (X = setprod R R /\
   exists a1 a2 b1 b2:set,
     a = (a1, a2) /\ b = (b1, b2) /\
     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
  \/
  (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b).
apply orIR.
prove ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b.
set T0' := ordinal X /\ X <> R.
set T1' := T0' /\ X <> rational_numbers.
set T2' := T1' /\ X <> setprod 2 omega.
set T3' := T2' /\ X <> setprod R R.
apply andI.
- prove T3'.
  apply andI.
  - prove T2'.
    apply andI.
    - prove T1'.
      apply andI.
      - prove T0'.
        apply andI.
        - exact Hord.
        - exact HneqR.
      - exact HneqRat.
    - exact Hneq2omega.
  - exact HneqRR.
- exact Hab.
Qed.

(** helper: order_rel implies membership on well_ordered_set carriers **)
Theorem order_rel_well_ordered_implies_mem : forall X a b:set,
  well_ordered_set X -> order_rel X a b -> a :e b.
let X a b.
assume Hwo: well_ordered_set X.
assume Hrel: order_rel X a b.
prove a :e b.
set T0 := ordinal X /\ X <> R.
set T1 := T0 /\ X <> rational_numbers.
set T2 := T1 /\ X <> setprod 2 omega.
set T3 := T2 /\ X <> setprod R R.
claim HT3: T3.
{ exact Hwo. }
claim HT2: T2.
{ exact (andEL T2 (X <> setprod R R) HT3). }
claim HneqRR: X <> setprod R R.
{ exact (andER T2 (X <> setprod R R) HT3). }
claim HT1: T1.
{ exact (andEL T1 (X <> setprod 2 omega) HT2). }
claim Hneq2omega: X <> setprod 2 omega.
{ exact (andER T1 (X <> setprod 2 omega) HT2). }
claim HT0: T0.
{ exact (andEL T0 (X <> rational_numbers) HT1). }
claim HneqRat: X <> rational_numbers.
{ exact (andER T0 (X <> rational_numbers) HT1). }
claim Hord: ordinal X.
{ exact (andEL (ordinal X) (X <> R) HT0). }
claim HneqR: X <> R.
{ exact (andER (ordinal X) (X <> R) HT0). }
apply (Hrel (a :e b)).
- assume Hleft6.
  apply (Hleft6 (a :e b)).
  - assume Hleft.
    apply (Hleft (a :e b)).
    - assume Hleft2.
      apply (Hleft2 (a :e b)).
      + assume Hleft3.
        apply (Hleft3 (a :e b)).
        * assume Hleft4.
          apply (Hleft4 (a :e b)).
          - assume HA: X = R /\ Rlt a b.
            apply FalseE.
            claim Heq: X = R.
            { exact (andEL (X = R) (Rlt a b) HA). }
            exact (HneqR Heq).
          - assume HB: X = rational_numbers /\ Rlt a b.
            apply FalseE.
            claim Heq: X = rational_numbers.
            { exact (andEL (X = rational_numbers) (Rlt a b) HB). }
            exact (HneqRat Heq).
        * assume HC: X = omega /\ a :e b.
          exact (andER (X = omega) (a :e b) HC).
      + assume HD: X = omega :\: {0} /\ a :e b.
        exact (andER (X = omega :\: {0}) (a :e b) HD).
    - assume HE: X = setprod 2 omega /\
        exists i m j n:set,
          i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
          a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)).
      apply FalseE.
      claim Heq: X = setprod 2 omega.
      { exact (andEL (X = setprod 2 omega)
                    (exists i m j n:set,
                      i :e 2 /\ m :e omega /\ j :e 2 /\ n :e omega /\
                      a = (i, m) /\ b = (j, n) /\ (i :e j \/ (i = j /\ m :e n)))
                    HE). }
      exact (Hneq2omega Heq).
  - assume HF: X = setprod R R /\
      exists a1 a2 b1 b2:set,
        a = (a1, a2) /\ b = (b1, b2) /\
        (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)).
    apply FalseE.
    claim Heq: X = setprod R R.
    { exact (andEL (X = setprod R R)
                   (exists a1 a2 b1 b2:set,
                     a = (a1, a2) /\ b = (b1, b2) /\
                     (Rlt a1 b1 \/ (a1 = b1 /\ Rlt a2 b2)))
                   HF). }
    exact (HneqRR Heq).
- assume Hord: ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R /\ a :e b.
  exact (andER (ordinal X /\ X <> R /\ X <> rational_numbers /\ X <> setprod 2 omega /\ X <> setprod R R)
               (a :e b)
               Hord).
Qed.
(** LATEX VERSION: Completely regular family helper. **)
(** moved below after completely_regular_space is defined **)
(** LATEX VERSION: A family {f_a}_{a in J} separates points from closed sets: for each x0 and neighborhood U of x0, some f_a is positive at x0 and vanishes off U. **)
Definition separating_family_of_functions : set -> set -> set -> set -> prop :=
  fun X Tx F J =>
    topology_on X Tx /\
    total_function_on F J (function_space X R) /\
    (forall j:set, j :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j)) /\
    (forall x0:set, x0 :e X ->
       forall U:set, U :e Tx -> x0 :e U ->
         exists j:set, j :e J /\
           Rlt 0 (apply_fun (apply_fun F j) x0) /\
           forall x:set, x :e X :\: U -> apply_fun (apply_fun F j) x = 0).

(** helper: under T1, separating family yields point separation **)
Theorem separating_family_of_functions_separates_points : forall X Tx F J x y:set,
  topology_on X Tx ->
  one_point_sets_closed X Tx ->
  separating_family_of_functions X Tx F J ->
  x :e X -> y :e X -> x <> y ->
  exists j:set, j :e J /\ apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
let X Tx F J x y.
assume HTx: topology_on X Tx.
assume HT1: one_point_sets_closed X Tx.
assume Hsep: separating_family_of_functions X Tx F J.
assume HxX: x :e X.
assume HyX: y :e X.
assume Hxy: x <> y.
prove exists j:set, j :e J /\ apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
claim HyCl: closed_in X Tx {y}.
{ exact (andER (topology_on X Tx)
               (forall z:set, z :e X -> closed_in X Tx {z})
               HT1 y HyX). }
set U := X :\: {y}.
claim HUopen_in: open_in X Tx U.
{ claim HUdef: U = X :\: {y}.
  { reflexivity. }
  rewrite HUdef.
  exact (open_of_closed_complement X Tx {y} HyCl). }
claim HUopen: U :e Tx.
{ exact (open_in_elem X Tx U HUopen_in). }
claim HxU: x :e U.
{ apply setminusI.
  - exact HxX.
  - assume Hxy0: x :e {y}.
    claim Heq: x = y.
    { exact (SingE y x Hxy0). }
    exact (Hxy Heq). }
claim Hneigh:
  exists j:set, j :e J /\
    Rlt 0 (apply_fun (apply_fun F j) x) /\
    forall z:set, z :e X :\: U -> apply_fun (apply_fun F j) z = 0.
{ claim HsepABC:
    (topology_on X Tx /\ total_function_on F J (function_space X R)) /\
    (forall j:set, j :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j)).
  { exact (andEL ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
                  (forall j:set, j :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j)))
                 (forall x0:set, x0 :e X ->
                    forall U0:set, U0 :e Tx -> x0 :e U0 ->
                      exists j:set, j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x0) /\
                        forall z:set, z :e X :\: U0 -> apply_fun (apply_fun F j) z = 0)
                 Hsep). }
  claim HsepD:
    forall x0:set, x0 :e X ->
      forall U0:set, U0 :e Tx -> x0 :e U0 ->
        exists j:set, j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x0) /\
          forall z:set, z :e X :\: U0 -> apply_fun (apply_fun F j) z = 0.
  { exact (andER ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
                  (forall j:set, j :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j)))
                 (forall x0:set, x0 :e X ->
                    forall U0:set, U0 :e Tx -> x0 :e U0 ->
                      exists j:set, j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x0) /\
                        forall z:set, z :e X :\: U0 -> apply_fun (apply_fun F j) z = 0)
                 Hsep). }
  exact (HsepD x HxX U HUopen HxU). }
apply Hneigh.
let j. assume Hj:
  j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x) /\
    forall z:set, z :e X :\: U -> apply_fun (apply_fun F j) z = 0.
witness j.
claim Hj12: j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x).
{ exact (andEL (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
               (forall z:set, z :e X :\: U -> apply_fun (apply_fun F j) z = 0)
               Hj). }
claim Hz0:
  forall z:set, z :e X :\: U -> apply_fun (apply_fun F j) z = 0.
{ exact (andER (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
               (forall z:set, z :e X :\: U -> apply_fun (apply_fun F j) z = 0)
               Hj). }
claim HjJ: j :e J.
{ exact (andEL (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
claim Hpos: Rlt 0 (apply_fun (apply_fun F j) x).
{ exact (andER (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
  claim HyIn: y :e X :\: U.
  { claim HsingSub: {y} c= X.
    { exact (singleton_subset y X HyX). }
    claim HUdef: U = X :\: {y}.
    { reflexivity. }
    claim Heq: X :\: U = {y}.
    { rewrite HUdef.
      exact (setminus_setminus_eq X {y} HsingSub). }
    rewrite Heq.
    exact (SingI y). }
claim Hy0: apply_fun (apply_fun F j) y = 0.
{ exact (Hz0 y HyIn). }
apply andI.
- exact HjJ.
- assume Heq: apply_fun (apply_fun F j) x = apply_fun (apply_fun F j) y.
  prove False.
  claim Hx0: apply_fun (apply_fun F j) x = 0.
  { rewrite Heq.
    exact Hy0. }
  claim Hpos0: Rlt 0 0.
  { rewrite <- Hx0 at 2.
    exact Hpos. }
  exact ((not_Rlt_refl 0 real_0) Hpos0).
Qed.

(** helper: diagonal map induced by an indexed family of functions **)
Definition diagonal_map : set -> set -> set -> set := fun X F J =>
  graph X (fun x:set => graph J (fun j:set => apply_fun (apply_fun F j) x)).

(** helper: evaluate a diagonal map at a coordinate **)
Theorem diagonal_map_coord_apply : forall X F J x i:set,
  x :e X -> i :e J ->
  apply_fun (apply_fun (diagonal_map X F J) x) i = apply_fun (apply_fun F i) x.
let X F J x i.
assume HxX: x :e X.
assume HiJ: i :e J.
claim HdiagDef: diagonal_map X F J =
  graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
{ reflexivity. }
rewrite HdiagDef.
rewrite (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX).
rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
reflexivity.
Qed.
(** LATEX VERSION: Embedding predicate. **)
(** FIXED: embedding_of requires f:X->Y is continuous, and is a homeomorphism onto its image with the subspace topology. **) 
Definition embedding_of : set -> set -> set -> set -> set -> prop := fun X Tx Y Ty f =>
  continuous_map X Tx Y Ty f /\
  homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f.

(** Helper: extract continuous_map from embedding_of **)
Theorem embedding_of_continuous : forall X Tx Y Ty f:set,
  embedding_of X Tx Y Ty f -> continuous_map X Tx Y Ty f.
let X Tx Y Ty f.
assume H: embedding_of X Tx Y Ty f.
claim HdefEmb: embedding_of X Tx Y Ty f =
  (continuous_map X Tx Y Ty f /\
   homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f).
{ reflexivity. }
claim Hpair: continuous_map X Tx Y Ty f /\
  homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f.
{ rewrite <- HdefEmb.
  exact H. }
exact (andEL (continuous_map X Tx Y Ty f)
             (homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f)
             Hpair).
Qed.

(** Helper: extract homeomorphism onto image from embedding_of **)
Theorem embedding_of_homeomorphism : forall X Tx Y Ty f:set,
  embedding_of X Tx Y Ty f ->
  homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f.
let X Tx Y Ty f.
assume H: embedding_of X Tx Y Ty f.
claim HdefEmb: embedding_of X Tx Y Ty f =
  (continuous_map X Tx Y Ty f /\
   homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f).
{ reflexivity. }
claim Hpair: continuous_map X Tx Y Ty f /\
  homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f.
{ rewrite <- HdefEmb.
  exact H. }
exact (andER (continuous_map X Tx Y Ty f)
             (homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f)
             Hpair).
Qed.

(** helper: neighborhood refinement gives a homeomorphism onto the image **)
Theorem embedding_of_from_local_refinement : forall X Tx Y Ty f:set,
  continuous_map X Tx Y Ty f ->
  (forall x U:set, x :e X -> U :e Tx -> x :e U ->
     exists V:set, V :e Ty /\ apply_fun f x :e V /\ preimage_of X f V c= U) ->
  (forall x y:set, x :e X -> y :e X -> apply_fun f x = apply_fun f y -> x = y) ->
  embedding_of X Tx Y Ty f.
let X Tx Y Ty f.
assume Hcont: continuous_map X Tx Y Ty f.
assume Hloc:
  forall x U:set, x :e X -> U :e Tx -> x :e U ->
    exists V:set, V :e Ty /\ apply_fun f x :e V /\ preimage_of X f V c= U.
assume Hinj:
  forall x y:set, x :e X -> y :e X -> apply_fun f x = apply_fun f y -> x = y.
set Im := image_of f X.
set Tim := subspace_topology Y Ty Im.
prove embedding_of X Tx Y Ty f.
claim HdefEmb: embedding_of X Tx Y Ty f =
  (continuous_map X Tx Y Ty f /\
   homeomorphism X Tx (image_of f X) (subspace_topology Y Ty (image_of f X)) f).
{ reflexivity. }
rewrite HdefEmb.
apply andI.
- exact Hcont.
- prove homeomorphism X Tx Im Tim f.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hcont). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim HfunXY: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
claim HImsubY: Im c= Y.
{ exact (image_of_sub_codomain f X Y X HfunXY (Subq_ref X)). }
claim HimgIm: forall x:set, x :e X -> apply_fun f x :e Im.
{ let x. assume HxX: x :e X.
  exact (ReplI X (fun x0:set => apply_fun f x0) x HxX). }
claim HcontIm: continuous_map X Tx Im Tim f.
{ exact (continuous_map_range_restrict X Tx Y Ty f Im Hcont HImsubY HimgIm). }
(** define inverse g on the image using choice **)
set gx := (fun y:set => Eps_i (fun x:set => x :e X /\ apply_fun f x = y)).
set g := graph Im (fun y:set => gx y).
claim Hgfun: function_on g Im X.
{ let y. assume HyIm: y :e Im.
  rewrite (apply_fun_graph Im (fun y0:set => gx y0) y HyIm).
  claim Hex: exists x:set, x :e X /\ apply_fun f x = y.
  { apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm (exists x:set, x :e X /\ apply_fun f x = y)).
    let x. assume HxX: x :e X.
    assume Hyeq: y = apply_fun f x.
    witness x.
    apply andI.
    - exact HxX.
    - rewrite Hyeq.
      reflexivity. }
  claim Hgx: gx y :e X /\ apply_fun f (gx y) = y.
  { exact (Eps_i_ex (fun x:set => x :e X /\ apply_fun f x = y) Hex). }
  exact (andEL (gx y :e X) (apply_fun f (gx y) = y) Hgx). }
claim Hgfmap: forall y:set, y :e Im -> apply_fun f (apply_fun g y) = y.
{ let y. assume HyIm: y :e Im.
  claim Hex: exists x:set, x :e X /\ apply_fun f x = y.
  { apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm (exists x:set, x :e X /\ apply_fun f x = y)).
    let x. assume HxX: x :e X.
    assume Hyeq: y = apply_fun f x.
    witness x.
    apply andI.
    - exact HxX.
    - rewrite Hyeq.
      reflexivity. }
  claim HgyDef: apply_fun g y = gx y.
  { claim Hgdef: g = graph Im (fun y0:set => gx y0).
    { reflexivity. }
    rewrite Hgdef.
    exact (apply_fun_graph Im (fun y0:set => gx y0) y HyIm). }
  rewrite HgyDef at 1.
  claim Hgx: gx y :e X /\ apply_fun f (gx y) = y.
  { exact (Eps_i_ex (fun x:set => x :e X /\ apply_fun f x = y) Hex). }
  exact (andER (gx y :e X) (apply_fun f (gx y) = y) Hgx). }
claim Hgcont: continuous_map Im Tim X Tx g.
{ (** show preimage of any U:e Tx is open in the image subspace topology **)
  prove topology_on Im Tim /\ topology_on X Tx /\ function_on g Im X /\
        forall U:set, U :e Tx -> preimage_of Im g U :e Tim.
  apply andI.
  - apply andI.
    + apply andI.
      * exact (subspace_topology_is_topology Y Ty Im HTy HImsubY).
      * exact HTx.
    + exact Hgfun.
  - let U. assume HU: U :e Tx.
    (** build a chosen open neighborhood family over U **)
    claim HUsubX: U c= X.
    { exact (topology_elem_subset X Tx U HTx HU). }
    set pick := (fun x:set => Eps_i (fun V:set => V :e Ty /\ apply_fun f x :e V /\ preimage_of X f V c= U)).
    set pickf := graph U (fun x:set => pick x).
    set Fam := image_of pickf U.
    set VU := Union Fam.
    claim HpickTy: forall x:set, x :e U -> pick x :e Ty /\ apply_fun f x :e pick x /\ preimage_of X f (pick x) c= U.
    { let x. assume HxU: x :e U.
      claim HxX: x :e X.
      { exact (HUsubX x HxU). }
      claim HexV: exists V:set, V :e Ty /\ apply_fun f x :e V /\ preimage_of X f V c= U.
      { exact (Hloc x U HxX HU HxU). }
      exact (Eps_i_ex (fun V:set => V :e Ty /\ apply_fun f x :e V /\ preimage_of X f V c= U) HexV). }
    claim HFamPow: Fam :e Power Ty.
    { apply PowerI.
      let V. assume HVFam: V :e Fam.
      prove V :e Ty.
      apply (ReplE_impred U (fun x0:set => apply_fun pickf x0) V HVFam (V :e Ty)).
      let x. assume HxU: x :e U.
      assume HVeq: V = apply_fun pickf x.
      rewrite HVeq.
      claim Hpf: apply_fun pickf x = pick x.
      { claim Hpfdef: pickf = graph U (fun x0:set => pick x0).
        { reflexivity. }
        rewrite Hpfdef.
        exact (apply_fun_graph U (fun x0:set => pick x0) x HxU). }
      rewrite Hpf at 1.
      claim Hp12: pick x :e Ty /\ apply_fun f x :e pick x.
      { exact (andEL (pick x :e Ty /\ apply_fun f x :e pick x)
                     (preimage_of X f (pick x) c= U)
                     (HpickTy x HxU)). }
      exact (andEL (pick x :e Ty) (apply_fun f x :e pick x) Hp12). }
    claim HVUopen: VU :e Ty.
    { exact (topology_union_closed_pow Y Ty Fam HTy HFamPow). }
    (** show preimage_of Im g U = VU ∩ Im **)
    claim HpreEq: preimage_of Im g U = (VU :/\: Im).
    { apply set_ext.
      - let y. assume HyPre: y :e preimage_of Im g U.
        prove y :e VU :/\: Im.
        claim HyIm: y :e Im.
        { exact (SepE1 Im (fun y0:set => apply_fun g y0 :e U) y HyPre). }
        claim HgyU: apply_fun g y :e U.
        { exact (SepE2 Im (fun y0:set => apply_fun g y0 :e U) y HyPre). }
        apply binintersectI.
        + (** y :e VU **)
          (** y = f(g y) and g y :e U, hence y :e pick(g y) ⊆ VU **)
          claim HgyX: apply_fun g y :e X.
          { exact (Hgfun y HyIm). }
          claim HyEq: apply_fun f (apply_fun g y) = y.
          { exact (Hgfmap y HyIm). }
          set x := apply_fun g y.
          claim HxU: x :e U.
          { exact HgyU. }
          claim Hp: pick x :e Ty /\ apply_fun f x :e pick x /\ preimage_of X f (pick x) c= U.
          { exact (HpickTy x HxU). }
          claim HyInPick: y :e pick x.
          { claim Hp12: pick x :e Ty /\ apply_fun f x :e pick x.
            { exact (andEL (pick x :e Ty /\ apply_fun f x :e pick x)
                           (preimage_of X f (pick x) c= U)
                           Hp). }
            claim HfxIn: apply_fun f x :e pick x.
            { exact (andER (pick x :e Ty) (apply_fun f x :e pick x) Hp12). }
            claim HyEq2: apply_fun f x = y.
            { claim Hxdef: x = apply_fun g y.
              { reflexivity. }
              rewrite Hxdef at 1.
              exact HyEq. }
            rewrite <- HyEq2 at 1.
            exact HfxIn. }
          claim HpickInFam: pick x :e Fam.
          { claim Htmp: apply_fun pickf x :e Fam.
            { exact (ReplI U (fun x0:set => apply_fun pickf x0) x HxU). }
            claim Hpf: apply_fun pickf x = pick x.
            { claim Hpfdef: pickf = graph U (fun x0:set => pick x0).
              { reflexivity. }
              rewrite Hpfdef.
              exact (apply_fun_graph U (fun x0:set => pick x0) x HxU). }
            rewrite <- Hpf.
            exact Htmp. }
          exact (UnionI Fam y (pick x) HyInPick HpickInFam).
        + exact HyIm.
      - let y. assume HyInt: y :e VU :/\: Im.
        prove y :e preimage_of Im g U.
        claim HyVU: y :e VU.
        { exact (binintersectE1 VU Im y HyInt). }
        claim HyIm: y :e Im.
        { exact (binintersectE2 VU Im y HyInt). }
        (** y :e Union Fam gives some x :e U with y :e pick x **)
        apply (UnionE_impred Fam y HyVU (y :e preimage_of Im g U)).
        let V. assume HyV: y :e V.
        assume HVFam: V :e Fam.
        apply (ReplE_impred U (fun x0:set => apply_fun pickf x0) V HVFam (y :e preimage_of Im g U)).
        let x. assume HxU: x :e U.
        assume HVe: V = apply_fun pickf x.
        claim Hpf: apply_fun pickf x = pick x.
        { claim Hpfdef: pickf = graph U (fun x0:set => pick x0).
          { reflexivity. }
          rewrite Hpfdef.
          exact (apply_fun_graph U (fun x0:set => pick x0) x HxU). }
        claim HVe2: V = pick x.
        { rewrite HVe.
          rewrite Hpf.
          reflexivity. }
        claim Hp: pick x :e Ty /\ apply_fun f x :e pick x /\ preimage_of X f (pick x) c= U.
        { exact (HpickTy x HxU). }
        claim HpreSub: preimage_of X f (pick x) c= U.
        { exact (andER (pick x :e Ty /\ apply_fun f x :e pick x)
                       (preimage_of X f (pick x) c= U)
                       Hp). }
        (** show apply_fun g y :e U using injectivity and y in pick x **)
        claim HyPick: y :e pick x.
        { rewrite <- HVe2.
          exact HyV. }
        claim HxX: x :e X.
        { exact (HUsubX x HxU). }
        claim Hyfx: apply_fun f x :e pick x.
        { claim Hp12: pick x :e Ty /\ apply_fun f x :e pick x.
          { exact (andEL (pick x :e Ty /\ apply_fun f x :e pick x)
                         (preimage_of X f (pick x) c= U)
                         Hp). }
          exact (andER (pick x :e Ty) (apply_fun f x :e pick x) Hp12). }
        (** Use f(g y)=y and y∈pick x to get g y ∈ preimage f(pick x) ⊆ U. **)
        claim HgyX: apply_fun g y :e X.
        { exact (Hgfun y HyIm). }
        claim HyEq: apply_fun f (apply_fun g y) = y.
        { exact (Hgfmap y HyIm). }
        claim HgyPre: apply_fun g y :e preimage_of X f (pick x).
        { claim HfgyPick: apply_fun f (apply_fun g y) :e pick x.
          { rewrite HyEq.
            exact HyPick. }
          exact (SepI X (fun u:set => apply_fun f u :e pick x) (apply_fun g y) HgyX HfgyPick). }
        claim HgyU: apply_fun g y :e U.
        { exact (HpreSub (apply_fun g y) HgyPre). }
        exact (SepI Im (fun y0:set => apply_fun g y0 :e U) y HyIm HgyU).
    }
    rewrite HpreEq.
    (** VU ∩ Im is open in the subspace topology **)
    claim Hopen: open_in Im Tim (VU :/\: Im).
    { claim HcapSub: (VU :/\: Im) c= Im.
      { let z. assume Hz: z :e VU :/\: Im.
        exact (binintersectE2 VU Im z Hz). }
      claim HTimdef: Tim = subspace_topology Y Ty Im.
      { reflexivity. }
      rewrite HTimdef at 1.
      apply (iffER (open_in Im (subspace_topology Y Ty Im) (VU :/\: Im))
                   (exists V :e Ty, (VU :/\: Im) = V :/\: Im)
                   (open_in_subspace_iff Y Ty Im (VU :/\: Im) HTy HImsubY HcapSub)).
      witness VU.
      apply andI.
      - exact HVUopen.
      - reflexivity. }
    exact (open_in_elem Im Tim (VU :/\: Im) Hopen).
}
prove (continuous_map X Tx Im Tim f /\
  exists g0:set, continuous_map Im Tim X Tx g0 /\
    (forall x:set, x :e X -> apply_fun g0 (apply_fun f x) = x) /\
    (forall y:set, y :e Im -> apply_fun f (apply_fun g0 y) = y)).
apply andI.
- exact HcontIm.
- witness g.
  apply andI.
  + apply andI.
    * exact Hgcont.
    * let x. assume HxX: x :e X.
      (** g(f x) = x by injectivity **)
      claim HfxIm: apply_fun f x :e Im.
      { exact (HimgIm x HxX). }
      claim Hgf: apply_fun f (apply_fun g (apply_fun f x)) = apply_fun f x.
      { exact (Hgfmap (apply_fun f x) HfxIm). }
      claim HgxX: apply_fun g (apply_fun f x) :e X.
      { exact (Hgfun (apply_fun f x) HfxIm). }
      exact (Hinj (apply_fun g (apply_fun f x)) x HgxX HxX Hgf).
  + let y. assume HyIm: y :e Im.
    exact (Hgfmap y HyIm).
Qed.
(** LATEX VERSION: Power and unit-interval cubes helpers; metrizability predicate. **)
(** LATEX VERSION: Notation R^J for the product of copies of R with the standard topology. **)
Definition power_real : set -> set := fun J =>
  product_space J (const_space_family J R R_standard_topology).
(** LATEX VERSION: Notation [0,1]^J for the product of copies of [0,1] (subspace topology). **)
Definition unit_interval_power : set -> set := fun J =>
  product_space J (const_space_family J unit_interval unit_interval_topology).

(** helper for §34 Corollary 34.3: a normalizing map R -> [0,1] **)
(** LATEX VERSION: A continuous map psi:R-> [0,1] with psi(0)=0 and psi(1)=1 can be used to turn R-valued separators into [0,1]-valued ones. **)
Definition one_minus_fun : set :=
  graph R (fun t:set => add_SNo 1 (minus_SNo t)).

Theorem one_minus_fun_value_in_R : forall t:set,
  t :e R -> apply_fun one_minus_fun t :e R.
let t.
assume HtR: t :e R.
prove apply_fun one_minus_fun t :e R.
claim Hdef: one_minus_fun = graph R (fun t0:set => add_SNo 1 (minus_SNo t0)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => add_SNo 1 (minus_SNo t0)) t HtR).
exact (real_add_SNo 1 real_1 (minus_SNo t) (real_minus_SNo t HtR)).
Qed.

Theorem one_minus_fun_0 : apply_fun one_minus_fun 0 = 1.
prove apply_fun one_minus_fun 0 = 1.
claim H0R: 0 :e R.
{ exact real_0. }
claim Hdef: one_minus_fun = graph R (fun t0:set => add_SNo 1 (minus_SNo t0)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => add_SNo 1 (minus_SNo t0)) 0 H0R).
rewrite (minus_SNo_0).
rewrite (add_SNo_0R 1 SNo_1).
reflexivity.
Qed.

Theorem one_minus_fun_1 : apply_fun one_minus_fun 1 = 0.
prove apply_fun one_minus_fun 1 = 0.
claim H1R: 1 :e R.
{ exact real_1. }
claim Hdef: one_minus_fun = graph R (fun t0:set => add_SNo 1 (minus_SNo t0)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => add_SNo 1 (minus_SNo t0)) 1 H1R).
rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
reflexivity.
Qed.

Theorem one_minus_fun_continuous :
  continuous_map R R_standard_topology R R_standard_topology one_minus_fun.
prove continuous_map R R_standard_topology R R_standard_topology one_minus_fun.
set Tx := R_standard_topology.
set S := open_rays_subbasis R.
(** continuity via the open rays subbasis for the order topology on R **)
claim HTx: topology_on R Tx.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on one_minus_fun R R.
{ let t. assume HtR: t :e R.
  exact (one_minus_fun_value_in_R t HtR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = Tx.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- Hgen at 2.

claim Hone_app: forall t:set, t :e R -> apply_fun one_minus_fun t = add_SNo 1 (minus_SNo t).
{ let t. assume HtR: t :e R.
  claim Hdef: one_minus_fun = graph R (fun t0:set => add_SNo 1 (minus_SNo t0)).
  { reflexivity. }
  rewrite Hdef.
  rewrite (apply_fun_graph R (fun t0:set => add_SNo 1 (minus_SNo t0)) t HtR).
  reflexivity. }

claim Hflip_upper: forall a t:set,
  a :e R -> t :e R ->
  (Rlt a (add_SNo 1 (minus_SNo t)) <-> Rlt t (add_SNo 1 (minus_SNo a))).
{ let a t.
  assume HaR: a :e R.
  assume HtR: t :e R.
  prove (Rlt a (add_SNo 1 (minus_SNo t)) <-> Rlt t (add_SNo 1 (minus_SNo a))).
  apply iffI.
  - assume Hlt: Rlt a (add_SNo 1 (minus_SNo t)).
    prove Rlt t (add_SNo 1 (minus_SNo a)).
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HtS: SNo t.
    { exact (real_SNo t HtR). }
    claim HmaS: SNo (minus_SNo a).
    { exact (SNo_minus_SNo a HaS). }
    claim HmtS: SNo (minus_SNo t).
    { exact (SNo_minus_SNo t HtS). }
    claim HsumS: SNo (add_SNo 1 (minus_SNo t)).
    { exact (SNo_add_SNo 1 (minus_SNo t) SNo_1 HmtS). }
    claim HltS: a < add_SNo 1 (minus_SNo t).
    { exact (RltE_lt a (add_SNo 1 (minus_SNo t)) Hlt). }
    claim H1: add_SNo a t < add_SNo (add_SNo 1 (minus_SNo t)) t.
    { exact (add_SNo_Lt1 a t (add_SNo 1 (minus_SNo t)) HaS HtS HsumS HltS). }
    claim HeqR: add_SNo (add_SNo 1 (minus_SNo t)) t = 1.
    { rewrite <- (add_SNo_assoc 1 (minus_SNo t) t SNo_1 HmtS HtS).
      rewrite (add_SNo_minus_SNo_linv t HtS).
      exact (add_SNo_0R 1 SNo_1). }
    claim H2: add_SNo a t < 1.
    { rewrite <- HeqR.
      exact H1. }
    claim H2c: add_SNo t a < 1.
    { rewrite (add_SNo_com t a HtS HaS).
      exact H2. }
    claim Hm1S: SNo (minus_SNo a).
    { exact HmaS. }
    claim H3: add_SNo (add_SNo t a) (minus_SNo a) < add_SNo 1 (minus_SNo a).
    { exact (add_SNo_Lt1 (add_SNo t a) (minus_SNo a) 1
             (SNo_add_SNo t a HtS HaS) Hm1S SNo_1 H2c). }
    claim HeqL: add_SNo (add_SNo t a) (minus_SNo a) = t.
    { rewrite <- (add_SNo_assoc t a (minus_SNo a) HtS HaS Hm1S).
      rewrite (add_SNo_minus_SNo_rinv a HaS).
      exact (add_SNo_0R t HtS). }
    claim H4: t < add_SNo 1 (minus_SNo a).
    { rewrite <- HeqL at 1.
      exact H3. }
    claim Hflip_aR: add_SNo 1 (minus_SNo a) :e R.
    { claim HmaR: minus_SNo a :e R.
      { exact (real_minus_SNo a HaR). }
      exact (real_add_SNo 1 real_1 (minus_SNo a) HmaR). }
    exact (RltI t (add_SNo 1 (minus_SNo a)) HtR Hflip_aR H4).
  - assume Hlt: Rlt t (add_SNo 1 (minus_SNo a)).
    prove Rlt a (add_SNo 1 (minus_SNo t)).
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HtS: SNo t.
    { exact (real_SNo t HtR). }
    claim HmaS: SNo (minus_SNo a).
    { exact (SNo_minus_SNo a HaS). }
    claim HmtS: SNo (minus_SNo t).
    { exact (SNo_minus_SNo t HtS). }
    claim Hflip_aS: SNo (add_SNo 1 (minus_SNo a)).
    { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 HmaS). }
    claim HltS: t < add_SNo 1 (minus_SNo a).
    { exact (RltE_lt t (add_SNo 1 (minus_SNo a)) Hlt). }
    claim H1: add_SNo t a < add_SNo (add_SNo 1 (minus_SNo a)) a.
    { exact (add_SNo_Lt1 t a (add_SNo 1 (minus_SNo a)) HtS HaS Hflip_aS HltS). }
    claim HeqR: add_SNo (add_SNo 1 (minus_SNo a)) a = 1.
    { rewrite <- (add_SNo_assoc 1 (minus_SNo a) a SNo_1 HmaS HaS).
      rewrite (add_SNo_minus_SNo_linv a HaS).
      exact (add_SNo_0R 1 SNo_1). }
    claim H2: add_SNo t a < 1.
    { rewrite <- HeqR.
      exact H1. }
    claim H2c: add_SNo a t < 1.
    { rewrite (add_SNo_com a t HaS HtS).
      exact H2. }
    claim Hm1S: SNo (minus_SNo t).
    { exact HmtS. }
    claim H3: add_SNo (add_SNo a t) (minus_SNo t) < add_SNo 1 (minus_SNo t).
    { exact (add_SNo_Lt1 (add_SNo a t) (minus_SNo t) 1
             (SNo_add_SNo a t HaS HtS) Hm1S SNo_1 H2c). }
    claim HeqL: add_SNo (add_SNo a t) (minus_SNo t) = a.
    { rewrite <- (add_SNo_assoc a t (minus_SNo t) HaS HtS Hm1S).
      rewrite (add_SNo_minus_SNo_rinv t HtS).
      exact (add_SNo_0R a HaS). }
    claim H4: a < add_SNo 1 (minus_SNo t).
    { rewrite <- HeqL at 1.
      exact H3. }
    claim Hflip_tR: add_SNo 1 (minus_SNo t) :e R.
    { claim HmtR: minus_SNo t :e R.
      { exact (real_minus_SNo t HtR). }
      exact (real_add_SNo 1 real_1 (minus_SNo t) HmtR). }
    exact (RltI a (add_SNo 1 (minus_SNo t)) HaR Hflip_tR H4). }

claim Hflip_lower: forall t b:set,
  t :e R -> b :e R ->
  (Rlt (add_SNo 1 (minus_SNo t)) b <-> Rlt (add_SNo 1 (minus_SNo b)) t).
{ let t b.
  assume HtR: t :e R.
  assume HbR: b :e R.
  prove (Rlt (add_SNo 1 (minus_SNo t)) b <-> Rlt (add_SNo 1 (minus_SNo b)) t).
  apply iffI.
  - assume Hlt: Rlt (add_SNo 1 (minus_SNo t)) b.
    prove Rlt (add_SNo 1 (minus_SNo b)) t.
    claim HtS: SNo t.
    { exact (real_SNo t HtR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim HmtS: SNo (minus_SNo t).
    { exact (SNo_minus_SNo t HtS). }
    claim HmbS: SNo (minus_SNo b).
    { exact (SNo_minus_SNo b HbS). }
    claim HsumS: SNo (add_SNo 1 (minus_SNo t)).
    { exact (SNo_add_SNo 1 (minus_SNo t) SNo_1 HmtS). }
    claim HltS: add_SNo 1 (minus_SNo t) < b.
    { exact (RltE_lt (add_SNo 1 (minus_SNo t)) b Hlt). }
    claim H1: add_SNo (add_SNo 1 (minus_SNo t)) t < add_SNo b t.
    { exact (add_SNo_Lt1 (add_SNo 1 (minus_SNo t)) t b HsumS HtS HbS HltS). }
    claim HeqL: add_SNo (add_SNo 1 (minus_SNo t)) t = 1.
    { rewrite <- (add_SNo_assoc 1 (minus_SNo t) t SNo_1 HmtS HtS).
      rewrite (add_SNo_minus_SNo_linv t HtS).
      exact (add_SNo_0R 1 SNo_1). }
    claim H2: 1 < add_SNo b t.
    { rewrite <- HeqL at 1.
      exact H1. }
	    claim H2c: 1 < add_SNo t b.
	    { rewrite (add_SNo_com t b HtS HbS).
	      exact H2. }
    claim Hm1S: SNo (minus_SNo b).
    { exact HmbS. }
    claim H3: add_SNo 1 (minus_SNo b) < add_SNo (add_SNo t b) (minus_SNo b).
    { exact (add_SNo_Lt1 1 (minus_SNo b) (add_SNo t b)
             SNo_1 Hm1S (SNo_add_SNo t b HtS HbS) H2c). }
    claim HeqR: add_SNo (add_SNo t b) (minus_SNo b) = t.
    { rewrite <- (add_SNo_assoc t b (minus_SNo b) HtS HbS Hm1S).
      rewrite (add_SNo_minus_SNo_rinv b HbS).
      exact (add_SNo_0R t HtS). }
    claim H4: add_SNo 1 (minus_SNo b) < t.
    { rewrite <- HeqR.
      exact H3. }
    claim Hflip_bR: add_SNo 1 (minus_SNo b) :e R.
    { claim HmbR: minus_SNo b :e R.
      { exact (real_minus_SNo b HbR). }
      exact (real_add_SNo 1 real_1 (minus_SNo b) HmbR). }
    exact (RltI (add_SNo 1 (minus_SNo b)) t Hflip_bR HtR H4).
  - assume Hlt: Rlt (add_SNo 1 (minus_SNo b)) t.
    prove Rlt (add_SNo 1 (minus_SNo t)) b.
    claim HtS: SNo t.
    { exact (real_SNo t HtR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim HmtS: SNo (minus_SNo t).
    { exact (SNo_minus_SNo t HtS). }
    claim HmbS: SNo (minus_SNo b).
    { exact (SNo_minus_SNo b HbS). }
    claim HsumS: SNo (add_SNo 1 (minus_SNo b)).
    { exact (SNo_add_SNo 1 (minus_SNo b) SNo_1 HmbS). }
    claim HltS: add_SNo 1 (minus_SNo b) < t.
    { exact (RltE_lt (add_SNo 1 (minus_SNo b)) t Hlt). }
    claim H1: add_SNo (add_SNo 1 (minus_SNo b)) b < add_SNo t b.
    { exact (add_SNo_Lt1 (add_SNo 1 (minus_SNo b)) b t HsumS HbS HtS HltS). }
    claim HeqL: add_SNo (add_SNo 1 (minus_SNo b)) b = 1.
    { rewrite <- (add_SNo_assoc 1 (minus_SNo b) b SNo_1 HmbS HbS).
      rewrite (add_SNo_minus_SNo_linv b HbS).
      exact (add_SNo_0R 1 SNo_1). }
    claim H2: 1 < add_SNo t b.
    { rewrite <- HeqL at 1.
      exact H1. }
    claim H2c: 1 < add_SNo b t.
    { rewrite <- (add_SNo_com t b HtS HbS).
      exact H2. }
    claim Hm1S: SNo (minus_SNo t).
    { exact HmtS. }
    claim H3: add_SNo 1 (minus_SNo t) < add_SNo (add_SNo b t) (minus_SNo t).
    { exact (add_SNo_Lt1 1 (minus_SNo t) (add_SNo b t)
             SNo_1 Hm1S (SNo_add_SNo b t HbS HtS) H2c). }
    claim HeqR: add_SNo (add_SNo b t) (minus_SNo t) = b.
    { rewrite <- (add_SNo_assoc b t (minus_SNo t) HbS HtS Hm1S).
      rewrite (add_SNo_minus_SNo_rinv t HtS).
      exact (add_SNo_0R b HbS). }
    claim H4: add_SNo 1 (minus_SNo t) < b.
    { rewrite <- HeqR.
      exact H3. }
    claim Hflip_tR: add_SNo 1 (minus_SNo t) :e R.
    { claim HmtR: minus_SNo t :e R.
      { exact (real_minus_SNo t HtR). }
      exact (real_add_SNo 1 real_1 (minus_SNo t) HmtR). }
    exact (RltI (add_SNo 1 (minus_SNo t)) b Hflip_tR HbR H4). }

claim HpreS: forall s:set, s :e S -> preimage_of R one_minus_fun s :e Tx.
{ let s. assume HsS: s :e S.
  prove preimage_of R one_minus_fun s :e Tx.
  apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b})
                    {R}
                    s
                    (preimage_of R one_minus_fun s :e Tx)).
  - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                      :\/:
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}).
    apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}
                      s
                      (preimage_of R one_minus_fun s :e Tx)).
    + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
      claim Hex: exists a :e R, s = open_ray_upper R a.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                    s
                    Hsu). }
      apply Hex.
      let a. assume Hacore.
      apply Hacore.
      assume HaR: a :e R.
      assume Hseq: s = open_ray_upper R a.
      set c := add_SNo 1 (minus_SNo a).
      claim HcR: c :e R.
      { claim HmaR: minus_SNo a :e R.
        { exact (real_minus_SNo a HaR). }
        exact (real_add_SNo 1 real_1 (minus_SNo a) HmaR). }
      claim Hcdef: c = add_SNo 1 (minus_SNo a).
      { reflexivity. }
      claim HpreEq: preimage_of R one_minus_fun (open_ray_upper R a) = open_ray_lower R c.
      { apply set_ext.
        - let t. assume Ht: t :e preimage_of R one_minus_fun (open_ray_upper R a).
          prove t :e open_ray_lower R c.
          claim HtR: t :e R.
          { exact (SepE1 R (fun x0:set => apply_fun one_minus_fun x0 :e open_ray_upper R a) t Ht). }
          claim Himg: apply_fun one_minus_fun t :e open_ray_upper R a.
          { exact (SepE2 R (fun x0:set => apply_fun one_minus_fun x0 :e open_ray_upper R a) t Ht). }
          claim Hrel: order_rel R a (apply_fun one_minus_fun t).
          { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun one_minus_fun t) Himg). }
          claim Hrlt: Rlt a (apply_fun one_minus_fun t).
          { exact (order_rel_R_implies_Rlt a (apply_fun one_minus_fun t) Hrel). }
          claim Hrlt2: Rlt a (add_SNo 1 (minus_SNo t)).
          { rewrite <- (Hone_app t HtR).
            exact Hrlt. }
          claim Hrlt3: Rlt t (add_SNo 1 (minus_SNo a)).
          { exact (iffEL (Rlt a (add_SNo 1 (minus_SNo t)))
                        (Rlt t (add_SNo 1 (minus_SNo a)))
                        (Hflip_upper a t HaR HtR)
                        Hrlt2). }
          claim Hrlt4: Rlt t c.
          { rewrite Hcdef.
            exact Hrlt3. }
          claim Hrel4: order_rel R t c.
          { exact (Rlt_implies_order_rel_R t c Hrlt4). }
          exact (SepI R (fun x0:set => order_rel R x0 c) t HtR Hrel4).
        - let t. assume Ht: t :e open_ray_lower R c.
          prove t :e preimage_of R one_minus_fun (open_ray_upper R a).
          claim HtR: t :e R.
          { exact (SepE1 R (fun x0:set => order_rel R x0 c) t Ht). }
          claim Hrel: order_rel R t c.
          { exact (SepE2 R (fun x0:set => order_rel R x0 c) t Ht). }
          claim Hrlt: Rlt t c.
          { exact (order_rel_R_implies_Rlt t c Hrel). }
          claim Hrlt2: Rlt t (add_SNo 1 (minus_SNo a)).
          { rewrite <- Hcdef.
            exact Hrlt. }
          claim Hrlt3: Rlt a (add_SNo 1 (minus_SNo t)).
          { exact (iffER (Rlt a (add_SNo 1 (minus_SNo t)))
                        (Rlt t (add_SNo 1 (minus_SNo a)))
                        (Hflip_upper a t HaR HtR)
                        Hrlt2). }
          claim Ht0: t :e preimage_of R one_minus_fun (open_ray_upper R a).
          { claim Hpredef: preimage_of R one_minus_fun (open_ray_upper R a) =
              {x0 :e R | apply_fun one_minus_fun x0 :e open_ray_upper R a}.
            { reflexivity. }
            rewrite Hpredef.
            apply SepI.
            - exact HtR.
            - claim HimgR: apply_fun one_minus_fun t :e R.
              { exact (Hfun t HtR). }
              claim HimgEq: apply_fun one_minus_fun t = add_SNo 1 (minus_SNo t).
              { exact (Hone_app t HtR). }
              claim Hrlt4: Rlt a (apply_fun one_minus_fun t).
              { rewrite HimgEq.
                exact Hrlt3. }
              claim Hrel4: order_rel R a (apply_fun one_minus_fun t).
              { exact (Rlt_implies_order_rel_R a (apply_fun one_minus_fun t) Hrlt4). }
              exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun one_minus_fun t) HimgR Hrel4). }
          exact Ht0. }
      rewrite Hseq.
      rewrite HpreEq.
      rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_lower R c :e open_rays_subbasis R.
      { exact (open_ray_lower_in_open_rays_subbasis R c HcR). }
      exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R c) HsRay).
    + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
      claim Hex: exists b :e R, s = open_ray_lower R b.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                    s
                    Hsl). }
      apply Hex.
      let b. assume Hbcore.
      apply Hbcore.
      assume HbR: b :e R.
      assume Hseq: s = open_ray_lower R b.
      set c := add_SNo 1 (minus_SNo b).
      claim HcR: c :e R.
      { claim HmbR: minus_SNo b :e R.
        { exact (real_minus_SNo b HbR). }
        exact (real_add_SNo 1 real_1 (minus_SNo b) HmbR). }
      claim Hcdef: c = add_SNo 1 (minus_SNo b).
      { reflexivity. }
      claim HpreEq: preimage_of R one_minus_fun (open_ray_lower R b) = open_ray_upper R c.
      { apply set_ext.
        - let t. assume Ht: t :e preimage_of R one_minus_fun (open_ray_lower R b).
          prove t :e open_ray_upper R c.
          claim HtR: t :e R.
          { exact (SepE1 R (fun x0:set => apply_fun one_minus_fun x0 :e open_ray_lower R b) t Ht). }
          claim Himg: apply_fun one_minus_fun t :e open_ray_lower R b.
          { exact (SepE2 R (fun x0:set => apply_fun one_minus_fun x0 :e open_ray_lower R b) t Ht). }
          claim Hrel: order_rel R (apply_fun one_minus_fun t) b.
          { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun one_minus_fun t) Himg). }
          claim Hrlt: Rlt (apply_fun one_minus_fun t) b.
          { exact (order_rel_R_implies_Rlt (apply_fun one_minus_fun t) b Hrel). }
          claim Hrlt2: Rlt (add_SNo 1 (minus_SNo t)) b.
          { rewrite <- (Hone_app t HtR).
            exact Hrlt. }
          claim Hrlt3: Rlt (add_SNo 1 (minus_SNo b)) t.
          { exact (iffEL (Rlt (add_SNo 1 (minus_SNo t)) b)
                        (Rlt (add_SNo 1 (minus_SNo b)) t)
                        (Hflip_lower t b HtR HbR)
                        Hrlt2). }
          claim Hrlt4: Rlt c t.
          { rewrite Hcdef.
            exact Hrlt3. }
          claim Hrel4: order_rel R c t.
          { exact (Rlt_implies_order_rel_R c t Hrlt4). }
          exact (SepI R (fun x0:set => order_rel R c x0) t HtR Hrel4).
        - let t. assume Ht: t :e open_ray_upper R c.
          prove t :e preimage_of R one_minus_fun (open_ray_lower R b).
          claim HtR: t :e R.
          { exact (SepE1 R (fun x0:set => order_rel R c x0) t Ht). }
          claim Hrel: order_rel R c t.
          { exact (SepE2 R (fun x0:set => order_rel R c x0) t Ht). }
          claim Hrlt: Rlt c t.
          { exact (order_rel_R_implies_Rlt c t Hrel). }
          claim Hrlt2: Rlt (add_SNo 1 (minus_SNo b)) t.
          { rewrite <- Hcdef.
            exact Hrlt. }
          claim Hrlt3: Rlt (add_SNo 1 (minus_SNo t)) b.
          { exact (iffER (Rlt (add_SNo 1 (minus_SNo t)) b)
                        (Rlt (add_SNo 1 (minus_SNo b)) t)
                        (Hflip_lower t b HtR HbR)
                        Hrlt2). }
          claim Hpredef: preimage_of R one_minus_fun (open_ray_lower R b) =
              {x0 :e R | apply_fun one_minus_fun x0 :e open_ray_lower R b}.
          { reflexivity. }
          rewrite Hpredef.
          apply SepI.
          - exact HtR.
          - claim HimgR: apply_fun one_minus_fun t :e R.
            { exact (Hfun t HtR). }
            claim HimgEq: apply_fun one_minus_fun t = add_SNo 1 (minus_SNo t).
            { exact (Hone_app t HtR). }
            claim Hrlt4: Rlt (apply_fun one_minus_fun t) b.
            { rewrite HimgEq.
              exact Hrlt3. }
            claim Hrel4: order_rel R (apply_fun one_minus_fun t) b.
            { exact (Rlt_implies_order_rel_R (apply_fun one_minus_fun t) b Hrlt4). }
            exact (SepI R (fun x0:set => order_rel R x0 b) (apply_fun one_minus_fun t) HimgR Hrel4). }
      rewrite Hseq.
      rewrite HpreEq.
      rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_upper R c :e open_rays_subbasis R.
      { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
      exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) HsRay).
    + exact Hs0.
  - assume HsR: s :e {R}.
    claim Hseq: s = R.
    { exact (SingE R s HsR). }
    rewrite Hseq.
    claim Heq: preimage_of R one_minus_fun R = R.
    { exact (preimage_of_whole R R one_minus_fun Hfun). }
    rewrite Heq.
    exact (topology_has_X R Tx HTx).
  - exact HsS. }

exact (continuous_map_from_subbasis R Tx R S one_minus_fun HTx Hfun HS HpreS).
Qed.

(** helper: negation map on R **)
Definition neg_fun : set :=
  graph R (fun t:set => minus_SNo t).

Theorem neg_fun_value_in_R : forall t:set,
  t :e R -> apply_fun neg_fun t :e R.
let t.
assume HtR: t :e R.
prove apply_fun neg_fun t :e R.
claim Hdef: neg_fun = graph R (fun t0:set => minus_SNo t0).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => minus_SNo t0) t HtR).
exact (real_minus_SNo t HtR).
Qed.

(** helper: neg_fun is an element of function_space R R **)
(** LATEX VERSION: Negation is a function ℝ→ℝ. **)
Theorem neg_fun_in_function_space : neg_fun :e function_space R R.
set g := (fun t:set => minus_SNo t).
claim Hg: forall t:set, t :e R -> g t :e R.
{ let t. assume HtR: t :e R.
  prove g t :e R.
  exact (real_minus_SNo t HtR). }
claim Hdef: neg_fun = graph R g.
{ reflexivity. }
rewrite Hdef.
exact (graph_in_function_space R R g Hg).
Qed.

Theorem neg_fun_apply : forall t:set, t :e R ->
  apply_fun neg_fun t = minus_SNo t.
let t.
assume HtR: t :e R.
prove apply_fun neg_fun t = minus_SNo t.
claim Hdef: neg_fun = graph R (fun t0:set => minus_SNo t0).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => minus_SNo t0) t HtR).
reflexivity.
Qed.

(** helper: double negation on R, local name **)
Theorem minus_SNo_minus_SNo_R : forall t:set, t :e R -> minus_SNo (minus_SNo t) = t.
let t. assume HtR: t :e R.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HmtS: SNo (minus_SNo t).
{ exact (SNo_minus_SNo t HtS). }
claim HmmtS: SNo (minus_SNo (minus_SNo t)).
{ exact (SNo_minus_SNo (minus_SNo t) HmtS). }
claim Hinv1: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = 0.
{ exact (add_SNo_minus_SNo_linv (minus_SNo t) HmtS). }
claim Hinv2: add_SNo t (minus_SNo t) = 0.
{ exact (add_SNo_minus_SNo_rinv t HtS). }
claim Heq: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = add_SNo t (minus_SNo t).
{ rewrite Hinv1.
  rewrite <- Hinv2.
  reflexivity. }
exact (add_SNo_cancel_R (minus_SNo (minus_SNo t)) (minus_SNo t) t HmmtS HmtS HtS Heq).
Qed.

Theorem neg_fun_flip_upper : forall a t:set,
  a :e R -> t :e R ->
  (Rlt a (minus_SNo t) <-> Rlt t (minus_SNo a)).
let a t.
assume HaR: a :e R.
assume HtR: t :e R.
prove (Rlt a (minus_SNo t) <-> Rlt t (minus_SNo a)).
apply iffI.
- assume Halt: Rlt a (minus_SNo t).
  prove Rlt t (minus_SNo a).
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HmtS: SNo (minus_SNo t).
  { exact (SNo_minus_SNo t HtS). }
  claim HmaS: SNo (minus_SNo a).
  { exact (SNo_minus_SNo a HaS). }
  claim HltS: a < minus_SNo t.
  { exact (RltE_lt a (minus_SNo t) Halt). }
  claim HltRaw: minus_SNo (minus_SNo t) < minus_SNo a.
  { exact (minus_SNo_Lt_contra a (minus_SNo t) HaS HmtS HltS). }
  claim HltS2: t < minus_SNo a.
  { rewrite <- (minus_SNo_minus_SNo_R t HtR) at 1.
    exact HltRaw. }
  claim HtLt: Rlt t (minus_SNo a).
  { claim Hm_aR: minus_SNo a :e R.
    { exact (real_minus_SNo a HaR). }
    exact (RltI t (minus_SNo a) HtR Hm_aR HltS2). }
  exact HtLt.
- assume Htlt: Rlt t (minus_SNo a).
  prove Rlt a (minus_SNo t).
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HmaS: SNo (minus_SNo a).
  { exact (SNo_minus_SNo a HaS). }
  claim HmtS: SNo (minus_SNo t).
  { exact (SNo_minus_SNo t HtS). }
  claim HltS: t < minus_SNo a.
  { exact (RltE_lt t (minus_SNo a) Htlt). }
  claim HltRaw: minus_SNo (minus_SNo a) < minus_SNo t.
  { exact (minus_SNo_Lt_contra t (minus_SNo a) HtS HmaS HltS). }
  claim HltS2: a < minus_SNo t.
  { rewrite <- (minus_SNo_minus_SNo_R a HaR) at 1.
    exact HltRaw. }
  claim Hm_tR: minus_SNo t :e R.
  { exact (real_minus_SNo t HtR). }
  exact (RltI a (minus_SNo t) HaR Hm_tR HltS2).
Qed.

Theorem neg_fun_flip_lower : forall t b:set,
  t :e R -> b :e R ->
  (Rlt (minus_SNo t) b <-> Rlt (minus_SNo b) t).
let t b.
assume HtR: t :e R.
assume HbR: b :e R.
prove (Rlt (minus_SNo t) b <-> Rlt (minus_SNo b) t).
apply iffI.
- assume Hlt: Rlt (minus_SNo t) b.
  prove Rlt (minus_SNo b) t.
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HmtS: SNo (minus_SNo t).
  { exact (SNo_minus_SNo t HtS). }
  claim HmbS: SNo (minus_SNo b).
  { exact (SNo_minus_SNo b HbS). }
  claim HltS: minus_SNo t < b.
  { exact (RltE_lt (minus_SNo t) b Hlt). }
  claim Hraw: minus_SNo b < minus_SNo (minus_SNo t).
  { exact (minus_SNo_Lt_contra (minus_SNo t) b HmtS HbS HltS). }
  claim Hraw2: minus_SNo b < t.
  { rewrite <- (minus_SNo_minus_SNo_R t HtR).
    exact Hraw. }
  claim HmbR: minus_SNo b :e R.
  { exact (real_minus_SNo b HbR). }
  exact (RltI (minus_SNo b) t HmbR HtR Hraw2).
- assume Hlt: Rlt (minus_SNo b) t.
  prove Rlt (minus_SNo t) b.
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HmbS: SNo (minus_SNo b).
  { exact (SNo_minus_SNo b HbS). }
  claim HmtS: SNo (minus_SNo t).
  { exact (SNo_minus_SNo t HtS). }
  claim HltS: minus_SNo b < t.
  { exact (RltE_lt (minus_SNo b) t Hlt). }
  claim Hraw: minus_SNo t < minus_SNo (minus_SNo b).
  { exact (minus_SNo_Lt_contra (minus_SNo b) t HmbS HtS HltS). }
  claim Hraw2: minus_SNo t < b.
  { rewrite <- (minus_SNo_minus_SNo_R b HbR).
    exact Hraw. }
  claim HmtR: minus_SNo t :e R.
  { exact (real_minus_SNo t HtR). }
  exact (RltI (minus_SNo t) b HmtR HbR Hraw2).
Qed.

Theorem preimage_neg_fun_open_ray_upper : forall a:set,
  a :e R ->
  preimage_of R neg_fun (open_ray_upper R a) = open_ray_lower R (minus_SNo a).
let a.
assume HaR: a :e R.
prove preimage_of R neg_fun (open_ray_upper R a) = open_ray_lower R (minus_SNo a).
apply set_ext.
- let t. assume Ht: t :e preimage_of R neg_fun (open_ray_upper R a).
  prove t :e open_ray_lower R (minus_SNo a).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => apply_fun neg_fun x0 :e open_ray_upper R a) t Ht). }
  claim Himg: apply_fun neg_fun t :e open_ray_upper R a.
  { exact (SepE2 R (fun x0:set => apply_fun neg_fun x0 :e open_ray_upper R a) t Ht). }
  claim Hrel: order_rel R a (apply_fun neg_fun t).
  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun neg_fun t) Himg). }
  claim Halt: Rlt a (apply_fun neg_fun t).
  { exact (order_rel_R_implies_Rlt a (apply_fun neg_fun t) Hrel). }
  claim HimgEq: apply_fun neg_fun t = minus_SNo t.
  { exact (neg_fun_apply t HtR). }
  claim Halt2: Rlt a (minus_SNo t).
  { rewrite <- HimgEq.
    exact Halt. }
  claim Htlt: Rlt t (minus_SNo a).
  { exact (iffEL (Rlt a (minus_SNo t)) (Rlt t (minus_SNo a))
           (neg_fun_flip_upper a t HaR HtR) Halt2). }
  claim Hrel2: order_rel R t (minus_SNo a).
  { exact (Rlt_implies_order_rel_R t (minus_SNo a) Htlt). }
  claim HmaR: minus_SNo a :e R.
  { exact (real_minus_SNo a HaR). }
  exact (SepI R (fun x0:set => order_rel R x0 (minus_SNo a)) t HtR Hrel2).
- let t. assume Ht: t :e open_ray_lower R (minus_SNo a).
  prove t :e preimage_of R neg_fun (open_ray_upper R a).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R x0 (minus_SNo a)) t Ht). }
  claim Hrel: order_rel R t (minus_SNo a).
  { exact (SepE2 R (fun x0:set => order_rel R x0 (minus_SNo a)) t Ht). }
  claim Htlt: Rlt t (minus_SNo a).
  { exact (order_rel_R_implies_Rlt t (minus_SNo a) Hrel). }
  claim Halt2: Rlt a (minus_SNo t).
  { exact (iffER (Rlt a (minus_SNo t)) (Rlt t (minus_SNo a))
           (neg_fun_flip_upper a t HaR HtR) Htlt). }
  claim Hpredef: preimage_of R neg_fun (open_ray_upper R a) =
    {x0 :e R | apply_fun neg_fun x0 :e open_ray_upper R a}.
  { reflexivity. }
  rewrite Hpredef.
  apply SepI.
  - exact HtR.
  - claim HimgR: apply_fun neg_fun t :e R.
    { exact (neg_fun_value_in_R t HtR). }
    claim HimgEq: apply_fun neg_fun t = minus_SNo t.
    { exact (neg_fun_apply t HtR). }
    claim Halt: Rlt a (apply_fun neg_fun t).
    { rewrite HimgEq.
      exact Halt2. }
    claim Hrel2: order_rel R a (apply_fun neg_fun t).
    { exact (Rlt_implies_order_rel_R a (apply_fun neg_fun t) Halt). }
    exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun neg_fun t) HimgR Hrel2).
Qed.

Theorem preimage_neg_fun_open_ray_lower : forall b:set,
  b :e R ->
  preimage_of R neg_fun (open_ray_lower R b) = open_ray_upper R (minus_SNo b).
let b.
assume HbR: b :e R.
prove preimage_of R neg_fun (open_ray_lower R b) = open_ray_upper R (minus_SNo b).
apply set_ext.
- let t. assume Ht: t :e preimage_of R neg_fun (open_ray_lower R b).
  prove t :e open_ray_upper R (minus_SNo b).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => apply_fun neg_fun x0 :e open_ray_lower R b) t Ht). }
  claim Himg: apply_fun neg_fun t :e open_ray_lower R b.
  { exact (SepE2 R (fun x0:set => apply_fun neg_fun x0 :e open_ray_lower R b) t Ht). }
  claim Hrel: order_rel R (apply_fun neg_fun t) b.
  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun neg_fun t) Himg). }
  claim Htlt: Rlt (apply_fun neg_fun t) b.
  { exact (order_rel_R_implies_Rlt (apply_fun neg_fun t) b Hrel). }
  claim HimgEq: apply_fun neg_fun t = minus_SNo t.
  { exact (neg_fun_apply t HtR). }
  claim Htlt2: Rlt (minus_SNo t) b.
  { rewrite <- HimgEq.
    exact Htlt. }
  claim Htlt3: Rlt (minus_SNo b) t.
  { exact (iffEL (Rlt (minus_SNo t) b) (Rlt (minus_SNo b) t)
           (neg_fun_flip_lower t b HtR HbR) Htlt2). }
  claim Hrel2: order_rel R (minus_SNo b) t.
  { exact (Rlt_implies_order_rel_R (minus_SNo b) t Htlt3). }
  claim HmbR: minus_SNo b :e R.
  { exact (real_minus_SNo b HbR). }
  exact (SepI R (fun x0:set => order_rel R (minus_SNo b) x0) t HtR Hrel2).
- let t. assume Ht: t :e open_ray_upper R (minus_SNo b).
  prove t :e preimage_of R neg_fun (open_ray_lower R b).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R (minus_SNo b) x0) t Ht). }
  claim Hrel: order_rel R (minus_SNo b) t.
  { exact (SepE2 R (fun x0:set => order_rel R (minus_SNo b) x0) t Ht). }
  claim Htlt: Rlt (minus_SNo b) t.
  { exact (order_rel_R_implies_Rlt (minus_SNo b) t Hrel). }
  claim Htlt2: Rlt (minus_SNo t) b.
  { exact (iffER (Rlt (minus_SNo t) b) (Rlt (minus_SNo b) t)
           (neg_fun_flip_lower t b HtR HbR) Htlt). }
  claim Hpredef: preimage_of R neg_fun (open_ray_lower R b) =
    {x0 :e R | apply_fun neg_fun x0 :e open_ray_lower R b}.
  { reflexivity. }
  rewrite Hpredef.
  apply SepI.
  - exact HtR.
  - claim HimgR: apply_fun neg_fun t :e R.
    { exact (neg_fun_value_in_R t HtR). }
    claim HimgEq: apply_fun neg_fun t = minus_SNo t.
    { exact (neg_fun_apply t HtR). }
    claim Htlt3: Rlt (apply_fun neg_fun t) b.
    { rewrite HimgEq.
      exact Htlt2. }
    claim Hrel2: order_rel R (apply_fun neg_fun t) b.
    { exact (Rlt_implies_order_rel_R (apply_fun neg_fun t) b Htlt3). }
    exact (SepI R (fun x0:set => order_rel R x0 b) (apply_fun neg_fun t) HimgR Hrel2).
Qed.

Theorem neg_fun_continuous :
  continuous_map R R_standard_topology R R_standard_topology neg_fun.
prove continuous_map R R_standard_topology R R_standard_topology neg_fun.
set Tx := R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on R Tx.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on neg_fun R R.
{ let t. assume HtR: t :e R.
  exact (neg_fun_value_in_R t HtR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = Tx.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- Hgen at 2.

claim HpreS: forall s:set, s :e S -> preimage_of R neg_fun s :e Tx.
{ let s. assume HsS: s :e S.
  prove preimage_of R neg_fun s :e Tx.
  apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b})
                    {R}
                    s
                    (preimage_of R neg_fun s :e Tx)).
  - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                      :\/:
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}).
    apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}
                      s
                      (preimage_of R neg_fun s :e Tx)).
    + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
      claim Hex: exists a :e R, s = open_ray_upper R a.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                    s
                    Hsu). }
      apply Hex.
      let a. assume Hacore.
      apply Hacore.
      assume HaR: a :e R.
      assume Hseq: s = open_ray_upper R a.
      rewrite Hseq.
      rewrite (preimage_neg_fun_open_ray_upper a HaR).
      rewrite <- standard_topology_is_order_topology.
      claim HmaR: minus_SNo a :e R.
      { exact (real_minus_SNo a HaR). }
      claim HsRay: open_ray_lower R (minus_SNo a) :e open_rays_subbasis R.
      { exact (open_ray_lower_in_open_rays_subbasis R (minus_SNo a) HmaR). }
      exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R (minus_SNo a)) HsRay).
    + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
      claim Hex: exists b :e R, s = open_ray_lower R b.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                    s
                    Hsl). }
      apply Hex.
      let b. assume Hbcore.
      apply Hbcore.
      assume HbR: b :e R.
      assume Hseq: s = open_ray_lower R b.
      rewrite Hseq.
      rewrite (preimage_neg_fun_open_ray_lower b HbR).
      rewrite <- standard_topology_is_order_topology.
      claim HmbR: minus_SNo b :e R.
      { exact (real_minus_SNo b HbR). }
      claim HsRay: open_ray_upper R (minus_SNo b) :e open_rays_subbasis R.
      { exact (open_ray_upper_in_open_rays_subbasis R (minus_SNo b) HmbR). }
      exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R (minus_SNo b)) HsRay).
    + exact Hs0.
  - assume HsR: s :e {R}.
    claim Hseq: s = R.
    { exact (SingE R s HsR). }
    rewrite Hseq.
    claim Heq: preimage_of R neg_fun R = R.
    { exact (preimage_of_whole R R neg_fun Hfun). }
    rewrite Heq.
    exact (topology_has_X R Tx HTx).
  - exact HsS. }

exact (continuous_map_from_subbasis R Tx R S neg_fun HTx Hfun HS HpreS).
Qed.

(** helper: addition map on R×R **)
Definition add_fun_R : set :=
  graph (setprod R R) (fun p:set => add_SNo (p 0) (p 1)).

Theorem add_fun_R_value_in_R : forall p:set,
  p :e setprod R R -> apply_fun add_fun_R p :e R.
let p.
assume HpRR: p :e setprod R R.
prove apply_fun add_fun_R p :e R.
claim Hp0R: p 0 :e R.
{ exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
claim Hp1R: p 1 :e R.
{ exact (ap1_Sigma R (fun _ : set => R) p HpRR). }
claim Hdef: add_fun_R = graph (setprod R R) (fun p0:set => add_SNo (p0 0) (p0 1)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph (setprod R R) (fun p0:set => add_SNo (p0 0) (p0 1)) p HpRR).
exact (real_add_SNo (p 0) Hp0R (p 1) Hp1R).
Qed.

(** helper: add_fun_R is an element of function_space (R×R) R **)
(** LATEX VERSION: Addition is a function (R×R)→R. **)
Theorem add_fun_R_in_function_space : add_fun_R :e function_space (setprod R R) R.
set g := (fun p:set => add_SNo (p 0) (p 1)).
claim Hg: forall p:set, p :e setprod R R -> g p :e R.
{ let p. assume HpRR: p :e setprod R R.
  prove g p :e R.
  claim Hp0R: p 0 :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpRR). }
  claim Hp1R: p 1 :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpRR). }
  exact (real_add_SNo (p 0) Hp0R (p 1) Hp1R). }
claim Hdef: add_fun_R = graph (setprod R R) g.
{ reflexivity. }
rewrite Hdef.
exact (graph_in_function_space (setprod R R) R g Hg).
Qed.

Theorem add_fun_R_apply : forall p:set,
  p :e setprod R R -> apply_fun add_fun_R p = add_SNo (p 0) (p 1).
let p.
assume HpRR: p :e setprod R R.
prove apply_fun add_fun_R p = add_SNo (p 0) (p 1).
claim Hdef: add_fun_R = graph (setprod R R) (fun p0:set => add_SNo (p0 0) (p0 1)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph (setprod R R) (fun p0:set => add_SNo (p0 0) (p0 1)) p HpRR).
reflexivity.
Qed.

Theorem preimage_add_fun_R_open_ray_upper_in_product_topology : forall a:set,
  a :e R ->
  preimage_of (setprod R R) add_fun_R (open_ray_upper R a) :e
    (product_topology R R_standard_topology R R_standard_topology).
let a.
assume HaR: a :e R.
prove preimage_of (setprod R R) add_fun_R (open_ray_upper R a) :e
  (product_topology R R_standard_topology R R_standard_topology).
set Tx := product_topology R R_standard_topology R R_standard_topology.
set B := product_subbasis R R_standard_topology R R_standard_topology.
set W := preimage_of (setprod R R) add_fun_R (open_ray_upper R a).
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim HdefT: Tx = generated_topology (setprod R R) B.
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod R R) B =
  {U :e Power (setprod R R) | forall p :e U, exists b :e B, p :e b /\ b c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod R R))
  (fun U:set => forall p :e U, exists b :e B, p :e b /\ b c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_upper R a) p Hp).
- let p. assume Hp: p :e W.
  prove exists b :e B, p :e b /\ b c= W.
  claim HpDom: p :e setprod R R.
  { exact (SepE1 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_upper R a) p Hp). }
  claim Hp0R: p 0 :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpDom). }
  claim Hp1R: p 1 :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpDom). }
  claim Himg: apply_fun add_fun_R p :e open_ray_upper R a.
  { exact (SepE2 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_upper R a) p Hp). }
  claim Hrel: order_rel R a (apply_fun add_fun_R p).
  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun add_fun_R p) Himg). }
  claim Halt: Rlt a (apply_fun add_fun_R p).
  { exact (order_rel_R_implies_Rlt a (apply_fun add_fun_R p) Hrel). }
  claim Hexdelta:
    exists delta:set, delta :e R /\ Rlt 0 delta /\
      rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                    (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) c= W.
  { set s := apply_fun add_fun_R p.
    set diff := add_SNo s (minus_SNo a).
    claim HsR: s :e R.
    { exact (add_fun_R_value_in_R p HpDom). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HsS: SNo s.
    { exact (real_SNo s HsR). }
    claim HdiffR: diff :e R.
    { exact (real_add_SNo s HsR (minus_SNo a) (real_minus_SNo a HaR)). }
    claim HdiffPos: Rlt 0 diff.
    { exact (Rlt_0_diff_of_lt a s Halt). }
    claim HexN: exists N :e omega, eps_ N < diff.
    { exact (exists_eps_lt_pos_Euclid diff HdiffR HdiffPos). }
    apply HexN.
    let N. assume HNpair.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega) (eps_ N < diff) HNpair). }
    claim HepsNltDiff: eps_ N < diff.
    { exact (andER (N :e omega) (eps_ N < diff) HNpair). }
    claim HNnat: nat_p N.
    { exact (omega_nat_p N HNomega). }
    claim HsuccOmega: ordsucc N :e omega.
    { exact (omega_ordsucc N HNomega). }
    set delta := eps_ (ordsucc N).
    witness delta.
    apply andI.
    - prove delta :e R /\ Rlt 0 delta.
      apply andI.
      + prove delta :e R.
        exact (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)).
      + prove Rlt 0 delta.
        claim HdeltaS: SNo delta.
        { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
        claim HdeltaPosS: 0 < delta.
        { exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
        claim HdeltaR: delta :e R.
        { exact (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
        exact (RltI 0 delta real_0 HdeltaR HdeltaPosS).
    - prove rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                          (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) c= W.
      let q. assume Hq: q :e rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                                           (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))).
      prove q :e W.
      claim Hq0U: q 0 :e open_ray_upper R (add_SNo (p 0) (minus_SNo delta)).
      { exact (ap0_Sigma (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                         (fun _ : set => open_ray_upper R (add_SNo (p 1) (minus_SNo delta)))
                         q
                         Hq). }
      claim Hq1V: q 1 :e open_ray_upper R (add_SNo (p 1) (minus_SNo delta)).
      { exact (ap1_Sigma (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                         (fun _ : set => open_ray_upper R (add_SNo (p 1) (minus_SNo delta)))
                         q
                         Hq). }
      claim Hq0R: q 0 :e R.
      { exact (SepE1 R (fun x:set => order_rel R (add_SNo (p 0) (minus_SNo delta)) x) (q 0) Hq0U). }
      claim Hq1R: q 1 :e R.
      { exact (SepE1 R (fun x:set => order_rel R (add_SNo (p 1) (minus_SNo delta)) x) (q 1) Hq1V). }
      claim Hq0rel: order_rel R (add_SNo (p 0) (minus_SNo delta)) (q 0).
      { exact (SepE2 R (fun x:set => order_rel R (add_SNo (p 0) (minus_SNo delta)) x) (q 0) Hq0U). }
      claim Hq1rel: order_rel R (add_SNo (p 1) (minus_SNo delta)) (q 1).
      { exact (SepE2 R (fun x:set => order_rel R (add_SNo (p 1) (minus_SNo delta)) x) (q 1) Hq1V). }
      claim Hq0lt: Rlt (add_SNo (p 0) (minus_SNo delta)) (q 0).
      { exact (order_rel_R_implies_Rlt (add_SNo (p 0) (minus_SNo delta)) (q 0) Hq0rel). }
      claim Hq1lt: Rlt (add_SNo (p 1) (minus_SNo delta)) (q 1).
      { exact (order_rel_R_implies_Rlt (add_SNo (p 1) (minus_SNo delta)) (q 1) Hq1rel). }
      claim Hp0S: SNo (p 0).
      { exact (real_SNo (p 0) Hp0R). }
      claim Hp1S: SNo (p 1).
      { exact (real_SNo (p 1) Hp1R). }
      claim HdeltaS: SNo delta.
      { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
      claim HepsNS: SNo (eps_ N).
      { exact (SNo_eps_ N HNomega). }
      claim Hq0S: SNo (q 0).
      { exact (real_SNo (q 0) Hq0R). }
      claim Hq1S: SNo (q 1).
      { exact (real_SNo (q 1) Hq1R). }
      claim Hp0mD_S: SNo (add_SNo (p 0) (minus_SNo delta)).
      { exact (SNo_add_SNo (p 0) (minus_SNo delta) Hp0S (SNo_minus_SNo delta HdeltaS)). }
      claim Hp1mD_S: SNo (add_SNo (p 1) (minus_SNo delta)).
      { exact (SNo_add_SNo (p 1) (minus_SNo delta) Hp1S (SNo_minus_SNo delta HdeltaS)). }
      claim Hq0ltS: add_SNo (p 0) (minus_SNo delta) < q 0.
      { exact (RltE_lt (add_SNo (p 0) (minus_SNo delta)) (q 0) Hq0lt). }
      claim Hq1ltS: add_SNo (p 1) (minus_SNo delta) < q 1.
      { exact (RltE_lt (add_SNo (p 1) (minus_SNo delta)) (q 1) Hq1lt). }
      claim Hq0plusDlt: p 0 < add_SNo (q 0) delta.
      { claim Htmp: add_SNo delta (add_SNo (p 0) (minus_SNo delta)) < add_SNo delta (q 0).
        { exact (add_SNo_Lt2 delta (add_SNo (p 0) (minus_SNo delta)) (q 0)
                 HdeltaS Hp0mD_S Hq0S Hq0ltS). }
        claim HlhsEq: add_SNo delta (add_SNo (p 0) (minus_SNo delta)) = p 0.
        { claim Ht1: add_SNo delta (add_SNo (p 0) (minus_SNo delta))
                   = add_SNo (add_SNo delta (p 0)) (minus_SNo delta).
          { exact (add_SNo_assoc delta (p 0) (minus_SNo delta) HdeltaS Hp0S (SNo_minus_SNo delta HdeltaS)). }
          rewrite Ht1.
          claim Ht2: add_SNo (add_SNo delta (p 0)) (minus_SNo delta)
                   = add_SNo (p 0) (add_SNo delta (minus_SNo delta)).
          { claim Hcom: add_SNo delta (p 0) = add_SNo (p 0) delta.
            { exact (add_SNo_com delta (p 0) HdeltaS Hp0S). }
            rewrite Hcom.
            rewrite <- (add_SNo_assoc (p 0) delta (minus_SNo delta) Hp0S HdeltaS (SNo_minus_SNo delta HdeltaS)) at 1.
            reflexivity. }
          rewrite Ht2.
          rewrite (add_SNo_minus_SNo_rinv delta HdeltaS).
          exact (add_SNo_0R (p 0) Hp0S). }
        claim HrhsEq: add_SNo delta (q 0) = add_SNo (q 0) delta.
        { exact (add_SNo_com delta (q 0) HdeltaS Hq0S). }
        claim HrhsEq2: add_SNo (q 0) delta = add_SNo delta (q 0).
        { exact (add_SNo_com (q 0) delta Hq0S HdeltaS). }
        rewrite HrhsEq2.
        rewrite <- HlhsEq.
        exact Htmp. }
      claim Hq1plusDlt: p 1 < add_SNo (q 1) delta.
      { claim Htmp: add_SNo delta (add_SNo (p 1) (minus_SNo delta)) < add_SNo delta (q 1).
        { exact (add_SNo_Lt2 delta (add_SNo (p 1) (minus_SNo delta)) (q 1)
                 HdeltaS Hp1mD_S Hq1S Hq1ltS). }
        claim HlhsEq: add_SNo delta (add_SNo (p 1) (minus_SNo delta)) = p 1.
        { claim Ht1: add_SNo delta (add_SNo (p 1) (minus_SNo delta))
                   = add_SNo (add_SNo delta (p 1)) (minus_SNo delta).
          { exact (add_SNo_assoc delta (p 1) (minus_SNo delta) HdeltaS Hp1S (SNo_minus_SNo delta HdeltaS)). }
          rewrite Ht1.
          claim Ht2: add_SNo (add_SNo delta (p 1)) (minus_SNo delta)
                   = add_SNo (p 1) (add_SNo delta (minus_SNo delta)).
          { claim Hcom: add_SNo delta (p 1) = add_SNo (p 1) delta.
            { exact (add_SNo_com delta (p 1) HdeltaS Hp1S). }
            rewrite Hcom.
            rewrite <- (add_SNo_assoc (p 1) delta (minus_SNo delta) Hp1S HdeltaS (SNo_minus_SNo delta HdeltaS)) at 1.
            reflexivity. }
          rewrite Ht2.
          rewrite (add_SNo_minus_SNo_rinv delta HdeltaS).
          exact (add_SNo_0R (p 1) Hp1S). }
        claim HrhsEq: add_SNo delta (q 1) = add_SNo (q 1) delta.
        { exact (add_SNo_com delta (q 1) HdeltaS Hq1S). }
        claim HrhsEq2: add_SNo (q 1) delta = add_SNo delta (q 1).
        { exact (add_SNo_com (q 1) delta Hq1S HdeltaS). }
        rewrite HrhsEq2.
        rewrite <- HlhsEq.
        exact Htmp. }
      claim HsumPlt: add_SNo (p 0) (p 1) < add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta).
      { claim H1: add_SNo (p 0) (p 1) < add_SNo (add_SNo (q 0) delta) (p 1).
        { claim Htmp: add_SNo (p 1) (p 0) < add_SNo (p 1) (add_SNo (q 0) delta).
          { exact (add_SNo_Lt2 (p 1) (p 0) (add_SNo (q 0) delta) Hp1S Hp0S
                   (SNo_add_SNo (q 0) delta Hq0S HdeltaS)
                   (RltE_lt (p 0) (add_SNo (q 0) delta) (RltI (p 0) (add_SNo (q 0) delta) Hp0R (real_add_SNo (q 0) Hq0R delta (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega))) Hq0plusDlt))). }
          claim HcomL: add_SNo (p 1) (p 0) = add_SNo (p 0) (p 1).
          { exact (add_SNo_com (p 1) (p 0) Hp1S Hp0S). }
          claim HcomR: add_SNo (p 1) (add_SNo (q 0) delta) = add_SNo (add_SNo (q 0) delta) (p 1).
          { exact (add_SNo_com (p 1) (add_SNo (q 0) delta) Hp1S (SNo_add_SNo (q 0) delta Hq0S HdeltaS)). }
          rewrite <- HcomL.
          rewrite <- HcomR.
          exact Htmp. }
        claim H2: add_SNo (add_SNo (q 0) delta) (p 1) < add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta).
        { exact (add_SNo_Lt2 (add_SNo (q 0) delta) (p 1) (add_SNo (q 1) delta)
                 (SNo_add_SNo (q 0) delta Hq0S HdeltaS)
                 Hp1S
                 (SNo_add_SNo (q 1) delta Hq1S HdeltaS)
                 (RltE_lt (p 1) (add_SNo (q 1) delta) (RltI (p 1) (add_SNo (q 1) delta) Hp1R (real_add_SNo (q 1) Hq1R delta (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega))) Hq1plusDlt))). }
        exact (SNoLt_tra (add_SNo (p 0) (p 1))
                         (add_SNo (add_SNo (q 0) delta) (p 1))
                         (add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta))
                         (SNo_add_SNo (p 0) (p 1) Hp0S Hp1S)
                         (SNo_add_SNo (add_SNo (q 0) delta) (p 1) (SNo_add_SNo (q 0) delta Hq0S HdeltaS) Hp1S)
                         (SNo_add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta)
                                      (SNo_add_SNo (q 0) delta Hq0S HdeltaS)
                                      (SNo_add_SNo (q 1) delta Hq1S HdeltaS))
                         H1 H2). }
      claim HepsHalf: add_SNo delta delta = eps_ N.
      { rewrite (eps_ordsucc_half_add N HNnat).
        reflexivity. }
      claim HsumQeq: add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta)
                   = add_SNo (add_SNo (q 0) (q 1)) (eps_ N).
      { claim Hassoc1: add_SNo (add_SNo (q 0) delta) (add_SNo (q 1) delta)
                    = add_SNo (add_SNo (add_SNo (q 0) delta) (q 1)) delta.
        { exact (add_SNo_assoc (add_SNo (q 0) delta) (q 1) delta
                 (SNo_add_SNo (q 0) delta Hq0S HdeltaS) Hq1S HdeltaS). }
        rewrite Hassoc1.
        claim Hassoc2: add_SNo (add_SNo (add_SNo (q 0) delta) (q 1)) delta
                    = add_SNo (add_SNo (q 0) (add_SNo delta (q 1))) delta.
        { rewrite <- (add_SNo_assoc (q 0) delta (q 1) Hq0S HdeltaS Hq1S) at 1.
          reflexivity. }
        claim Hcomd: add_SNo delta (q 1) = add_SNo (q 1) delta.
        { exact (add_SNo_com delta (q 1) HdeltaS Hq1S). }
        rewrite Hassoc2.
        rewrite Hcomd.
        claim Hassoc3: add_SNo (add_SNo (q 0) (add_SNo (q 1) delta)) delta
                    = add_SNo (add_SNo (q 0) (q 1)) (add_SNo delta delta).
        { claim Hassoc4: add_SNo (q 0) (add_SNo (q 1) delta) = add_SNo (add_SNo (q 0) (q 1)) delta.
	          { exact (add_SNo_assoc (q 0) (q 1) delta Hq0S Hq1S HdeltaS). }
	          rewrite Hassoc4.
	          rewrite <- (add_SNo_assoc (add_SNo (q 0) (q 1)) delta delta
	                 (SNo_add_SNo (q 0) (q 1) Hq0S Hq1S) HdeltaS HdeltaS) at 1.
	          reflexivity. }
        rewrite Hassoc3.
        rewrite HepsHalf.
        reflexivity. }
      claim HsumPlt2: add_SNo (p 0) (p 1) < add_SNo (add_SNo (q 0) (q 1)) (eps_ N).
      { rewrite <- HsumQeq.
        exact HsumPlt. }
      claim HdiffLtS: eps_ N < diff.
      { exact HepsNltDiff. }
	      claim HaepsLtS: add_SNo a (eps_ N) < add_SNo (p 0) (p 1).
	      { claim Htmp: add_SNo a (eps_ N) < add_SNo a diff.
	        { exact (add_SNo_Lt2 a (eps_ N) diff HaS HepsNS (real_SNo diff HdiffR) HdiffLtS). }
	        claim Haeqd: add_SNo a diff = add_SNo (p 0) (p 1).
	        { claim HsEq: s = add_SNo (p 0) (p 1).
	          { exact (add_fun_R_apply p HpDom). }
	          rewrite <- HsEq at 1.
	          claim Hassoc1: add_SNo a (add_SNo s (minus_SNo a)) = add_SNo (add_SNo a s) (minus_SNo a).
	          { exact (add_SNo_assoc a s (minus_SNo a) HaS HsS (SNo_minus_SNo a HaS)). }
	          rewrite Hassoc1.
	          claim Hcom1: add_SNo a s = add_SNo s a.
	          { exact (add_SNo_com a s HaS HsS). }
	          rewrite Hcom1.
	          claim Hassoc2: add_SNo (add_SNo s a) (minus_SNo a) = add_SNo s (add_SNo a (minus_SNo a)).
	          { rewrite <- (add_SNo_assoc s a (minus_SNo a) HsS HaS (SNo_minus_SNo a HaS)) at 1.
	            reflexivity. }
	          rewrite Hassoc2.
	          rewrite (add_SNo_minus_SNo_rinv a HaS).
	          exact (add_SNo_0R s HsS). }
	        rewrite <- Haeqd.
	        exact Htmp. }
      claim HaepsLtR: Rlt (add_SNo a (eps_ N)) (add_SNo (p 0) (p 1)).
      { claim HaepsR: add_SNo a (eps_ N) :e R.
        { exact (real_add_SNo a HaR (eps_ N) (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega))). }
        claim HsumPR: add_SNo (p 0) (p 1) :e R.
        { exact (real_add_SNo (p 0) Hp0R (p 1) Hp1R). }
        exact (RltI (add_SNo a (eps_ N)) (add_SNo (p 0) (p 1)) HaepsR HsumPR HaepsLtS). }
      claim HqsumR: add_SNo (q 0) (q 1) :e R.
      { exact (real_add_SNo (q 0) Hq0R (q 1) Hq1R). }
      claim HrR: add_SNo (add_SNo (q 0) (q 1)) (eps_ N) :e R.
      { exact (real_add_SNo (add_SNo (q 0) (q 1)) HqsumR (eps_ N) (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega))). }
      claim HsumPR: add_SNo (p 0) (p 1) :e R.
      { exact (real_add_SNo (p 0) Hp0R (p 1) Hp1R). }
      claim HsumPlt2R: Rlt (add_SNo (p 0) (p 1)) (add_SNo (add_SNo (q 0) (q 1)) (eps_ N)).
      { exact (RltI (add_SNo (p 0) (p 1)) (add_SNo (add_SNo (q 0) (q 1)) (eps_ N))
               HsumPR HrR HsumPlt2). }
      claim HaepsLtQ: Rlt (add_SNo a (eps_ N)) (add_SNo (add_SNo (q 0) (q 1)) (eps_ N)).
      { exact (Rlt_tra (add_SNo a (eps_ N)) (add_SNo (p 0) (p 1)) (add_SNo (add_SNo (q 0) (q 1)) (eps_ N))
               HaepsLtR HsumPlt2R). }
      claim HaepsLtQS: add_SNo a (eps_ N) < add_SNo (add_SNo (q 0) (q 1)) (eps_ N).
      { exact (RltE_lt (add_SNo a (eps_ N)) (add_SNo (add_SNo (q 0) (q 1)) (eps_ N)) HaepsLtQ). }
      claim HcomL: add_SNo a (eps_ N) = add_SNo (eps_ N) a.
      { exact (add_SNo_com a (eps_ N) HaS HepsNS). }
      claim HcomR: add_SNo (add_SNo (q 0) (q 1)) (eps_ N) = add_SNo (eps_ N) (add_SNo (q 0) (q 1)).
      { exact (add_SNo_com (add_SNo (q 0) (q 1)) (eps_ N)
               (SNo_add_SNo (q 0) (q 1) Hq0S Hq1S) HepsNS). }
      claim HaepsLtQS2: add_SNo (eps_ N) a < add_SNo (eps_ N) (add_SNo (q 0) (q 1)).
      { rewrite <- HcomL.
        rewrite <- HcomR.
        exact HaepsLtQS. }
      claim HfinalS: a < add_SNo (q 0) (q 1).
      { exact (add_SNo_Lt2_cancel (eps_ N) a (add_SNo (q 0) (q 1)) HepsNS HaS
               (SNo_add_SNo (q 0) (q 1) Hq0S Hq1S) HaepsLtQS2). }
      claim HfinalR: Rlt a (add_SNo (q 0) (q 1)).
      { exact (RltI a (add_SNo (q 0) (q 1)) HaR HqsumR HfinalS). }
      claim HqDom: q :e setprod R R.
      { claim HUsub: open_ray_upper R (add_SNo (p 0) (minus_SNo delta)) c= R.
        { let x. assume HxU.
          exact (SepE1 R (fun t:set => order_rel R (add_SNo (p 0) (minus_SNo delta)) t) x HxU). }
        claim HVsub: open_ray_upper R (add_SNo (p 1) (minus_SNo delta)) c= R.
        { let x. assume HxV.
          exact (SepE1 R (fun t:set => order_rel R (add_SNo (p 1) (minus_SNo delta)) t) x HxV). }
        exact (setprod_Subq (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                            (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) R R HUsub HVsub q Hq). }
      claim HdefW: W = {x :e setprod R R | apply_fun add_fun_R x :e open_ray_upper R a}.
      { reflexivity. }
      rewrite HdefW.
      apply (SepI (setprod R R) (fun r0:set => apply_fun add_fun_R r0 :e open_ray_upper R a) q HqDom).
      prove apply_fun add_fun_R q :e open_ray_upper R a.
      claim HdefRay: open_ray_upper R a = {x :e R | order_rel R a x}.
      { reflexivity. }
      rewrite HdefRay.
      apply (SepI R (fun x0:set => order_rel R a x0) (apply_fun add_fun_R q) (add_fun_R_value_in_R q HqDom)).
      prove order_rel R a (apply_fun add_fun_R q).
        claim HsumEq: apply_fun add_fun_R q = add_SNo (q 0) (q 1).
        { exact (add_fun_R_apply q HqDom). }
        rewrite HsumEq.
        exact (Rlt_implies_order_rel_R a (add_SNo (q 0) (q 1)) HfinalR). }
  apply Hexdelta.
  let delta. assume Hdelta.
  claim Hdelta1: delta :e R /\ Rlt 0 delta.
  { exact (andEL (delta :e R /\ Rlt 0 delta)
                 (rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                                (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) c= W)
                 Hdelta). }
  claim Hbsub: rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                             (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) c= W.
  { exact (andER (delta :e R /\ Rlt 0 delta)
                 (rectangle_set (open_ray_upper R (add_SNo (p 0) (minus_SNo delta)))
                                (open_ray_upper R (add_SNo (p 1) (minus_SNo delta))) c= W)
                 Hdelta). }
  claim HdeltaR: delta :e R.
  { exact (andEL (delta :e R) (Rlt 0 delta) Hdelta1). }
  claim HdeltaPos: Rlt 0 delta.
  { exact (andER (delta :e R) (Rlt 0 delta) Hdelta1). }
  set U := open_ray_upper R (add_SNo (p 0) (minus_SNo delta)).
  set V := open_ray_upper R (add_SNo (p 1) (minus_SNo delta)).
  set b := rectangle_set U V.
  witness b.
  apply andI.
  - prove b :e B.
    prove b :e \/_ U0 :e R_standard_topology, {rectangle_set U0 V0|V0 :e R_standard_topology}.
	    claim HmDeltaR: minus_SNo delta :e R.
	    { exact (real_minus_SNo delta HdeltaR). }
	    claim HUargR: add_SNo (p 0) (minus_SNo delta) :e R.
	    { exact (real_add_SNo (p 0) Hp0R (minus_SNo delta) HmDeltaR). }
	    claim HVargR: add_SNo (p 1) (minus_SNo delta) :e R.
	    { exact (real_add_SNo (p 1) Hp1R (minus_SNo delta) HmDeltaR). }
    claim HUopen: U :e R_standard_topology.
    { rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_upper R (add_SNo (p 0) (minus_SNo delta)) :e open_rays_subbasis R.
      { exact (open_ray_upper_in_open_rays_subbasis R (add_SNo (p 0) (minus_SNo delta)) HUargR). }
      exact (open_rays_subbasis_sub_order_topology_R U HsRay). }
    claim HVopen: V :e R_standard_topology.
    { rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_upper R (add_SNo (p 1) (minus_SNo delta)) :e open_rays_subbasis R.
      { exact (open_ray_upper_in_open_rays_subbasis R (add_SNo (p 1) (minus_SNo delta)) HVargR). }
      exact (open_rays_subbasis_sub_order_topology_R V HsRay). }
    claim HbInFam: b :e {rectangle_set U V0|V0 :e R_standard_topology}.
    { exact (ReplI R_standard_topology (fun V0:set => rectangle_set U V0) V HVopen). }
    exact (famunionI R_standard_topology (fun U0:set => {rectangle_set U0 V0|V0 :e R_standard_topology})
           U b HUopen HbInFam).
  - apply andI.
	    + prove p :e b.
	      rewrite rectangle_set_def.
	      claim HpEta: p = (p 0, p 1).
	      { exact (setprod_eta R R p HpDom). }
	      rewrite HpEta at 1.
	      claim Hp0U: p 0 :e U.
	      { claim HdefU: U = {x :e R | order_rel R (add_SNo (p 0) (minus_SNo delta)) x}.
	        { reflexivity. }
	        rewrite HdefU.
	        apply (SepI R (fun x:set => order_rel R (add_SNo (p 0) (minus_SNo delta)) x) (p 0) Hp0R).
	        claim Hp0S: SNo (p 0).
	        { exact (real_SNo (p 0) Hp0R). }
	        claim HdeltaS: SNo delta.
	        { exact (real_SNo delta HdeltaR). }
	        claim HdeltaPosS: 0 < delta.
	        { exact (RltE_lt 0 delta HdeltaPos). }
	        claim HmDeltaLt0: minus_SNo delta < 0.
	        { rewrite <- minus_SNo_0.
	          exact (minus_SNo_Lt_contra 0 delta SNo_0 HdeltaS HdeltaPosS). }
	        claim HmDeltaS: SNo (minus_SNo delta).
	        { exact (SNo_minus_SNo delta HdeltaS). }
	        claim Hp0plus0: add_SNo (p 0) 0 = p 0.
	        { exact (add_SNo_0R (p 0) Hp0S). }
	        claim HltS': add_SNo (p 0) (minus_SNo delta) < add_SNo (p 0) 0.
	        { exact (add_SNo_Lt2 (p 0) (minus_SNo delta) 0 Hp0S HmDeltaS SNo_0 HmDeltaLt0). }
	        claim HltS: add_SNo (p 0) (minus_SNo delta) < p 0.
	        { rewrite <- Hp0plus0 at 2.
	          exact HltS'. }
	        claim HUargR2: add_SNo (p 0) (minus_SNo delta) :e R.
	        { exact (real_add_SNo (p 0) Hp0R (minus_SNo delta) (real_minus_SNo delta HdeltaR)). }
	        claim HaltR: Rlt (add_SNo (p 0) (minus_SNo delta)) (p 0).
	        { exact (RltI (add_SNo (p 0) (minus_SNo delta)) (p 0) HUargR2 Hp0R HltS). }
	        exact (Rlt_implies_order_rel_R (add_SNo (p 0) (minus_SNo delta)) (p 0) HaltR). }
	      claim Hp1V: p 1 :e V.
	      { claim HdefV: V = {x :e R | order_rel R (add_SNo (p 1) (minus_SNo delta)) x}.
	        { reflexivity. }
	        rewrite HdefV.
	        apply (SepI R (fun x:set => order_rel R (add_SNo (p 1) (minus_SNo delta)) x) (p 1) Hp1R).
	        claim Hp1S: SNo (p 1).
	        { exact (real_SNo (p 1) Hp1R). }
	        claim HdeltaS: SNo delta.
	        { exact (real_SNo delta HdeltaR). }
	        claim HdeltaPosS: 0 < delta.
	        { exact (RltE_lt 0 delta HdeltaPos). }
	        claim HmDeltaLt0: minus_SNo delta < 0.
	        { rewrite <- minus_SNo_0.
	          exact (minus_SNo_Lt_contra 0 delta SNo_0 HdeltaS HdeltaPosS). }
	        claim HmDeltaS: SNo (minus_SNo delta).
	        { exact (SNo_minus_SNo delta HdeltaS). }
	        claim Hp1plus0: add_SNo (p 1) 0 = p 1.
	        { exact (add_SNo_0R (p 1) Hp1S). }
	        claim HltS': add_SNo (p 1) (minus_SNo delta) < add_SNo (p 1) 0.
	        { exact (add_SNo_Lt2 (p 1) (minus_SNo delta) 0 Hp1S HmDeltaS SNo_0 HmDeltaLt0). }
	        claim HltS: add_SNo (p 1) (minus_SNo delta) < p 1.
	        { rewrite <- Hp1plus0 at 2.
	          exact HltS'. }
	        claim HVargR2: add_SNo (p 1) (minus_SNo delta) :e R.
	        { exact (real_add_SNo (p 1) Hp1R (minus_SNo delta) (real_minus_SNo delta HdeltaR)). }
	        claim HaltR: Rlt (add_SNo (p 1) (minus_SNo delta)) (p 1).
	        { exact (RltI (add_SNo (p 1) (minus_SNo delta)) (p 1) HVargR2 Hp1R HltS). }
	        exact (Rlt_implies_order_rel_R (add_SNo (p 1) (minus_SNo delta)) (p 1) HaltR). }
	      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1V).
	    + prove b c= W.
	      exact Hbsub.
Qed.

Theorem preimage_add_fun_R_open_ray_lower_in_product_topology : forall b:set,
  b :e R ->
  preimage_of (setprod R R) add_fun_R (open_ray_lower R b) :e
    (product_topology R R_standard_topology R R_standard_topology).
let b.
assume HbR: b :e R.
prove preimage_of (setprod R R) add_fun_R (open_ray_lower R b) :e
  (product_topology R R_standard_topology R R_standard_topology).
set Tx := product_topology R R_standard_topology R R_standard_topology.
set B := product_subbasis R R_standard_topology R R_standard_topology.
set W := preimage_of (setprod R R) add_fun_R (open_ray_lower R b).
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim HdefT: Tx = generated_topology (setprod R R) B.
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod R R) B =
  {U :e Power (setprod R R) | forall p :e U, exists b0 :e B, p :e b0 /\ b0 c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod R R))
  (fun U:set => forall p :e U, exists b0 :e B, p :e b0 /\ b0 c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_lower R b) p Hp).
- let p. assume Hp: p :e W.
  prove exists b0 :e B, p :e b0 /\ b0 c= W.
  claim HpDom: p :e setprod R R.
  { exact (SepE1 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_lower R b) p Hp). }
  claim Hp0R: p 0 :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpDom). }
  claim Hp1R: p 1 :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpDom). }
  claim Himg: apply_fun add_fun_R p :e open_ray_lower R b.
  { exact (SepE2 (setprod R R) (fun q:set => apply_fun add_fun_R q :e open_ray_lower R b) p Hp). }
  claim Hrel: order_rel R (apply_fun add_fun_R p) b.
  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun add_fun_R p) Himg). }
  claim Halt: Rlt (apply_fun add_fun_R p) b.
  { exact (order_rel_R_implies_Rlt (apply_fun add_fun_R p) b Hrel). }
	  claim Hexdelta:
	    exists delta:set, delta :e R /\ Rlt 0 delta /\
	      rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
	                    (open_ray_lower R (add_SNo (p 1) delta)) c= W.
	  { set s := apply_fun add_fun_R p.
	    set diff := add_SNo b (minus_SNo s).
	    claim HsR: s :e R.
	    { exact (add_fun_R_value_in_R p HpDom). }
	    claim HbS: SNo b.
	    { exact (real_SNo b HbR). }
	    claim HsS: SNo s.
	    { exact (real_SNo s HsR). }
	    claim HdiffR: diff :e R.
	    { exact (real_add_SNo b HbR (minus_SNo s) (real_minus_SNo s HsR)). }
	    claim HdiffPos: Rlt 0 diff.
	    { exact (Rlt_0_diff_of_lt s b Halt). }
	    claim HexN: exists N :e omega, eps_ N < diff.
	    { exact (exists_eps_lt_pos_Euclid diff HdiffR HdiffPos). }
	    apply HexN.
	    let N. assume HNpair.
	    claim HNomega: N :e omega.
	    { exact (andEL (N :e omega) (eps_ N < diff) HNpair). }
	    claim HepsNltDiff: eps_ N < diff.
	    { exact (andER (N :e omega) (eps_ N < diff) HNpair). }
	    claim HNnat: nat_p N.
	    { exact (omega_nat_p N HNomega). }
	    claim HsuccOmega: ordsucc N :e omega.
	    { exact (omega_ordsucc N HNomega). }
	    set delta := eps_ (ordsucc N).
	    witness delta.
	    apply andI.
	    - prove delta :e R /\ Rlt 0 delta.
	      apply andI.
	      + prove delta :e R.
	        exact (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)).
	      + prove Rlt 0 delta.
	        claim HdeltaS: SNo delta.
	        { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
	        claim HdeltaPosS: 0 < delta.
	        { exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
	        claim HdeltaR: delta :e R.
	        { exact (SNoS_omega_real delta (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
	        exact (RltI 0 delta real_0 HdeltaR HdeltaPosS).
	    - prove rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
	                          (open_ray_lower R (add_SNo (p 1) delta)) c= W.
	      let q. assume Hq: q :e rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
	                                           (open_ray_lower R (add_SNo (p 1) delta)).
	      prove q :e W.
	      claim Hq0U: q 0 :e open_ray_lower R (add_SNo (p 0) delta).
	      { exact (ap0_Sigma (open_ray_lower R (add_SNo (p 0) delta))
	                         (fun _ : set => open_ray_lower R (add_SNo (p 1) delta))
	                         q
	                         Hq). }
	      claim Hq1V: q 1 :e open_ray_lower R (add_SNo (p 1) delta).
	      { exact (ap1_Sigma (open_ray_lower R (add_SNo (p 0) delta))
	                         (fun _ : set => open_ray_lower R (add_SNo (p 1) delta))
	                         q
	                         Hq). }
	      claim Hq0R: q 0 :e R.
	      { exact (SepE1 R (fun x:set => order_rel R x (add_SNo (p 0) delta)) (q 0) Hq0U). }
	      claim Hq1R: q 1 :e R.
	      { exact (SepE1 R (fun x:set => order_rel R x (add_SNo (p 1) delta)) (q 1) Hq1V). }
	      claim Hq0rel: order_rel R (q 0) (add_SNo (p 0) delta).
	      { exact (SepE2 R (fun x:set => order_rel R x (add_SNo (p 0) delta)) (q 0) Hq0U). }
	      claim Hq1rel: order_rel R (q 1) (add_SNo (p 1) delta).
	      { exact (SepE2 R (fun x:set => order_rel R x (add_SNo (p 1) delta)) (q 1) Hq1V). }
	      claim Hq0lt: Rlt (q 0) (add_SNo (p 0) delta).
	      { exact (order_rel_R_implies_Rlt (q 0) (add_SNo (p 0) delta) Hq0rel). }
	      claim Hq1lt: Rlt (q 1) (add_SNo (p 1) delta).
	      { exact (order_rel_R_implies_Rlt (q 1) (add_SNo (p 1) delta) Hq1rel). }
	      claim Hp0S: SNo (p 0).
	      { exact (real_SNo (p 0) Hp0R). }
	      claim Hp1S: SNo (p 1).
	      { exact (real_SNo (p 1) Hp1R). }
	      claim Hq0S: SNo (q 0).
	      { exact (real_SNo (q 0) Hq0R). }
	      claim Hq1S: SNo (q 1).
	      { exact (real_SNo (q 1) Hq1R). }
	      claim HdeltaS: SNo delta.
	      { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
	      claim HepsNS: SNo (eps_ N).
	      { exact (SNo_eps_ N HNomega). }
	      claim Hq0ltS: q 0 < add_SNo (p 0) delta.
	      { exact (RltE_lt (q 0) (add_SNo (p 0) delta) Hq0lt). }
	      claim Hq1ltS: q 1 < add_SNo (p 1) delta.
	      { exact (RltE_lt (q 1) (add_SNo (p 1) delta) Hq1lt). }
	      claim HsumQlt: add_SNo (q 0) (q 1) < add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta).
	      { claim H1: add_SNo (q 0) (q 1) < add_SNo (add_SNo (p 0) delta) (q 1).
	        { claim Htmp: add_SNo (q 1) (q 0) < add_SNo (q 1) (add_SNo (p 0) delta).
	          { exact (add_SNo_Lt2 (q 1) (q 0) (add_SNo (p 0) delta) Hq1S Hq0S
	                   (SNo_add_SNo (p 0) delta Hp0S HdeltaS) Hq0ltS). }
	          claim HcomL: add_SNo (q 1) (q 0) = add_SNo (q 0) (q 1).
	          { exact (add_SNo_com (q 1) (q 0) Hq1S Hq0S). }
	          claim HcomR: add_SNo (q 1) (add_SNo (p 0) delta) = add_SNo (add_SNo (p 0) delta) (q 1).
	          { exact (add_SNo_com (q 1) (add_SNo (p 0) delta) Hq1S (SNo_add_SNo (p 0) delta Hp0S HdeltaS)). }
	          rewrite <- HcomL.
	          rewrite <- HcomR.
	          exact Htmp. }
	        claim H2: add_SNo (add_SNo (p 0) delta) (q 1) < add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta).
	        { exact (add_SNo_Lt2 (add_SNo (p 0) delta) (q 1) (add_SNo (p 1) delta)
	                 (SNo_add_SNo (p 0) delta Hp0S HdeltaS) Hq1S (SNo_add_SNo (p 1) delta Hp1S HdeltaS) Hq1ltS). }
	        exact (SNoLt_tra (add_SNo (q 0) (q 1))
	                         (add_SNo (add_SNo (p 0) delta) (q 1))
	                         (add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta))
	                         (SNo_add_SNo (q 0) (q 1) Hq0S Hq1S)
	                         (SNo_add_SNo (add_SNo (p 0) delta) (q 1) (SNo_add_SNo (p 0) delta Hp0S HdeltaS) Hq1S)
	                         (SNo_add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta)
	                                      (SNo_add_SNo (p 0) delta Hp0S HdeltaS)
	                                      (SNo_add_SNo (p 1) delta Hp1S HdeltaS))
	                         H1 H2). }
	      claim HepsHalf: add_SNo delta delta = eps_ N.
	      { rewrite (eps_ordsucc_half_add N HNnat).
	        reflexivity. }
	      claim HsumP: add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta) = add_SNo (add_SNo (p 0) (p 1)) (eps_ N).
	      { claim Hassoc1: add_SNo (add_SNo (p 0) delta) (add_SNo (p 1) delta)
	                    = add_SNo (add_SNo (add_SNo (p 0) delta) (p 1)) delta.
	        { exact (add_SNo_assoc (add_SNo (p 0) delta) (p 1) delta
	                 (SNo_add_SNo (p 0) delta Hp0S HdeltaS) Hp1S HdeltaS). }
	        rewrite Hassoc1.
	        claim Hassoc2: add_SNo (add_SNo (add_SNo (p 0) delta) (p 1)) delta
	                    = add_SNo (add_SNo (p 0) (add_SNo delta (p 1))) delta.
	        { rewrite <- (add_SNo_assoc (p 0) delta (p 1) Hp0S HdeltaS Hp1S) at 1.
	          reflexivity. }
	        claim Hcomd: add_SNo delta (p 1) = add_SNo (p 1) delta.
	        { exact (add_SNo_com delta (p 1) HdeltaS Hp1S). }
	        rewrite Hassoc2.
	        rewrite Hcomd.
	        claim Hassoc3: add_SNo (add_SNo (p 0) (add_SNo (p 1) delta)) delta
	                    = add_SNo (add_SNo (p 0) (p 1)) (add_SNo delta delta).
	        { claim Hassoc4: add_SNo (p 0) (add_SNo (p 1) delta) = add_SNo (add_SNo (p 0) (p 1)) delta.
	          { exact (add_SNo_assoc (p 0) (p 1) delta Hp0S Hp1S HdeltaS). }
	          rewrite Hassoc4.
	          rewrite <- (add_SNo_assoc (add_SNo (p 0) (p 1)) delta delta (SNo_add_SNo (p 0) (p 1) Hp0S Hp1S) HdeltaS HdeltaS) at 1.
	          reflexivity. }
	        rewrite Hassoc3.
	        rewrite HepsHalf.
	        reflexivity. }
		      claim HsumQlt2: add_SNo (q 0) (q 1) < add_SNo (add_SNo (p 0) (p 1)) (eps_ N).
		      { rewrite <- HsumP.
		        exact HsumQlt. }
	      claim HrR: add_SNo (add_SNo (p 0) (p 1)) (eps_ N) :e R.
	      { exact (real_add_SNo (add_SNo (p 0) (p 1)) (real_add_SNo (p 0) Hp0R (p 1) Hp1R) (eps_ N) (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega))). }
	      claim HqsumR: add_SNo (q 0) (q 1) :e R.
	      { exact (real_add_SNo (q 0) Hq0R (q 1) Hq1R). }
	      claim HsumQltR: Rlt (add_SNo (q 0) (q 1)) (add_SNo (add_SNo (p 0) (p 1)) (eps_ N)).
	      { exact (RltI (add_SNo (q 0) (q 1)) (add_SNo (add_SNo (p 0) (p 1)) (eps_ N)) HqsumR HrR HsumQlt2). }
	      claim HdiffLtS: eps_ N < diff.
	      { exact HepsNltDiff. }
	      claim HsEq: s = add_SNo (p 0) (p 1).
	      { exact (add_fun_R_apply p HpDom). }
	      claim HsepsLtS: add_SNo s (eps_ N) < b.
	      { claim Htmp: add_SNo s (eps_ N) < add_SNo s diff.
	        { exact (add_SNo_Lt2 s (eps_ N) diff HsS HepsNS (real_SNo diff HdiffR) HdiffLtS). }
	        claim HsdEq: add_SNo s diff = b.
	        { claim Hassoc1: add_SNo s (add_SNo b (minus_SNo s)) = add_SNo (add_SNo s b) (minus_SNo s).
	          { exact (add_SNo_assoc s b (minus_SNo s) HsS HbS (SNo_minus_SNo s HsS)). }
	          rewrite Hassoc1.
	          claim Hcom1: add_SNo s b = add_SNo b s.
	          { exact (add_SNo_com s b HsS HbS). }
	          rewrite Hcom1.
	          claim Hassoc2: add_SNo (add_SNo b s) (minus_SNo s) = add_SNo b (add_SNo s (minus_SNo s)).
	          { rewrite <- (add_SNo_assoc b s (minus_SNo s) HbS HsS (SNo_minus_SNo s HsS)) at 1.
	            reflexivity. }
	          rewrite Hassoc2.
	          rewrite (add_SNo_minus_SNo_rinv s HsS).
	          exact (add_SNo_0R b HbS). }
	        rewrite <- HsdEq.
	        exact Htmp. }
	      claim HsepsLtR: Rlt (add_SNo s (eps_ N)) b.
	      { claim HsepsR: add_SNo s (eps_ N) :e R.
	        { exact (real_add_SNo s HsR (eps_ N) (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega))). }
	        exact (RltI (add_SNo s (eps_ N)) b HsepsR HbR HsepsLtS). }
	      claim HsepsLtR2: Rlt (add_SNo (add_SNo (p 0) (p 1)) (eps_ N)) b.
	      { rewrite <- HsEq at 1.
	        exact HsepsLtR. }
	      claim Hfinal: Rlt (add_SNo (q 0) (q 1)) b.
	      { exact (Rlt_tra (add_SNo (q 0) (q 1)) (add_SNo (add_SNo (p 0) (p 1)) (eps_ N)) b HsumQltR HsepsLtR2). }
	      claim HqDom: q :e setprod R R.
	      { claim HUsub: open_ray_lower R (add_SNo (p 0) delta) c= R.
	        { let x. assume HxU.
	          exact (SepE1 R (fun t:set => order_rel R t (add_SNo (p 0) delta)) x HxU). }
	        claim HVsub: open_ray_lower R (add_SNo (p 1) delta) c= R.
	        { let x. assume HxV.
	          exact (SepE1 R (fun t:set => order_rel R t (add_SNo (p 1) delta)) x HxV). }
	        exact (setprod_Subq (open_ray_lower R (add_SNo (p 0) delta))
	                            (open_ray_lower R (add_SNo (p 1) delta)) R R HUsub HVsub q Hq). }
	      claim HdefW: W = {x :e setprod R R | apply_fun add_fun_R x :e open_ray_lower R b}.
	      { reflexivity. }
	      rewrite HdefW.
	      apply (SepI (setprod R R) (fun r0:set => apply_fun add_fun_R r0 :e open_ray_lower R b) q HqDom).
	      prove apply_fun add_fun_R q :e open_ray_lower R b.
	      claim HdefRay: open_ray_lower R b = {x :e R | order_rel R x b}.
	      { reflexivity. }
	      rewrite HdefRay.
	      apply (SepI R (fun x0:set => order_rel R x0 b) (apply_fun add_fun_R q) (add_fun_R_value_in_R q HqDom)).
	      prove order_rel R (apply_fun add_fun_R q) b.
	      claim HsumEq: apply_fun add_fun_R q = add_SNo (q 0) (q 1).
	      { exact (add_fun_R_apply q HqDom). }
	      rewrite HsumEq.
	      exact (Rlt_implies_order_rel_R (add_SNo (q 0) (q 1)) b Hfinal). }
  apply Hexdelta.
  let delta. assume Hdelta.
  claim Hdelta1: delta :e R /\ Rlt 0 delta.
  { exact (andEL (delta :e R /\ Rlt 0 delta)
                 (rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
                                (open_ray_lower R (add_SNo (p 1) delta)) c= W)
                 Hdelta). }
  claim Hbsub: rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
                             (open_ray_lower R (add_SNo (p 1) delta)) c= W.
  { exact (andER (delta :e R /\ Rlt 0 delta)
                 (rectangle_set (open_ray_lower R (add_SNo (p 0) delta))
                                (open_ray_lower R (add_SNo (p 1) delta)) c= W)
                 Hdelta). }
  claim HdeltaR: delta :e R.
  { exact (andEL (delta :e R) (Rlt 0 delta) Hdelta1). }
  claim HdeltaPos: Rlt 0 delta.
  { exact (andER (delta :e R) (Rlt 0 delta) Hdelta1). }
  set U := open_ray_lower R (add_SNo (p 0) delta).
  set V := open_ray_lower R (add_SNo (p 1) delta).
  set b0 := rectangle_set U V.
  witness b0.
  apply andI.
  - prove b0 :e B.
    prove b0 :e \/_ U0 :e R_standard_topology, {rectangle_set U0 V0|V0 :e R_standard_topology}.
    claim HUargR: add_SNo (p 0) delta :e R.
    { exact (real_add_SNo (p 0) Hp0R delta HdeltaR). }
    claim HVargR: add_SNo (p 1) delta :e R.
    { exact (real_add_SNo (p 1) Hp1R delta HdeltaR). }
    claim HUopen: U :e R_standard_topology.
    { rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_lower R (add_SNo (p 0) delta) :e open_rays_subbasis R.
      { exact (open_ray_lower_in_open_rays_subbasis R (add_SNo (p 0) delta) HUargR). }
      exact (open_rays_subbasis_sub_order_topology_R U HsRay). }
    claim HVopen: V :e R_standard_topology.
    { rewrite <- standard_topology_is_order_topology.
      claim HsRay: open_ray_lower R (add_SNo (p 1) delta) :e open_rays_subbasis R.
      { exact (open_ray_lower_in_open_rays_subbasis R (add_SNo (p 1) delta) HVargR). }
      exact (open_rays_subbasis_sub_order_topology_R V HsRay). }
    claim HbInFam: b0 :e {rectangle_set U V0|V0 :e R_standard_topology}.
    { exact (ReplI R_standard_topology (fun V0:set => rectangle_set U V0) V HVopen). }
    exact (famunionI R_standard_topology (fun U0:set => {rectangle_set U0 V0|V0 :e R_standard_topology})
           U b0 HUopen HbInFam).
  - apply andI.
    + prove p :e b0.
      rewrite rectangle_set_def.
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta R R p HpDom). }
	      rewrite HpEta at 1.
	      claim Hp0U: p 0 :e U.
	      { claim HdefU: U = {x :e R | order_rel R x (add_SNo (p 0) delta)}.
	        { reflexivity. }
	        rewrite HdefU.
	        apply (SepI R (fun x:set => order_rel R x (add_SNo (p 0) delta)) (p 0) Hp0R).
	        claim Hp0S: SNo (p 0).
	        { exact (real_SNo (p 0) Hp0R). }
	        claim HdeltaS: SNo delta.
	        { exact (real_SNo delta HdeltaR). }
	        claim HdeltaPosS: 0 < delta.
	        { exact (RltE_lt 0 delta HdeltaPos). }
	        claim Hp0plus0: add_SNo (p 0) 0 = p 0.
	        { exact (add_SNo_0R (p 0) Hp0S). }
	        claim HltS': add_SNo (p 0) 0 < add_SNo (p 0) delta.
	        { exact (add_SNo_Lt2 (p 0) 0 delta Hp0S SNo_0 HdeltaS HdeltaPosS). }
	        claim HltS: p 0 < add_SNo (p 0) delta.
	        { rewrite <- Hp0plus0 at 1.
	          exact HltS'. }
	        claim HUargR2: add_SNo (p 0) delta :e R.
	        { exact (real_add_SNo (p 0) Hp0R delta HdeltaR). }
	        claim HaltR: Rlt (p 0) (add_SNo (p 0) delta).
	        { exact (RltI (p 0) (add_SNo (p 0) delta) Hp0R HUargR2 HltS). }
	        exact (Rlt_implies_order_rel_R (p 0) (add_SNo (p 0) delta) HaltR). }
	      claim Hp1V: p 1 :e V.
	      { claim HdefV: V = {x :e R | order_rel R x (add_SNo (p 1) delta)}.
	        { reflexivity. }
	        rewrite HdefV.
	        apply (SepI R (fun x:set => order_rel R x (add_SNo (p 1) delta)) (p 1) Hp1R).
	        claim Hp1S: SNo (p 1).
	        { exact (real_SNo (p 1) Hp1R). }
	        claim HdeltaS: SNo delta.
	        { exact (real_SNo delta HdeltaR). }
	        claim HdeltaPosS: 0 < delta.
	        { exact (RltE_lt 0 delta HdeltaPos). }
	        claim Hp1plus0: add_SNo (p 1) 0 = p 1.
	        { exact (add_SNo_0R (p 1) Hp1S). }
	        claim HltS': add_SNo (p 1) 0 < add_SNo (p 1) delta.
	        { exact (add_SNo_Lt2 (p 1) 0 delta Hp1S SNo_0 HdeltaS HdeltaPosS). }
	        claim HltS: p 1 < add_SNo (p 1) delta.
	        { rewrite <- Hp1plus0 at 1.
	          exact HltS'. }
	        claim HVargR2: add_SNo (p 1) delta :e R.
	        { exact (real_add_SNo (p 1) Hp1R delta HdeltaR). }
	        claim HaltR: Rlt (p 1) (add_SNo (p 1) delta).
	        { exact (RltI (p 1) (add_SNo (p 1) delta) Hp1R HVargR2 HltS). }
	        exact (Rlt_implies_order_rel_R (p 1) (add_SNo (p 1) delta) HaltR). }
	      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1V).
    + prove b0 c= W.
      exact Hbsub.
Qed.

Theorem add_fun_R_continuous :
  continuous_map (setprod R R) (product_topology R R_standard_topology R R_standard_topology)
    R R_standard_topology add_fun_R.
prove continuous_map (setprod R R) (product_topology R R_standard_topology R R_standard_topology)
  R R_standard_topology add_fun_R.
set Tx := product_topology R R_standard_topology R R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim Hfun: function_on add_fun_R (setprod R R) R.
{ let p. assume HpRR: p :e setprod R R.
  exact (add_fun_R_value_in_R p HpRR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }

claim HpreS: forall s:set, s :e S -> preimage_of (setprod R R) add_fun_R s :e Tx.
{ let s. assume HsS: s :e S.
  prove preimage_of (setprod R R) add_fun_R s :e Tx.
  apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b})
                    {R}
                    s
                    (preimage_of (setprod R R) add_fun_R s :e Tx)).
  - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                      :\/:
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}).
    apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}
                      s
                      (preimage_of (setprod R R) add_fun_R s :e Tx)).
    + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
      claim Hex: exists a :e R, s = open_ray_upper R a.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                    s
                    Hsu). }
      apply Hex.
      let a. assume Hacore.
      apply Hacore.
      assume HaR: a :e R.
      assume Hseq: s = open_ray_upper R a.
      rewrite Hseq.
      exact (preimage_add_fun_R_open_ray_upper_in_product_topology a HaR).
    + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
      claim Hex: exists b :e R, s = open_ray_lower R b.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                    s
                    Hsl). }
      apply Hex.
      let b. assume Hbcore.
      apply Hbcore.
      assume HbR: b :e R.
      assume Hseq: s = open_ray_lower R b.
      rewrite Hseq.
      exact (preimage_add_fun_R_open_ray_lower_in_product_topology b HbR).
    + exact Hs0.
  - assume HsR: s :e {R}.
    claim Hseq: s = R.
    { exact (SingE R s HsR). }
    rewrite Hseq.
    claim Heq: preimage_of (setprod R R) add_fun_R R = setprod R R.
    { exact (preimage_of_whole (setprod R R) R add_fun_R Hfun). }
    rewrite Heq.
    exact (topology_has_X (setprod R R) Tx HTx).
  - exact HsS. }

claim Hcont0:
  continuous_map (setprod R R) Tx R (generated_topology_from_subbasis R S) add_fun_R.
{ exact (continuous_map_from_subbasis (setprod R R) Tx R S add_fun_R HTx Hfun HS HpreS). }
claim Hsub: R_standard_topology c= generated_topology_from_subbasis R S.
{ rewrite <- Hgen.
  let U. assume HU: U :e generated_topology_from_subbasis R S.
  exact HU. }
exact (continuous_map_codomain_coarser (setprod R R) Tx R
        (generated_topology_from_subbasis R S) R_standard_topology
        add_fun_R
        Hcont0
        R_standard_topology_is_topology_local
        Hsub).
Qed.

Definition normalize01_fun : set :=
  graph R (fun t:set =>
    div_SNo (mul_SNo t t)
      (add_SNo (mul_SNo t t)
        (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))))).

Theorem normalize01_fun_value_in_R : forall t:set,
  t :e R -> apply_fun normalize01_fun t :e R.
let t.
assume HtR: t :e R.
prove apply_fun normalize01_fun t :e R.
claim Hdef: normalize01_fun =
  graph R (fun t0:set =>
    div_SNo (mul_SNo t0 t0)
      (add_SNo (mul_SNo t0 t0)
        (mul_SNo (add_SNo t0 (minus_SNo 1)) (add_SNo t0 (minus_SNo 1))))).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R
  (fun t0:set =>
    div_SNo (mul_SNo t0 t0)
      (add_SNo (mul_SNo t0 t0)
        (mul_SNo (add_SNo t0 (minus_SNo 1)) (add_SNo t0 (minus_SNo 1)))))
  t HtR).
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim HnumR: mul_SNo t t :e R.
{ exact (real_mul_SNo t HtR t HtR). }
claim Htminus1R: add_SNo t (minus_SNo 1) :e R.
{ exact (real_add_SNo t HtR (minus_SNo 1) Hm1R). }
claim Hsq2R: mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1)) :e R.
{ exact (real_mul_SNo (add_SNo t (minus_SNo 1)) Htminus1R (add_SNo t (minus_SNo 1)) Htminus1R). }
claim HdenR: add_SNo (mul_SNo t t) (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))) :e R.
{ exact (real_add_SNo (mul_SNo t t) HnumR
                      (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))) Hsq2R). }
exact (real_div_SNo (mul_SNo t t) HnumR
	                    (add_SNo (mul_SNo t t) (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1)))) HdenR).
Qed.

(** moved earlier: used by normalize01_fun_preimage_open_ray lemmas **)
Theorem normalize01_fun_range_in_unit_interval : forall t:set,
  t :e R -> apply_fun normalize01_fun t :e unit_interval.
let t.
assume HtR: t :e R.
prove apply_fun normalize01_fun t :e unit_interval.
set f := apply_fun normalize01_fun t.

claim HfR: f :e R.
{ exact (normalize01_fun_value_in_R t HtR). }

claim HtS: SNo t.
{ exact (real_SNo t HtR). }

set num := mul_SNo t t.
set u := add_SNo t (minus_SNo 1).
set u2 := mul_SNo u u.
set den := add_SNo num u2.

claim HnumS: SNo num.
{ exact (SNo_mul_SNo t t HtS HtS). }
claim HuS: SNo u.
{ claim Hm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim HuR: u :e R.
  { exact (real_add_SNo t HtR (minus_SNo 1) Hm1R). }
  exact (real_SNo u HuR). }
claim Hu2S: SNo u2.
{ exact (SNo_mul_SNo u u HuS HuS). }
claim HdenS: SNo den.
{ exact (SNo_add_SNo num u2 HnumS Hu2S). }

claim HfEq: f = div_SNo num den.
{ claim Hdef: normalize01_fun =
    graph R (fun t0:set =>
      div_SNo (mul_SNo t0 t0)
        (add_SNo (mul_SNo t0 t0)
          (mul_SNo (add_SNo t0 (minus_SNo 1)) (add_SNo t0 (minus_SNo 1))))).
  { reflexivity. }
  rewrite Hdef.
  rewrite (apply_fun_graph R
    (fun t0:set =>
      div_SNo (mul_SNo t0 t0)
        (add_SNo (mul_SNo t0 t0)
          (mul_SNo (add_SNo t0 (minus_SNo 1)) (add_SNo t0 (minus_SNo 1)))))
    t HtR).
  prove div_SNo (mul_SNo t t)
        (add_SNo (mul_SNo t t)
          (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))))
      = div_SNo num den.
  reflexivity. }

claim H0le_num: 0 <= num.
{ exact (SNo_sqr_nonneg t HtS). }
claim H0le_u2: 0 <= u2.
{ exact (SNo_sqr_nonneg u HuS). }

claim H0le_den: 0 <= den.
{ claim H00le: add_SNo 0 0 <= add_SNo num u2.
  { exact (add_SNo_Le3 0 0 num u2 SNo_0 SNo_0 HnumS Hu2S H0le_num H0le_u2). }
  claim HdenDef: den = add_SNo num u2.
  { reflexivity. }
  rewrite HdenDef at 1.
  rewrite <- (add_SNo_0R 0 SNo_0) at 1.
  exact H00le. }

claim Hden_ne0: den <> 0.
{ assume Hden0: den = 0.
  prove False.

  (** derive num = 0 and u2 = 0 from den = 0 using nonnegativity **)
  claim Hnum_le_den: num <= den.
  { exact (SNoLe_add_nonneg_right num u2 HnumS Hu2S H0le_u2). }
  claim Hu2_le_den: u2 <= den.
  { claim HdenDef: den = add_SNo num u2.
    { reflexivity. }
    rewrite HdenDef at 1.
    rewrite (add_SNo_com num u2 HnumS Hu2S) at 1.
    exact (SNoLe_add_nonneg_right u2 num Hu2S HnumS H0le_num). }

  claim Hdenle0: den <= 0.
  { rewrite Hden0 at 1.
    exact (SNoLe_ref 0). }

  claim Hnumle0: num <= 0.
  { exact (SNoLe_tra num den 0 HnumS HdenS SNo_0 Hnum_le_den Hdenle0). }
  claim Hu2le0: u2 <= 0.
  { exact (SNoLe_tra u2 den 0 Hu2S HdenS SNo_0 Hu2_le_den Hdenle0). }

  claim Hnum0: num = 0.
  { exact (SNoLe_antisym num 0 HnumS SNo_0 Hnumle0 H0le_num). }
  claim Hu20: u2 = 0.
  { exact (SNoLe_antisym u2 0 Hu2S SNo_0 Hu2le0 H0le_u2). }

  (** deduce t = 0 from square = 0 **)
  claim Ht0: t = 0.
  { claim Hcases: t = 0 \/ 0 < mul_SNo t t.
    { exact (SNo_zero_or_sqr_pos t HtS). }
    apply Hcases.
    - assume H0: t = 0.
      exact H0.
    - assume Hpos: 0 < mul_SNo t t.
      claim Hpos0: 0 < 0.
      { rewrite <- Hnum0 at 2.
        exact Hpos. }
      exact (FalseE ((SNoLt_irref 0) Hpos0) (t = 0)). }

  (** deduce u = 0 from square = 0 **)
  claim Hu0: u = 0.
  { claim Hcases: u = 0 \/ 0 < mul_SNo u u.
    { exact (SNo_zero_or_sqr_pos u HuS). }
    apply Hcases.
    - assume H0: u = 0.
      exact H0.
    - assume Hpos: 0 < mul_SNo u u.
      claim Hpos0: 0 < 0.
      { rewrite <- Hu20 at 2.
        exact Hpos. }
      exact (FalseE ((SNoLt_irref 0) Hpos0) (u = 0)). }

  (** from u = t + (-1) = 0 derive t = 1, contradicting t = 0 **)
  claim Ht1: t = 1.
  { claim HuDef: u = add_SNo t (minus_SNo 1).
    { reflexivity. }
    claim HtEq: add_SNo u 1 = t.
    { rewrite HuDef.
      exact (add_SNo_minus_R2' t 1 HtS SNo_1). }
    rewrite <- HtEq.
    rewrite Hu0.
    exact (add_SNo_0L 1 SNo_1). }
  claim H01: 0 = 1.
  { rewrite <- Ht0 at 1.
    exact Ht1. }
  exact (neq_0_1 H01). }

claim Hden_pos: 0 < den.
{ claim Hcases: 0 < den \/ 0 = den.
  { exact (SNoLeE 0 den SNo_0 HdenS H0le_den). }
  apply Hcases.
  - assume Hpos: 0 < den.
    exact Hpos.
  - assume Heq: 0 = den.
    apply FalseE.
    claim Hden0: den = 0.
    { rewrite <- Heq.
      reflexivity. }
    exact (Hden_ne0 Hden0). }

claim Hden_ne0': den <> 0.
{ exact Hden_ne0. }

(** membership in the unit interval is non-strict bounds against 0 and 1 **)
apply (SepI R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) f HfR).
apply andI.
- (** not (f < 0) **)
  assume Hlt: Rlt f 0.
  prove False.
  claim HfS: SNo f.
  { exact (real_SNo f HfR). }
  claim HfLt0: f < 0.
  { exact (RltE_lt f 0 Hlt). }
  claim HdenLt0: 0 < den.
  { exact Hden_pos. }
  claim HmulLt0: mul_SNo f den < 0.
  { exact (mul_SNo_neg_pos f den HfS HdenS HfLt0 HdenLt0). }
  claim HmulEq: mul_SNo f den = num.
  { rewrite HfEq.
    exact (mul_div_SNo_invL num den HnumS HdenS Hden_ne0'). }
  claim HnumLt0: num < 0.
  { rewrite <- HmulEq at 1.
    exact HmulLt0. }
  claim Hbad: 0 < 0.
  { exact (SNoLeLt_tra 0 num 0 SNo_0 HnumS SNo_0 H0le_num HnumLt0). }
  exact (FalseE ((SNoLt_irref 0) Hbad) False).
- (** not (1 < f) **)
  assume Hlt: Rlt 1 f.
  prove False.
  claim H1Lt: 1 < f.
  { exact (RltE_lt 1 f Hlt). }
  claim HdenLt0: 0 < den.
  { exact Hden_pos. }
  claim HfDiv: f = div_SNo num den.
  { exact HfEq. }
  claim H1LtDiv: 1 < div_SNo num den.
  { rewrite <- HfDiv.
    exact H1Lt. }
	  claim HdenLtNum: den < num.
	  { claim H1denLt: mul_SNo 1 den < num.
	    { exact (div_SNo_pos_LtR' num den 1 HnumS HdenS SNo_1 HdenLt0 H1LtDiv). }
	    rewrite <- (mul_SNo_oneL den HdenS) at 1.
	    exact H1denLt. }
	  claim HnumLeDen: num <= den.
	  { exact (SNoLe_add_nonneg_right num u2 HnumS Hu2S H0le_u2). }
  claim Hbad: den < den.
  { exact (SNoLtLe_tra den num den HdenS HnumS HdenS HdenLtNum HnumLeDen). }
  exact (FalseE ((SNoLt_irref den) Hbad) False).
Qed.

(** helper for normalize01_fun_continuous: preimage of an upper open ray **)
(** LATEX VERSION: Preimage of a basic open ray under the function t^2/(t^2+(t-1)^2) is open in the standard topology on R. **)
Theorem normalize01_fun_preimage_open_ray_upper_mid : forall a:set,
  a :e R -> ~(Rlt a 0) -> Rlt a 1 ->
  preimage_of R normalize01_fun (open_ray_upper R a) :e R_standard_topology.
let a.
assume HaR: a :e R.
assume Hanlt0: ~(Rlt a 0).
assume Halt1: Rlt a 1.
prove preimage_of R normalize01_fun (open_ray_upper R a) :e R_standard_topology.
set W := preimage_of R normalize01_fun (open_ray_upper R a).
(** TODO: show W is open in R_standard_topology by rewriting membership as an inequality on div_SNo,
    then reducing to openness of a strict inequality in the order topology on R.  This currently
    avoids forward references to later continuity of multiplication. **)
admit. (** FAIL **)
Qed.

Theorem normalize01_fun_preimage_open_ray_upper : forall a:set,
  a :e R -> preimage_of R normalize01_fun (open_ray_upper R a) :e R_standard_topology.
let a.
assume HaR: a :e R.
prove preimage_of R normalize01_fun (open_ray_upper R a) :e R_standard_topology.
apply xm (Rlt a 0).
- assume Halt0: Rlt a 0.
  claim HpreEq: preimage_of R normalize01_fun (open_ray_upper R a) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R normalize01_fun (open_ray_upper R a).
      exact (SepE1 R (fun x:set => apply_fun normalize01_fun x :e open_ray_upper R a) t HtPre).
    - let t. assume HtR: t :e R.
      claim HfUI: apply_fun normalize01_fun t :e unit_interval.
      { exact (normalize01_fun_range_in_unit_interval t HtR). }
      claim HfR: apply_fun normalize01_fun t :e R.
      { exact (normalize01_fun_value_in_R t HtR). }
      claim Hbounds: ~(Rlt (apply_fun normalize01_fun t) 0) /\ ~(Rlt 1 (apply_fun normalize01_fun t)).
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) (apply_fun normalize01_fun t) HfUI). }
      claim Hnlt0: ~(Rlt (apply_fun normalize01_fun t) 0).
      { exact (andEL (~(Rlt (apply_fun normalize01_fun t) 0))
                     (~(Rlt 1 (apply_fun normalize01_fun t))) Hbounds). }
      claim Hle0: Rle 0 (apply_fun normalize01_fun t).
      { exact (RleI 0 (apply_fun normalize01_fun t) real_0 HfR Hnlt0). }
      claim Haltf: Rlt a (apply_fun normalize01_fun t).
      { exact (Rlt_Rle_tra a 0 (apply_fun normalize01_fun t) Halt0 Hle0). }
      claim Hrel: order_rel R a (apply_fun normalize01_fun t).
      { exact (Rlt_implies_order_rel_R a (apply_fun normalize01_fun t) Haltf). }
      claim HftRay: apply_fun normalize01_fun t :e open_ray_upper R a.
      { exact (SepI R (fun x:set => order_rel R a x) (apply_fun normalize01_fun t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun normalize01_fun x :e open_ray_upper R a) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume Hnlt0: ~(Rlt a 0).
  apply xm (Rlt a 1).
  + assume Halt1: Rlt a 1.
    exact (normalize01_fun_preimage_open_ray_upper_mid a HaR Hnlt0 Halt1).
  + assume Hnlt1: ~(Rlt a 1).
    claim HpreEq: preimage_of R normalize01_fun (open_ray_upper R a) = Empty.
    { apply set_ext.
      - let t. assume HtPre: t :e preimage_of R normalize01_fun (open_ray_upper R a).
        prove t :e Empty.
        apply FalseE.
        claim HtR: t :e R.
        { exact (SepE1 R (fun x:set => apply_fun normalize01_fun x :e open_ray_upper R a) t HtPre). }
        claim HfUI: apply_fun normalize01_fun t :e unit_interval.
        { exact (normalize01_fun_range_in_unit_interval t HtR). }
        claim HfR: apply_fun normalize01_fun t :e R.
        { exact (normalize01_fun_value_in_R t HtR). }
        claim Hbounds: ~(Rlt (apply_fun normalize01_fun t) 0) /\ ~(Rlt 1 (apply_fun normalize01_fun t)).
        { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) (apply_fun normalize01_fun t) HfUI). }
        claim Hnlt1f: ~(Rlt 1 (apply_fun normalize01_fun t)).
        { exact (andER (~(Rlt (apply_fun normalize01_fun t) 0))
                       (~(Rlt 1 (apply_fun normalize01_fun t))) Hbounds). }
        claim HfaRay: apply_fun normalize01_fun t :e open_ray_upper R a.
        { exact (SepE2 R (fun x:set => apply_fun normalize01_fun x :e open_ray_upper R a) t HtPre). }
        claim Hrel: order_rel R a (apply_fun normalize01_fun t).
        { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun normalize01_fun t) HfaRay). }
        claim Haltf: Rlt a (apply_fun normalize01_fun t).
        { exact (order_rel_R_implies_Rlt a (apply_fun normalize01_fun t) Hrel). }
        claim H1leA: Rle 1 a.
        { exact (RleI 1 a real_1 HaR Hnlt1). }
        claim H1ltf: Rlt 1 (apply_fun normalize01_fun t).
        { exact (Rle_Rlt_tra 1 a (apply_fun normalize01_fun t) H1leA Haltf). }
        exact (Hnlt1f H1ltf).
      - let t. assume HtE: t :e Empty.
        prove t :e preimage_of R normalize01_fun (open_ray_upper R a).
        apply FalseE.
        exact (EmptyE t HtE). }
    rewrite HpreEq.
    exact (topology_has_empty R R_standard_topology R_standard_topology_is_topology).
Qed.

(** helper for normalize01_fun_continuous: preimage of a lower open ray **)
(** LATEX VERSION: Preimage of a basic open ray under the function t^2/(t^2+(t-1)^2) is open in the standard topology on R. **)
Theorem normalize01_fun_preimage_open_ray_lower_mid : forall b:set,
  b :e R -> ~(Rlt 1 b) -> Rlt 0 b ->
  preimage_of R normalize01_fun (open_ray_lower R b) :e R_standard_topology.
let b.
assume HbR: b :e R.
assume Hnlt1: ~(Rlt 1 b).
assume H0ltb: Rlt 0 b.
prove preimage_of R normalize01_fun (open_ray_lower R b) :e R_standard_topology.
set W := preimage_of R normalize01_fun (open_ray_lower R b).
(** TODO: as in the upper-ray case, rewrite membership in W as a strict inequality on div_SNo
    and reduce to openness in the order topology on R, without using later multiplication
    continuity results. **)
admit. (** FAIL **)
Qed.

Theorem normalize01_fun_preimage_open_ray_lower : forall b:set,
  b :e R -> preimage_of R normalize01_fun (open_ray_lower R b) :e R_standard_topology.
let b.
assume HbR: b :e R.
prove preimage_of R normalize01_fun (open_ray_lower R b) :e R_standard_topology.
apply xm (Rlt 1 b).
- assume H1ltb: Rlt 1 b.
  claim HpreEq: preimage_of R normalize01_fun (open_ray_lower R b) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R normalize01_fun (open_ray_lower R b).
      exact (SepE1 R (fun x:set => apply_fun normalize01_fun x :e open_ray_lower R b) t HtPre).
    - let t. assume HtR: t :e R.
      claim HfUI: apply_fun normalize01_fun t :e unit_interval.
      { exact (normalize01_fun_range_in_unit_interval t HtR). }
      claim HfR: apply_fun normalize01_fun t :e R.
      { exact (normalize01_fun_value_in_R t HtR). }
      claim Hbounds: ~(Rlt (apply_fun normalize01_fun t) 0) /\ ~(Rlt 1 (apply_fun normalize01_fun t)).
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) (apply_fun normalize01_fun t) HfUI). }
      claim Hnlt1: ~(Rlt 1 (apply_fun normalize01_fun t)).
      { exact (andER (~(Rlt (apply_fun normalize01_fun t) 0))
                     (~(Rlt 1 (apply_fun normalize01_fun t))) Hbounds). }
      claim Hle: Rle (apply_fun normalize01_fun t) 1.
      { exact (RleI (apply_fun normalize01_fun t) 1 HfR real_1 Hnlt1). }
      claim Hlt: Rlt (apply_fun normalize01_fun t) b.
      { exact (Rle_Rlt_tra (apply_fun normalize01_fun t) 1 b Hle H1ltb). }
      claim Hrel: order_rel R (apply_fun normalize01_fun t) b.
      { exact (Rlt_implies_order_rel_R (apply_fun normalize01_fun t) b Hlt). }
      claim HftRay: apply_fun normalize01_fun t :e open_ray_lower R b.
      { exact (SepI R (fun x:set => order_rel R x b) (apply_fun normalize01_fun t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun normalize01_fun x :e open_ray_lower R b) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume Hnlt1: ~(Rlt 1 b).
  apply xm (Rlt 0 b).
  + assume H0ltb: Rlt 0 b.
    exact (normalize01_fun_preimage_open_ray_lower_mid b HbR Hnlt1 H0ltb).
  + assume Hnlt0: ~(Rlt 0 b).
    claim HpreEq: preimage_of R normalize01_fun (open_ray_lower R b) = Empty.
    { apply set_ext.
      - let t. assume HtPre: t :e preimage_of R normalize01_fun (open_ray_lower R b).
        prove t :e Empty.
        apply FalseE.
        claim HtR: t :e R.
        { exact (SepE1 R (fun x:set => apply_fun normalize01_fun x :e open_ray_lower R b) t HtPre). }
        claim HfUI: apply_fun normalize01_fun t :e unit_interval.
        { exact (normalize01_fun_range_in_unit_interval t HtR). }
        claim HfR: apply_fun normalize01_fun t :e R.
        { exact (normalize01_fun_value_in_R t HtR). }
        claim Hbounds: ~(Rlt (apply_fun normalize01_fun t) 0) /\ ~(Rlt 1 (apply_fun normalize01_fun t)).
        { exact (SepE2 R (fun x0:set => ~(Rlt x0 0) /\ ~(Rlt 1 x0)) (apply_fun normalize01_fun t) HfUI). }
        claim Hnltf0: ~(Rlt (apply_fun normalize01_fun t) 0).
        { exact (andEL (~(Rlt (apply_fun normalize01_fun t) 0))
                       (~(Rlt 1 (apply_fun normalize01_fun t))) Hbounds). }
        claim HfaRay: apply_fun normalize01_fun t :e open_ray_lower R b.
        { exact (SepE2 R (fun x:set => apply_fun normalize01_fun x :e open_ray_lower R b) t HtPre). }
        claim Hrel: order_rel R (apply_fun normalize01_fun t) b.
        { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun normalize01_fun t) HfaRay). }
        claim Hlt: Rlt (apply_fun normalize01_fun t) b.
        { exact (order_rel_R_implies_Rlt (apply_fun normalize01_fun t) b Hrel). }
        claim Hb0: Rle b 0.
        { exact (RleI b 0 HbR real_0 Hnlt0). }
        claim Hlt0: Rlt (apply_fun normalize01_fun t) 0.
        { exact (Rlt_Rle_tra (apply_fun normalize01_fun t) b 0 Hlt Hb0). }
        exact (Hnltf0 Hlt0).
      - let t. assume HtE: t :e Empty.
        prove t :e preimage_of R normalize01_fun (open_ray_lower R b).
        apply FalseE.
        exact (EmptyE t HtE). }
    rewrite HpreEq.
    exact (topology_has_empty R R_standard_topology R_standard_topology_is_topology).
Qed.

Theorem normalize01_fun_continuous :
  continuous_map R R_standard_topology R R_standard_topology normalize01_fun.
prove continuous_map R R_standard_topology R R_standard_topology normalize01_fun.
set Tx := R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on R Tx.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on normalize01_fun R R.
{ let t. assume HtR: t :e R.
  exact (normalize01_fun_value_in_R t HtR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = Tx.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- Hgen at 2.
apply (continuous_map_from_subbasis R Tx R S normalize01_fun HTx Hfun HS).
let s. assume HsS: s :e S.
prove preimage_of R normalize01_fun s :e Tx.
claim HSdef: S =
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ reflexivity. }
claim HsS': s :e
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ rewrite <- HSdef.
  exact HsS. }
apply (binunionE'
  ({I :e Power R | exists a :e R, I = open_ray_upper R a}
   :\/:
   {I :e Power R | exists b :e R, I = open_ray_lower R b})
  {R}
  s
  (preimage_of R normalize01_fun s :e Tx)).
- assume HsAB: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b}).
  apply (binunionE'
    {I :e Power R | exists a :e R, I = open_ray_upper R a}
    {I :e Power R | exists b :e R, I = open_ray_lower R b}
    s
    (preimage_of R normalize01_fun s :e Tx)).
  + assume HsUpper: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
    claim Hex: exists a :e R, s = open_ray_upper R a.
    { exact (SepE2 (Power R) (fun I0:set => exists a :e R, I0 = open_ray_upper R a) s HsUpper). }
    apply Hex.
    let a. assume Hacore.
    apply Hacore.
    assume HaR: a :e R.
    assume Hseq: s = open_ray_upper R a.
    rewrite Hseq.
    exact (normalize01_fun_preimage_open_ray_upper a HaR).
  + assume HsLower: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
    claim Hex: exists b :e R, s = open_ray_lower R b.
    { exact (SepE2 (Power R) (fun I0:set => exists b :e R, I0 = open_ray_lower R b) s HsLower). }
    apply Hex.
    let b. assume Hbcore.
    apply Hbcore.
    assume HbR: b :e R.
    assume Hseq: s = open_ray_lower R b.
    rewrite Hseq.
    exact (normalize01_fun_preimage_open_ray_lower b HbR).
  + exact HsAB.
- assume HsR: s :e {R}.
  claim Hseq: s = R.
  { exact (SingE R s HsR). }
  rewrite Hseq.
  rewrite (preimage_of_whole R R normalize01_fun Hfun).
  exact (topology_has_X R Tx HTx).
- exact HsS'.
Qed.

Theorem normalize01_fun_continuous_to_unit_interval :
  continuous_map R R_standard_topology unit_interval unit_interval_topology normalize01_fun.
prove continuous_map R R_standard_topology unit_interval unit_interval_topology normalize01_fun.
claim HcontR: continuous_map R R_standard_topology R R_standard_topology normalize01_fun.
{ exact normalize01_fun_continuous. }
claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
rewrite Hut.
apply (continuous_map_range_restrict R R_standard_topology R R_standard_topology normalize01_fun unit_interval
       HcontR unit_interval_sub_R).
let x. assume HxR: x :e R.
exact (normalize01_fun_range_in_unit_interval x HxR).
Qed.

Theorem normalize01_fun_0 : apply_fun normalize01_fun 0 = 0.
prove apply_fun normalize01_fun 0 = 0.
claim H0R: 0 :e R.
{ exact real_0. }
claim Hdef: normalize01_fun =
  graph R (fun t:set =>
    div_SNo (mul_SNo t t)
      (add_SNo (mul_SNo t t)
        (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))))).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R
  (fun t:set =>
    div_SNo (mul_SNo t t)
      (add_SNo (mul_SNo t t)
        (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1)))))
  0 H0R).
claim Hnum: mul_SNo 0 0 = 0.
{ exact (mul_SNo_zeroR 0 SNo_0). }
rewrite Hnum at 1.
claim HdenS: SNo (add_SNo (mul_SNo 0 0)
  (mul_SNo (add_SNo 0 (minus_SNo 1)) (add_SNo 0 (minus_SNo 1)))).
{ claim H00S: SNo (mul_SNo 0 0).
  { exact (SNo_mul_SNo 0 0 SNo_0 SNo_0). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim H0m1S: SNo (add_SNo 0 (minus_SNo 1)).
  { exact (SNo_add_SNo 0 (minus_SNo 1) SNo_0 Hm1S). }
  claim HsqS: SNo (mul_SNo (add_SNo 0 (minus_SNo 1)) (add_SNo 0 (minus_SNo 1))).
  { exact (SNo_mul_SNo (add_SNo 0 (minus_SNo 1)) (add_SNo 0 (minus_SNo 1)) H0m1S H0m1S). }
  exact (SNo_add_SNo (mul_SNo 0 0)
    (mul_SNo (add_SNo 0 (minus_SNo 1)) (add_SNo 0 (minus_SNo 1)))
    H00S HsqS). }
exact (div_SNo_0_num
  (add_SNo (mul_SNo 0 0)
    (mul_SNo (add_SNo 0 (minus_SNo 1)) (add_SNo 0 (minus_SNo 1))))
  HdenS).
Qed.

Theorem normalize01_fun_1 : apply_fun normalize01_fun 1 = 1.
prove apply_fun normalize01_fun 1 = 1.
claim H1R: 1 :e R.
{ exact real_1. }
claim Hdef: normalize01_fun =
  graph R (fun t:set =>
    div_SNo (mul_SNo t t)
      (add_SNo (mul_SNo t t)
        (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1))))).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R
  (fun t:set =>
    div_SNo (mul_SNo t t)
      (add_SNo (mul_SNo t t)
        (mul_SNo (add_SNo t (minus_SNo 1)) (add_SNo t (minus_SNo 1)))))
  1 H1R).
rewrite (mul_SNo_oneR 1 SNo_1).
rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
rewrite (mul_SNo_zeroR 0 SNo_0).
rewrite (add_SNo_0R 1 SNo_1).
claim Hrecip1: recip_SNo 1 = 1.
{ claim H1neq0: 1 <> 0.
  { exact neq_1_0. }
  claim Hinv: mul_SNo 1 (recip_SNo 1) = 1.
  { exact (recip_SNo_invR 1 SNo_1 H1neq0). }
  rewrite <- (mul_SNo_oneL (recip_SNo 1) (SNo_recip_SNo 1 SNo_1)) at 1.
  exact Hinv. }
claim Hdivdef: div_SNo 1 1 = mul_SNo 1 (recip_SNo 1).
{ reflexivity. }
rewrite Hdivdef.
rewrite Hrecip1.
rewrite (mul_SNo_oneR 1 SNo_1).
reflexivity.
Qed.

(** helper: graphs into R^J as points of power_real J **)
Theorem graph_to_R_in_power_real : forall J:set, forall g:set->set,
  (forall j:set, j :e J -> g j :e R) ->
  graph J g :e power_real J.
let J g.
assume Hg: forall j:set, j :e J -> g j :e R.
set Xi := const_space_family J R R_standard_topology.
prove graph J g :e product_space J Xi.
claim Hdef: product_space J Xi =
  {f :e Power (setprod J (space_family_union J Xi))|
     total_function_on f J (space_family_union J Xi) /\ functional_graph f /\
     forall i0:set, i0 :e J -> apply_fun f i0 :e space_family_set Xi i0}.
{ reflexivity. }
rewrite Hdef.
apply SepI.
- (** subset of J×(space_family_union J Xi) **)
  apply (PowerI (setprod J (space_family_union J Xi)) (graph J g)).
  let p. assume Hp: p :e graph J g.
  prove p :e setprod J (space_family_union J Xi).
  apply (ReplE_impred J (fun j0:set => (j0, g j0)) p Hp (p :e setprod J (space_family_union J Xi))).
  let j. assume HjJ: j :e J.
  assume Hpeq: p = (j, g j).
  rewrite Hpeq.
  claim HgjR: g j :e R.
  { exact (Hg j HjJ). }
  claim HgjInUnion: g j :e space_family_union J Xi.
  { set Sj := space_family_set Xi j.
    claim HSjFam: Sj :e {space_family_set Xi i|i :e J}.
    { exact (ReplI J (fun i0:set => space_family_set Xi i0) j HjJ). }
    claim HSjEq: Sj = R.
    { rewrite (space_family_set_const_space_family J R R_standard_topology j HjJ).
      reflexivity. }
    claim HgjSj: g j :e Sj.
    { rewrite HSjEq.
      exact HgjR. }
    exact (UnionI {space_family_set Xi i|i :e J} (g j) Sj HgjSj HSjFam). }
  exact (tuple_2_setprod_by_pair_Sigma J (space_family_union J Xi) j (g j) HjJ HgjInUnion).
- (** total_function_on + functional_graph + coordinate-in-R **)
  prove total_function_on (graph J g) J (space_family_union J Xi) /\ functional_graph (graph J g) /\
        forall i0:set, i0 :e J -> apply_fun (graph J g) i0 :e space_family_set Xi i0.
  apply andI.
  - apply andI.
    + apply (total_function_on_graph J (space_family_union J Xi) g).
      let j. assume HjJ: j :e J.
      claim HgjR: g j :e R.
      { exact (Hg j HjJ). }
      set Sj := space_family_set Xi j.
      claim HSjFam: Sj :e {space_family_set Xi i|i :e J}.
      { exact (ReplI J (fun i0:set => space_family_set Xi i0) j HjJ). }
      claim HSjEq: Sj = R.
      { rewrite (space_family_set_const_space_family J R R_standard_topology j HjJ).
        reflexivity. }
      claim HgjSj: g j :e Sj.
      { rewrite HSjEq.
        exact HgjR. }
      exact (UnionI {space_family_set Xi i|i :e J} (g j) Sj HgjSj HSjFam).
    + exact (functional_graph_graph J g).
  - let j. assume HjJ: j :e J.
    prove apply_fun (graph J g) j :e space_family_set Xi j.
    rewrite (apply_fun_graph J g j HjJ).
    rewrite (space_family_set_const_space_family J R R_standard_topology j HjJ).
    exact (Hg j HjJ).
Qed.

(** helper: diagonal_map is a function X -> R^J when F:J->(X->R) is total **)
Theorem diagonal_map_function_on_power_real : forall X F J:set,
  total_function_on F J (function_space X R) ->
  function_on (diagonal_map X F J) X (power_real J).
let X F J.
assume Htot: total_function_on F J (function_space X R).
 prove function_on (diagonal_map X F J) X (power_real J).
 let x. assume HxX: x :e X.
 claim HdiagDef: diagonal_map X F J =
   graph X (fun x0:set => graph J (fun j:set => apply_fun (apply_fun F j) x0)).
 { reflexivity. }
 rewrite HdiagDef at 1.
 rewrite (apply_fun_graph X (fun x0:set => graph J (fun j:set => apply_fun (apply_fun F j) x0)) x HxX).
 apply (graph_to_R_in_power_real J (fun j:set => apply_fun (apply_fun F j) x)).
 let j. assume HjJ: j :e J.
claim HFj: apply_fun F j :e function_space X R.
{ exact (total_function_on_apply_fun_in_Y F J (function_space X R) j Htot HjJ). }
claim HFjFun: function_on (apply_fun F j) X R.
{ exact (SepE2 (Power (setprod X R)) (fun f0:set => function_on f0 X R) (apply_fun F j) HFj). }
exact (HFjFun x HxX).
Qed.

(** helper: graphs into [0,1]^J as points of unit_interval_power J **)
Theorem graph_to_unit_interval_in_unit_interval_power : forall J:set, forall g:set->set,
  (forall j:set, j :e J -> g j :e unit_interval) ->
  graph J g :e unit_interval_power J.
let J g.
assume Hg: forall j:set, j :e J -> g j :e unit_interval.
set Xi := const_space_family J unit_interval unit_interval_topology.
prove graph J g :e product_space J Xi.
claim Hdef: product_space J Xi =
  {f :e Power (setprod J (space_family_union J Xi))|
     total_function_on f J (space_family_union J Xi) /\ functional_graph f /\
     forall i0:set, i0 :e J -> apply_fun f i0 :e space_family_set Xi i0}.
{ reflexivity. }
rewrite Hdef.
apply SepI.
- (** subset of J×(space_family_union J Xi) **)
  apply (PowerI (setprod J (space_family_union J Xi)) (graph J g)).
  let p. assume Hp: p :e graph J g.
  prove p :e setprod J (space_family_union J Xi).
  apply (ReplE_impred J (fun j0:set => (j0, g j0)) p Hp (p :e setprod J (space_family_union J Xi))).
  let j. assume HjJ: j :e J.
  assume Hpeq: p = (j, g j).
  rewrite Hpeq.
  claim HgjI: g j :e unit_interval.
  { exact (Hg j HjJ). }
  claim HgjInUnion: g j :e space_family_union J Xi.
  { set Sj := space_family_set Xi j.
    claim HSjFam: Sj :e {space_family_set Xi i|i :e J}.
    { exact (ReplI J (fun i0:set => space_family_set Xi i0) j HjJ). }
    claim HSjEq: Sj = unit_interval.
    { rewrite (space_family_set_const_space_family J unit_interval unit_interval_topology j HjJ).
      reflexivity. }
    claim HgjSj: g j :e Sj.
    { rewrite HSjEq.
      exact HgjI. }
    exact (UnionI {space_family_set Xi i|i :e J} (g j) Sj HgjSj HSjFam). }
  exact (tuple_2_setprod_by_pair_Sigma J (space_family_union J Xi) j (g j) HjJ HgjInUnion).
- (** total_function_on + functional_graph + coordinate-in-[0,1] **)
  prove total_function_on (graph J g) J (space_family_union J Xi) /\ functional_graph (graph J g) /\
        forall i0:set, i0 :e J -> apply_fun (graph J g) i0 :e space_family_set Xi i0.
  apply andI.
  - apply andI.
    + apply (total_function_on_graph J (space_family_union J Xi) g).
      let j. assume HjJ: j :e J.
      claim HgjI: g j :e unit_interval.
      { exact (Hg j HjJ). }
      set Sj := space_family_set Xi j.
      claim HSjFam: Sj :e {space_family_set Xi i|i :e J}.
      { exact (ReplI J (fun i0:set => space_family_set Xi i0) j HjJ). }
      claim HSjEq: Sj = unit_interval.
      { rewrite (space_family_set_const_space_family J unit_interval unit_interval_topology j HjJ).
        reflexivity. }
      claim HgjSj: g j :e Sj.
      { rewrite HSjEq.
        exact HgjI. }
      exact (UnionI {space_family_set Xi i|i :e J} (g j) Sj HgjSj HSjFam).
    + exact (functional_graph_graph J g).
  - let j. assume HjJ: j :e J.
    prove apply_fun (graph J g) j :e space_family_set Xi j.
    rewrite (apply_fun_graph J g j HjJ).
    rewrite (space_family_set_const_space_family J unit_interval unit_interval_topology j HjJ).
    exact (Hg j HjJ).
Qed.

(** helper: diagonal_map is a function X -> [0,1]^J when F:J->(X->[0,1]) is total **)
Theorem diagonal_map_function_on_unit_interval_power : forall X F J:set,
  total_function_on F J (function_space X unit_interval) ->
  function_on (diagonal_map X F J) X (unit_interval_power J).
let X F J.
assume Htot: total_function_on F J (function_space X unit_interval).
prove function_on (diagonal_map X F J) X (unit_interval_power J).
let x. assume HxX: x :e X.
claim HdiagDef: diagonal_map X F J =
  graph X (fun x0:set => graph J (fun j:set => apply_fun (apply_fun F j) x0)).
{ reflexivity. }
rewrite HdiagDef at 1.
rewrite (apply_fun_graph X (fun x0:set => graph J (fun j:set => apply_fun (apply_fun F j) x0)) x HxX).
apply (graph_to_unit_interval_in_unit_interval_power J (fun j:set => apply_fun (apply_fun F j) x)).
let j. assume HjJ: j :e J.
claim HFj: apply_fun F j :e function_space X unit_interval.
{ exact (total_function_on_apply_fun_in_Y F J (function_space X unit_interval) j Htot HjJ). }
claim HFjFun: function_on (apply_fun F j) X unit_interval.
{ exact (SepE2 (Power (setprod X unit_interval)) (fun f0:set => function_on f0 X unit_interval) (apply_fun F j) HFj). }
exact (HFjFun x HxX).
Qed.

(** helper: continuity of the diagonal map into a unit_interval cube for nonempty index sets **)
Theorem diagonal_map_continuous_unit_interval_power : forall X Tx F J:set,
  topology_on X Tx ->
  J <> Empty ->
  total_function_on F J (function_space X unit_interval) ->
  (forall j:set, j :e J -> continuous_map X Tx unit_interval unit_interval_topology (apply_fun F j)) ->
  continuous_map X Tx (unit_interval_power J)
    (product_topology_full J (const_space_family J unit_interval unit_interval_topology))
    (diagonal_map X F J).
let X Tx F J.
assume HTx: topology_on X Tx.
assume HJne: J <> Empty.
assume Htot: total_function_on F J (function_space X unit_interval).
assume HcontCoord: forall j:set, j :e J -> continuous_map X Tx unit_interval unit_interval_topology (apply_fun F j).
set Xi := const_space_family J unit_interval unit_interval_topology.
set Ty := product_topology_full J Xi.
prove continuous_map X Tx (unit_interval_power J) Ty (diagonal_map X F J).
claim HYdef: unit_interval_power J = product_space J Xi.
{ reflexivity. }
claim Hfun: function_on (diagonal_map X F J) X (unit_interval_power J).
{ exact (diagonal_map_function_on_unit_interval_power X F J Htot). }
claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume HiJ: i :e J.
  rewrite (space_family_set_const_space_family J unit_interval unit_interval_topology i HiJ).
  rewrite (space_family_topology_const_space_family J unit_interval unit_interval_topology i HiJ).
  exact unit_interval_topology_on. }
claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
{ exact (product_subbasis_full_subbasis_on J Xi HJne HcompTop). }
claim HfunY: function_on (diagonal_map X F J) X (product_space J Xi).
{ rewrite <- HYdef.
  exact Hfun. }
rewrite HYdef.
apply (continuous_map_from_subbasis X Tx (product_space J Xi) (product_subbasis_full J Xi)
       (diagonal_map X F J) HTx HfunY HSsub).
let s. assume HsS: s :e product_subbasis_full J Xi.
prove preimage_of X (diagonal_map X F J) s :e Tx.
set Fam := (fun i0:set => {product_cylinder J Xi i0 U0|U0 :e space_family_topology Xi i0}).
claim HsFam: s :e (\/_ i0 :e J, Fam i0).
{ exact HsS. }
apply (famunionE_impred J Fam s HsFam (preimage_of X (diagonal_map X F J) s :e Tx)).
let i. assume HiJ: i :e J.
assume HsFi: s :e Fam i.
claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder J Xi i U.
{ exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder J Xi i U0) s HsFi). }
apply HexU.
let U. assume HUand: U :e space_family_topology Xi i /\ s = product_cylinder J Xi i U.
claim HUtop: U :e space_family_topology Xi i.
{ exact (andEL (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
claim Hseq: s = product_cylinder J Xi i U.
{ exact (andER (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
rewrite Hseq.
claim Hconti: continuous_map X Tx unit_interval unit_interval_topology (apply_fun F i).
{ exact (HcontCoord i HiJ). }
claim HUui: U :e unit_interval_topology.
{ claim Htopi: space_family_topology Xi i = unit_interval_topology.
  { exact (space_family_topology_const_space_family J unit_interval unit_interval_topology i HiJ). }
  rewrite <- Htopi.
  exact HUtop. }
claim HpreEq: preimage_of X (diagonal_map X F J) (product_cylinder J Xi i U) =
  preimage_of X (apply_fun F i) U.
{ apply set_ext.
  - let x. assume HxPre: x :e preimage_of X (diagonal_map X F J) (product_cylinder J Xi i U).
    prove x :e preimage_of X (apply_fun F i) U.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun (diagonal_map X F J) x0 :e product_cylinder J Xi i U) x HxPre). }
    claim HfxCyl: apply_fun (diagonal_map X F J) x :e product_cylinder J Xi i U.
    { exact (SepE2 X (fun x0:set => apply_fun (diagonal_map X F J) x0 :e product_cylinder J Xi i U) x HxPre). }
    claim HcylProp:
      i :e J /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun (diagonal_map X F J) x) i :e U.
    { exact (SepE2 (product_space J Xi)
                   (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                   (apply_fun (diagonal_map X F J) x) HfxCyl). }
    claim HcoordU: apply_fun (apply_fun (diagonal_map X F J) x) i :e U.
    { claim H12: i :e J /\ U :e space_family_topology Xi i.
      { exact (andEL (i :e J /\ U :e space_family_topology Xi i)
                     (apply_fun (apply_fun (diagonal_map X F J) x) i :e U)
                     HcylProp). }
      exact (andER (i :e J /\ U :e space_family_topology Xi i)
                   (apply_fun (apply_fun (diagonal_map X F J) x) i :e U)
                   HcylProp). }
    claim HFmapx: apply_fun (diagonal_map X F J) x =
      graph J (fun j0:set => apply_fun (apply_fun F j0) x).
    { claim HdiagDef: diagonal_map X F J =
        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
      { reflexivity. }
      rewrite HdiagDef.
      exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
    claim HcoordEq: apply_fun (apply_fun (diagonal_map X F J) x) i = apply_fun (apply_fun F i) x.
    { rewrite HFmapx.
      rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
      reflexivity. }
    claim HfiU: apply_fun (apply_fun F i) x :e U.
    { rewrite <- HcoordEq.
      exact HcoordU. }
    exact (SepI X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxX HfiU).
  - let x. assume HxPre: x :e preimage_of X (apply_fun F i) U.
    prove x :e preimage_of X (diagonal_map X F J) (product_cylinder J Xi i U).
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
    claim HfiU: apply_fun (apply_fun F i) x :e U.
    { exact (SepE2 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
    claim HFmapx: apply_fun (diagonal_map X F J) x =
      graph J (fun j0:set => apply_fun (apply_fun F j0) x).
    { claim HdiagDef: diagonal_map X F J =
        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
      { reflexivity. }
      rewrite HdiagDef.
      exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
    claim HcoordEq: apply_fun (apply_fun (diagonal_map X F J) x) i = apply_fun (apply_fun F i) x.
    { rewrite HFmapx.
      rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
      reflexivity. }
    claim HcoordU: apply_fun (apply_fun (diagonal_map X F J) x) i :e U.
    { rewrite HcoordEq.
      exact HfiU. }
    claim HfunPow0: function_on (diagonal_map X F J) X (unit_interval_power J).
    { exact (diagonal_map_function_on_unit_interval_power X F J Htot). }
    claim HfunPow: function_on (diagonal_map X F J) X (product_space J Xi).
    { rewrite <- HYdef.
      exact HfunPow0. }
    claim HfxY: apply_fun (diagonal_map X F J) x :e product_space J Xi.
    { exact (HfunPow x HxX). }
    claim HfxCyl: apply_fun (diagonal_map X F J) x :e product_cylinder J Xi i U.
    { claim HcylDef: product_cylinder J Xi i U =
        {f0 :e product_space J Xi | i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U}.
      { reflexivity. }
      rewrite HcylDef.
      apply (SepI (product_space J Xi)
        (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
        (apply_fun (diagonal_map X F J) x)
        HfxY).
      apply andI.
      - apply andI.
        + exact HiJ.
        + exact HUtop.
      - exact HcoordU. }
    exact (SepI X (fun x0:set => apply_fun (diagonal_map X F J) x0 :e product_cylinder J Xi i U) x HxX HfxCyl). }
rewrite HpreEq.
exact (continuous_map_preimage X Tx unit_interval unit_interval_topology (apply_fun F i) Hconti U HUui).
Qed.

(** helper: ω-power of R equals the previously defined R^ω product space **)
(** LATEX VERSION: Identify ℝ^ω with the earlier `R_omega_space` definition. **)
Theorem power_real_omega_eq_Romega_space : power_real omega = R_omega_space.
prove power_real omega = R_omega_space.
reflexivity.
Qed.

(** helper: ω-power of [0,1] as a product space **)
(** LATEX VERSION: Identify [0,1]^ω with the corresponding product space. **)
Theorem unit_interval_power_omega_def :
  unit_interval_power omega = product_space omega (const_space_family omega unit_interval unit_interval_topology).
prove unit_interval_power omega = product_space omega (const_space_family omega unit_interval unit_interval_topology).
reflexivity.
Qed.
Definition metrizable : set -> set -> prop := fun X Tx =>
  exists d:set, metric_on X d /\ metric_topology X d = Tx.

(** from §30 Example 4: product of Lindelöf spaces need not be Lindelöf **) 
(** LATEX VERSION: The product of two Lindelöf Sorgenfrey lines (the Sorgenfrey plane) is not Lindelöf. **)
(** from §30 Example 4: define L subset of the Sorgenfrey plane **)
(** LATEX VERSION: L = { x × (-x) | x ∈ R_l }. **)
Definition Sorgenfrey_plane_L : set :=
  {(x, minus_SNo x)|x :e Sorgenfrey_line}.

(** from §30 Example 4: special basis rectangles **)
(** LATEX VERSION: Basis elements of the form [a,b) × [-a,d). **)
Definition Sorgenfrey_plane_special_rectangle : set -> set -> set -> set :=
  fun a b d => rectangle_set (halfopen_interval_left a b) (halfopen_interval_left (minus_SNo a) d).

(** helper: special rectangles are open in the Sorgenfrey plane **)
Theorem Sorgenfrey_plane_special_rectangle_open : forall a b d:set,
  a :e R -> b :e R -> d :e R ->
  Sorgenfrey_plane_special_rectangle a b d :e Sorgenfrey_plane_topology.
let a b d.
assume HaR: a :e R.
assume HbR: b :e R.
assume HdR: d :e R.
prove Sorgenfrey_plane_special_rectangle a b d :e Sorgenfrey_plane_topology.
set U := halfopen_interval_left a b.
set V := halfopen_interval_left (minus_SNo a) d.
claim HTx: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HUopen: U :e Sorgenfrey_topology.
{ exact (halfopen_interval_left_in_R_lower_limit_topology a b HaR HbR). }
claim HmaR: (minus_SNo a) :e R.
{ exact (real_minus_SNo a HaR). }
claim HVopen: V :e Sorgenfrey_topology.
{ exact (halfopen_interval_left_in_R_lower_limit_topology (minus_SNo a) d HmaR HdR). }
claim HBasis: basis_on (setprod Sorgenfrey_line Sorgenfrey_line)
  (product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology).
{ exact (product_subbasis_is_basis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology
         HTx HTx). }
claim HrectIn: rectangle_set U V
  :e product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
{ claim HVfam: rectangle_set U V :e {rectangle_set U V0|V0 :e Sorgenfrey_topology}.
  { exact (ReplI Sorgenfrey_topology (fun V0:set => rectangle_set U V0) V HVopen). }
  exact (famunionI Sorgenfrey_topology (fun U0:set => {rectangle_set U0 V0|V0 :e Sorgenfrey_topology})
         U (rectangle_set U V) HUopen HVfam). }
claim HdefRect: Sorgenfrey_plane_special_rectangle a b d = rectangle_set U V.
{ reflexivity. }
claim HdefTop: Sorgenfrey_plane_topology
  = product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
{ reflexivity. }
claim HdefProd: product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology
  = generated_topology (setprod Sorgenfrey_line Sorgenfrey_line)
      (product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology).
{ reflexivity. }
rewrite HdefTop.
rewrite HdefProd.
rewrite HdefRect.
exact (generated_topology_contains_basis (setprod Sorgenfrey_line Sorgenfrey_line)
       (product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology)
       HBasis (rectangle_set U V) HrectIn).
Qed.

(** helper: L is uncountable **)
Theorem Sorgenfrey_plane_L_uncountable : ~ countable_set Sorgenfrey_plane_L.
assume HcountL: countable_set Sorgenfrey_plane_L.
prove False.
claim HinjRL: atleastp Sorgenfrey_line Sorgenfrey_plane_L.
{ prove exists f:set -> set, inj Sorgenfrey_line Sorgenfrey_plane_L f.
  witness (fun x:set => (x, minus_SNo x)).
  apply (injI Sorgenfrey_line Sorgenfrey_plane_L (fun x:set => (x, minus_SNo x))).
  - let x. assume HxR: x :e Sorgenfrey_line.
    prove (x, minus_SNo x) :e Sorgenfrey_plane_L.
    exact (ReplI Sorgenfrey_line (fun x0:set => (x0, minus_SNo x0)) x HxR).
  - let x1. assume Hx1: x1 :e Sorgenfrey_line.
    let x2. assume Hx2: x2 :e Sorgenfrey_line.
    assume Heq: (x1, minus_SNo x1) = (x2, minus_SNo x2).
    prove x1 = x2.
    claim H0: (x1, minus_SNo x1) 0 = (x2, minus_SNo x2) 0.
    { rewrite Heq. reflexivity. }
    claim Hx10: (x1, minus_SNo x1) 0 = x1.
    { rewrite <- (tuple_pair x1 (minus_SNo x1)).
      exact (pair_ap_0 x1 (minus_SNo x1)). }
    claim Hx20: (x2, minus_SNo x2) 0 = x2.
    { rewrite <- (tuple_pair x2 (minus_SNo x2)).
      exact (pair_ap_0 x2 (minus_SNo x2)). }
    rewrite <- Hx10 at 1.
    rewrite <- Hx20.
    exact H0. }
claim HcountR: atleastp Sorgenfrey_line omega.
{ exact (atleastp_tra Sorgenfrey_line Sorgenfrey_plane_L omega HinjRL HcountL). }
exact (form100_22_real_uncountable_atleastp HcountR).
Qed.

(** helper: if (x,-x) lies in [a,b)×[-a,d), then x=a **)
Theorem Sorgenfrey_plane_special_rectangle_L_point : forall a b d x:set,
  a :e R -> b :e R -> d :e R -> x :e R ->
  (x, minus_SNo x) :e Sorgenfrey_plane_special_rectangle a b d ->
  x = a.
let a b d x.
assume HaR: a :e R.
assume HbR: b :e R.
assume HdR: d :e R.
assume HxR: x :e R.
assume Hrect: (x, minus_SNo x) :e Sorgenfrey_plane_special_rectangle a b d.
prove x = a.
set U := halfopen_interval_left a b.
set V := halfopen_interval_left (minus_SNo a) d.
claim HpUV: (x, minus_SNo x) :e setprod U V.
{ rewrite <- rectangle_set_def.
  exact Hrect. }
claim Hp0U: proj0 (x, minus_SNo x) :e U.
{ exact (proj0_Sigma U (fun _ : set => V) (x, minus_SNo x) HpUV). }
claim Hp1V: proj1 (x, minus_SNo x) :e V.
{ exact (proj1_Sigma U (fun _ : set => V) (x, minus_SNo x) HpUV). }
claim Hp0U0: (x, minus_SNo x) 0 :e U.
{ rewrite <- (proj0_ap_0 (x, minus_SNo x)).
  exact Hp0U. }
claim Hp1V1: (x, minus_SNo x) 1 :e V.
{ rewrite <- (proj1_ap_1 (x, minus_SNo x)).
  exact Hp1V. }
claim Hx0: (x, minus_SNo x) 0 = x.
{ rewrite <- (tuple_pair x (minus_SNo x)).
  exact (pair_ap_0 x (minus_SNo x)). }
claim Hx1: (x, minus_SNo x) 1 = minus_SNo x.
{ rewrite <- (tuple_pair x (minus_SNo x)).
  exact (pair_ap_1 x (minus_SNo x)). }
claim HxU: x :e U.
{ rewrite <- Hx0.
  exact Hp0U0. }
claim HmxV: (minus_SNo x) :e V.
{ rewrite <- Hx1.
  exact Hp1V1. }
claim HxUprop: ~(Rlt x a) /\ Rlt x b.
{ exact (SepE2 R (fun t:set => ~(Rlt t a) /\ Rlt t b) x HxU). }
claim Hnlt_xa: ~(Rlt x a).
{ exact (andEL (~(Rlt x a)) (Rlt x b) HxUprop). }
claim HmxVprop: ~(Rlt (minus_SNo x) (minus_SNo a)) /\ Rlt (minus_SNo x) d.
{ exact (SepE2 R (fun t:set => ~(Rlt t (minus_SNo a)) /\ Rlt t d) (minus_SNo x) HmxV). }
claim Hnlt_mx_ma: ~(Rlt (minus_SNo x) (minus_SNo a)).
{ exact (andEL (~(Rlt (minus_SNo x) (minus_SNo a))) (Rlt (minus_SNo x) d) HmxVprop). }
claim Hnlt_ax: ~(Rlt a x).
{ assume Hltax: Rlt a x.
  prove False.
  claim Hltax_lt: a < x.
  { exact (RltE_lt a x Hltax). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim Hmx_lt_ma: (minus_SNo x) < (minus_SNo a).
  { exact (minus_SNo_Lt_contra a x HaS HxS Hltax_lt). }
  claim HmxR: (minus_SNo x) :e R.
  { exact (real_minus_SNo x HxR). }
  claim HmaR: (minus_SNo a) :e R.
  { exact (real_minus_SNo a HaR). }
  claim Hlt: Rlt (minus_SNo x) (minus_SNo a).
  { exact (RltI (minus_SNo x) (minus_SNo a) HmxR HmaR Hmx_lt_ma). }
  exact (Hnlt_mx_ma Hlt). }
exact (Rle_antisym x a
        (RleI x a HxR HaR Hnlt_ax)
        (RleI a x HaR HxR Hnlt_xa)).
Qed.

(** helper: extensionality for 2-tuples **)
Theorem tuple_2_ext : forall a b c d:set,
  a = c -> b = d -> (a,b) = (c,d).
let a b c d.
assume Hac: a = c.
assume Hbd: b = d.
rewrite Hac.
rewrite Hbd.
reflexivity.
Qed.

(** from §30 Example 4: L is closed in the Sorgenfrey plane **)
(** LATEX VERSION: L is closed in the Sorgenfrey plane. **)
Theorem Sorgenfrey_plane_L_closed :
  closed_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology Sorgenfrey_plane_L.
prove closed_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology Sorgenfrey_plane_L.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
set L := Sorgenfrey_plane_L.
set B := product_subbasis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.

(** topology on X **)
claim HTline: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HBasis: basis_on X B.
{ exact (product_subbasis_is_basis Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HTline HTline). }
claim HTx: topology_on X Tx.
{ exact (lemma_topology_from_basis X B HBasis). }

(** L ⊂ X **)
claim HLsub: L c= X.
{ let p. assume HpL: p :e L.
  claim Hex: exists x :e R, p = (x, minus_SNo x).
  { exact (ReplE R (fun x0:set => (x0, minus_SNo x0)) p HpL). }
  apply Hex.
  let x. assume Hxpair: x :e R /\ p = (x, minus_SNo x).
  claim HxR: x :e R.
  { exact (andEL (x :e R) (p = (x, minus_SNo x)) Hxpair). }
  claim Hpeq: p = (x, minus_SNo x).
  { exact (andER (x :e R) (p = (x, minus_SNo x)) Hxpair). }
  claim HmxR: (minus_SNo x) :e R.
  { exact (real_minus_SNo x HxR). }
  rewrite Hpeq.
  exact (tuple_2_setprod_by_pair_Sigma R R x (minus_SNo x) HxR HmxR). }

(** show U = X\\L is open in Tx **)
set U := X :\: L.
claim HUinT: U :e Tx.
{ claim HTdef: Tx = generated_topology X B.
  { reflexivity. }
  rewrite HTdef.
  prove U :e generated_topology X B.
  claim HUpow: U :e Power X.
  { exact (setminus_In_Power X L). }
  claim HUloc: forall p :e U, exists b :e B, p :e b /\ b c= U.
  { let p. assume HpU: p :e U.
    claim HpX: p :e X.
    { exact (setminusE1 X L p HpU). }
    claim HpnotL: p /:e L.
    { exact (setminusE2 X L p HpU). }
    claim Hp0R: (p 0) :e R.
    { exact (ap0_Sigma R (fun _ : set => R) p HpX). }
    claim Hp1R: (p 1) :e R.
    { exact (ap1_Sigma R (fun _ : set => R) p HpX). }
    claim Hm0R: (minus_SNo (p 0)) :e R.
    { exact (real_minus_SNo (p 0) Hp0R). }
    claim Hp0S: SNo (p 0).
    { exact (real_SNo (p 0) Hp0R). }
    claim Hp1S: SNo (p 1).
    { exact (real_SNo (p 1) Hp1R). }
    claim Hm0S: SNo (minus_SNo (p 0)).
    { exact (real_SNo (minus_SNo (p 0)) Hm0R). }

    (** split by trichotomy on p1 vs -p0 **)
    apply (SNoLt_trichotomy_or_impred (p 1) (minus_SNo (p 0)) Hp1S Hm0S (exists b :e B, p :e b /\ b c= U)).
    - (** case p1 < -p0 **)
      assume Hylt: (p 1) < (minus_SNo (p 0)).
      claim HyltR: Rlt (p 1) (minus_SNo (p 0)).
      { exact (RltI (p 1) (minus_SNo (p 0)) Hp1R Hm0R Hylt). }
      claim Hexq: exists q :e rational_numbers, Rlt (p 1) q /\ Rlt q (minus_SNo (p 0)).
      { exact (rational_dense_between_reals (p 1) (minus_SNo (p 0)) Hp1R Hm0R HyltR). }
      apply Hexq.
      let q. assume Hqpair.
      claim HqQ: q :e rational_numbers.
      { exact (andEL (q :e rational_numbers) (Rlt (p 1) q /\ Rlt q (minus_SNo (p 0))) Hqpair). }
      claim Hqprop: Rlt (p 1) q /\ Rlt q (minus_SNo (p 0)).
      { exact (andER (q :e rational_numbers) (Rlt (p 1) q /\ Rlt q (minus_SNo (p 0))) Hqpair). }
      claim Hp1q: Rlt (p 1) q.
      { exact (andEL (Rlt (p 1) q) (Rlt q (minus_SNo (p 0))) Hqprop). }
      claim Hq_m0: Rlt q (minus_SNo (p 0)).
      { exact (andER (Rlt (p 1) q) (Rlt q (minus_SNo (p 0))) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqS: SNo q.
      { exact (real_SNo q HqR). }
      claim HmqR: (minus_SNo q) :e R.
      { exact (real_minus_SNo q HqR). }
      claim Hq_m0_lt: q < (minus_SNo (p 0)).
      { exact (RltE_lt q (minus_SNo (p 0)) Hq_m0). }
      claim Hp0_lt_mq: (p 0) < (minus_SNo q).
      { exact (minus_SNo_Lt_contra2 q (p 0) HqS Hp0S Hq_m0_lt). }
      claim Hp0mq: Rlt (p 0) (minus_SNo q).
      { exact (RltI (p 0) (minus_SNo q) Hp0R HmqR Hp0_lt_mq). }

      set U0 := halfopen_interval_left (p 0) (minus_SNo q).
      set V0 := halfopen_interval_left (p 1) q.

      claim HU0T: U0 :e Sorgenfrey_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology (p 0) (minus_SNo q) Hp0R HmqR). }
      claim HV0T: V0 :e Sorgenfrey_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology (p 1) q Hp1R HqR). }
      claim HbB: rectangle_set U0 V0 :e B.
      { prove rectangle_set U0 V0 :e product_subbasis R R_lower_limit_topology R R_lower_limit_topology.
        claim HbRepl: rectangle_set U0 V0 :e {rectangle_set U0 V|V :e R_lower_limit_topology}.
        { exact (ReplI R_lower_limit_topology (fun V:set => rectangle_set U0 V) V0 HV0T). }
        exact (famunionI R_lower_limit_topology (fun Ux:set => {rectangle_set Ux V|V :e R_lower_limit_topology})
                         U0 (rectangle_set U0 V0) HU0T HbRepl). }
      claim HpU0: (p 0) :e U0.
      { exact (halfopen_interval_left_leftmem (p 0) (minus_SNo q) Hp0mq). }
      claim HpV0: (p 1) :e V0.
      { exact (halfopen_interval_left_leftmem (p 1) q Hp1q). }
      claim Hpb: p :e rectangle_set U0 V0.
      { claim HpEta: p = (p 0, p 1).
        { exact (setprod_eta R R p HpX). }
        rewrite HpEta at 1.
        exact (tuple_2_rectangle_set U0 V0 (p 0) (p 1) HpU0 HpV0). }
      claim HbSub: rectangle_set U0 V0 c= U.
      { let z. assume Hz: z :e rectangle_set U0 V0.
        prove z :e U.
        claim HzX: z :e X.
        { claim HzProd: z :e setprod U0 V0.
          { rewrite <- rectangle_set_def.
            exact Hz. }
          exact (setprod_Subq U0 V0 R R (halfopen_interval_left_Subq_R (p 0) (minus_SNo q))
                                   (halfopen_interval_left_Subq_R (p 1) q)
                                   z HzProd). }
        apply setminusI X L z HzX.
        assume HzL: z :e L.
        claim Hext: exists t :e R, z = (t, minus_SNo t).
        { exact (ReplE R (fun t0:set => (t0, minus_SNo t0)) z HzL). }
        apply Hext.
        let t. assume Htpair.
        claim HtR: t :e R.
        { exact (andEL (t :e R) (z = (t, minus_SNo t)) Htpair). }
        claim Hzeq: z = (t, minus_SNo t).
        { exact (andER (t :e R) (z = (t, minus_SNo t)) Htpair). }
        claim HmtR: (minus_SNo t) :e R.
        { exact (real_minus_SNo t HtR). }
        claim HtS: SNo t.
        { exact (real_SNo t HtR). }
        claim HmtS: SNo (minus_SNo t).
        { exact (real_SNo (minus_SNo t) HmtR). }
        claim Hz0: z 0 = t.
        { rewrite Hzeq. exact (tuple_2_0_eq t (minus_SNo t)). }
        claim Hz1: z 1 = minus_SNo t.
        { rewrite Hzeq. exact (tuple_2_1_eq t (minus_SNo t)). }
        claim Hz0U0: (z 0) :e U0.
        { claim HzProd: z :e setprod U0 V0.
          { rewrite <- rectangle_set_def.
            exact Hz. }
          exact (ap0_Sigma U0 (fun _ : set => V0) z HzProd). }
        claim Hz1V0: (z 1) :e V0.
        { claim HzProd: z :e setprod U0 V0.
          { rewrite <- rectangle_set_def.
            exact Hz. }
          exact (ap1_Sigma U0 (fun _ : set => V0) z HzProd). }
        claim HtU0: t :e U0.
        { rewrite <- Hz0. exact Hz0U0. }
        claim HmtV0: (minus_SNo t) :e V0.
        { rewrite <- Hz1. exact Hz1V0. }
        claim HtU0prop: ~(Rlt t (p 0)) /\ Rlt t (minus_SNo q).
        { exact (SepE2 R (fun u:set => ~(Rlt u (p 0)) /\ Rlt u (minus_SNo q)) t HtU0). }
        claim Ht_lt_mq: Rlt t (minus_SNo q).
        { exact (andER (~(Rlt t (p 0))) (Rlt t (minus_SNo q)) HtU0prop). }
        claim HmtV0prop: ~(Rlt (minus_SNo t) (p 1)) /\ Rlt (minus_SNo t) q.
        { exact (SepE2 R (fun v:set => ~(Rlt v (p 1)) /\ Rlt v q) (minus_SNo t) HmtV0). }
        claim Hmt_lt_q: Rlt (minus_SNo t) q.
        { exact (andER (~(Rlt (minus_SNo t) (p 1))) (Rlt (minus_SNo t) q) HmtV0prop). }
        claim Ht_lt_mq_lt: t < (minus_SNo q).
        { exact (RltE_lt t (minus_SNo q) Ht_lt_mq). }
        claim Hq_lt_mt: q < (minus_SNo t).
        { exact (minus_SNo_Lt_contra2 t q HtS HqS Ht_lt_mq_lt). }
        claim Hq_lt_mtR: Rlt q (minus_SNo t).
        { exact (RltI q (minus_SNo t) HqR HmtR Hq_lt_mt). }
        exact ((not_Rlt_sym q (minus_SNo t) Hq_lt_mtR) Hmt_lt_q). }
        witness (rectangle_set U0 V0).
        apply andI.
        - exact HbB.
        - apply andI.
          * exact Hpb.
          * exact HbSub.

    - (** case p1 = -p0: contradiction with p∉L, then close by FalseE **)
      assume Hyeq: (p 1) = (minus_SNo (p 0)).
      apply FalseE.
      (** show p ∈ L from the coordinates **)
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta R R p HpX). }
	      claim Htuple: (p 0, p 1) = (p 0, minus_SNo (p 0)).
	      { apply (tuple_2_ext (p 0) (p 1) (p 0) (minus_SNo (p 0))).
	        - reflexivity.
	        - exact Hyeq. }
      claim HptupleL: (p 0, p 1) :e L.
      { rewrite Htuple.
        exact (ReplI R (fun x0:set => (x0, minus_SNo x0)) (p 0) Hp0R). }
      claim HpL: p :e L.
      { rewrite HpEta.
        exact HptupleL. }
      exact (HpnotL HpL).

    - (** case -p0 < p1 **)
      assume Hlt: (minus_SNo (p 0)) < (p 1).
      claim HltR: Rlt (minus_SNo (p 0)) (p 1).
      { exact (RltI (minus_SNo (p 0)) (p 1) Hm0R Hp1R Hlt). }
      claim Hexq: exists q :e rational_numbers, Rlt (minus_SNo (p 0)) q /\ Rlt q (p 1).
      { exact (rational_dense_between_reals (minus_SNo (p 0)) (p 1) Hm0R Hp1R HltR). }
      apply Hexq.
      let q. assume Hqpair.
      claim HqQ: q :e rational_numbers.
      { exact (andEL (q :e rational_numbers) (Rlt (minus_SNo (p 0)) q /\ Rlt q (p 1)) Hqpair). }
      claim Hqprop: Rlt (minus_SNo (p 0)) q /\ Rlt q (p 1).
      { exact (andER (q :e rational_numbers) (Rlt (minus_SNo (p 0)) q /\ Rlt q (p 1)) Hqpair). }
      claim Hm0q: Rlt (minus_SNo (p 0)) q.
      { exact (andEL (Rlt (minus_SNo (p 0)) q) (Rlt q (p 1)) Hqprop). }
      claim Hqy: Rlt q (p 1).
      { exact (andER (Rlt (minus_SNo (p 0)) q) (Rlt q (p 1)) Hqprop). }
      claim HqR: q :e R.
      { exact (rational_numbers_in_R q HqQ). }
      claim HqS: SNo q.
      { exact (real_SNo q HqR). }
      claim Hy1R: (add_SNo (p 1) 1) :e R.
      { exact (real_add_SNo (p 1) Hp1R 1 real_1). }
      claim Hy1S: SNo (add_SNo (p 1) 1).
      { exact (real_SNo (add_SNo (p 1) 1) Hy1R). }
	      claim Hp1_lt_p11: (p 1) < (add_SNo (p 1) 1).
	      { rewrite <- (add_SNo_0R (p 1) Hp1S) at 1.
	        exact (add_SNo_Lt2 (p 1) 0 1 Hp1S SNo_0 SNo_1 SNoLt_0_1). }
      claim Hp1_lt_p11R: Rlt (p 1) (add_SNo (p 1) 1).
      { exact (RltI (p 1) (add_SNo (p 1) 1) Hp1R Hy1R Hp1_lt_p11). }
      claim Hq_lt_y1: Rlt q (add_SNo (p 1) 1).
      { exact (Rlt_tra q (p 1) (add_SNo (p 1) 1) Hqy Hp1_lt_p11R). }

	      set U0 := halfopen_interval_left (p 0) (add_SNo (p 0) 1).
	      set V0 := halfopen_interval_left q (add_SNo (p 1) 1).

      claim Hp01R: (add_SNo (p 0) 1) :e R.
      { exact (real_add_SNo (p 0) Hp0R 1 real_1). }
      claim Hp01S: SNo (add_SNo (p 0) 1).
      { exact (real_SNo (add_SNo (p 0) 1) Hp01R). }
	      claim Hp0_lt_p01: (p 0) < (add_SNo (p 0) 1).
	      { rewrite <- (add_SNo_0R (p 0) Hp0S) at 1.
	        exact (add_SNo_Lt2 (p 0) 0 1 Hp0S SNo_0 SNo_1 SNoLt_0_1). }
      claim Hp0_lt_p01R: Rlt (p 0) (add_SNo (p 0) 1).
      { exact (RltI (p 0) (add_SNo (p 0) 1) Hp0R Hp01R Hp0_lt_p01). }

      claim HU0T: U0 :e Sorgenfrey_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology (p 0) (add_SNo (p 0) 1) Hp0R Hp01R). }
      claim HV0T: V0 :e Sorgenfrey_topology.
      { exact (halfopen_interval_left_in_R_lower_limit_topology q (add_SNo (p 1) 1) HqR Hy1R). }
	      claim HbB: (rectangle_set U0 V0) :e B.
	      { prove (rectangle_set U0 V0) :e product_subbasis R R_lower_limit_topology R R_lower_limit_topology.
	        claim HbRepl: (rectangle_set U0 V0) :e {rectangle_set U0 V|V :e R_lower_limit_topology}.
	        { exact (ReplI R_lower_limit_topology (fun V:set => rectangle_set U0 V) V0 HV0T). }
	        exact (famunionI R_lower_limit_topology (fun Ux:set => {rectangle_set Ux V|V :e R_lower_limit_topology})
	                         U0 (rectangle_set U0 V0) HU0T HbRepl). }
      claim HpU0: (p 0) :e U0.
      { exact (halfopen_interval_left_leftmem (p 0) (add_SNo (p 0) 1) Hp0_lt_p01R). }
      claim HpV0: (p 1) :e V0.
      { (** q < p1 implies not(p1<q), so p1∈[q,p1+1) **)
        claim Hnlt: ~(Rlt (p 1) q).
        { exact (not_Rlt_sym q (p 1) Hqy). }
        claim Hp1V0prop: ~(Rlt (p 1) q) /\ Rlt (p 1) (add_SNo (p 1) 1).
        { apply andI.
          - exact Hnlt.
          - exact Hp1_lt_p11R. }
        exact (SepI R (fun v:set => ~(Rlt v q) /\ Rlt v (add_SNo (p 1) 1)) (p 1) Hp1R Hp1V0prop). }
	      claim Hpb: p :e rectangle_set U0 V0.
	      { claim HpEta: p = (p 0, p 1).
	        { exact (setprod_eta R R p HpX). }
	        rewrite HpEta at 1.
	        exact (tuple_2_rectangle_set U0 V0 (p 0) (p 1) HpU0 HpV0). }
	      claim HbSub: (rectangle_set U0 V0) c= U.
	      { let z. assume Hz: z :e rectangle_set U0 V0.
	        prove z :e U.
	        claim HzProd: z :e setprod U0 V0.
	        { rewrite <- rectangle_set_def.
	          exact Hz. }
	        claim HzX: z :e X.
	        { exact (setprod_Subq U0 V0 R R (halfopen_interval_left_Subq_R (p 0) (add_SNo (p 0) 1))
	                               (halfopen_interval_left_Subq_R q (add_SNo (p 1) 1))
	                               z HzProd). }
        apply setminusI X L z HzX.
        assume HzL: z :e L.
        claim Hext: exists t :e R, z = (t, minus_SNo t).
        { exact (ReplE R (fun t0:set => (t0, minus_SNo t0)) z HzL). }
        apply Hext.
        let t. assume Htpair.
        claim HtR: t :e R.
        { exact (andEL (t :e R) (z = (t, minus_SNo t)) Htpair). }
        claim Hzeq: z = (t, minus_SNo t).
        { exact (andER (t :e R) (z = (t, minus_SNo t)) Htpair). }
        claim HmtR: (minus_SNo t) :e R.
        { exact (real_minus_SNo t HtR). }
        claim HtS: SNo t.
        { exact (real_SNo t HtR). }
        claim HmtS: SNo (minus_SNo t).
        { exact (real_SNo (minus_SNo t) HmtR). }
        claim Hz0: z 0 = t.
        { rewrite Hzeq. exact (tuple_2_0_eq t (minus_SNo t)). }
        claim Hz1: z 1 = minus_SNo t.
        { rewrite Hzeq. exact (tuple_2_1_eq t (minus_SNo t)). }
	        claim Hz0U0: (z 0) :e U0.
	        { exact (ap0_Sigma U0 (fun _ : set => V0) z HzProd). }
	        claim Hz1V0: (z 1) :e V0.
	        { exact (ap1_Sigma U0 (fun _ : set => V0) z HzProd). }
        claim HtU0: t :e U0.
        { rewrite <- Hz0. exact Hz0U0. }
        claim HmtV0: (minus_SNo t) :e V0.
        { rewrite <- Hz1. exact Hz1V0. }
        claim HtU0prop: ~(Rlt t (p 0)) /\ Rlt t (add_SNo (p 0) 1).
        { exact (SepE2 R (fun u:set => ~(Rlt u (p 0)) /\ Rlt u (add_SNo (p 0) 1)) t HtU0). }
        claim Hnlt_tx: ~(Rlt t (p 0)).
        { exact (andEL (~(Rlt t (p 0))) (Rlt t (add_SNo (p 0) 1)) HtU0prop). }
        claim HmtV0prop: ~(Rlt (minus_SNo t) q) /\ Rlt (minus_SNo t) (add_SNo (p 1) 1).
        { exact (SepE2 R (fun v:set => ~(Rlt v q) /\ Rlt v (add_SNo (p 1) 1)) (minus_SNo t) HmtV0). }
        claim Hnlt_mt_q: ~(Rlt (minus_SNo t) q).
        { exact (andEL (~(Rlt (minus_SNo t) q)) (Rlt (minus_SNo t) (add_SNo (p 1) 1)) HmtV0prop). }
        (** show -t < q, contradicting ~( -t < q ) **)
        apply (SNoLt_trichotomy_or_impred (p 0) t Hp0S HtS False).
        - assume Hp0lt: (p 0) < t.
          claim Hmt_lt_m0: (minus_SNo t) < (minus_SNo (p 0)).
          { exact (minus_SNo_Lt_contra (p 0) t Hp0S HtS Hp0lt). }
          claim Hmt_m0: Rlt (minus_SNo t) (minus_SNo (p 0)).
          { exact (RltI (minus_SNo t) (minus_SNo (p 0)) HmtR Hm0R Hmt_lt_m0). }
          claim Hmt_q: Rlt (minus_SNo t) q.
          { exact (Rlt_tra (minus_SNo t) (minus_SNo (p 0)) q Hmt_m0 Hm0q). }
          exact (Hnlt_mt_q Hmt_q).
        - assume Heq0: (p 0) = t.
          claim Hmt_q: Rlt (minus_SNo t) q.
          { rewrite <- Heq0.
            exact Hm0q. }
          exact (Hnlt_mt_q Hmt_q).
        - assume Htlt: t < (p 0).
          claim Hr: Rlt t (p 0).
          { exact (RltI t (p 0) HtR Hp0R Htlt). }
          exact (FalseE (Hnlt_tx Hr) False). }
      witness (rectangle_set U0 V0).
      apply andI.
      - exact HbB.
      - apply andI.
        * exact Hpb.
        * exact HbSub.
  }
  exact (SepI (Power X) (fun U0:set => forall p0 :e U0, exists b :e B, p0 :e b /\ b c= U0) U HUpow HUloc). }

claim Hex: exists U0 :e Tx, L = X :\: U0.
{ witness U.
  apply andI.
  - exact HUinT.
  - prove L = X :\: U.
    (** U is X\\L, so X\\U = L since L ⊂ X **)
    prove L = X :\: (X :\: L).
    apply set_ext.
    + let p. assume HpL: p :e L.
      prove p :e X :\: (X :\: L).
      claim HpX: p :e X.
      { exact (HLsub p HpL). }
      apply setminusI X (X :\: L) p HpX.
      assume HpXL: p :e X :\: L.
      claim HpnotL: p /:e L.
      { exact (setminusE2 X L p HpXL). }
      exact (HpnotL HpL).
    + let p. assume Hp: p :e X :\: (X :\: L).
      prove p :e L.
      claim HpX: p :e X.
      { exact (setminusE1 X (X :\: L) p Hp). }
      claim HpnotXL: p /:e X :\: L.
      { exact (setminusE2 X (X :\: L) p Hp). }
      apply (xm (p :e L)).
      - assume HpL: p :e L.
        exact HpL.
      - assume HpnotL: p /:e L.
        claim HpXL: p :e X :\: L.
        { apply setminusI.
          - exact HpX.
          - exact HpnotL. }
        apply FalseE.
        exact (HpnotXL HpXL). }

exact (closed_inI X Tx L HTx HLsub Hex).
Qed.

(** from §30 Example 4: Sorgenfrey plane not Lindelof **)
(** LATEX VERSION: The Sorgenfrey plane is not Lindelöf. **)
Theorem Sorgenfrey_plane_not_Lindelof :
  ~ Lindelof_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove ~ Lindelof_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
assume HL: Lindelof_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove False.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                 exists V:set, countable_subcollection V U /\ covers X V)
               HL). }
claim HLind: forall U:set, open_cover X Tx U ->
  exists V:set, countable_subcollection V U /\ covers X V.
{ exact (andER (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                 exists V:set, countable_subcollection V U /\ covers X V)
               HL). }

(** define the standard open cover from the text **)
set L := Sorgenfrey_plane_L.
set Lcomp := X :\: L.
set FamSpec := (\/_ a :e R, \/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R}).
set Cover := {Lcomp} :\/: FamSpec.

claim Hcover_open: forall U:set, U :e Cover -> U :e Tx.
{ let U. assume HU: U :e Cover.
  apply (binunionE {Lcomp} FamSpec U HU).
  - assume HUs: U :e {Lcomp}.
    claim Heq: U = Lcomp.
    { exact (SingE Lcomp U HUs). }
    rewrite Heq.
    claim Hcl: closed_in X Tx L.
    { exact Sorgenfrey_plane_L_closed. }
    claim Hopen: open_in X Tx (X :\: L).
    { exact (open_of_closed_complement X Tx L Hcl). }
    exact (andER (topology_on X Tx) ((X :\: L) :e Tx) Hopen).
  - assume HUF: U :e FamSpec.
    claim Hexa: exists a :e R, U :e (\/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R}).
    { exact (famunionE R (fun a0:set => \/_ b :e R, {Sorgenfrey_plane_special_rectangle a0 b d|d :e R}) U HUF). }
    apply Hexa.
    let a. assume Hap: a :e R /\ U :e (\/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R}).
    claim HaR: a :e R.
    { exact (andEL (a :e R) (U :e (\/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R})) Hap). }
    claim HUin: U :e (\/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R}).
    { exact (andER (a :e R) (U :e (\/_ b :e R, {Sorgenfrey_plane_special_rectangle a b d|d :e R})) Hap). }
    claim Hexb: exists b :e R, U :e {Sorgenfrey_plane_special_rectangle a b d|d :e R}.
    { exact (famunionE R (fun b0:set => {Sorgenfrey_plane_special_rectangle a b0 d|d :e R}) U HUin). }
    apply Hexb.
    let b. assume Hbp: b :e R /\ U :e {Sorgenfrey_plane_special_rectangle a b d|d :e R}.
    claim HbR: b :e R.
    { exact (andEL (b :e R) (U :e {Sorgenfrey_plane_special_rectangle a b d|d :e R}) Hbp). }
    claim HUrepl: U :e {Sorgenfrey_plane_special_rectangle a b d|d :e R}.
    { exact (andER (b :e R) (U :e {Sorgenfrey_plane_special_rectangle a b d|d :e R}) Hbp). }
    claim Hexd: exists d :e R, U = Sorgenfrey_plane_special_rectangle a b d.
    { exact (ReplE R (fun d0:set => Sorgenfrey_plane_special_rectangle a b d0) U HUrepl). }
    apply Hexd.
    let d. assume Hdp: d :e R /\ U = Sorgenfrey_plane_special_rectangle a b d.
    claim HdR: d :e R.
    { exact (andEL (d :e R) (U = Sorgenfrey_plane_special_rectangle a b d) Hdp). }
    claim Heq: U = Sorgenfrey_plane_special_rectangle a b d.
    { exact (andER (d :e R) (U = Sorgenfrey_plane_special_rectangle a b d) Hdp). }
    rewrite Heq.
    exact (Sorgenfrey_plane_special_rectangle_open a b d HaR HbR HdR). }

claim Hcover_covers: covers X Cover.
{ let p. assume HpX: p :e X.
  apply (xm (p :e L)).
  - assume HpL: p :e L.
    (** pick x with p=(x,-x), then choose a basis rectangle about it **)
    claim Hexx: exists x :e R, p = (x, minus_SNo x).
    { exact (ReplE R (fun x0:set => (x0, minus_SNo x0)) p HpL). }
    apply Hexx.
    let x. assume Hxp: x :e R /\ p = (x, minus_SNo x).
    claim HxR: x :e R.
    { exact (andEL (x :e R) (p = (x, minus_SNo x)) Hxp). }
    claim Hpeq: p = (x, minus_SNo x).
    { exact (andER (x :e R) (p = (x, minus_SNo x)) Hxp). }
	set b := add_SNo x 1.
	set d := add_SNo (minus_SNo x) 1.
	claim HbR: b :e R.
	{ exact (real_add_SNo x HxR 1 real_1). }
	claim HdR: d :e R.
	{ exact (real_add_SNo (minus_SNo x) (real_minus_SNo x HxR) 1 real_1). }
    set U0 := Sorgenfrey_plane_special_rectangle x b d.
    claim HU0inFam: U0 :e FamSpec.
    { prove U0 :e (\/_ a :e R, \/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}).
      apply (famunionI R (fun a0:set => \/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a0 b0 d0|d0 :e R}) x).
      - exact HxR.
      - prove U0 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle x b0 d0|d0 :e R}).
        apply (famunionI R (fun b0:set => {Sorgenfrey_plane_special_rectangle x b0 d0|d0 :e R}) b).
        + exact HbR.
        + prove U0 :e {Sorgenfrey_plane_special_rectangle x b d0|d0 :e R}.
          exact (ReplI R (fun d0:set => Sorgenfrey_plane_special_rectangle x b d0) d HdR). }
	claim HU0inC: U0 :e Cover.
	{ exact (binunionI2 {Lcomp} FamSpec U0 HU0inFam). }
	claim HpU0: p :e U0.
	{ rewrite Hpeq.
	  claim HU0eq: U0 = rectangle_set (halfopen_interval_left x b) (halfopen_interval_left (minus_SNo x) d).
	  { reflexivity. }
	  rewrite HU0eq.
	  rewrite rectangle_set_def.
	  prove (x, minus_SNo x) :e setprod (halfopen_interval_left x b) (halfopen_interval_left (minus_SNo x) d).
	  apply tuple_2_setprod_by_pair_Sigma.
	  - claim HxS: SNo x.
	    { exact (real_SNo x HxR). }
	    claim Hx_lt_bS: x < b.
	    { rewrite <- (add_SNo_0R x HxS) at 1.
	      exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
	    claim Hx_lt_bR: Rlt x b.
	    { exact (RltI x b HxR HbR Hx_lt_bS). }
	    exact (halfopen_interval_left_leftmem x b Hx_lt_bR).
	  - claim HmxR: (minus_SNo x) :e R.
	    { exact (real_minus_SNo x HxR). }
	    claim HmxS: SNo (minus_SNo x).
	    { exact (real_SNo (minus_SNo x) HmxR). }
	    claim Hmx_lt_dS: (minus_SNo x) < d.
	    { rewrite <- (add_SNo_0R (minus_SNo x) HmxS) at 1.
	      exact (add_SNo_Lt2 (minus_SNo x) 0 1 HmxS SNo_0 SNo_1 SNoLt_0_1). }
	    claim Hmx_lt_dR: Rlt (minus_SNo x) d.
	    { exact (RltI (minus_SNo x) d HmxR HdR Hmx_lt_dS). }
	    exact (halfopen_interval_left_leftmem (minus_SNo x) d Hmx_lt_dR). }
    witness U0.
    apply andI.
    - exact HU0inC.
    - exact HpU0.
  - assume HpnotL: p /:e L.
    claim HpLcomp: p :e Lcomp.
    { apply setminusI.
      - exact HpX.
      - exact HpnotL. }
    claim HLcompC: Lcomp :e Cover.
    { exact (binunionI1 {Lcomp} FamSpec Lcomp (SingI Lcomp)). }
    witness Lcomp.
    apply andI.
    - exact HLcompC.
    - exact HpLcomp. }

claim Hcover: open_cover X Tx Cover.
{ prove (forall u:set, u :e Cover -> u :e Tx) /\ covers X Cover.
  apply andI.
  - exact Hcover_open.
  - exact Hcover_covers. }

claim HexV: exists V:set, countable_subcollection V Cover /\ covers X V.
{ exact (HLind Cover Hcover). }
apply HexV.
let V. assume HVp: countable_subcollection V Cover /\ covers X V.
claim HVcount: countable_subcollection V Cover.
{ exact (andEL (countable_subcollection V Cover) (covers X V) HVp). }
claim HVcov: covers X V.
{ exact (andER (countable_subcollection V Cover) (covers X V) HVp). }

(** define choice of a set in V covering each point of L, and show injective **)
set pick := fun x:set => Eps_i (fun U0:set => U0 :e V /\ (x, minus_SNo x) :e U0).

claim Hpick_spec: forall x:set, x :e R ->
  pick x :e V /\ (x, minus_SNo x) :e pick x.
{ let x. assume HxR: x :e R.
  claim HpxX: (x, minus_SNo x) :e X.
  { exact (tuple_2_setprod_by_pair_Sigma R R x (minus_SNo x) HxR (real_minus_SNo x HxR)). }
  claim Hp_in_cov: exists U0:set, U0 :e V /\ (x, minus_SNo x) :e U0.
  { exact (HVcov (x, minus_SNo x) HpxX). }
  apply Hp_in_cov.
  let U0. assume HU0pair: U0 :e V /\ (x, minus_SNo x) :e U0.
  exact (Eps_i_ax (fun U1:set => U1 :e V /\ (x, minus_SNo x) :e U1) U0 HU0pair). }

claim Hpick_inj: inj R V pick.
{ apply (injI R V pick).
  - let x. assume HxR: x :e R.
    exact (andEL (pick x :e V) ((x, minus_SNo x) :e pick x) (Hpick_spec x HxR)).
  - let x1. assume Hx1R: x1 :e R.
    let x2. assume Hx2R: x2 :e R.
    assume Heq: pick x1 = pick x2.
    prove x1 = x2.
    claim Hmem1: (x1, minus_SNo x1) :e pick x1.
    { exact (andER (pick x1 :e V) ((x1, minus_SNo x1) :e pick x1) (Hpick_spec x1 Hx1R)). }
	    claim Hmem2: (x2, minus_SNo x2) :e pick x2.
	    { exact (andER (pick x2 :e V) ((x2, minus_SNo x2) :e pick x2) (Hpick_spec x2 Hx2R)). }
	    claim Hmem1p: (x1, minus_SNo x1) :e pick x2.
	    { rewrite <- Heq at 1.
	      exact Hmem1. }
	    claim Hboth: (x1, minus_SNo x1) :e pick x2 /\ (x2, minus_SNo x2) :e pick x2.
	    { apply andI.
	      - exact Hmem1p.
	      - exact Hmem2. }
    claim HVsub: V c= Cover.
    { exact (andEL (V c= Cover) (countable_set V) HVcount). }
    claim HcoverU: pick x2 :e Cover.
    { apply HVsub.
      exact (andEL (pick x2 :e V) ((x2, minus_SNo x2) :e pick x2) (Hpick_spec x2 Hx2R)). }
    apply (binunionE {Lcomp} FamSpec (pick x2) HcoverU).
	    - assume Hsing: pick x2 :e {Lcomp}.
	      claim HeqL: pick x2 = Lcomp.
	      { exact (SingE Lcomp (pick x2) Hsing). }
	      apply FalseE.
	      claim Hmem2L: (x2, minus_SNo x2) :e Lcomp.
	      { rewrite <- HeqL at 1.
	        exact Hmem2. }
	      exact (setminusE2 X L (x2, minus_SNo x2) Hmem2L
	             (ReplI R (fun x0:set => (x0, minus_SNo x0)) x2 Hx2R)).
	    - assume Hfam: pick x2 :e FamSpec.
      claim Hexa: exists a :e R, pick x2 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}).
      { exact (famunionE R (fun a0:set => \/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a0 b0 d0|d0 :e R}) (pick x2) Hfam). }
      apply Hexa.
      let a. assume Hap: a :e R /\ pick x2 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}).
      claim HaR: a :e R.
      { exact (andEL (a :e R) (pick x2 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R})) Hap). }
      claim HUin: pick x2 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}).
      { exact (andER (a :e R) (pick x2 :e (\/_ b0 :e R, {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R})) Hap). }
      claim Hexb: exists b0 :e R, pick x2 :e {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}.
      { exact (famunionE R (fun b0:set => {Sorgenfrey_plane_special_rectangle a b0 d0|d0 :e R}) (pick x2) HUin). }
      apply Hexb.
      let b. assume Hbp: b :e R /\ pick x2 :e {Sorgenfrey_plane_special_rectangle a b d0|d0 :e R}.
      claim HbR2: b :e R.
      { exact (andEL (b :e R) (pick x2 :e {Sorgenfrey_plane_special_rectangle a b d0|d0 :e R}) Hbp). }
      claim HUrepl: pick x2 :e {Sorgenfrey_plane_special_rectangle a b d0|d0 :e R}.
      { exact (andER (b :e R) (pick x2 :e {Sorgenfrey_plane_special_rectangle a b d0|d0 :e R}) Hbp). }
      claim Hexd: exists d :e R, pick x2 = Sorgenfrey_plane_special_rectangle a b d.
      { exact (ReplE R (fun d0:set => Sorgenfrey_plane_special_rectangle a b d0) (pick x2) HUrepl). }
      apply Hexd.
      let d. assume Hdp: d :e R /\ pick x2 = Sorgenfrey_plane_special_rectangle a b d.
      claim HdR2: d :e R.
      { exact (andEL (d :e R) (pick x2 = Sorgenfrey_plane_special_rectangle a b d) Hdp). }
      claim HeqU: pick x2 = Sorgenfrey_plane_special_rectangle a b d.
      { exact (andER (d :e R) (pick x2 = Sorgenfrey_plane_special_rectangle a b d) Hdp). }
	      claim Hp1inPick: (x1, minus_SNo x1) :e pick x2.
	      { exact (andEL ((x1, minus_SNo x1) :e pick x2) ((x2, minus_SNo x2) :e pick x2) Hboth). }
	      claim Hp1inRect: (x1, minus_SNo x1) :e Sorgenfrey_plane_special_rectangle a b d.
	      { rewrite <- HeqU at 1.
	        exact Hp1inPick. }
	      claim Hp2inRect: (x2, minus_SNo x2) :e Sorgenfrey_plane_special_rectangle a b d.
	      { rewrite <- HeqU at 1.
	        exact Hmem2. }
	      claim Hx1eq: x1 = a.
	      { exact (Sorgenfrey_plane_special_rectangle_L_point a b d x1 HaR HbR2 HdR2 Hx1R Hp1inRect). }
	      claim Hx2eq: x2 = a.
	      { exact (Sorgenfrey_plane_special_rectangle_L_point a b d x2 HaR HbR2 HdR2 Hx2R Hp2inRect). }
	      rewrite Hx1eq.
	      rewrite Hx2eq.
	      reflexivity.
} 

claim HinjRV: atleastp R V.
{ prove exists f : set -> set, inj R V f.
  witness pick.
  exact Hpick_inj. }
claim HVOmega: atleastp V omega.
{ claim HcountV: countable_set V.
  { exact (andER (V c= Cover) (countable_set V) HVcount). }
  exact HcountV. }
claim HcountR: atleastp R omega.
{ exact (atleastp_tra R V omega HinjRV HVOmega). }
exact (form100_22_real_uncountable_atleastp HcountR).
Qed.

(** from §30 Example 5: subspace of Lindelöf space need not be Lindelöf **) 
(** LATEX VERSION: A subspace of a Lindelöf space can fail to be Lindelöf (ordered square strip example). **)
Theorem ordered_square_subspace_not_Lindelof :
  Lindelof_space ordered_square ordered_square_topology /\
  ~ Lindelof_space ordered_square_open_strip ordered_square_subspace_topology.
prove Lindelof_space ordered_square ordered_square_topology /\ ~ Lindelof_space ordered_square_open_strip ordered_square_subspace_topology.
admit. (** FAIL **)
Qed.

(** from §31 Lemma 31.1: closure-neighborhood reformulations of regular/normal **) 
(** LATEX VERSION: Lemma 31.1: characterizations of regular/normal via closures and neighborhoods (assuming T1). **)
Theorem regular_normal_via_closure : forall X Tx:set,
  topology_on X Tx ->
  (one_point_sets_closed X Tx -> (regular_space X Tx <->
     forall x U:set, x :e X -> U :e Tx -> x :e U -> exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U)) /\
  (one_point_sets_closed X Tx -> (normal_space X Tx <->
     forall A U:set, closed_in X Tx A -> U :e Tx -> A c= U -> exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U)).
let X Tx.
assume HTx: topology_on X Tx.
prove (one_point_sets_closed X Tx -> (regular_space X Tx <->
     forall x U:set, x :e X -> U :e Tx -> x :e U -> exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U)) /\
  (one_point_sets_closed X Tx -> (normal_space X Tx <->
     forall A U:set, closed_in X Tx A -> U :e Tx -> A c= U -> exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U)).
apply andI.
- (** Regular part **)
  assume HT1: one_point_sets_closed X Tx.
  prove regular_space X Tx <->
       forall x U:set, x :e X -> U :e Tx -> x :e U ->
         exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U.
  apply iffI.
  * assume Hreg: regular_space X Tx.
    prove forall x U:set, x :e X -> U :e Tx -> x :e U ->
         exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U.
    claim HSepReg:
      forall x:set, x :e X ->
        forall F:set, closed_in X Tx F -> x /:e F ->
          exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
    { exact (andER (one_point_sets_closed X Tx)
                   (forall x:set, x :e X ->
                     forall F:set, closed_in X Tx F -> x /:e F ->
                       exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
                   Hreg). }
    let x U.
    assume HxX: x :e X.
    assume HU: U :e Tx.
    assume HxU: x :e U.
    set B := X :\: U.
    claim HBcl: closed_in X Tx B.
    { exact (closed_of_open_complement X Tx U HTx HU). }
    claim HxnotB: x /:e B.
    { assume HxB: x :e B.
      claim HxnotU: x /:e U.
      { exact (setminusE2 X U x HxB). }
      exact (HxnotU HxU). }
    claim Hex: exists V W:set, V :e Tx /\ W :e Tx /\ x :e V /\ B c= W /\ V :/\: W = Empty.
    { exact (HSepReg x HxX B HBcl HxnotB). }
    set V0 := Eps_i (fun V:set => exists W:set, V :e Tx /\ W :e Tx /\ x :e V /\ B c= W /\ V :/\: W = Empty).
    claim HV0ex: exists W:set, V0 :e Tx /\ W :e Tx /\ x :e V0 /\ B c= W /\ V0 :/\: W = Empty.
    { exact (Eps_i_ex (fun V:set => exists W:set, V :e Tx /\ W :e Tx /\ x :e V /\ B c= W /\ V :/\: W = Empty) Hex). }
    set W0 := Eps_i (fun W:set => V0 :e Tx /\ W :e Tx /\ x :e V0 /\ B c= W /\ V0 :/\: W = Empty).
    claim HW0prop: V0 :e Tx /\ W0 :e Tx /\ x :e V0 /\ B c= W0 /\ V0 :/\: W0 = Empty.
    { exact (Eps_i_ex (fun W:set => V0 :e Tx /\ W :e Tx /\ x :e V0 /\ B c= W /\ V0 :/\: W = Empty)
                      HV0ex). }
    claim H1234: (((V0 :e Tx /\ W0 :e Tx) /\ x :e V0) /\ B c= W0).
    { exact (andEL ((((V0 :e Tx /\ W0 :e Tx) /\ x :e V0) /\ B c= W0))
                   (V0 :/\: W0 = Empty)
                   HW0prop). }
    claim HdisjVW: V0 :/\: W0 = Empty.
    { exact (andER ((((V0 :e Tx /\ W0 :e Tx) /\ x :e V0) /\ B c= W0))
                   (V0 :/\: W0 = Empty)
                   HW0prop). }
    claim H123: ((V0 :e Tx /\ W0 :e Tx) /\ x :e V0).
    { exact (andEL ((V0 :e Tx /\ W0 :e Tx) /\ x :e V0) (B c= W0) H1234). }
    claim H12: (V0 :e Tx /\ W0 :e Tx).
    { exact (andEL (V0 :e Tx /\ W0 :e Tx) (x :e V0) H123). }
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (W0 :e Tx) H12). }
    claim HW0Tx: W0 :e Tx.
    { exact (andER (V0 :e Tx) (W0 :e Tx) H12). }
    claim HxV0: x :e V0.
    { exact (andER (V0 :e Tx /\ W0 :e Tx) (x :e V0) H123). }
    claim HBsubW0: B c= W0.
    { exact (andER ((V0 :e Tx /\ W0 :e Tx) /\ x :e V0) (B c= W0) H1234). }
    claim HdisjWV: W0 :/\: V0 = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e W0 :/\: V0.
      prove z :e Empty.
      claim HzW: z :e W0.
      { exact (binintersectE1 W0 V0 z Hz). }
      claim HzV: z :e V0.
      { exact (binintersectE2 W0 V0 z Hz). }
      claim HzVW: z :e V0 :/\: W0.
      { exact (binintersectI V0 W0 z HzV HzW). }
      claim HzE: z :e Empty.
      { rewrite <- HdisjVW. exact HzVW. }
      exact HzE. }
	    claim HclV0subU: closure_of X Tx V0 c= U.
	    { let z. assume Hzcl: z :e closure_of X Tx V0.
	      prove z :e U.
	      claim HzX: z :e X.
	      { exact (SepE1 X (fun z0:set => forall N:set, N :e Tx -> z0 :e N -> N :/\: V0 <> Empty) z Hzcl). }
	      apply xm (z :e U).
	      - assume HzU: z :e U.
	        exact HzU.
	      - assume HznotU: z /:e U.
	        claim HzB: z :e B.
	        { exact (setminusI X U z HzX HznotU). }
	        claim HzW0: z :e W0.
	        { exact (HBsubW0 z HzB). }
	        claim Hcliff: z :e closure_of X Tx V0 <-> (forall N :e Tx, z :e N -> N :/\: V0 <> Empty).
	        { exact (closure_characterization X Tx V0 z HTx HzX). }
	        claim Hneigh: forall N :e Tx, z :e N -> N :/\: V0 <> Empty.
	        { exact (iffEL (z :e closure_of X Tx V0)
	                       (forall N :e Tx, z :e N -> N :/\: V0 <> Empty)
	                       Hcliff Hzcl). }
	        claim Hcontr: W0 :/\: V0 <> Empty.
	        { exact (Hneigh W0 HW0Tx HzW0). }
	        apply FalseE.
	        exact (Hcontr HdisjWV). }
	    witness V0.
	    apply andI.
	    - apply andI.
	      + exact HV0Tx.
      + exact HxV0.
    - exact HclV0subU.
  * assume Hcrit:
      forall x U:set, x :e X -> U :e Tx -> x :e U ->
        exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U.
    prove regular_space X Tx.
    prove one_point_sets_closed X Tx /\
         forall x:set, x :e X ->
           forall F:set, closed_in X Tx F -> x /:e F ->
             exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
    apply andI.
    - exact HT1.
    - let x. assume HxX: x :e X.
      let F. assume HFcl: closed_in X Tx F.
      assume HxnotF: x /:e F.
      prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
      set U0 := X :\: F.
      claim Hop0: open_in X Tx U0.
      { exact (open_of_closed_complement X Tx F HFcl). }
      claim HU0Tx: U0 :e Tx.
      { exact (andER (topology_on X Tx) (U0 :e Tx) Hop0). }
      claim HxU0: x :e U0.
      { exact (setminusI X F x HxX HxnotF). }
      claim HexV: exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U0.
      { exact (Hcrit x U0 HxX HU0Tx HxU0). }
      set V0 := Eps_i (fun V:set => V :e Tx /\ x :e V /\ closure_of X Tx V c= U0).
	      claim HV0prop: V0 :e Tx /\ x :e V0 /\ closure_of X Tx V0 c= U0.
	      { exact (Eps_i_ex (fun V:set => V :e Tx /\ x :e V /\ closure_of X Tx V c= U0) HexV). }
	      claim HV0TxHx: V0 :e Tx /\ x :e V0.
	      { exact (andEL (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0prop). }
	      claim HV0Tx: V0 :e Tx.
	      { exact (andEL (V0 :e Tx) (x :e V0) HV0TxHx). }
	      claim HxV0: x :e V0.
	      { exact (andER (V0 :e Tx) (x :e V0) HV0TxHx). }
	      claim Hclsub: closure_of X Tx V0 c= U0.
	      { exact (andER (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0prop). }
      claim HTsub: Tx c= Power X.
      { exact (topology_subset_axiom X Tx HTx). }
      claim HV0subX: V0 c= X.
      { exact (PowerE X V0 (HTsub V0 HV0Tx)). }
      claim HclV0cl: closed_in X Tx (closure_of X Tx V0).
      { exact (closure_is_closed X Tx V0 HTx HV0subX). }
      set W0 := X :\: closure_of X Tx V0.
      claim HopW: open_in X Tx W0.
      { exact (open_of_closed_complement X Tx (closure_of X Tx V0) HclV0cl). }
      claim HW0Tx: W0 :e Tx.
      { exact (andER (topology_on X Tx) (W0 :e Tx) HopW). }
	      claim HFsubW0: F c= W0.
	      { let z. assume HzF: z :e F.
	        prove z :e W0.
	        claim HFsubX: F c= X.
	        { exact (closed_in_subset X Tx F HFcl). }
	        claim HzX: z :e X.
	        { exact (HFsubX z HzF). }
	        apply xm (z :e closure_of X Tx V0).
	        - assume Hzcl: z :e closure_of X Tx V0.
	          claim HzU0: z :e U0.
	          { exact (Hclsub z Hzcl). }
	          claim HznotF2: z /:e F.
	          { exact (setminusE2 X F z HzU0). }
	          apply FalseE.
	          exact (HznotF2 HzF).
	        - assume Hznotcl: z /:e closure_of X Tx V0.
	          exact (setminusI X (closure_of X Tx V0) z HzX Hznotcl).
	        }
      claim HVsubcl: V0 c= closure_of X Tx V0.
      { exact (subset_of_closure X Tx V0 HTx HV0subX). }
      claim Hdisj: V0 :/\: W0 = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e V0 :/\: W0.
        prove z :e Empty.
        claim HzV: z :e V0.
        { exact (binintersectE1 V0 W0 z Hz). }
        claim HzW: z :e W0.
        { exact (binintersectE2 V0 W0 z Hz). }
        claim Hzcl: z :e closure_of X Tx V0.
        { exact (HVsubcl z HzV). }
        claim Hznotcl: z /:e closure_of X Tx V0.
        { exact (setminusE2 X (closure_of X Tx V0) z HzW). }
        apply FalseE.
        exact (Hznotcl Hzcl). }
      witness V0.
      witness W0.
      apply andI.
      - apply andI.
        + apply andI.
          * apply andI.
            { exact HV0Tx. }
            { exact HW0Tx. }
          * exact HxV0.
        + exact HFsubW0.
      - exact Hdisj.

- (** Normal part **)
  assume HT1: one_point_sets_closed X Tx.
  prove normal_space X Tx <->
       forall A U:set, closed_in X Tx A -> U :e Tx -> A c= U ->
         exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U.
  apply iffI.
  * assume Hnorm: normal_space X Tx.
    prove forall A U:set, closed_in X Tx A -> U :e Tx -> A c= U ->
         exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U.
    claim HSepNorm:
      forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
        exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
    { exact (andER (one_point_sets_closed X Tx)
                   (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                     exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                   Hnorm). }
    let A U.
    assume HAcl: closed_in X Tx A.
    assume HU: U :e Tx.
    assume HAsubU: A c= U.
    set B := X :\: U.
    claim HBcl: closed_in X Tx B.
    { exact (closed_of_open_complement X Tx U HTx HU). }
    claim HABdisj: A :/\: B = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e A :/\: B.
      prove z :e Empty.
      claim HzA: z :e A.
      { exact (binintersectE1 A B z Hz). }
      claim HzB: z :e B.
      { exact (binintersectE2 A B z Hz). }
      claim HzU: z :e U.
      { exact (HAsubU z HzA). }
      claim HznotU: z /:e U.
      { exact (setminusE2 X U z HzB). }
      apply FalseE.
      exact (HznotU HzU). }
    claim Hex: exists V W:set, V :e Tx /\ W :e Tx /\ A c= V /\ B c= W /\ V :/\: W = Empty.
    { exact (HSepNorm A B HAcl HBcl HABdisj). }
    set V0 := Eps_i (fun V:set => exists W:set, V :e Tx /\ W :e Tx /\ A c= V /\ B c= W /\ V :/\: W = Empty).
    claim HV0ex: exists W:set, V0 :e Tx /\ W :e Tx /\ A c= V0 /\ B c= W /\ V0 :/\: W = Empty.
    { exact (Eps_i_ex (fun V:set => exists W:set, V :e Tx /\ W :e Tx /\ A c= V /\ B c= W /\ V :/\: W = Empty) Hex). }
    set W0 := Eps_i (fun W:set => V0 :e Tx /\ W :e Tx /\ A c= V0 /\ B c= W /\ V0 :/\: W = Empty).
    claim HW0prop: V0 :e Tx /\ W0 :e Tx /\ A c= V0 /\ B c= W0 /\ V0 :/\: W0 = Empty.
    { exact (Eps_i_ex (fun W:set => V0 :e Tx /\ W :e Tx /\ A c= V0 /\ B c= W /\ V0 :/\: W = Empty)
                      HV0ex). }
    claim H1234: (((V0 :e Tx /\ W0 :e Tx) /\ A c= V0) /\ B c= W0).
    { exact (andEL ((((V0 :e Tx /\ W0 :e Tx) /\ A c= V0) /\ B c= W0))
                   (V0 :/\: W0 = Empty)
                   HW0prop). }
    claim HdisjVW: V0 :/\: W0 = Empty.
    { exact (andER ((((V0 :e Tx /\ W0 :e Tx) /\ A c= V0) /\ B c= W0))
                   (V0 :/\: W0 = Empty)
                   HW0prop). }
    claim H123: ((V0 :e Tx /\ W0 :e Tx) /\ A c= V0).
    { exact (andEL ((V0 :e Tx /\ W0 :e Tx) /\ A c= V0) (B c= W0) H1234). }
    claim H12: (V0 :e Tx /\ W0 :e Tx).
    { exact (andEL (V0 :e Tx /\ W0 :e Tx) (A c= V0) H123). }
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (W0 :e Tx) H12). }
    claim HW0Tx: W0 :e Tx.
    { exact (andER (V0 :e Tx) (W0 :e Tx) H12). }
    claim HAsubV0: A c= V0.
    { exact (andER (V0 :e Tx /\ W0 :e Tx) (A c= V0) H123). }
    claim HBsubW0: B c= W0.
    { exact (andER ((V0 :e Tx /\ W0 :e Tx) /\ A c= V0) (B c= W0) H1234). }
    claim HdisjWV: W0 :/\: V0 = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e W0 :/\: V0.
      prove z :e Empty.
      claim HzW: z :e W0.
      { exact (binintersectE1 W0 V0 z Hz). }
      claim HzV: z :e V0.
      { exact (binintersectE2 W0 V0 z Hz). }
      claim HzVW: z :e V0 :/\: W0.
      { exact (binintersectI V0 W0 z HzV HzW). }
      claim HzE: z :e Empty.
      { rewrite <- HdisjVW. exact HzVW. }
      exact HzE. }
	    claim HclV0subU: closure_of X Tx V0 c= U.
	    { let z. assume Hzcl: z :e closure_of X Tx V0.
	      prove z :e U.
	      claim HzX: z :e X.
	      { exact (SepE1 X (fun z0:set => forall N:set, N :e Tx -> z0 :e N -> N :/\: V0 <> Empty) z Hzcl). }
	      apply xm (z :e U).
	      - assume HzU: z :e U.
	        exact HzU.
	      - assume HznotU: z /:e U.
	        claim HzB: z :e B.
	        { exact (setminusI X U z HzX HznotU). }
	        claim HzW0: z :e W0.
	        { exact (HBsubW0 z HzB). }
	        claim Hcliff: z :e closure_of X Tx V0 <-> (forall N :e Tx, z :e N -> N :/\: V0 <> Empty).
	        { exact (closure_characterization X Tx V0 z HTx HzX). }
	        claim Hneigh: forall N :e Tx, z :e N -> N :/\: V0 <> Empty.
	        { exact (iffEL (z :e closure_of X Tx V0)
	                       (forall N :e Tx, z :e N -> N :/\: V0 <> Empty)
	                       Hcliff Hzcl). }
	        claim Hcontr: W0 :/\: V0 <> Empty.
	        { exact (Hneigh W0 HW0Tx HzW0). }
	        apply FalseE.
	        exact (Hcontr HdisjWV). }
	    witness V0.
	    apply andI.
	    - apply andI.
      + exact HV0Tx.
      + exact HAsubV0.
    - exact HclV0subU.
  * assume Hcrit:
      forall A U:set, closed_in X Tx A -> U :e Tx -> A c= U ->
        exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U.
    prove normal_space X Tx.
    prove one_point_sets_closed X Tx /\
         forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
           exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
    apply andI.
    - exact HT1.
    - let A. let B.
      assume HAcl: closed_in X Tx A.
      assume HBcl: closed_in X Tx B.
      assume Hdisj: A :/\: B = Empty.
      prove exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
      set U0 := X :\: B.
      claim Hop0: open_in X Tx U0.
      { exact (open_of_closed_complement X Tx B HBcl). }
      claim HU0Tx: U0 :e Tx.
      { exact (andER (topology_on X Tx) (U0 :e Tx) Hop0). }
	      claim HAsubU0: A c= U0.
	      { let z. assume HzA: z :e A.
	        prove z :e U0.
	        claim HAsubX: A c= X.
	        { exact (closed_in_subset X Tx A HAcl). }
	        claim HzX: z :e X.
	        { exact (HAsubX z HzA). }
	        apply xm (z :e B).
	        - assume HzB: z :e B.
	          claim HzAB: z :e A :/\: B.
	          { exact (binintersectI A B z HzA HzB). }
	          claim HzE: z :e Empty.
	          { rewrite <- Hdisj. exact HzAB. }
	          apply FalseE.
	          exact (EmptyE z HzE False).
	        - assume HznotB: z /:e B.
	          exact (setminusI X B z HzX HznotB). }
      claim HexV: exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U0.
      { exact (Hcrit A U0 HAcl HU0Tx HAsubU0). }
	      set V0 := Eps_i (fun V:set => V :e Tx /\ A c= V /\ closure_of X Tx V c= U0).
	      claim HV0prop: V0 :e Tx /\ A c= V0 /\ closure_of X Tx V0 c= U0.
	      { exact (Eps_i_ex (fun V:set => V :e Tx /\ A c= V /\ closure_of X Tx V c= U0) HexV). }
	      claim HV0TxHA: V0 :e Tx /\ A c= V0.
	      { exact (andEL (V0 :e Tx /\ A c= V0) (closure_of X Tx V0 c= U0) HV0prop). }
	      claim HV0Tx: V0 :e Tx.
	      { exact (andEL (V0 :e Tx) (A c= V0) HV0TxHA). }
	      claim HAsubV0: A c= V0.
	      { exact (andER (V0 :e Tx) (A c= V0) HV0TxHA). }
	      claim Hclsub: closure_of X Tx V0 c= U0.
	      { exact (andER (V0 :e Tx /\ A c= V0) (closure_of X Tx V0 c= U0) HV0prop). }
      claim HTsub: Tx c= Power X.
      { exact (topology_subset_axiom X Tx HTx). }
      claim HV0subX: V0 c= X.
      { exact (PowerE X V0 (HTsub V0 HV0Tx)). }
      claim HclV0cl: closed_in X Tx (closure_of X Tx V0).
      { exact (closure_is_closed X Tx V0 HTx HV0subX). }
      set W0 := X :\: closure_of X Tx V0.
      claim HopW: open_in X Tx W0.
      { exact (open_of_closed_complement X Tx (closure_of X Tx V0) HclV0cl). }
      claim HW0Tx: W0 :e Tx.
      { exact (andER (topology_on X Tx) (W0 :e Tx) HopW). }
	      claim HBsubW0: B c= W0.
	      { let z. assume HzB: z :e B.
	        prove z :e W0.
	        claim HBsubX: B c= X.
	        { exact (closed_in_subset X Tx B HBcl). }
	        claim HzX: z :e X.
	        { exact (HBsubX z HzB). }
	        apply xm (z :e closure_of X Tx V0).
	        - assume Hzcl: z :e closure_of X Tx V0.
	          claim HzU0: z :e U0.
	          { exact (Hclsub z Hzcl). }
	          claim HznotB: z /:e B.
	          { exact (setminusE2 X B z HzU0). }
	          apply FalseE.
	          exact (HznotB HzB).
	        - assume Hznotcl: z /:e closure_of X Tx V0.
	          exact (setminusI X (closure_of X Tx V0) z HzX Hznotcl). }
      claim HVsubcl: V0 c= closure_of X Tx V0.
      { exact (subset_of_closure X Tx V0 HTx HV0subX). }
      claim HdisjVW: V0 :/\: W0 = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e V0 :/\: W0.
        prove z :e Empty.
        claim HzV: z :e V0.
        { exact (binintersectE1 V0 W0 z Hz). }
        claim HzW: z :e W0.
        { exact (binintersectE2 V0 W0 z Hz). }
        claim Hzcl: z :e closure_of X Tx V0.
        { exact (HVsubcl z HzV). }
        claim Hznotcl: z /:e closure_of X Tx V0.
        { exact (setminusE2 X (closure_of X Tx V0) z HzW). }
        apply FalseE.
        exact (Hznotcl Hzcl). }
		      witness V0.
		      witness W0.
		      apply andI.
		      - apply andI.
		        + apply andI.
		          - apply andI.
		            + exact HV0Tx.
		            + exact HW0Tx.
		          - exact HAsubV0.
		        + exact HBsubW0.
		      - exact HdisjVW.
	Qed.

	(** Helper: regular spaces admit closure-shrinking neighborhoods (used in product regularity proofs). **)
		Theorem regular_space_shrink_neighborhood : forall X Tx x U:set,
		  regular_space X Tx ->
		  x :e X ->
		  U :e Tx ->
		  x :e U ->
		  exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U.
	let X Tx x U.
	assume Hreg: regular_space X Tx.
	assume HxX: x :e X.
	assume HU: U :e Tx.
	assume HxU: x :e U.
	prove exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= U.
	claim HT1: one_point_sets_closed X Tx.
	{ exact (andEL (one_point_sets_closed X Tx)
	               (forall x0:set, x0 :e X ->
	                 forall F:set, closed_in X Tx F -> x0 /:e F ->
	                   exists U0 V0:set, U0 :e Tx /\ V0 :e Tx /\ x0 :e U0 /\ F c= V0 /\ U0 :/\: V0 = Empty)
	               Hreg). }
	claim HTx: topology_on X Tx.
	{ exact (andEL (topology_on X Tx)
	               (forall x0:set, x0 :e X -> closed_in X Tx {x0})
	               HT1). }
	claim Hlemma: one_point_sets_closed X Tx ->
	  (regular_space X Tx <->
	     forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
	       exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0).
	{ exact (andEL (one_point_sets_closed X Tx -> (regular_space X Tx <->
	             forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
	               exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0))
	           (one_point_sets_closed X Tx -> (normal_space X Tx <->
	             forall A U0:set, closed_in X Tx A -> U0 :e Tx -> A c= U0 ->
	               exists V0:set, V0 :e Tx /\ A c= V0 /\ closure_of X Tx V0 c= U0))
	           (regular_normal_via_closure X Tx HTx)). }
	claim Hiff: regular_space X Tx <->
	  forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
	    exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0.
	{ exact (Hlemma HT1). }
	claim Hcrit:
	  forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
	    exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0.
	{ exact (iffEL (regular_space X Tx)
	               (forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
	                  exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0)
	               Hiff Hreg). }
		exact (Hcrit x U HxX HU HxU).
		Qed.

		(** Helper: normal spaces admit closure-shrinking open neighborhoods of closed subsets. **)
		(** LATEX VERSION: If X is normal and A is closed with A ⊆ U (U open), then there exists open V with A ⊆ V and closure(V) ⊆ U. **)
		Theorem normal_space_shrink_closed : forall X Tx A U:set,
		  normal_space X Tx ->
		  closed_in X Tx A ->
		  U :e Tx ->
		  A c= U ->
		  exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U.
		let X Tx A U.
		assume Hnorm: normal_space X Tx.
		assume HAcl: closed_in X Tx A.
		assume HU: U :e Tx.
		assume HAU: A c= U.
		prove exists V:set, V :e Tx /\ A c= V /\ closure_of X Tx V c= U.
		claim HT1: one_point_sets_closed X Tx.
		{ exact (andEL (one_point_sets_closed X Tx)
		               (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
		                 exists U0 V0:set, U0 :e Tx /\ V0 :e Tx /\ A0 c= U0 /\ B0 c= V0 /\ U0 :/\: V0 = Empty)
		               Hnorm). }
		claim HTx: topology_on X Tx.
		{ exact (andEL (topology_on X Tx)
		               (forall x0:set, x0 :e X -> closed_in X Tx {x0})
		               HT1). }
		claim Hlemma:
		  one_point_sets_closed X Tx ->
		  (normal_space X Tx <->
		     forall A0 U0:set, closed_in X Tx A0 -> U0 :e Tx -> A0 c= U0 ->
		       exists V0:set, V0 :e Tx /\ A0 c= V0 /\ closure_of X Tx V0 c= U0).
		{ exact (andER (one_point_sets_closed X Tx -> (regular_space X Tx <->
		             forall x0 U0:set, x0 :e X -> U0 :e Tx -> x0 :e U0 ->
		               exists V0:set, V0 :e Tx /\ x0 :e V0 /\ closure_of X Tx V0 c= U0))
		           (one_point_sets_closed X Tx -> (normal_space X Tx <->
		             forall A0 U0:set, closed_in X Tx A0 -> U0 :e Tx -> A0 c= U0 ->
		               exists V0:set, V0 :e Tx /\ A0 c= V0 /\ closure_of X Tx V0 c= U0))
		           (regular_normal_via_closure X Tx HTx)). }
		claim Hiff:
		  normal_space X Tx <->
		  forall A0 U0:set, closed_in X Tx A0 -> U0 :e Tx -> A0 c= U0 ->
		    exists V0:set, V0 :e Tx /\ A0 c= V0 /\ closure_of X Tx V0 c= U0.
		{ exact (Hlemma HT1). }
		claim Hcrit:
		  forall A0 U0:set, closed_in X Tx A0 -> U0 :e Tx -> A0 c= U0 ->
		    exists V0:set, V0 :e Tx /\ A0 c= V0 /\ closure_of X Tx V0 c= U0.
		{ exact (iffEL (normal_space X Tx)
		               (forall A0 U0:set, closed_in X Tx A0 -> U0 :e Tx -> A0 c= U0 ->
		                 exists V0:set, V0 :e Tx /\ A0 c= V0 /\ closure_of X Tx V0 c= U0)
		               Hiff Hnorm). }
		exact (Hcrit A U HAcl HU HAU).
		Qed.

(** Helper: product of regular spaces is regular (binary product topology). **)
(** LATEX VERSION: The product of regular spaces is regular (Theorem 31.2, product clause). **)
Theorem product_topology_regular : forall X Tx Y Ty:set,
  regular_space X Tx -> regular_space Y Ty ->
  regular_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HregX: regular_space X Tx.
assume HregY: regular_space Y Ty.
set Z := setprod X Y.
set Tz := product_topology X Tx Y Ty.
prove regular_space Z Tz.
claim HTx: topology_on X Tx.
{ exact (regular_space_topology_on X Tx HregX). }
claim HTy: topology_on Y Ty.
{ exact (regular_space_topology_on Y Ty HregY). }
claim HTz: topology_on Z Tz.
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }

(** one_point_sets_closed for the product via Hausdorff **)
claim Hhx: Hausdorff_space X Tx.
{ exact (regular_space_implies_Hausdorff X Tx HregX). }
claim Hhy: Hausdorff_space Y Ty.
{ exact (regular_space_implies_Hausdorff Y Ty HregY). }
claim Hhz: Hausdorff_space Z Tz.
{ exact (ex17_11_product_Hausdorff X Tx Y Ty Hhx Hhy). }
claim HT1z: one_point_sets_closed Z Tz.
{ prove topology_on Z Tz /\ forall p:set, p :e Z -> closed_in Z Tz {p}.
  apply andI.
  - exact (Hausdorff_space_topology Z Tz Hhz).
  - let p. assume HpZ: p :e Z.
    exact (Hausdorff_singletons_closed Z Tz p Hhz HpZ). }

(** closure-neighborhood characterization of regularity in the product **)
claim Hclosure_prop:
  forall p U:set, p :e Z -> U :e Tz -> p :e U ->
    exists V:set, V :e Tz /\ p :e V /\ closure_of Z Tz V c= U.
{ let p U.
  assume HpZ: p :e Z.
  assume HU: U :e Tz.
  assume HpU: p :e U.
  (** refine U at p by a basic rectangle b = U0×V0 **)
  claim Hexb: exists b :e product_subbasis X Tx Y Ty, p :e b /\ b c= U.
  { exact (generated_topology_local_refine Z (product_subbasis X Tx Y Ty) U p HU HpU). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB: b :e product_subbasis X Tx Y Ty.
  { exact (andEL (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair). }
  claim Hpb: p :e b.
  { exact (andEL (p :e b) (b c= U) (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair)). }
  claim HbsubU: b c= U.
  { exact (andER (p :e b) (b c= U) (andER (b :e product_subbasis X Tx Y Ty) (p :e b /\ b c= U) Hbpair)). }

  (** write b as a rectangle_set U0 V0 with U0∈Tx and V0∈Ty **)
  claim HexU0: exists U0 :e Tx, b :e {rectangle_set U0 V|V :e Ty}.
  { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbB). }
  apply HexU0.
  let U0. assume HU0pair.
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0pair). }
  claim HbFam: b :e {rectangle_set U0 V|V :e Ty}.
  { exact (andER (U0 :e Tx) (b :e {rectangle_set U0 V|V :e Ty}) HU0pair). }
  claim HexV0: exists V0 :e Ty, b = rectangle_set U0 V0.
  { exact (ReplE Ty (fun V0:set => rectangle_set U0 V0) b HbFam). }
  apply HexV0.
  let V0. assume HV0pair.
  claim HV0Ty: V0 :e Ty.
  { exact (andEL (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }
  claim Hbeq: b = rectangle_set U0 V0.
  { exact (andER (V0 :e Ty) (b = rectangle_set U0 V0) HV0pair). }

  (** coordinate decomposition of p and membership in U0,V0 **)
  claim HpxX: (p 0) :e X.
  { exact (ap0_Sigma X (fun x:set => Y) p HpZ). }
  claim HpyY: (p 1) :e Y.
  { exact (ap1_Sigma X (fun x:set => Y) p HpZ). }
  claim Hrectmem: p :e setprod U0 V0.
  { claim Hpbrect: p :e rectangle_set U0 V0.
    { rewrite <- Hbeq.
      exact Hpb. }
    rewrite (rectangle_set_def U0 V0) at 1.
    exact Hpbrect. }
  claim HpxU0: (p 0) :e U0.
  { exact (ap0_Sigma U0 (fun x:set => V0) p Hrectmem). }
  claim HpyV0: (p 1) :e V0.
  { exact (ap1_Sigma U0 (fun x:set => V0) p Hrectmem). }

  (** shrink U0,V0 by regularity in each factor **)
  claim HexUx: exists Ux:set, Ux :e Tx /\ (p 0) :e Ux /\ closure_of X Tx Ux c= U0.
  { exact (regular_space_shrink_neighborhood X Tx (p 0) U0 HregX HpxX HU0Tx HpxU0). }
  set Ux := Eps_i (fun Ux0:set => Ux0 :e Tx /\ (p 0) :e Ux0 /\ closure_of X Tx Ux0 c= U0).
  claim HUxprop: Ux :e Tx /\ (p 0) :e Ux /\ closure_of X Tx Ux c= U0.
  { exact (Eps_i_ex (fun Ux0:set => Ux0 :e Tx /\ (p 0) :e Ux0 /\ closure_of X Tx Ux0 c= U0) HexUx). }
  claim HUx12: Ux :e Tx /\ (p 0) :e Ux.
  { exact (andEL (Ux :e Tx /\ (p 0) :e Ux)
                 (closure_of X Tx Ux c= U0)
                 HUxprop). }
  claim HUxTx: Ux :e Tx.
  { exact (andEL (Ux :e Tx) ((p 0) :e Ux) HUx12). }
  claim HpUx: (p 0) :e Ux.
  { exact (andER (Ux :e Tx) ((p 0) :e Ux) HUx12). }
  claim HclUxSubU0: closure_of X Tx Ux c= U0.
  { exact (andER (Ux :e Tx /\ (p 0) :e Ux)
                 (closure_of X Tx Ux c= U0)
                 HUxprop). }

  claim HexVy: exists Vy:set, Vy :e Ty /\ (p 1) :e Vy /\ closure_of Y Ty Vy c= V0.
  { exact (regular_space_shrink_neighborhood Y Ty (p 1) V0 HregY HpyY HV0Ty HpyV0). }
  set Vy := Eps_i (fun Vy0:set => Vy0 :e Ty /\ (p 1) :e Vy0 /\ closure_of Y Ty Vy0 c= V0).
  claim HVyprop: Vy :e Ty /\ (p 1) :e Vy /\ closure_of Y Ty Vy c= V0.
  { exact (Eps_i_ex (fun Vy0:set => Vy0 :e Ty /\ (p 1) :e Vy0 /\ closure_of Y Ty Vy0 c= V0) HexVy). }
  claim HVy12: Vy :e Ty /\ (p 1) :e Vy.
  { exact (andEL (Vy :e Ty /\ (p 1) :e Vy)
                 (closure_of Y Ty Vy c= V0)
                 HVyprop). }
  claim HVyTy: Vy :e Ty.
  { exact (andEL (Vy :e Ty) ((p 1) :e Vy) HVy12). }
  claim HpVy: (p 1) :e Vy.
  { exact (andER (Vy :e Ty) ((p 1) :e Vy) HVy12). }
  claim HclVySubV0: closure_of Y Ty Vy c= V0.
  { exact (andER (Vy :e Ty /\ (p 1) :e Vy)
                 (closure_of Y Ty Vy c= V0)
                 HVyprop). }

	  set V := rectangle_set Ux Vy.
	  witness V.
	  apply andI.
	  - apply andI.
	    + (** V open in the product topology **)
	      claim HVsub: V :e product_subbasis X Tx Y Ty.
	      { prove V :e product_subbasis X Tx Y Ty.
	        claim HVfam: V :e {rectangle_set Ux V0|V0 :e Ty}.
	        { exact (ReplI Ty (fun V0:set => rectangle_set Ux V0) Vy HVyTy). }
	        exact (famunionI Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) Ux V HUxTx HVfam). }
	      claim HTzDef: Tz = generated_topology (setprod X Y) (product_subbasis X Tx Y Ty).
	      { reflexivity. }
	      rewrite HTzDef.
	      (** use the general generator lemma: any designated generator subset of X is open in generated_topology **)
	      claim HVpow: V :e Power (setprod X Y).
	      { apply (PowerI (setprod X Y) V).
	        let q. assume Hq: q :e V.
	        prove q :e setprod X Y.
	        claim HqRect: q :e rectangle_set Ux Vy.
	        { claim HVdef: V = rectangle_set Ux Vy.
	          { reflexivity. }
	          rewrite HVdef.
	          exact Hq. }
	        claim HqProd: q :e setprod Ux Vy.
	        { rewrite <- (rectangle_set_def Ux Vy) at 1.
	          exact HqRect. }
	        claim HTxSub: Tx c= Power X.
	        { exact (topology_subset_axiom X Tx HTx). }
	        claim HTySub: Ty c= Power Y.
	        { exact (topology_subset_axiom Y Ty HTy). }
	        claim HUxPow: Ux :e Power X.
	        { exact (HTxSub Ux HUxTx). }
	        claim HVyPow: Vy :e Power Y.
	        { exact (HTySub Vy HVyTy). }
	        claim HUxSubX: Ux c= X.
	        { exact (PowerE X Ux HUxPow). }
	        claim HVySubY: Vy c= Y.
	        { exact (PowerE Y Vy HVyPow). }
	        claim HrectSub: setprod Ux Vy c= setprod X Y.
	        { exact (setprod_Subq Ux Vy X Y HUxSubX HVySubY). }
	        exact (HrectSub q HqProd). }
	      exact (generated_topology_contains_elem (setprod X Y) (product_subbasis X Tx Y Ty) V HVpow HVsub).
	    + (** p in V **)
	      claim HVdef: V = rectangle_set Ux Vy.
	      { reflexivity. }
	      rewrite HVdef.
	      rewrite (rectangle_set_def Ux Vy).
	      (** use the eta-law for setprod to reduce to the tuple (p0,p1) **)
	      claim HpEta: p = (p 0, p 1).
	      { exact (setprod_eta X Y p HpZ). }
	      rewrite HpEta at 1.
	      exact (tuple_2_setprod_by_pair_Sigma Ux Vy (p 0) (p 1) HpUx HpVy).
	  - (** closure(V) subset U **)
	    claim HclVeq:
	      closure_of Z Tz V = setprod (closure_of X Tx Ux) (closure_of Y Ty Vy).
	    { claim HVdef: V = rectangle_set Ux Vy.
	      { reflexivity. }
	      rewrite HVdef at 1.
	      rewrite (rectangle_set_def Ux Vy) at 1.
	      exact (ex17_9_closure_of_product_subset X Y Tx Ty Ux Vy HTx HTy). }
	    claim HclSubRect:
	      closure_of Z Tz V c= setprod U0 V0.
		    { rewrite HclVeq.
		      apply (setprod_Subq (closure_of X Tx Ux) (closure_of Y Ty Vy) U0 V0).
		      - exact HclUxSubU0.
		      - exact HclVySubV0. }
		    claim HrectSubU: setprod U0 V0 c= U.
		    { rewrite <- (rectangle_set_def U0 V0).
		      rewrite <- Hbeq.
		      exact HbsubU. }
	    exact (Subq_tra (closure_of Z Tz V) (setprod U0 V0) U HclSubRect HrectSubU).
	}

(** conclude regularity via Lemma 31.1 closure characterization **)
claim Hlemma:
  one_point_sets_closed Z Tz ->
    (regular_space Z Tz <->
      forall p U:set, p :e Z -> U :e Tz -> p :e U ->
        exists V:set, V :e Tz /\ p :e V /\ closure_of Z Tz V c= U).
{ exact (andEL (one_point_sets_closed Z Tz -> (regular_space Z Tz <->
             forall p0 U0:set, p0 :e Z -> U0 :e Tz -> p0 :e U0 ->
               exists V0:set, V0 :e Tz /\ p0 :e V0 /\ closure_of Z Tz V0 c= U0))
           (one_point_sets_closed Z Tz -> (normal_space Z Tz <->
             forall A U0:set, closed_in Z Tz A -> U0 :e Tz -> A c= U0 ->
               exists V0:set, V0 :e Tz /\ A c= V0 /\ closure_of Z Tz V0 c= U0))
           (regular_normal_via_closure Z Tz HTz)). }
claim Hiff:
  regular_space Z Tz <->
    forall p U:set, p :e Z -> U :e Tz -> p :e U ->
      exists V:set, V :e Tz /\ p :e V /\ closure_of Z Tz V c= U.
{ exact (Hlemma HT1z). }
exact (iffER (regular_space Z Tz)
             (forall p U:set, p :e Z -> U :e Tz -> p :e U ->
               exists V:set, V :e Tz /\ p :e V /\ closure_of Z Tz V c= U)
             Hiff Hclosure_prop).
Qed.

	(** Helper for products used in §31. **)
	(** Helper: distinct points in a product differ in some coordinate. **)
	Theorem product_space_points_differ_coord : forall I Xi x1 x2:set,
	  x1 :e product_space I Xi ->
  x2 :e product_space I Xi ->
  x1 <> x2 ->
  exists i:set, i :e I /\ apply_fun x1 i <> apply_fun x2 i.
let I Xi x1 x2.
assume Hx1: x1 :e product_space I Xi.
assume Hx2: x2 :e product_space I Xi.
assume Hneq: x1 <> x2.
apply (xm (exists i:set, i :e I /\ apply_fun x1 i <> apply_fun x2 i)).
- assume Hex. exact Hex.
- assume Hno: ~ (exists i:set, i :e I /\ apply_fun x1 i <> apply_fun x2 i).
  apply FalseE.
  set Y := space_family_union I Xi.
  claim Hx1Pow: x1 :e Power (setprod I Y).
  { exact (SepE1 (Power (setprod I Y))
                 (fun f : set =>
                   total_function_on f I Y /\ functional_graph f /\
                   forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i)
                 x1 Hx1). }
  claim Hx2Pow: x2 :e Power (setprod I Y).
  { exact (SepE1 (Power (setprod I Y))
                 (fun f : set =>
                   total_function_on f I Y /\ functional_graph f /\
                   forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i)
                 x2 Hx2). }
  claim Hx1sub: x1 c= setprod I Y.
  { exact (PowerE (setprod I Y) x1 Hx1Pow). }
  claim Hx2sub: x2 c= setprod I Y.
  { exact (PowerE (setprod I Y) x2 Hx2Pow). }
  claim Hx1prop:
    total_function_on x1 I Y /\ functional_graph x1 /\
    forall i:set, i :e I -> apply_fun x1 i :e space_family_set Xi i.
  { exact (SepE2 (Power (setprod I Y))
                 (fun f : set =>
                   total_function_on f I Y /\ functional_graph f /\
                   forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i)
                 x1 Hx1). }
  claim Hx2prop:
    total_function_on x2 I Y /\ functional_graph x2 /\
    forall i:set, i :e I -> apply_fun x2 i :e space_family_set Xi i.
  { exact (SepE2 (Power (setprod I Y))
                 (fun f : set =>
                   total_function_on f I Y /\ functional_graph f /\
                   forall i:set, i :e I -> apply_fun f i :e space_family_set Xi i)
                 x2 Hx2). }
  claim Hx1pair: total_function_on x1 I Y /\ functional_graph x1.
  { exact (andEL (total_function_on x1 I Y /\ functional_graph x1)
                 (forall i:set, i :e I -> apply_fun x1 i :e space_family_set Xi i)
                 Hx1prop). }
  claim Hx2pair: total_function_on x2 I Y /\ functional_graph x2.
  { exact (andEL (total_function_on x2 I Y /\ functional_graph x2)
                 (forall i:set, i :e I -> apply_fun x2 i :e space_family_set Xi i)
                 Hx2prop). }
  claim Htot1: total_function_on x1 I Y.
  { exact (andEL (total_function_on x1 I Y) (functional_graph x1) Hx1pair). }
  claim Htot2: total_function_on x2 I Y.
  { exact (andEL (total_function_on x2 I Y) (functional_graph x2) Hx2pair). }
  claim Hfun1: functional_graph x1.
  { exact (andER (total_function_on x1 I Y) (functional_graph x1) Hx1pair). }
  claim Hfun2: functional_graph x2.
  { exact (andER (total_function_on x2 I Y) (functional_graph x2) Hx2pair). }
  claim Hall: forall i:set, i :e I -> apply_fun x1 i = apply_fun x2 i.
  { let i. assume HiI: i :e I.
    apply (xm (apply_fun x1 i = apply_fun x2 i)).
    - assume Heq. exact Heq.
    - assume Hdiff: apply_fun x1 i <> apply_fun x2 i.
      apply FalseE.
      apply Hno.
      witness i.
      apply andI.
      + exact HiI.
      + exact Hdiff. }
  claim Hsub12: x1 c= x2.
  { let p. assume HpIn1: p :e x1.
    prove p :e x2.
    claim HpX: p :e setprod I Y.
    { exact (Hx1sub p HpIn1). }
    apply (setprod_elem_decompose I Y p HpX).
    let i. assume Hiconj.
    claim HiI: i :e I.
    { exact (andEL (i :e I) (exists y :e Y, p :e setprod {i} {y}) Hiconj). }
    apply (andER (i :e I) (exists y :e Y, p :e setprod {i} {y}) Hiconj).
    let y. assume Hyconj.
    claim HyY: y :e Y.
    { exact (andEL (y :e Y) (p :e setprod {i} {y}) Hyconj). }
    claim Hpiy: p :e setprod {i} {y}.
    { exact (andER (y :e Y) (p :e setprod {i} {y}) Hyconj). }
    claim Hp0: p 0 :e {i}.
    { exact (ap0_Sigma {i} (fun _ : set => {y}) p Hpiy). }
    claim Hp1sing: p 1 :e {y}.
    { exact (ap1_Sigma {i} (fun _ : set => {y}) p Hpiy). }
    claim Hp0eq: p 0 = i.
    { exact (singleton_elem (p 0) i Hp0). }
    claim Hp1eq: p 1 = y.
    { exact (singleton_elem (p 1) y Hp1sing). }
    claim Heta: p = (p 0, p 1).
    { exact (setprod_eta {i} {y} p Hpiy). }
    claim HpEq: p = (i,y).
    { rewrite Heta.
      rewrite Hp0eq.
      rewrite Hp1eq.
      reflexivity. }
    claim Hpair1: (i,y) :e x1.
    { prove (i,y) :e x1.
      rewrite <- HpEq at 1.
      exact HpIn1. }
    claim Happ1: apply_fun x1 i = y.
    { exact (functional_graph_apply_fun_eq x1 i y Hfun1 Hpair1). }
    claim Happ2: apply_fun x2 i = y.
    { rewrite <- (Hall i HiI).
      exact Happ1. }
    claim Hpair2: (i, apply_fun x2 i) :e x2.
    { exact (total_function_on_apply_fun_in_graph x2 I Y i Htot2 HiI). }
    claim Hiy2: (i,y) :e x2.
    { prove (i,y) :e x2.
      rewrite <- Happ2 at 1.
      exact Hpair2. }
    rewrite HpEq.
    exact Hiy2. }
  claim Hsub21: x2 c= x1.
  { let p. assume HpIn2: p :e x2.
    prove p :e x1.
    claim HpX: p :e setprod I Y.
    { exact (Hx2sub p HpIn2). }
    apply (setprod_elem_decompose I Y p HpX).
    let i. assume Hiconj.
    claim HiI: i :e I.
    { exact (andEL (i :e I) (exists y :e Y, p :e setprod {i} {y}) Hiconj). }
    apply (andER (i :e I) (exists y :e Y, p :e setprod {i} {y}) Hiconj).
    let y. assume Hyconj.
    claim Hpiy: p :e setprod {i} {y}.
    { exact (andER (y :e Y) (p :e setprod {i} {y}) Hyconj). }
    claim Hp0: p 0 :e {i}.
    { exact (ap0_Sigma {i} (fun _ : set => {y}) p Hpiy). }
    claim Hp1sing: p 1 :e {y}.
    { exact (ap1_Sigma {i} (fun _ : set => {y}) p Hpiy). }
    claim Hp0eq: p 0 = i.
    { exact (singleton_elem (p 0) i Hp0). }
    claim Hp1eq: p 1 = y.
    { exact (singleton_elem (p 1) y Hp1sing). }
    claim Heta: p = (p 0, p 1).
    { exact (setprod_eta {i} {y} p Hpiy). }
    claim HpEq: p = (i,y).
    { rewrite Heta.
      rewrite Hp0eq.
      rewrite Hp1eq.
      reflexivity. }
    claim Hpair2: (i,y) :e x2.
    { prove (i,y) :e x2.
      rewrite <- HpEq at 1.
      exact HpIn2. }
    claim Happ2: apply_fun x2 i = y.
    { exact (functional_graph_apply_fun_eq x2 i y Hfun2 Hpair2). }
    claim Happ1: apply_fun x1 i = y.
    { rewrite (Hall i HiI) at 1.
      exact Happ2. }
    claim Hpair1: (i, apply_fun x1 i) :e x1.
    { exact (total_function_on_apply_fun_in_graph x1 I Y i Htot1 HiI). }
    claim Hiy1: (i,y) :e x1.
    { prove (i,y) :e x1.
      rewrite <- Happ1 at 1.
      exact Hpair1. }
    rewrite HpEq.
    exact Hiy1. }
  claim Heq: x1 = x2.
  { apply set_ext.
    - exact Hsub12.
    - exact Hsub21. }
exact (Hneq Heq).
Qed.

(** Helper: closure of a cylinder stays inside the cylinder of the coordinate closure. **)
Theorem closure_of_product_cylinder_sub : forall I Xi i V U:set,
  I <> Empty ->
  (forall j:set, j :e I -> topology_on (space_family_set Xi j) (space_family_topology Xi j)) ->
  i :e I ->
  V :e space_family_topology Xi i ->
  U :e space_family_topology Xi i ->
  closure_of (space_family_set Xi i) (space_family_topology Xi i) V c= U ->
  closure_of (product_space I Xi) (product_topology_full I Xi) (product_cylinder I Xi i V)
    c= product_cylinder I Xi i U.
let I Xi i V U.
assume HIne: I <> Empty.
assume HcompTop: forall j:set, j :e I -> topology_on (space_family_set Xi j) (space_family_topology Xi j).
assume HiI: i :e I.
assume HV: V :e space_family_topology Xi i.
assume HU: U :e space_family_topology Xi i.
assume HclVsubU: closure_of (space_family_set Xi i) (space_family_topology Xi i) V c= U.
set X := product_space I Xi.
set T := product_topology_full I Xi.
set S := product_subbasis_full I Xi.
prove closure_of X T (product_cylinder I Xi i V) c= product_cylinder I Xi i U.
claim HSsub: subbasis_on X S.
{ exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
claim HT: topology_on X T.
{ exact (topology_from_subbasis_is_topology X S HSsub). }
let f. assume Hfcl: f :e closure_of X T (product_cylinder I Xi i V).
prove f :e product_cylinder I Xi i U.
claim HfX: f :e X.
{ exact (closure_in_space X T (product_cylinder I Xi i V) HT f Hfcl). }
apply (xm (apply_fun f i :e U)).
- assume HfiU: apply_fun f i :e U.
  claim HdefCylU: product_cylinder I Xi i U =
    {g :e X | i :e I /\ U :e space_family_topology Xi i /\ apply_fun g i :e U}.
  { reflexivity. }
  rewrite HdefCylU.
  claim Hprop: i :e I /\ U :e space_family_topology Xi i /\ apply_fun f i :e U.
  { apply andI.
    - apply andI.
      + exact HiI.
      + exact HU.
    - exact HfiU. }
  exact (SepI X (fun g:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun g i :e U) f HfX Hprop).
- assume HfiNotU: apply_fun f i /:e U.
  apply FalseE.
  claim Htopi: topology_on (space_family_set Xi i) (space_family_topology Xi i).
  { exact (HcompTop i HiI). }
  claim HTsub: (space_family_topology Xi i) c= Power (space_family_set Xi i).
  { exact (topology_subset_axiom (space_family_set Xi i) (space_family_topology Xi i) Htopi). }
	  claim HVsubXi: V c= space_family_set Xi i.
	  { exact (PowerE (space_family_set Xi i) V (HTsub V HV)). }
	  claim Hfprop:
	    total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
	    forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j.
	  { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
	                 (fun g : set =>
	                   total_function_on g I (space_family_union I Xi) /\ functional_graph g /\
	                   forall j:set, j :e I -> apply_fun g j :e space_family_set Xi j)
	                 f HfX). }
	  claim Hcoords: forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j.
	  { exact (andER (total_function_on f I (space_family_union I Xi) /\ functional_graph f)
	                 (forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
	                 Hfprop). }
	  claim Hxcoord: apply_fun f i :e space_family_set Xi i.
	  { exact (Hcoords i HiI). }
  claim HfiNotClV: apply_fun f i /:e closure_of (space_family_set Xi i) (space_family_topology Xi i) V.
  { assume HfiClV: apply_fun f i :e closure_of (space_family_set Xi i) (space_family_topology Xi i) V.
    exact (HfiNotU (HclVsubU (apply_fun f i) HfiClV)). }
  claim HexW: exists W:set,
    W :e space_family_topology Xi i /\ apply_fun f i :e W /\ W :/\: V = Empty.
  { exact (not_in_closure_has_disjoint_open (space_family_set Xi i) (space_family_topology Xi i) V (apply_fun f i)
             Htopi HVsubXi Hxcoord HfiNotClV). }
	  apply HexW.
	  let W. assume HWconj.
	  claim HWcore: W :e space_family_topology Xi i /\ apply_fun f i :e W.
	  { exact (andEL (W :e space_family_topology Xi i /\ apply_fun f i :e W)
	                 (W :/\: V = Empty)
	                 HWconj). }
	  claim HWdisj: W :/\: V = Empty.
	  { exact (andER (W :e space_family_topology Xi i /\ apply_fun f i :e W)
	                 (W :/\: V = Empty)
	                 HWconj). }
	  claim HW0: W :e space_family_topology Xi i.
	  { exact (andEL (W :e space_family_topology Xi i) (apply_fun f i :e W) HWcore). }
	  claim HfiW: apply_fun f i :e W.
	  { exact (andER (W :e space_family_topology Xi i) (apply_fun f i :e W) HWcore). }
  set N := product_cylinder I Xi i W.
  claim HNsub: N :e S.
  { prove N :e (\/_ j :e I, {product_cylinder I Xi j U0|U0 :e space_family_topology Xi j}).
    apply (famunionI I (fun j:set => {product_cylinder I Xi j U0|U0 :e space_family_topology Xi j}) i N HiI).
    exact (ReplI (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0) W HW0). }
  claim HNopen: N :e T.
  { exact (subbasis_elem_open_in_generated_from_subbasis X S N HSsub HNsub). }
  claim HfN: f :e N.
  { claim HdefCylW: N =
      {g :e X | i :e I /\ W :e space_family_topology Xi i /\ apply_fun g i :e W}.
    { reflexivity. }
    rewrite HdefCylW.
    claim HpropW: i :e I /\ W :e space_family_topology Xi i /\ apply_fun f i :e W.
    { apply andI.
      - apply andI.
        + exact HiI.
        + exact HW0.
      - exact HfiW. }
    exact (SepI X (fun g:set => i :e I /\ W :e space_family_topology Xi i /\ apply_fun g i :e W) f
               HfX HpropW). }
  claim Hcliff_prod:
    f :e closure_of X T (product_cylinder I Xi i V) <->
      (forall O :e T, f :e O -> O :/\: product_cylinder I Xi i V <> Empty).
  { exact (closure_characterization X T (product_cylinder I Xi i V) f HT HfX). }
  claim HallO: forall O :e T, f :e O -> O :/\: product_cylinder I Xi i V <> Empty.
  { exact (iffEL (f :e closure_of X T (product_cylinder I Xi i V))
                 (forall O :e T, f :e O -> O :/\: product_cylinder I Xi i V <> Empty)
                 Hcliff_prod Hfcl). }
  claim Hcontr: N :/\: product_cylinder I Xi i V <> Empty.
  { exact (HallO N HNopen HfN). }
  claim HNintEmpty: N :/\: product_cylinder I Xi i V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e N :/\: product_cylinder I Xi i V.
    prove z :e Empty.
    claim HzN: z :e N.
    { exact (binintersectE1 N (product_cylinder I Xi i V) z Hz). }
    claim HzV: z :e product_cylinder I Xi i V.
    { exact (binintersectE2 N (product_cylinder I Xi i V) z Hz). }
    claim HzNprop: i :e I /\ W :e space_family_topology Xi i /\ apply_fun z i :e W.
    { exact (SepE2 X (fun g:set => i :e I /\ W :e space_family_topology Xi i /\ apply_fun g i :e W) z HzN). }
    claim HzVprop: i :e I /\ V :e space_family_topology Xi i /\ apply_fun z i :e V.
    { exact (SepE2 X (fun g:set => i :e I /\ V :e space_family_topology Xi i /\ apply_fun g i :e V) z HzV). }
    claim HziW: apply_fun z i :e W.
    { exact (andER (i :e I /\ W :e space_family_topology Xi i) (apply_fun z i :e W) HzNprop). }
    claim HziV: apply_fun z i :e V.
    { exact (andER (i :e I /\ V :e space_family_topology Xi i) (apply_fun z i :e V) HzVprop). }
    claim HziWV: apply_fun z i :e W :/\: V.
    { exact (binintersectI W V (apply_fun z i) HziW HziV). }
	    claim HziE: apply_fun z i :e Empty.
	    { rewrite <- HWdisj.
	      exact HziWV. }
	    apply FalseE.
	    exact (EmptyE (apply_fun z i) HziE). }
  exact (Hcontr HNintEmpty).
Qed.

(** from §31 Theorem 31.2 (products): Hausdorff part **) 
(** LATEX VERSION: Hausdorff/regular properties preserved under subspaces and products (with factorwise assumptions). **)
Theorem product_topology_full_Hausdorff_axiom : forall I Xi:set,
  Hausdorff_spaces_family I Xi ->
  Hausdorff_space (product_space I Xi) (product_topology_full I Xi).
let I Xi.
assume HHfam: Hausdorff_spaces_family I Xi.
prove Hausdorff_space (product_space I Xi) (product_topology_full I Xi).
prove topology_on (product_space I Xi) (product_topology_full I Xi) /\
  forall x1 x2:set, x1 :e product_space I Xi -> x2 :e product_space I Xi -> x1 <> x2 ->
    exists U V:set, U :e product_topology_full I Xi /\ V :e product_topology_full I Xi /\
      x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- (** topology_on product_topology_full **)
  apply (xm (I = Empty)).
  + assume HI0: I = Empty.
    rewrite HI0.
    claim Hdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
    { reflexivity. }
    rewrite Hdef.
    exact (countable_product_topology_subbasis_empty_is_topology Xi).
  + assume HIne: I <> Empty.
    claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
    { let i. assume HiI: i :e I.
      exact (Hausdorff_space_topology (product_component Xi i) (product_component_topology Xi i) (HHfam i HiI)). }
    claim HS: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
    { exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
    exact (topology_from_subbasis_is_topology (product_space I Xi) (product_subbasis_full I Xi) HS).
- (** Hausdorff separation axiom for product_topology_full **)
  let x1 x2.
  assume Hx1: x1 :e product_space I Xi.
  assume Hx2: x2 :e product_space I Xi.
  assume Hneq: x1 <> x2.
  prove exists U V:set, U :e product_topology_full I Xi /\ V :e product_topology_full I Xi /\
    x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  apply (xm (I = Empty)).
  + assume HI0: I = Empty.
    apply FalseE.
    (** product_space Empty Xi = {Empty}, so no distinct points exist **)
    claim HX0: product_space Empty Xi = {Empty}.
    { exact (product_space_empty_index Xi). }
    claim Hx1S: x1 :e {Empty}.
    { rewrite <- HX0.
      claim Hx1Eidx: x1 :e product_space Empty Xi.
      { prove x1 :e product_space Empty Xi.
        rewrite <- HI0.
        exact Hx1. }
      exact Hx1Eidx. }
    claim Hx2S: x2 :e {Empty}.
    { rewrite <- HX0.
      claim Hx2Eidx: x2 :e product_space Empty Xi.
      { prove x2 :e product_space Empty Xi.
        rewrite <- HI0.
        exact Hx2. }
      exact Hx2Eidx. }
    claim Hx1E: x1 = Empty.
    { exact (SingE Empty x1 Hx1S). }
    claim Hx2E: x2 = Empty.
    { exact (SingE Empty x2 Hx2S). }
    claim Heq: x1 = x2.
    { rewrite Hx1E.
      rewrite Hx2E.
      reflexivity. }
    exact (Hneq Heq).
  + assume HIne: I <> Empty.
    set X := product_space I Xi.
    claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
    { let i. assume HiI: i :e I.
      exact (Hausdorff_space_topology (product_component Xi i) (product_component_topology Xi i) (HHfam i HiI)). }
    claim HSsub: subbasis_on X (product_subbasis_full I Xi).
    { exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
    claim Hexi: exists i:set, i :e I /\ apply_fun x1 i <> apply_fun x2 i.
    { exact (product_space_points_differ_coord I Xi x1 x2 Hx1 Hx2 Hneq). }
    apply Hexi.
    let i. assume Hiconj.
    claim HiI: i :e I.
    { exact (andEL (i :e I) (apply_fun x1 i <> apply_fun x2 i) Hiconj). }
    claim Hdiff: apply_fun x1 i <> apply_fun x2 i.
    { exact (andER (i :e I) (apply_fun x1 i <> apply_fun x2 i) Hiconj). }
    claim HHi: Hausdorff_space (product_component Xi i) (product_component_topology Xi i).
    { exact (HHfam i HiI). }
    claim HTi: topology_on (product_component Xi i) (product_component_topology Xi i).
    { exact (Hausdorff_space_topology (product_component Xi i) (product_component_topology Xi i) HHi). }
    claim HSepi:
      forall y1 y2:set, y1 :e product_component Xi i -> y2 :e product_component Xi i -> y1 <> y2 ->
        exists U V:set, U :e product_component_topology Xi i /\ V :e product_component_topology Xi i /\
          y1 :e U /\ y2 :e V /\ U :/\: V = Empty.
    { exact (andER (topology_on (product_component Xi i) (product_component_topology Xi i))
                   (forall y1 y2:set, y1 :e product_component Xi i -> y2 :e product_component Xi i -> y1 <> y2 ->
                      exists U V:set, U :e product_component_topology Xi i /\ V :e product_component_topology Xi i /\
                        y1 :e U /\ y2 :e V /\ U :/\: V = Empty)
                   HHi). }
    claim Hx1i: apply_fun x1 i :e product_component Xi i.
    { claim Hx1prop:
        total_function_on x1 I (space_family_union I Xi) /\ functional_graph x1 /\
        forall j:set, j :e I -> apply_fun x1 j :e space_family_set Xi j.
      { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                     (fun f : set =>
                       total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
                       forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
                     x1 Hx1). }
      claim Hx1all: forall j:set, j :e I -> apply_fun x1 j :e space_family_set Xi j.
      { exact (andER (total_function_on x1 I (space_family_union I Xi) /\ functional_graph x1)
                     (forall j:set, j :e I -> apply_fun x1 j :e space_family_set Xi j)
                     Hx1prop). }
      exact (Hx1all i HiI). }
    claim Hx2i: apply_fun x2 i :e product_component Xi i.
    { claim Hx2prop:
        total_function_on x2 I (space_family_union I Xi) /\ functional_graph x2 /\
        forall j:set, j :e I -> apply_fun x2 j :e space_family_set Xi j.
      { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                     (fun f : set =>
                       total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
                       forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
                     x2 Hx2). }
      claim Hx2all: forall j:set, j :e I -> apply_fun x2 j :e space_family_set Xi j.
      { exact (andER (total_function_on x2 I (space_family_union I Xi) /\ functional_graph x2)
                     (forall j:set, j :e I -> apply_fun x2 j :e space_family_set Xi j)
                     Hx2prop). }
      exact (Hx2all i HiI). }
    claim HexUV: exists U0 V0:set,
      U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i /\
        apply_fun x1 i :e U0 /\ apply_fun x2 i :e V0 /\ U0 :/\: V0 = Empty.
    { exact (HSepi (apply_fun x1 i) (apply_fun x2 i) Hx1i Hx2i Hdiff). }
    apply HexUV.
    let U0. assume HU0conj.
    apply HU0conj.
    let V0. assume HV0conj.
    claim H4:
      (((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0) /\ apply_fun x2 i :e V0).
    { exact (andEL ((((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0) /\ apply_fun x2 i :e V0))
                   (U0 :/\: V0 = Empty)
                   HV0conj). }
    claim Hdisj: U0 :/\: V0 = Empty.
    { exact (andER ((((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0) /\ apply_fun x2 i :e V0))
                   (U0 :/\: V0 = Empty)
                   HV0conj). }
    claim H3:
      ((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0).
    { exact (andEL (((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0))
                   (apply_fun x2 i :e V0)
                   H4). }
    claim Hx2V0: apply_fun x2 i :e V0.
    { exact (andER (((U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i) /\ apply_fun x1 i :e U0))
                   (apply_fun x2 i :e V0)
                   H4). }
    claim HUV: U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i.
    { exact (andEL (U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i)
                   (apply_fun x1 i :e U0)
                   H3). }
    claim Hx1U0: apply_fun x1 i :e U0.
    { exact (andER (U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i)
                   (apply_fun x1 i :e U0)
                   H3). }
    claim HU0top: U0 :e product_component_topology Xi i.
    { exact (andEL (U0 :e product_component_topology Xi i) (V0 :e product_component_topology Xi i) HUV). }
    claim HV0top: V0 :e product_component_topology Xi i.
    { exact (andER (U0 :e product_component_topology Xi i) (V0 :e product_component_topology Xi i) HUV). }
    set U := product_cylinder I Xi i U0.
    set V := product_cylinder I Xi i V0.
    witness U.
    witness V.
    apply and5I.
    - (** U open **)
      claim HUsub: U :e product_subbasis_full I Xi.
      { prove U :e product_subbasis_full I Xi.
        prove U :e (\/_ j :e I, {product_cylinder I Xi j W|W :e space_family_topology Xi j}).
        apply (famunionI I (fun j:set => {product_cylinder I Xi j W|W :e space_family_topology Xi j}) i U HiI).
        exact (ReplI (space_family_topology Xi i) (fun W:set => product_cylinder I Xi i W) U0 HU0top). }
      exact (subbasis_elem_open_in_generated_from_subbasis X (product_subbasis_full I Xi) U HSsub HUsub).
    - (** V open **)
      claim HVsub: V :e product_subbasis_full I Xi.
      { prove V :e product_subbasis_full I Xi.
        prove V :e (\/_ j :e I, {product_cylinder I Xi j W|W :e space_family_topology Xi j}).
        apply (famunionI I (fun j:set => {product_cylinder I Xi j W|W :e space_family_topology Xi j}) i V HiI).
        exact (ReplI (space_family_topology Xi i) (fun W:set => product_cylinder I Xi i W) V0 HV0top). }
      exact (subbasis_elem_open_in_generated_from_subbasis X (product_subbasis_full I Xi) V HSsub HVsub).
    - (** x1 in U **)
      prove x1 :e U.
      claim HdefU: U = {f :e product_space I Xi | i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0}.
      { reflexivity. }
      rewrite HdefU.
      apply (SepI (product_space I Xi) (fun f:set => i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0) x1 Hx1).
      apply andI.
      + apply andI.
        * exact HiI.
        * exact HU0top.
      + exact Hx1U0.
    - (** x2 in V **)
      prove x2 :e V.
      claim HdefV: V = {f :e product_space I Xi | i :e I /\ V0 :e space_family_topology Xi i /\ apply_fun f i :e V0}.
      { reflexivity. }
      rewrite HdefV.
      apply (SepI (product_space I Xi) (fun f:set => i :e I /\ V0 :e space_family_topology Xi i /\ apply_fun f i :e V0) x2 Hx2).
      apply andI.
      + apply andI.
        * exact HiI.
        * exact HV0top.
      + exact Hx2V0.
    - (** U :/\: V = Empty **)
      prove U :/\: V = Empty.
      apply set_ext.
      + let f. assume Hf: f :e U :/\: V.
        apply FalseE.
        claim HfU: f :e U.
        { exact (binintersectE1 U V f Hf). }
        claim HfV: f :e V.
        { exact (binintersectE2 U V f Hf). }
        claim HfUprop: i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0.
        { exact (SepE2 X (fun f0:set => i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f0 i :e U0) f HfU). }
        claim HfVprop: i :e I /\ V0 :e space_family_topology Xi i /\ apply_fun f i :e V0.
        { exact (SepE2 X (fun f0:set => i :e I /\ V0 :e space_family_topology Xi i /\ apply_fun f0 i :e V0) f HfV). }
        claim HfiU0: apply_fun f i :e U0.
        { exact (andER (i :e I /\ U0 :e space_family_topology Xi i) (apply_fun f i :e U0) HfUprop). }
        claim HfiV0: apply_fun f i :e V0.
        { exact (andER (i :e I /\ V0 :e space_family_topology Xi i) (apply_fun f i :e V0) HfVprop). }
        claim HfiInt: apply_fun f i :e U0 :/\: V0.
        { apply binintersectI.
          - exact HfiU0.
          - exact HfiV0. }
        claim HfiE: apply_fun f i :e Empty.
        { rewrite <- Hdisj. exact HfiInt. }
        exact (EmptyE (apply_fun f i) HfiE).
      + let f. assume Hf: f :e Empty.
        apply FalseE.
        exact (EmptyE f Hf).
Qed.

(** from §31 Theorem 31.2 (products): regular part **) 
(** LATEX VERSION: Hausdorff/regular properties preserved under subspaces and products (with factorwise assumptions). **)
Theorem product_topology_full_regular_axiom : forall I Xi:set,
  regular_spaces_family I Xi ->
  regular_space (product_space I Xi) (product_topology_full I Xi).
let I Xi.
assume Hrfam: regular_spaces_family I Xi.
prove regular_space (product_space I Xi) (product_topology_full I Xi).
prove one_point_sets_closed (product_space I Xi) (product_topology_full I Xi) /\
  forall x:set, x :e product_space I Xi ->
    forall F:set, closed_in (product_space I Xi) (product_topology_full I Xi) F -> x /:e F ->
      exists U V:set,
        U :e product_topology_full I Xi /\ V :e product_topology_full I Xi /\
        x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- (** one_point_sets_closed for the product **)
  prove topology_on (product_space I Xi) (product_topology_full I Xi) /\
    forall x:set, x :e product_space I Xi -> closed_in (product_space I Xi) (product_topology_full I Xi) {x}.
  apply andI.
  + (** topology_on product_topology_full **)
    apply (xm (I = Empty)).
    * assume HI0: I = Empty.
      rewrite HI0.
      claim Hdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
      { reflexivity. }
      rewrite Hdef.
      exact (countable_product_topology_subbasis_empty_is_topology Xi).
    * assume HIne: I <> Empty.
      claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
      { let i. assume HiI: i :e I.
        claim Hreg: regular_space (product_component Xi i) (product_component_topology Xi i).
        { exact (Hrfam i HiI). }
        claim Hopc: one_point_sets_closed (product_component Xi i) (product_component_topology Xi i).
        { exact (andEL (one_point_sets_closed (product_component Xi i) (product_component_topology Xi i))
                       (forall x:set, x :e product_component Xi i ->
                         forall F:set, closed_in (product_component Xi i) (product_component_topology Xi i) F -> x /:e F ->
                           exists U V:set,
                             U :e product_component_topology Xi i /\ V :e product_component_topology Xi i /\
                             x :e U /\ F c= V /\ U :/\: V = Empty)
                       Hreg). }
        exact (andEL (topology_on (product_component Xi i) (product_component_topology Xi i))
                     (forall x:set, x :e product_component Xi i -> closed_in (product_component Xi i) (product_component_topology Xi i) {x})
                     Hopc). }
      claim HS: subbasis_on (product_space I Xi) (product_subbasis_full I Xi).
      { exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
      exact (topology_from_subbasis_is_topology (product_space I Xi) (product_subbasis_full I Xi) HS).
  + (** singletons closed in the product topology **)
    let x. assume Hx: x :e product_space I Xi.
    prove closed_in (product_space I Xi) (product_topology_full I Xi) {x}.
    apply (xm (I = Empty)).
    * assume HI0: I = Empty.
      rewrite HI0.
      (** reduce to the empty-index product, which is a singleton {Empty} **)
      claim HX0: product_space Empty Xi = {Empty}.
      { exact (product_space_empty_index Xi). }
      claim HxEidx: x :e product_space Empty Xi.
      { prove x :e product_space Empty Xi.
        rewrite <- HI0.
        exact Hx. }
      claim HxS: x :e {Empty}.
      { rewrite <- HX0.
        exact HxEidx. }
      claim HxEq: x = Empty.
      { exact (SingE Empty x HxS). }
      claim HT0: topology_on (product_space Empty Xi) (product_topology_full Empty Xi).
      { claim HTdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
        { reflexivity. }
        rewrite HTdef.
        exact (countable_product_topology_subbasis_empty_is_topology Xi). }
      claim HsetEq: {x} = product_space Empty Xi.
      { rewrite HxEq.
        rewrite <- HX0.
        reflexivity. }
      rewrite HsetEq.
      exact (X_is_closed (product_space Empty Xi) (product_topology_full Empty Xi) HT0).
    * assume HIne: I <> Empty.
      set X := product_space I Xi.
      set T := product_topology_full I Xi.
      set S := product_subbasis_full I Xi.
      (** We show X \\ {x} is open, hence {x} is closed. **)
      claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
      { let i. assume HiI: i :e I.
        claim Hreg: regular_space (product_component Xi i) (product_component_topology Xi i).
        { exact (Hrfam i HiI). }
        claim Hopc: one_point_sets_closed (product_component Xi i) (product_component_topology Xi i).
        { exact (andEL (one_point_sets_closed (product_component Xi i) (product_component_topology Xi i))
                       (forall x0:set, x0 :e product_component Xi i ->
                         forall F0:set, closed_in (product_component Xi i) (product_component_topology Xi i) F0 -> x0 /:e F0 ->
                           exists U0 V0:set,
                             U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i /\
                             x0 :e U0 /\ F0 c= V0 /\ U0 :/\: V0 = Empty)
                       Hreg). }
        exact (andEL (topology_on (product_component Xi i) (product_component_topology Xi i))
                     (forall x0:set, x0 :e product_component Xi i -> closed_in (product_component Xi i) (product_component_topology Xi i) {x0})
                     Hopc). }
      claim HSsub: subbasis_on X S.
      { exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
      claim HT: topology_on X T.
      { exact (topology_from_subbasis_is_topology X S HSsub). }

      set Ofam := {U :e T | x /:e U}.
      claim HOfamSub: Ofam c= T.
      { let U. assume HU: U :e Ofam.
        exact (SepE1 T (fun U0:set => x /:e U0) U HU). }
      claim HUnionOpen: Union Ofam :e T.
      { exact (topology_union_closed X T Ofam HT HOfamSub). }

      claim HUnionEq: Union Ofam = X :\: {x}.
      { apply set_ext.
        - let y. assume Hy: y :e Union Ofam.
          apply UnionE_impred Ofam y Hy.
          let U. assume HyU: y :e U. assume HUfam: U :e Ofam.
          claim HUT: U :e T.
          { exact (SepE1 T (fun U0:set => x /:e U0) U HUfam). }
          claim HxnotU: x /:e U.
          { exact (SepE2 T (fun U0:set => x /:e U0) U HUfam). }
          claim HUSubX: U c= X.
          { exact (topology_elem_subset X T U HT HUT). }
          claim HyX: y :e X.
          { exact (HUSubX y HyU). }
          claim HynotSing: y /:e {x}.
          { assume HySing: y :e {x}.
            apply FalseE.
            claim Hyeq: y = x.
            { exact (SingE x y HySing). }
            claim HxU: x :e U.
            { prove x :e U.
              rewrite <- Hyeq.
              exact HyU. }
            exact (HxnotU HxU). }
          apply setminusI.
          + exact HyX.
          + exact HynotSing.
        - let y. assume Hy: y :e X :\: {x}.
          claim HyX: y :e X.
          { exact (setminusE1 X {x} y Hy). }
          claim HynotSing: y /:e {x}.
          { exact (setminusE2 X {x} y Hy). }
          claim Hyneq: y <> x.
          { assume Hyeq: y = x.
            apply FalseE.
            claim HySing: y :e {x}.
            { prove y :e {x}.
              rewrite Hyeq.
              exact (SingI x). }
            exact (HynotSing HySing). }
          claim Hexi: exists i:set, i :e I /\ apply_fun y i <> apply_fun x i.
          { exact (product_space_points_differ_coord I Xi y x HyX Hx Hyneq). }
          apply Hexi.
          let i. assume Hiconj.
          claim HiI: i :e I.
          { exact (andEL (i :e I) (apply_fun y i <> apply_fun x i) Hiconj). }
          claim Hdiff: apply_fun y i <> apply_fun x i.
          { exact (andER (i :e I) (apply_fun y i <> apply_fun x i) Hiconj). }
          (** singleton {x(i)} closed in component i **)
          claim Hregi: regular_space (product_component Xi i) (product_component_topology Xi i).
          { exact (Hrfam i HiI). }
          claim Hopci: one_point_sets_closed (product_component Xi i) (product_component_topology Xi i).
          { exact (andEL (one_point_sets_closed (product_component Xi i) (product_component_topology Xi i))
                         (forall x0:set, x0 :e product_component Xi i ->
                           forall F0:set, closed_in (product_component Xi i) (product_component_topology Xi i) F0 -> x0 /:e F0 ->
                             exists U0 V0:set,
                               U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i /\
                               x0 :e U0 /\ F0 c= V0 /\ U0 :/\: V0 = Empty)
                         Hregi). }
          claim HTi: topology_on (product_component Xi i) (product_component_topology Xi i).
          { exact (andEL (topology_on (product_component Xi i) (product_component_topology Xi i))
                         (forall z:set, z :e product_component Xi i ->
                           closed_in (product_component Xi i) (product_component_topology Xi i) {z})
                         Hopci). }
          claim Hxiprop:
            total_function_on x I (space_family_union I Xi) /\ functional_graph x /\
            forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j.
          { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                         (fun f : set =>
                           total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
                           forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
                         x Hx). }
          claim Hxiall: forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j.
          { exact (andER (total_function_on x I (space_family_union I Xi) /\ functional_graph x)
                         (forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j)
                         Hxiprop). }
          claim Hxi: apply_fun x i :e product_component Xi i.
          { exact (Hxiall i HiI). }
          claim Hyprop:
            total_function_on y I (space_family_union I Xi) /\ functional_graph y /\
            forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j.
          { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                         (fun f : set =>
                           total_function_on f I (space_family_union I Xi) /\ functional_graph f /\
                           forall j:set, j :e I -> apply_fun f j :e space_family_set Xi j)
                         y HyX). }
          claim Hyall: forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j.
          { exact (andER (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
                         (forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j)
                         Hyprop). }
          claim Hyi: apply_fun y i :e product_component Xi i.
          { exact (Hyall i HiI). }
          claim Hsingcl: closed_in (product_component Xi i) (product_component_topology Xi i) {apply_fun x i}.
          { exact (andER (topology_on (product_component Xi i) (product_component_topology Xi i))
                         (forall z:set, z :e product_component Xi i ->
                           closed_in (product_component Xi i) (product_component_topology Xi i) {z})
                         Hopci (apply_fun x i) Hxi). }
          claim Hpkg: {apply_fun x i} c= product_component Xi i /\
            exists U0 :e product_component_topology Xi i, {apply_fun x i} = (product_component Xi i) :\: U0.
          { exact (closed_in_package (product_component Xi i) (product_component_topology Xi i) {apply_fun x i} Hsingcl). }
          claim HexU0: exists U0 :e product_component_topology Xi i,
            {apply_fun x i} = (product_component Xi i) :\: U0.
          { exact (andER ({apply_fun x i} c= product_component Xi i)
                         (exists U0 :e product_component_topology Xi i, {apply_fun x i} = (product_component Xi i) :\: U0)
                         Hpkg). }
          apply HexU0.
          let U0. assume HU0conj.
          claim HU0top: U0 :e product_component_topology Xi i.
          { exact (andEL (U0 :e product_component_topology Xi i)
                         ({apply_fun x i} = product_component Xi i :\: U0)
                         HU0conj). }
          claim HsingEq: {apply_fun x i} = product_component Xi i :\: U0.
          { exact (andER (U0 :e product_component_topology Xi i)
                         ({apply_fun x i} = product_component Xi i :\: U0)
                         HU0conj). }
          (** x(i) not in U0 **)
          claim Hxi_in_sing: apply_fun x i :e {apply_fun x i}.
          { exact (SingI (apply_fun x i)). }
          claim Hxi_in_comp: apply_fun x i :e product_component Xi i :\: U0.
          { rewrite <- HsingEq.
            exact Hxi_in_sing. }
          claim Hxi_notU0: apply_fun x i /:e U0.
          { exact (setminusE2 (product_component Xi i) U0 (apply_fun x i) Hxi_in_comp). }
          (** y(i) in U0, since y(i) != x(i) **)
          claim Hyi_notSing: apply_fun y i /:e {apply_fun x i}.
          { assume HySing: apply_fun y i :e {apply_fun x i}.
            apply FalseE.
            claim Heq: apply_fun y i = apply_fun x i.
            { exact (SingE (apply_fun x i) (apply_fun y i) HySing). }
            exact (Hdiff Heq). }
          claim Hyi_inU0: apply_fun y i :e U0.
          { apply (xm (apply_fun y i :e U0)).
            - assume Hyes. exact Hyes.
            - assume HnoU: apply_fun y i /:e U0.
              apply FalseE.
              claim Hyi_in_comp2: apply_fun y i :e product_component Xi i :\: U0.
              { apply setminusI.
                + exact Hyi.
                + exact HnoU. }
              claim Hyi_in_sing2: apply_fun y i :e {apply_fun x i}.
              { rewrite HsingEq.
                exact Hyi_in_comp2. }
              exact (Hyi_notSing Hyi_in_sing2). }
          (** build cylinder separating y from x **)
          set U := product_cylinder I Xi i U0.
          claim HUsub: U :e S.
          { prove U :e S.
            prove U :e (\/_ j :e I, {product_cylinder I Xi j W|W :e space_family_topology Xi j}).
            apply (famunionI I (fun j:set => {product_cylinder I Xi j W|W :e space_family_topology Xi j}) i U HiI).
            exact (ReplI (space_family_topology Xi i) (fun W:set => product_cylinder I Xi i W) U0 HU0top). }
          claim HUopen: U :e T.
          { exact (subbasis_elem_open_in_generated_from_subbasis X S U HSsub HUsub). }
          claim HyU: y :e U.
          { claim HdefU: U = {f :e X | i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0}.
            { reflexivity. }
            rewrite HdefU.
            apply (SepI X (fun f:set => i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0) y HyX).
            apply andI.
            - apply andI.
              + exact HiI.
              + exact HU0top.
            - exact Hyi_inU0. }
          claim HxnotU: x /:e U.
          { assume HxU: x :e U.
            claim HdefU: U = {f :e X | i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0}.
            { reflexivity. }
            claim HxU2: x :e {f :e X | i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0}.
            { rewrite <- HdefU.
              exact HxU. }
            claim Hxprop2: i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun x i :e U0.
            { exact (SepE2 X (fun f:set => i :e I /\ U0 :e space_family_topology Xi i /\ apply_fun f i :e U0) x HxU2). }
            claim Hx_inU0: apply_fun x i :e U0.
            { exact (andER (i :e I /\ U0 :e space_family_topology Xi i) (apply_fun x i :e U0) Hxprop2). }
            exact (Hxi_notU0 Hx_inU0). }
          claim HUfam: U :e Ofam.
          { apply (SepI T (fun U1:set => x /:e U1) U HUopen).
            exact HxnotU. }
          exact (UnionI Ofam y U HyU HUfam). }

      (** conclude openness of X \\ {x} **)
      claim HopenComp: X :\: {x} :e T.
      { rewrite <- HUnionEq.
        exact HUnionOpen. }
      claim HsingSub: {x} c= X.
      { exact (singleton_subset x X Hx). }
      apply (closed_inI X T {x} HT HsingSub).
      witness (X :\: {x}).
      apply andI.
      - exact HopenComp.
      - (** {x} = X \\ (X \\ {x}) **)
        prove {x} = X :\: (X :\: {x}).
        rewrite (setminus_setminus_eq X {x} HsingSub).
        reflexivity.
- (** regular separation axiom for the product **)
  apply (xm (I = Empty)).
  - assume HI0: I = Empty.
    rewrite HI0.
    (** in the singleton empty-index product, regularity is trivial **)
    let x. assume Hx: x :e product_space Empty Xi.
    let F. assume HF: closed_in (product_space Empty Xi) (product_topology_full Empty Xi) F.
    assume HxnotF: x /:e F.
    prove exists U V:set,
      U :e product_topology_full Empty Xi /\ V :e product_topology_full Empty Xi /\
      x :e U /\ F c= V /\ U :/\: V = Empty.
    claim HT0: topology_on (product_space Empty Xi) (product_topology_full Empty Xi).
    { claim HTdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
      { reflexivity. }
      rewrite HTdef.
      exact (countable_product_topology_subbasis_empty_is_topology Xi). }
    witness (product_space Empty Xi).
    witness Empty.
    (** we use U = X and V = Empty **)
    apply and5I.
    - exact (topology_has_X (product_space Empty Xi) (product_topology_full Empty Xi) HT0).
    - exact (topology_has_empty (product_space Empty Xi) (product_topology_full Empty Xi) HT0).
    - exact Hx.
    - (** F c= Empty, since X is a singleton and x /:e F **)
      let y. assume HyF: y :e F.
      prove y :e Empty.
      claim HFsub: F c= product_space Empty Xi.
      { exact (closed_in_subset (product_space Empty Xi) (product_topology_full Empty Xi) F HF). }
      claim HyX: y :e product_space Empty Xi.
      { exact (HFsub y HyF). }
      claim HX0: product_space Empty Xi = {Empty}.
      { exact (product_space_empty_index Xi). }
      claim HyS: y :e {Empty}.
      { rewrite <- HX0.
        exact HyX. }
      claim HyEq: y = Empty.
      { exact (SingE Empty y HyS). }
      claim HxS: x :e {Empty}.
      { rewrite <- HX0.
        exact Hx. }
      claim HxEq: x = Empty.
      { exact (SingE Empty x HxS). }
      claim Hyx: y = x.
      { rewrite HyEq.
        rewrite <- HxEq.
        reflexivity. }
      apply FalseE.
      claim HxF: x :e F.
      { prove x :e F.
        rewrite <- Hyx.
        exact HyF. }
      exact (HxnotF HxF).
	    - (** (product_space Empty Xi) :/\: Empty = Empty **)
	      claim Hinter: (product_space Empty Xi) :/\: Empty = Empty.
	      { exact (binintersect_Empty_right (product_space Empty Xi)). }
	      exact Hinter.
  - assume HIne: I <> Empty.
    set X := product_space I Xi.
    set T := product_topology_full I Xi.
    set S := product_subbasis_full I Xi.
    claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
    { let i. assume HiI: i :e I.
      claim Hreg: regular_space (product_component Xi i) (product_component_topology Xi i).
      { exact (Hrfam i HiI). }
      claim Hopc: one_point_sets_closed (product_component Xi i) (product_component_topology Xi i).
      { exact (andEL (one_point_sets_closed (product_component Xi i) (product_component_topology Xi i))
                     (forall x0:set, x0 :e product_component Xi i ->
                       forall F0:set, closed_in (product_component Xi i) (product_component_topology Xi i) F0 -> x0 /:e F0 ->
                         exists U0 V0:set,
                           U0 :e product_component_topology Xi i /\ V0 :e product_component_topology Xi i /\
                           x0 :e U0 /\ F0 c= V0 /\ U0 :/\: V0 = Empty)
                     Hreg). }
      exact (andEL (topology_on (product_component Xi i) (product_component_topology Xi i))
                   (forall x0:set, x0 :e product_component Xi i -> closed_in (product_component Xi i) (product_component_topology Xi i) {x0})
                   Hopc). }
    claim HSsub: subbasis_on X S.
    { exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
    claim HT: topology_on X T.
    { exact (topology_from_subbasis_is_topology X S HSsub). }
    let x. assume Hx: x :e X.
    let F. assume HF: closed_in X T F.
    assume HxnotF: x /:e F.
    prove exists U V:set,
      U :e T /\ V :e T /\ x :e U /\ F c= V /\ U :/\: V = Empty.
    apply (xm (F = Empty)).
    + assume HF0: F = Empty.
      witness X.
      witness Empty.
      apply and5I.
      - exact (topology_has_X X T HT).
      - exact (topology_has_empty X T HT).
      - exact Hx.
      - let y. assume HyF: y :e F.
        prove y :e Empty.
        rewrite <- HF0.
        exact HyF.
      - (** X :/\: Empty = Empty **)
        claim Hinter: X :/\: Empty = Empty.
        { exact (binintersect_Empty_right X). }
        exact Hinter.
	    + assume HFne: F <> Empty.
	      (** Use the closed-set witness F = X \\ Uc with Uc open containing x, then pick a basis neighborhood b0 ⊆ Uc. **)
	      claim HFpkg: F c= X /\ exists Uc :e T, F = X :\: Uc.
	      { exact (closed_in_package X T F HF). }
	      claim HFsubX: F c= X.
	      { exact (andEL (F c= X) (exists Uc :e T, F = X :\: Uc) HFpkg). }
	      claim HexUc: exists Uc :e T, F = X :\: Uc.
	      { exact (andER (F c= X) (exists Uc :e T, F = X :\: Uc) HFpkg). }
	      apply HexUc.
	      let Uc. assume HUc_conj.
	      apply HUc_conj.
	      assume HUcT: Uc :e T.
	      assume HFeq: F = X :\: Uc.

	      claim HxUc: x :e Uc.
	      { apply (xm (x :e Uc)).
	        - assume H. exact H.
	        - assume HxnotUc: x /:e Uc.
	          apply FalseE.
	          claim HxF: x :e F.
	          { rewrite HFeq.
	            exact (setminusI X Uc x Hx HxnotUc). }
	          exact (HxnotF HxF). }

	      (** Unfold generated topology: T = generated_topology X (basis_of_subbasis X S). **)
	      claim HTdef1: T = generated_topology_from_subbasis X S.
	      { reflexivity. }
	      claim HTdef2: generated_topology_from_subbasis X S = generated_topology X (basis_of_subbasis X S).
	      { reflexivity. }
	      claim HUcG: Uc :e generated_topology X (basis_of_subbasis X S).
	      { rewrite <- HTdef2.
	        rewrite <- HTdef1.
	        exact HUcT. }

	      (** Extract the local basis property for Uc. **)
	      claim HUc_local:
	        forall z :e Uc, exists b :e basis_of_subbasis X S, z :e b /\ b c= Uc.
	      { exact (SepE2 (Power X)
	                     (fun U0:set => forall z :e U0, exists b :e basis_of_subbasis X S, z :e b /\ b c= U0)
	                     Uc HUcG). }
	      claim Hexb0: exists b0 :e basis_of_subbasis X S, x :e b0 /\ b0 c= Uc.
	      { exact (HUc_local x HxUc). }
	      apply Hexb0.
	      let b0. assume Hb0_conj.
	      apply Hb0_conj.
	      assume Hb0B: b0 :e basis_of_subbasis X S.
	      assume Hb0props.
	      claim Hxb0: x :e b0.
	      { exact (andEL (x :e b0) (b0 c= Uc) Hb0props). }
	      claim Hb0subUc: b0 c= Uc.
	      { exact (andER (x :e b0) (b0 c= Uc) Hb0props). }

	      (** b0 is open in T since basis_of_subbasis is a basis under HSsub. **)
	      claim HBasis: basis_on X (basis_of_subbasis X S).
	      { exact (finite_intersections_basis_of_subbasis X S HSsub). }
	      claim Hb0T: b0 :e T.
	      { rewrite HTdef1.
	        rewrite HTdef2.
	        exact (generated_topology_contains_basis X (basis_of_subbasis X S) HBasis b0 Hb0B). }

			      (** Main regularity step needed:
			          find an open neighborhood U of x whose closure is still inside the chosen basis neighborhood b0 ⊆ Uc. **)
			      claim HexU: exists U:set,
			        U :e T /\ x :e U /\ U c= b0 /\ closure_of X T U c= b0.
			      { apply (xm (b0 = X)).
			        - assume Hb0X: b0 = X.
			          witness X.
			          apply and4I.
			          + exact (topology_has_X X T HT).
			          + exact Hx.
			          + rewrite Hb0X.
			            exact (Subq_ref X).
			          + rewrite Hb0X.
			            claim HclXeq: closure_of X T X = X.
			            { exact (closure_of_space X T HT). }
			            rewrite HclXeq.
			            exact (Subq_ref X).
			        - assume Hb0neX: b0 <> X.
			          (** Decompose b0 as a nonempty finite intersection of subbasis elements. **)
			          claim Hb0fin: b0 :e finite_intersections_of X S.
			          { exact (SepE1 (finite_intersections_of X S) (fun b:set => b <> Empty) b0 Hb0B). }
			          claim Hb0ne: b0 <> Empty.
			          { exact (SepE2 (finite_intersections_of X S) (fun b:set => b <> Empty) b0 Hb0B). }
			          claim HexF: exists F :e finite_subcollections S, b0 = intersection_of_family X F.
			          { exact (ReplE (finite_subcollections S) (fun F0:set => intersection_of_family X F0) b0 Hb0fin). }
			          set F := Eps_i (fun F0:set => F0 :e finite_subcollections S /\ b0 = intersection_of_family X F0).
			          claim HFprop: F :e finite_subcollections S /\ b0 = intersection_of_family X F.
			          { exact (Eps_i_ex (fun F0:set => F0 :e finite_subcollections S /\ b0 = intersection_of_family X F0) HexF). }
			          claim HFfin: F :e finite_subcollections S.
			          { exact (andEL (F :e finite_subcollections S) (b0 = intersection_of_family X F) HFprop). }
			          claim Hb0eqF: b0 = intersection_of_family X F.
			          { exact (andER (F :e finite_subcollections S) (b0 = intersection_of_family X F) HFprop). }
			          claim HxInInter: x :e intersection_of_family X F.
			          { rewrite <- Hb0eqF.
			            exact Hxb0. }
				          claim HxAll: forall s:set, s :e F -> x :e s.
				          { exact (SepE2 X (fun z0:set => forall U0:set, U0 :e F -> z0 :e U0) x HxInInter). }
				          (** Next step (still missing): shrink each subbasis cylinder in F around x using component regularity,
				              and build a finite intersection U with closure(U) c= b0. **)
				          claim HFpowS: F :e Power S.
				          { exact (SepE1 (Power S) (fun F0:set => finite F0) F HFfin). }
				          claim HFin: finite F.
				          { exact (SepE2 (Power S) (fun F0:set => finite F0) F HFfin). }
				          claim HFsubS: F c= S.
				          { exact (PowerE S F HFpowS). }

				          set p : set -> prop := fun H:set =>
				            H c= F ->
				              exists U0:set,
				                U0 :e T /\ x :e U0 /\ U0 c= intersection_of_family X H /\
				                closure_of X T U0 c= intersection_of_family X H.

				          claim HpEmpty: p Empty.
				          { assume Hsub: Empty c= F.
				            witness X.
				            apply and4I.
				            - exact (topology_has_X X T HT).
				            - exact Hx.
				            - rewrite (intersection_of_family_empty_eq X).
				              exact (Subq_ref X).
				            - rewrite (intersection_of_family_empty_eq X).
				              claim HclX: closure_of X T X = X.
				              { exact (closure_of_space X T HT). }
				              rewrite HclX.
				              exact (Subq_ref X). }

					          claim HpStep: forall H y:set, finite H -> y /:e H -> p H -> p (H :\/: {y}).
					          { let H y.
					            assume HfH: finite H.
					            assume HyNotH: y /:e H.
					            assume HpH: p H.
					            prove p (H :\/: {y}).
					            assume HsubHF: (H :\/: {y}) c= F.

					            (** derive H c= F and y :e F **)
					            claim HsubH: H c= H :\/: {y}.
					            { exact (binunion_Subq_1 H {y}). }
					            claim HsubF: H c= F.
					            { exact (Subq_tra H (H :\/: {y}) F HsubH HsubHF). }
					            claim HyIn: y :e H :\/: {y}.
					            { exact (binunionI2 H {y} y (SingI y)). }
					            claim HyF: y :e F.
					            { exact (HsubHF y HyIn). }

					            (** get neighborhood Uh for the subfamily H **)
					            claim HexUh: exists Uh:set,
					              Uh :e T /\ x :e Uh /\ Uh c= intersection_of_family X H /\
					              closure_of X T Uh c= intersection_of_family X H.
					            { exact (HpH HsubF). }
					            apply HexUh.
					            let Uh. assume HUh_conj.
					            claim HUh12: (Uh :e T /\ x :e Uh /\ Uh c= intersection_of_family X H).
					            { exact (andEL (Uh :e T /\ x :e Uh /\ Uh c= intersection_of_family X H)
					                           (closure_of X T Uh c= intersection_of_family X H)
					                           HUh_conj). }
					            claim HclUh: closure_of X T Uh c= intersection_of_family X H.
					            { exact (andER (Uh :e T /\ x :e Uh /\ Uh c= intersection_of_family X H)
					                           (closure_of X T Uh c= intersection_of_family X H)
					                           HUh_conj). }
					            claim HUhTxHx: Uh :e T /\ x :e Uh.
					            { exact (andEL (Uh :e T /\ x :e Uh) (Uh c= intersection_of_family X H) HUh12). }
					            claim HUhT: Uh :e T.
					            { exact (andEL (Uh :e T) (x :e Uh) HUhTxHx). }
					            claim HxUh: x :e Uh.
					            { exact (andER (Uh :e T) (x :e Uh) HUhTxHx). }
					            claim HUhsub: Uh c= intersection_of_family X H.
					            { exact (andER (Uh :e T /\ x :e Uh) (Uh c= intersection_of_family X H) HUh12). }

					            (** Decompose the added subbasis element y into a coordinate cylinder. **)
					            claim HyS: y :e S.
					            { exact (HFsubS y HyF). }
					            set Fam := (fun i0:set => {product_cylinder I Xi i0 U0|U0 :e space_family_topology Xi i0}).
					            claim HSdef: S = (\/_ i0 :e I, Fam i0).
					            { reflexivity. }
					            claim HyFam: y :e (\/_ i0 :e I, Fam i0).
					            { rewrite <- HSdef.
					              exact HyS. }
					            claim HexiU: exists i0:set,
					              i0 :e I /\ exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0.
					            { apply (famunionE_impred I Fam y HyFam (exists i0:set, i0 :e I /\ exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0)).
					              let i0. assume Hi0I: i0 :e I.
					              assume HyFi0: y :e Fam i0.
					              claim HexU0: exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0.
					              { exact (ReplE (space_family_topology Xi i0) (fun U0:set => product_cylinder I Xi i0 U0) y HyFi0). }
					              witness i0.
					              apply andI.
					              - exact Hi0I.
					              - exact HexU0. }
					            apply HexiU.
					            let i0. assume Hi0conj.
					            claim Hi0I: i0 :e I.
					            { exact (andEL (i0 :e I) (exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0) Hi0conj). }
					            claim HexU0: exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0.
					            { exact (andER (i0 :e I) (exists U0 :e space_family_topology Xi i0, y = product_cylinder I Xi i0 U0) Hi0conj). }
					            apply HexU0.
					            let U0. assume HU0conj.
					            claim HU0top: U0 :e space_family_topology Xi i0.
					            { exact (andEL (U0 :e space_family_topology Xi i0) (y = product_cylinder I Xi i0 U0) HU0conj). }
					            claim HyEq: y = product_cylinder I Xi i0 U0.
					            { exact (andER (U0 :e space_family_topology Xi i0) (y = product_cylinder I Xi i0 U0) HU0conj). }

					            (** x is in y because y :e F and x is in ⋂F. **)
					            claim Hxy: x :e y.
					            { exact (HxAll y HyF). }
					            claim HxCyl: x :e product_cylinder I Xi i0 U0.
					            { rewrite <- HyEq.
					              exact Hxy. }
					            claim HxCylProp: i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e U0.
					            { exact (SepE2 X (fun f0:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e U0) x HxCyl). }
					            claim Hxi0U0: apply_fun x i0 :e U0.
					            { exact (andER (i0 :e I /\ U0 :e space_family_topology Xi i0) (apply_fun x i0 :e U0) HxCylProp). }

					            (** Shrink inside U0 using regularity of the i0-th component. **)
					            claim Hreg0: regular_space (product_component Xi i0) (product_component_topology Xi i0).
					            { exact (Hrfam i0 Hi0I). }
					            claim Hregi0: regular_space (space_family_set Xi i0) (space_family_topology Xi i0).
					            { claim HeqX0: product_component Xi i0 = space_family_set Xi i0.
					              { reflexivity. }
					              claim HeqT0: product_component_topology Xi i0 = space_family_topology Xi i0.
					              { reflexivity. }
					              rewrite <- HeqX0.
					              rewrite <- HeqT0.
					              exact Hreg0. }
					            claim Hxprop:
					              total_function_on x I (space_family_union I Xi) /\ functional_graph x /\
					              forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j.
					            { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
					                           (fun f0 : set =>
					                             total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
					                             forall j:set, j :e I -> apply_fun f0 j :e space_family_set Xi j)
					                           x Hx). }
					            claim HcoordsX: forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j.
					            { exact (andER (total_function_on x I (space_family_union I Xi) /\ functional_graph x)
					                           (forall j:set, j :e I -> apply_fun x j :e space_family_set Xi j)
					                           Hxprop). }
					            claim Hxi0X0: apply_fun x i0 :e space_family_set Xi i0.
					            { exact (HcoordsX i0 Hi0I). }

					            claim HexV0: exists V0:set,
					              V0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e V0 /\
					              closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0 c= U0.
					            { exact (regular_space_shrink_neighborhood (space_family_set Xi i0) (space_family_topology Xi i0) (apply_fun x i0) U0
					                       Hregi0 Hxi0X0 HU0top Hxi0U0). }
					            apply HexV0.
					            let V0. assume HV0conj.
					            claim HV0core: V0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e V0.
					            { exact (andEL (V0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e V0)
					                           (closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0 c= U0)
					                           HV0conj). }
					            claim HV0top: V0 :e space_family_topology Xi i0.
					            { exact (andEL (V0 :e space_family_topology Xi i0) (apply_fun x i0 :e V0) HV0core). }
					            claim Hxi0V0: apply_fun x i0 :e V0.
					            { exact (andER (V0 :e space_family_topology Xi i0) (apply_fun x i0 :e V0) HV0core). }
					            claim HclV0subU0: closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0 c= U0.
					            { exact (andER (V0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e V0)
					                           (closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0 c= U0)
					                           HV0conj). }

					            (** V0 ⊆ U0 because V0 ⊆ cl(V0) ⊆ U0. **)
					            claim Htopi: topology_on (space_family_set Xi i0) (space_family_topology Xi i0).
					            { exact (HcompTop i0 Hi0I). }
					            claim HTsubXi: space_family_topology Xi i0 c= Power (space_family_set Xi i0).
					            { exact (topology_subset_axiom (space_family_set Xi i0) (space_family_topology Xi i0) Htopi). }
					            claim HV0subXi: V0 c= space_family_set Xi i0.
					            { exact (PowerE (space_family_set Xi i0) V0 (HTsubXi V0 HV0top)). }
					            claim HV0subCl: V0 c= closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0.
					            { exact (subset_of_closure (space_family_set Xi i0) (space_family_topology Xi i0) V0 Htopi HV0subXi). }
					            claim HV0subU0: V0 c= U0.
					            { exact (Subq_tra V0 (closure_of (space_family_set Xi i0) (space_family_topology Xi i0) V0) U0 HV0subCl HclV0subU0). }

					            set Wcyl := product_cylinder I Xi i0 V0.
					            claim HWcylS: Wcyl :e S.
					            { claim HSdef2: S = (\/_ j :e I, {product_cylinder I Xi j U1|U1 :e space_family_topology Xi j}).
					              { reflexivity. }
					              rewrite HSdef2.
					              apply (famunionI I (fun j:set => {product_cylinder I Xi j U1|U1 :e space_family_topology Xi j}) i0 Wcyl Hi0I).
					              exact (ReplI (space_family_topology Xi i0) (fun U1:set => product_cylinder I Xi i0 U1) V0 HV0top). }
					            claim HWcylT: Wcyl :e T.
					            { exact (subbasis_elem_open_in_generated_from_subbasis X S Wcyl HSsub HWcylS). }
					            claim HxWcyl: x :e Wcyl.
					            { claim HdefW: Wcyl = {f0 :e X | i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e V0}.
					              { reflexivity. }
					              rewrite HdefW.
					              claim HpropW: i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun x i0 :e V0.
					              { apply andI.
					                - apply andI.
					                  + exact Hi0I.
					                  + exact HV0top.
					                - exact Hxi0V0. }
					              exact (SepI X (fun f0:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e V0) x Hx HpropW). }

					            (** Wcyl ⊆ y because V0 ⊆ U0. **)
					            claim HWsub: Wcyl c= y.
					            { rewrite HyEq.
					              let f0. assume Hf0: f0 :e Wcyl.
					              prove f0 :e product_cylinder I Xi i0 U0.
					              claim Hf0X: f0 :e X.
					              { exact (SepE1 X (fun g:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e V0) f0 Hf0). }
					              claim Hprop0: i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e V0.
					              { exact (SepE2 X (fun g:set => i0 :e I /\ V0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e V0) f0 Hf0). }
					              claim HfiV0: apply_fun f0 i0 :e V0.
					              { exact (andER (i0 :e I /\ V0 :e space_family_topology Xi i0) (apply_fun f0 i0 :e V0) Hprop0). }
					              claim HfiU0: apply_fun f0 i0 :e U0.
					              { exact (HV0subU0 (apply_fun f0 i0) HfiV0). }
					              claim HdefCylU0: product_cylinder I Xi i0 U0 =
					                {g :e X | i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e U0}.
					              { reflexivity. }
					              rewrite HdefCylU0.
					              claim HpropU0: i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun f0 i0 :e U0.
					              { apply andI.
					                - apply andI.
					                  + exact Hi0I.
					                  + exact HU0top.
					                - exact HfiU0. }
					              exact (SepI X (fun g:set => i0 :e I /\ U0 :e space_family_topology Xi i0 /\ apply_fun g i0 :e U0) f0 Hf0X HpropU0). }

					            claim HclWsub: closure_of X T Wcyl c= y.
					            { rewrite HyEq.
					              exact (closure_of_product_cylinder_sub I Xi i0 V0 U0 HIne HcompTop Hi0I HV0top HU0top HclV0subU0). }

					            set Unew := Uh :/\: Wcyl.
					            claim HUnewT: Unew :e T.
					            { exact (lemma_intersection_two_open X T Uh Wcyl HT HUhT HWcylT). }
					            claim HxUnew: x :e Unew.
					            { exact (binintersectI Uh Wcyl x HxUh HxWcyl). }

					            claim HinterEq: intersection_of_family X (H :\/: {y}) = (intersection_of_family X H) :/\: y.
					            { exact (intersection_of_family_adjoin X H y). }
					            claim HUnewSub: Unew c= intersection_of_family X (H :\/: {y}).
					            { rewrite HinterEq.
					              let z. assume HzU: z :e Unew.
					              prove z :e (intersection_of_family X H) :/\: y.
					              claim HzUh: z :e Uh.
					              { exact (binintersectE1 Uh Wcyl z HzU). }
					              claim HzW: z :e Wcyl.
					              { exact (binintersectE2 Uh Wcyl z HzU). }
					              claim HzInterH: z :e intersection_of_family X H.
					              { exact (HUhsub z HzUh). }
					              claim Hzy: z :e y.
					              { exact (HWsub z HzW). }
					              exact (binintersectI (intersection_of_family X H) y z HzInterH Hzy). }

					            claim HclUnewSub: closure_of X T Unew c= intersection_of_family X (H :\/: {y}).
					            { claim HTsubX: T c= Power X.
					              { exact (topology_subset_axiom X T HT). }
					              claim HUhSubX: Uh c= X.
					              { exact (PowerE X Uh (HTsubX Uh HUhT)). }
					              claim HWSubX: Wcyl c= X.
					              { exact (PowerE X Wcyl (HTsubX Wcyl HWcylT)). }
					              claim HclInt:
					                closure_of X T Unew c= (closure_of X T Uh) :/\: (closure_of X T Wcyl).
					              { exact (closure_intersection_contained X T Uh Wcyl HT HUhSubX HWSubX). }
					              rewrite HinterEq.
					              let z. assume Hzcl: z :e closure_of X T Unew.
					              prove z :e (intersection_of_family X H) :/\: y.
					              claim Hzcl2: z :e (closure_of X T Uh) :/\: (closure_of X T Wcyl).
					              { exact (HclInt z Hzcl). }
					              claim HzclUh: z :e closure_of X T Uh.
					              { exact (binintersectE1 (closure_of X T Uh) (closure_of X T Wcyl) z Hzcl2). }
					              claim HzclW: z :e closure_of X T Wcyl.
					              { exact (binintersectE2 (closure_of X T Uh) (closure_of X T Wcyl) z Hzcl2). }
					              claim HzInterH: z :e intersection_of_family X H.
					              { exact (HclUh z HzclUh). }
					              claim Hzy: z :e y.
					              { exact (HclWsub z HzclW). }
					              exact (binintersectI (intersection_of_family X H) y z HzInterH Hzy). }

					            witness Unew.
					            apply and4I.
					            - exact HUnewT.
					            - exact HxUnew.
					            - exact HUnewSub.
					            - exact HclUnewSub.
					          }

				          claim HpAll: forall H:set, finite H -> p H.
				          { exact (finite_ind p HpEmpty HpStep). }
				          claim HpF: p F.
				          { exact (HpAll F HFin). }
				          claim HexU0: exists U0:set,
				            U0 :e T /\ x :e U0 /\ U0 c= intersection_of_family X F /\
				            closure_of X T U0 c= intersection_of_family X F.
				          { exact (HpF (Subq_ref F)). }
				          apply HexU0.
				          let U0. assume HU0conj.
				          claim HU0l: (U0 :e T /\ x :e U0 /\ U0 c= intersection_of_family X F).
				          { exact (andEL (U0 :e T /\ x :e U0 /\ U0 c= intersection_of_family X F)
				                         (closure_of X T U0 c= intersection_of_family X F)
				                         HU0conj). }
				          claim HU0cl: closure_of X T U0 c= intersection_of_family X F.
				          { exact (andER (U0 :e T /\ x :e U0 /\ U0 c= intersection_of_family X F)
				                         (closure_of X T U0 c= intersection_of_family X F)
				                         HU0conj). }
				          claim HU0Tx: U0 :e T /\ x :e U0.
				          { exact (andEL (U0 :e T /\ x :e U0) (U0 c= intersection_of_family X F) HU0l). }
				          claim HU0T: U0 :e T.
				          { exact (andEL (U0 :e T) (x :e U0) HU0Tx). }
				          claim HxU0: x :e U0.
				          { exact (andER (U0 :e T) (x :e U0) HU0Tx). }
				          claim HU0sub: U0 c= intersection_of_family X F.
				          { exact (andER (U0 :e T /\ x :e U0) (U0 c= intersection_of_family X F) HU0l). }
				          witness U0.
				          apply and4I.
				          - exact HU0T.
				          - exact HxU0.
				          - rewrite Hb0eqF.
				            exact HU0sub.
				          - rewrite Hb0eqF.
				            exact HU0cl. }
			      apply HexU.
			      let U. assume HU_conj.
			      claim HU12: (U :e T /\ x :e U) /\ U c= b0.
			      { exact (andEL ((U :e T /\ x :e U) /\ U c= b0) (closure_of X T U c= b0) HU_conj). }
			      claim HclU_sub_b0: closure_of X T U c= b0.
			      { exact (andER ((U :e T /\ x :e U) /\ U c= b0) (closure_of X T U c= b0) HU_conj). }
			      claim HU1: U :e T /\ x :e U.
			      { exact (andEL (U :e T /\ x :e U) (U c= b0) HU12). }
			      claim HUsubb0: U c= b0.
			      { exact (andER (U :e T /\ x :e U) (U c= b0) HU12). }
			      claim HUinT: U :e T.
			      { exact (andEL (U :e T) (x :e U) HU1). }
			      claim HxU: x :e U.
			      { exact (andER (U :e T) (x :e U) HU1). }
			      claim HUsubX: U c= X.
			      { let z. assume Hz: z :e U.
			        prove z :e X.
			        claim Hzb0: z :e b0.
			        { exact (HUsubb0 z Hz). }
			        claim HzUc: z :e Uc.
			        { exact (Hb0subUc z Hzb0). }
			        claim HUcsub: Uc c= X.
			        { claim HUcPow: Uc :e Power X.
			          { exact (SepE1 (Power X)
			                         (fun U0:set => forall z :e U0, exists b :e basis_of_subbasis X S, z :e b /\ b c= U0)
		                         Uc HUcG). }
		          exact (PowerE X Uc HUcPow). }
			        exact (HUcsub z HzUc). }
	
			      claim HclU_sub_Uc: closure_of X T U c= Uc.
			      { let y. assume HyCl: y :e closure_of X T U.
			        prove y :e Uc.
			        claim Hyb0: y :e b0.
			        { exact (HclU_sub_b0 y HyCl). }
			        exact (Hb0subUc y Hyb0). }

	      (** Let V be the open complement of cl(U); then F ⊆ V and U ∩ V = ∅. **)
	      claim HclU_closed: closed_in X T (closure_of X T U).
	      { exact (closure_is_closed X T U HT HUsubX). }
	      claim HclU_pkg: closure_of X T U c= X /\ exists V0 :e T, closure_of X T U = X :\: V0.
	      { exact (closed_in_package X T (closure_of X T U) HclU_closed). }
	      claim HexV0: exists V0 :e T, closure_of X T U = X :\: V0.
	      { exact (andER (closure_of X T U c= X) (exists V0 :e T, closure_of X T U = X :\: V0) HclU_pkg). }
		      apply HexV0.
		      let V0. assume HV0_conj.
		      apply HV0_conj.
		      assume HV0T: V0 :e T.
		      assume HclEq: closure_of X T U = X :\: V0.

		      witness U.
		      witness V0.
		      apply and5I.
		      - exact HUinT.
		      - exact HV0T.
		      - exact HxU.
		      - (** F c= V **)
		        let y. assume HyF: y :e F.
		        prove y :e V0.
		        claim HyX: y :e X.
		        { exact (HFsubX y HyF). }
		        claim HyNotUc: y /:e Uc.
		        { claim HyInXU: y :e X :\: Uc.
		          { rewrite <- HFeq.
		            exact HyF. }
		          exact (setminusE2 X Uc y HyInXU). }
		        claim HyNotClU: y /:e closure_of X T U.
		        { assume HyCl: y :e closure_of X T U.
		          apply FalseE.
		          claim HyUc: y :e Uc.
		          { exact (HclU_sub_Uc y HyCl). }
		          exact (HyNotUc HyUc). }
		        (** Since cl(U) = X \\ V, HyNotClU gives y :e V. **)
		        claim HyV: y :e V0.
		        { apply (xm (y :e V0)).
		          - assume H. exact H.
		          - assume HyNotV0: y /:e V0.
		            apply FalseE.
		            claim HyClU: y :e closure_of X T U.
		            { rewrite HclEq.
		              exact (setminusI X V0 y HyX HyNotV0). }
		            exact (HyNotClU HyClU). }
		        exact HyV.
		      - (** U :/\: V = Empty **)
		        apply Empty_Subq_eq.
		        let z. assume Hz: z :e U :/\: V0.
		        prove z :e Empty.
		        apply FalseE.
		        claim HzU: z :e U.
		        { exact (binintersectE1 U V0 z Hz). }
		        claim HzV0: z :e V0.
		        { exact (binintersectE2 U V0 z Hz). }
		        claim HzCl: z :e closure_of X T U.
		        { exact (subset_of_closure X T U HT HUsubX z HzU). }
		        claim HzXminus: z :e X :\: V0.
		        { rewrite <- HclEq.
		          exact HzCl. }
		        claim HzNotV0: z /:e V0.
		        { exact (setminusE2 X V0 z HzXminus). }
		        exact (HzNotV0 HzV0).
Qed.

Theorem separation_axioms_subspace_product : forall X Tx:set,
  topology_on X Tx ->
  (forall Y:set, Y c= X -> Hausdorff_space X Tx -> Hausdorff_space Y (subspace_topology X Tx Y)) /\
  (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi)) /\
  (forall Y:set, Y c= X -> regular_space X Tx -> regular_space Y (subspace_topology X Tx Y)) /\
  (forall I Xi:set, regular_spaces_family I Xi -> regular_space (product_space I Xi) (product_topology_full I Xi)).
	let X Tx.
	assume HTx: topology_on X Tx.
	prove (forall Y:set, Y c= X -> Hausdorff_space X Tx -> Hausdorff_space Y (subspace_topology X Tx Y)) /\
	  (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi)) /\
	  (forall Y:set, Y c= X -> regular_space X Tx -> regular_space Y (subspace_topology X Tx Y)) /\
	  (forall I Xi:set, regular_spaces_family I Xi -> regular_space (product_space I Xi) (product_topology_full I Xi)).
	apply andI.
	- apply andI.
		  + apply andI.
		    - let Y. assume HYsub: Y c= X.
		      assume HH: Hausdorff_space X Tx.
		      prove Hausdorff_space Y (subspace_topology X Tx Y).
		      exact (ex17_12_subspace_Hausdorff X Tx Y HH HYsub).
		    - let I Xi. assume HHfam: Hausdorff_spaces_family I Xi.
		      exact (product_topology_full_Hausdorff_axiom I Xi HHfam).
			  + let Y. assume HYsub: Y c= X.
			    assume Hreg: regular_space X Tx.
			    prove one_point_sets_closed Y (subspace_topology X Tx Y) /\
		      forall y0:set, y0 :e Y ->
		        forall F0:set, closed_in Y (subspace_topology X Tx Y) F0 -> y0 /:e F0 ->
		          exists U V:set, U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\ y0 :e U /\ F0 c= V /\ U :/\: V = Empty.
		    claim HTy: topology_on Y (subspace_topology X Tx Y).
		    { exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
	    claim HT1X: one_point_sets_closed X Tx.
	    { exact (andEL (one_point_sets_closed X Tx)
	                   (forall x:set, x :e X ->
	                     forall F:set, closed_in X Tx F -> x /:e F ->
	                       exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
	                   Hreg). }
	    claim HsingX: forall x:set, x :e X -> closed_in X Tx {x}.
	    { exact (andER (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1X). }
	    claim HsepX:
	      forall x:set, x :e X ->
	        forall F:set, closed_in X Tx F -> x /:e F ->
	          exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
	    { exact (andER (one_point_sets_closed X Tx)
	                   (forall x:set, x :e X ->
	                     forall F:set, closed_in X Tx F -> x /:e F ->
	                       exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
	                   Hreg). }
		    apply andI.
			    - prove topology_on Y (subspace_topology X Tx Y) /\
			        forall y:set, y :e Y -> closed_in Y (subspace_topology X Tx Y) {y}.
			      apply andI.
			      + exact HTy.
			      + let y. assume HyY: y :e Y.
			        prove closed_in Y (subspace_topology X Tx Y) {y}.
		        claim HyX: y :e X.
		        { exact (HYsub y HyY). }
	        apply (iffER (closed_in Y (subspace_topology X Tx Y) {y})
	                     (exists C:set, closed_in X Tx C /\ {y} = C :/\: Y)
	                     (closed_in_subspace_iff_intersection X Tx Y {y} HTx HYsub)).
	        witness {y}.
	        apply andI.
	        - exact (HsingX y HyX).
	        - apply set_ext.
	          + let z. assume Hz: z :e {y}.
	            prove z :e {y} :/\: Y.
	            claim Hzeq: z = y.
	            { exact (SingE y z Hz). }
	            rewrite Hzeq.
	            exact (binintersectI {y} Y y (SingI y) HyY).
	          + let z. assume Hz: z :e {y} :/\: Y.
	            prove z :e {y}.
	            exact (binintersectE1 {y} Y z Hz).
		    - let y. assume HyY: y :e Y.
		      let F. assume HFcl: closed_in Y (subspace_topology X Tx Y) F.
		      assume HynotF: y /:e F.
		      prove exists U V:set, U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\ y :e U /\ F c= V /\ U :/\: V = Empty.
		      claim HyX: y :e X.
		      { exact (HYsub y HyY). }
	      claim HexC: exists C:set, closed_in X Tx C /\ F = C :/\: Y.
	      { exact (iffEL (closed_in Y (subspace_topology X Tx Y) F)
	                     (exists C:set, closed_in X Tx C /\ F = C :/\: Y)
	                     (closed_in_subspace_iff_intersection X Tx Y F HTx HYsub)
	                     HFcl). }
		      set C0 := Eps_i (fun C:set => closed_in X Tx C /\ F = C :/\: Y).
		      claim HC0prop: closed_in X Tx C0 /\ F = C0 :/\: Y.
		      { exact (Eps_i_ex (fun C:set => closed_in X Tx C /\ F = C :/\: Y) HexC). }
	      claim HC0cl: closed_in X Tx C0.
	      { exact (andEL (closed_in X Tx C0) (F = C0 :/\: Y) HC0prop). }
	      claim HFeq: F = C0 :/\: Y.
	      { exact (andER (closed_in X Tx C0) (F = C0 :/\: Y) HC0prop). }
	      claim HynotC0: y /:e C0.
	      { assume HyC0: y :e C0.
	        prove False.
	        claim HyF: y :e F.
	        { rewrite HFeq.
	          exact (binintersectI C0 Y y HyC0 HyY). }
	        exact (HynotF HyF). }
		      claim HexUV: exists U V:set, U :e Tx /\ V :e Tx /\ y :e U /\ C0 c= V /\ U :/\: V = Empty.
		      { exact (HsepX y HyX C0 HC0cl HynotC0). }
		      set Ux := Eps_i (fun U:set =>
		        exists V:set, U :e Tx /\ V :e Tx /\ y :e U /\ C0 c= V /\ U :/\: V = Empty).
		      claim HUxprop: exists V:set, Ux :e Tx /\ V :e Tx /\ y :e Ux /\ C0 c= V /\ Ux :/\: V = Empty.
		      { exact (Eps_i_ex (fun U:set =>
		               exists V:set, U :e Tx /\ V :e Tx /\ y :e U /\ C0 c= V /\ U :/\: V = Empty) HexUV). }
		      set Vx := Eps_i (fun V:set => Ux :e Tx /\ V :e Tx /\ y :e Ux /\ C0 c= V /\ Ux :/\: V = Empty).
		      claim HVxprop: Ux :e Tx /\ Vx :e Tx /\ y :e Ux /\ C0 c= Vx /\ Ux :/\: Vx = Empty.
		      { exact (Eps_i_ex (fun V:set => Ux :e Tx /\ V :e Tx /\ y :e Ux /\ C0 c= V /\ Ux :/\: V = Empty) HUxprop). }
		      claim H1234: ((Ux :e Tx /\ Vx :e Tx) /\ y :e Ux) /\ C0 c= Vx.
		      { exact (andEL (((Ux :e Tx /\ Vx :e Tx) /\ y :e Ux) /\ C0 c= Vx)
		                     (Ux :/\: Vx = Empty)
		                     HVxprop). }
		      claim HdisjUV: Ux :/\: Vx = Empty.
		      { exact (andER (((Ux :e Tx /\ Vx :e Tx) /\ y :e Ux) /\ C0 c= Vx)
		                     (Ux :/\: Vx = Empty)
		                     HVxprop). }
		      claim H123: (Ux :e Tx /\ Vx :e Tx) /\ y :e Ux.
		      { exact (andEL ((Ux :e Tx /\ Vx :e Tx) /\ y :e Ux) (C0 c= Vx) H1234). }
		      claim HC0subVx: C0 c= Vx.
		      { exact (andER ((Ux :e Tx /\ Vx :e Tx) /\ y :e Ux) (C0 c= Vx) H1234). }
		      claim H12: Ux :e Tx /\ Vx :e Tx.
		      { exact (andEL (Ux :e Tx /\ Vx :e Tx) (y :e Ux) H123). }
		      claim HyUx: y :e Ux.
		      { exact (andER (Ux :e Tx /\ Vx :e Tx) (y :e Ux) H123). }
		      claim HUxTx: Ux :e Tx.
		      { exact (andEL (Ux :e Tx) (Vx :e Tx) H12). }
		      claim HVxTx: Vx :e Tx.
		      { exact (andER (Ux :e Tx) (Vx :e Tx) H12). }
		      set U0 := Ux :/\: Y.
		      set V0 := Vx :/\: Y.
		      witness U0.
		      witness V0.
		      apply andI.
		      - apply andI.
		        + apply andI.
		          - apply andI.
		            + prove U0 :e subspace_topology X Tx Y.
		              claim HU0subY: U0 c= Y.
		              { exact (binintersect_Subq_2 Ux Y). }
		              claim HU0pow: U0 :e Power Y.
		              { exact (PowerI Y U0 HU0subY). }
		              claim HU0ex: exists V :e Tx, U0 = V :/\: Y.
		              { witness Ux.
		                apply andI.
		                - exact HUxTx.
		                - reflexivity. }
		              exact (SepI (Power Y) (fun U:set => exists V :e Tx, U = V :/\: Y) U0 HU0pow HU0ex).
		            + prove V0 :e subspace_topology X Tx Y.
		              claim HV0subY: V0 c= Y.
		              { exact (binintersect_Subq_2 Vx Y). }
		              claim HV0pow: V0 :e Power Y.
		              { exact (PowerI Y V0 HV0subY). }
		              claim HV0ex: exists V :e Tx, V0 = V :/\: Y.
		              { witness Vx.
		                apply andI.
		                - exact HVxTx.
		                - reflexivity. }
		              exact (SepI (Power Y) (fun U:set => exists V :e Tx, U = V :/\: Y) V0 HV0pow HV0ex).
		          - exact (binintersectI Ux Y y HyUx HyY).
		        + let z. assume HzF: z :e F.
		          prove z :e V0.
		          claim HzCY: z :e C0 :/\: Y.
		          { rewrite <- HFeq. exact HzF. }
		          claim HzC0: z :e C0.
		          { exact (binintersectE1 C0 Y z HzCY). }
		          claim HzY: z :e Y.
		          { exact (binintersectE2 C0 Y z HzCY). }
		          claim HzVx: z :e Vx.
		          { exact (HC0subVx z HzC0). }
		          exact (binintersectI Vx Y z HzVx HzY).
		      - apply Empty_Subq_eq.
		        let z. assume Hz: z :e U0 :/\: V0.
		        prove z :e Empty.
		        claim HzU0: z :e U0.
		        { exact (binintersectE1 U0 V0 z Hz). }
		        claim HzV0: z :e V0.
		        { exact (binintersectE2 U0 V0 z Hz). }
		        claim HzUx: z :e Ux.
		        { exact (binintersectE1 Ux Y z HzU0). }
		        claim HzVx: z :e Vx.
		        { exact (binintersectE1 Vx Y z HzV0). }
		        claim HzUV: z :e Ux :/\: Vx.
		        { exact (binintersectI Ux Vx z HzUx HzVx). }
			        rewrite <- HdisjUV.
			        exact HzUV.
		- let I Xi. assume Hrfam: regular_spaces_family I Xi.
		  exact (product_topology_full_regular_axiom I Xi Hrfam).
Qed.

(** from §31 Example 1 setup: R_K space **) 
(** LATEX VERSION: Let R_K denote the real line equipped later with the K-topology. **)
Definition R_K : set := R.

(** from §31 Example 1: R_K Hausdorff but not regular **) 
(** LATEX VERSION: The K-topology on ℝ is Hausdorff but not regular. **)
(** Helper for RK_not_regular_axiom: an open neighborhood of a point of K_set meets the complement of K_set inside any ambient open interval. **)
(** SUSPICIOUS THEOREM: This is true because open intervals contain points other than the finitely many K_set points between endpoints; a full proof needs explicit control of K_set spacing (via inv_nat monotonicity) and density of reals/rationals. **)
Theorem K_set_point_has_nonK_neighbor_in_intersection :
  forall a b c d y:set,
    a :e R -> b :e R -> c :e R -> d :e R ->
    y :e K_set ->
    y :e open_interval a b ->
    y :e open_interval c d ->
    exists z:set, z :e (open_interval a b :/\: open_interval c d) /\ z /:e K_set.
let a b c d y.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume HdR: d :e R.
assume HyK: y :e K_set.
assume Hyab: y :e open_interval a b.
assume Hycd: y :e open_interval c d.
prove exists z:set, z :e (open_interval a b :/\: open_interval c d) /\ z /:e K_set.
set I := open_interval a b :/\: open_interval c d.

(** shrink to a standard basic open interval around y inside I **)
claim HabB: open_interval a b :e R_standard_basis.
{ claim Habfam: open_interval a b :e {open_interval a bb|bb :e R}.
  { exact (ReplI R (fun bb0:set => open_interval a bb0) b HbR). }
  exact (famunionI R (fun aa0:set => {open_interval aa0 bb|bb :e R}) a (open_interval a b) HaR Habfam). }
claim HcdB: open_interval c d :e R_standard_basis.
{ claim Hcdfam: open_interval c d :e {open_interval c dd|dd :e R}.
  { exact (ReplI R (fun dd0:set => open_interval c dd0) d HdR). }
  exact (famunionI R (fun cc0:set => {open_interval cc0 dd|dd :e R}) c (open_interval c d) HcR Hcdfam). }
claim Hexb3: exists b3 :e R_standard_basis, y :e b3 /\ b3 c= I.
{ exact (basis_on_refine R R_standard_basis
         R_standard_basis_is_basis_local
         (open_interval a b) HabB
         (open_interval c d) HcdB
         y Hyab Hycd). }
apply Hexb3.
let b3. assume Hb3pair.
claim Hb3B: b3 :e R_standard_basis.
{ exact (andEL (b3 :e R_standard_basis) (y :e b3 /\ b3 c= I) Hb3pair). }
claim Hb3rest: y :e b3 /\ b3 c= I.
{ exact (andER (b3 :e R_standard_basis) (y :e b3 /\ b3 c= I) Hb3pair). }
claim Hyb3: y :e b3.
{ exact (andEL (y :e b3) (b3 c= I) Hb3rest). }
claim Hb3subI: b3 c= I.
{ exact (andER (y :e b3) (b3 c= I) Hb3rest). }

(** b3 is an open interval (e,f) with y inside; defer the non-K point existence inside (e,f) **)
claim Hexe: exists e :e R, b3 :e {open_interval e f|f :e R}.
{ exact (famunionE R (fun e0:set => {open_interval e0 f|f :e R}) b3 Hb3B). }
apply Hexe.
let e. assume Hepair.
claim HeR: e :e R.
{ exact (andEL (e :e R) (b3 :e {open_interval e f|f :e R}) Hepair). }
claim Hb3fam: b3 :e {open_interval e f|f :e R}.
{ exact (andER (e :e R) (b3 :e {open_interval e f|f :e R}) Hepair). }
claim Hexf: exists f :e R, b3 = open_interval e f.
{ exact (ReplE R (fun f0:set => open_interval e f0) b3 Hb3fam). }
apply Hexf.
let f. assume Hfpair.
claim HfR: f :e R.
{ exact (andEL (f :e R) (b3 = open_interval e f) Hfpair). }
claim Hb3eq: b3 = open_interval e f.
{ exact (andER (f :e R) (b3 = open_interval e f) Hfpair). }
claim Hyef: y :e open_interval e f.
{ rewrite <- Hb3eq. exact Hyb3. }

(** Remaining key fact: any open interval around a K_set point contains a point outside K_set. **)
claim Hexz: exists z:set, z :e open_interval e f /\ z /:e K_set.
{ (** We choose z in the right subinterval (y,f), avoiding the finite set K_set∩(y,f). **)
  claim HyR0: y :e R.
  { exact (K_set_Subq_R y HyK). }
  claim Hypos: Rlt 0 y.
  { apply (ReplE_impred (omega :\: {0}) (fun n:set => inv_nat n) y HyK (Rlt 0 y)).
    let n. assume HnIn: n :e omega :\: {0}. assume Hyeq: y = inv_nat n.
    rewrite Hyeq.
    exact (inv_nat_pos n HnIn). }
  claim HyefProp: Rlt e y /\ Rlt y f.
  { exact (SepE2 R (fun x0:set => Rlt e x0 /\ Rlt x0 f) y Hyef). }
  claim HyltF: Rlt y f.
  { exact (andER (Rlt e y) (Rlt y f) HyefProp). }
  claim HeltY: Rlt e y.
  { exact (andEL (Rlt e y) (Rlt y f) HyefProp). }

  set J := open_interval y f.
  claim HinfJ: infinite J.
  { prove infinite J.
    assume HfinJ: finite J.
    (** J is nonempty by density of Q in R **)
    claim Hexq: exists q :e rational_numbers, Rlt y q /\ Rlt q f.
    { exact (rational_dense_between_reals y f HyR0 HfR HyltF). }
    apply Hexq.
    let q. assume Hqpair.
    claim HqQ: q :e rational_numbers.
    { exact (andEL (q :e rational_numbers) (Rlt y q /\ Rlt q f) Hqpair). }
    claim Hqrest: Rlt y q /\ Rlt q f.
    { exact (andER (q :e rational_numbers) (Rlt y q /\ Rlt q f) Hqpair). }
    claim HqR: q :e R.
    { exact (rational_numbers_in_R q HqQ). }
    claim HqJ: q :e J.
    { exact (SepI R (fun x0:set => Rlt y x0 /\ Rlt x0 f) q HqR Hqrest). }
    claim HJne: J <> Empty.
    { exact (elem_implies_nonempty J q HqJ). }
    (** Take a maximum element m of J; then pick a rational strictly between m and f, contradicting maximality. **)
    claim HAllSNo: forall t :e J, SNo t.
    { let t. assume HtJ: t :e J.
      exact (real_SNo t (SepE1 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) t HtJ)). }
    claim Hexm: exists m:set, SNo_max_of J m.
    { exact (finite_max_exists J (fun t HtJ => HAllSNo t HtJ) HfinJ HJne). }
    apply Hexm.
    let m. assume Hmmax: SNo_max_of J m.
    claim Hmconj1: m :e J /\ SNo m.
    { exact (andEL (m :e J /\ SNo m) (forall t :e J, SNo t -> t <= m) Hmmax). }
    claim HmJ: m :e J.
    { exact (andEL (m :e J) (SNo m) Hmconj1). }
    claim HmS: SNo m.
    { exact (andER (m :e J) (SNo m) Hmconj1). }
    claim Hmmaxprop: forall t :e J, SNo t -> t <= m.
    { exact (andER (m :e J /\ SNo m) (forall t :e J, SNo t -> t <= m) Hmmax). }
    claim HmR: m :e R.
    { exact (SepE1 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) m HmJ). }
    claim HmProp: Rlt y m /\ Rlt m f.
    { exact (SepE2 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) m HmJ). }
    claim HmltF: Rlt m f.
    { exact (andER (Rlt y m) (Rlt m f) HmProp). }

    claim Hexq2: exists q2 :e rational_numbers, Rlt m q2 /\ Rlt q2 f.
    { exact (rational_dense_between_reals m f HmR HfR HmltF). }
    apply Hexq2.
    let q2. assume Hq2pair.
    claim Hq2Q: q2 :e rational_numbers.
    { exact (andEL (q2 :e rational_numbers) (Rlt m q2 /\ Rlt q2 f) Hq2pair). }
    claim Hq2rest: Rlt m q2 /\ Rlt q2 f.
    { exact (andER (q2 :e rational_numbers) (Rlt m q2 /\ Rlt q2 f) Hq2pair). }
    claim Hq2R: q2 :e R.
    { exact (rational_numbers_in_R q2 Hq2Q). }
    claim Hmq2: Rlt m q2.
    { exact (andEL (Rlt m q2) (Rlt q2 f) Hq2rest). }
    claim Hq2ltF: Rlt q2 f.
    { exact (andER (Rlt m q2) (Rlt q2 f) Hq2rest). }
    claim Hylm: Rlt y m.
    { exact (andEL (Rlt y m) (Rlt m f) HmProp). }
    claim Hylq2: Rlt y q2.
    { exact (Rlt_tra y m q2 Hylm Hmq2). }
    claim Hq2J: q2 :e J.
    { exact (SepI R (fun x0:set => Rlt y x0 /\ Rlt x0 f) q2 Hq2R (andI (Rlt y q2) (Rlt q2 f) Hylq2 Hq2ltF)). }
    claim Hq2S: SNo q2.
    { exact (real_SNo q2 Hq2R). }
    claim Hq2le: q2 <= m.
    { exact (Hmmaxprop q2 Hq2J Hq2S). }
    claim Hmq2lt: m < q2.
    { exact (RltE_lt m q2 Hmq2). }
    claim HmLtM: m < m.
    { exact (SNoLtLe_tra m q2 m HmS Hq2S HmS Hmq2lt Hq2le). }
    exact ((SNoLt_irref m) HmLtM). }

  (** F = K_set ∩ J is finite because J ⊆ {t| y<t} and K_set∩{t|y<t} is finite (y>0). **)
  set F := K_set :/\: J.
  set V := {t :e R|Rlt y t}.
  claim HVfin: finite (K_set :/\: V).
  { exact (K_set_above_positive_bound_finite y HyR0 Hypos). }
  claim HFsub: F c= (K_set :/\: V).
  { let t. assume HtF: t :e F.
    claim HtK: t :e K_set.
    { exact (binintersectE1 K_set J t HtF). }
    claim HtJ: t :e J.
    { exact (binintersectE2 K_set J t HtF). }
    claim HtR: t :e R.
    { exact (SepE1 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) t HtJ). }
    claim HtProp: Rlt y t /\ Rlt t f.
    { exact (SepE2 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) t HtJ). }
    claim HyltT: Rlt y t.
    { exact (andEL (Rlt y t) (Rlt t f) HtProp). }
    claim HtV: t :e V.
    { exact (SepI R (fun t0:set => Rlt y t0) t HtR HyltT). }
    exact (binintersectI K_set V t HtK HtV). }
  claim HFfin: finite F.
  { exact (Subq_finite (K_set :/\: V) HVfin F HFsub). }

  claim Hexw: exists z:set, z :e J :\: F.
  { exact (infinite_setminus_finite_nonempty J F HinfJ HFfin). }
  apply Hexw.
  let z. assume HzJF: z :e J :\: F.
  claim HzJ: z :e J.
  { exact (setminusE1 J F z HzJF). }
  claim HznotF: z /:e F.
  { exact (setminusE2 J F z HzJF). }
  claim HzR: z :e R.
  { exact (SepE1 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) z HzJ). }
  claim HzProp: Rlt y z /\ Rlt z f.
  { exact (SepE2 R (fun x0:set => Rlt y x0 /\ Rlt x0 f) z HzJ). }
  claim HyltZ: Rlt y z.
  { exact (andEL (Rlt y z) (Rlt z f) HzProp). }
  claim HzltF: Rlt z f.
  { exact (andER (Rlt y z) (Rlt z f) HzProp). }
  claim HznotK: z /:e K_set.
  { assume HzK: z :e K_set.
    claim HzF: z :e F.
    { exact (binintersectI K_set J z HzK HzJ). }
    exact (HznotF HzF). }
  claim Helz: Rlt e z.
  { exact (Rlt_tra e y z HeltY HyltZ). }
  witness z.
  apply andI.
  - prove z :e open_interval e f.
    exact (SepI R (fun x0:set => Rlt e x0 /\ Rlt x0 f) z HzR (andI (Rlt e z) (Rlt z f) Helz HzltF)).
  - exact HznotK. }
apply Hexz.
let z. assume Hzpair.
claim Hzef: z :e open_interval e f.
{ exact (andEL (z :e open_interval e f) (z /:e K_set) Hzpair). }
claim HznotK: z /:e K_set.
{ exact (andER (z :e open_interval e f) (z /:e K_set) Hzpair). }
claim Hzb3: z :e b3.
{ rewrite Hb3eq.
  exact Hzef. }
claim HzI: z :e I.
{ exact (Hb3subI z Hzb3). }
witness z.
apply andI.
- exact HzI.
- exact HznotK.
Qed.

Theorem RK_not_regular_axiom : ~ regular_space R_K R_K_topology.
prove ~ regular_space R_K R_K_topology.
(** Strategy: Use the standard K-topology counterexample at x=0 and the closed set K_set.
    In the K-topology, K_set is closed (closure_of_K_in_R_K_topology), but any open V containing K_set meets every basic neighborhood of 0. **)
assume Hreg: regular_space R_K R_K_topology.
prove False.
(** unpack regularity **)
claim HregSep:
  forall x:set, x :e R_K ->
    forall F:set, closed_in R_K R_K_topology F -> x /:e F ->
      exists U V:set, U :e R_K_topology /\ V :e R_K_topology /\ x :e U /\ F c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed R_K R_K_topology)
               (forall x:set, x :e R_K ->
                 forall F:set, closed_in R_K R_K_topology F -> x /:e F ->
                   exists U V:set, U :e R_K_topology /\ V :e R_K_topology /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }

(** K_set is closed in the K-topology **)
claim HKsubX: K_set c= R_K.
{ let t. assume Ht: t :e K_set.
  exact (K_set_Subq_R t Ht). }
claim HTx: topology_on R_K R_K_topology.
{ exact (regular_space_topology_on R_K R_K_topology Hreg). }
claim HKclosed: closed_in R_K R_K_topology K_set.
{ rewrite <- (closure_of_K_in_R_K_topology) at 1.
  exact (closure_is_closed R_K R_K_topology K_set HTx HKsubX). }
claim H0X: 0 :e R_K.
{ exact real_0. }
claim H0notK: 0 /:e K_set.
{ exact zero_not_in_K_set. }

(** obtain disjoint open U,V with 0∈U and K_set⊆V **)
claim HexUV: exists U V:set,
  U :e R_K_topology /\ V :e R_K_topology /\ 0 :e U /\ K_set c= V /\ U :/\: V = Empty.
{ exact (HregSep 0 H0X K_set HKclosed H0notK). }
apply HexUV.
let U. assume HexV: exists V:set,
  U :e R_K_topology /\ V :e R_K_topology /\ 0 :e U /\ K_set c= V /\ U :/\: V = Empty.
apply HexV.
let V. assume HUV.

(** destruct the left-associated conjunction in HUV **)
claim Hpre: (((U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U) /\ K_set c= V).
{ exact (andEL (((U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U) /\ K_set c= V)
               (U :/\: V = Empty)
               HUV). }
claim Hdisj: U :/\: V = Empty.
{ exact (andER (((U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U) /\ K_set c= V)
               (U :/\: V = Empty)
               HUV). }
claim Hpre2: (U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U.
{ exact (andEL ((U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U)
               (K_set c= V)
               Hpre). }
claim HKsubV: K_set c= V.
{ exact (andER ((U :e R_K_topology /\ V :e R_K_topology) /\ 0 :e U)
               (K_set c= V)
               Hpre). }
claim HUVopen: U :e R_K_topology /\ V :e R_K_topology.
{ exact (andEL (U :e R_K_topology /\ V :e R_K_topology)
               (0 :e U)
               Hpre2). }
claim H0U: 0 :e U.
{ exact (andER (U :e R_K_topology /\ V :e R_K_topology)
               (0 :e U)
               Hpre2). }
claim HUopen: U :e R_K_topology.
{ exact (andEL (U :e R_K_topology) (V :e R_K_topology) HUVopen). }
claim HVopen: V :e R_K_topology.
{ exact (andER (U :e R_K_topology) (V :e R_K_topology) HUVopen). }

(** Use the generated-topology neighborhood property to pick basis elements inside U and V **)
set B := (R_standard_basis :\/: R_K_basis).
claim HUprop: forall x :e U, exists b0 :e B, x :e b0 /\ b0 c= U.
{ exact (SepE2 (Power R_K)
               (fun U0:set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
               U
               HUopen). }
claim HVprop: forall x :e V, exists b0 :e B, x :e b0 /\ b0 c= V.
{ exact (SepE2 (Power R_K)
               (fun U0:set => forall x0 :e U0, exists b0 :e B, x0 :e b0 /\ b0 c= U0)
               V
               HVopen). }

(** pick bU ⊆ U with 0 ∈ bU **)
claim HexbU: exists bU :e B, 0 :e bU /\ bU c= U.
{ exact (HUprop 0 H0U). }
apply HexbU.
let bU. assume HbUpair.
claim HbUB: bU :e B.
{ exact (andEL (bU :e B) (0 :e bU /\ bU c= U) HbUpair). }
claim HbUrest: 0 :e bU /\ bU c= U.
{ exact (andER (bU :e B) (0 :e bU /\ bU c= U) HbUpair). }
claim H0bU: 0 :e bU.
{ exact (andEL (0 :e bU) (bU c= U) HbUrest). }
claim HbUsub: bU c= U.
{ exact (andER (0 :e bU) (bU c= U) HbUrest). }

(** Case split: bU is a standard interval or an interval with K removed **)
apply (binunionE R_standard_basis R_K_basis bU HbUB).
- (** bU from standard basis; then bU meets K_set, so U meets V **)
  assume HbUstd: bU :e R_standard_basis.
  claim Hexa: exists a :e R, bU :e {open_interval a b|b :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 b|b :e R}) bU HbUstd). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR: a :e R.
  { exact (andEL (a :e R) (bU :e {open_interval a b|b :e R}) Hapair). }
  claim HbUfam: bU :e {open_interval a b|b :e R}.
  { exact (andER (a :e R) (bU :e {open_interval a b|b :e R}) Hapair). }
  claim Hexb: exists b :e R, bU = open_interval a b.
  { exact (ReplE R (fun b0 : set => open_interval a b0) bU HbUfam). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbR: b :e R.
  { exact (andEL (b :e R) (bU = open_interval a b) Hbpair). }
  claim HbUeq: bU = open_interval a b.
  { exact (andER (b :e R) (bU = open_interval a b) Hbpair). }
  claim H0I: 0 :e open_interval a b.
  { rewrite <- HbUeq.
    exact H0bU. }
  claim H0cond: Rlt a 0 /\ Rlt 0 b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) 0 H0I). }
  claim H0b: Rlt 0 b.
  { exact (andER (Rlt a 0) (Rlt 0 b) H0cond). }
  claim HexN: exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) b.
  { exact (exists_inv_nat_ordsucc_lt b HbR H0b). }
  apply HexN.
  let N. assume HNpair.
  claim HNO: N :e omega.
  { exact (andEL (N :e omega) (Rlt (inv_nat (ordsucc N)) b) HNpair). }
  claim Hyltb: Rlt (inv_nat (ordsucc N)) b.
  { exact (andER (N :e omega) (Rlt (inv_nat (ordsucc N)) b) HNpair). }
  set y := inv_nat (ordsucc N).
  claim HsN: ordsucc N :e omega.
  { exact (omega_ordsucc N HNO). }
  claim HsNnot0: ordsucc N /:e {0}.
  { assume Hs0: ordsucc N :e {0}.
    claim Heq0: ordsucc N = 0.
    { exact (SingE 0 (ordsucc N) Hs0). }
    exact ((neq_ordsucc_0 N) Heq0). }
  claim HsNin: ordsucc N :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc N) HsN HsNnot0). }
  claim HyK: y :e K_set.
  { exact (ReplI (omega :\: {0}) (fun n0:set => inv_nat n0) (ordsucc N) HsNin). }
  claim HyU: y :e U.
  { (** y ∈ bU, hence y ∈ U **)
    claim HyR: y :e R.
    { exact (inv_nat_real (ordsucc N) HsN). }
    claim HyPos: Rlt 0 y.
    { exact (inv_nat_pos (ordsucc N) HsNin). }
    claim Ha0: Rlt a 0.
    { exact (andEL (Rlt a 0) (Rlt 0 b) H0cond). }
    claim Hay: Rlt a y.
    { exact (Rlt_tra a 0 y Ha0 HyPos). }
    claim HyI: y :e open_interval a b.
    { exact (SepI R (fun x0:set => Rlt a x0 /\ Rlt x0 b) y HyR (andI (Rlt a y) (Rlt y b) Hay Hyltb)). }
    claim HybU: y :e bU.
    { rewrite HbUeq.
      exact HyI. }
    exact (HbUsub y HybU). }
  claim HyV: y :e V.
  { exact (HKsubV y HyK). }
  claim HyUV: y :e U :/\: V.
  { exact (binintersectI U V y HyU HyV). }
  claim HyEmpty: y :e Empty.
  { rewrite <- Hdisj.
    exact HyUV. }
  exact (EmptyE y HyEmpty).
- (** bU from K-basis; use a neighborhood of a K_set point inside V and the helper lemma **)
  assume HbUK: bU :e R_K_basis.
  claim Hexa: exists a :e R, bU :e {open_interval a b :\: K_set|b :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 b :\: K_set|b :e R}) bU HbUK). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR: a :e R.
  { exact (andEL (a :e R) (bU :e {open_interval a b :\: K_set|b :e R}) Hapair). }
  claim HbUfam: bU :e {open_interval a b :\: K_set|b :e R}.
  { exact (andER (a :e R) (bU :e {open_interval a b :\: K_set|b :e R}) Hapair). }
  claim Hexb: exists b :e R, bU = open_interval a b :\: K_set.
  { exact (ReplE R (fun b0 : set => open_interval a b0 :\: K_set) bU HbUfam). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbR: b :e R.
  { exact (andEL (b :e R) (bU = open_interval a b :\: K_set) Hbpair). }
  claim HbUeq: bU = open_interval a b :\: K_set.
  { exact (andER (b :e R) (bU = open_interval a b :\: K_set) Hbpair). }
  claim H0bU': 0 :e open_interval a b.
  { claim H0bUset: 0 :e open_interval a b :\: K_set.
    { rewrite <- HbUeq.
      exact H0bU. }
    exact (setminusE1 (open_interval a b) K_set 0 H0bUset). }
  claim H0cond: Rlt a 0 /\ Rlt 0 b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) 0 H0bU'). }
  claim H0b: Rlt 0 b.
  { exact (andER (Rlt a 0) (Rlt 0 b) H0cond). }
  (** pick a K_set point y in (a,b) **)
  claim HexN: exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) b.
  { exact (exists_inv_nat_ordsucc_lt b HbR H0b). }
  apply HexN.
  let N. assume HNpair.
  claim HNO: N :e omega.
  { exact (andEL (N :e omega) (Rlt (inv_nat (ordsucc N)) b) HNpair). }
  claim Hyltb: Rlt (inv_nat (ordsucc N)) b.
  { exact (andER (N :e omega) (Rlt (inv_nat (ordsucc N)) b) HNpair). }
  set y := inv_nat (ordsucc N).
  claim HsN: ordsucc N :e omega.
  { exact (omega_ordsucc N HNO). }
  claim HsNnot0: ordsucc N /:e {0}.
  { assume Hs0: ordsucc N :e {0}.
    claim Heq0: ordsucc N = 0.
    { exact (SingE 0 (ordsucc N) Hs0). }
    exact ((neq_ordsucc_0 N) Heq0). }
  claim HsNin: ordsucc N :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc N) HsN HsNnot0). }
  claim HyK: y :e K_set.
  { exact (ReplI (omega :\: {0}) (fun n0:set => inv_nat n0) (ordsucc N) HsNin). }
  claim HyR: y :e R.
  { exact (inv_nat_real (ordsucc N) HsN). }
  claim HyPos: Rlt 0 y.
  { exact (inv_nat_pos (ordsucc N) HsNin). }
  claim Ha0: Rlt a 0.
  { exact (andEL (Rlt a 0) (Rlt 0 b) H0cond). }
  claim Hay: Rlt a y.
  { exact (Rlt_tra a 0 y Ha0 HyPos). }
  claim Hyab: y :e open_interval a b.
  { exact (SepI R (fun x0:set => Rlt a x0 /\ Rlt x0 b) y HyR (andI (Rlt a y) (Rlt y b) Hay Hyltb)). }
  (** y ∈ V, so pick a basis neighborhood bV ⊆ V with y ∈ bV **)
  claim HyV: y :e V.
  { exact (HKsubV y HyK). }
  claim HexbV: exists bV :e B, y :e bV /\ bV c= V.
  { exact (HVprop y HyV). }
  apply HexbV.
  let bV. assume HbVpair.
  claim HbVB: bV :e B.
  { exact (andEL (bV :e B) (y :e bV /\ bV c= V) HbVpair). }
  claim HbVrest: y :e bV /\ bV c= V.
  { exact (andER (bV :e B) (y :e bV /\ bV c= V) HbVpair). }
  claim HybV: y :e bV.
  { exact (andEL (y :e bV) (bV c= V) HbVrest). }
  claim HbVsubV: bV c= V.
  { exact (andER (y :e bV) (bV c= V) HbVrest). }
  (** bV cannot be a K-basis element because it contains y :e K_set **)
  apply (binunionE R_standard_basis R_K_basis bV HbVB).
  * (** bV standard basis: extract (c,d) with bV = (c,d) **)
    assume HbVstd: bV :e R_standard_basis.
    claim Hexc: exists c :e R, bV :e {open_interval c d|d :e R}.
    { exact (famunionE R (fun c0 : set => {open_interval c0 d|d :e R}) bV HbVstd). }
    apply Hexc.
    let c. assume Hcpair.
    claim HcR: c :e R.
    { exact (andEL (c :e R) (bV :e {open_interval c d|d :e R}) Hcpair). }
    claim HbVfam: bV :e {open_interval c d|d :e R}.
    { exact (andER (c :e R) (bV :e {open_interval c d|d :e R}) Hcpair). }
    claim Hexd: exists d :e R, bV = open_interval c d.
    { exact (ReplE R (fun d0 : set => open_interval c d0) bV HbVfam). }
    apply Hexd.
    let d. assume Hdpair.
    claim HdR: d :e R.
    { exact (andEL (d :e R) (bV = open_interval c d) Hdpair). }
    claim HbVeq: bV = open_interval c d.
    { exact (andER (d :e R) (bV = open_interval c d) Hdpair). }
    claim Hycd: y :e open_interval c d.
    { rewrite <- HbVeq.
      exact HybV. }
    (** use the helper lemma to get z in the intersection of intervals but not in K_set **)
    claim Hexz: exists z:set, z :e (open_interval a b :/\: open_interval c d) /\ z /:e K_set.
    { exact (K_set_point_has_nonK_neighbor_in_intersection a b c d y HaR HbR HcR HdR HyK Hyab Hycd). }
    apply Hexz.
    let z. assume Hzpair.
    claim HzI: z :e (open_interval a b :/\: open_interval c d).
    { exact (andEL (z :e (open_interval a b :/\: open_interval c d)) (z /:e K_set) Hzpair). }
    claim HznotK: z /:e K_set.
    { exact (andER (z :e (open_interval a b :/\: open_interval c d)) (z /:e K_set) Hzpair). }
    claim Hzab: z :e open_interval a b.
    { exact (binintersectE1 (open_interval a b) (open_interval c d) z HzI). }
    claim Hzcd: z :e open_interval c d.
    { exact (binintersectE2 (open_interval a b) (open_interval c d) z HzI). }
    (** z ∈ bU = (a,b)\\K_set, hence z ∈ U **)
    claim HzbU: z :e bU.
    { rewrite HbUeq.
      exact (setminusI (open_interval a b) K_set z Hzab HznotK). }
    claim HzU: z :e U.
    { exact (HbUsub z HzbU). }
    (** z ∈ bV ⊆ V **)
    claim HzbV: z :e bV.
    { rewrite HbVeq.
      exact Hzcd. }
    claim HzV: z :e V.
    { exact (HbVsubV z HzbV). }
    claim HzUV: z :e U :/\: V.
    { exact (binintersectI U V z HzU HzV). }
    claim HzEmpty: z :e Empty.
    { rewrite <- Hdisj.
      exact HzUV. }
    exact (EmptyE z HzEmpty).
  * (** bV in K-basis: contradiction since y ∈ K_set **)
    assume HbVK: bV :e R_K_basis.
    (** any K-basis element is of the form (c,d)\\K_set, so it cannot contain y :e K_set **)
    claim Hexc: exists c :e R, bV :e {open_interval c d :\: K_set|d :e R}.
    { exact (famunionE R (fun c0 : set => {open_interval c0 d :\: K_set|d :e R}) bV HbVK). }
    apply Hexc.
    let c. assume Hcpair.
    claim HcR: c :e R.
    { exact (andEL (c :e R) (bV :e {open_interval c d :\: K_set|d :e R}) Hcpair). }
    claim HbVfam2: bV :e {open_interval c d :\: K_set|d :e R}.
    { exact (andER (c :e R) (bV :e {open_interval c d :\: K_set|d :e R}) Hcpair). }
    claim Hexd: exists d :e R, bV = open_interval c d :\: K_set.
    { exact (ReplE R (fun d0 : set => open_interval c d0 :\: K_set) bV HbVfam2). }
    apply Hexd.
    let d. assume Hdpair.
    claim HbVeq: bV = open_interval c d :\: K_set.
    { exact (andER (d :e R) (bV = open_interval c d :\: K_set) Hdpair). }
    claim HyNotK: y /:e K_set.
    { claim HybVset: y :e open_interval c d :\: K_set.
      { rewrite <- HbVeq.
        exact HybV. }
      exact (setminusE2 (open_interval c d) K_set y HybVset). }
    exact (HyNotK HyK).
Qed.
Theorem RK_Hausdorff_not_regular :
  Hausdorff_space R_K R_K_topology /\ ~ regular_space R_K R_K_topology.
prove Hausdorff_space R_K R_K_topology /\ ~ regular_space R_K R_K_topology.
apply andI.
- (** Hausdorff part follows from earlier theorem about R_K_topology **)
  claim HRKeq: R_K = R.
  { reflexivity. }
  rewrite HRKeq.
  exact R_K_topology_Hausdorff.
- (** Not regular: standard counterexample at 0 using closed set K_set; pending full formal proof. **)
  exact RK_not_regular_axiom.
Qed.

(** from §31 Example 2: Sorgenfrey line normal **) 
(** LATEX VERSION: The Sorgenfrey line is normal. **)
  (** helper: the Sorgenfrey line is regular **)
  (** LATEX VERSION: The Sorgenfrey line is regular (points and closed sets separated by disjoint half open intervals). **)
Theorem Sorgenfrey_line_regular : regular_space Sorgenfrey_line Sorgenfrey_topology.
prove regular_space Sorgenfrey_line Sorgenfrey_topology.
prove one_point_sets_closed Sorgenfrey_line Sorgenfrey_topology /\
  forall x:set, x :e Sorgenfrey_line ->
    forall F:set, closed_in Sorgenfrey_line Sorgenfrey_topology F -> x /:e F ->
      exists U V:set, U :e Sorgenfrey_topology /\ V :e Sorgenfrey_topology /\
        x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- (** one_point_sets_closed **)
  prove topology_on Sorgenfrey_line Sorgenfrey_topology /\
       forall x:set, x :e Sorgenfrey_line -> closed_in Sorgenfrey_line Sorgenfrey_topology {x}.
  apply andI.
  * exact (Hausdorff_space_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line_Hausdorff).
  * let x. assume Hx: x :e Sorgenfrey_line.
    exact (Hausdorff_singletons_closed Sorgenfrey_line Sorgenfrey_topology x Sorgenfrey_line_Hausdorff Hx).
- let x. assume HxR: x :e Sorgenfrey_line.
  let F. assume HFcl: closed_in Sorgenfrey_line Sorgenfrey_topology F.
  assume HxnotF: x /:e F.
  set U0 := Sorgenfrey_line :\: F.
  claim HU0open_in: open_in Sorgenfrey_line Sorgenfrey_topology U0.
  { claim HU0def: U0 = Sorgenfrey_line :\: F.
    { reflexivity. }
    rewrite HU0def.
    exact (open_of_closed_complement Sorgenfrey_line Sorgenfrey_topology F HFcl). }
  claim HU0open: U0 :e Sorgenfrey_topology.
  { exact (open_in_elem Sorgenfrey_line Sorgenfrey_topology U0 HU0open_in). }
  claim HxU0: x :e U0.
  { apply setminusI.
    - exact HxR.
    - exact HxnotF. }
  (** choose a basis neighborhood b with x in b and b subset U0 **)
  claim Hexb: exists b :e R_lower_limit_basis, x :e b /\ b c= U0.
  { exact (generated_topology_local_refine R R_lower_limit_basis U0 x HU0open HxU0). }
  apply Hexb.
  let b. assume Hbpair.
  claim HbB: b :e R_lower_limit_basis.
  { exact (andEL (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair). }
  claim Hxb: x :e b.
  { exact (andEL (x :e b) (b c= U0) (andER (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair)). }
  claim HbSubU0: b c= U0.
  { exact (andER (x :e b) (b c= U0) (andER (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair)). }
  claim Hbopen: b :e Sorgenfrey_topology.
  { exact (generated_topology_contains_basis R R_lower_limit_basis R_lower_limit_basis_is_basis_local b HbB). }
  (** represent b as a half open interval [a,d) and use the pre-proved complement lemma **)
  claim Hexa : exists a :e R, b :e {halfopen_interval_left a d|d :e R}.
  { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 d|d :e R}) b HbB). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR : a :e R.
  { exact (andEL (a :e R) (b :e {halfopen_interval_left a d|d :e R}) Hapair). }
  claim HbFam : b :e {halfopen_interval_left a d|d :e R}.
  { exact (andER (a :e R) (b :e {halfopen_interval_left a d|d :e R}) Hapair). }
  claim Hexd : exists d :e R, b = halfopen_interval_left a d.
  { exact (ReplE R (fun d0 : set => halfopen_interval_left a d0) b HbFam). }
  apply Hexd.
  let d. assume Hdpair.
  claim HdR : d :e R.
  { exact (andEL (d :e R) (b = halfopen_interval_left a d) Hdpair). }
  claim Hbeq : b = halfopen_interval_left a d.
  { exact (andER (d :e R) (b = halfopen_interval_left a d) Hdpair). }
  witness b.
  witness (Sorgenfrey_line :\: b).
  apply and5I.
  - exact Hbopen.
  - claim HeqV: (Sorgenfrey_line :\: b) = (R :\: halfopen_interval_left a d).
    { rewrite Hbeq.
      reflexivity. }
    rewrite HeqV.
    exact (complement_halfopen_interval_left_in_R_lower_limit_topology a d HaR HdR).
  - exact Hxb.
  - (** F subset V because U subset U0 = R\\F **)
    let y. assume HyF: y :e F.
    prove y :e (Sorgenfrey_line :\: b).
    claim HFsubR: F c= Sorgenfrey_line.
    { exact (closed_in_subset Sorgenfrey_line Sorgenfrey_topology F HFcl). }
    claim HyR: y :e Sorgenfrey_line.
    { exact (HFsubR y HyF). }
    apply (setminusI Sorgenfrey_line b y HyR).
    assume Hyb: y :e b.
    claim HyU0: y :e U0.
    { exact (HbSubU0 y Hyb). }
    claim HyNotF: y /:e F.
    { exact (setminusE2 Sorgenfrey_line F y HyU0). }
    exact (HyNotF HyF).
  - (** U and V are disjoint **)
    apply Empty_Subq_eq.
    let z. assume Hz: z :e b :/\: (Sorgenfrey_line :\: b).
    prove z :e Empty.
    claim HzU: z :e b.
    { exact (binintersectE1 b (Sorgenfrey_line :\: b) z Hz). }
    claim HzV: z :e (Sorgenfrey_line :\: b).
    { exact (binintersectE2 b (Sorgenfrey_line :\: b) z Hz). }
    claim HznU: z /:e b.
    { exact (setminusE2 Sorgenfrey_line b z HzV). }
    apply FalseE.
    exact (HznU HzU).
Qed.

(** NOTE: Theorem `Sorgenfrey_line_normal` is proved later, after §32.4 infrastructure becomes available. **)

(** from §31 Exercise 9: Sorgenfrey plane rational/irrational diagonal non-separation **)
(** LATEX VERSION: In ℝ_ℓ², let A = {x × (-x) | x rational}, B = {x × (-x) | x irrational}. No open sets separate A and B. **)
(** NOTE: Moved here so it can be used in §31 Example 3 (`Sorgenfrey_plane_not_normal`). **)
(** Diagonal sets in the Sorgenfrey plane used in this exercise. **)
Definition Sorgenfrey_plane_diag_rational : set :=
  {(x, minus_SNo x) | x :e rational_numbers}.
Definition Sorgenfrey_plane_diag_irrational : set :=
  {(x, minus_SNo x) | x :e (Sorgenfrey_line :\: rational_numbers)}.

(** helper: rational and irrational diagonals are disjoint **)
Theorem Sorgenfrey_plane_diag_disjoint :
  Sorgenfrey_plane_diag_rational :/\: Sorgenfrey_plane_diag_irrational = Empty.
apply Empty_Subq_eq.
let p. assume Hp: p :e Sorgenfrey_plane_diag_rational :/\: Sorgenfrey_plane_diag_irrational.
prove p :e Empty.
claim HpA: p :e Sorgenfrey_plane_diag_rational.
{ exact (binintersectE1 Sorgenfrey_plane_diag_rational Sorgenfrey_plane_diag_irrational p Hp). }
claim HpB: p :e Sorgenfrey_plane_diag_irrational.
{ exact (binintersectE2 Sorgenfrey_plane_diag_rational Sorgenfrey_plane_diag_irrational p Hp). }
claim Hexx: exists x :e rational_numbers, p = (x, minus_SNo x).
{ exact (ReplE rational_numbers (fun x0:set => (x0, minus_SNo x0)) p HpA). }
apply Hexx.
let x. assume Hxpair.
claim HxQ: x :e rational_numbers.
{ exact (andEL (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
claim Hpeq1: p = (x, minus_SNo x).
{ exact (andER (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
claim Hexy: exists y :e (Sorgenfrey_line :\: rational_numbers), p = (y, minus_SNo y).
{ exact (ReplE (Sorgenfrey_line :\: rational_numbers) (fun y0:set => (y0, minus_SNo y0)) p HpB). }
apply Hexy.
let y. assume Hypair.
claim HyIrr: y :e (Sorgenfrey_line :\: rational_numbers).
{ exact (andEL (y :e (Sorgenfrey_line :\: rational_numbers)) (p = (y, minus_SNo y)) Hypair). }
claim Hpeq2: p = (y, minus_SNo y).
{ exact (andER (y :e (Sorgenfrey_line :\: rational_numbers)) (p = (y, minus_SNo y)) Hypair). }
claim Hp0x: (p 0) = x.
{ rewrite Hpeq1 at 1.
  exact (tuple_2_0_eq x (minus_SNo x)). }
claim Hp0y: (p 0) = y.
{ rewrite Hpeq2 at 1.
  exact (tuple_2_0_eq y (minus_SNo y)). }
claim HxEqy: x = y.
{ rewrite <- Hp0x.
  exact Hp0y. }
claim HynQ: y /:e rational_numbers.
{ exact (setminusE2 Sorgenfrey_line rational_numbers y HyIrr). }
apply FalseE.
prove False.
claim HyQ: y :e rational_numbers.
{ rewrite <- HxEqy.
  exact HxQ. }
exact (HynQ HyQ).
Qed.

(** Diagonal sets are closed in the Sorgenfrey plane (needed for non-normality). **)
Theorem Sorgenfrey_plane_diag_rational_closed :
  closed_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology Sorgenfrey_plane_diag_rational.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
set L := Sorgenfrey_plane_L.
set Ta := subspace_topology X Tx L.
set A := Sorgenfrey_plane_diag_rational.
set B := Sorgenfrey_plane_diag_irrational.

claim HTline: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HTx: topology_on X Tx.
{ (** unfold Sorgenfrey_plane_topology via its definition **)
  claim Hdef: Tx = product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
  { reflexivity. }
  rewrite Hdef.
  exact (product_topology_is_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HTline HTline). }

claim HLcl: closed_in X Tx L.
{ exact Sorgenfrey_plane_L_closed. }
claim HLsubX: L c= X.
{ exact (closed_in_subset X Tx L HLcl). }
claim HTa: topology_on L Ta.
{ exact (subspace_topology_is_topology X Tx L HTx HLsubX). }

claim HAsubL: A c= L.
{ let p. assume HpA: p :e A.
  claim Hexx: exists x :e rational_numbers, p = (x, minus_SNo x).
  { exact (ReplE rational_numbers (fun x0:set => (x0, minus_SNo x0)) p HpA). }
  apply Hexx.
  let x. assume Hxpair.
  claim HxQ: x :e rational_numbers.
  { exact (andEL (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
  claim Hpeq: p = (x, minus_SNo x).
  { exact (andER (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
  claim HxR: x :e R.
  { exact (rational_numbers_in_R x HxQ). }
  claim HxSline: x :e Sorgenfrey_line.
  { claim HSlineDef: Sorgenfrey_line = R.
    { reflexivity. }
    rewrite HSlineDef.
    exact HxR. }
  rewrite Hpeq.
  exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }

claim HBsubL: B c= L.
{ let p. assume HpB: p :e B.
  claim Hexx: exists x :e (Sorgenfrey_line :\: rational_numbers), p = (x, minus_SNo x).
  { exact (ReplE (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) p HpB). }
  apply Hexx.
  let x. assume Hxpair.
  claim HxIrr: x :e (Sorgenfrey_line :\: rational_numbers).
  { exact (andEL (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
  claim Hpeq: p = (x, minus_SNo x).
  { exact (andER (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
  claim HxSline: x :e Sorgenfrey_line.
  { exact (setminusE1 Sorgenfrey_line rational_numbers x HxIrr). }
  rewrite Hpeq.
  exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }

(** show B is open in the subspace topology on L by an explicit union of special rectangles **)
claim HBopen: open_in L Ta B.
{ apply (iffER (open_in L Ta B)
               (exists V :e Tx, B = V :/\: L)
               (open_in_subspace_iff X Tx L B HTx HLsubX HBsubL)).
  set Fam := {Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1)
              | x :e (Sorgenfrey_line :\: rational_numbers)}.
  set V := Union Fam.
  witness V.
  apply andI.
  - (** V :e Tx **)
    claim HFamPow: Fam :e Power Tx.
    { apply PowerI Tx Fam.
      let W. assume HW: W :e Fam.
      prove W :e Tx.
      claim Hexx: exists x :e (Sorgenfrey_line :\: rational_numbers),
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (ReplE (Sorgenfrey_line :\: rational_numbers)
                     (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                     W
                     HW). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxIrr: x :e (Sorgenfrey_line :\: rational_numbers).
      { exact (andEL (x :e (Sorgenfrey_line :\: rational_numbers))
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HWeq:
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (andER (x :e (Sorgenfrey_line :\: rational_numbers))
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HxSline: x :e Sorgenfrey_line.
      { exact (setminusE1 Sorgenfrey_line rational_numbers x HxIrr). }
      claim HxR: x :e R.
      { claim HSlineDef: Sorgenfrey_line = R.
        { reflexivity. }
        rewrite <- HSlineDef.
        exact HxSline. }
      claim HbR: add_SNo x 1 :e R.
      { exact (real_add_SNo x HxR 1 real_1). }
      claim HmxR: minus_SNo x :e R.
      { exact (real_minus_SNo x HxR). }
      claim HdR: add_SNo (minus_SNo x) 1 :e R.
      { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
      rewrite HWeq.
      exact (Sorgenfrey_plane_special_rectangle_open x (add_SNo x 1) (add_SNo (minus_SNo x) 1) HxR HbR HdR). }
    exact (topology_union_axiom X Tx HTx Fam HFamPow). 
  - (** B = V :/\: L **)
    apply set_ext.
    { let p. assume HpB: p :e B.
      prove p :e V :/\: L.
      claim Hexx: exists x :e (Sorgenfrey_line :\: rational_numbers), p = (x, minus_SNo x).
      { exact (ReplE (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) p HpB). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxIrr: x :e (Sorgenfrey_line :\: rational_numbers).
      { exact (andEL (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
      claim Hpeq: p = (x, minus_SNo x).
      { exact (andER (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
      claim HxSline: x :e Sorgenfrey_line.
      { exact (setminusE1 Sorgenfrey_line rational_numbers x HxIrr). }
      claim HpL: p :e L.
      { rewrite Hpeq.
        exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }
      claim HpV: p :e V.
      { rewrite Hpeq.
        apply (UnionI Fam (x, minus_SNo x)
                     (Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))).
        - (** membership in the special rectangle **)
          claim HxR: x :e R.
          { claim HSlineDef: Sorgenfrey_line = R.
            { reflexivity. }
            rewrite <- HSlineDef.
            exact HxSline. }
          claim HxS: SNo x.
          { exact (real_SNo x HxR). }
          claim HmxR: minus_SNo x :e R.
          { exact (real_minus_SNo x HxR). }
          claim HmxS: SNo (minus_SNo x).
          { exact (real_SNo (minus_SNo x) HmxR). }
          claim HbR: add_SNo x 1 :e R.
          { exact (real_add_SNo x HxR 1 real_1). }
          claim HdR: add_SNo (minus_SNo x) 1 :e R.
          { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
          claim Hx0eq: add_SNo x 0 = x.
          { exact (add_SNo_0R x HxS). }
          claim Hmx0eq: add_SNo (minus_SNo x) 0 = minus_SNo x.
          { exact (add_SNo_0R (minus_SNo x) HmxS). }
          claim Hxlt: add_SNo x 0 < add_SNo x 1.
          { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hmxlt: add_SNo (minus_SNo x) 0 < add_SNo (minus_SNo x) 1.
          { exact (add_SNo_Lt2 (minus_SNo x) 0 1 HmxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hxltb: x < add_SNo x 1.
          { rewrite <- Hx0eq at 1.
            exact Hxlt. }
          claim HmxLtd: (minus_SNo x) < add_SNo (minus_SNo x) 1.
          { rewrite <- Hmx0eq at 1.
            exact Hmxlt. }
          claim HxRltb: Rlt x (add_SNo x 1).
          { exact (RltI x (add_SNo x 1) HxR HbR Hxltb). }
          claim HmxRltd: Rlt (minus_SNo x) (add_SNo (minus_SNo x) 1).
          { exact (RltI (minus_SNo x) (add_SNo (minus_SNo x) 1) HmxR HdR HmxLtd). }
          claim HxU: x :e halfopen_interval_left x (add_SNo x 1).
          { exact (halfopen_interval_left_leftmem x (add_SNo x 1) HxRltb). }
          claim HxV: (minus_SNo x) :e halfopen_interval_left (minus_SNo x) (add_SNo (minus_SNo x) 1).
          { exact (halfopen_interval_left_leftmem (minus_SNo x) (add_SNo (minus_SNo x) 1) HmxRltd). }
          exact (tuple_2_rectangle_set (halfopen_interval_left x (add_SNo x 1))
                                      (halfopen_interval_left (minus_SNo x) (add_SNo (minus_SNo x) 1))
                                      x (minus_SNo x) HxU HxV).
        - (** rectangle is in the family **)
          exact (ReplI (Sorgenfrey_line :\: rational_numbers)
                       (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                       x
                       HxIrr). }
      exact (binintersectI V L p HpV HpL).
    }
    { let p. assume HpVL: p :e V :/\: L.
      prove p :e B.
      claim HpV: p :e V.
      { exact (binintersectE1 V L p HpVL). }
      claim HpL: p :e L.
      { exact (binintersectE2 V L p HpVL). }
      (** extract t with p = (t,-t) from p∈L **)
      claim Hext: exists t :e Sorgenfrey_line, p = (t, minus_SNo t).
      { exact (ReplE Sorgenfrey_line (fun t0:set => (t0, minus_SNo t0)) p HpL). }
      apply Hext.
      let t. assume Htpair.
      claim HtSline: t :e Sorgenfrey_line.
      { exact (andEL (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
      claim Hpeq: p = (t, minus_SNo t).
      { exact (andER (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
      (** pick a generating rectangle W in Fam with p∈W **)
      apply (UnionE_impred Fam p HpV (p :e B)).
      let W. assume HpW: p :e W. assume HWFam: W :e Fam.
      prove p :e B.
      claim Hexx: exists x :e (Sorgenfrey_line :\: rational_numbers),
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (ReplE (Sorgenfrey_line :\: rational_numbers)
                     (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                     W
                     HWFam). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxIrr: x :e (Sorgenfrey_line :\: rational_numbers).
      { exact (andEL (x :e (Sorgenfrey_line :\: rational_numbers))
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HWeq:
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (andER (x :e (Sorgenfrey_line :\: rational_numbers))
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HxSline: x :e Sorgenfrey_line.
      { exact (setminusE1 Sorgenfrey_line rational_numbers x HxIrr). }
      claim HxR: x :e R.
      { claim HSlineDef: Sorgenfrey_line = R.
        { reflexivity. }
        rewrite <- HSlineDef.
        exact HxSline. }
      claim HbR: add_SNo x 1 :e R.
      { exact (real_add_SNo x HxR 1 real_1). }
      claim HmxR: minus_SNo x :e R.
      { exact (real_minus_SNo x HxR). }
      claim HdR: add_SNo (minus_SNo x) 1 :e R.
      { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
      claim HtR: t :e R.
      { claim HSlineDef: Sorgenfrey_line = R.
        { reflexivity. }
        rewrite <- HSlineDef.
        exact HtSline. }
      (** rewrite p in HpW and apply the special-rectangle lemma to get t=x **)
      claim HpInRect: (t, minus_SNo t) :e Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { rewrite <- HWeq at 1.
        rewrite <- Hpeq at 1.
        exact HpW. }
      claim Htx: t = x.
      { exact (Sorgenfrey_plane_special_rectangle_L_point x (add_SNo x 1) (add_SNo (minus_SNo x) 1) t
                HxR HbR HdR HtR HpInRect). }
      rewrite Hpeq.
      rewrite Htx.
      exact (ReplI (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) x HxIrr).
    }
}

claim HBelem: B :e Ta.
{ exact (open_in_elem L Ta B HBopen). }

claim HAeq: A = L :\: B.
{ apply set_ext.
  - let p. assume HpA: p :e A.
    prove p :e L :\: B.
    apply setminusI.
    + exact (HAsubL p HpA).
    + assume HpB: p :e B.
      prove False.
      claim HpAB: p :e A :/\: B.
      { exact (binintersectI A B p HpA HpB). }
      claim HpEmpty: p :e Empty.
      { rewrite <- Sorgenfrey_plane_diag_disjoint.
        exact HpAB. }
      exact (EmptyE p HpEmpty).
  - let p. assume HpLB: p :e L :\: B.
    prove p :e A.
    claim HpL: p :e L.
    { exact (setminusE1 L B p HpLB). }
    claim HpnotB: p /:e B.
    { exact (setminusE2 L B p HpLB). }
    claim Hext: exists t :e Sorgenfrey_line, p = (t, minus_SNo t).
    { exact (ReplE Sorgenfrey_line (fun t0:set => (t0, minus_SNo t0)) p HpL). }
    apply Hext.
    let t. assume Htpair.
    claim HtSline: t :e Sorgenfrey_line.
    { exact (andEL (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
    claim Hpeq: p = (t, minus_SNo t).
    { exact (andER (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
    apply (xm (t :e rational_numbers)).
    + assume HtQ: t :e rational_numbers.
      rewrite Hpeq.
      exact (ReplI rational_numbers (fun x0:set => (x0, minus_SNo x0)) t HtQ).
    + assume HtnQ: t /:e rational_numbers.
      apply FalseE.
      prove False.
      claim HtIrr: t :e (Sorgenfrey_line :\: rational_numbers).
      { apply setminusI.
        - exact HtSline.
        - exact HtnQ. }
      claim HpB: p :e B.
      { rewrite Hpeq.
        exact (ReplI (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) t HtIrr). }
      exact (HpnotB HpB). }

claim HAclL: closed_in L Ta A.
{ apply (closed_inI L Ta A HTa HAsubL).
  witness B.
  apply andI.
  - exact HBelem.
  - exact HAeq. }

exact (ex17_2_closed_in_closed_subspace X Tx L A HLcl HAclL).
Qed.

Theorem Sorgenfrey_plane_diag_irrational_closed :
  closed_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology Sorgenfrey_plane_diag_irrational.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
set L := Sorgenfrey_plane_L.
set Ta := subspace_topology X Tx L.
set A := Sorgenfrey_plane_diag_irrational.
set B := Sorgenfrey_plane_diag_rational.

claim HTline: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HTx: topology_on X Tx.
{ claim Hdef: Tx = product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
  { reflexivity. }
  rewrite Hdef.
  exact (product_topology_is_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HTline HTline). }

claim HLcl: closed_in X Tx L.
{ exact Sorgenfrey_plane_L_closed. }
claim HLsubX: L c= X.
{ exact (closed_in_subset X Tx L HLcl). }
claim HTa: topology_on L Ta.
{ exact (subspace_topology_is_topology X Tx L HTx HLsubX). }

claim HAsubL: A c= L.
{ let p. assume HpA: p :e A.
  claim Hexx: exists x :e (Sorgenfrey_line :\: rational_numbers), p = (x, minus_SNo x).
  { exact (ReplE (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) p HpA). }
  apply Hexx.
  let x. assume Hxpair.
  claim HxIrr: x :e (Sorgenfrey_line :\: rational_numbers).
  { exact (andEL (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
  claim Hpeq: p = (x, minus_SNo x).
  { exact (andER (x :e (Sorgenfrey_line :\: rational_numbers)) (p = (x, minus_SNo x)) Hxpair). }
  claim HxSline: x :e Sorgenfrey_line.
  { exact (setminusE1 Sorgenfrey_line rational_numbers x HxIrr). }
  rewrite Hpeq.
  exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }

claim HBsubL: B c= L.
{ let p. assume HpB: p :e B.
  claim Hexx: exists x :e rational_numbers, p = (x, minus_SNo x).
  { exact (ReplE rational_numbers (fun x0:set => (x0, minus_SNo x0)) p HpB). }
  apply Hexx.
  let x. assume Hxpair.
  claim HxQ: x :e rational_numbers.
  { exact (andEL (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
  claim Hpeq: p = (x, minus_SNo x).
  { exact (andER (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
  claim HxR: x :e R.
  { exact (rational_numbers_in_R x HxQ). }
  claim HxSline: x :e Sorgenfrey_line.
  { claim HSlineDef: Sorgenfrey_line = R.
    { reflexivity. }
    rewrite HSlineDef.
    exact HxR. }
  rewrite Hpeq.
  exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }

(** show B is open in the subspace topology on L by an explicit union of special rectangles **)
claim HBopen: open_in L Ta B.
{ apply (iffER (open_in L Ta B)
               (exists V :e Tx, B = V :/\: L)
               (open_in_subspace_iff X Tx L B HTx HLsubX HBsubL)).
  set Fam := {Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1)
              | x :e rational_numbers}.
  set V := Union Fam.
  witness V.
  apply andI.
  - (** V :e Tx **)
    claim HFamPow: Fam :e Power Tx.
    { apply PowerI Tx Fam.
      let W. assume HW: W :e Fam.
      prove W :e Tx.
      claim Hexx: exists x :e rational_numbers,
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (ReplE rational_numbers
                     (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                     W
                     HW). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxQ: x :e rational_numbers.
      { exact (andEL (x :e rational_numbers)
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HWeq:
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (andER (x :e rational_numbers)
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HxR: x :e R.
      { exact (rational_numbers_in_R x HxQ). }
      claim HbR: add_SNo x 1 :e R.
      { exact (real_add_SNo x HxR 1 real_1). }
      claim HmxR: minus_SNo x :e R.
      { exact (real_minus_SNo x HxR). }
      claim HdR: add_SNo (minus_SNo x) 1 :e R.
      { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
      rewrite HWeq.
      exact (Sorgenfrey_plane_special_rectangle_open x (add_SNo x 1) (add_SNo (minus_SNo x) 1) HxR HbR HdR). }
    exact (topology_union_axiom X Tx HTx Fam HFamPow).
  - (** B = V :/\: L **)
    apply set_ext.
    { let p. assume HpB: p :e B.
      prove p :e V :/\: L.
      claim Hexx: exists x :e rational_numbers, p = (x, minus_SNo x).
      { exact (ReplE rational_numbers (fun x0:set => (x0, minus_SNo x0)) p HpB). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxQ: x :e rational_numbers.
      { exact (andEL (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
      claim Hpeq: p = (x, minus_SNo x).
      { exact (andER (x :e rational_numbers) (p = (x, minus_SNo x)) Hxpair). }
      claim HxR: x :e R.
      { exact (rational_numbers_in_R x HxQ). }
      claim HxSline: x :e Sorgenfrey_line.
      { claim HSlineDef: Sorgenfrey_line = R.
        { reflexivity. }
        rewrite HSlineDef.
        exact HxR. }
      claim HpL: p :e L.
      { rewrite Hpeq.
        exact (ReplI Sorgenfrey_line (fun t:set => (t, minus_SNo t)) x HxSline). }
      claim HpV: p :e V.
      { rewrite Hpeq.
        apply (UnionI Fam (x, minus_SNo x)
                     (Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))).
        - (** membership in the special rectangle **)
          claim HxS: SNo x.
          { exact (real_SNo x HxR). }
          claim HmxR: minus_SNo x :e R.
          { exact (real_minus_SNo x HxR). }
          claim HmxS: SNo (minus_SNo x).
          { exact (real_SNo (minus_SNo x) HmxR). }
          claim HbR: add_SNo x 1 :e R.
          { exact (real_add_SNo x HxR 1 real_1). }
          claim HdR: add_SNo (minus_SNo x) 1 :e R.
          { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
          claim Hx0eq: add_SNo x 0 = x.
          { exact (add_SNo_0R x HxS). }
          claim Hmx0eq: add_SNo (minus_SNo x) 0 = minus_SNo x.
          { exact (add_SNo_0R (minus_SNo x) HmxS). }
          claim Hxlt: add_SNo x 0 < add_SNo x 1.
          { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hmxlt: add_SNo (minus_SNo x) 0 < add_SNo (minus_SNo x) 1.
          { exact (add_SNo_Lt2 (minus_SNo x) 0 1 HmxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hxltb: x < add_SNo x 1.
          { rewrite <- Hx0eq at 1.
            exact Hxlt. }
          claim HmxLtd: (minus_SNo x) < add_SNo (minus_SNo x) 1.
          { rewrite <- Hmx0eq at 1.
            exact Hmxlt. }
          claim HxRltb: Rlt x (add_SNo x 1).
          { exact (RltI x (add_SNo x 1) HxR HbR Hxltb). }
          claim HmxRltd: Rlt (minus_SNo x) (add_SNo (minus_SNo x) 1).
          { exact (RltI (minus_SNo x) (add_SNo (minus_SNo x) 1) HmxR HdR HmxLtd). }
          claim HxU: x :e halfopen_interval_left x (add_SNo x 1).
          { exact (halfopen_interval_left_leftmem x (add_SNo x 1) HxRltb). }
          claim HxV: (minus_SNo x) :e halfopen_interval_left (minus_SNo x) (add_SNo (minus_SNo x) 1).
          { exact (halfopen_interval_left_leftmem (minus_SNo x) (add_SNo (minus_SNo x) 1) HmxRltd). }
          exact (tuple_2_rectangle_set (halfopen_interval_left x (add_SNo x 1))
                                      (halfopen_interval_left (minus_SNo x) (add_SNo (minus_SNo x) 1))
                                      x (minus_SNo x) HxU HxV).
        - (** rectangle is in the family **)
          exact (ReplI rational_numbers
                       (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                       x
                       HxQ). }
      exact (binintersectI V L p HpV HpL).
    }
    { let p. assume HpVL: p :e V :/\: L.
      prove p :e B.
      claim HpV: p :e V.
      { exact (binintersectE1 V L p HpVL). }
      claim HpL: p :e L.
      { exact (binintersectE2 V L p HpVL). }
      claim Hext: exists t :e Sorgenfrey_line, p = (t, minus_SNo t).
      { exact (ReplE Sorgenfrey_line (fun t0:set => (t0, minus_SNo t0)) p HpL). }
      apply Hext.
      let t. assume Htpair.
      claim HtSline: t :e Sorgenfrey_line.
      { exact (andEL (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
      claim Hpeq: p = (t, minus_SNo t).
      { exact (andER (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
      apply (UnionE_impred Fam p HpV (p :e B)).
      let W. assume HpW: p :e W. assume HWFam: W :e Fam.
      prove p :e B.
      claim Hexx: exists x :e rational_numbers,
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (ReplE rational_numbers
                     (fun x0:set => Sorgenfrey_plane_special_rectangle x0 (add_SNo x0 1) (add_SNo (minus_SNo x0) 1))
                     W
                     HWFam). }
      apply Hexx.
      let x. assume Hxpair.
      claim HxQ: x :e rational_numbers.
      { exact (andEL (x :e rational_numbers)
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HWeq:
        W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { exact (andER (x :e rational_numbers)
                     (W = Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1))
                     Hxpair). }
      claim HtR: t :e R.
      { claim HSlineDef: Sorgenfrey_line = R.
        { reflexivity. }
        rewrite <- HSlineDef.
        exact HtSline. }
      claim HxR: x :e R.
      { exact (rational_numbers_in_R x HxQ). }
      claim HbR: add_SNo x 1 :e R.
      { exact (real_add_SNo x HxR 1 real_1). }
      claim HmxR: minus_SNo x :e R.
      { exact (real_minus_SNo x HxR). }
      claim HdR: add_SNo (minus_SNo x) 1 :e R.
      { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
      claim HpInRect: (t, minus_SNo t) :e Sorgenfrey_plane_special_rectangle x (add_SNo x 1) (add_SNo (minus_SNo x) 1).
      { rewrite <- HWeq at 1.
        rewrite <- Hpeq at 1.
        exact HpW. }
      claim Htx: t = x.
      { exact (Sorgenfrey_plane_special_rectangle_L_point x (add_SNo x 1) (add_SNo (minus_SNo x) 1) t
                HxR HbR HdR HtR HpInRect). }
      rewrite Hpeq.
      rewrite Htx.
      exact (ReplI rational_numbers (fun x0:set => (x0, minus_SNo x0)) x HxQ).
    }
}

claim HBelem: B :e Ta.
{ exact (open_in_elem L Ta B HBopen). }

claim HAeq: A = L :\: B.
{ apply set_ext.
  - let p. assume HpA: p :e A.
    prove p :e L :\: B.
    apply setminusI.
    + exact (HAsubL p HpA).
    + assume HpB: p :e B.
      prove False.
      claim HpAB: p :e A :/\: B.
      { exact (binintersectI A B p HpA HpB). }
      claim HpEmpty: p :e Empty.
      { claim HabEmpty: A :/\: B = Empty.
        { rewrite (binintersect_com A B).
          exact Sorgenfrey_plane_diag_disjoint. }
        rewrite <- HabEmpty.
        exact HpAB. }
      exact (EmptyE p HpEmpty).
  - let p. assume HpLB: p :e L :\: B.
    prove p :e A.
    claim HpL: p :e L.
    { exact (setminusE1 L B p HpLB). }
    claim HpnotB: p /:e B.
    { exact (setminusE2 L B p HpLB). }
    claim Hext: exists t :e Sorgenfrey_line, p = (t, minus_SNo t).
    { exact (ReplE Sorgenfrey_line (fun t0:set => (t0, minus_SNo t0)) p HpL). }
    apply Hext.
    let t. assume Htpair.
    claim HtSline: t :e Sorgenfrey_line.
    { exact (andEL (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
    claim Hpeq: p = (t, minus_SNo t).
    { exact (andER (t :e Sorgenfrey_line) (p = (t, minus_SNo t)) Htpair). }
    apply (xm (t :e rational_numbers)).
    + assume HtQ: t :e rational_numbers.
      apply FalseE.
      prove False.
      claim HpB: p :e B.
      { rewrite Hpeq.
        exact (ReplI rational_numbers (fun x0:set => (x0, minus_SNo x0)) t HtQ). }
      exact (HpnotB HpB).
    + assume HtnQ: t /:e rational_numbers.
      claim HtIrr: t :e (Sorgenfrey_line :\: rational_numbers).
      { apply setminusI.
        - exact HtSline.
        - exact HtnQ. }
      rewrite Hpeq.
      exact (ReplI (Sorgenfrey_line :\: rational_numbers) (fun x0:set => (x0, minus_SNo x0)) t HtIrr). }

claim HAclL: closed_in L Ta A.
{ apply (closed_inI L Ta A HTa HAsubL).
  witness B.
  apply andI.
  - exact HBelem.
  - exact HAeq. }

exact (ex17_2_closed_in_closed_subspace X Tx L A HLcl HAclL).
Qed.

(** from §31 Example 3 (part): L has the discrete topology as a subspace of the Sorgenfrey plane **)
(** LATEX VERSION: L = {x×(-x)} is a closed discrete subspace of R_l^2. **)
Theorem Sorgenfrey_plane_L_subspace_discrete :
  subspace_topology (setprod Sorgenfrey_line Sorgenfrey_line)
                    Sorgenfrey_plane_topology
                    Sorgenfrey_plane_L
  = discrete_topology Sorgenfrey_plane_L.
prove subspace_topology (setprod Sorgenfrey_line Sorgenfrey_line)
                        Sorgenfrey_plane_topology
                        Sorgenfrey_plane_L
  = discrete_topology Sorgenfrey_plane_L.
set X := setprod Sorgenfrey_line Sorgenfrey_line.
set Tx := Sorgenfrey_plane_topology.
set L := Sorgenfrey_plane_L.
set Ta := subspace_topology X Tx L.

claim HTline: topology_on Sorgenfrey_line Sorgenfrey_topology.
{ exact R_lower_limit_topology_is_topology. }
claim HTx: topology_on X Tx.
{ claim Hdef: Tx = product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
  { reflexivity. }
  rewrite Hdef.
  exact (product_topology_is_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HTline HTline). }
claim HLcl: closed_in X Tx L.
{ exact Sorgenfrey_plane_L_closed. }
claim HLsubX: L c= X.
{ exact (closed_in_subset X Tx L HLcl). }
claim HTa: topology_on L Ta.
{ exact (subspace_topology_is_topology X Tx L HTx HLsubX). }

(** show singleton basis is included in the subspace topology **)
claim HsingleIn: forall b :e singleton_basis L, b :e Ta.
{ let b. assume Hb: b :e singleton_basis L.
  apply (ReplE_impred L (fun x0:set => {x0}) b Hb).
  let p. assume HpL. assume Hbeq: b = {p}.
  (** show {p} is open in the subspace topology by a special rectangle neighborhood **)
  claim HsingSub: {p} c= L.
  { exact (singleton_subset p L HpL). }
  claim Hop: open_in L Ta {p}.
  { apply (iffER (open_in L Ta {p})
                 (exists V :e Tx, {p} = V :/\: L)
                 (open_in_subspace_iff X Tx L {p} HTx HLsubX HsingSub)).
    (** choose x with p = (x,-x) **)
    claim Hexx: exists x :e Sorgenfrey_line, p = (x, minus_SNo x).
    { exact (ReplE Sorgenfrey_line (fun x0:set => (x0, minus_SNo x0)) p HpL). }
    apply Hexx.
    let x. assume Hxpair.
    claim HxSline: x :e Sorgenfrey_line.
    { exact (andEL (x :e Sorgenfrey_line) (p = (x, minus_SNo x)) Hxpair). }
    claim Hpeq: p = (x, minus_SNo x).
    { exact (andER (x :e Sorgenfrey_line) (p = (x, minus_SNo x)) Hxpair). }
    claim HxR: x :e R.
    { claim HSlineDef: Sorgenfrey_line = R.
      { reflexivity. }
      rewrite <- HSlineDef.
      exact HxSline. }
    set b0 := add_SNo x 1.
    set d0 := add_SNo (minus_SNo x) 1.
    set V0 := Sorgenfrey_plane_special_rectangle x b0 d0.
    claim Hb0R: b0 :e R.
    { exact (real_add_SNo x HxR 1 real_1). }
    claim HmxR: minus_SNo x :e R.
    { exact (real_minus_SNo x HxR). }
    claim Hd0R: d0 :e R.
    { exact (real_add_SNo (minus_SNo x) HmxR 1 real_1). }
    witness V0.
    apply andI.
    - exact (Sorgenfrey_plane_special_rectangle_open x b0 d0 HxR Hb0R Hd0R).
    - (** {p} = V0 :/\: L **)
      apply set_ext.
      { let y. assume Hy: y :e {p}.
        prove y :e V0 :/\: L.
        claim Hyeq: y = p.
        { exact (SingE p y Hy). }
        rewrite Hyeq.
        apply binintersectI.
        - (** p :e V0 **)
          rewrite Hpeq.
          (** show (x,-x) belongs to the special rectangle by left endpoints **)
          claim HxS: SNo x.
          { exact (real_SNo x HxR). }
          claim HmxS: SNo (minus_SNo x).
          { exact (real_SNo (minus_SNo x) HmxR). }
          claim Hx0eq: add_SNo x 0 = x.
          { exact (add_SNo_0R x HxS). }
          claim Hmx0eq: add_SNo (minus_SNo x) 0 = minus_SNo x.
          { exact (add_SNo_0R (minus_SNo x) HmxS). }
          claim Hxlt: add_SNo x 0 < add_SNo x 1.
          { exact (add_SNo_Lt2 x 0 1 HxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hmxlt: add_SNo (minus_SNo x) 0 < add_SNo (minus_SNo x) 1.
          { exact (add_SNo_Lt2 (minus_SNo x) 0 1 HmxS SNo_0 SNo_1 SNoLt_0_1). }
          claim Hxltb: x < b0.
          { rewrite <- Hx0eq at 1.
            exact Hxlt. }
          claim Hmxltd: (minus_SNo x) < d0.
          { rewrite <- Hmx0eq at 1.
            exact Hmxlt. }
          claim HxRltb: Rlt x b0.
          { exact (RltI x b0 HxR Hb0R Hxltb). }
          claim HmxRltd: Rlt (minus_SNo x) d0.
          { exact (RltI (minus_SNo x) d0 HmxR Hd0R Hmxltd). }
          claim HxU: x :e halfopen_interval_left x b0.
          { exact (halfopen_interval_left_leftmem x b0 HxRltb). }
          claim HxV: (minus_SNo x) :e halfopen_interval_left (minus_SNo x) d0.
          { exact (halfopen_interval_left_leftmem (minus_SNo x) d0 HmxRltd). }
          claim HdefRect: Sorgenfrey_plane_special_rectangle x b0 d0
            = rectangle_set (halfopen_interval_left x b0)
                            (halfopen_interval_left (minus_SNo x) d0).
          { reflexivity. }
          rewrite HdefRect.
          rewrite rectangle_set_def.
          exact (tuple_2_setprod_by_pair_Sigma (halfopen_interval_left x b0)
                                              (halfopen_interval_left (minus_SNo x) d0)
                                              x (minus_SNo x) HxU HxV).
        - exact HpL.
      }
      { let y. assume Hy: y :e V0 :/\: L.
        prove y :e {p}.
        claim HyL: y :e L.
        { exact (binintersectE2 V0 L y Hy). }
        claim Hexy: exists t :e Sorgenfrey_line, y = (t, minus_SNo t).
        { exact (ReplE Sorgenfrey_line (fun t0:set => (t0, minus_SNo t0)) y HyL). }
        apply Hexy.
        let t. assume Htpair.
        claim HtSline: t :e Sorgenfrey_line.
        { exact (andEL (t :e Sorgenfrey_line) (y = (t, minus_SNo t)) Htpair). }
        claim Hyeq: y = (t, minus_SNo t).
        { exact (andER (t :e Sorgenfrey_line) (y = (t, minus_SNo t)) Htpair). }
        claim HyV0: y :e V0.
        { exact (binintersectE1 V0 L y Hy). }
        claim HtR: t :e R.
        { claim HSlineDef: Sorgenfrey_line = R.
          { reflexivity. }
          rewrite <- HSlineDef.
          exact HtSline. }
        claim HpInRect: (t, minus_SNo t) :e V0.
        { rewrite <- Hyeq.
          exact HyV0. }
        claim Htx: t = x.
        { exact (Sorgenfrey_plane_special_rectangle_L_point x b0 d0 t HxR Hb0R Hd0R HtR HpInRect). }
        claim HyEqP: y = p.
        { rewrite Hyeq.
          rewrite Htx.
          rewrite <- Hpeq.
          reflexivity. }
        rewrite HyEqP.
        exact (SingI p).
      }
  }
  claim HsingElem: {p} :e Ta.
  { exact (open_in_elem L Ta {p} Hop). }
  rewrite Hbeq.
  exact HsingElem.
}

claim HsingleBasis: basis_on L (singleton_basis L).
{ exact (singleton_basis_is_basis L). }
claim HdTop: discrete_topology L c= Ta.
{ (** discrete_topology L = generated_topology L (singleton_basis L) ⊆ Ta **)
  claim HgenSub: finer_than Ta (generated_topology L (singleton_basis L)).
  { exact (generated_topology_finer L (singleton_basis L) Ta HsingleBasis HTa HsingleIn). }
  claim HgenEq: generated_topology L (singleton_basis L) = discrete_topology L.
  { exact (generated_topology_singletons_discrete L). }
  rewrite <- HgenEq.
  exact HgenSub.
}

claim HTaSub: Ta c= discrete_topology L.
{ claim HTaPow: Ta c= Power L.
  { exact (topology_subset_axiom L Ta HTa). }
  exact HTaPow. }

apply set_ext.
- exact HTaSub.
- exact HdTop.
Qed.

(** helper: injections lift to power sets via images **)
Theorem inj_Power_image : forall A B:set, forall f:set->set,
  inj A B f ->
  inj (Power A) (Power B) (fun S:set => {f x|x :e S}).
let A B f.
assume Hinj: inj A B f.
prove inj (Power A) (Power B) (fun S:set => {f x|x :e S}).
apply (injI (Power A) (Power B) (fun S:set => {f x|x :e S})).
- let S. assume HS: S :e Power A.
  prove {f x|x :e S} :e Power B.
  apply PowerI.
  prove {f x|x :e S} c= B.
  let y. assume Hy: y :e {f x|x :e S}.
  prove y :e B.
  claim Himg: forall x :e A, f x :e B.
  { exact (andEL (forall x :e A, f x :e B)
                 (forall x z :e A, f x = f z -> x = z)
                 Hinj). }
  claim HSsubA: S c= A.
  { exact (PowerE A S HS). }
  apply (ReplE_impred S f y Hy (y :e B)).
  let x. assume HxS: x :e S.
  assume Hyeq: y = f x.
  claim HxA: x :e A.
  { exact (HSsubA x HxS). }
  rewrite Hyeq.
  exact (Himg x HxA).
- let S1. assume HS1: S1 :e Power A.
  let S2. assume HS2: S2 :e Power A.
  assume Heq: {f x|x :e S1} = {f x|x :e S2}.
  prove S1 = S2.
  apply set_ext.
  + let x. assume Hx1: x :e S1.
    prove x :e S2.
    claim HS1subA: S1 c= A.
    { exact (PowerE A S1 HS1). }
    claim HS2subA: S2 c= A.
    { exact (PowerE A S2 HS2). }
    claim Hinj0: forall u v :e A, f u = f v -> u = v.
    { exact (andER (forall x :e A, f x :e B)
                   (forall x z :e A, f x = f z -> x = z)
                   Hinj). }
    claim Hfx1: f x :e {f y|y :e S1}.
    { exact (ReplI S1 f x Hx1). }
    claim Hfx2: f x :e {f y|y :e S2}.
    { rewrite <- Heq.
      exact Hfx1. }
    apply (ReplE_impred S2 f (f x) Hfx2 (x :e S2)).
    let y. assume HyS2: y :e S2.
    assume Hfxy: f x = f y.
    claim HxA: x :e A.
    { exact (HS1subA x Hx1). }
    claim HyA: y :e A.
    { exact (HS2subA y HyS2). }
    claim Hxy: x = y.
    { exact (Hinj0 x HxA y HyA Hfxy). }
    rewrite Hxy.
    exact HyS2.
  + let x. assume Hx2: x :e S2.
    prove x :e S1.
    claim HS1subA: S1 c= A.
    { exact (PowerE A S1 HS1). }
    claim HS2subA: S2 c= A.
    { exact (PowerE A S2 HS2). }
    claim Hinj0: forall u v :e A, f u = f v -> u = v.
    { exact (andER (forall x :e A, f x :e B)
                   (forall x z :e A, f x = f z -> x = z)
                   Hinj). }
    claim Hfx2: f x :e {f y|y :e S2}.
    { exact (ReplI S2 f x Hx2). }
    claim Hfx1: f x :e {f y|y :e S1}.
    { rewrite Heq.
      exact Hfx2. }
    apply (ReplE_impred S1 f (f x) Hfx1 (x :e S1)).
    let y. assume HyS1: y :e S1.
    assume Hfxy: f x = f y.
    claim HxA: x :e A.
    { exact (HS2subA x Hx2). }
    claim HyA: y :e A.
    { exact (HS1subA y HyS1). }
    claim Hxy: x = y.
    { exact (Hinj0 x HxA y HyA Hfxy). }
    rewrite Hxy.
    exact HyS1.
Qed.

Theorem ex31_9_Sorgenfrey_plane_no_separation :
  ~ (exists U V:set,
      open_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology U /\
      open_in (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology V /\
      Sorgenfrey_plane_diag_rational c= U /\
      Sorgenfrey_plane_diag_irrational c= V /\
      U :/\: V = Empty).
admit. (** FAIL **)
Qed.

(** from §31 Example 3: Sorgenfrey plane not normal **) 
(** LATEX VERSION: The Sorgenfrey plane is regular but not normal. **)
Theorem Sorgenfrey_plane_not_normal :
  regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology /\
  ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology /\
  ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
apply andI.
- (** regularity of the Sorgenfrey plane (skeleton) **)
  claim HdefTop:
    Sorgenfrey_plane_topology =
      product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology.
  { reflexivity. }
	rewrite HdefTop.
	exact (product_topology_regular Sorgenfrey_line Sorgenfrey_topology
		                                 Sorgenfrey_line Sorgenfrey_topology
		                                 Sorgenfrey_line_regular Sorgenfrey_line_regular).
		- (** non-normality of the Sorgenfrey plane via Cantor argument **)
		  assume Hnorm: normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
		  prove False.
		  set X := setprod Sorgenfrey_line Sorgenfrey_line.
		  set Tx := Sorgenfrey_plane_topology.
		  set L := Sorgenfrey_plane_L.
		  set D := Sorgenfrey_plane_rational_points.
		  claim HTx: topology_on X Tx.
		  { exact (normal_space_topology_on X Tx Hnorm). }
		  claim HcountD: countable_set D.
		  { exact Sorgenfrey_plane_rational_points_countable. }
		  claim Hdense: closure_of X Tx D = X.
		  { exact Sorgenfrey_plane_rational_points_dense. }
		  claim HLcl: closed_in X Tx L.
		  { exact Sorgenfrey_plane_L_closed. }
		  claim HLsubX: L c= X.
		  { exact (closed_in_subset X Tx L HLcl). }
		  set Ta := subspace_topology X Tx L.
		  claim HTa: topology_on L Ta.
		  { exact (subspace_topology_is_topology X Tx L HTx HLsubX). }
		  claim HTaEq: Ta = discrete_topology L.
		  { claim HdefTa: Ta = subspace_topology X Tx L.
		    { reflexivity. }
		    rewrite HdefTa.
		    exact Sorgenfrey_plane_L_subspace_discrete. }
		  claim HsepFn:
		    forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
		      exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty.
		  { exact (andER (one_point_sets_closed X Tx)
		                 (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
		                   exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
		                 Hnorm). }

		  (** choose for each A ⊂ L a separating pair (U_A,V_A) and define theta(A)=D∩U_A **)
		  set UV := fun A:set =>
		    Eps_i (fun W:set =>
		      exists U V:set,
		        W = (U,V) /\
		        (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty)).
		  set Uof := fun A:set => (UV A) 0.
		  set Vof := fun A:set => (UV A) 1.
		  set theta := fun A:set => D :/\: (Uof A).

		  claim HUV_ok: forall A :e Power L,
		    exists U V:set,
		      UV A = (U,V) /\
		      (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty).
		  { let A. assume HA: A :e Power L.
		    prove exists U V:set,
		      UV A = (U,V) /\
		      (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty).
		    claim HAsubL: A c= L.
		    { exact (PowerE L A HA). }
		    claim HAcSubL: (L :\: A) c= L.
		    { apply setminus_Subq. }
		    claim HAopenTa: A :e Ta.
		    { rewrite HTaEq.
		      exact (PowerI L A HAsubL). }
		    claim HAcopenTa: (L :\: A) :e Ta.
		    { rewrite HTaEq.
		      exact (PowerI L (L :\: A) HAcSubL). }
		    claim HAcclTa0: closed_in L Ta (L :\: (L :\: A)).
		    { exact (closed_of_open_complement L Ta (L :\: A) HTa HAcopenTa). }
		    claim Hsetminus1: L :\: (L :\: A) = A.
		    { exact (setminus_setminus_eq L A HAsubL). }
		    claim HAclTa: closed_in L Ta A.
		    { rewrite <- Hsetminus1.
		      exact HAcclTa0. }
		    claim HAcclTa: closed_in L Ta (L :\: A).
		    { exact (closed_of_open_complement L Ta A HTa HAopenTa). }
		    claim HAcl: closed_in X Tx A.
		    { exact (ex17_2_closed_in_closed_subspace X Tx L A HLcl HAclTa). }
		    claim HAccl: closed_in X Tx (L :\: A).
		    { exact (ex17_2_closed_in_closed_subspace X Tx L (L :\: A) HLcl HAcclTa). }
		    claim Hdisj: A :/\: (L :\: A) = Empty.
		    { apply set_ext.
		      - let x. assume Hx: x :e A :/\: (L :\: A).
		        prove x :e Empty.
		        claim HxA: x :e A.
		        { exact (binintersectE1 A (L :\: A) x Hx). }
		        claim HxAc: x :e (L :\: A).
		        { exact (binintersectE2 A (L :\: A) x Hx). }
		        claim HxNotA: x /:e A.
		        { exact (andER (x :e L) (x /:e A) (setminusE L A x HxAc)). }
		        exact (FalseE (HxNotA HxA) (x :e Empty)).
		      - let x. assume Hx: x :e Empty.
		        prove x :e A :/\: (L :\: A).
		        exact (EmptyE x Hx (x :e A :/\: (L :\: A))). }
		    claim HexUV:
		      exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty.
		    { exact (HsepFn A (L :\: A) HAcl HAccl Hdisj). }
		    claim HexW:
		      exists W:set,
		        (exists U V:set,
		           W = (U,V) /\
		           (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty)).
		    { apply HexUV.
		      let U. assume HexV.
		      apply HexV.
		      let V. assume HUV.
		      witness (U,V).
		      witness U.
		      witness V.
		      apply andI.
		      - reflexivity.
		      - exact HUV. }
		    claim HUVeps:
		      exists U V:set,
		        UV A = (U,V) /\
		        (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty).
		    { exact (Eps_i_ex (fun W:set =>
		              exists U V:set,
		                W = (U,V) /\
		                (U :e Tx /\ V :e Tx /\ A c= U /\ (L :\: A) c= V /\ U :/\: V = Empty)) HexW). }
		    exact HUVeps. }

		  claim Htheta_inj: inj (Power L) (Power D) theta.
		  { apply (injI (Power L) (Power D) theta).
		    - let A. assume HA: A :e Power L.
		      prove theta A :e Power D.
		      apply PowerI.
		      exact (binintersect_Subq_1 D (Uof A)).
		    - let A. assume HA: A :e Power L.
		      let B. assume HB: B :e Power L.
		      assume Heq: theta A = theta B.
		      prove A = B.
		      claim HAB: A c= B.
		      { let p. assume HpA: p :e A.
		        prove p :e B.
		        apply xm (p :e B).
		        + assume HpB: p :e B.
		          exact HpB.
		        + assume HpNotB: p /:e B.
		          prove p :e B.
		          claim HAsubL: A c= L.
		          { exact (PowerE L A HA). }
		          claim HBsubL: B c= L.
		          { exact (PowerE L B HB). }
		          claim HpL: p :e L.
		          { exact (HAsubL p HpA). }
		          claim HpLB: p :e (L :\: B).
		          { exact (setminusI L B p HpL HpNotB). }
		          claim HexA: exists U1 V1:set,
		            UV A = (U1,V1) /\
		            (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty).
		          { exact (HUV_ok A HA). }
		          claim HexB: exists U2 V2:set,
		            UV B = (U2,V2) /\
		            (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty).
		          { exact (HUV_ok B HB). }
		          apply HexA.
		          let U1. assume HexV1.
		          apply HexV1.
		          let V1. assume HpackA.
		          apply HexB.
		          let U2. assume HexV2.
		          apply HexV2.
		          let V2. assume HpackB.
		          claim HUV_A: UV A = (U1,V1).
		          { exact (andEL (UV A = (U1,V1))
		                         (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty)
		                         HpackA). }
		          claim HUV_B: UV B = (U2,V2).
		          { exact (andEL (UV B = (U2,V2))
		                         (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty)
		                         HpackB). }
		          claim HpropsA:
		            U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty.
		          { exact (andER (UV A = (U1,V1))
		                         (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty)
		                         HpackA). }
		          claim HpropsB:
		            U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty.
		          { exact (andER (UV B = (U2,V2))
		                         (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty)
		                         HpackB). }
		          claim HleftA:
		            ((U1 :e Tx /\ V1 :e Tx) /\ A c= U1) /\ (L :\: A) c= V1.
		          { exact (andEL (((U1 :e Tx /\ V1 :e Tx) /\ A c= U1) /\ (L :\: A) c= V1)
		                         (U1 :/\: V1 = Empty)
		                         HpropsA). }
		          claim HUV1pair: (U1 :e Tx /\ V1 :e Tx) /\ A c= U1.
		          { exact (andEL ((U1 :e Tx /\ V1 :e Tx) /\ A c= U1)
		                         ((L :\: A) c= V1)
		                         HleftA). }
		          claim HU1V1: U1 :e Tx /\ V1 :e Tx.
		          { exact (andEL (U1 :e Tx /\ V1 :e Tx) (A c= U1) HUV1pair). }
		          claim HU1: U1 :e Tx.
		          { exact (andEL (U1 :e Tx) (V1 :e Tx) HU1V1). }
		          claim HAsubU1: A c= U1.
		          { exact (andER (U1 :e Tx /\ V1 :e Tx) (A c= U1) HUV1pair). }
		          claim HleftB:
		            ((U2 :e Tx /\ V2 :e Tx) /\ B c= U2) /\ (L :\: B) c= V2.
		          { exact (andEL (((U2 :e Tx /\ V2 :e Tx) /\ B c= U2) /\ (L :\: B) c= V2)
		                         (U2 :/\: V2 = Empty)
		                         HpropsB). }
		          claim HUV2pair: (U2 :e Tx /\ V2 :e Tx) /\ B c= U2.
		          { exact (andEL ((U2 :e Tx /\ V2 :e Tx) /\ B c= U2)
		                         ((L :\: B) c= V2)
		                         HleftB). }
		          claim HU2V2: U2 :e Tx /\ V2 :e Tx.
		          { exact (andEL (U2 :e Tx /\ V2 :e Tx) (B c= U2) HUV2pair). }
		          claim HV2: V2 :e Tx.
		          { exact (andER (U2 :e Tx) (V2 :e Tx) HU2V2). }
		          claim HLBsubV2: (L :\: B) c= V2.
		          { exact (andER ((U2 :e Tx /\ V2 :e Tx) /\ B c= U2)
		                         ((L :\: B) c= V2)
		                         HleftB). }
		          claim HdisjB: U2 :/\: V2 = Empty.
		          { exact (andER (((U2 :e Tx /\ V2 :e Tx) /\ B c= U2) /\ (L :\: B) c= V2)
		                         (U2 :/\: V2 = Empty)
		                         HpropsB). }
		          claim HpU1: p :e U1.
		          { exact (HAsubU1 p HpA). }
		          claim HpV2: p :e V2.
		          { exact (HLBsubV2 p HpLB). }
		          set W := U1 :/\: V2.
		          claim HWopen: W :e Tx.
		          { exact (topology_binintersect_axiom X Tx HTx U1 HU1 V2 HV2). }
		          claim HWne: W <> Empty.
		          { exact (elem_implies_nonempty W p (binintersectI U1 V2 p HpU1 HpV2)). }
		          claim HWmeet: W :/\: D <> Empty.
		          { exact (dense_in_meets_nonempty_open D X Tx W HTx Hdense HWopen HWne). }
		          claim Hexd: exists d:set, d :e W :/\: D.
		          { exact (nonempty_has_element (W :/\: D) HWmeet). }
		          apply Hexd.
		          let d. assume HdWD: d :e W :/\: D.
		          claim HdW: d :e W.
		          { exact (binintersectE1 W D d HdWD). }
		          claim HdD: d :e D.
		          { exact (binintersectE2 W D d HdWD). }
		          claim HdefW: W = U1 :/\: V2.
		          { reflexivity. }
		          claim HdWV: d :e U1 :/\: V2.
		          { rewrite <- HdefW.
		            exact HdW. }
		          claim HdU1: d :e U1.
		          { exact (binintersectE1 U1 V2 d HdWV). }
		          claim HdV2: d :e V2.
		          { exact (binintersectE2 U1 V2 d HdWV). }
		          claim HUofA: Uof A = U1.
		          { claim HdefU: Uof A = (UV A) 0.
		            { reflexivity. }
		            rewrite HdefU.
		            rewrite HUV_A.
		            rewrite <- (tuple_pair U1 V1).
		            exact (pair_ap_0 U1 V1). }
		          claim HUofB: Uof B = U2.
		          { claim HdefU: Uof B = (UV B) 0.
		            { reflexivity. }
		            rewrite HdefU.
		            rewrite HUV_B.
		            rewrite <- (tuple_pair U2 V2).
		            exact (pair_ap_0 U2 V2). }
		          claim HVofB: Vof B = V2.
		          { claim HdefV: Vof B = (UV B) 1.
		            { reflexivity. }
		            rewrite HdefV.
		            rewrite HUV_B.
		            rewrite <- (tuple_pair U2 V2).
		            exact (pair_ap_1 U2 V2). }
		          claim HdthetaA: d :e theta A.
		          { claim HdefTheta: theta A = D :/\: (Uof A).
		            { reflexivity. }
		            rewrite HdefTheta.
		            rewrite HUofA.
		            exact (binintersectI D U1 d HdD HdU1). }
		          claim HdNotUofB: d /:e Uof B.
		          { assume HdUofB: d :e Uof B.
		            claim HdU2: d :e U2.
		            { rewrite <- HUofB.
		              exact HdUofB. }
		            claim HdUV0: d :e U2 :/\: V2.
		            { exact (binintersectI U2 V2 d HdU2 HdV2). }
		            claim HdEmpty: d :e Empty.
		            { rewrite <- HdisjB.
		              exact HdUV0. }
		            exact (EmptyE d HdEmpty False). }
		          claim HdNotThetaB: d /:e theta B.
		          { assume HdthetaB: d :e theta B.
		            claim HdefThetaB: theta B = D :/\: (Uof B).
		            { reflexivity. }
		            claim HdthetaB0: d :e D :/\: (Uof B).
		            { rewrite <- HdefThetaB.
		              exact HdthetaB. }
		            claim HdUofB: d :e Uof B.
		            { exact (binintersectE2 D (Uof B) d HdthetaB0). }
		            exact (HdNotUofB HdUofB). }
		          claim HdthetaB0: d :e theta B.
		          { rewrite <- Heq.
		            exact HdthetaA. }
			          exact (FalseE (HdNotThetaB HdthetaB0) (p :e B)). }
		      claim HBA: B c= A.
		      { let p. assume HpB: p :e B.
		        prove p :e A.
		        apply xm (p :e A).
		        + assume HpA: p :e A.
		          exact HpA.
		        + assume HpNotA: p /:e A.
		          prove p :e A.
		          claim HAsubL: A c= L.
		          { exact (PowerE L A HA). }
		          claim HBsubL: B c= L.
		          { exact (PowerE L B HB). }
		          claim HpL: p :e L.
		          { exact (HBsubL p HpB). }
		          claim HpLA: p :e (L :\: A).
		          { exact (setminusI L A p HpL HpNotA). }
		          claim HexA: exists U1 V1:set,
		            UV A = (U1,V1) /\
		            (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty).
		          { exact (HUV_ok A HA). }
		          claim HexB: exists U2 V2:set,
		            UV B = (U2,V2) /\
		            (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty).
		          { exact (HUV_ok B HB). }
		          apply HexA.
		          let U1. assume HexV1.
		          apply HexV1.
		          let V1. assume HpackA.
		          apply HexB.
		          let U2. assume HexV2.
		          apply HexV2.
		          let V2. assume HpackB.
		          claim HUV_A: UV A = (U1,V1).
		          { exact (andEL (UV A = (U1,V1))
		                         (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty)
		                         HpackA). }
		          claim HUV_B: UV B = (U2,V2).
		          { exact (andEL (UV B = (U2,V2))
		                         (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty)
		                         HpackB). }
		          claim HpropsA:
		            U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty.
		          { exact (andER (UV A = (U1,V1))
		                         (U1 :e Tx /\ V1 :e Tx /\ A c= U1 /\ (L :\: A) c= V1 /\ U1 :/\: V1 = Empty)
		                         HpackA). }
		          claim HpropsB:
		            U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty.
		          { exact (andER (UV B = (U2,V2))
		                         (U2 :e Tx /\ V2 :e Tx /\ B c= U2 /\ (L :\: B) c= V2 /\ U2 :/\: V2 = Empty)
		                         HpackB). }
		          claim HleftA:
		            ((U1 :e Tx /\ V1 :e Tx) /\ A c= U1) /\ (L :\: A) c= V1.
		          { exact (andEL (((U1 :e Tx /\ V1 :e Tx) /\ A c= U1) /\ (L :\: A) c= V1)
		                         (U1 :/\: V1 = Empty)
		                         HpropsA). }
		          claim HUV1pair: (U1 :e Tx /\ V1 :e Tx) /\ A c= U1.
		          { exact (andEL ((U1 :e Tx /\ V1 :e Tx) /\ A c= U1)
		                         ((L :\: A) c= V1)
		                         HleftA). }
		          claim HU1V1: U1 :e Tx /\ V1 :e Tx.
		          { exact (andEL (U1 :e Tx /\ V1 :e Tx) (A c= U1) HUV1pair). }
		          claim HV1: V1 :e Tx.
		          { exact (andER (U1 :e Tx) (V1 :e Tx) HU1V1). }
		          claim HLBsubV1: (L :\: A) c= V1.
		          { exact (andER ((U1 :e Tx /\ V1 :e Tx) /\ A c= U1)
		                         ((L :\: A) c= V1)
		                         HleftA). }
		          claim HdisjA: U1 :/\: V1 = Empty.
		          { exact (andER (((U1 :e Tx /\ V1 :e Tx) /\ A c= U1) /\ (L :\: A) c= V1)
		                         (U1 :/\: V1 = Empty)
		                         HpropsA). }
		          claim HleftB:
		            ((U2 :e Tx /\ V2 :e Tx) /\ B c= U2) /\ (L :\: B) c= V2.
		          { exact (andEL (((U2 :e Tx /\ V2 :e Tx) /\ B c= U2) /\ (L :\: B) c= V2)
		                         (U2 :/\: V2 = Empty)
		                         HpropsB). }
		          claim HUV2pair: (U2 :e Tx /\ V2 :e Tx) /\ B c= U2.
		          { exact (andEL ((U2 :e Tx /\ V2 :e Tx) /\ B c= U2)
		                         ((L :\: B) c= V2)
		                         HleftB). }
		          claim HU2V2: U2 :e Tx /\ V2 :e Tx.
		          { exact (andEL (U2 :e Tx /\ V2 :e Tx) (B c= U2) HUV2pair). }
		          claim HU2: U2 :e Tx.
		          { exact (andEL (U2 :e Tx) (V2 :e Tx) HU2V2). }
		          claim HBsubU2: B c= U2.
		          { exact (andER (U2 :e Tx /\ V2 :e Tx) (B c= U2) HUV2pair). }
		          claim HpU2: p :e U2.
		          { exact (HBsubU2 p HpB). }
		          claim HpV1: p :e V1.
		          { exact (HLBsubV1 p HpLA). }
		          set W := U2 :/\: V1.
		          claim HWopen: W :e Tx.
		          { exact (topology_binintersect_axiom X Tx HTx U2 HU2 V1 HV1). }
		          claim HWne: W <> Empty.
		          { exact (elem_implies_nonempty W p (binintersectI U2 V1 p HpU2 HpV1)). }
		          claim HWmeet: W :/\: D <> Empty.
		          { exact (dense_in_meets_nonempty_open D X Tx W HTx Hdense HWopen HWne). }
		          claim Hexd: exists d:set, d :e W :/\: D.
		          { exact (nonempty_has_element (W :/\: D) HWmeet). }
		          apply Hexd.
		          let d. assume HdWD: d :e W :/\: D.
		          claim HdW: d :e W.
		          { exact (binintersectE1 W D d HdWD). }
		          claim HdD: d :e D.
		          { exact (binintersectE2 W D d HdWD). }
		          claim HdefW: W = U2 :/\: V1.
		          { reflexivity. }
		          claim HdWV: d :e U2 :/\: V1.
		          { rewrite <- HdefW.
		            exact HdW. }
		          claim HdU2: d :e U2.
		          { exact (binintersectE1 U2 V1 d HdWV). }
		          claim HdV1: d :e V1.
		          { exact (binintersectE2 U2 V1 d HdWV). }
		          claim HUofA: Uof A = U1.
		          { claim HdefU: Uof A = (UV A) 0.
		            { reflexivity. }
		            rewrite HdefU.
		            rewrite HUV_A.
		            rewrite <- (tuple_pair U1 V1).
		            exact (pair_ap_0 U1 V1). }
		          claim HUofB: Uof B = U2.
		          { claim HdefU: Uof B = (UV B) 0.
		            { reflexivity. }
		            rewrite HdefU.
		            rewrite HUV_B.
		            rewrite <- (tuple_pair U2 V2).
		            exact (pair_ap_0 U2 V2). }
		          claim HdthetaB: d :e theta B.
		          { claim HdefTheta: theta B = D :/\: (Uof B).
		            { reflexivity. }
		            rewrite HdefTheta.
		            rewrite HUofB.
		            exact (binintersectI D U2 d HdD HdU2). }
		          claim HdNotUofA: d /:e Uof A.
		          { assume HdUofA: d :e Uof A.
		            claim HdU1: d :e U1.
		            { rewrite <- HUofA.
		              exact HdUofA. }
		            claim HdUV0: d :e U1 :/\: V1.
		            { exact (binintersectI U1 V1 d HdU1 HdV1). }
		            claim HdEmpty: d :e Empty.
		            { rewrite <- HdisjA.
		              exact HdUV0. }
		            exact (EmptyE d HdEmpty False). }
		          claim HdNotThetaA: d /:e theta A.
		          { assume HdthetaA: d :e theta A.
		            claim HdUofA: d :e Uof A.
		            { exact (binintersectE2 D (Uof A) d HdthetaA). }
		            exact (HdNotUofA HdUofA). }
		          claim HdthetaA0: d :e theta A.
		          { rewrite Heq.
		            exact HdthetaB. }
		          exact (FalseE (HdNotThetaA HdthetaA0) (p :e A)). }
		      exact (set_ext A B HAB HBA).
		  }
		
		  (** build an injection Power(Power omega) -> Power omega and contradict Cantor **)
		  apply HcountD.
		  let fD. assume HfD: inj D omega fD.
		  set Pow_fD := fun S:set => {fD x|x :e S}.
		  claim HpowD: inj (Power D) (Power omega) Pow_fD.
		  { exact (inj_Power_image D omega fD HfD). }
		  claim HeqR: equip real (Power omega).
		  { exact equip_real_Power_omega. }
		  claim HeqRsym: equip (Power omega) real.
		  { exact (equip_sym real (Power omega) HeqR). }
		  claim HatleastpPow: atleastp (Power omega) real.
		  { exact (equip_atleastp (Power omega) real HeqRsym). }
		  apply HatleastpPow.
		  let h0. assume Hh0: inj (Power omega) real h0.
		  claim HlineDef: Sorgenfrey_line = real.
		  { claim H1: Sorgenfrey_line = R.
		    { reflexivity. }
		    claim H2: R = real.
		    { reflexivity. }
		    rewrite H1.
		    exact H2. }
		  claim Hh0line: inj (Power omega) Sorgenfrey_line h0.
		  { rewrite HlineDef.
		    exact Hh0. }
		  claim HinjLineL: inj Sorgenfrey_line L (fun x:set => (x, minus_SNo x)).
		  { apply (injI Sorgenfrey_line L (fun x:set => (x, minus_SNo x))).
		    - let x. assume Hx: x :e Sorgenfrey_line.
		      prove (x, minus_SNo x) :e L.
		      exact (ReplI Sorgenfrey_line (fun x0:set => (x0, minus_SNo x0)) x Hx).
		    - let x1. assume Hx1: x1 :e Sorgenfrey_line.
		      let x2. assume Hx2: x2 :e Sorgenfrey_line.
		      assume Heq: (x1, minus_SNo x1) = (x2, minus_SNo x2).
		      prove x1 = x2.
		      claim H0: (x1, minus_SNo x1) 0 = (x2, minus_SNo x2) 0.
		      { rewrite Heq. reflexivity. }
		      claim Hx10: (x1, minus_SNo x1) 0 = x1.
		      { rewrite <- (tuple_pair x1 (minus_SNo x1)).
		        exact (pair_ap_0 x1 (minus_SNo x1)). }
		      claim Hx20: (x2, minus_SNo x2) 0 = x2.
		      { rewrite <- (tuple_pair x2 (minus_SNo x2)).
		        exact (pair_ap_0 x2 (minus_SNo x2)). }
		      rewrite <- Hx10 at 1.
		      rewrite <- Hx20.
		      exact H0. }
		  claim HinjPowL: inj (Power omega) L (fun S:set => (fun x:set => (x, minus_SNo x)) (h0 S)).
		  { exact (inj_comp (Power omega) Sorgenfrey_line L h0 (fun x:set => (x, minus_SNo x))
		                    Hh0line HinjLineL). }
		  set Pow_h := fun S:set => { (fun S0:set => (fun x:set => (x, minus_SNo x)) (h0 S0)) x | x :e S }.
		  claim HpowL: inj (Power (Power omega)) (Power L) Pow_h.
		  { exact (inj_Power_image (Power omega) L (fun S0:set => (fun x:set => (x, minus_SNo x)) (h0 S0)) HinjPowL). }
		  set mid := fun S:set => theta (Pow_h S).
		  claim Hmid: inj (Power (Power omega)) (Power D) mid.
		  { exact (inj_comp (Power (Power omega)) (Power L) (Power D) Pow_h theta HpowL Htheta_inj). }
		  set final := fun S:set => Pow_fD (mid S).
		  claim Hfinal: inj (Power (Power omega)) (Power omega) final.
		  { exact (inj_comp (Power (Power omega)) (Power D) (Power omega) mid Pow_fD Hmid HpowD). }
		  exact ((form100_63_injCantor (Power omega) final) Hfinal).
Qed.

(** helper: if a set injects into omega, then the preimage of a finite initial segment is finite **)
(** LATEX VERSION: A subset of a finite set is finite; hence for an injection f:A→ω, the set of a with f(a)≤n is finite. **)
Theorem inj_omega_preimage_ordsucc_finite : forall A n:set, forall f:set->set,
  nat_p n ->
  inj A omega f ->
  finite {a :e A | f a :e ordsucc n}.
let A n f.
assume Hn: nat_p n.
assume Hinj: inj A omega f.
set An := {a :e A | f a :e ordsucc n}.
claim Hsucc: nat_p (ordsucc n).
{ exact (nat_ordsucc n Hn). }
claim HinjAn: inj An (ordsucc n) f.
{ prove (forall u :e An, f u :e ordsucc n) /\ (forall u v :e An, f u = f v -> u = v).
  apply andI.
  - let u. assume Hu: u :e An.
    exact (SepE2 A (fun a0:set => f a0 :e ordsucc n) u Hu).
  - let u. assume Hu: u :e An.
    let v. assume Hv: v :e An.
    assume Heq: f u = f v.
    claim HuA: u :e A.
    { exact (SepE1 A (fun a0:set => f a0 :e ordsucc n) u Hu). }
    claim HvA: v :e A.
    { exact (SepE1 A (fun a0:set => f a0 :e ordsucc n) v Hv). }
    claim Hinj0: forall x z :e A, f x = f z -> x = z.
    { exact (andER (forall x :e A, f x :e omega)
                   (forall x z :e A, f x = f z -> x = z)
                   Hinj). }
    exact (Hinj0 u HuA v HvA Heq).
}
exact (inj_into_finite_nat An (ordsucc n) f Hsucc HinjAn).
Qed.

(** helper: union of the empty family is empty **)
(** LATEX VERSION: Union of the empty family of sets is empty. **)
Theorem Union_Empty_eq : Union Empty = Empty.
apply set_ext.
- let x. assume Hx: x :e Union Empty.
  prove x :e Empty.
  apply (UnionE_impred Empty x Hx (x :e Empty)).
  let U. assume _: x :e U.
  assume HU: U :e Empty.
  exact (EmptyE U HU (x :e Empty)).
- let x. assume Hx: x :e Empty.
  prove x :e Union Empty.
  exact (EmptyE x Hx (x :e Union Empty)).
Qed.

(** helper: Union(F ∪ {y}) = Union(F) ∪ y **)
(** LATEX VERSION: Union distributes over adjoining a singleton to the index family. **)
Theorem Union_binunion_singleton_eq : forall F y:set,
  Union (F :\/: {y}) = (Union F) :\/: y.
let F y.
apply set_ext.
- let x. assume Hx: x :e Union (F :\/: {y}).
  prove x :e (Union F) :\/: y.
  apply (UnionE_impred (F :\/: {y}) x Hx (x :e (Union F) :\/: y)).
  let U. assume HxU: x :e U.
  assume HU: U :e (F :\/: {y}).
  apply (binunionE F {y} U HU (x :e (Union F) :\/: y)).
  + assume HU_F: U :e F.
    exact (binunionI1 (Union F) y x (UnionI F x U HxU HU_F)).
  + assume HU_sing: U :e {y}.
    claim HUeq: U = y.
    { exact (SingE y U HU_sing). }
    claim Hxy: x :e y.
    { rewrite <- HUeq.
      exact HxU. }
    exact (binunionI2 (Union F) y x Hxy).
- let x. assume Hx: x :e (Union F) :\/: y.
  prove x :e Union (F :\/: {y}).
  apply (binunionE (Union F) y x Hx (x :e Union (F :\/: {y}))).
  + assume HxUF: x :e Union F.
    apply (UnionE_impred F x HxUF (x :e Union (F :\/: {y}))).
    let U. assume HxU: x :e U.
    assume HU_F: U :e F.
    exact (UnionI (F :\/: {y}) x U HxU (binunionI1 F {y} U HU_F)).
  + assume Hxy: x :e y.
    exact (UnionI (F :\/: {y}) x y Hxy (binunionI2 F {y} y (SingI y))).
Qed.

(** helper: finite unions of closed sets are closed **)
(** LATEX VERSION: A finite union of closed sets is closed. **)
Theorem finite_union_closed_in : forall X Tx F:set,
  topology_on X Tx ->
  finite F ->
  (forall C:set, C :e F -> closed_in X Tx C) ->
  closed_in X Tx (Union F).
let X Tx F.
assume HTx: topology_on X Tx.
assume HFfin: finite F.
assume Hall: forall C:set, C :e F -> closed_in X Tx C.
set p := fun F0:set =>
  (forall C:set, C :e F0 -> closed_in X Tx C) ->
  closed_in X Tx (Union F0).
claim HpEmpty: p Empty.
{ assume Hall0: forall C:set, C :e Empty -> closed_in X Tx C.
  rewrite Union_Empty_eq.
  exact (Empty_is_closed X Tx HTx). }
claim HpStep: forall F0 y:set,
  finite F0 ->
  y /:e F0 ->
  p F0 ->
  p (F0 :\/: {y}).
{ let F0 y.
  assume HF0fin: finite F0.
  assume HyNot: y /:e F0.
  assume IH: p F0.
  assume HallU: forall C:set, C :e (F0 :\/: {y}) -> closed_in X Tx C.
  claim HallF0: forall C:set, C :e F0 -> closed_in X Tx C.
  { let C. assume HC: C :e F0.
    exact (HallU C (binunionI1 F0 {y} C HC)). }
  claim HUnionF0closed: closed_in X Tx (Union F0).
  { exact (IH HallF0). }
  claim HyClosed: closed_in X Tx y.
  { exact (HallU y (binunionI2 F0 {y} y (SingI y))). }
  rewrite (Union_binunion_singleton_eq F0 y).
  exact (closed_binunion X Tx (Union F0) y HUnionF0closed HyClosed). }
claim HallF: p F.
{ exact (finite_ind p HpEmpty HpStep F HFfin). }
exact (HallF Hall).
Qed.

(** from §32 Theorem 32.1: regular space with countable basis is normal **) 
(** LATEX VERSION: Regular + second countable ⇒ normal (Theorem 32.1). **)
Theorem regular_countable_basis_normal : forall X Tx:set,
  regular_space X Tx -> second_countable_space X Tx -> normal_space X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume Hscc: second_countable_space X Tx.
prove normal_space X Tx.
(** Theorem 32.1 proof follows topology.tex: choose countable basis elements whose closures miss the other closed set, then apply the standard countable separation trick. **)
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1). }
prove one_point_sets_closed X Tx /\
  forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
apply andI.
- exact HT1.
- let A B.
  assume HAcl: closed_in X Tx A.
  assume HBcl: closed_in X Tx B.
  assume HAB: A :/\: B = Empty.
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HAcl). }
  claim HBsubX: B c= X.
  { exact (closed_in_subset X Tx B HBcl). }
  claim HexBasis: exists Basis:set, basis_on X Basis /\ countable_set Basis /\ basis_generates X Basis Tx.
  { exact (andER (topology_on X Tx)
                 (exists B0:set, basis_on X B0 /\ countable_set B0 /\ basis_generates X B0 Tx)
                 Hscc). }
  apply HexBasis.
  let Basis.
  assume HBasisPack: basis_on X Basis /\ countable_set Basis /\ basis_generates X Basis Tx.
  claim HBCore: (basis_on X Basis /\ countable_set Basis) /\ basis_generates X Basis Tx.
  { exact HBasisPack. }
  claim HBasisCount: (basis_on X Basis /\ countable_set Basis).
  { exact (andEL (basis_on X Basis /\ countable_set Basis) (basis_generates X Basis Tx) HBCore). }
  claim Hgen: basis_generates X Basis Tx.
  { exact (andER (basis_on X Basis /\ countable_set Basis) (basis_generates X Basis Tx) HBCore). }
  claim HBasis: basis_on X Basis.
  { exact (andEL (basis_on X Basis) (countable_set Basis) HBasisCount). }
  claim HBcount: countable_set Basis.
  { exact (andER (basis_on X Basis) (countable_set Basis) HBasisCount). }
  claim HgenEq: generated_topology X Basis = Tx.
  { exact (andER (basis_on X Basis) (generated_topology X Basis = Tx) Hgen). }
  claim HBasisSubTx: Basis c= Tx.
  { let b. assume Hb: b :e Basis.
	    claim HbGen: b :e generated_topology X Basis.
	    { exact (generated_topology_contains_basis X Basis HBasis b Hb). }
	    rewrite <- HgenEq.
	    exact HbGen. }
  (** Build a countable cover of A by basis elements b with closure(b) disjoint from B. **)
  set Cand := {b :e Basis | closure_of X Tx b :/\: B = Empty}.
  claim HCandSubBasis: Cand c= Basis.
  { let b. assume Hb: b :e Cand.
    exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) b Hb). }
  claim HCandCount: countable_set Cand.
  { exact (Subq_countable Cand Basis HBcount HCandSubBasis). }
  claim HAcover: A c= Union Cand.
  { let x. assume HxA: x :e A.
    prove x :e Union Cand.
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    claim HxnotB: x /:e B.
    { assume HxB: x :e B.
      claim HxAB: x :e A :/\: B.
      { exact (binintersectI A B x HxA HxB). }
      claim HxE: x :e Empty.
      { rewrite <- HAB. exact HxAB. }
      exact (EmptyE x HxE). }
    set U0 := X :\: B.
    claim HU0open: open_in X Tx U0.
    { exact (open_of_closed_complement X Tx B HBcl). }
    claim HU0Tx: U0 :e Tx.
    { exact (open_in_elem X Tx U0 HU0open). }
    claim HxU0: x :e U0.
    { exact (setminusI X B x HxX HxnotB). }
    apply (regular_space_shrink_neighborhood X Tx x U0 Hreg HxX HU0Tx HxU0).
    let V0.
    assume HV0: V0 :e Tx /\ x :e V0 /\ closure_of X Tx V0 c= U0.
    claim HV0a: (V0 :e Tx /\ x :e V0) /\ closure_of X Tx V0 c= U0.
    { exact HV0. }
    claim HV0b: V0 :e Tx /\ x :e V0.
    { exact (andEL (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0a). }
    claim HclV0subU0: closure_of X Tx V0 c= U0.
    { exact (andER (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0a). }
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (x :e V0) HV0b). }
    claim HxV0: x :e V0.
    { exact (andER (V0 :e Tx) (x :e V0) HV0b). }
    claim HV0subX: V0 c= X.
    { exact (topology_elem_subset X Tx V0 HTx HV0Tx). }
	    (** Choose a basis element b with x in b and b subset V0 using the generated-topology neighborhood property. **)
	    claim HV0openGen: open_in X (generated_topology X Basis) V0.
	    { rewrite HgenEq.
	      exact (open_inI X Tx V0 HTx HV0Tx). }
    claim HV0eq: V0 = Union {b :e Basis | b c= V0}.
    { exact (open_as_union_of_basis_elements X Basis HBasis V0 HV0openGen). }
    claim HxUnion: x :e Union {b :e Basis | b c= V0}.
    { rewrite <- HV0eq.
      exact HxV0. }
    apply (UnionE_impred {b :e Basis | b c= V0} x HxUnion).
    let b.
    assume Hxb HbFam.
    claim HbBasis: b :e Basis.
    { exact (SepE1 Basis (fun b0:set => b0 c= V0) b HbFam). }
    claim HbsubV0: b c= V0.
    { exact (SepE2 Basis (fun b0:set => b0 c= V0) b HbFam). }
    (** Show closure(b) disjoint B via closure(b) subset closure(V0) subset U0 = X\\B **)
    claim HclbsubclV0: closure_of X Tx b c= closure_of X Tx V0.
    { exact (closure_monotone X Tx b V0 HTx HbsubV0 HV0subX). }
    claim HclbsubU0: closure_of X Tx b c= U0.
    { exact (Subq_tra (closure_of X Tx b) (closure_of X Tx V0) U0 HclbsubclV0 HclV0subU0). }
    claim HclbDisjB: closure_of X Tx b :/\: B = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e (closure_of X Tx b) :/\: B.
      claim Hzclb: z :e closure_of X Tx b.
      { exact (binintersectE1 (closure_of X Tx b) B z Hz). }
      claim HzB: z :e B.
      { exact (binintersectE2 (closure_of X Tx b) B z Hz). }
      claim HzU0: z :e U0.
      { exact (HclbsubU0 z Hzclb). }
      claim HznotB: z /:e B.
      { exact (setminusE2 X B z HzU0). }
      apply FalseE.
      prove False.
      exact (HznotB HzB). }
    claim HbCand: b :e Cand.
    { exact (SepI Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) b HbBasis HclbDisjB). }
    exact (UnionI Cand x b Hxb HbCand). }
  (** Symmetrically cover B by basis elements with closures disjoint from A. **)
  set Dand := {b :e Basis | closure_of X Tx b :/\: A = Empty}.
  claim HDandSubBasis: Dand c= Basis.
  { let b. assume Hb: b :e Dand.
    exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: A = Empty) b Hb). }
  claim HDandCount: countable_set Dand.
  { exact (Subq_countable Dand Basis HBcount HDandSubBasis). }
  claim HBcover: B c= Union Dand.
  { let x. assume HxB: x :e B.
    prove x :e Union Dand.
    claim HxX: x :e X.
    { exact (HBsubX x HxB). }
    claim HxnotA: x /:e A.
    { assume HxA: x :e A.
      claim HxAB: x :e A :/\: B.
      { exact (binintersectI A B x HxA HxB). }
      claim HxE: x :e Empty.
      { rewrite <- HAB. exact HxAB. }
      exact (EmptyE x HxE). }
    set U0 := X :\: A.
    claim HU0open: open_in X Tx U0.
    { exact (open_of_closed_complement X Tx A HAcl). }
    claim HU0Tx: U0 :e Tx.
    { exact (open_in_elem X Tx U0 HU0open). }
    claim HxU0: x :e U0.
    { exact (setminusI X A x HxX HxnotA). }
    apply (regular_space_shrink_neighborhood X Tx x U0 Hreg HxX HU0Tx HxU0).
    let V0.
    assume HV0: V0 :e Tx /\ x :e V0 /\ closure_of X Tx V0 c= U0.
    claim HV0a: (V0 :e Tx /\ x :e V0) /\ closure_of X Tx V0 c= U0.
    { exact HV0. }
    claim HV0b: V0 :e Tx /\ x :e V0.
    { exact (andEL (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0a). }
    claim HclV0subU0: closure_of X Tx V0 c= U0.
    { exact (andER (V0 :e Tx /\ x :e V0) (closure_of X Tx V0 c= U0) HV0a). }
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (x :e V0) HV0b). }
    claim HxV0: x :e V0.
    { exact (andER (V0 :e Tx) (x :e V0) HV0b). }
    claim HV0subX: V0 c= X.
    { exact (topology_elem_subset X Tx V0 HTx HV0Tx). }
    claim HV0openGen: open_in X (generated_topology X Basis) V0.
    { rewrite HgenEq.
      exact (open_inI X Tx V0 HTx HV0Tx). }
    claim HV0eq: V0 = Union {b :e Basis | b c= V0}.
    { exact (open_as_union_of_basis_elements X Basis HBasis V0 HV0openGen). }
    claim HxUnion: x :e Union {b :e Basis | b c= V0}.
    { rewrite <- HV0eq.
      exact HxV0. }
    apply (UnionE_impred {b :e Basis | b c= V0} x HxUnion).
    let b.
    assume Hxb HbFam.
    claim HbBasis: b :e Basis.
    { exact (SepE1 Basis (fun b0:set => b0 c= V0) b HbFam). }
    claim HbsubV0: b c= V0.
    { exact (SepE2 Basis (fun b0:set => b0 c= V0) b HbFam). }
    claim HclbsubclV0: closure_of X Tx b c= closure_of X Tx V0.
    { exact (closure_monotone X Tx b V0 HTx HbsubV0 HV0subX). }
    claim HclbsubU0: closure_of X Tx b c= U0.
    { exact (Subq_tra (closure_of X Tx b) (closure_of X Tx V0) U0 HclbsubclV0 HclV0subU0). }
    claim HclbDisjA: closure_of X Tx b :/\: A = Empty.
    { apply Empty_Subq_eq.
      let z. assume Hz: z :e (closure_of X Tx b) :/\: A.
      claim Hzclb: z :e closure_of X Tx b.
      { exact (binintersectE1 (closure_of X Tx b) A z Hz). }
      claim HzA: z :e A.
      { exact (binintersectE2 (closure_of X Tx b) A z Hz). }
      claim HzU0: z :e U0.
      { exact (HclbsubU0 z Hzclb). }
      claim HznotA: z /:e A.
      { exact (setminusE2 X A z HzU0). }
      apply FalseE.
      prove False.
      exact (HznotA HzA). }
    claim HbDand: b :e Dand.
    { exact (SepI Basis (fun b0:set => closure_of X Tx b0 :/\: A = Empty) b HbBasis HclbDisjA). }
    exact (UnionI Dand x b Hxb HbDand). }
  (** Pending: apply the standard countable separation trick to Cand and Dand to obtain disjoint open neighborhoods of A and B. **)
  (** First step: fix injections Cand→ω and Dand→ω, so that “initial segments” are finite. **)
  apply HCandCount.
  let fC. assume HfC: inj Cand omega fC.
  apply HDandCount.
  let fD. assume HfD: inj Dand omega fD.
  claim HfiniteDprefix: forall n:set, nat_p n -> finite {d :e Dand | fD d :e ordsucc n}.
  { let n. assume Hnat: nat_p n.
    exact (inj_omega_preimage_ordsucc_finite Dand n fD Hnat HfD). }
  claim HfiniteCprefix: forall n:set, nat_p n -> finite {c :e Cand | fC c :e ordsucc n}.
  { let n. assume Hnat: nat_p n.
    exact (inj_omega_preimage_ordsucc_finite Cand n fC Hnat HfC). }
  (** Define the indexed families U_n and V_n from the injections Cand→ω and Dand→ω. **)
  set Cand_eq := fun n:set => {c :e Cand | fC c = n}.
  set Dand_eq := fun n:set => {d :e Dand | fD d = n}.
  set Uraw := fun n:set => Union (Cand_eq n).
  set Vraw := fun n:set => Union (Dand_eq n).

  (** Define finite initial segments of Cand/Dand (indices ≤ n), and their closure-unions. **)
  set Cand_pref := fun n:set => {c :e Cand | fC c :e ordsucc n}.
  set Dand_pref := fun n:set => {d :e Dand | fD d :e ordsucc n}.
  set ClDfam := fun n:set => {closure_of X Tx d | d :e Dand_pref n}.
  set ClCfam := fun n:set => {closure_of X Tx c | c :e Cand_pref n}.
  set ClD := fun n:set => Union (ClDfam n).
  set ClC := fun n:set => Union (ClCfam n).

  (** Primed opens: U'_n = U_n ∩ (X \\ ClD(n)), V'_n = V_n ∩ (X \\ ClC(n)). **)
  set Uprime := fun n:set => (Uraw n) :/\: (X :\: (ClD n)).
  set Vprime := fun n:set => (Vraw n) :/\: (X :\: (ClC n)).
  set Uall := Union {Uprime n | n :e omega}.
  set Vall := Union {Vprime n | n :e omega}.

  (** Uall and Vall are open in Tx. **)
  claim HUallTx: Uall :e Tx.
  { claim HUfamPow: {Uprime n | n :e omega} :e Power Tx.
    { claim HUsubTx: {Uprime n | n :e omega} c= Tx.
      { let U0. assume HU0: U0 :e {Uprime n | n :e omega}.
        prove U0 :e Tx.
        apply (ReplE_impred omega (fun n:set => Uprime n) U0 HU0 (U0 :e Tx)).
        let n. assume HnO: n :e omega.
        assume HU0eq: U0 = Uprime n.
        rewrite HU0eq.
      (** Uprime n is intersection of two opens: Uraw n and X\\ClD n. **)
      claim HUnat: nat_p n.
      { exact (omega_nat_p n HnO). }
      claim HDprefFin: finite (Dand_pref n).
      { exact (HfiniteDprefix n HUnat). }
      claim HClDfamFin: finite (ClDfam n).
      { exact (Repl_finite (fun d0:set => closure_of X Tx d0) (Dand_pref n) HDprefFin). }
      claim HClDfamClosed: forall C0:set, C0 :e (ClDfam n) -> closed_in X Tx C0.
      { let C0. assume HC0: C0 :e (ClDfam n).
        apply (ReplE_impred (Dand_pref n) (fun d0:set => closure_of X Tx d0) C0 HC0 (closed_in X Tx C0)).
        let d0. assume Hd0: d0 :e Dand_pref n.
        assume HC0eq: C0 = closure_of X Tx d0.
        rewrite HC0eq.
        (** d0 is open in Tx (as a basis element), hence d0 ⊆ X. **)
        claim Hd0Dand: d0 :e Dand.
        { exact (SepE1 Dand (fun d1:set => fD d1 :e ordsucc n) d0 Hd0). }
        claim Hd0Basis: d0 :e Basis.
        { exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: A = Empty) d0 Hd0Dand). }
        claim Hd0Tx: d0 :e Tx.
        { exact (HBasisSubTx d0 Hd0Basis). }
        claim Hd0subX: d0 c= X.
        { exact (topology_elem_subset X Tx d0 HTx Hd0Tx). }
        exact (closure_is_closed X Tx d0 HTx Hd0subX). }
      claim HClDclosed: closed_in X Tx (ClD n).
      { exact (finite_union_closed_in X Tx (ClDfam n) HTx HClDfamFin HClDfamClosed). }
      claim HcompClD: X :\: (ClD n) :e Tx.
      { claim Hopen: open_in X Tx (X :\: (ClD n)).
        { exact (open_of_closed_complement X Tx (ClD n) HClDclosed). }
        exact (open_in_elem X Tx (X :\: (ClD n)) Hopen). }
      (** Uraw n is open as a union of subfamily of Cand ⊂ Basis ⊂ Tx. **)
      claim HUrawTx: Uraw n :e Tx.
      { claim HCeqSubCand: Cand_eq n c= Cand.
        { let c. assume Hc: c :e Cand_eq n.
          exact (SepE1 Cand (fun c0:set => fC c0 = n) c Hc). }
        claim HCeqSubBasis: Cand_eq n c= Basis.
        { exact (Subq_tra (Cand_eq n) Cand Basis HCeqSubCand HCandSubBasis). }
        claim HCeqSubTx: Cand_eq n c= Tx.
        { exact (Subq_tra (Cand_eq n) Basis Tx HCeqSubBasis HBasisSubTx). }
        claim HCeqPow: Cand_eq n :e Power Tx.
        { exact (PowerI Tx (Cand_eq n) HCeqSubTx). }
        exact (lemma_union_of_topology_family_open X Tx (Cand_eq n) HTx HCeqPow). }
        exact (topology_binintersect_closed X Tx (Uraw n) (X :\: (ClD n)) HTx HUrawTx HcompClD). }
      exact (PowerI Tx {Uprime n | n :e omega} HUsubTx). }
    exact (lemma_union_of_topology_family_open X Tx {Uprime n | n :e omega} HTx HUfamPow). }

  claim HVallTx: Vall :e Tx.
  { claim HVfamPow: {Vprime n | n :e omega} :e Power Tx.
    { claim HVsubTx: {Vprime n | n :e omega} c= Tx.
      { let V0. assume HV0: V0 :e {Vprime n | n :e omega}.
        prove V0 :e Tx.
        apply (ReplE_impred omega (fun n:set => Vprime n) V0 HV0 (V0 :e Tx)).
        let n. assume HnO: n :e omega.
        assume HV0eq: V0 = Vprime n.
        rewrite HV0eq.
      claim HUnat: nat_p n.
      { exact (omega_nat_p n HnO). }
      claim HCprefFin: finite (Cand_pref n).
      { exact (HfiniteCprefix n HUnat). }
      claim HClCfamFin: finite (ClCfam n).
      { exact (Repl_finite (fun c0:set => closure_of X Tx c0) (Cand_pref n) HCprefFin). }
      claim HClCfamClosed: forall C0:set, C0 :e (ClCfam n) -> closed_in X Tx C0.
      { let C0. assume HC0: C0 :e (ClCfam n).
        apply (ReplE_impred (Cand_pref n) (fun c0:set => closure_of X Tx c0) C0 HC0 (closed_in X Tx C0)).
        let c0. assume Hc0: c0 :e Cand_pref n.
        assume HC0eq: C0 = closure_of X Tx c0.
        rewrite HC0eq.
        claim Hc0Cand: c0 :e Cand.
        { exact (SepE1 Cand (fun c1:set => fC c1 :e ordsucc n) c0 Hc0). }
        claim Hc0Basis: c0 :e Basis.
        { exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) c0 Hc0Cand). }
        claim Hc0Tx: c0 :e Tx.
        { exact (HBasisSubTx c0 Hc0Basis). }
        claim Hc0subX: c0 c= X.
        { exact (topology_elem_subset X Tx c0 HTx Hc0Tx). }
        exact (closure_is_closed X Tx c0 HTx Hc0subX). }
      claim HClCclosed: closed_in X Tx (ClC n).
      { exact (finite_union_closed_in X Tx (ClCfam n) HTx HClCfamFin HClCfamClosed). }
      claim HcompClC: X :\: (ClC n) :e Tx.
      { claim Hopen: open_in X Tx (X :\: (ClC n)).
        { exact (open_of_closed_complement X Tx (ClC n) HClCclosed). }
        exact (open_in_elem X Tx (X :\: (ClC n)) Hopen). }
      claim HVrawTx: Vraw n :e Tx.
      { claim HDeqSubDand: Dand_eq n c= Dand.
        { let d. assume Hd: d :e Dand_eq n.
          exact (SepE1 Dand (fun d0:set => fD d0 = n) d Hd). }
        claim HDeqSubBasis: Dand_eq n c= Basis.
        { exact (Subq_tra (Dand_eq n) Dand Basis HDeqSubDand HDandSubBasis). }
        claim HDeqSubTx: Dand_eq n c= Tx.
        { exact (Subq_tra (Dand_eq n) Basis Tx HDeqSubBasis HBasisSubTx). }
        claim HDeqPow: Dand_eq n :e Power Tx.
        { exact (PowerI Tx (Dand_eq n) HDeqSubTx). }
        exact (lemma_union_of_topology_family_open X Tx (Dand_eq n) HTx HDeqPow). }
        exact (topology_binintersect_closed X Tx (Vraw n) (X :\: (ClC n)) HTx HVrawTx HcompClC). }
      exact (PowerI Tx {Vprime n | n :e omega} HVsubTx). }
    exact (lemma_union_of_topology_family_open X Tx {Vprime n | n :e omega} HTx HVfamPow). }

  (** A ⊆ Uall and B ⊆ Vall (as in the TeX proof); disjointness will be proved later. **)
  witness Uall.
  witness Vall.
  prove Uall :e Tx /\ Vall :e Tx /\ A c= Uall /\ B c= Vall /\ Uall :/\: Vall = Empty.
  apply andI.
  - (** Uall :e Tx /\ Vall :e Tx /\ A c= Uall /\ B c= Vall **)
    apply andI.
    + (** Uall :e Tx /\ Vall :e Tx /\ A c= Uall **)
      apply andI.
	      * (** Uall :e Tx /\ Vall :e Tx **)
	        apply andI.
	        - exact HUallTx.
	        - exact HVallTx.
	      * (** A c= Uall **)
	        prove A c= Uall.
	        let x. assume HxA: x :e A.
	        prove x :e Uall.
	        claim HxUnionCand: x :e Union Cand.
	        { exact (HAcover x HxA). }
	        apply (UnionE_impred Cand x HxUnionCand).
	        let c. assume Hxc: x :e c. assume HcCand: c :e Cand.
	        set n := fC c.
	        claim HnO: n :e omega.
	        { claim HfCinto: forall u :e Cand, fC u :e omega.
	          { exact (andEL (forall u :e Cand, fC u :e omega)
	                         (forall u v :e Cand, fC u = fC v -> u = v)
	                         HfC). }
	          exact (HfCinto c HcCand). }
	        claim HcEq: c :e Cand_eq n.
	        { claim HCeqdef: Cand_eq n = {c0 :e Cand | fC c0 = n}.
	          { reflexivity. }
	          rewrite HCeqdef.
	          apply (SepI Cand (fun c0:set => fC c0 = n) c HcCand).
	          reflexivity. }
	        claim HxUraw: x :e Uraw n.
	        { exact (UnionI (Cand_eq n) x c Hxc HcEq). }
	        claim HxX: x :e X.
	        { exact (HAsubX x HxA). }
	        claim HxnotClD: x /:e (ClD n).
	        { assume HxClD: x :e (ClD n).
	          apply (UnionE_impred (ClDfam n) x HxClD).
	          let C0. assume HxC0: x :e C0. assume HC0: C0 :e (ClDfam n).
	          apply (ReplE_impred (Dand_pref n) (fun d0:set => closure_of X Tx d0) C0 HC0 False).
	          let d0. assume Hd0: d0 :e (Dand_pref n).
	          assume HC0eq: C0 = closure_of X Tx d0.
	          claim Hxd0cl: x :e closure_of X Tx d0.
	          { rewrite <- HC0eq. exact HxC0. }
	          claim Hd0Dand: d0 :e Dand.
	          { exact (SepE1 Dand (fun d1:set => fD d1 :e ordsucc n) d0 Hd0). }
	          claim Hd0DisjA: closure_of X Tx d0 :/\: A = Empty.
	          { exact (SepE2 Basis (fun b0:set => closure_of X Tx b0 :/\: A = Empty) d0 Hd0Dand). }
	          claim HxInt: x :e (closure_of X Tx d0) :/\: A.
	          { exact (binintersectI (closure_of X Tx d0) A x Hxd0cl HxA). }
	          claim HxEmp: x :e Empty.
	          { rewrite <- Hd0DisjA. exact HxInt. }
	          exact (EmptyE x HxEmp). }
	        claim HxCompClD: x :e X :\: (ClD n).
	        { exact (setminusI X (ClD n) x HxX HxnotClD). }
	        claim HxUprime: x :e (Uprime n).
	        { exact (binintersectI (Uraw n) (X :\: (ClD n)) x HxUraw HxCompClD). }
	        claim HUpInFam: (Uprime n) :e {Uprime k | k :e omega}.
	        { exact (ReplI omega (fun k:set => Uprime k) n HnO). }
	        exact (UnionI {Uprime k | k :e omega} x (Uprime n) HxUprime HUpInFam).
	    + (** B c= Vall **)
	      prove B c= Vall.
	      let x. assume HxB: x :e B.
	      prove x :e Vall.
	      claim HxUnionDand: x :e Union Dand.
	      { exact (HBcover x HxB). }
	      apply (UnionE_impred Dand x HxUnionDand).
	      let d. assume Hxd: x :e d. assume HdDand: d :e Dand.
	      set n := fD d.
	      claim HnO: n :e omega.
	      { claim HfDinto: forall u :e Dand, fD u :e omega.
	        { exact (andEL (forall u :e Dand, fD u :e omega)
	                       (forall u v :e Dand, fD u = fD v -> u = v)
	                       HfD). }
	        exact (HfDinto d HdDand). }
	      claim HdEq: d :e Dand_eq n.
	      { claim HDeqdef: Dand_eq n = {d0 :e Dand | fD d0 = n}.
	        { reflexivity. }
	        rewrite HDeqdef.
	        apply (SepI Dand (fun d0:set => fD d0 = n) d HdDand).
	        reflexivity. }
	      claim HxVraw: x :e Vraw n.
	      { exact (UnionI (Dand_eq n) x d Hxd HdEq). }
	      claim HxX: x :e X.
	      { exact (HBsubX x HxB). }
	      claim HxnotClC: x /:e (ClC n).
	      { assume HxClC: x :e (ClC n).
	        apply (UnionE_impred (ClCfam n) x HxClC).
	        let C0. assume HxC0: x :e C0. assume HC0: C0 :e (ClCfam n).
	        apply (ReplE_impred (Cand_pref n) (fun c0:set => closure_of X Tx c0) C0 HC0 False).
	        let c0. assume Hc0: c0 :e (Cand_pref n).
	        assume HC0eq: C0 = closure_of X Tx c0.
	        claim Hxc0cl: x :e closure_of X Tx c0.
	        { rewrite <- HC0eq. exact HxC0. }
	        claim Hc0Cand: c0 :e Cand.
	        { exact (SepE1 Cand (fun c1:set => fC c1 :e ordsucc n) c0 Hc0). }
	        claim Hc0DisjB: closure_of X Tx c0 :/\: B = Empty.
	        { exact (SepE2 Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) c0 Hc0Cand). }
	        claim HxInt: x :e (closure_of X Tx c0) :/\: B.
	        { exact (binintersectI (closure_of X Tx c0) B x Hxc0cl HxB). }
	        claim HxEmp: x :e Empty.
	        { rewrite <- Hc0DisjB. exact HxInt. }
	        exact (EmptyE x HxEmp). }
	      claim HxCompClC: x :e X :\: (ClC n).
	      { exact (setminusI X (ClC n) x HxX HxnotClC). }
	      claim HxVprime: x :e (Vprime n).
	      { exact (binintersectI (Vraw n) (X :\: (ClC n)) x HxVraw HxCompClC). }
	      claim HVpInFam: (Vprime n) :e {Vprime k | k :e omega}.
	      { exact (ReplI omega (fun k:set => Vprime k) n HnO). }
	      exact (UnionI {Vprime k | k :e omega} x (Vprime n) HxVprime HVpInFam).
	  - (** Uall :/\: Vall = Empty **)
	    apply Empty_Subq_eq.
	    let x. assume HxUV: x :e Uall :/\: Vall.
	    prove x :e Empty.
	    apply FalseE.
	    prove False.
	    claim HxUall: x :e Uall.
	    { exact (binintersectE1 Uall Vall x HxUV). }
	    claim HxVall: x :e Vall.
	    { exact (binintersectE2 Uall Vall x HxUV). }
	    (** Choose indices i,j and point-memberships x:e Uprime i and x:e Vprime j. **)
	    apply (UnionE_impred {Uprime k | k :e omega} x HxUall).
	    let U0. assume HxU0: x :e U0. assume HU0: U0 :e {Uprime k | k :e omega}.
	    apply (ReplE_impred omega (fun k:set => Uprime k) U0 HU0 False).
	    let i. assume HiO: i :e omega. assume HU0eq: U0 = Uprime i.
	    claim HxUi: x :e Uprime i.
	    { rewrite <- HU0eq. exact HxU0. }
	    claim HxUraw: x :e Uraw i.
	    { exact (binintersectE1 (Uraw i) (X :\: (ClD i)) x HxUi). }
	    claim HxXminusClD: x :e X :\: (ClD i).
	    { exact (binintersectE2 (Uraw i) (X :\: (ClD i)) x HxUi). }
	    claim HxnotClD: x /:e (ClD i).
	    { exact (setminusE2 X (ClD i) x HxXminusClD). }
	    apply (UnionE_impred {Vprime k | k :e omega} x HxVall).
	    let V0. assume HxV0: x :e V0. assume HV0: V0 :e {Vprime k | k :e omega}.
	    apply (ReplE_impred omega (fun k:set => Vprime k) V0 HV0 False).
	    let j. assume HjO: j :e omega. assume HV0eq: V0 = Vprime j.
	    claim HxVj: x :e Vprime j.
	    { rewrite <- HV0eq. exact HxV0. }
	    claim HxVraw: x :e Vraw j.
	    { exact (binintersectE1 (Vraw j) (X :\: (ClC j)) x HxVj). }
	    claim HxXminusClC: x :e X :\: (ClC j).
	    { exact (binintersectE2 (Vraw j) (X :\: (ClC j)) x HxVj). }
	    claim HxnotClC: x /:e (ClC j).
	    { exact (setminusE2 X (ClC j) x HxXminusClC). }
	    (** Choose basis elements c in Cand_eq i and d in Dand_eq j with x:e c and x:e d. **)
	    apply (UnionE_impred (Cand_eq i) x HxUraw).
	    let c. assume Hxc: x :e c. assume HcEq: c :e Cand_eq i.
	    claim HcCand: c :e Cand.
	    { exact (SepE1 Cand (fun c0:set => fC c0 = i) c HcEq). }
	    claim HfCc: fC c = i.
	    { exact (SepE2 Cand (fun c0:set => fC c0 = i) c HcEq). }
	    apply (UnionE_impred (Dand_eq j) x HxVraw).
	    let d. assume Hxd: x :e d. assume HdEq: d :e Dand_eq j.
	    claim HdDand: d :e Dand.
	    { exact (SepE1 Dand (fun d0:set => fD d0 = j) d HdEq). }
	    claim HfDd: fD d = j.
	    { exact (SepE2 Dand (fun d0:set => fD d0 = j) d HdEq). }
	    (** Reduce to ordinal comparison between i and j. **)
	    claim HiNat: nat_p i.
	    { exact (omega_nat_p i HiO). }
	    claim HjNat: nat_p j.
	    { exact (omega_nat_p j HjO). }
	    claim HiOrd: ordinal i.
	    { exact (nat_p_ordinal i HiNat). }
	    claim HjOrd: ordinal j.
	    { exact (nat_p_ordinal j HjNat). }
	    apply (ordinal_trichotomy_or_impred i j HiOrd HjOrd False).
	    - assume Hij: i :e j.
	      (** If i<j then c contributes to ClC j, contradicting x:e X\\ClC j. **)
	      claim HiSuccJ: i :e ordsucc j.
	      { exact (ordsuccI1 j i Hij). }
		      claim HcPref: c :e Cand_pref j.
			      { claim HCprefdef: Cand_pref j = {c0 :e Cand | fC c0 :e ordsucc j}.
			        { reflexivity. }
			        rewrite HCprefdef.
			        apply (SepI Cand (fun c0:set => fC c0 :e ordsucc j) c HcCand).
			        rewrite HfCc.
			        exact HiSuccJ. }
	      claim HclcInFam: closure_of X Tx c :e ClCfam j.
	      { exact (ReplI (Cand_pref j) (fun c0:set => closure_of X Tx c0) c HcPref). }
	      claim HcBasis: c :e Basis.
	      { exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) c HcCand). }
	      claim HcTx: c :e Tx.
	      { exact (HBasisSubTx c HcBasis). }
	      claim HcSubX: c c= X.
	      { exact (topology_elem_subset X Tx c HTx HcTx). }
	      claim Hxclc: x :e closure_of X Tx c.
	      { claim HcSubCl: c c= closure_of X Tx c.
	        { exact (subset_of_closure X Tx c HTx HcSubX). }
	        exact (HcSubCl x Hxc). }
	      claim HxClC: x :e ClC j.
	      { exact (UnionI (ClCfam j) x (closure_of X Tx c) Hxclc HclcInFam). }
	      exact (HxnotClC HxClC).
	    - assume HijEq: i = j.
	      (** If i=j then c contributes to ClC j, contradicting x:e X\\ClC j. **)
	      claim HiSuccJ: i :e ordsucc j.
	      { rewrite HijEq. exact (ordsuccI2 j). }
		      claim HcPref: c :e Cand_pref j.
			      { claim HCprefdef: Cand_pref j = {c0 :e Cand | fC c0 :e ordsucc j}.
			        { reflexivity. }
			        rewrite HCprefdef.
			        apply (SepI Cand (fun c0:set => fC c0 :e ordsucc j) c HcCand).
			        rewrite HfCc.
			        exact HiSuccJ. }
	      claim HclcInFam: closure_of X Tx c :e ClCfam j.
	      { exact (ReplI (Cand_pref j) (fun c0:set => closure_of X Tx c0) c HcPref). }
	      claim HcBasis: c :e Basis.
	      { exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: B = Empty) c HcCand). }
	      claim HcTx: c :e Tx.
	      { exact (HBasisSubTx c HcBasis). }
	      claim HcSubX: c c= X.
	      { exact (topology_elem_subset X Tx c HTx HcTx). }
	      claim Hxclc: x :e closure_of X Tx c.
	      { claim HcSubCl: c c= closure_of X Tx c.
	        { exact (subset_of_closure X Tx c HTx HcSubX). }
	        exact (HcSubCl x Hxc). }
	      claim HxClC: x :e ClC j.
	      { exact (UnionI (ClCfam j) x (closure_of X Tx c) Hxclc HclcInFam). }
	      exact (HxnotClC HxClC).
		    - assume Hji: j :e i.
		      (** If j<i then d contributes to ClD i, contradicting x:e X\\ClD i. **)
	      claim HjSuccI: j :e ordsucc i.
	      { exact (ordsuccI1 i j Hji). }
		      claim HdPref: d :e Dand_pref i.
			      { claim HDprefdef: Dand_pref i = {d0 :e Dand | fD d0 :e ordsucc i}.
			        { reflexivity. }
			        rewrite HDprefdef.
			        apply (SepI Dand (fun d0:set => fD d0 :e ordsucc i) d HdDand).
			        rewrite HfDd.
			        exact HjSuccI. }
	      claim HcldInFam: closure_of X Tx d :e ClDfam i.
	      { exact (ReplI (Dand_pref i) (fun d0:set => closure_of X Tx d0) d HdPref). }
	      claim HdBasis: d :e Basis.
	      { exact (SepE1 Basis (fun b0:set => closure_of X Tx b0 :/\: A = Empty) d HdDand). }
	      claim HdTx: d :e Tx.
	      { exact (HBasisSubTx d HdBasis). }
	      claim HdSubX: d c= X.
	      { exact (topology_elem_subset X Tx d HTx HdTx). }
	      claim Hxcld: x :e closure_of X Tx d.
	      { claim HdSubCl: d c= closure_of X Tx d.
	        { exact (subset_of_closure X Tx d HTx HdSubX). }
	        exact (HdSubCl x Hxd). }
	      claim HxClD: x :e ClD i.
	      { exact (UnionI (ClDfam i) x (closure_of X Tx d) Hxcld HcldInFam). }
	      exact (HxnotClD HxClD).
		Qed.

	(** helper: right-closed order interval (x,y] as used in §32 Thm 32.4 **)
	Definition order_interval_right_closed : set -> set -> set -> set := fun X x y =>
	  {z :e X | order_rel X x z /\ (z = y \/ order_rel X z y)}.

	(** helper: (x,y] equals (x, succ(y)) in well-ordered carriers, hence is open **)
	Theorem order_interval_right_closed_open : forall X x y:set,
	  well_ordered_set X ->
	  simply_ordered_set X ->
	  x :e X ->
	  y :e X ->
	  order_rel X x y ->
	  order_interval_right_closed X x y :e order_topology X.
	let X x y.
	assume Hwo: well_ordered_set X.
	assume Hso: simply_ordered_set X.
	assume HxX: x :e X.
	assume HyX: y :e X.
	assume Hxy: order_rel X x y.
	set I := order_interval_right_closed X x y.
	set J := order_interval X x (ordsucc y).
	claim HIeq: I = J.
	{ apply set_ext.
	  - let z. assume HzI: z :e I.
	    prove z :e J.
	    claim HzX: z :e X.
	    { exact (SepE1 X (fun z0:set => order_rel X x z0 /\ (z0 = y \/ order_rel X z0 y)) z HzI). }
	    claim Hzconj: order_rel X x z /\ (z = y \/ order_rel X z y).
	    { exact (SepE2 X (fun z0:set => order_rel X x z0 /\ (z0 = y \/ order_rel X z0 y)) z HzI). }
	    claim Hxz: order_rel X x z.
	    { exact (andEL (order_rel X x z) (z = y \/ order_rel X z y) Hzconj). }
	    claim Hzcase: z = y \/ order_rel X z y.
	    { exact (andER (order_rel X x z) (z = y \/ order_rel X z y) Hzconj). }
	    claim HJdef: J = {z0 :e X | order_rel X x z0 /\ order_rel X z0 (ordsucc y)}.
	    { reflexivity. }
	    rewrite HJdef.
	    apply (SepI X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzX).
	    apply andI.
	    - exact Hxz.
	    - apply Hzcase.
	      + assume Hzy: z = y.
	        rewrite Hzy.
	        claim Hymem: y :e ordsucc y.
	        { exact (ordsuccI2 y). }
	        exact (mem_implies_order_rel_well_ordered X y (ordsucc y) Hwo Hymem).
	      + assume Hzy: order_rel X z y.
	        claim Hmem: z :e y.
	        { exact (order_rel_well_ordered_implies_mem X z y Hwo Hzy). }
	        claim Hzsucc: z :e ordsucc y.
	        { exact (ordsuccI1 y z Hmem). }
	        exact (mem_implies_order_rel_well_ordered X z (ordsucc y) Hwo Hzsucc).
	  - let z. assume HzJ: z :e J.
	    prove z :e I.
	    claim HzX: z :e X.
	    { exact (SepE1 X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzJ). }
	    claim Hzconj: order_rel X x z /\ order_rel X z (ordsucc y).
	    { exact (SepE2 X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzJ). }
	    claim Hxz: order_rel X x z.
	    { exact (andEL (order_rel X x z) (order_rel X z (ordsucc y)) Hzconj). }
	    claim HzSucc: order_rel X z (ordsucc y).
	    { exact (andER (order_rel X x z) (order_rel X z (ordsucc y)) Hzconj). }
	    claim HmemSucc: z :e ordsucc y.
	    { exact (order_rel_well_ordered_implies_mem X z (ordsucc y) Hwo HzSucc). }
	    claim Hzcase: z :e y \/ z = y.
	    { exact (ordsuccE y z HmemSucc). }
	    claim HIdef: I = {z0 :e X | order_rel X x z0 /\ (z0 = y \/ order_rel X z0 y)}.
	    { reflexivity. }
	    rewrite HIdef.
	    apply (SepI X (fun z0:set => order_rel X x z0 /\ (z0 = y \/ order_rel X z0 y)) z HzX).
	    apply andI.
	    - exact Hxz.
	    - apply Hzcase.
	      + assume Hzy: z :e y.
	        apply orIR.
	        exact (mem_implies_order_rel_well_ordered X z y Hwo Hzy).
	      + assume Hzy: z = y.
	        apply orIL.
	        exact Hzy. }

	(** show J is open in the order topology (basis interval if succ(y)∈X, otherwise it reduces to an upper ray) **)
	claim HordX: ordinal X.
	{ exact (well_ordered_set_is_ordinal X Hwo). }
	claim HsuccCase: ordsucc y :e X \/ X = ordsucc y.
	{ exact (ordinal_ordsucc_In_eq X y HordX HyX). }
	apply HsuccCase.
		- assume HsuccIn: ordsucc y :e X.
		  (** J is a basis element, hence open in generated topology. **)
		  claim HJinB: J :e order_topology_basis X.
		  { set F1 := {I0 :e Power X | exists a :e X, exists b :e X,
		                 I0 = {t :e X | order_rel X a t /\ order_rel X t b}}.
		    set F2 := {I0 :e Power X | exists b :e X, I0 = {t :e X | order_rel X t b}}.
		    set F3 := {I0 :e Power X | exists a :e X, I0 = {t :e X | order_rel X a t}}.
		    set F12 := F1 :\/: F2.
		    set F123 := F12 :\/: F3.
		    claim HBdef: order_topology_basis X = F123 :\/: {X}.
		    { reflexivity. }
		    rewrite HBdef.

		    claim HJpow: J :e Power X.
		    { apply PowerI.
		      let t. assume HtJ: t :e J.
		      exact (SepE1 X (fun t0:set => order_rel X x t0 /\ order_rel X t0 (ordsucc y)) t HtJ). }
		    claim Hex: exists a :e X, exists b :e X,
		          J = {t :e X | order_rel X a t /\ order_rel X t b}.
		    { witness x.
		      prove x :e X /\ exists b :e X, J = {t :e X | order_rel X x t /\ order_rel X t b}.
		      apply andI.
		      - exact HxX.
		      - witness (ordsucc y).
		        apply andI.
		        - exact HsuccIn.
		        - reflexivity. }
		    claim HJfam: J :e F1.
		    { exact (SepI (Power X)
		              (fun I0:set => exists a :e X, exists b :e X,
		                  I0 = {t :e X | order_rel X a t /\ order_rel X t b})
		              J
		              HJpow
		              Hex). }
		    claim HJinF123: J :e F123.
		    { exact (binunionI1 F12 F3 J (binunionI1 F1 F2 J HJfam)). }
		    exact (binunionI1 F123 {X} J HJinF123). }
		  claim HJopen: J :e order_topology X.
		  { claim HdefT: order_topology X = generated_topology X (order_topology_basis X).
		    { reflexivity. }
		    rewrite HdefT.
		    claim HJpow: J :e Power X.
		    { apply PowerI.
		      let t. assume HtJ: t :e J.
		      exact (SepE1 X (fun t0:set => order_rel X x t0 /\ order_rel X t0 (ordsucc y)) t HtJ). }
		    exact (generated_topology_contains_elem X (order_topology_basis X) J HJpow HJinB). }
		  rewrite HIeq.
		  exact HJopen.
	- assume HsuccEq: X = ordsucc y.
	  (** Then J is the upper ray (x,∞); use the already-known basis lemma for upper rays. **)
		  claim HJray: J = open_ray_upper X x.
		  { apply set_ext.
		    - let z. assume HzJ: z :e J.
		      prove z :e open_ray_upper X x.
		      claim HzX: z :e X.
		      { exact (SepE1 X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzJ). }
		      claim Hxz: order_rel X x z.
		      { exact (andEL (order_rel X x z) (order_rel X z (ordsucc y))
		              (SepE2 X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzJ)). }
		      exact (SepI X (fun z0:set => order_rel X x z0) z HzX Hxz).
		    - let z. assume HzU: z :e open_ray_upper X x.
		      prove z :e J.
		      claim HJdef: J = {z0 :e X | order_rel X x z0 /\ order_rel X z0 (ordsucc y)}.
		      { reflexivity. }
		      rewrite HJdef.
		      claim HzX: z :e X.
		      { exact (SepE1 X (fun z0:set => order_rel X x z0) z HzU). }
		      claim Hxz: order_rel X x z.
		      { exact (SepE2 X (fun z0:set => order_rel X x z0) z HzU). }
		      apply (SepI X (fun z0:set => order_rel X x z0 /\ order_rel X z0 (ordsucc y)) z HzX).
	      apply andI.
		      - exact Hxz.
		      - rewrite <- HsuccEq.
		        exact (mem_implies_order_rel_well_ordered X z X Hwo HzX). }
	  claim HrayB: open_ray_upper X x :e order_topology_basis X.
	  { exact (open_ray_upper_in_order_topology_basis X x HxX). }
	  claim HrayPow: open_ray_upper X x :e Power X.
	  { apply PowerI.
	    let z. assume Hz: z :e open_ray_upper X x.
	    exact (SepE1 X (fun z0:set => order_rel X x z0) z Hz). }
		  claim HrayOpen: open_ray_upper X x :e order_topology X.
		  { exact (generated_topology_contains_elem X (order_topology_basis X) (open_ray_upper X x) HrayPow HrayB). }
		  rewrite HIeq.
		  rewrite HJray.
		  exact HrayOpen.
		Qed.
		
		(** helper for §32 Thm 32.4: open neighborhoods contain basis elements **)
		(** LATEX VERSION: If U is open in the order topology and y∈U, then y lies in some basis element b⊆U. **)
		Theorem order_topology_local_basis_elem : forall X U y:set,
		  simply_ordered_set X ->
		  U :e order_topology X ->
		  y :e U ->
		  exists b :e order_topology_basis X, y :e b /\ b c= U.
		let X U y.
		assume Hso: simply_ordered_set X.
		assume HU: U :e order_topology X.
		assume HyU: y :e U.
		claim HTx: topology_on X (order_topology X).
		{ exact (order_topology_is_topology X Hso). }
		claim HUopen: open_in X (order_topology X) U.
		{ exact (andI (topology_on X (order_topology X)) (U :e order_topology X) HTx HU). }
		claim HBasis: basis_on X (order_topology_basis X).
		{ exact (order_topology_basis_is_basis X Hso). }
		set Fam := {b :e order_topology_basis X | b c= U}.
		claim HUeq: U = Union Fam.
		{ exact (open_as_union_of_basis_elements X (order_topology_basis X) HBasis U HUopen). }
		claim HyUnion: y :e Union Fam.
		{ rewrite <- HUeq.
		  exact HyU. }
		apply UnionE_impred Fam y HyUnion.
			let b. assume Hyb: y :e b. assume HbFam: b :e Fam.
			witness b.
			prove b :e order_topology_basis X /\ (y :e b /\ b c= U).
			claim HbB: b :e order_topology_basis X.
			{ exact (SepE1 (order_topology_basis X) (fun b0:set => b0 c= U) b HbFam). }
		claim Hbsub: b c= U.
		{ exact (SepE2 (order_topology_basis X) (fun b0:set => b0 c= U) b HbFam). }
		apply andI.
		- exact HbB.
		- apply andI.
		  + exact Hyb.
		  + exact Hbsub.
		Qed.

	(** from §32 Theorem 32.4: well-ordered sets are normal in order topology **) 
	(** LATEX VERSION: Well-ordered sets with the order topology are normal. **)
	Theorem well_ordered_sets_normal : forall X:set,
	  well_ordered_set X ->
  simply_ordered_set X ->
  normal_space X (order_topology X).
let X.
		assume Hwo: well_ordered_set X.
		assume Hso: simply_ordered_set X.
		prove normal_space X (order_topology X).
		prove one_point_sets_closed X (order_topology X) /\
		  forall A B:set, closed_in X (order_topology X) A -> closed_in X (order_topology X) B -> A :/\: B = Empty ->
		    exists U V:set, U :e order_topology X /\ V :e order_topology X /\ A c= U /\ B c= V /\ U :/\: V = Empty.
		apply andI.
		- (** one_point_sets_closed from Hausdorff property of order topology **)
		  claim HH: Hausdorff_space X (order_topology X).
		  { exact (ex17_10_order_topology_Hausdorff X Hso). }
		  prove one_point_sets_closed X (order_topology X).
		  prove topology_on X (order_topology X) /\
		       forall x:set, x :e X -> closed_in X (order_topology X) {x}.
		  apply andI.
		  * exact (Hausdorff_space_topology X (order_topology X) HH).
		  * let x. assume HxX: x :e X.
		    exact (Hausdorff_singletons_closed X (order_topology X) x HH HxX).
		- (** separation of disjoint closed sets (Topological Spaces and Continuous Functions, §32 Thm 32.4) **)
		  let A B.
		  assume HAcl: closed_in X (order_topology X) A.
		  assume HBcl: closed_in X (order_topology X) B.
		  assume HABdisj: A :/\: B = Empty.
		  prove exists U V:set, U :e order_topology X /\ V :e order_topology X /\ A c= U /\ B c= V /\ U :/\: V = Empty.

		  claim HTx: topology_on X (order_topology X).
		  { exact (order_topology_is_topology X Hso). }
		  claim HAsubX: A c= X.
		  { exact (closed_in_subset X (order_topology X) A HAcl). }
		  claim HBsubX: B c= X.
		  { exact (closed_in_subset X (order_topology X) B HBcl). }

		  (** Trivial empty cases. **)
		  apply (xm (A = Empty)).
		  - assume HAe: A = Empty.
		    witness Empty.
		    witness X.
		    apply and5I.
		    - exact (topology_has_empty X (order_topology X) HTx).
		    - exact (topology_has_X X (order_topology X) HTx).
		    - rewrite HAe. exact (Subq_Empty Empty).
		    - exact HBsubX.
		    - exact (binintersect_Empty_left X).
		  - assume HAnE: ~(A = Empty).
		    apply (xm (B = Empty)).
		    + assume HBe: B = Empty.
		      witness X.
		      witness Empty.
		      apply and5I.
		      - exact (topology_has_X X (order_topology X) HTx).
		      - exact (topology_has_empty X (order_topology X) HTx).
		      - exact HAsubX.
		      - rewrite HBe. exact (Subq_Empty Empty).
		      - exact (binintersect_Empty_right X).
		    + assume HBnE: ~(B = Empty).

		      (** Let Uc be the open complement of B; let Vc be the open complement of A. **)
		      claim HexUB: exists UB :e order_topology X, B = X :\: UB.
		      { exact (closed_in_exists_open_complement X (order_topology X) B HBcl). }
		      set UB := Eps_i (fun U:set => U :e order_topology X /\ B = X :\: U).
		      claim HUB: UB :e order_topology X /\ B = X :\: UB.
		      { exact (Eps_i_ex (fun U:set => U :e order_topology X /\ B = X :\: U) HexUB). }
		      claim HUBTx: UB :e order_topology X.
		      { exact (andEL (UB :e order_topology X) (B = X :\: UB) HUB). }
		      claim HBdef: B = X :\: UB.
		      { exact (andER (UB :e order_topology X) (B = X :\: UB) HUB). }

		      claim HexVA: exists VA :e order_topology X, A = X :\: VA.
		      { exact (closed_in_exists_open_complement X (order_topology X) A HAcl). }
		      set VA := Eps_i (fun U:set => U :e order_topology X /\ A = X :\: U).
		      claim HVA: VA :e order_topology X /\ A = X :\: VA.
		      { exact (Eps_i_ex (fun U:set => U :e order_topology X /\ A = X :\: U) HexVA). }
		      claim HVATx: VA :e order_topology X.
		      { exact (andEL (VA :e order_topology X) (A = X :\: VA) HVA). }
		      claim HAdef: A = X :\: VA.
		      { exact (andER (VA :e order_topology X) (A = X :\: VA) HVA). }

		      (** Main separation construction (as in Munkres Thm 32.4). **)
		      (** If 0∈A (the least element), split it off using its clopen singleton; similarly for B. **)
			      apply (xm (0 :e A)).
			      - assume H0A: 0 :e A.
			        (** {0} is open and closed in the order topology on an ordinal; defer details. **)
			        admit. (** FAIL **)
			      - assume H0An: ~(0 :e A).
			        apply (xm (0 :e B)).
			        - assume H0B: 0 :e B.
			           admit. (** FAIL **)
				        - assume H0Bn: ~(0 :e B).

				           (** Choose, for each a∈A, an open interval (x_a,a] disjoint from B. **)
				           (** First note A ⊆ UB and B ⊆ VA (by disjointness). **)
				           claim HAsubUB: A c= UB.
				           { let a. assume HaA: a :e A.
				             prove a :e UB.
				             claim HaX: a :e X.
				             { exact (HAsubX a HaA). }
				             apply (xm (a :e UB)).
				             - assume HaUB: a :e UB. exact HaUB.
				             - assume HaNotUB: ~(a :e UB).
				               claim HaXB: a :e X :\: UB.
				               { exact (setminusI X UB a HaX HaNotUB). }
				               claim HaB: a :e B.
				               { rewrite HBdef.
				                 exact HaXB. }
				               claim HaAB: a :e A :/\: B.
				               { exact (binintersectI A B a HaA HaB). }
				               claim HaE: a :e Empty.
				               { rewrite <- HABdisj.
				                 exact HaAB. }
				               exact (EmptyE a HaE (a :e UB)). }
				           claim HBsubVA: B c= VA.
				           { let b. assume HbB: b :e B.
				             prove b :e VA.
				             claim HbX: b :e X.
				             { exact (HBsubX b HbB). }
				             apply (xm (b :e VA)).
				             - assume HbVA: b :e VA. exact HbVA.
				             - assume HbNotVA: ~(b :e VA).
				               claim HbXA: b :e X :\: VA.
				               { exact (setminusI X VA b HbX HbNotVA). }
				               claim HbA: b :e A.
				               { rewrite HAdef.
				                 exact HbXA. }
				               claim HbAB: b :e A :/\: B.
				               { exact (binintersectI A B b HbA HbB). }
				               claim HbE: b :e Empty.
				               { rewrite <- HABdisj.
				                 exact HbAB. }
				               exact (EmptyE b HbE (b :e VA)). }

				           (** For each a∈A, extract a basis neighborhood contained in UB. **)
				           claim HexA_basis: forall a:set, a :e A ->
				             exists b :e order_topology_basis X, a :e b /\ b c= UB.
				           { let a. assume HaA: a :e A.
				             claim HaUB: a :e UB.
				             { exact (HAsubUB a HaA). }
				             exact (order_topology_local_basis_elem X UB a Hso HUBTx HaUB). }

				           (** Remaining: refine these local neighborhoods to the right-closed form (x,a] and assemble disjoint U,V. **)
				           admit. (** FAIL **)
		Qed.
(** helper: sup of negated distances from a point to a set **)
Definition metric_sup_neg_dists : set -> set -> set -> set -> set := fun X d x A =>
  Eps_i (fun l:set => R_lub (metric_neg_dists X d x A) l).

(** helper: nonempty set of negated distances has a least upper bound **)
Theorem metric_sup_neg_dists_is_lub : forall X d x A:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  A <> Empty ->
  R_lub (metric_neg_dists X d x A) (metric_sup_neg_dists X d x A).
let X d x A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
assume HAne: A <> Empty.
set S := metric_neg_dists X d x A.
claim HexS: exists t0:set, t0 :e S.
{ claim HexA: exists a0:set, a0 :e A.
  { exact (nonempty_has_element A HAne). }
  set a0 := Eps_i (fun a:set => a :e A).
  claim Ha0: a0 :e A.
  { exact (Eps_i_ex (fun a:set => a :e A) HexA). }
  witness (minus_SNo (apply_fun d (x,a0))).
  prove minus_SNo (apply_fun d (x,a0)) :e S.
  claim HSdef: S = metric_neg_dists X d x A.
  { reflexivity. }
  rewrite HSdef.
  exact (ReplI A (fun a:set => minus_SNo (apply_fun d (x,a))) a0 Ha0). }
claim HS_R: forall t:set, t :e S -> t :e R.
{ let t. assume HtS: t :e S.
  exact (metric_neg_dists_in_R X d x A Hm HxX HAsub t HtS). }
claim HubS: exists u:set, u :e R /\ forall t:set, t :e S -> t :e R -> Rle t u.
{ witness 0.
  prove 0 :e R /\ forall t:set, t :e S -> t :e R -> Rle t 0.
  apply andI.
  - exact real_0.
  - let t. assume HtS: t :e S.
    assume _: t :e R.
    exact (metric_neg_dists_le_0 X d x A Hm HxX HAsub t HtS). }
claim Hexlub: exists l:set, R_lub S l.
{ exact (R_lub_exists S HexS HS_R HubS). }
exact (Eps_i_ex (fun l:set => R_lub S l) Hexlub).
Qed.

(** helper: distance from point to set, defined as inf via negated sup **)
Definition metric_dist_to_set : set -> set -> set -> set -> set := fun X d x A =>
  minus_SNo (metric_sup_neg_dists X d x A).

(** helper: metric_dist_to_set is real when the set is nonempty **)
Theorem metric_dist_to_set_in_R : forall X d x A:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  A <> Empty ->
  metric_dist_to_set X d x A :e R.
let X d x A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
assume HAne: A <> Empty.
set l := metric_sup_neg_dists X d x A.
claim Hlub: R_lub (metric_neg_dists X d x A) l.
{ exact (metric_sup_neg_dists_is_lub X d x A Hm HxX HAsub HAne). }
claim HlR: l :e R.
{ exact (R_lub_in_R (metric_neg_dists X d x A) l Hlub). }
prove metric_dist_to_set X d x A :e R.
claim Hdef: metric_dist_to_set X d x A = minus_SNo l.
{ reflexivity. }
rewrite Hdef.
exact (real_minus_SNo l HlR).
Qed.

(** helper: distance to a set is zero for points in the set **)
Theorem metric_dist_to_set_eq_0_if_mem : forall X d x A:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  x :e A ->
  metric_dist_to_set X d x A = 0.
let X d x A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
assume HxA: x :e A.
claim HAne: A <> Empty.
{ exact (elem_implies_nonempty A x HxA). }
set S := metric_neg_dists X d x A.
set l := metric_sup_neg_dists X d x A.
claim Hlub: R_lub S l.
{ exact (metric_sup_neg_dists_is_lub X d x A Hm HxX HAsub HAne). }

claim H0inS: 0 :e S.
{ claim HxIn: minus_SNo (apply_fun d (x,x)) :e S.
  { exact (ReplI A (fun a:set => minus_SNo (apply_fun d (x,a))) x HxA). }
  claim Hdxx0: apply_fun d (x,x) = 0.
  { exact (metric_on_diag_zero X d x Hm HxX). }
  claim H0eq: minus_SNo (apply_fun d (x,x)) = 0.
  { rewrite Hdxx0.
    exact minus_SNo_0. }
  rewrite <- H0eq.
  exact HxIn. }

claim Hlub0: R_lub S 0.
{ prove (0 :e R /\
    (forall t:set, t :e S -> t :e R -> Rle t 0) /\
    (forall u:set, u :e R ->
       (forall t:set, t :e S -> t :e R -> Rle t u) ->
       Rle 0 u)).
  apply andI.
  - apply andI.
    + exact real_0.
    + let t.
      assume HtS: t :e S.
      assume _: t :e R.
      exact (metric_neg_dists_le_0 X d x A Hm HxX HAsub t HtS).
  - let u.
    assume HuR: u :e R.
    assume Hub: forall t:set, t :e S -> t :e R -> Rle t u.
    exact (Hub 0 H0inS real_0). }

claim HlEq0: l = 0.
{ exact (R_lub_unique S l 0 Hlub Hlub0). }
claim Hdef: metric_dist_to_set X d x A = minus_SNo l.
{ reflexivity. }
rewrite Hdef.
rewrite HlEq0.
exact minus_SNo_0.
Qed.

(** helper: double negation on real numbers **)
Theorem minus_SNo_minus_SNo_real : forall t:set, t :e R -> minus_SNo (minus_SNo t) = t.
let t. assume HtR: t :e R.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HmtS: SNo (minus_SNo t).
{ exact (SNo_minus_SNo t HtS). }
claim HmmtS: SNo (minus_SNo (minus_SNo t)).
{ exact (SNo_minus_SNo (minus_SNo t) HmtS). }
claim Hinv1: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = 0.
{ exact (add_SNo_minus_SNo_linv (minus_SNo t) HmtS). }
claim Hinv2: add_SNo t (minus_SNo t) = 0.
{ exact (add_SNo_minus_SNo_rinv t HtS). }
claim Heq: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = add_SNo t (minus_SNo t).
{ rewrite Hinv1.
  rewrite <- Hinv2.
  reflexivity. }
exact (add_SNo_cancel_R (minus_SNo (minus_SNo t)) (minus_SNo t) t HmmtS HmtS HtS Heq).
Qed.

(** helper: distance to set is bounded by distance to a member **)
Theorem metric_dist_to_set_le_dist : forall X d x A a:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  A <> Empty ->
  a :e A ->
  Rle (metric_dist_to_set X d x A) (apply_fun d (x,a)).
let X d x A a.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
assume HAne: A <> Empty.
assume HaA: a :e A.
claim HaX: a :e X.
{ exact (HAsub a HaA). }
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxaIn: (x,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x a HxX HaX). }
claim HdxaR: apply_fun d (x,a) :e R.
{ exact (Hfun (x,a) HxaIn). }
set l := metric_sup_neg_dists X d x A.
claim Hlub: R_lub (metric_neg_dists X d x A) l.
{ exact (metric_sup_neg_dists_is_lub X d x A Hm HxX HAsub HAne). }
claim HlR: l :e R.
{ exact (R_lub_in_R (metric_neg_dists X d x A) l Hlub). }
claim HdistDef: metric_dist_to_set X d x A = minus_SNo l.
{ reflexivity. }
claim HdistR: metric_dist_to_set X d x A :e R.
{ exact (metric_dist_to_set_in_R X d x A Hm HxX HAsub HAne). }
set t := minus_SNo (apply_fun d (x,a)).
claim HtIn: t :e metric_neg_dists X d x A.
{ exact (ReplI A (fun a0:set => minus_SNo (apply_fun d (x,a0))) a HaA). }
claim HtR: t :e R.
{ exact (metric_neg_dists_in_R X d x A Hm HxX HAsub t HtIn). }
claim Hcore: l :e R /\ forall s:set, s :e metric_neg_dists X d x A -> s :e R -> Rle s l.
{ exact (andEL (l :e R /\ forall s:set, s :e metric_neg_dists X d x A -> s :e R -> Rle s l)
               (forall v:set, v :e R ->
                 (forall s:set, s :e metric_neg_dists X d x A -> s :e R -> Rle s v) ->
                 Rle l v)
               Hlub). }
claim Hub: forall s:set, s :e metric_neg_dists X d x A -> s :e R -> Rle s l.
{ exact (andER (l :e R) (forall s:set, s :e metric_neg_dists X d x A -> s :e R -> Rle s l) Hcore). }
claim Htle: Rle t l.
{ exact (Hub t HtIn HtR). }
claim Hnlt: ~(Rlt l t).
{ exact (RleE_nlt t l Htle). }
apply (RleI (metric_dist_to_set X d x A) (apply_fun d (x,a)) HdistR HdxaR).
assume Hlt: Rlt (apply_fun d (x,a)) (metric_dist_to_set X d x A).
claim HltS: apply_fun d (x,a) < metric_dist_to_set X d x A.
{ exact (RltE_lt (apply_fun d (x,a)) (metric_dist_to_set X d x A) Hlt). }
claim HdxaS: SNo (apply_fun d (x,a)).
{ exact (real_SNo (apply_fun d (x,a)) HdxaR). }
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim HdistS: SNo (metric_dist_to_set X d x A).
{ exact (real_SNo (metric_dist_to_set X d x A) HdistR). }
claim HltS2: apply_fun d (x,a) < minus_SNo l.
{ rewrite <- HdistDef.
  exact HltS. }
claim Hltneg: l < minus_SNo (apply_fun d (x,a)).
{ exact (minus_SNo_Lt_contra2 (apply_fun d (x,a)) l HdxaS HlS HltS2). }
claim HltR2: Rlt l t.
{ claim HtDef: t = minus_SNo (apply_fun d (x,a)).
  { reflexivity. }
  rewrite HtDef.
  exact (RltI l (minus_SNo (apply_fun d (x,a))) HlR (real_minus_SNo (apply_fun d (x,a)) HdxaR) Hltneg). }
exact (Hnlt HltR2).
Qed.

(** helper: approximate a minimizer for distance to a nonempty set **)
Theorem metric_dist_to_set_approx : forall X d x A eps:set,
  metric_on X d ->
  x :e X ->
  A c= X ->
  A <> Empty ->
  eps :e R -> Rlt 0 eps ->
  exists a:set, a :e A /\ a :e X /\
    Rlt (apply_fun d (x,a)) (add_SNo (metric_dist_to_set X d x A) eps).
let X d x A eps.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HAsub: A c= X.
assume HAne: A <> Empty.
assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
set S := metric_neg_dists X d x A.
set l := metric_sup_neg_dists X d x A.
claim Hlub: R_lub S l.
{ exact (metric_sup_neg_dists_is_lub X d x A Hm HxX HAsub HAne). }
claim HlR: l :e R.
{ exact (R_lub_in_R S l Hlub). }
claim HdistR: metric_dist_to_set X d x A :e R.
{ exact (metric_dist_to_set_in_R X d x A Hm HxX HAsub HAne). }
claim HdistDef: metric_dist_to_set X d x A = minus_SNo l.
{ reflexivity. }
claim Hex: exists t:set, t :e S /\ t :e R /\ Rlt (add_SNo l (minus_SNo eps)) t.
{ exact (R_lub_approx_from_below S l eps Hlub HepsR HepsPos). }
apply Hex.
let t. assume Htpack.
claim HtCore: t :e S /\ t :e R.
{ exact (andEL (t :e S /\ t :e R)
               (Rlt (add_SNo l (minus_SNo eps)) t)
               Htpack). }
claim HtIn: t :e S.
{ exact (andEL (t :e S) (t :e R) HtCore). }
apply (ReplE_impred A (fun a0:set => minus_SNo (apply_fun d (x,a0))) t HtIn
  (exists a:set, a :e A /\ a :e X /\ Rlt (apply_fun d (x,a)) (add_SNo (metric_dist_to_set X d x A) eps))).
let a. assume HaA: a :e A.
assume Hteq: t = minus_SNo (apply_fun d (x,a)).
claim HaX: a :e X.
{ exact (HAsub a HaA). }
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxaIn: (x,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x a HxX HaX). }
claim HdxaR: apply_fun d (x,a) :e R.
{ exact (Hfun (x,a) HxaIn). }
claim HtR: t :e R.
{ exact (andER (t :e S) (t :e R) HtCore). }
claim Hlt: Rlt (add_SNo l (minus_SNo eps)) t.
{ exact (andER (t :e S /\ t :e R)
               (Rlt (add_SNo l (minus_SNo eps)) t)
               Htpack). }
claim HltS: add_SNo l (minus_SNo eps) < t.
{ exact (RltE_lt (add_SNo l (minus_SNo eps)) t Hlt). }
claim HlS: SNo l.
{ exact (real_SNo l HlR). }
claim HepsS: SNo eps.
{ exact (real_SNo eps HepsR). }
claim HmepsR: minus_SNo eps :e R.
{ exact (real_minus_SNo eps HepsR). }
claim HmepsS: SNo (minus_SNo eps).
{ exact (real_SNo (minus_SNo eps) HmepsR). }
claim HsumS: SNo (add_SNo l (minus_SNo eps)).
{ exact (real_SNo (add_SNo l (minus_SNo eps)) (real_add_SNo l HlR (minus_SNo eps) HmepsR)). }
claim HdxaS: SNo (apply_fun d (x,a)).
{ exact (real_SNo (apply_fun d (x,a)) HdxaR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HltS2: add_SNo l (minus_SNo eps) < minus_SNo (apply_fun d (x,a)).
{ rewrite <- Hteq.
  exact HltS. }
(** negate inequality to get d(x,a) < - (l - eps) **)
claim Hneg: apply_fun d (x,a) < minus_SNo (add_SNo l (minus_SNo eps)).
{ claim Hneg1: minus_SNo (minus_SNo (apply_fun d (x,a))) < minus_SNo (add_SNo l (minus_SNo eps)).
  { exact (minus_SNo_Lt_contra (add_SNo l (minus_SNo eps)) (minus_SNo (apply_fun d (x,a)))
                               HsumS (SNo_minus_SNo (apply_fun d (x,a)) HdxaS) HltS2). }
  claim Hinv: minus_SNo (minus_SNo (apply_fun d (x,a))) = apply_fun d (x,a).
  { exact (minus_SNo_minus_SNo_real (apply_fun d (x,a)) HdxaR). }
  rewrite <- Hinv.
  exact Hneg1. }
claim HrhsEq: minus_SNo (add_SNo l (minus_SNo eps)) =
  add_SNo (minus_SNo l) eps.
{ rewrite (minus_add_SNo_distr l (minus_SNo eps) HlS HmepsS).
  rewrite (minus_SNo_minus_SNo_real eps HepsR).
  reflexivity. }
claim HltR2: Rlt (apply_fun d (x,a)) (add_SNo (minus_SNo l) eps).
{ rewrite <- HrhsEq.
  exact (RltI (apply_fun d (x,a)) (minus_SNo (add_SNo l (minus_SNo eps))) HdxaR
              (real_minus_SNo (add_SNo l (minus_SNo eps))
                              (real_add_SNo l HlR (minus_SNo eps) HmepsR))
              Hneg). }
witness a.
apply andI.
- apply andI.
  + exact HaA.
  + exact HaX.
- rewrite HdistDef.
  exact HltR2.
Qed.

(** helper: distance to a set is 1-Lipschitz in a metric space **)
Theorem metric_dist_to_set_Lipschitz : forall X d x y A:set,
  metric_on X d ->
  x :e X -> y :e X ->
  A c= X -> A <> Empty ->
  Rle (metric_dist_to_set X d y A)
      (add_SNo (metric_dist_to_set X d x A) (apply_fun d (x,y))).
let X d x y A.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HyX: y :e X.
assume HAsub: A c= X.
assume HAne: A <> Empty.
set distx := metric_dist_to_set X d x A.
set disty := metric_dist_to_set X d y A.
claim HdistxR: distx :e R.
{ exact (metric_dist_to_set_in_R X d x A Hm HxX HAsub HAne). }
claim HdistyR: disty :e R.
{ exact (metric_dist_to_set_in_R X d y A Hm HyX HAsub HAne). }
claim Hfun: function_on d (setprod X X) R.
{ exact (metric_on_function_on X d Hm). }
claim HxyIn: (x,y) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
claim HdxyR: apply_fun d (x,y) :e R.
{ exact (Hfun (x,y) HxyIn). }
set q := add_SNo distx (apply_fun d (x,y)).
claim HqR: q :e R.
{ exact (real_add_SNo distx HdistxR (apply_fun d (x,y)) HdxyR). }
apply (RleI disty q HdistyR HqR).
assume Hlt: Rlt q disty.
set diff := add_SNo disty (minus_SNo q).
claim HdiffR: diff :e R.
{ exact (real_add_SNo disty HdistyR (minus_SNo q) (real_minus_SNo q HqR)). }
claim HdiffPos: Rlt 0 diff.
{ exact (Rlt_0_diff_of_lt q disty Hlt). }
claim HexN0: exists N0 :e omega, eps_ N0 < diff.
{ exact (exists_eps_lt_pos diff HdiffR HdiffPos). }
apply HexN0.
let N0. assume HN0pair.
claim HN0omega: N0 :e omega.
{ exact (andEL (N0 :e omega) (eps_ N0 < diff) HN0pair). }
claim Hepslt: eps_ N0 < diff.
{ exact (andER (N0 :e omega) (eps_ N0 < diff) HN0pair). }
set eps0 := eps_ N0.
claim Heps0R: eps0 :e R.
{ exact (SNoS_omega_real eps0 (SNo_eps_SNoS_omega N0 HN0omega)). }
claim Heps0posS: 0 < eps0.
{ exact (SNo_eps_pos N0 HN0omega). }
claim Heps0pos: Rlt 0 eps0.
{ exact (RltI 0 eps0 real_0 Heps0R Heps0posS). }
claim Heps0ltDiffR: Rlt eps0 diff.
{ exact (RltI eps0 diff Heps0R HdiffR Hepslt). }
claim Heps0ltDiffS: eps0 < diff.
{ exact (RltE_lt eps0 diff Heps0ltDiffR). }
claim HqS: SNo q.
{ exact (real_SNo q HqR). }
claim Heps0S: SNo eps0.
{ exact (real_SNo eps0 Heps0R). }
claim HdiffS: SNo diff.
{ exact (real_SNo diff HdiffR). }
claim HqepsLt: add_SNo q eps0 < add_SNo q diff.
{ exact (add_SNo_Lt2 q eps0 diff HqS Heps0S HdiffS Heps0ltDiffS). }
claim HqdiffEq: add_SNo q diff = disty.
{ claim HdistyS: SNo disty.
  { exact (real_SNo disty HdistyR). }
  claim HqSNo: SNo distx.
  { exact (real_SNo distx HdistxR). }
  claim HdxyS: SNo (apply_fun d (x,y)).
  { exact (real_SNo (apply_fun d (x,y)) HdxyR). }
  claim HmqR: minus_SNo q :e R.
  { exact (real_minus_SNo q HqR). }
  claim HmqS: SNo (minus_SNo q).
  { exact (real_SNo (minus_SNo q) HmqR). }
  claim HdiffDef: diff = add_SNo disty (minus_SNo q).
  { reflexivity. }
  rewrite HdiffDef.
  rewrite (add_SNo_assoc q disty (minus_SNo q) HqS HdistyS HmqS).
  rewrite (add_SNo_com q disty HqS HdistyS).
  rewrite <- (add_SNo_assoc disty q (minus_SNo q) HdistyS HqS HmqS).
  rewrite (add_SNo_minus_SNo_rinv q HqS).
  rewrite (add_SNo_0R disty HdistyS).
  reflexivity. }
claim HqepsRlt: Rlt (add_SNo q eps0) disty.
{ rewrite <- HqdiffEq.
  exact (RltI (add_SNo q eps0) (add_SNo q diff)
              (real_add_SNo q HqR eps0 Heps0R)
              (real_add_SNo q HqR diff HdiffR)
              HqepsLt). }

(** approximate minimizer for dist(x,A) at scale eps0 **)
claim Hexa: exists a:set, a :e A /\ a :e X /\
  Rlt (apply_fun d (x,a)) (add_SNo distx eps0).
{ exact (metric_dist_to_set_approx X d x A eps0 Hm HxX HAsub HAne Heps0R Heps0pos). }
apply Hexa.
let a. assume Hapack.
claim HaCore: a :e A /\ a :e X.
{ exact (andEL (a :e A /\ a :e X)
               (Rlt (apply_fun d (x,a)) (add_SNo distx eps0))
               Hapack). }
claim HaA: a :e A.
{ exact (andEL (a :e A) (a :e X) HaCore). }
claim HaX: a :e X.
{ exact (andER (a :e A) (a :e X) HaCore). }
claim HdxaIn: (x,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x a HxX HaX). }
claim HdyaIn: (y,a) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X y a HyX HaX). }
claim HdxaR: apply_fun d (x,a) :e R.
{ exact (Hfun (x,a) HdxaIn). }
claim HdyaR: apply_fun d (y,a) :e R.
{ exact (Hfun (y,a) HdyaIn). }
claim Hdxalt: Rlt (apply_fun d (x,a)) (add_SNo distx eps0).
{ exact (andER (a :e A /\ a :e X)
               (Rlt (apply_fun d (x,a)) (add_SNo distx eps0))
               Hapack). }
claim HdxySym: apply_fun d (y,x) = apply_fun d (x,y).
{ exact (metric_on_symmetric X d y x Hm HyX HxX). }
claim HdxyR2: apply_fun d (y,x) :e R.
{ exact (Hfun (y,x) (tuple_2_setprod_by_pair_Sigma X X y x HyX HxX)). }
claim HsumR1: add_SNo (apply_fun d (y,x)) (apply_fun d (x,a)) :e R.
{ exact (real_add_SNo (apply_fun d (y,x)) HdxyR2 (apply_fun d (x,a)) HdxaR). }
claim HsumR2: add_SNo (apply_fun d (x,y)) (apply_fun d (x,a)) :e R.
{ exact (real_add_SNo (apply_fun d (x,y)) HdxyR (apply_fun d (x,a)) HdxaR). }
claim HtriLe: Rle (apply_fun d (y,a)) (add_SNo (apply_fun d (y,x)) (apply_fun d (x,a))).
{ apply (RleI (apply_fun d (y,a)) (add_SNo (apply_fun d (y,x)) (apply_fun d (x,a))) HdyaR HsumR1).
  assume Hbad: Rlt (add_SNo (apply_fun d (y,x)) (apply_fun d (x,a))) (apply_fun d (y,a)).
  exact ((metric_on_triangle X d y x a Hm HyX HxX HaX) Hbad). }
claim HtriLe2: Rle (apply_fun d (y,a)) (add_SNo (apply_fun d (x,y)) (apply_fun d (x,a))).
{ rewrite <- HdxySym.
  exact HtriLe. }
claim Hdyalt: Rlt (apply_fun d (y,a)) (add_SNo q eps0).
{ (** first show (d(x,y)+d(x,a)) < q+eps0 **)
  claim HdxyS: SNo (apply_fun d (x,y)).
  { exact (real_SNo (apply_fun d (x,y)) HdxyR). }
  claim HdxaS: SNo (apply_fun d (x,a)).
  { exact (real_SNo (apply_fun d (x,a)) HdxaR). }
  claim HdistxS: SNo distx.
  { exact (real_SNo distx HdistxR). }
  claim Heps0S2: SNo eps0.
  { exact (real_SNo eps0 Heps0R). }
  claim Hm1S: SNo (add_SNo distx eps0).
  { exact (real_SNo (add_SNo distx eps0) (real_add_SNo distx HdistxR eps0 Heps0R)). }
  claim Hlt1S: apply_fun d (x,a) < add_SNo distx eps0.
  { exact (RltE_lt (apply_fun d (x,a)) (add_SNo distx eps0) Hdxalt). }
  claim HsumLtS: add_SNo (apply_fun d (x,y)) (apply_fun d (x,a)) <
                 add_SNo (apply_fun d (x,y)) (add_SNo distx eps0).
  { exact (add_SNo_Lt2 (apply_fun d (x,y)) (apply_fun d (x,a)) (add_SNo distx eps0)
                       HdxyS HdxaS Hm1S Hlt1S). }
  claim HrhsEq: add_SNo (apply_fun d (x,y)) (add_SNo distx eps0) = add_SNo q eps0.
  { claim HqDef: q = add_SNo distx (apply_fun d (x,y)).
    { reflexivity. }
    rewrite HqDef.
    rewrite (add_SNo_assoc (apply_fun d (x,y)) distx eps0 HdxyS HdistxS Heps0S2).
    rewrite (add_SNo_com (apply_fun d (x,y)) distx HdxyS HdistxS).
    reflexivity. }
  claim HsumLtR: Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (x,a))) (add_SNo q eps0).
  { rewrite <- HrhsEq.
    exact (RltI (add_SNo (apply_fun d (x,y)) (apply_fun d (x,a)))
                (add_SNo (apply_fun d (x,y)) (add_SNo distx eps0))
                (real_add_SNo (apply_fun d (x,y)) HdxyR (apply_fun d (x,a)) HdxaR)
                (real_add_SNo (apply_fun d (x,y)) HdxyR (add_SNo distx eps0) (real_add_SNo distx HdistxR eps0 Heps0R))
                HsumLtS). }
  exact (Rle_Rlt_tra_Euclid (apply_fun d (y,a))
                            (add_SNo (apply_fun d (x,y)) (apply_fun d (x,a)))
                            (add_SNo q eps0)
                            HtriLe2
                            HsumLtR). }
claim HdistyLe: Rle disty (apply_fun d (y,a)).
{ exact (metric_dist_to_set_le_dist X d y A a Hm HyX HAsub HAne HaA). }
claim HdistyLt: Rlt disty (add_SNo q eps0).
{ exact (Rle_Rlt_tra_Euclid disty (apply_fun d (y,a)) (add_SNo q eps0) HdistyLe Hdyalt). }
exact ((not_Rlt_sym (add_SNo q eps0) disty HqepsRlt) HdistyLt).
Qed.

(** helper: point outside a closed set has positive distance to the set in metric topology **)
Theorem metric_dist_to_closed_set_pos_if_not_mem : forall X d B x:set,
  metric_on X d ->
  closed_in X (metric_topology X d) B ->
  x :e X ->
  x /:e B ->
  B <> Empty ->
  Rlt 0 (metric_dist_to_set X d x B).
let X d B x.
assume Hm: metric_on X d.
assume HBcl: closed_in X (metric_topology X d) B.
assume HxX: x :e X.
assume HxnotB: x /:e B.
assume HBne: B <> Empty.
set Tx := metric_topology X d.
claim HTx: topology_on X Tx.
{ exact (metric_topology_is_topology X d Hm). }
claim HBpkg: B c= X /\ exists U :e Tx, B = X :\: U.
{ exact (closed_in_package X Tx B HBcl). }
claim HBsub: B c= X.
{ exact (andEL (B c= X) (exists U :e Tx, B = X :\: U) HBpkg). }
claim HexU: exists U :e Tx, B = X :\: U.
{ exact (andER (B c= X) (exists U :e Tx, B = X :\: U) HBpkg). }
apply HexU.
let U. assume HUconj.
claim HU: U :e Tx.
{ exact (andEL (U :e Tx) (B = X :\: U) HUconj). }
claim HBdef: B = X :\: U.
{ exact (andER (U :e Tx) (B = X :\: U) HUconj). }

claim HxU: x :e U.
{ apply (xm (x :e U)).
  - assume H: x :e U. exact H.
  - assume Hnot: x /:e U.
    claim HxBU: x :e X :\: U.
    { exact (setminusI X U x HxX Hnot). }
    claim HxB: x :e B.
    { rewrite HBdef. exact HxBU. }
    apply FalseE.
    exact (HxnotB HxB). }

claim HexBall: exists r:set, r :e R /\ (Rlt 0 r /\ open_ball X d x r c= U).
{ set B0 := famunion X (fun c:set => {open_ball X d c r0|r0 :e R, Rlt 0 r0}).
  claim Hdef: Tx = generated_topology X B0.
  { reflexivity. }
  claim HUgen: U :e generated_topology X B0.
  { rewrite <- Hdef.
    exact HU. }
  claim HUcond: forall y :e U, exists b0 :e B0, y :e b0 /\ b0 c= U.
  { exact (SepE2 (Power X)
                 (fun U0:set => forall y0:set, y0 :e U0 -> exists b0 :e B0, y0 :e b0 /\ b0 c= U0)
                 U
                 HUgen). }
  claim Hexb0: exists b0 :e B0, x :e b0 /\ b0 c= U.
  { exact (HUcond x HxU). }
  apply Hexb0.
  let b0. assume Hb0pair.
  claim Hb0B0: b0 :e B0.
  { exact (andEL (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair). }
  claim Hxinb0: x :e b0.
  { exact (andEL (x :e b0) (b0 c= U)
                 (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
  claim Hb0sub: b0 c= U.
  { exact (andER (x :e b0) (b0 c= U)
                 (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
  apply (famunionE_impred X (fun c:set => {open_ball X d c r0|r0 :e R, Rlt 0 r0})
                          b0 Hb0B0
                          (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
  let c. assume HcX: c :e X.
  assume Hb0In: b0 :e {open_ball X d c r0|r0 :e R, Rlt 0 r0}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0)
                          b0 Hb0In
                          (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
  let r0. assume Hr0R: r0 :e R.
  assume Hr0pos: Rlt 0 r0.
  assume Hb0eq: b0 = open_ball X d c r0.
  claim HxinBall: x :e open_ball X d c r0.
  { rewrite <- Hb0eq.
    exact Hxinb0. }
  claim HballsubU: open_ball X d c r0 c= U.
  { rewrite <- Hb0eq.
    exact Hb0sub. }
  claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r0.
  { exact (open_ball_refine_center X d c x r0 Hm HcX HxX Hr0R Hr0pos HxinBall). }
  apply Hexs.
  let s. assume Hs.
  claim Hs12: s :e R /\ Rlt 0 s.
  { exact (andEL (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
  claim HsR: s :e R.
  { exact (andEL (s :e R) (Rlt 0 s) Hs12). }
  claim Hspos: Rlt 0 s.
  { exact (andER (s :e R) (Rlt 0 s) Hs12). }
  claim HsubBall: open_ball X d x s c= open_ball X d c r0.
  { exact (andER (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
  claim HsubU: open_ball X d x s c= U.
  { exact (Subq_tra (open_ball X d x s) (open_ball X d c r0) U HsubBall HballsubU). }
  witness s.
  apply andI.
  - exact HsR.
  - apply andI.
    + exact Hspos.
    + exact HsubU. }
apply HexBall.
let r. assume Hrpack.
claim HrR: r :e R.
{ exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
claim Hrprop: Rlt 0 r /\ open_ball X d x r c= U.
{ exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
claim Hrpos: Rlt 0 r.
{ exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
claim HballsubU: open_ball X d x r c= U.
{ exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }

claim HdistR: metric_dist_to_set X d x B :e R.
{ exact (metric_dist_to_set_in_R X d x B Hm HxX HBsub HBne). }
set l := metric_sup_neg_dists X d x B.
claim Hlub: R_lub (metric_neg_dists X d x B) l.
{ exact (metric_sup_neg_dists_is_lub X d x B Hm HxX HBsub HBne). }
claim HlR: l :e R.
{ exact (R_lub_in_R (metric_neg_dists X d x B) l Hlub). }
claim HdistDef: metric_dist_to_set X d x B = minus_SNo l.
{ reflexivity. }
set u := minus_SNo r.
claim HuR: u :e R.
{ exact (real_minus_SNo r HrR). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HuDef: u = minus_SNo r.
{ reflexivity. }
claim HuS: SNo u.
{ rewrite HuDef.
  exact (SNo_minus_SNo r HrS). }

(** show u is an upper bound for metric_neg_dists X d x B **)
claim Hub: forall t:set, t :e metric_neg_dists X d x B -> t :e R -> Rle t u.
{ let t. assume HtS: t :e metric_neg_dists X d x B.
  assume HtR: t :e R.
  apply (ReplE_impred B (fun b0:set => minus_SNo (apply_fun d (x,b0))) t HtS (Rle t u)).
  let b. assume HbB: b :e B.
  assume Hteq: t = minus_SNo (apply_fun d (x,b)).
  claim HbX: b :e X.
  { exact (HBsub b HbB). }
  claim HbnotU: b /:e U.
  { claim HbBU: b :e X :\: U.
    { rewrite <- HBdef. exact HbB. }
    exact (setminusE2 X U b HbBU). }
  claim HbnotBall: b /:e open_ball X d x r.
  { assume HbBall: b :e open_ball X d x r.
    claim HbU: b :e U.
    { exact (HballsubU b HbBall). }
    exact (HbnotU HbU). }
  claim Hnlt: ~(Rlt (apply_fun d (x,b)) r).
  { assume Hlt: Rlt (apply_fun d (x,b)) r.
    claim HbBall: b :e open_ball X d x r.
    { exact (SepI X (fun y0:set => Rlt (apply_fun d (x,y0)) r) b HbX Hlt). }
    exact (HbnotBall HbBall). }
  claim HdxbR: apply_fun d (x,b) :e R.
  { claim Hfun: function_on d (setprod X X) R.
    { exact (metric_on_function_on X d Hm). }
    claim HxbIn: (x,b) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x b HxX HbX). }
    exact (Hfun (x,b) HxbIn). }
  claim Hrle: Rle r (apply_fun d (x,b)).
  { exact (RleI r (apply_fun d (x,b)) HrR HdxbR Hnlt). }
  (** turn r <= d into -d <= -r **)
  claim Hntlt: ~(Rlt u t).
  { assume Hltut: Rlt u t.
    claim Hut: u < t.
    { exact (RltE_lt u t Hltut). }
    claim Hut2: u < minus_SNo (apply_fun d (x,b)).
    { rewrite <- Hteq.
      exact Hut. }
    claim HdS: SNo (apply_fun d (x,b)).
    { exact (real_SNo (apply_fun d (x,b)) HdxbR). }
    claim Hltneg: apply_fun d (x,b) < minus_SNo u.
    { exact (minus_SNo_Lt_contra2 u (apply_fun d (x,b))
                                 HuS HdS Hut2). }
    claim Hinv: minus_SNo u = r.
    { rewrite HuDef.
      exact (minus_SNo_minus_SNo_real r HrR). }
    claim Hltneg2: apply_fun d (x,b) < r.
    { rewrite <- Hinv.
      exact Hltneg. }
    claim HltR: Rlt (apply_fun d (x,b)) r.
    { exact (RltI (apply_fun d (x,b)) r HdxbR HrR Hltneg2). }
    exact (Hnlt HltR). }
  (** now show Rle t u **)
  apply (RleI t u HtR HuR).
  assume Hltut: Rlt u t.
  exact (Hntlt Hltut). }

claim Hmin: forall v:set, v :e R ->
  (forall t:set, t :e metric_neg_dists X d x B -> t :e R -> Rle t v) ->
  Rle l v.
{ exact (andER (l :e R /\ forall t:set, t :e metric_neg_dists X d x B -> t :e R -> Rle t l)
               (forall v:set, v :e R ->
                 (forall t:set, t :e metric_neg_dists X d x B -> t :e R -> Rle t v) ->
                 Rle l v)
               Hlub). }

claim Hle_l_u: Rle l u.
{ exact (Hmin u HuR Hub). }
claim Hnlt_u_l: ~(Rlt u l).
{ exact (RleE_nlt l u Hle_l_u). }

claim Hle_r_dist: Rle r (metric_dist_to_set X d x B).
{ apply (RleI r (metric_dist_to_set X d x B) HrR HdistR).
  assume Hlt: Rlt (metric_dist_to_set X d x B) r.
  claim Hlt2: Rlt (minus_SNo l) r.
  { rewrite <- HdistDef.
    exact Hlt. }
  claim HltS: minus_SNo l < r.
  { exact (RltE_lt (minus_SNo l) r Hlt2). }
  claim HlS: SNo l.
  { exact (real_SNo l HlR). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim Hneg: minus_SNo r < l.
  { exact (minus_SNo_Lt_contra1 l r HlS HrS HltS). }
  claim HnegR: Rlt u l.
  { exact (RltI u l HuR HlR Hneg). }
  exact (Hnlt_u_l HnegR). }

rewrite HdistDef.
exact (Rlt_Rle_tra 0 r (minus_SNo l) Hrpos Hle_r_dist).
Qed.

(** from §32 Theorem 32.2: metrizable spaces are normal **) 
(** LATEX VERSION: Every metrizable space is normal. **)
Theorem metrizable_spaces_normal : forall X d:set,
  metric_on X d -> normal_space X (metric_topology X d).
let X d.
assume Hd: metric_on X d.
prove normal_space X (metric_topology X d).
(** Strategy: Build the T1 package from metric balls, then handle separation of disjoint closed sets. **)
prove one_point_sets_closed X (metric_topology X d) /\
  forall A B:set, closed_in X (metric_topology X d) A -> closed_in X (metric_topology X d) B -> A :/\: B = Empty ->
    exists U V:set, U :e (metric_topology X d) /\ V :e (metric_topology X d) /\ A c= U /\ B c= V /\ U :/\: V = Empty.
apply andI.
- exact (metric_topology_one_point_sets_closed X d Hd).
- let A B.
  assume HAcl: closed_in X (metric_topology X d) A.
  assume HBcl: closed_in X (metric_topology X d) B.
  assume Hdisj: A :/\: B = Empty.
  prove exists U V:set, U :e (metric_topology X d) /\ V :e (metric_topology X d) /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  claim HTx: topology_on X (metric_topology X d).
  { exact (metric_topology_is_topology X d Hd). }

  apply (xm (A = Empty)).
  - assume HAe: A = Empty.
    witness Empty.
    witness X.
    prove Empty :e metric_topology X d /\ X :e metric_topology X d /\ A c= Empty /\ B c= X /\ Empty :/\: X = Empty.
    apply andI.
    + apply andI.
      * apply andI.
        - apply andI.
          { exact (topology_has_empty X (metric_topology X d) HTx). }
          { exact (topology_has_X X (metric_topology X d) HTx). }
        - rewrite HAe. exact (Subq_Empty Empty).
      * exact (closed_in_subset X (metric_topology X d) B HBcl).
    + apply set_ext.
      * let x. assume Hx: x :e Empty :/\: X.
        prove x :e Empty.
        exact (binintersectE1 Empty X x Hx).
      * let x. assume Hx: x :e Empty.
        prove x :e Empty :/\: X.
        exact (EmptyE x Hx (x :e Empty :/\: X)).
  - assume HAn: ~(A = Empty).
    apply (xm (B = Empty)).
    + assume HBe: B = Empty.
      witness X.
      witness Empty.
      prove X :e metric_topology X d /\ Empty :e metric_topology X d /\ A c= X /\ B c= Empty /\ X :/\: Empty = Empty.
      apply andI.
      * apply andI.
        - apply andI.
          { apply andI.
            - exact (topology_has_X X (metric_topology X d) HTx).
            - exact (topology_has_empty X (metric_topology X d) HTx). }
          { exact (closed_in_subset X (metric_topology X d) A HAcl). }
        - rewrite HBe. exact (Subq_Empty Empty).
      * apply set_ext.
        { let x. assume Hx: x :e X :/\: Empty.
          prove x :e Empty.
          exact (binintersectE2 X Empty x Hx). }
        { let x. assume Hx: x :e Empty.
          prove x :e X :/\: Empty.
          exact (EmptyE x Hx (x :e X :/\: Empty)). }
    + assume HBn: ~(B = Empty).
      (** Standard construction using distance to closed sets. **)
      set U := {x :e X|Rlt (metric_dist_to_set X d x A) (metric_dist_to_set X d x B)}.
      set V := {x :e X|Rlt (metric_dist_to_set X d x B) (metric_dist_to_set X d x A)}.
      witness U.
      witness V.
      prove U :e metric_topology X d /\ V :e metric_topology X d /\ A c= U /\ B c= V /\ U :/\: V = Empty.
      (** The open-membership and inclusion parts are left as admitted scaffolding. **)
      apply andI.
      - apply andI.
	        + apply andI.
	          * apply andI.
	            { (** U is open in the metric topology **)
	              claim HAsubX: A c= X.
	              { exact (closed_in_subset X (metric_topology X d) A HAcl). }
	              claim HBsubX: B c= X.
	              { exact (closed_in_subset X (metric_topology X d) B HBcl). }
	              set B0 := famunion X (fun x0:set => {open_ball X d x0 r0|r0 :e R, Rlt 0 r0}).
	              claim HTdef: metric_topology X d = generated_topology X B0.
	              { reflexivity. }
		              rewrite HTdef.
		              prove U :e generated_topology X B0.
		              claim HUsubX0: U c= X.
		              { let x0. assume Hx0U: x0 :e U.
		                exact (SepE1 X (fun z0:set => Rlt (metric_dist_to_set X d z0 A)
		                                                 (metric_dist_to_set X d z0 B)) x0 Hx0U). }
		              claim HUPow: U :e Power X.
		              { exact (PowerI X U HUsubX0). }
		              claim HUprop: forall x0 :e U, exists b :e B0, x0 :e b /\ b c= U.
		              { let x0. assume Hx0U: x0 :e U.
		                prove exists b :e B0, x0 :e b /\ b c= U.
	              claim Hx0X: x0 :e X.
	              { exact (SepE1 X (fun z0:set => Rlt (metric_dist_to_set X d z0 A)
	                                                (metric_dist_to_set X d z0 B)) x0 Hx0U). }
	              claim Hx0lt: Rlt (metric_dist_to_set X d x0 A) (metric_dist_to_set X d x0 B).
	              { exact (SepE2 X (fun z0:set => Rlt (metric_dist_to_set X d z0 A)
	                                                (metric_dist_to_set X d z0 B)) x0 Hx0U). }
	              set distA0 := metric_dist_to_set X d x0 A.
	              set distB0 := metric_dist_to_set X d x0 B.
	              claim HdistA0R: distA0 :e R.
	              { exact (metric_dist_to_set_in_R X d x0 A Hd Hx0X HAsubX HAn). }
	              claim HdistB0R: distB0 :e R.
	              { exact (metric_dist_to_set_in_R X d x0 B Hd Hx0X HBsubX HBn). }
	              set gap := add_SNo distB0 (minus_SNo distA0).
	              claim HgapPos: Rlt 0 gap.
	              { exact (Rlt_0_diff_of_lt distA0 distB0 Hx0lt). }
	              claim HgapR: gap :e R.
	              { exact (RltE_right 0 gap HgapPos). }
	              claim HexN0: exists N0 :e omega, eps_ N0 < gap.
	              { exact (exists_eps_lt_pos gap HgapR HgapPos). }
	              apply HexN0.
	              let N0. assume HN0pair.
	              claim HN0omega: N0 :e omega.
	              { exact (andEL (N0 :e omega) (eps_ N0 < gap) HN0pair). }
	              claim HepsN0lt: eps_ N0 < gap.
	              { exact (andER (N0 :e omega) (eps_ N0 < gap) HN0pair). }
	              claim HepsN0R: eps_ N0 :e R.
	              { exact (SNoS_omega_real (eps_ N0) (SNo_eps_SNoS_omega N0 HN0omega)). }
	              claim HepsN0Rlt: Rlt (eps_ N0) gap.
	              { exact (RltI (eps_ N0) gap HepsN0R HgapR HepsN0lt). }
	              claim HN0nat: nat_p N0.
	              { exact (omega_nat_p N0 HN0omega). }
	              claim Hsucc0: ordsucc N0 :e omega.
	              { exact (omega_ordsucc N0 HN0omega). }
	              set r := eps_ (ordsucc N0).
	              claim HrR: r :e R.
	              { exact (SNoS_omega_real r (SNo_eps_SNoS_omega (ordsucc N0) Hsucc0)). }
	              claim HrposS: 0 < r.
	              { exact (SNo_eps_pos (ordsucc N0) Hsucc0). }
	              claim Hrpos: Rlt 0 r.
	              { exact (RltI 0 r real_0 HrR HrposS). }
	              claim HrrEq: add_SNo r r = eps_ N0.
	              { exact (eps_ordsucc_half_add N0 HN0nat). }
	              claim HrrR: add_SNo r r :e R.
	              { exact (real_add_SNo r HrR r HrR). }
	              claim HrrLtGap: Rlt (add_SNo r r) gap.
	              { rewrite HrrEq.
	                exact HepsN0Rlt. }
	              claim Hmargin: Rlt (add_SNo distA0 r) (add_SNo distB0 (minus_SNo r)).
	              { (** distA0 + r + r < distB0 implies distA0 + r < distB0 - r **)
	                claim HdistA0S: SNo distA0.
	                { exact (real_SNo distA0 HdistA0R). }
	                claim HdistB0S: SNo distB0.
	                { exact (real_SNo distB0 HdistB0R). }
	                claim HrS: SNo r.
	                { exact (real_SNo r HrR). }
	                claim HgapS: SNo gap.
	                { exact (real_SNo gap HgapR). }
	                claim HrrS: SNo (add_SNo r r).
	                { exact (real_SNo (add_SNo r r) HrrR). }
	                claim HrrLtGapS: add_SNo r r < gap.
	                { exact (RltE_lt (add_SNo r r) gap HrrLtGap). }
	                claim HlhsR: add_SNo distA0 (add_SNo r r) :e R.
	                { exact (real_add_SNo distA0 HdistA0R (add_SNo r r) HrrR). }
	                claim Hr2R: add_SNo distB0 (minus_SNo distA0) :e R.
	                { exact (real_add_SNo distB0 HdistB0R (minus_SNo distA0) (real_minus_SNo distA0 HdistA0R)). }
	                claim HtmpLt: add_SNo distA0 (add_SNo r r) < add_SNo distA0 gap.
	                { exact (add_SNo_Lt2 distA0 (add_SNo r r) gap HdistA0S HrrS HgapS HrrLtGapS). }
	                claim HtmpRlt: Rlt (add_SNo distA0 (add_SNo r r)) (add_SNo distA0 gap).
	                { exact (RltI (add_SNo distA0 (add_SNo r r)) (add_SNo distA0 gap)
	                            HlhsR
	                            (real_add_SNo distA0 HdistA0R gap HgapR)
	                            HtmpLt). }
	                claim HgapEq: add_SNo distA0 gap = distB0.
	                { rewrite (add_SNo_assoc distA0 distB0 (minus_SNo distA0) HdistA0S HdistB0S (real_SNo (minus_SNo distA0) (real_minus_SNo distA0 HdistA0R))).
	                  rewrite (add_SNo_com distA0 distB0 HdistA0S HdistB0S).
	                  rewrite <- (add_SNo_assoc distB0 distA0 (minus_SNo distA0) HdistB0S HdistA0S (real_SNo (minus_SNo distA0) (real_minus_SNo distA0 HdistA0R))).
	                  rewrite (add_SNo_minus_SNo_rinv distA0 HdistA0S).
	                  rewrite (add_SNo_0R distB0 HdistB0S).
	                  reflexivity. }
		                claim HtmpRlt2: Rlt (add_SNo distA0 (add_SNo r r)) distB0.
		                { rewrite <- HgapEq. exact HtmpRlt. }
	                claim HminusR: minus_SNo r :e R.
	                { exact (real_minus_SNo r HrR). }
	                claim HminusS: SNo (minus_SNo r).
	                { exact (real_SNo (minus_SNo r) HminusR). }
	                claim HaddLe: Rlt (add_SNo (add_SNo distA0 (add_SNo r r)) (minus_SNo r))
	                                (add_SNo distB0 (minus_SNo r)).
	                { exact (RltI (add_SNo (add_SNo distA0 (add_SNo r r)) (minus_SNo r))
	                              (add_SNo distB0 (minus_SNo r))
	                              (real_add_SNo (add_SNo distA0 (add_SNo r r)) HlhsR (minus_SNo r) HminusR)
	                              (real_add_SNo distB0 HdistB0R (minus_SNo r) HminusR)
	                              (add_SNo_Lt1 (add_SNo distA0 (add_SNo r r)) (minus_SNo r) distB0
		                                           (real_SNo (add_SNo distA0 (add_SNo r r)) HlhsR) HminusS HdistB0S
		                                           (RltE_lt (add_SNo distA0 (add_SNo r r)) distB0 HtmpRlt2))). }
	                claim HlhsEq: add_SNo (add_SNo distA0 (add_SNo r r)) (minus_SNo r) = add_SNo distA0 r.
	                { rewrite (add_SNo_assoc distA0 r r HdistA0S HrS HrS).
	                  rewrite <- (add_SNo_assoc (add_SNo distA0 r) r (minus_SNo r)
	                           (real_SNo (add_SNo distA0 r) (real_add_SNo distA0 HdistA0R r HrR))
	                           HrS HminusS).
	                  rewrite (add_SNo_minus_SNo_rinv r HrS).
	                  rewrite (add_SNo_0R (add_SNo distA0 r)
	                           (real_SNo (add_SNo distA0 r) (real_add_SNo distA0 HdistA0R r HrR))).
	                  reflexivity. }
		                claim HaddLe2: Rlt (add_SNo distA0 r) (add_SNo distB0 (minus_SNo r)).
		                { rewrite <- HlhsEq. exact HaddLe. }
		                exact HaddLe2. }
		              witness (open_ball X d x0 r).
		              prove open_ball X d x0 r :e B0 /\ (x0 :e open_ball X d x0 r /\ open_ball X d x0 r c= U).
		              apply andI.
		              - (** ball is in B0 **)
		                claim HballIn: open_ball X d x0 r :e {open_ball X d x0 r0|r0 :e R, Rlt 0 r0}.
		                { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x0 r0)
		                               r HrR Hrpos). }
		                exact (famunionI X (fun x1:set => {open_ball X d x1 r0|r0 :e R, Rlt 0 r0})
		                                 x0 (open_ball X d x0 r) Hx0X HballIn).
		              - apply andI.
		                + exact (center_in_open_ball X d x0 r Hd Hx0X Hrpos).
		                + (** ball subset U **)
		                  let y0. assume Hy0Ball: y0 :e open_ball X d x0 r.
		                  prove y0 :e U.
	                  claim Hy0X: y0 :e X.
	                  { exact (SepE1 X (fun z0:set => Rlt (apply_fun d (x0,z0)) r) y0 Hy0Ball). }
	                  claim Hdxy0: Rlt (apply_fun d (x0,y0)) r.
	                  { exact (SepE2 X (fun z0:set => Rlt (apply_fun d (x0,z0)) r) y0 Hy0Ball). }
		                  claim Hdxy0R: apply_fun d (x0,y0) :e R.
		                  { exact (metric_on_function_on X d Hd (x0,y0)
		                           (tuple_2_setprod_by_pair_Sigma X X x0 y0 Hx0X Hy0X)). }
	                  claim HleA: Rle (metric_dist_to_set X d y0 A) (add_SNo distA0 (apply_fun d (x0,y0))).
	                  { exact (metric_dist_to_set_Lipschitz X d x0 y0 A Hd Hx0X Hy0X HAsubX HAn). }
	                  claim HltA1: Rlt (add_SNo distA0 (apply_fun d (x0,y0))) (add_SNo distA0 r).
	                  { claim HdistA0S: SNo distA0.
	                    { exact (real_SNo distA0 HdistA0R). }
	                    claim Hdxy0S: SNo (apply_fun d (x0,y0)).
	                    { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim HrS: SNo r.
	                    { exact (real_SNo r HrR). }
	                    exact (RltI (add_SNo distA0 (apply_fun d (x0,y0))) (add_SNo distA0 r)
	                               (real_add_SNo distA0 HdistA0R (apply_fun d (x0,y0)) Hdxy0R)
	                               (real_add_SNo distA0 HdistA0R r HrR)
	                               (add_SNo_Lt2 distA0 (apply_fun d (x0,y0)) r HdistA0S Hdxy0S HrS
	                                           (RltE_lt (apply_fun d (x0,y0)) r Hdxy0))). }
	                  claim HltA: Rlt (metric_dist_to_set X d y0 A) (add_SNo distA0 r).
	                  { exact (Rle_Rlt_tra_Euclid (metric_dist_to_set X d y0 A)
	                                              (add_SNo distA0 (apply_fun d (x0,y0)))
	                                              (add_SNo distA0 r)
	                                              HleA HltA1). }
	                  claim HleBswap: Rle distB0 (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (y0,x0))).
	                  { exact (metric_dist_to_set_Lipschitz X d y0 x0 B Hd Hy0X Hx0X HBsubX HBn). }
	                  claim Hsymd: apply_fun d (y0,x0) = apply_fun d (x0,y0).
	                  { exact (metric_on_symmetric X d y0 x0 Hd Hy0X Hx0X). }
	                  claim HleB: Rle distB0 (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0))).
	                  { rewrite <- Hsymd.
	                    exact HleBswap. }
	                  claim HlowerB: Rle (add_SNo distB0 (minus_SNo (apply_fun d (x0,y0)))) (metric_dist_to_set X d y0 B).
	                  { claim HmdxyR: minus_SNo (apply_fun d (x0,y0)) :e R.
	                    { exact (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim HmdxyS: SNo (minus_SNo (apply_fun d (x0,y0))).
	                    { exact (real_SNo (minus_SNo (apply_fun d (x0,y0))) HmdxyR). }
	                    claim HsumR: add_SNo (minus_SNo (apply_fun d (x0,y0))) distB0 :e R.
	                    { exact (real_add_SNo (minus_SNo (apply_fun d (x0,y0))) HmdxyR distB0 HdistB0R). }
	                    claim HsumR2: add_SNo (minus_SNo (apply_fun d (x0,y0)))
	                                     (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0))) :e R.
	                    { exact (real_add_SNo (minus_SNo (apply_fun d (x0,y0))) HmdxyR
	                                          (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0)))
	                                          (real_add_SNo (metric_dist_to_set X d y0 B)
	                                                        (metric_dist_to_set_in_R X d y0 B Hd Hy0X HBsubX HBn)
	                                                        (apply_fun d (x0,y0)) Hdxy0R)). }
	                    claim Hshift: Rle (add_SNo (minus_SNo (apply_fun d (x0,y0))) distB0)
	                                    (add_SNo (minus_SNo (apply_fun d (x0,y0)))
	                                             (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0)))).
	                    { exact (Rle_add_SNo_2 (minus_SNo (apply_fun d (x0,y0))) distB0
	                                           (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0)))
	                                           HmdxyR HdistB0R
	                                           (real_add_SNo (metric_dist_to_set X d y0 B)
	                                                         (metric_dist_to_set_in_R X d y0 B Hd Hy0X HBsubX HBn)
	                                                         (apply_fun d (x0,y0)) Hdxy0R)
	                                           HleB). }
	                    claim HrhsEq: add_SNo (minus_SNo (apply_fun d (x0,y0)))
	                                     (add_SNo (metric_dist_to_set X d y0 B) (apply_fun d (x0,y0))) =
	                                   metric_dist_to_set X d y0 B.
	                    { claim HdxyS: SNo (apply_fun d (x0,y0)).
	                      { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                      claim HB0R: metric_dist_to_set X d y0 B :e R.
	                      { exact (metric_dist_to_set_in_R X d y0 B Hd Hy0X HBsubX HBn). }
	                      claim HB0S: SNo (metric_dist_to_set X d y0 B).
	                      { exact (real_SNo (metric_dist_to_set X d y0 B) HB0R). }
	                      claim HmdxyS2: SNo (minus_SNo (apply_fun d (x0,y0))).
	                      { exact (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R)). }
	                      rewrite (add_SNo_assoc (minus_SNo (apply_fun d (x0,y0)))
	                                             (metric_dist_to_set X d y0 B)
	                                             (apply_fun d (x0,y0))
	                                             HmdxyS2 HB0S HdxyS).
	                      rewrite (add_SNo_com (minus_SNo (apply_fun d (x0,y0))) (metric_dist_to_set X d y0 B)
	                                           HmdxyS2 HB0S).
	                      rewrite <- (add_SNo_assoc (metric_dist_to_set X d y0 B)
	                                                (minus_SNo (apply_fun d (x0,y0)))
	                                                (apply_fun d (x0,y0))
	                                                HB0S HmdxyS2 HdxyS).
	                      rewrite (add_SNo_minus_SNo_linv (apply_fun d (x0,y0)) HdxyS).
	                      rewrite (add_SNo_0R (metric_dist_to_set X d y0 B) HB0S).
	                      reflexivity. }
	                    claim HlhsEq: add_SNo (minus_SNo (apply_fun d (x0,y0))) distB0 =
	                                  add_SNo distB0 (minus_SNo (apply_fun d (x0,y0))).
	                    { claim HdistB0S: SNo distB0.
	                      { exact (real_SNo distB0 HdistB0R). }
	                      claim HmdxyS2: SNo (minus_SNo (apply_fun d (x0,y0))).
	                      { exact (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R)). }
	                      exact (add_SNo_com (minus_SNo (apply_fun d (x0,y0))) distB0 HmdxyS2 HdistB0S). }
		                    claim Hshift2: Rle (add_SNo distB0 (minus_SNo (apply_fun d (x0,y0))))
		                                     (metric_dist_to_set X d y0 B).
		                    { rewrite <- HlhsEq. rewrite <- HrhsEq. exact Hshift. }
		                    exact Hshift2. }
	                  claim HltB0: Rlt (add_SNo distB0 (minus_SNo r))
	                                  (add_SNo distB0 (minus_SNo (apply_fun d (x0,y0)))).
	                  { claim HrS: SNo r.
	                    { exact (real_SNo r HrR). }
	                    claim HdxyS: SNo (apply_fun d (x0,y0)).
	                    { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim HmdxyS: SNo (minus_SNo (apply_fun d (x0,y0))).
	                    { exact (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R)). }
	                    claim HmrS: SNo (minus_SNo r).
	                    { exact (real_SNo (minus_SNo r) (real_minus_SNo r HrR)). }
	                    claim HdxyLtS: apply_fun d (x0,y0) < r.
	                    { exact (RltE_lt (apply_fun d (x0,y0)) r Hdxy0). }
		                    claim HnegLt: minus_SNo r < minus_SNo (apply_fun d (x0,y0)).
		                    { exact (minus_SNo_Lt_contra (apply_fun d (x0,y0)) r HdxyS HrS HdxyLtS). }
	                    exact (RltI (add_SNo distB0 (minus_SNo r))
	                               (add_SNo distB0 (minus_SNo (apply_fun d (x0,y0))))
	                               (real_add_SNo distB0 HdistB0R (minus_SNo r) (real_minus_SNo r HrR))
	                               (real_add_SNo distB0 HdistB0R (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                               (add_SNo_Lt2 distB0 (minus_SNo r) (minus_SNo (apply_fun d (x0,y0)))
	                                           (real_SNo distB0 HdistB0R)
	                                           (real_SNo (minus_SNo r) (real_minus_SNo r HrR))
	                                           (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                           HnegLt)). }
	                  claim HltB: Rlt (add_SNo distB0 (minus_SNo r)) (metric_dist_to_set X d y0 B).
	                  { exact (Rlt_Rle_tra (add_SNo distB0 (minus_SNo r))
	                                      (add_SNo distB0 (minus_SNo (apply_fun d (x0,y0))))
	                                      (metric_dist_to_set X d y0 B)
	                                      HltB0 HlowerB). }
	                  claim HltMid: Rlt (add_SNo distA0 r) (metric_dist_to_set X d y0 B).
	                  { exact (Rlt_tra (add_SNo distA0 r) (add_SNo distB0 (minus_SNo r)) (metric_dist_to_set X d y0 B)
	                                   Hmargin HltB). }
		                  apply (SepI X (fun z0:set => Rlt (metric_dist_to_set X d z0 A) (metric_dist_to_set X d z0 B)) y0 Hy0X).
		                  exact (Rlt_tra (metric_dist_to_set X d y0 A) (add_SNo distA0 r) (metric_dist_to_set X d y0 B)
		                                 HltA HltMid). }
			              exact (SepI (Power X)
			                          (fun U0:set => forall x0 :e U0, exists b :e B0, x0 :e b /\ b c= U0)
			                          U
			                          HUPow
			                          HUprop).
			            }
		            { (** V is open in the metric topology **)
	              claim HAsubX: A c= X.
	              { exact (closed_in_subset X (metric_topology X d) A HAcl). }
	              claim HBsubX: B c= X.
	              { exact (closed_in_subset X (metric_topology X d) B HBcl). }
	              set B0 := famunion X (fun x0:set => {open_ball X d x0 r0|r0 :e R, Rlt 0 r0}).
		              claim HTdef: metric_topology X d = generated_topology X B0.
		              { reflexivity. }
		              rewrite HTdef.
		              prove V :e generated_topology X B0.
		              claim HVsubX0: V c= X.
		              { let x0. assume Hx0V: x0 :e V.
		                exact (SepE1 X (fun z0:set => Rlt (metric_dist_to_set X d z0 B)
		                                                 (metric_dist_to_set X d z0 A)) x0 Hx0V). }
		              claim HVPow: V :e Power X.
		              { exact (PowerI X V HVsubX0). }
		              claim HVprop: forall x0 :e V, exists b :e B0, x0 :e b /\ b c= V.
		              { let x0. assume Hx0V: x0 :e V.
		                prove exists b :e B0, x0 :e b /\ b c= V.
	              claim Hx0X: x0 :e X.
	              { exact (SepE1 X (fun z0:set => Rlt (metric_dist_to_set X d z0 B)
	                                                (metric_dist_to_set X d z0 A)) x0 Hx0V). }
	              claim Hx0lt: Rlt (metric_dist_to_set X d x0 B) (metric_dist_to_set X d x0 A).
	              { exact (SepE2 X (fun z0:set => Rlt (metric_dist_to_set X d z0 B)
	                                                (metric_dist_to_set X d z0 A)) x0 Hx0V). }
	              set distA0 := metric_dist_to_set X d x0 A.
	              set distB0 := metric_dist_to_set X d x0 B.
	              claim HdistA0R: distA0 :e R.
	              { exact (metric_dist_to_set_in_R X d x0 A Hd Hx0X HAsubX HAn). }
	              claim HdistB0R: distB0 :e R.
	              { exact (metric_dist_to_set_in_R X d x0 B Hd Hx0X HBsubX HBn). }
	              set gap := add_SNo distA0 (minus_SNo distB0).
	              claim HgapPos: Rlt 0 gap.
	              { exact (Rlt_0_diff_of_lt distB0 distA0 Hx0lt). }
	              claim HgapR: gap :e R.
	              { exact (RltE_right 0 gap HgapPos). }
	              claim HexN0: exists N0 :e omega, eps_ N0 < gap.
	              { exact (exists_eps_lt_pos gap HgapR HgapPos). }
	              apply HexN0.
	              let N0. assume HN0pair.
	              claim HN0omega: N0 :e omega.
	              { exact (andEL (N0 :e omega) (eps_ N0 < gap) HN0pair). }
	              claim HepsN0lt: eps_ N0 < gap.
	              { exact (andER (N0 :e omega) (eps_ N0 < gap) HN0pair). }
	              claim HepsN0R: eps_ N0 :e R.
	              { exact (SNoS_omega_real (eps_ N0) (SNo_eps_SNoS_omega N0 HN0omega)). }
	              claim HepsN0Rlt: Rlt (eps_ N0) gap.
	              { exact (RltI (eps_ N0) gap HepsN0R HgapR HepsN0lt). }
	              claim HN0nat: nat_p N0.
	              { exact (omega_nat_p N0 HN0omega). }
	              claim Hsucc0: ordsucc N0 :e omega.
	              { exact (omega_ordsucc N0 HN0omega). }
	              set r := eps_ (ordsucc N0).
	              claim HrR: r :e R.
	              { exact (SNoS_omega_real r (SNo_eps_SNoS_omega (ordsucc N0) Hsucc0)). }
	              claim HrposS: 0 < r.
	              { exact (SNo_eps_pos (ordsucc N0) Hsucc0). }
	              claim Hrpos: Rlt 0 r.
	              { exact (RltI 0 r real_0 HrR HrposS). }
	              claim HrrEq: add_SNo r r = eps_ N0.
	              { exact (eps_ordsucc_half_add N0 HN0nat). }
	              claim HrrR: add_SNo r r :e R.
	              { exact (real_add_SNo r HrR r HrR). }
	              claim HrrLtGap: Rlt (add_SNo r r) gap.
	              { rewrite HrrEq.
	                exact HepsN0Rlt. }
	              claim Hmargin: Rlt (add_SNo distB0 r) (add_SNo distA0 (minus_SNo r)).
	              { (** distB0 + r + r < distA0 implies distB0 + r < distA0 - r **)
	                claim HdistA0S: SNo distA0.
	                { exact (real_SNo distA0 HdistA0R). }
	                claim HdistB0S: SNo distB0.
	                { exact (real_SNo distB0 HdistB0R). }
	                claim HrS: SNo r.
	                { exact (real_SNo r HrR). }
	                claim HgapS: SNo gap.
	                { exact (real_SNo gap HgapR). }
	                claim HrrS: SNo (add_SNo r r).
	                { exact (real_SNo (add_SNo r r) HrrR). }
	                claim HrrLtGapS: add_SNo r r < gap.
	                { exact (RltE_lt (add_SNo r r) gap HrrLtGap). }
	                claim HlhsR: add_SNo distB0 (add_SNo r r) :e R.
	                { exact (real_add_SNo distB0 HdistB0R (add_SNo r r) HrrR). }
	                claim HtmpLt: add_SNo distB0 (add_SNo r r) < add_SNo distB0 gap.
	                { exact (add_SNo_Lt2 distB0 (add_SNo r r) gap HdistB0S HrrS HgapS HrrLtGapS). }
	                claim HtmpRlt: Rlt (add_SNo distB0 (add_SNo r r)) (add_SNo distB0 gap).
	                { exact (RltI (add_SNo distB0 (add_SNo r r)) (add_SNo distB0 gap)
	                            HlhsR
	                            (real_add_SNo distB0 HdistB0R gap HgapR)
	                            HtmpLt). }
	                claim HgapEq: add_SNo distB0 gap = distA0.
	                { claim HdistA0S2: SNo distA0.
	                  { exact (real_SNo distA0 HdistA0R). }
	                  claim HdistB0S2: SNo distB0.
	                  { exact (real_SNo distB0 HdistB0R). }
	                  claim HmB: SNo (minus_SNo distB0).
	                  { exact (real_SNo (minus_SNo distB0) (real_minus_SNo distB0 HdistB0R)). }
	                  rewrite (add_SNo_assoc distB0 distA0 (minus_SNo distB0) HdistB0S2 HdistA0S2 HmB).
	                  rewrite (add_SNo_com distB0 distA0 HdistB0S2 HdistA0S2).
	                  rewrite <- (add_SNo_assoc distA0 distB0 (minus_SNo distB0) HdistA0S2 HdistB0S2 HmB).
	                  rewrite (add_SNo_minus_SNo_rinv distB0 HdistB0S2).
	                  rewrite (add_SNo_0R distA0 HdistA0S2).
	                  reflexivity. }
		                claim HtmpRlt2: Rlt (add_SNo distB0 (add_SNo r r)) distA0.
		                { rewrite <- HgapEq. exact HtmpRlt. }
	                claim HminusR: minus_SNo r :e R.
	                { exact (real_minus_SNo r HrR). }
	                claim HminusS: SNo (minus_SNo r).
	                { exact (real_SNo (minus_SNo r) HminusR). }
	                claim HaddLe: Rlt (add_SNo (add_SNo distB0 (add_SNo r r)) (minus_SNo r))
	                                (add_SNo distA0 (minus_SNo r)).
	                { exact (RltI (add_SNo (add_SNo distB0 (add_SNo r r)) (minus_SNo r))
	                              (add_SNo distA0 (minus_SNo r))
	                              (real_add_SNo (add_SNo distB0 (add_SNo r r)) HlhsR (minus_SNo r) HminusR)
	                              (real_add_SNo distA0 HdistA0R (minus_SNo r) HminusR)
	                              (add_SNo_Lt1 (add_SNo distB0 (add_SNo r r)) (minus_SNo r) distA0
		                                           (real_SNo (add_SNo distB0 (add_SNo r r)) HlhsR) HminusS (real_SNo distA0 HdistA0R)
		                                           (RltE_lt (add_SNo distB0 (add_SNo r r)) distA0 HtmpRlt2))). }
	                claim HlhsEq: add_SNo (add_SNo distB0 (add_SNo r r)) (minus_SNo r) = add_SNo distB0 r.
	                { rewrite (add_SNo_assoc distB0 r r (real_SNo distB0 HdistB0R) (real_SNo r HrR) (real_SNo r HrR)).
	                  rewrite <- (add_SNo_assoc (add_SNo distB0 r) r (minus_SNo r)
	                           (real_SNo (add_SNo distB0 r) (real_add_SNo distB0 HdistB0R r HrR))
	                           (real_SNo r HrR) (real_SNo (minus_SNo r) (real_minus_SNo r HrR))).
	                  rewrite (add_SNo_minus_SNo_rinv r (real_SNo r HrR)).
	                  rewrite (add_SNo_0R (add_SNo distB0 r)
	                           (real_SNo (add_SNo distB0 r) (real_add_SNo distB0 HdistB0R r HrR))).
	                  reflexivity. }
		                claim HaddLe2: Rlt (add_SNo distB0 r) (add_SNo distA0 (minus_SNo r)).
		                { rewrite <- HlhsEq. exact HaddLe. }
		                exact HaddLe2. }
		              witness (open_ball X d x0 r).
		              prove open_ball X d x0 r :e B0 /\ (x0 :e open_ball X d x0 r /\ open_ball X d x0 r c= V).
		              apply andI.
		              - claim HballIn: open_ball X d x0 r :e {open_ball X d x0 r0|r0 :e R, Rlt 0 r0}.
		                { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x0 r0)
		                               r HrR Hrpos). }
		                exact (famunionI X (fun x1:set => {open_ball X d x1 r0|r0 :e R, Rlt 0 r0})
		                                 x0 (open_ball X d x0 r) Hx0X HballIn).
		              - apply andI.
		                + exact (center_in_open_ball X d x0 r Hd Hx0X Hrpos).
		                + let y0. assume Hy0Ball: y0 :e open_ball X d x0 r.
		                  prove y0 :e V.
	                  claim Hy0X: y0 :e X.
	                  { exact (SepE1 X (fun z0:set => Rlt (apply_fun d (x0,z0)) r) y0 Hy0Ball). }
	                  claim Hdxy0: Rlt (apply_fun d (x0,y0)) r.
	                  { exact (SepE2 X (fun z0:set => Rlt (apply_fun d (x0,z0)) r) y0 Hy0Ball). }
	                  claim Hdxy0R: apply_fun d (x0,y0) :e R.
	                  { exact (metric_on_function_on X d Hd (x0,y0) (tuple_2_setprod_by_pair_Sigma X X x0 y0 Hx0X Hy0X)). }
	                  claim HleB: Rle (metric_dist_to_set X d y0 B) (add_SNo distB0 (apply_fun d (x0,y0))).
	                  { exact (metric_dist_to_set_Lipschitz X d x0 y0 B Hd Hx0X Hy0X HBsubX HBn). }
	                  claim HltB1: Rlt (add_SNo distB0 (apply_fun d (x0,y0))) (add_SNo distB0 r).
	                  { claim HdistB0S: SNo distB0.
	                    { exact (real_SNo distB0 HdistB0R). }
	                    claim Hdxy0S: SNo (apply_fun d (x0,y0)).
	                    { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim HrS: SNo r.
	                    { exact (real_SNo r HrR). }
	                    exact (RltI (add_SNo distB0 (apply_fun d (x0,y0))) (add_SNo distB0 r)
	                               (real_add_SNo distB0 HdistB0R (apply_fun d (x0,y0)) Hdxy0R)
	                               (real_add_SNo distB0 HdistB0R r HrR)
	                               (add_SNo_Lt2 distB0 (apply_fun d (x0,y0)) r HdistB0S Hdxy0S HrS
	                                           (RltE_lt (apply_fun d (x0,y0)) r Hdxy0))). }
	                  claim HltB: Rlt (metric_dist_to_set X d y0 B) (add_SNo distB0 r).
	                  { exact (Rle_Rlt_tra_Euclid (metric_dist_to_set X d y0 B)
	                                              (add_SNo distB0 (apply_fun d (x0,y0)))
	                                              (add_SNo distB0 r)
	                                              HleB HltB1). }
	                  claim HleAswap: Rle distA0 (add_SNo (metric_dist_to_set X d y0 A) (apply_fun d (y0,x0))).
	                  { exact (metric_dist_to_set_Lipschitz X d y0 x0 A Hd Hy0X Hx0X HAsubX HAn). }
	                  claim Hsymd: apply_fun d (y0,x0) = apply_fun d (x0,y0).
	                  { exact (metric_on_symmetric X d y0 x0 Hd Hy0X Hx0X). }
	                  claim HleA: Rle distA0 (add_SNo (metric_dist_to_set X d y0 A) (apply_fun d (x0,y0))).
	                  { rewrite <- Hsymd.
	                    exact HleAswap. }
	                  claim HlowerA: Rle (add_SNo distA0 (minus_SNo (apply_fun d (x0,y0)))) (metric_dist_to_set X d y0 A).
	                  { claim HmdxyR: minus_SNo (apply_fun d (x0,y0)) :e R.
	                    { exact (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim Hshift: Rle (add_SNo (minus_SNo (apply_fun d (x0,y0))) distA0)
	                                    (add_SNo (minus_SNo (apply_fun d (x0,y0)))
	                                             (add_SNo (metric_dist_to_set X d y0 A) (apply_fun d (x0,y0)))).
	                    { exact (Rle_add_SNo_2 (minus_SNo (apply_fun d (x0,y0))) distA0
	                                           (add_SNo (metric_dist_to_set X d y0 A) (apply_fun d (x0,y0)))
	                                           HmdxyR HdistA0R
	                                           (real_add_SNo (metric_dist_to_set X d y0 A)
	                                                         (metric_dist_to_set_in_R X d y0 A Hd Hy0X HAsubX HAn)
	                                                         (apply_fun d (x0,y0)) Hdxy0R)
	                                           HleA). }
	                    claim HlhsEq: add_SNo (minus_SNo (apply_fun d (x0,y0))) distA0 =
	                                  add_SNo distA0 (minus_SNo (apply_fun d (x0,y0))).
	                    { exact (add_SNo_com (minus_SNo (apply_fun d (x0,y0))) distA0
	                                         (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                         (real_SNo distA0 HdistA0R)). }
	                    claim HrhsEq: add_SNo (minus_SNo (apply_fun d (x0,y0)))
	                                     (add_SNo (metric_dist_to_set X d y0 A) (apply_fun d (x0,y0))) =
	                                   metric_dist_to_set X d y0 A.
	                    { claim HdxyS: SNo (apply_fun d (x0,y0)).
	                      { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                      claim HA0R: metric_dist_to_set X d y0 A :e R.
	                      { exact (metric_dist_to_set_in_R X d y0 A Hd Hy0X HAsubX HAn). }
	                      claim HA0S: SNo (metric_dist_to_set X d y0 A).
	                      { exact (real_SNo (metric_dist_to_set X d y0 A) HA0R). }
	                      rewrite (add_SNo_assoc (minus_SNo (apply_fun d (x0,y0)))
	                                             (metric_dist_to_set X d y0 A)
	                                             (apply_fun d (x0,y0))
	                                             (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                             HA0S HdxyS).
	                      rewrite (add_SNo_com (minus_SNo (apply_fun d (x0,y0))) (metric_dist_to_set X d y0 A)
	                                           (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                           HA0S).
	                      rewrite <- (add_SNo_assoc (metric_dist_to_set X d y0 A)
	                                                (minus_SNo (apply_fun d (x0,y0)))
	                                                (apply_fun d (x0,y0))
	                                                HA0S (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                                HdxyS).
	                      rewrite (add_SNo_minus_SNo_linv (apply_fun d (x0,y0)) HdxyS).
	                      rewrite (add_SNo_0R (metric_dist_to_set X d y0 A) HA0S).
	                      reflexivity. }
			                    claim Hshift2: Rle (add_SNo distA0 (minus_SNo (apply_fun d (x0,y0))))
			                                     (metric_dist_to_set X d y0 A).
			                    { rewrite <- HlhsEq. rewrite <- HrhsEq. exact Hshift. }
			                    exact Hshift2. }
		                  claim HltA0: Rlt (add_SNo distA0 (minus_SNo r))
		                                  (add_SNo distA0 (minus_SNo (apply_fun d (x0,y0)))).
	                  { claim HrS: SNo r.
	                    { exact (real_SNo r HrR). }
	                    claim HdxyS: SNo (apply_fun d (x0,y0)).
	                    { exact (real_SNo (apply_fun d (x0,y0)) Hdxy0R). }
	                    claim HdxyLtS: apply_fun d (x0,y0) < r.
	                    { exact (RltE_lt (apply_fun d (x0,y0)) r Hdxy0). }
	                    claim HnegLt: minus_SNo r < minus_SNo (apply_fun d (x0,y0)).
		                    { exact (minus_SNo_Lt_contra (apply_fun d (x0,y0)) r HdxyS HrS HdxyLtS). }
	                    exact (RltI (add_SNo distA0 (minus_SNo r))
	                               (add_SNo distA0 (minus_SNo (apply_fun d (x0,y0))))
	                               (real_add_SNo distA0 HdistA0R (minus_SNo r) (real_minus_SNo r HrR))
	                               (real_add_SNo distA0 HdistA0R (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                               (add_SNo_Lt2 distA0 (minus_SNo r) (minus_SNo (apply_fun d (x0,y0)))
	                                           (real_SNo distA0 HdistA0R)
	                                           (real_SNo (minus_SNo r) (real_minus_SNo r HrR))
	                                           (real_SNo (minus_SNo (apply_fun d (x0,y0))) (real_minus_SNo (apply_fun d (x0,y0)) Hdxy0R))
	                                           HnegLt)). }
	                  claim HltA: Rlt (add_SNo distA0 (minus_SNo r)) (metric_dist_to_set X d y0 A).
	                  { exact (Rlt_Rle_tra (add_SNo distA0 (minus_SNo r))
	                                      (add_SNo distA0 (minus_SNo (apply_fun d (x0,y0))))
	                                      (metric_dist_to_set X d y0 A)
	                                      HltA0 HlowerA). }
	                  claim HltMid: Rlt (add_SNo distB0 r) (metric_dist_to_set X d y0 A).
	                  { exact (Rlt_tra (add_SNo distB0 r) (add_SNo distA0 (minus_SNo r)) (metric_dist_to_set X d y0 A)
	                                   Hmargin HltA). }
		                  apply (SepI X (fun z0:set => Rlt (metric_dist_to_set X d z0 B) (metric_dist_to_set X d z0 A)) y0 Hy0X).
			                  exact (Rlt_tra (metric_dist_to_set X d y0 B) (add_SNo distB0 r) (metric_dist_to_set X d y0 A)
			                                 HltB HltMid). }
			              exact (SepI (Power X)
			                          (fun V0:set => forall x0 :e V0, exists b :e B0, x0 :e b /\ b c= V0)
			                          V
			                          HVPow
			                          HVprop).
			            }
		          * (** A c= U **)
	            let a. assume HaA: a :e A.
	            prove a :e U.
	            claim HAsubX: A c= X.
            { exact (closed_in_subset X (metric_topology X d) A HAcl). }
            claim HBsubX: B c= X.
            { exact (closed_in_subset X (metric_topology X d) B HBcl). }
            claim HaX: a :e X.
            { exact (HAsubX a HaA). }
            apply (SepI X (fun x0:set => Rlt (metric_dist_to_set X d x0 A) (metric_dist_to_set X d x0 B)) a HaX).
            (** dist(a,A)=0, dist(a,B)>0 because B is closed and a notin B **)
            claim HAne: A <> Empty.
            { exact (elem_implies_nonempty A a HaA). }
            claim HBne: B <> Empty.
            { exact HBn. }
            claim Ha_notB: a /:e B.
            { assume HaB: a :e B.
              claim HaAB: a :e A :/\: B.
              { exact (binintersectI A B a HaA HaB). }
              claim HaE: a :e Empty.
              { rewrite <- Hdisj. exact HaAB. }
              exact (EmptyE a HaE False). }
            claim HdistA0: metric_dist_to_set X d a A = 0.
            { exact (metric_dist_to_set_eq_0_if_mem X d a A Hd HaX HAsubX HaA). }
            claim HdistBpos: Rlt 0 (metric_dist_to_set X d a B).
            { exact (metric_dist_to_closed_set_pos_if_not_mem X d B a Hd HBcl HaX Ha_notB HBne). }
            rewrite HdistA0.
            exact HdistBpos.
        + (** B c= V **)
          let b. assume HbB: b :e B.
          prove b :e V.
          claim HAsubX: A c= X.
          { exact (closed_in_subset X (metric_topology X d) A HAcl). }
          claim HBsubX: B c= X.
          { exact (closed_in_subset X (metric_topology X d) B HBcl). }
          claim HbX: b :e X.
          { exact (HBsubX b HbB). }
          apply (SepI X (fun x0:set => Rlt (metric_dist_to_set X d x0 B) (metric_dist_to_set X d x0 A)) b HbX).
          claim HAne: A <> Empty.
          { exact HAn. }
          claim HBne: B <> Empty.
          { exact (elem_implies_nonempty B b HbB). }
          claim Hb_notA: b /:e A.
          { assume HbA: b :e A.
            claim HbAB: b :e A :/\: B.
            { exact (binintersectI A B b HbA HbB). }
            claim HbE: b :e Empty.
            { rewrite <- Hdisj. exact HbAB. }
            exact (EmptyE b HbE False). }
          claim HdistB0: metric_dist_to_set X d b B = 0.
          { exact (metric_dist_to_set_eq_0_if_mem X d b B Hd HbX HBsubX HbB). }
          claim HdistApos: Rlt 0 (metric_dist_to_set X d b A).
          { exact (metric_dist_to_closed_set_pos_if_not_mem X d A b Hd HAcl HbX Hb_notA HAne). }
          rewrite HdistB0.
          exact HdistApos.
      - apply set_ext.
        + let x. assume Hx: x :e U :/\: V.
          prove x :e Empty.
          claim HxU: x :e U.
          { exact (binintersectE1 U V x Hx). }
          claim HxV: x :e V.
          { exact (binintersectE2 U V x Hx). }
          claim HltAB: Rlt (metric_dist_to_set X d x A) (metric_dist_to_set X d x B).
          { exact (SepE2 X (fun x0:set => Rlt (metric_dist_to_set X d x0 A) (metric_dist_to_set X d x0 B)) x HxU). }
          claim HltBA: Rlt (metric_dist_to_set X d x B) (metric_dist_to_set X d x A).
          { exact (SepE2 X (fun x0:set => Rlt (metric_dist_to_set X d x0 B) (metric_dist_to_set X d x0 A)) x HxV). }
          apply FalseE.
          exact ((not_Rlt_sym (metric_dist_to_set X d x A) (metric_dist_to_set X d x B) HltAB) HltBA).
        + let x. assume Hx: x :e Empty.
          prove x :e U :/\: V.
          exact (EmptyE x Hx (x :e U :/\: V)).
Qed.

(** from §32 Theorem 32.3: compact Hausdorff spaces are normal **) 
(** LATEX VERSION: Compact Hausdorff ⇒ normal (Theorem 32.3). **)
Theorem compact_Hausdorff_normal : forall X Tx:set,
  compact_space X Tx -> Hausdorff_space X Tx -> normal_space X Tx.
let X Tx.
assume Hcomp: compact_space X Tx.
assume HH: Hausdorff_space X Tx.
prove normal_space X Tx.
claim HTx: topology_on X Tx.
{ exact (compact_space_topology X Tx Hcomp). }
claim HT1: one_point_sets_closed X Tx.
{ prove topology_on X Tx /\ forall x:set, x :e X -> closed_in X Tx {x}.
  apply andI.
  - exact HTx.
  - let x. assume HxX: x :e X.
    exact (Hausdorff_singletons_closed X Tx x HH HxX). }
prove one_point_sets_closed X Tx /\
  forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
apply andI.
- exact HT1.
- let A B.
  assume HAcl: closed_in X Tx A.
  assume HBcl: closed_in X Tx B.
  assume Hdisj: A :/\: B = Empty.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HAcl). }
  claim HBsubX: B c= X.
  { exact (closed_in_subset X Tx B HBcl). }
  claim HcompA: compact_space A (subspace_topology X Tx A).
  { exact (closed_subspace_compact X Tx A Hcomp HAcl). }
  claim HcompB: compact_space B (subspace_topology X Tx B).
  { exact (closed_subspace_compact X Tx B Hcomp HBcl). }

  (** For each a∈A, separate a from compact B. **)
  set Uof := fun a:set =>
    Eps_i (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty).
  set Vof := fun a:set =>
    Eps_i (fun V:set => Uof a :e Tx /\ V :e Tx /\ a :e Uof a /\ B c= V /\ Uof a :/\: V = Empty).

  claim UVprop: forall a:set, a :e A ->
    Uof a :e Tx /\ (Vof a :e Tx /\ (a :e Uof a /\ (B c= Vof a /\ Uof a :/\: Vof a = Empty))).
  { let a. assume HaA: a :e A.
    claim HaX: a :e X.
    { exact (HAsubX a HaA). }
    claim HanotB: a /:e B.
    { assume HaB: a :e B.
      claim HaAB: a :e A :/\: B.
      { exact (binintersectI A B a HaA HaB). }
      claim HaE: a :e Empty.
      { rewrite <- Hdisj. exact HaAB. }
      apply FalseE.
      exact (EmptyE a HaE False). }
    claim HexUV: exists U V:set, U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty.
    { exact (Hausdorff_separate_point_compact_set X Tx B a HH HBsubX HcompB HaX HanotB). }
    claim HUof: exists V:set, Uof a :e Tx /\ V :e Tx /\ a :e Uof a /\ B c= V /\ Uof a :/\: V = Empty.
    { exact (Eps_i_ex (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty) HexUV). }
    claim HVof: Uof a :e Tx /\ Vof a :e Tx /\ a :e Uof a /\ B c= Vof a /\ Uof a :/\: Vof a = Empty.
    { exact (Eps_i_ex (fun V:set => Uof a :e Tx /\ V :e Tx /\ a :e Uof a /\ B c= V /\ Uof a :/\: V = Empty) HUof). }
    (** Repackage the left-associated 5-way conjunction into a right-associated form. **)
    claim H1234: ((Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a) /\ B c= Vof a.
    { exact (andEL (((Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a) /\ B c= Vof a)
                   (Uof a :/\: Vof a = Empty)
                   HVof). }
    claim H5: Uof a :/\: Vof a = Empty.
    { exact (andER (((Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a) /\ B c= Vof a)
                   (Uof a :/\: Vof a = Empty)
                   HVof). }
    claim H123: (Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a.
    { exact (andEL ((Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a)
                   (B c= Vof a)
                   H1234). }
    claim H4: B c= Vof a.
    { exact (andER ((Uof a :e Tx /\ Vof a :e Tx) /\ a :e Uof a)
                   (B c= Vof a)
                   H1234). }
    claim H12: Uof a :e Tx /\ Vof a :e Tx.
    { exact (andEL (Uof a :e Tx /\ Vof a :e Tx)
                   (a :e Uof a)
                   H123). }
    claim H3: a :e Uof a.
    { exact (andER (Uof a :e Tx /\ Vof a :e Tx)
                   (a :e Uof a)
                   H123). }
    claim HUofTx: Uof a :e Tx.
    { exact (andEL (Uof a :e Tx) (Vof a :e Tx) H12). }
    claim HVofTx: Vof a :e Tx.
    { exact (andER (Uof a :e Tx) (Vof a :e Tx) H12). }
    apply andI.
    - exact HUofTx.
	    - apply andI.
	      + exact HVofTx.
	      + apply andI.
	        * exact H3.
	        * apply andI.
	          - exact H4.
	          - exact H5. }

  (** Cover A by opens Uof a. **)
  set Fam := {Uof a|a :e A}.
  claim HFamSub: Fam c= Tx.
  { let U. assume HU: U :e Fam.
    apply (ReplE_impred A (fun a:set => Uof a) U HU (U :e Tx)).
    let a. assume HaA: a :e A.
    assume HUeq: U = Uof a.
    claim HUofTx: Uof a :e Tx.
    { exact (andEL (Uof a :e Tx)
                   (Vof a :e Tx /\ (a :e Uof a /\ (B c= Vof a /\ Uof a :/\: Vof a = Empty)))
                   (UVprop a HaA)). }
    rewrite HUeq.
    exact HUofTx. }
  claim HAcov: A c= Union Fam.
  { let a. assume HaA: a :e A.
    prove a :e Union Fam.
    claim HaU: a :e Uof a.
    { exact (andEL (a :e Uof a)
                   (B c= Vof a /\ Uof a :/\: Vof a = Empty)
                   (andER (Vof a :e Tx)
                          (a :e Uof a /\ (B c= Vof a /\ Uof a :/\: Vof a = Empty))
                          (andER (Uof a :e Tx)
                                 (Vof a :e Tx /\ (a :e Uof a /\ (B c= Vof a /\ Uof a :/\: Vof a = Empty)))
                                 (UVprop a HaA)))). }
    claim HUinFam: Uof a :e Fam.
    { exact (ReplI A (fun a0:set => Uof a0) a HaA). }
    exact (UnionI Fam a (Uof a) HaU HUinFam). }

  (** Use compactness of A to extract a finite subcover from Fam. **)
  claim HcoverProp: forall Fam0:set, (Fam0 c= Tx /\ A c= Union Fam0) -> has_finite_subcover A Tx Fam0.
  { claim Hequiv:
      (compact_space A (subspace_topology X Tx A) <->
        forall Fam0:set, (Fam0 c= Tx /\ A c= Union Fam0) -> has_finite_subcover A Tx Fam0).
    { exact (compact_subspace_via_ambient_covers X Tx A HTx HAsubX). }
    exact (iffEL (compact_space A (subspace_topology X Tx A))
                 (forall Fam0:set, (Fam0 c= Tx /\ A c= Union Fam0) -> has_finite_subcover A Tx Fam0)
                 Hequiv HcompA). }

  claim Hfin: has_finite_subcover A Tx Fam.
  { exact (HcoverProp Fam (andI (Fam c= Tx) (A c= Union Fam) HFamSub HAcov)). }
  apply Hfin.
  let G. assume HG: G c= Fam /\ finite G /\ A c= Union G.
  claim HGleft: G c= Fam /\ finite G.
  { exact (andEL (G c= Fam /\ finite G) (A c= Union G) HG). }
  claim HGsubFam: G c= Fam.
  { exact (andEL (G c= Fam) (finite G) HGleft). }
  claim HGfin: finite G.
  { exact (andER (G c= Fam) (finite G) HGleft). }
  claim HAcovG: A c= Union G.
  { exact (andER (G c= Fam /\ finite G) (A c= Union G) HG). }
  claim HGsubTx: G c= Tx.
  { let U. assume HU: U :e G.
    prove U :e Tx.
    claim HUfam: U :e Fam.
    { exact (HGsubFam U HU). }
    exact (HFamSub U HUfam). }

  (** Define U = union of the finite subcover G. **)
  set U := Union G.
  claim HUtx: U :e Tx.
  { exact (topology_union_closed X Tx G HTx HGsubTx). }

  (** Pick an index a(U) for each U∈G with U = Uof a(U). **)
  set Wof := fun U0:set => Eps_i (fun a:set => a :e A /\ U0 = Uof a).
  claim Wof_spec: forall U0:set, U0 :e G -> Wof U0 :e A /\ U0 = Uof (Wof U0).
  { let U0. assume HU0G: U0 :e G.
    claim HU0Fam: U0 :e Fam.
    { exact (HGsubFam U0 HU0G). }
    claim Hexa: exists a:set, a :e A /\ U0 = Uof a.
    { apply (ReplE_impred A (fun a0:set => Uof a0) U0 HU0Fam (exists a:set, a :e A /\ U0 = Uof a)).
      let a. assume HaA: a :e A.
      assume HU0eq: U0 = Uof a.
      witness a.
      apply andI.
      - exact HaA.
      - exact HU0eq. }
    apply Hexa.
    let a. assume HaPair: a :e A /\ U0 = Uof a.
    exact (Eps_i_ax (fun a0:set => a0 :e A /\ U0 = Uof a0) a HaPair). }

  (** Define the corresponding family of V's and take their finite intersection. **)
  set GV := {Vof (Wof U0)|U0 :e G}.
  claim HGVfin: finite GV.
  { exact (Repl_finite (fun U0:set => Vof (Wof U0)) G HGfin). }
  claim HGVsubTx: GV c= Tx.
  { let V. assume HV: V :e GV.
    apply (ReplE_impred G (fun U0:set => Vof (Wof U0)) V HV (V :e Tx)).
    let U0. assume HU0G: U0 :e G.
    assume HVe: V = Vof (Wof U0).
    claim HWofA: Wof U0 :e A.
    { exact (andEL (Wof U0 :e A) (U0 = Uof (Wof U0)) (Wof_spec U0 HU0G)). }
    claim HVofTx: Vof (Wof U0) :e Tx.
    { exact (andEL (Vof (Wof U0) :e Tx)
                   (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty))
                   (andER (Uof (Wof U0) :e Tx)
                          (Vof (Wof U0) :e Tx /\ (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)))
                          (UVprop (Wof U0) HWofA))). }
    rewrite HVe.
    exact HVofTx. }

  set V := intersection_of_family X GV.
  claim HVtx: V :e Tx.
  { claim HGVpow: GV :e Power Tx.
    { apply PowerI.
      exact HGVsubTx. }
    exact (finite_intersection_in_topology X Tx GV HTx HGVpow HGVfin). }

  (** B is contained in V since each Vof a contains B. **)
  claim HBsubV: B c= V.
  { let b. assume HbB: b :e B.
    prove b :e V.
    claim HbPred: forall U1:set, U1 :e GV -> b :e U1.
    { let W. assume HW: W :e GV.
      prove b :e W.
      apply (ReplE_impred G (fun U0:set => Vof (Wof U0)) W HW (b :e W)).
      let U0. assume HU0G: U0 :e G.
      assume HWeq: W = Vof (Wof U0).
      claim HWofA: Wof U0 :e A.
      { exact (andEL (Wof U0 :e A) (U0 = Uof (Wof U0)) (Wof_spec U0 HU0G)). }
      claim HUV1:
        Vof (Wof U0) :e Tx /\
        (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)).
      { exact (andER (Uof (Wof U0) :e Tx)
                     (Vof (Wof U0) :e Tx /\ (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)))
                     (UVprop (Wof U0) HWofA)). }
      claim HUV2:
        Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty).
      { exact (andER (Vof (Wof U0) :e Tx)
                     (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty))
                     HUV1). }
      claim HUV3: B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty.
      { exact (andER (Wof U0 :e Uof (Wof U0))
                     (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)
                     HUV2). }
      claim HBsubVof: B c= Vof (Wof U0).
      { exact (andEL (B c= Vof (Wof U0))
                     (Uof (Wof U0) :/\: Vof (Wof U0) = Empty)
                     HUV3). }
      rewrite HWeq.
      exact (HBsubVof b HbB). }
    exact (SepI X (fun x:set => forall U1:set, U1 :e GV -> x :e U1) b (HBsubX b HbB) HbPred). }

  (** U and V are disjoint. **)
  claim HUVdisj: U :/\: V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e U :/\: V.
    prove z :e Empty.
    claim HzU: z :e U.
    { exact (binintersectE1 U V z Hz). }
    claim HzV: z :e V.
    { exact (binintersectE2 U V z Hz). }
    apply (UnionE_impred G z HzU (z :e Empty)).
    let U0. assume HzU0: z :e U0.
    assume HU0G: U0 :e G.
    claim HWofA: Wof U0 :e A.
    { exact (andEL (Wof U0 :e A) (U0 = Uof (Wof U0)) (Wof_spec U0 HU0G)). }
    claim HU0eq: U0 = Uof (Wof U0).
    { exact (andER (Wof U0 :e A) (U0 = Uof (Wof U0)) (Wof_spec U0 HU0G)). }
    claim HVinGV: Vof (Wof U0) :e GV.
    { exact (ReplI G (fun U1:set => Vof (Wof U1)) U0 HU0G). }
    claim HzVof: z :e Vof (Wof U0).
    { exact (SepE2 X (fun x:set => forall U1:set, U1 :e GV -> x :e U1) z HzV (Vof (Wof U0)) HVinGV). }
    claim HzUof: z :e Uof (Wof U0).
    { rewrite <- HU0eq. exact HzU0. }
    claim Hdisj0: Uof (Wof U0) :/\: Vof (Wof U0) = Empty.
    { claim HUV1:
        Vof (Wof U0) :e Tx /\
        (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)).
      { exact (andER (Uof (Wof U0) :e Tx)
                     (Vof (Wof U0) :e Tx /\ (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)))
                     (UVprop (Wof U0) HWofA)). }
      claim HUV2:
        Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty).
      { exact (andER (Vof (Wof U0) :e Tx)
                     (Wof U0 :e Uof (Wof U0) /\ (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty))
                     HUV1). }
      claim HUV3: B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty.
      { exact (andER (Wof U0 :e Uof (Wof U0))
                     (B c= Vof (Wof U0) /\ Uof (Wof U0) :/\: Vof (Wof U0) = Empty)
                     HUV2). }
      exact (andER (B c= Vof (Wof U0))
                   (Uof (Wof U0) :/\: Vof (Wof U0) = Empty)
                   HUV3). }
    claim HzUV0: z :e Uof (Wof U0) :/\: Vof (Wof U0).
    { exact (binintersectI (Uof (Wof U0)) (Vof (Wof U0)) z HzUof HzVof). }
    rewrite <- Hdisj0.
    exact HzUV0. }

  (** Build the final neighborhoods. **)
  witness U.
  witness V.
  apply andI.
  - apply andI.
    - apply andI.
      - apply andI.
        - exact HUtx.
        - exact HVtx.
      - exact HAcovG.
    - exact HBsubV.
  - exact HUVdisj.
Qed.

(** from §32 Example 1: uncountable product of R not normal **) 
(** LATEX VERSION: An uncountable product of ℝ with product topology need not be normal. **)
Theorem uncountable_product_R_not_normal : forall J:set,
  uncountable_set J -> ~ normal_space (product_space J (const_space_family J R R_standard_topology)) (product_topology_full J (const_space_family J R R_standard_topology)).
let J.
assume HJ: uncountable_set J.
prove ~ normal_space (product_space J (const_space_family J R R_standard_topology)) (product_topology_full J (const_space_family J R R_standard_topology)).
admit. (** FAIL **)
Qed.

(** from §32 Example 2: SOmega x SbarOmega not normal **)
(** LATEX VERSION: Product S_Ω×S̄_Ω gives a non-normal example. **)
(** FIXED: Use abstract placeholders matching topology.tex: S_Omega is an uncountable well-ordered set and Sbar_Omega is S_Omega with one new point adjoined. **)
(** NOTE: We model the point Omega by adjoining S_Omega itself; by In_irref we have S_Omega /:e S_Omega, so this really adds a new element. **)
Theorem exists_uncountable_well_ordered_set : exists X:set, well_ordered_set X /\ uncountable_set X.
admit. (** FAIL **)
Qed.

(** helper: extract an uncountable ordinal from an uncountable well-orderable set **)
(** LATEX VERSION: Any uncountable well-ordered set has order type given by an uncountable ordinal. **)
Theorem exists_uncountable_ordinal : exists alpha:set, ordinal alpha /\ uncountable_set alpha.
prove exists alpha:set, ordinal alpha /\ uncountable_set alpha.
claim Hex: exists X:set, well_ordered_set X /\ uncountable_set X.
{ exact exists_uncountable_well_ordered_set. }
apply Hex.
let X. assume HX: well_ordered_set X /\ uncountable_set X.
claim Hwo: well_ordered_set X.
{ exact (andEL (well_ordered_set X) (uncountable_set X) HX). }
claim HuncX: uncountable_set X.
{ exact (andER (well_ordered_set X) (uncountable_set X) HX). }
witness X.
apply andI.
- exact (well_ordered_set_is_ordinal X Hwo).
- exact HuncX.
Qed.

(** Choose S_Omega as an uncountable ordinal (hence well-ordered by membership). **)
Definition S_Omega : set := Eps_i (fun X:set => well_ordered_set X /\ uncountable_set X).

Theorem S_Omega_well_ordered_uncountable : well_ordered_set S_Omega /\ uncountable_set S_Omega.
prove well_ordered_set S_Omega /\ uncountable_set S_Omega.
claim Hex: exists X:set, well_ordered_set X /\ uncountable_set X.
{ exact exists_uncountable_well_ordered_set. }
exact (Eps_i_ex (fun X:set => well_ordered_set X /\ uncountable_set X) Hex).
Qed.

Theorem S_Omega_ordinal_uncountable : ordinal S_Omega /\ uncountable_set S_Omega.
prove ordinal S_Omega /\ uncountable_set S_Omega.
apply andI.
- exact (well_ordered_set_is_ordinal S_Omega (andEL (well_ordered_set S_Omega) (uncountable_set S_Omega) S_Omega_well_ordered_uncountable)).
- exact (andER (well_ordered_set S_Omega) (uncountable_set S_Omega) S_Omega_well_ordered_uncountable).
Qed.
Definition Sbar_Omega : set := SetAdjoin S_Omega S_Omega.
(** helper: Sbar_Omega is the ordinal successor of S_Omega **)
(** LATEX VERSION: \\bar S_\\Omega is obtained by adjoining one new point above all points of S_\\Omega; for an ordinal, this is the successor ordinal. **)
Theorem Sbar_Omega_eq_ordsucc : Sbar_Omega = ordsucc S_Omega.
prove Sbar_Omega = ordsucc S_Omega.
apply set_ext.
- prove Sbar_Omega c= ordsucc S_Omega.
  let y.
  assume Hy : y :e Sbar_Omega.
  claim Hy' : y :e S_Omega :\/: {S_Omega}.
  { exact Hy. }
  apply (binunionE S_Omega {S_Omega} y Hy').
  + assume Hyin : y :e S_Omega.
    exact (ordsuccI1 S_Omega y Hyin).
  + assume Hyin : y :e {S_Omega}.
    claim Heq : y = S_Omega.
    { exact (SingE S_Omega y Hyin). }
    rewrite Heq.
    exact (ordsuccI2 S_Omega).
- prove ordsucc S_Omega c= Sbar_Omega.
  let y.
  assume Hy : y :e ordsucc S_Omega.
  apply (ordsuccE S_Omega y Hy).
  + assume Hyin : y :e S_Omega.
    claim Hy' : y :e S_Omega :\/: {S_Omega}.
    { exact (binunionI1 S_Omega {S_Omega} y Hyin). }
    exact Hy'.
  + assume Heq : y = S_Omega.
    claim Hy' : y :e S_Omega :\/: {S_Omega}.
    { apply (binunionI2 S_Omega {S_Omega} y).
      rewrite Heq.
      exact (SingI S_Omega). }
    exact Hy'.
Qed.

(** helper: Sbar_Omega is an ordinal (hence a simply ordered set under membership) **)
(** LATEX VERSION: If S_\\Omega is an ordinal, then its successor is also an ordinal. **)
Theorem Sbar_Omega_ordinal : ordinal Sbar_Omega.
prove ordinal Sbar_Omega.
claim Hord: ordinal S_Omega.
{ exact (andEL (ordinal S_Omega) (uncountable_set S_Omega) S_Omega_ordinal_uncountable). }
rewrite Sbar_Omega_eq_ordsucc.
exact (ordinal_ordsucc S_Omega Hord).
Qed.

(** helper: Sbar_Omega is within the simply_ordered_set scope **)
(** LATEX VERSION: Ordinals are simply ordered by membership. **)
Theorem simply_ordered_set_Sbar_Omega : simply_ordered_set Sbar_Omega.
prove simply_ordered_set Sbar_Omega.
prove Sbar_Omega = R
  \/ Sbar_Omega = rational_numbers
  \/ Sbar_Omega = omega
  \/ Sbar_Omega = omega :\: {0}
  \/ Sbar_Omega = setprod 2 omega
  \/ Sbar_Omega = setprod R R
  \/ ordinal Sbar_Omega.
apply orIR.
exact Sbar_Omega_ordinal.
Qed.
(** helper: S_Omega is a subset of Sbar_Omega **)
Theorem S_Omega_Subq_Sbar_Omega : S_Omega c= Sbar_Omega.
prove S_Omega c= Sbar_Omega.
exact (binunion_Subq_1 S_Omega {S_Omega}).
Qed.

(** helper: the adjoined point Omega (represented by S_Omega) is in Sbar_Omega **)
Theorem S_Omega_in_Sbar_Omega : S_Omega :e Sbar_Omega.
prove S_Omega :e Sbar_Omega.
apply (binunionI2 S_Omega {S_Omega} S_Omega).
exact (SingI S_Omega).
Qed.
(** LATEX VERSION: Both spaces are given the order topology. **)
Definition SOmega_topology : set := order_topology S_Omega.
Definition SbarOmega_topology : set := order_topology Sbar_Omega.

Theorem SOmega_SbarOmega_not_normal :
  normal_space S_Omega SOmega_topology /\ normal_space Sbar_Omega SbarOmega_topology /\
  ~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology).
prove normal_space S_Omega SOmega_topology /\ normal_space Sbar_Omega SbarOmega_topology /\
  ~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology).
admit. (** FAIL **)
Qed.

(** from §33 Theorem 33.1 (Urysohn lemma): continuous function separating closed sets in normal space **)
(** LATEX VERSION: Urysohn lemma: In a normal space, disjoint closed sets can be separated by continuous f: X→[a,b]. **)
(** FIXED: Urysohn_lemma includes separation conditions f|A = a and f|B = b, not merely existence of some continuous f. **) 
Definition closed_interval : set -> set -> set := fun a b =>
  {x :e R | ~(Rlt x a) /\ ~(Rlt b x)}.

(** Helper: topology on [a,b] is the subspace topology inherited from the standard topology on R **)
(** LATEX VERSION: The interval [a,b] carries the subspace topology inherited from the standard topology on R. **)
Definition closed_interval_topology : set -> set -> set := fun a b =>
  subspace_topology R R_standard_topology (closed_interval a b).

(** helper: closed_interval is a subset of R **)
Theorem closed_interval_sub_R : forall a b:set, closed_interval a b c= R.
let a b.
let x. assume Hx: x :e closed_interval a b.
prove x :e R.
claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ reflexivity. }
claim Hx': x :e {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ rewrite <- HCI_def. exact Hx. }
exact (SepE1 R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x Hx').
Qed.

(** helper: membership in closed_interval gives the endpoint inequalities **)
Theorem closed_interval_bounds : forall a b x:set,
  a :e R -> b :e R ->
  x :e closed_interval a b ->
  Rle a x /\ Rle x b.
let a b x.
assume HaR: a :e R.
assume HbR: b :e R.
assume Hx: x :e closed_interval a b.
prove Rle a x /\ Rle x b.
claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ reflexivity. }
claim Hx': x :e {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ rewrite <- HCI_def. exact Hx. }
claim HxR: x :e R.
{ exact (SepE1 R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x Hx'). }
claim Hconj: ~(Rlt x a) /\ ~(Rlt b x).
{ exact (SepE2 R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x Hx'). }
claim Hnlt_xa: ~(Rlt x a).
{ exact (andEL (~(Rlt x a)) (~(Rlt b x)) Hconj). }
claim Hnlt_bx: ~(Rlt b x).
{ exact (andER (~(Rlt x a)) (~(Rlt b x)) Hconj). }
apply andI.
- exact (RleI a x HaR HxR Hnlt_xa).
- exact (RleI x b HxR HbR Hnlt_bx).
Qed.

(** helper: build membership in closed_interval from endpoint inequalities **)
Theorem closed_intervalI_of_Rle : forall a b x:set,
  a :e R -> b :e R -> x :e R ->
  Rle a x -> Rle x b ->
  x :e closed_interval a b.
let a b x.
assume HaR: a :e R.
assume HbR: b :e R.
assume HxR: x :e R.
assume Hax: Rle a x.
assume Hxb: Rle x b.
prove x :e closed_interval a b.
claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ reflexivity. }
rewrite HCI_def.
apply (SepI R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x HxR).
apply andI.
- exact (RleE_nlt a x Hax).
- exact (RleE_nlt x b Hxb).
Qed.

(** helper: if x is not in [a,b] then x<a or b<x **)
Theorem closed_interval_not_mem_cases : forall a b x:set,
  a :e R -> b :e R -> x :e R ->
  x /:e closed_interval a b ->
  Rlt x a \/ Rlt b x.
let a b x.
assume HaR: a :e R.
assume HbR: b :e R.
assume HxR: x :e R.
assume Hnot: x /:e closed_interval a b.
prove Rlt x a \/ Rlt b x.
apply (xm (Rlt x a)).
- assume Hltxa: Rlt x a.
  apply orIL.
  exact Hltxa.
- assume Hnltxa: ~(Rlt x a).
  apply (xm (Rlt b x)).
  + assume Hltbx: Rlt b x.
    apply orIR.
    exact Hltbx.
  + assume Hnltbx: ~(Rlt b x).
    apply FalseE.
    claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
    { reflexivity. }
    claim Hxin: x :e closed_interval a b.
    { rewrite HCI_def.
      apply (SepI R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x HxR).
      exact (andI (~(Rlt x a)) (~(Rlt b x)) Hnltxa Hnltbx). }
    exact (Hnot Hxin).
Qed.

(** helper: closed_interval_topology is a topology on closed_interval **)
Theorem closed_interval_topology_on : forall a b:set,
  topology_on (closed_interval a b) (closed_interval_topology a b).
let a b.
prove topology_on (closed_interval a b) (closed_interval_topology a b).
exact (subspace_topology_is_topology R R_standard_topology (closed_interval a b)
         R_standard_topology_is_topology (closed_interval_sub_R a b)).
Qed.

(** helper: endpoints lie in closed_interval when a<=b **)
Theorem left_endpoint_in_closed_interval : forall a b:set,
  Rle a b -> a :e closed_interval a b.
let a b.
assume Hab: Rle a b.
prove a :e closed_interval a b.
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim Hnlt_ba: ~(Rlt b a).
{ exact (RleE_nlt a b Hab). }
claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ reflexivity. }
rewrite HCI_def.
apply (SepI R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) a HaR).
apply andI.
- assume Hlt: Rlt a a.
  prove False.
  claim Halt: a < a.
  { exact (RltE_lt a a Hlt). }
  exact ((SNoLt_irref a) Halt).
- exact Hnlt_ba.
Qed.

Theorem right_endpoint_in_closed_interval : forall a b:set,
  Rle a b -> b :e closed_interval a b.
let a b.
assume Hab: Rle a b.
prove b :e closed_interval a b.
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim Hnlt_ba: ~(Rlt b a).
{ exact (RleE_nlt a b Hab). }
claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
{ reflexivity. }
rewrite HCI_def.
apply (SepI R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) b HbR).
apply andI.
- exact Hnlt_ba.
- assume Hlt: Rlt b b.
  prove False.
  claim Halt: b < b.
  { exact (RltE_lt b b Hlt). }
  exact ((SNoLt_irref b) Halt).
Qed.

(** helper: degenerate closed_interval has only the endpoint **)
Theorem closed_interval_degenerate : forall a y:set,
  a :e R -> y :e closed_interval a a -> y = a.
let a y.
assume HaR: a :e R.
assume Hy: y :e closed_interval a a.
prove y = a.
claim HCIaa_def: closed_interval a a = {t :e R | ~(Rlt t a) /\ ~(Rlt a t)}.
{ reflexivity. }
claim Hy': y :e {t :e R | ~(Rlt t a) /\ ~(Rlt a t)}.
{ rewrite <- HCIaa_def. exact Hy. }
claim HyR: y :e R.
{ exact (SepE1 R (fun t:set => ~(Rlt t a) /\ ~(Rlt a t)) y Hy'). }
claim Hyprop: ~(Rlt y a) /\ ~(Rlt a y).
{ exact (SepE2 R (fun t:set => ~(Rlt t a) /\ ~(Rlt a t)) y Hy'). }
claim Hnlt_ya: ~(Rlt y a).
{ exact (andEL (~(Rlt y a)) (~(Rlt a y)) Hyprop). }
claim Hnlt_ay: ~(Rlt a y).
{ exact (andER (~(Rlt y a)) (~(Rlt a y)) Hyprop). }
claim Hale: Rle a y.
{ exact (RleI a y HaR HyR Hnlt_ya). }
claim Hya: Rle y a.
{ exact (RleI y a HyR HaR Hnlt_ay). }
claim Haeq: a = y.
{ exact (Rle_antisym a y Hale Hya). }
rewrite Haeq.
reflexivity.
Qed.

(** helper: closed_interval is closed in the standard topology on R **)
Theorem closed_interval_closed_in_R_standard_topology : forall a b:set,
  a :e R -> b :e R -> closed_in R R_standard_topology (closed_interval a b).
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
prove closed_in R R_standard_topology (closed_interval a b).
claim HT: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology. }
set U := {x :e R | Rlt x a}.
set V := {x :e R | Rlt b x}.
claim HUopen: U :e R_standard_topology.
{ exact (open_left_ray_in_R_standard_topology a HaR). }
claim HVopen: V :e R_standard_topology.
{ exact (open_ray_in_R_standard_topology b HbR). }
claim HUVopen: (U :\/: V) :e R_standard_topology.
{ exact (binunion_in_R_standard_topology U V HUopen HVopen). }
claim Heq: closed_interval a b = R :\: (U :\/: V).
{ apply set_ext.
  - let x. assume HxI: x :e closed_interval a b.
    prove x :e R :\: (U :\/: V).
    claim HxR: x :e R.
    { exact (SepE1 R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x HxI). }
    claim Hxprop: ~(Rlt x a) /\ ~(Rlt b x).
    { exact (SepE2 R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x HxI). }
    claim Hnlt_xa: ~(Rlt x a).
    { exact (andEL (~(Rlt x a)) (~(Rlt b x)) Hxprop). }
    claim Hnlt_bx: ~(Rlt b x).
    { exact (andER (~(Rlt x a)) (~(Rlt b x)) Hxprop). }
    apply setminusI.
    + exact HxR.
    + assume HxUV: x :e (U :\/: V).
      apply (binunionE U V x HxUV).
      * assume HxU: x :e U.
        claim Hlt: Rlt x a.
        { exact (SepE2 R (fun t:set => Rlt t a) x HxU). }
        exact (Hnlt_xa Hlt).
      * assume HxV: x :e V.
        claim Hlt: Rlt b x.
        { exact (SepE2 R (fun t:set => Rlt b t) x HxV). }
        exact (Hnlt_bx Hlt).
  - let x. assume Hx: x :e R :\: (U :\/: V).
    prove x :e closed_interval a b.
    apply (setminusE R (U :\/: V) x Hx).
    assume HxR: x :e R.
    assume Hxnot: x /:e (U :\/: V).
    claim HCI_def: closed_interval a b = {t :e R | ~(Rlt t a) /\ ~(Rlt b t)}.
    { reflexivity. }
    rewrite HCI_def.
    apply (SepI R (fun t:set => ~(Rlt t a) /\ ~(Rlt b t)) x HxR).
    apply andI.
    + assume Hlt: Rlt x a.
      prove False.
      apply Hxnot.
      apply (binunionI1 U V x).
      exact (SepI R (fun t:set => Rlt t a) x HxR Hlt).
    + assume Hlt: Rlt b x.
      prove False.
      apply Hxnot.
      apply (binunionI2 U V x).
      exact (SepI R (fun t:set => Rlt b t) x HxR Hlt). }
rewrite Heq.
exact (closed_of_open_complement R R_standard_topology (U :\/: V) HT HUVopen).
Qed.

(** helper: a closed interval is closed in any closed_interval subspace topology by intersection **)
Theorem closed_interval_closed_in_closed_interval_topology : forall a b c d:set,
  a :e R -> b :e R -> c :e R -> d :e R ->
  closed_in (closed_interval a b) (closed_interval_topology a b) ((closed_interval c d) :/\: (closed_interval a b)).
let a b c d.
assume HaR: a :e R.
assume HbR: b :e R.
assume HcR: c :e R.
assume HdR: d :e R.
set I := closed_interval a b.
set Ti := closed_interval_topology a b.
set C := closed_interval c d.
prove closed_in I Ti (C :/\: I).
claim HT: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology. }
claim HISubR: I c= R.
{ exact (closed_interval_sub_R a b). }
claim HCclosed: closed_in R R_standard_topology C.
{ exact (closed_interval_closed_in_R_standard_topology c d HcR HdR). }
apply (iffER (closed_in I Ti (C :/\: I))
             (exists D:set, closed_in R R_standard_topology D /\ (C :/\: I) = D :/\: I)
             (closed_in_subspace_iff_intersection R R_standard_topology I (C :/\: I) HT HISubR)).
witness C.
apply andI.
- exact HCclosed.
- reflexivity.
Qed.

(** helper for §33 Urysohn lemma: extend a nested family by one point **)
(** LATEX VERSION: Given finitely many indices with nested closures, insert a new index r by shrinking between the lower-closure union and upper open intersection. **)
Theorem normal_extend_nested_open_family_by_point :
  forall X Tx:set, normal_space X Tx ->
  forall F:set, finite F -> F c= R ->
  forall Uof:set->set,
    (forall p:set, p :e F -> Uof p :e Tx) ->
    (forall p q:set, p :e F -> q :e F -> Rlt p q -> closure_of X Tx (Uof p) c= Uof q) ->
  forall r:set, r :e R ->
    exists Ur:set, Ur :e Tx /\
      (forall p:set, p :e F -> Rlt p r -> closure_of X Tx (Uof p) c= Ur) /\
      (forall q:set, q :e F -> Rlt r q -> closure_of X Tx Ur c= Uof q).
let X Tx.
assume Hnorm: normal_space X Tx.
let F.
assume HFfin: finite F.
assume HFsubR: F c= R.
let Uof.
assume HUof: forall p:set, p :e F -> Uof p :e Tx.
assume Hnest: forall p q:set, p :e F -> q :e F -> Rlt p q -> closure_of X Tx (Uof p) c= Uof q.
let r. assume HrR: r :e R.
prove exists Ur:set, Ur :e Tx /\
  (forall p:set, p :e F -> Rlt p r -> closure_of X Tx (Uof p) c= Ur) /\
  (forall q:set, q :e F -> Rlt r q -> closure_of X Tx Ur c= Uof q).
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
(** lower closed union **)
claim HFltFin: finite {x :e F | Rlt x r}.
{ claim HFltSubF: {x :e F | Rlt x r} c= F.
  { let p. assume Hp: p :e {x :e F | Rlt x r}.
    exact (SepE1 F (fun p0:set => Rlt p0 r) p Hp). }
  exact (Subq_finite F HFfin {x :e F | Rlt x r} HFltSubF). }
set ClFam := {closure_of X Tx (Uof p) | p :e {x :e F | Rlt x r}}.
claim HClFamFin: finite ClFam.
{ exact (Repl_finite (fun p:set => closure_of X Tx (Uof p)) {x :e F | Rlt x r} HFltFin). }
claim HClFamClosed: forall C:set, C :e ClFam -> closed_in X Tx C.
{ let C. assume HC: C :e ClFam.
  apply (ReplE_impred {x :e F | Rlt x r} (fun p:set => closure_of X Tx (Uof p)) C HC (closed_in X Tx C)).
  let p. assume HpFlt: p :e {x :e F | Rlt x r}.
  assume HCeq: C = closure_of X Tx (Uof p).
  rewrite HCeq.
  claim HpF: p :e F.
  { exact (SepE1 F (fun p0:set => Rlt p0 r) p HpFlt). }
  claim HUpTx: Uof p :e Tx.
  { exact (HUof p HpF). }
  claim HUpSubX: Uof p c= X.
  { exact (topology_elem_subset X Tx (Uof p) HTx HUpTx). }
  exact (closure_is_closed X Tx (Uof p) HTx HUpSubX). }
set Lower := Union ClFam.
claim HLowerClosed: closed_in X Tx Lower.
{ exact (finite_union_closed_in X Tx ClFam HTx HClFamFin HClFamClosed). }
(** upper open intersection **)
claim HFgtFin: finite {x :e F | Rlt r x}.
{ claim HFgtSubF: {x :e F | Rlt r x} c= F.
  { let q. assume Hq: q :e {x :e F | Rlt r x}.
    exact (SepE1 F (fun q0:set => Rlt r q0) q Hq). }
  exact (Subq_finite F HFfin {x :e F | Rlt r x} HFgtSubF). }
set UpFam := {Uof q | q :e {x :e F | Rlt r x}}.
claim HUpFamFin: finite UpFam.
{ exact (Repl_finite (fun q:set => Uof q) {x :e F | Rlt r x} HFgtFin). }
claim HUpFamSubTx: UpFam c= Tx.
{ let U. assume HU: U :e UpFam.
  apply (ReplE_impred {x :e F | Rlt r x} (fun q:set => Uof q) U HU (U :e Tx)).
  let q. assume HqFgt: q :e {x :e F | Rlt r x}.
  assume HUeq: U = Uof q.
  rewrite HUeq.
  claim HqF: q :e F.
  { exact (SepE1 F (fun q0:set => Rlt r q0) q HqFgt). }
  exact (HUof q HqF). }
claim HUpFamPow: UpFam :e Power Tx.
{ exact (PowerI Tx UpFam HUpFamSubTx). }
set Upper := intersection_of_family X UpFam.
claim HUpperTx: Upper :e Tx.
{ exact (finite_intersection_in_topology X Tx UpFam HTx HUpFamPow HUpFamFin). }
claim HLowerSubUpper: Lower c= Upper.
{ let x. assume Hx: x :e Lower.
  prove x :e Upper.
  apply (UnionE ClFam x Hx).
  let C. assume HCpair: x :e C /\ C :e ClFam.
  apply HCpair.
  assume HxC: x :e C.
  assume HCin: C :e ClFam.
  apply (ReplE_impred {x :e F | Rlt x r} (fun p0:set => closure_of X Tx (Uof p0)) C HCin (x :e Upper)).
  let p. assume HpFlt: p :e {x :e F | Rlt x r}.
  assume HCeq: C = closure_of X Tx (Uof p).
  claim HxCl: x :e closure_of X Tx (Uof p).
  { rewrite <- HCeq. exact HxC. }
  (** show x belongs to every Uof q with r<q **)
  claim HxX: x :e X.
  { exact (closed_in_subset X Tx Lower HLowerClosed x Hx). }
  claim HallU: forall U:set, U :e UpFam -> x :e U.
  { let U. assume HU: U :e UpFam.
    apply (ReplE_impred {x :e F | Rlt r x} (fun q0:set => Uof q0) U HU (x :e U)).
    let q. assume HqFgt: q :e {x :e F | Rlt r x}.
    assume HUeq: U = Uof q.
    rewrite HUeq.
    claim HpF: p :e F.
    { exact (SepE1 F (fun p0:set => Rlt p0 r) p HpFlt). }
    claim HqF: q :e F.
    { exact (SepE1 F (fun q0:set => Rlt r q0) q HqFgt). }
    claim Hpr: Rlt p r.
    { exact (SepE2 F (fun p0:set => Rlt p0 r) p HpFlt). }
    claim Hrq: Rlt r q.
    { exact (SepE2 F (fun q0:set => Rlt r q0) q HqFgt). }
    claim Hpq: Rlt p q.
    { exact (Rlt_tra p r q Hpr Hrq). }
    claim Hsub: closure_of X Tx (Uof p) c= Uof q.
    { exact (Hnest p q HpF HqF Hpq). }
    exact (Hsub x HxCl). }
  exact (intersection_of_familyI X UpFam x HxX HallU).
}
(** shrink between Lower (closed) and Upper (open) **)
claim HUpperOpen: Upper :e Tx.
{ exact HUpperTx. }
apply (normal_space_shrink_closed X Tx Lower Upper Hnorm HLowerClosed HUpperOpen HLowerSubUpper).
let Ur.
assume HUr: Ur :e Tx /\ Lower c= Ur /\ closure_of X Tx Ur c= Upper.
witness Ur.
claim HUr12: Ur :e Tx /\ Lower c= Ur.
{ exact (andEL (Ur :e Tx /\ Lower c= Ur) (closure_of X Tx Ur c= Upper) HUr). }
claim HUr1: Ur :e Tx.
{ exact (andEL (Ur :e Tx) (Lower c= Ur) HUr12). }
claim HLowerSubUr: Lower c= Ur.
{ exact (andER (Ur :e Tx) (Lower c= Ur) HUr12). }
claim HUr3: closure_of X Tx Ur c= Upper.
{ exact (andER (Ur :e Tx /\ Lower c= Ur) (closure_of X Tx Ur c= Upper) HUr). }
apply andI.
- (** Ur :e Tx /\ lower-closure property **)
  apply andI.
  + exact HUr1.
  + let p. assume HpF: p :e F.
    assume Hpr: Rlt p r.
    prove closure_of X Tx (Uof p) c= Ur.
    let x. assume Hx: x :e closure_of X Tx (Uof p).
    prove x :e Ur.
    claim HpFlt: p :e {x :e F | Rlt x r}.
    { exact (SepI F (fun p0:set => Rlt p0 r) p HpF Hpr). }
    claim HCin: closure_of X Tx (Uof p) :e ClFam.
    { exact (ReplI {x :e F | Rlt x r} (fun p0:set => closure_of X Tx (Uof p0)) p HpFlt). }
    claim HxLower: x :e Lower.
    { exact (UnionI ClFam x (closure_of X Tx (Uof p)) Hx HCin). }
    exact (HLowerSubUr x HxLower).
- (** closure(Ur) included in each upper member **)
  let q. assume HqF: q :e F.
  assume Hrq: Rlt r q.
  prove closure_of X Tx Ur c= Uof q.
  claim HUin: Uof q :e UpFam.
  { claim HqFgt: q :e {x :e F | Rlt r x}.
    { exact (SepI F (fun q0:set => Rlt r q0) q HqF Hrq). }
    exact (ReplI {x :e F | Rlt r x} (fun q0:set => Uof q0) q HqFgt). }
  let x. assume Hx: x :e closure_of X Tx Ur.
  claim HxU: x :e Upper.
  { exact (HUr3 x Hx). }
  exact (intersection_of_familyE2 X UpFam x HxU (Uof q) HUin).
Qed.

Theorem Urysohn_lemma : forall X Tx A B a b:set,
  Rle a b ->
  normal_space X Tx -> closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
  exists f:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) f /\
    (forall x:set, x :e A -> apply_fun f x = a) /\
    (forall x:set, x :e B -> apply_fun f x = b).
let X Tx A B a b.
assume Hab: Rle a b.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume HB: closed_in X Tx B.
assume Hdisj: A :/\: B = Empty.
prove exists f:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) f /\
    (forall x:set, x :e A -> apply_fun f x = a) /\
    (forall x:set, x :e B -> apply_fun f x = b).
(** setup: extract basic topology facts and interval topology **)
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HbR: b :e R.
{ exact (RleE_right a b Hab). }
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A HA). }
claim HBsubX: B c= X.
{ exact (closed_in_subset X Tx B HB). }
set I := closed_interval a b.
set Ti := closed_interval_topology a b.
claim HaI: a :e I.
{ exact (SepI R (fun x:set => ~(Rlt x a) /\ ~(Rlt b x)) a HaR
           (andI (~(Rlt a a)) (~(Rlt b a))
                 (not_Rlt_refl a HaR)
                 (RleE_nlt a b Hab))). }
claim HbI: b :e I.
{ exact (SepI R (fun x:set => ~(Rlt x a) /\ ~(Rlt b x)) b HbR
           (andI (~(Rlt b a)) (~(Rlt b b))
                 (RleE_nlt a b Hab)
                 (not_Rlt_refl b HbR))). }
claim HISubR: I c= R.
{ let r. assume Hr: r :e I.
  exact (SepE1 R (fun x:set => ~(Rlt x a) /\ ~(Rlt b x)) r Hr). }
		claim HTi: topology_on I Ti.
		{ exact (subspace_topology_is_topology R R_standard_topology I (R_standard_topology_is_topology) HISubR). }
		(** Step 0 (TeX): handle the degenerate interval case a=b by the constant map. **)
		apply (xm (a = b)).
		- assume HabEq': a = b.
		  set f := const_fun X a.
		  witness f.
			  apply andI.
			  + prove continuous_map X Tx I Ti f /\ (forall x:set, x :e A -> apply_fun f x = a).
			    apply andI.
			    * exact (const_fun_continuous X Tx I Ti a HTx HTi HaI).
			    * let x. assume HxA: x :e A.
			      claim HxX: x :e X.
			      { exact (HAsubX x HxA). }
			      rewrite (const_fun_apply X a x HxX).
			      reflexivity.
			  + let x. assume HxB: x :e B.
			    claim HxX: x :e X.
			    { exact (HBsubX x HxB). }
			    rewrite (const_fun_apply X a x HxX).
			    rewrite <- HabEq'.
			    reflexivity.
		- assume HabNe: ~(a = b).
		  (** TeX §33: non-degenerate interval case (a<b). **)
		  (** First step of the TeX proof: get disjoint open neighborhoods of A and B, then closure-shrink them. **)
		  claim HsepAx:
		    forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
		      exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty.
		  { exact (andER (one_point_sets_closed X Tx)
		                 (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
		                    exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
		                 Hnorm). }
		  claim HexShrink:
		    exists U0 V0 U1 V1:set,
		      (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		      /\
		      ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		       /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		  { apply (HsepAx A B HA HB Hdisj).
		    let U0.
		    assume HexV0: exists V0:set, U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty.
		    apply HexV0.
		    let V0.
		    assume HUV0: U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty.
		    claim Hcore0: (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0).
		    { exact (andEL (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0)
		                   (U0 :/\: V0 = Empty)
		                   HUV0). }
		    claim Hcore1: ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0).
		    { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0)
		                   (B c= V0)
		                   Hcore0). }
		    claim HBsubV0: B c= V0.
		    { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0)
		                   (B c= V0)
		                   Hcore0). }
		    claim HUVTx: (U0 :e Tx /\ V0 :e Tx).
		    { exact (andEL (U0 :e Tx /\ V0 :e Tx)
		                   (A c= U0)
		                   Hcore1). }
		    claim HAsubU0: A c= U0.
		    { exact (andER (U0 :e Tx /\ V0 :e Tx)
		                   (A c= U0)
		                   Hcore1). }
		    claim HU0Tx: U0 :e Tx.
		    { exact (andEL (U0 :e Tx) (V0 :e Tx) HUVTx). }
		    claim HV0Tx: V0 :e Tx.
		    { exact (andER (U0 :e Tx) (V0 :e Tx) HUVTx). }
		    claim HshrinkA: exists U1:set, U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0.
		    { exact (normal_space_shrink_closed X Tx A U0 Hnorm HA HU0Tx HAsubU0). }
		    apply HshrinkA.
		    let U1.
		    assume HU1: U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0.
		    claim HshrinkB: exists V1:set, V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0.
		    { exact (normal_space_shrink_closed X Tx B V0 Hnorm HB HV0Tx HBsubV0). }
		    apply HshrinkB.
		    let V1.
		    assume HV1: V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0.
		    witness U0.
		    witness V0.
		    witness U1.
		    witness V1.
		    prove (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		      /\ ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		          /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		    apply andI.
		    - exact HUV0.
		    - apply andI.
		      + exact HU1.
		      + exact HV1. }
		  (** Extract U0,V0,U1,V1 and derive basic disjointness and inclusion properties for the later construction. **)
		  apply HexShrink.
		  let U0. assume HexV0: exists V0:set, exists U1:set, exists V1:set,
		    (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		    /\ ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		        /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		  apply HexV0.
		  let V0. assume HexU1: exists U1:set, exists V1:set,
		    (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		    /\ ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		        /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		  apply HexU1.
		  let U1. assume HexV1: exists V1:set,
		    (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		    /\ ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		        /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		  apply HexV1.
		  let V1. assume Hshrink: (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		    /\ ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		        /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)).
		  claim HUV0: U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty.
		  { exact (andEL (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		                 ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		                  /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0))
		                 Hshrink). }
		  claim HUV1: (U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		    /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0).
		  { exact (andER (U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty)
		                 ((U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		                  /\ (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0))
		                 Hshrink). }
		  claim HUV0core: (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0).
		  { exact (andEL (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0)
		                 (U0 :/\: V0 = Empty)
		                 HUV0). }
		  claim HUV0disj: U0 :/\: V0 = Empty.
		  { exact (andER (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0)
		                 (U0 :/\: V0 = Empty)
		                 HUV0). }
		  claim HUV0L: (U0 :e Tx /\ V0 :e Tx) /\ A c= U0.
		  { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0)
		                 (B c= V0)
		                 HUV0core). }
		  claim HBsubV0: B c= V0.
		  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0)
		                 (B c= V0)
		                 HUV0core). }
		  claim HUV0Tx: U0 :e Tx /\ V0 :e Tx.
		  { exact (andEL (U0 :e Tx /\ V0 :e Tx) (A c= U0) HUV0L). }
		  claim HU0Tx: U0 :e Tx.
		  { exact (andEL (U0 :e Tx) (V0 :e Tx) HUV0Tx). }
		  claim HV0Tx: V0 :e Tx.
		  { exact (andER (U0 :e Tx) (V0 :e Tx) HUV0Tx). }
		  claim HUV1U: U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0.
		  { exact (andEL (U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		                 (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)
		                 HUV1). }
		  claim HUV1V: V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0.
		  { exact (andER (U1 :e Tx /\ A c= U1 /\ closure_of X Tx U1 c= U0)
		                 (V1 :e Tx /\ B c= V1 /\ closure_of X Tx V1 c= V0)
		                 HUV1). }
		  claim HU1Tx: U1 :e Tx.
		  { claim HU1pair: U1 :e Tx /\ A c= U1.
		    { exact (andEL (U1 :e Tx /\ A c= U1) (closure_of X Tx U1 c= U0) HUV1U). }
		    exact (andEL (U1 :e Tx) (A c= U1) HU1pair). }
		  claim HV1Tx: V1 :e Tx.
		  { claim HV1pair: V1 :e Tx /\ B c= V1.
		    { exact (andEL (V1 :e Tx /\ B c= V1) (closure_of X Tx V1 c= V0) HUV1V). }
		    exact (andEL (V1 :e Tx) (B c= V1) HV1pair). }
		  claim HclU1subU0: closure_of X Tx U1 c= U0.
		  { exact (andER (U1 :e Tx /\ A c= U1) (closure_of X Tx U1 c= U0) HUV1U). }
		  claim HclV1subV0: closure_of X Tx V1 c= V0.
		  { exact (andER (V1 :e Tx /\ B c= V1) (closure_of X Tx V1 c= V0) HUV1V). }
		  claim HU1subX: U1 c= X.
		  { exact (topology_elem_subset X Tx U1 HTx HU1Tx). }
		  claim HV1subX: V1 c= X.
		  { exact (topology_elem_subset X Tx V1 HTx HV1Tx). }
		  claim HU1subU0: U1 c= U0.
		  { claim HU1subCl: U1 c= closure_of X Tx U1.
		    { exact (subset_of_closure X Tx U1 HTx HU1subX). }
		    exact (Subq_tra U1 (closure_of X Tx U1) U0 HU1subCl HclU1subU0). }
		  claim HV1subV0: V1 c= V0.
		  { claim HV1subCl: V1 c= closure_of X Tx V1.
		    { exact (subset_of_closure X Tx V1 HTx HV1subX). }
		    exact (Subq_tra V1 (closure_of X Tx V1) V0 HV1subCl HclV1subV0). }
		  claim HU1V1disj: U1 :/\: V1 = Empty.
		  { apply Empty_Subq_eq.
		    claim HsubU0: U1 :/\: V1 c= U0.
		    { exact (Subq_tra (U1 :/\: V1) U1 U0 (binintersect_Subq_1 U1 V1) HU1subU0). }
		    claim HsubV0: U1 :/\: V1 c= V0.
		    { exact (Subq_tra (U1 :/\: V1) V1 V0 (binintersect_Subq_2 U1 V1) HV1subV0). }
		    claim HsubUV0: U1 :/\: V1 c= U0 :/\: V0.
		    { exact (binintersect_Subq_max U0 V0 (U1 :/\: V1) HsubU0 HsubV0). }
		    claim HsubEmpty: U0 :/\: V0 c= Empty.
		    { rewrite HUV0disj. exact (Subq_ref Empty). }
		    exact (Subq_tra (U1 :/\: V1) (U0 :/\: V0) Empty HsubUV0 HsubEmpty). }
		  claim HclU1clV1disj: closure_of X Tx U1 :/\: closure_of X Tx V1 = Empty.
		  { apply Empty_Subq_eq.
		    claim HsubU0: closure_of X Tx U1 :/\: closure_of X Tx V1 c= U0.
		    { exact (Subq_tra (closure_of X Tx U1 :/\: closure_of X Tx V1) (closure_of X Tx U1) U0
		                     (binintersect_Subq_1 (closure_of X Tx U1) (closure_of X Tx V1)) HclU1subU0). }
		    claim HsubV0: closure_of X Tx U1 :/\: closure_of X Tx V1 c= V0.
		    { exact (Subq_tra (closure_of X Tx U1 :/\: closure_of X Tx V1) (closure_of X Tx V1) V0
		                     (binintersect_Subq_2 (closure_of X Tx U1) (closure_of X Tx V1)) HclV1subV0). }
		    claim HsubUV0: closure_of X Tx U1 :/\: closure_of X Tx V1 c= U0 :/\: V0.
		    { exact (binintersect_Subq_max U0 V0 (closure_of X Tx U1 :/\: closure_of X Tx V1) HsubU0 HsubV0). }
		    claim HsubEmpty: U0 :/\: V0 c= Empty.
		    { rewrite HUV0disj. exact (Subq_ref Empty). }
		    exact (Subq_tra (closure_of X Tx U1 :/\: closure_of X Tx V1) (U0 :/\: V0) Empty HsubUV0 HsubEmpty). }
		  claim Hnltba: ~(Rlt b a).
		  { exact (RleE_nlt a b Hab). }
		  claim HaRb: a :e R.
		  { exact HaR. }
			  claim HbRb: b :e R.
			  { exact HbR. }
			  claim Hltab: Rlt a b.
			  { claim HaS: SNo a.
			    { exact (real_SNo a HaRb). }
			    claim HbS: SNo b.
			    { exact (real_SNo b HbRb). }
			    apply (SNoLt_trichotomy_or_impred a b HaS HbS (Rlt a b)).
			    - assume HabSlt: a < b.
			      exact (RltI a b HaRb HbRb HabSlt).
			    - assume Heq: a = b.
			      apply FalseE.
			      exact (HabNe Heq).
			    - assume HbaSlt: b < a.
			      claim HbaRlt: Rlt b a.
				  { exact (RltI b a HbRb HaRb HbaSlt). }
				  apply FalseE.
				  exact (Hnltba HbaRlt). }
				  (** TeX §33 Step 1 (setup for the indexed open family): define the endpoint neighborhoods U_b and U_a. **)
				  set U_b := X :\: B.
				  claim HU_bTx: U_b :e Tx.
				  { exact (open_in_elem X Tx U_b (open_of_closed_complement X Tx B HB)). }
				  claim HA_sub_U_b: A c= U_b.
				  { let x. assume HxA: x :e A.
				    claim HxX: x :e X.
				    { exact (HAsubX x HxA). }
				    claim HxNotB: x /:e B.
				    { assume HxB: x :e B.
				      claim HxAB: x :e A :/\: B.
				      { exact (binintersectI A B x HxA HxB). }
				      claim HxE: x :e Empty.
				      { rewrite <- Hdisj.
				        exact HxAB. }
				      exact (EmptyE x HxE False). }
				    exact (setminusI X B x HxX HxNotB). }
				  claim HexU_a: exists U_a:set, U_a :e Tx /\ A c= U_a /\ closure_of X Tx U_a c= U_b.
				  { exact (normal_space_shrink_closed X Tx A U_b Hnorm HA HU_bTx HA_sub_U_b). }
					  apply HexU_a.
						  let U_a.
						  assume HU_a: U_a :e Tx /\ A c= U_a /\ closure_of X Tx U_a c= U_b.
						  claim HU_aTx: U_a :e Tx.
						  { claim HU_a12: U_a :e Tx /\ A c= U_a.
						    { exact (andEL (U_a :e Tx /\ A c= U_a) (closure_of X Tx U_a c= U_b) HU_a). }
						    exact (andEL (U_a :e Tx) (A c= U_a) HU_a12). }
						  claim HclU_a_sub_U_b: closure_of X Tx U_a c= U_b.
						  { exact (andER (U_a :e Tx /\ A c= U_a) (closure_of X Tx U_a c= U_b) HU_a). }
					  (** Helper instantiation: between any a<r<b, insert Ur with cl(U_a)⊆Ur⊆cl(Ur)⊆U_b (finite family {a,b}). **)
					  claim Hex_between: forall r:set, r :e R -> Rlt a r -> Rlt r b ->
					    exists Ur:set, Ur :e Tx /\ closure_of X Tx U_a c= Ur /\ closure_of X Tx Ur c= U_b.
					  { let r. assume HrR: r :e R.
					    assume Har: Rlt a r.
					    assume Hrb: Rlt r b.
					    set F := UPair a b.
					    claim HFfin: finite F.
					    { exact (finite_UPair a b). }
					    claim HFsubR: F c= R.
					    { let t. assume HtF: t :e F.
					      apply (UPairE t a b HtF (t :e R)).
					      - assume Ht: t = a. rewrite Ht. exact HaR.
					      - assume Ht: t = b. rewrite Ht. exact HbR. }
					    set Uof := (fun t:set => if t = a then U_a else U_b).
					    claim HUof: forall p:set, p :e F -> Uof p :e Tx.
					    { let p. assume HpF: p :e F.
					      apply (UPairE p a b HpF (Uof p :e Tx)).
					      - assume Hpa: p = a.
					        rewrite Hpa.
					        claim HUofbeta: Uof a = if a = a then U_a else U_b.
					        { reflexivity. }
					        rewrite HUofbeta.
					        claim Haa: a = a.
					        { reflexivity. }
					        rewrite (If_i_1 (a = a) U_a U_b Haa).
					        exact HU_aTx.
					      - assume Hpb: p = b.
					        rewrite Hpb.
					        claim HUofbeta: Uof b = if b = a then U_a else U_b.
					        { reflexivity. }
					        rewrite HUofbeta.
					        claim Hbna: ~(b = a).
					        { assume Hba: b = a.
					          apply HabNe.
					          symmetry. exact Hba. }
					        rewrite (If_i_0 (b = a) U_a U_b Hbna).
					        exact HU_bTx. }
					    claim Hnest: forall p q:set, p :e F -> q :e F -> Rlt p q -> closure_of X Tx (Uof p) c= Uof q.
					    { let p q.
					      assume HpF: p :e F.
					      assume HqF: q :e F.
					      assume Hpq: Rlt p q.
					      apply (UPairE p a b HpF (closure_of X Tx (Uof p) c= Uof q)).
					      - assume Hpa: p = a.
					        rewrite Hpa.
					        apply (UPairE q a b HqF (closure_of X Tx (Uof a) c= Uof q)).
						        + assume Hqa: q = a.
						          apply FalseE.
						          claim Haa: Rlt a a.
						          { rewrite <- Hpa at 1.
						            rewrite <- Hqa at 1.
						            exact Hpq. }
						          exact (not_Rlt_refl a HaR Haa).
					        + assume Hqb: q = b.
					          rewrite Hqb.
					          claim HUofa: Uof a = U_a.
					          { claim Haa: a = a.
					            { reflexivity. }
					            claim HUofbeta: Uof a = if a = a then U_a else U_b.
					            { reflexivity. }
					            rewrite HUofbeta.
					            exact (If_i_1 (a = a) U_a U_b Haa). }
					          claim HUofb: Uof b = U_b.
					          { claim Hbna: ~(b = a).
					            { assume Hba: b = a.
					              apply HabNe.
					              symmetry. exact Hba. }
					            claim HUofbeta: Uof b = if b = a then U_a else U_b.
					            { reflexivity. }
					            rewrite HUofbeta.
					            exact (If_i_0 (b = a) U_a U_b Hbna). }
					          rewrite HUofa.
					          rewrite HUofb.
					          exact HclU_a_sub_U_b.
					      - assume Hpb: p = b.
					        apply FalseE.
					        claim Hbq: Rlt b q.
					        { rewrite <- Hpb. exact Hpq. }
					        apply Hnltba.
					        apply (UPairE q a b HqF (Rlt b a)).
					        + assume Hqa: q = a.
					          claim Hba: Rlt b a.
					          { rewrite <- Hqa. exact Hbq. }
					          exact Hba.
						        + assume Hqb: q = b.
						          apply FalseE.
						          claim Hbb: Rlt b b.
						          { rewrite <- Hqb at 2. exact Hbq. }
						          exact (not_Rlt_refl b HbR Hbb). }
					    apply (normal_extend_nested_open_family_by_point X Tx Hnorm F HFfin HFsubR Uof HUof Hnest r HrR).
					    let Ur.
					    assume HUr: Ur :e Tx /\
					      (forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur) /\
					      (forall q0:set, q0 :e F -> Rlt r q0 -> closure_of X Tx Ur c= Uof q0).
					    witness Ur.
					    claim HUr12: (Ur :e Tx /\ forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur).
					    { exact (andEL (Ur :e Tx /\ forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur)
					                 (forall q0:set, q0 :e F -> Rlt r q0 -> closure_of X Tx Ur c= Uof q0)
					                 HUr). }
					    claim HUrTx: Ur :e Tx.
					    { exact (andEL (Ur :e Tx)
					                 (forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur)
					                 HUr12). }
					    claim Hleft: forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur.
					    { exact (andER (Ur :e Tx)
					                 (forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur)
					                 HUr12). }
					    claim Hright: forall q0:set, q0 :e F -> Rlt r q0 -> closure_of X Tx Ur c= Uof q0.
					    { exact (andER (Ur :e Tx /\ forall p0:set, p0 :e F -> Rlt p0 r -> closure_of X Tx (Uof p0) c= Ur)
					                 (forall q0:set, q0 :e F -> Rlt r q0 -> closure_of X Tx Ur c= Uof q0)
					                 HUr). }
					    claim HUofa: Uof a = U_a.
					    { claim Haa: a = a.
					      { reflexivity. }
					      claim HUofbeta: Uof a = if a = a then U_a else U_b.
					      { reflexivity. }
					      rewrite HUofbeta.
					      exact (If_i_1 (a = a) U_a U_b Haa). }
					    claim HUofb: Uof b = U_b.
					    { claim Hbna: ~(b = a).
					      { assume Hba: b = a.
					        apply HabNe.
					        symmetry. exact Hba. }
					      claim HUofbeta: Uof b = if b = a then U_a else U_b.
					      { reflexivity. }
					      rewrite HUofbeta.
					      exact (If_i_0 (b = a) U_a U_b Hbna). }
					    apply andI.
					    - apply andI.
					      + exact HUrTx.
					      + rewrite <- HUofa.
					        exact (Hleft a (UPairI1 a b) Har).
					    - rewrite <- HUofb.
					      exact (Hright b (UPairI2 a b) Hrb).
					  }
					  (** TeX §33 Step 1: choose a countable dense index set inside [a,b]. **)
					  set P0 := rational_numbers :/\: I.
					  set P := P0 :\/: (UPair a b).
				  claim HP_count: countable P.
				  { (** P0 is countable as a subset of Q **)
				    claim HQcount: countable rational_numbers.
				    { exact (rational_numbers_countable). }
				    claim HP0count: countable P0.
				    { exact (binintersect_countable_left rational_numbers I HQcount). }
				    (** add endpoints a,b (finite hence countable) **)
				    claim HabFin: finite (UPair a b).
				    { exact (finite_UPair a b). }
				    claim HabCount: countable (UPair a b).
				    { exact (finite_countable (UPair a b) HabFin). }
				    exact (binunion_countable P0 (UPair a b) HP0count HabCount). }
				  claim HP_sub_R: P c= R.
				  { let r. assume HrP: r :e P.
				    apply (binunionE P0 (UPair a b) r HrP (r :e R)).
				    - assume HrP0: r :e P0.
				      claim HrQ: r :e rational_numbers.
				      { exact (binintersectE1 rational_numbers I r HrP0). }
				      exact (rational_numbers_in_R r HrQ).
				    - assume HrAB: r :e UPair a b.
					      claim HrEq: r = a \/ r = b.
					      { exact (UPairE r a b HrAB). }
				      apply HrEq.
				      + assume Hra: r = a.
				        rewrite Hra.
				        exact HaR.
				      + assume Hrb: r = b.
				        rewrite Hrb.
				        exact HbR. }
					  (** TeX §33 Step 1: use countability of P to obtain an injection code:P→ω (used to define finite prefixes). **)
					  apply HP_count.
					  let code : set -> set.
					  assume Hcode_inj: inj P omega code.
					  claim Hcode_in_omega: forall p:set, p :e P -> code p :e omega.
					  { apply Hcode_inj.
					    assume Hcode_in Hcode_inj0.
					    let p. assume HpP: p :e P.
					    exact (Hcode_in p HpP). }
					  (** Finite prefixes of P via the injection code **)
					  set Ppref := (fun n:set => {p :e P | code p :e ordsucc n}).
					  claim Hpref_finite: forall n:set, nat_p n -> finite (Ppref n).
					  { let n. assume Hnat: nat_p n.
					    exact (inj_omega_preimage_ordsucc_finite P n code Hnat Hcode_inj). }
					  (** TeX §33 Step 1 (work-in-progress): pick the (unique) element of P with a given code value. **)
					  set P_eq := (fun n:set => {p :e P | code p = n}).
					  set pnew := (fun n:set => Eps_i (fun p:set => p :e P /\ code p = n)).
					  claim Hpnew_spec: forall n:set, (exists p:set, p :e P /\ code p = n) ->
					    pnew n :e P /\ code (pnew n) = n.
					  { let n. assume Hex: exists p:set, p :e P /\ code p = n.
					    set Ppred := (fun p:set => p :e P /\ code p = n).
					    claim HpnewPpred: Ppred (pnew n).
					    { exact (Eps_i_ex Ppred Hex). }
					    exact HpnewPpred. }
						  (** TeX §33 Step 1 (planned): a nat_primrec state carrying a finite domain and a function-graph on it. **)
						  set BaseF := UPair a b.
						  set BaseG := graph BaseF (fun t:set => if t = a then U_a else U_b).
						  set BaseState := (BaseF, BaseG).
						  set Ur_of := (fun n st:set =>
						    Eps_i (fun U:set =>
						      U :e Tx /\
						      (forall p0:set, p0 :e (st 0) -> Rlt p0 (pnew n) ->
						        closure_of X Tx (apply_fun (st 1) p0) c= U)
						      /\
						      (forall q0:set, q0 :e (st 0) -> Rlt (pnew n) q0 ->
						        closure_of X Tx U c= apply_fun (st 1) q0))).
						  (** Step 1 helper: extend the stage-graph by rebuilding it as a graph over the enlarged domain. **)
						  set Gext := (fun n st:set =>
						    graph ((st 0) :\/: {pnew n})
						      (fun p:set => if p = pnew n then Ur_of n st else apply_fun (st 1) p)).
						  set StepState := (fun n st:set =>
						    if (exists p:set, p :e P /\ code p = n)
						    then
						      if (pnew n :e (st 0))
						      then st
						      else ((st 0) :\/: {pnew n}, Gext n st)
						    else st).
					  set State := (fun n:set => nat_primrec BaseState StepState n).
						  set Fof := (fun n:set => (State n) 0).
						  set Gof := (fun n:set => (State n) 1).
						  (** TeX §33 Step 1 invariant for the finite-stage construction. **)
						  set Inv := (fun st:set =>
						    finite (st 0) /\
						    (st 0 c= R) /\
						    total_function_on (st 1) (st 0) Tx /\ functional_graph (st 1) /\ graph_domain_subset (st 1) (st 0) /\
						      forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						        closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q).
						  (** Basic facts about the base state. **)
						  claim HBaseFfin: finite BaseF.
						  { exact (finite_UPair a b). }
						  claim HBaseGa: apply_fun BaseG a = U_a.
						  { claim HaBaseF: a :e BaseF.
						    { exact (UPairI1 a b). }
						    claim Haa: a = a.
						    { reflexivity. }
						    rewrite (apply_fun_graph BaseF (fun t:set => if t = a then U_a else U_b) a HaBaseF).
						    rewrite (If_i_1 (a = a) U_a U_b Haa).
						    reflexivity. }
						  claim HBaseGb: apply_fun BaseG b = U_b.
						  { claim HbBaseF: b :e BaseF.
						    { exact (UPairI2 a b). }
						    rewrite (apply_fun_graph BaseF (fun t:set => if t = a then U_a else U_b) b HbBaseF).
						    claim Hbna: ~(b = a).
						    { assume Hba: b = a.
						      apply HabNe.
						      symmetry. exact Hba. }
						    rewrite (If_i_0 (b = a) U_a U_b Hbna).
						    reflexivity. }
						  (** Base state satisfies Inv. **)
						  claim HInvBase: Inv BaseState.
						  { (** destruct the left-associated conjunction defining Inv **)
						    claim HBaseStateDef: BaseState = (BaseF, BaseG).
						    { reflexivity. }
						    claim HBaseState0: BaseState 0 = BaseF.
						    { rewrite HBaseStateDef.
						      exact (tuple_2_0_eq BaseF BaseG). }
						    claim HBaseState1: BaseState 1 = BaseG.
						    { rewrite HBaseStateDef.
						      exact (tuple_2_1_eq BaseF BaseG). }
						    claim HInvUnfold:
						      Inv BaseState =
						        (finite (BaseState 0) /\
						         (BaseState 0 c= R) /\
						         total_function_on (BaseState 1) (BaseState 0) Tx /\ functional_graph (BaseState 1) /\ graph_domain_subset (BaseState 1) (BaseState 0) /\
						           forall p q:set, p :e (BaseState 0) -> q :e (BaseState 0) -> Rlt p q ->
						             closure_of X Tx (apply_fun (BaseState 1) p) c= apply_fun (BaseState 1) q).
						    { reflexivity. }
						    rewrite HInvUnfold.
						    apply andI.
						    - prove (((finite (BaseState 0) /\ (BaseState 0 c= R)) /\ total_function_on (BaseState 1) (BaseState 0) Tx) /\
						              functional_graph (BaseState 1)) /\
						             graph_domain_subset (BaseState 1) (BaseState 0).
						      apply andI.
						      + prove ((finite (BaseState 0) /\ (BaseState 0 c= R)) /\ total_function_on (BaseState 1) (BaseState 0) Tx) /\
						              functional_graph (BaseState 1).
						        apply andI.
						        * prove (finite (BaseState 0) /\ (BaseState 0 c= R)) /\
						                total_function_on (BaseState 1) (BaseState 0) Tx.
						          apply andI.
							          - prove finite (BaseState 0) /\ (BaseState 0 c= R).
							             apply andI.
							             + (** finite (BaseState 0) **)
							                rewrite HBaseState0.
							                exact HBaseFfin.
							             + (** (BaseState 0) c= R **)
							                rewrite HBaseState0.
								                let t. assume HtF: t :e BaseF.
								                apply (UPairE t a b HtF (t :e R)).
								                - assume Hta: t = a. rewrite Hta. exact HaR.
								                - assume Htb: t = b. rewrite Htb. exact HbR.
							          - (** total_function_on (BaseState 1) (BaseState 0) Tx **)
							             rewrite HBaseState1.
							             rewrite HBaseState0.
						             apply (total_function_on_graph BaseF Tx (fun t:set => if t = a then U_a else U_b)).
						             let t. assume HtF: t :e BaseF.
						             claim Ht_cases: t = a \/ t = b.
						             { exact (UPairE t a b HtF). }
						             apply Ht_cases.
						             - assume Ht: t = a.
						               claim Hif: U_a = (fun u:set => if u = a then U_a else U_b) t.
						               { rewrite Ht at 1.
						                 symmetry.
						                 claim Haa: a = a.
						                 { reflexivity. }
						                 claim Hbeta: (fun u:set => if u = a then U_a else U_b) a = if a = a then U_a else U_b.
						                 { reflexivity. }
						                 rewrite Hbeta.
						                 rewrite (If_i_1 (a = a) U_a U_b Haa).
						                 reflexivity. }
						               rewrite <- Hif.
						               exact HU_aTx.
						             - assume Ht: t = b.
						               claim Hbna: ~(b = a).
						               { assume Hba: b = a.
						                 apply HabNe.
						                 symmetry. exact Hba. }
						               claim Hif: U_b = (fun u:set => if u = a then U_a else U_b) t.
						               { rewrite Ht at 1.
						                 symmetry.
						                 claim Hbeta: (fun u:set => if u = a then U_a else U_b) b = if b = a then U_a else U_b.
						                 { reflexivity. }
						                 rewrite Hbeta.
						                 rewrite (If_i_0 (b = a) U_a U_b Hbna).
						                 reflexivity. }
						               rewrite <- Hif.
						               exact HU_bTx.
						        * (** functional_graph (BaseState 1) **)
						          rewrite HBaseState1.
						          exact (functional_graph_graph BaseF (fun t:set => if t = a then U_a else U_b)).
						      + (** graph_domain_subset (BaseState 1) (BaseState 0) **)
						        rewrite HBaseState1 at 1.
						        rewrite HBaseState0 at 1.
						        exact (graph_domain_subset_graph BaseF (fun t:set => if t = a then U_a else U_b)).
						    - (** nesting invariant for the base family **)
						      let p q.
						      assume HpF: p :e (BaseState 0).
						      assume HqF: q :e (BaseState 0).
						      assume Hpq: Rlt p q.
						      prove closure_of X Tx (apply_fun (BaseState 1) p) c= apply_fun (BaseState 1) q.
						      claim HpF0: p :e BaseF.
						      { rewrite <- HBaseState0.
						        exact HpF. }
						      claim HqF0: q :e BaseF.
						      { rewrite <- HBaseState0.
						        exact HqF. }
						      rewrite HBaseState1.
						      apply (UPairE p a b HpF0 (closure_of X Tx (apply_fun BaseG p) c= apply_fun BaseG q)).
						      + assume Hpa: p = a.
						        apply (UPairE q a b HqF0 (closure_of X Tx (apply_fun BaseG p) c= apply_fun BaseG q)).
						        * assume Hqa: q = a.
						          apply FalseE.
						          claim Hpqaa: Rlt a a.
						          { rewrite <- Hpa at 1.
						            rewrite <- Hqa at 1.
						            exact Hpq. }
						          exact ((not_Rlt_refl a HaR) Hpqaa).
						        * assume Hqb: q = b.
						          rewrite Hpa.
						          rewrite Hqb.
						          rewrite HBaseGa.
						          rewrite HBaseGb.
						          exact HclU_a_sub_U_b.
						      + assume Hpb: p = b.
						        apply (UPairE q a b HqF0 (closure_of X Tx (apply_fun BaseG p) c= apply_fun BaseG q)).
						        * assume Hqa: q = a.
						          apply FalseE.
						          claim Hpqba: Rlt b a.
						          { rewrite <- Hpb at 1.
						            rewrite <- Hqa at 1.
						            exact Hpq. }
						          exact (Hnltba Hpqba).
						        * assume Hqb: q = b.
						          apply FalseE.
						          claim Hpqbb: Rlt b b.
						          { rewrite <- Hpb at 1.
						            rewrite <- Hqb at 1.
						            exact Hpq. }
						          exact ((not_Rlt_refl b HbR) Hpqbb).
						  }
						  (** code-fiber selector agrees with any given witness (by injectivity). **)
						  claim Hcode_inj_eq: forall x z:set, x :e P -> z :e P -> code x = code z -> x = z.
						  { claim Hinj0: forall x z :e P, code x = code z -> x = z.
						    { apply Hcode_inj.
					      assume _ Hinj0'.
					      exact Hinj0'. }
					    let x. let z.
					    assume HxP: x :e P.
					    assume HzP: z :e P.
					    assume Heq: code x = code z.
					    exact (Hinj0 x HxP z HzP Heq). }
						  claim Hpnew_eq_of_code: forall n p:set, p :e P -> code p = n ->
						    (exists p0:set, p0 :e P /\ code p0 = n) -> pnew n = p.
						  { let n p. assume HpP: p :e P.
						    assume Hcodep: code p = n.
						    assume Hex: exists p0:set, p0 :e P /\ code p0 = n.
						    claim Hpnewpair: pnew n :e P /\ code (pnew n) = n.
						    { exact (Hpnew_spec n Hex). }
						    claim HpnewP: pnew n :e P.
						    { exact (andEL (pnew n :e P) (code (pnew n) = n) Hpnewpair). }
						    claim Hcodenew: code (pnew n) = n.
						    { exact (andER (pnew n :e P) (code (pnew n) = n) Hpnewpair). }
						    apply (Hcode_inj_eq (pnew n) p HpnewP HpP).
						    claim Hcodeeq: code (pnew n) = code p.
						    { rewrite Hcodenew.
						      rewrite <- Hcodep.
						      reflexivity. }
						    exact Hcodeeq. }
						  (** TeX §33 Step 1 (in progress): stage invariants for the nat_primrec construction. **)
						  claim HInvStep: forall n st:set, Inv st -> Inv (StepState n st).
						  { let n st.
						    assume HInvst: Inv st.
						    apply (xm (exists p:set, p :e P /\ code p = n)).
						    - assume Hex: exists p:set, p :e P /\ code p = n.
						      apply (xm (pnew n :e (st 0))).
						      + assume Hin: pnew n :e (st 0).
						        claim Hbeta: StepState n st =
						          if (exists p:set, p :e P /\ code p = n)
						          then (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						          else st.
						        { reflexivity. }
						        claim Houter: StepState n st =
						          if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st).
						        { rewrite Hbeta.
						          exact (If_i_1 (exists p:set, p :e P /\ code p = n)
						                   (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						                   st Hex). }
						        claim Heq: StepState n st = st.
						        { rewrite Houter.
						          exact (If_i_1 (pnew n :e (st 0)) st ((st 0) :\/: {pnew n}, Gext n st) Hin). }
						        rewrite Heq.
						        exact HInvst.
						      + assume Hnotin: ~(pnew n :e (st 0)).
						        (** Main Step 1 extension case: insert pnew n between lower/upper members via Ur_of and rebuild the graph on the enlarged domain. **)
						        claim Hbeta2: StepState n st =
						          if (exists p:set, p :e P /\ code p = n)
						          then (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						          else st.
						        { reflexivity. }
						        claim Houter2: StepState n st =
						          if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st).
						        { rewrite Hbeta2.
						          exact (If_i_1 (exists p:set, p :e P /\ code p = n)
						                   (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						                   st Hex). }
						        claim Heq2: StepState n st = ((st 0) :\/: {pnew n}, Gext n st).
						        { rewrite Houter2.
						          exact (If_i_0 (pnew n :e (st 0)) st ((st 0) :\/: {pnew n}, Gext n st) Hnotin). }
						        rewrite Heq2.
						        (** unpack Inv st (as a left-associated conjunction) **)
						        claim HInvUnfold2:
						          Inv st =
						            (finite (st 0) /\
						             (st 0 c= R) /\
						             total_function_on (st 1) (st 0) Tx /\ functional_graph (st 1) /\ graph_domain_subset (st 1) (st 0) /\
						               forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						                 closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q).
						        { reflexivity. }
						        claim HInvStExp:
						          finite (st 0) /\
						          (st 0 c= R) /\
						          total_function_on (st 1) (st 0) Tx /\ functional_graph (st 1) /\ graph_domain_subset (st 1) (st 0) /\
						            forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						              closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q.
						        { rewrite <- HInvUnfold2.
						          exact HInvst. }
						        (** HInvStExp parses left-associatively:
						           (((((finite /\ subR) /\ tot) /\ fun) /\ dom) /\ nest) **)
						        claim Hhead12345:
						          ((((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1)) /\
						            graph_domain_subset (st 1) (st 0)).
						        { exact (andEL
						                  ((((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1)) /\
						                    graph_domain_subset (st 1) (st 0))
						                  (forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						                     closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q)
						                  HInvStExp). }
						        claim Hnest:
						          forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						            closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q.
						        { exact (andER
						                  ((((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1)) /\
						                    graph_domain_subset (st 1) (st 0))
						                  (forall p q:set, p :e (st 0) -> q :e (st 0) -> Rlt p q ->
						                     closure_of X Tx (apply_fun (st 1) p) c= apply_fun (st 1) q)
						                  HInvStExp). }
						        claim Hhead1234:
						          (((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1)).
						        { exact (andEL
						                  (((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1))
						                  (graph_domain_subset (st 1) (st 0))
						                  Hhead12345). }
						        claim Hdom: graph_domain_subset (st 1) (st 0).
						        { exact (andER
						                  (((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx) /\ functional_graph (st 1))
						                  (graph_domain_subset (st 1) (st 0))
						                  Hhead12345). }
						        claim Hhead123:
						          ((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx).
						        { exact (andEL
						                  ((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx)
						                  (functional_graph (st 1))
						                  Hhead1234). }
						        claim Hfun: functional_graph (st 1).
						        { exact (andER
						                  ((finite (st 0) /\ (st 0 c= R)) /\ total_function_on (st 1) (st 0) Tx)
						                  (functional_graph (st 1))
						                  Hhead1234). }
						        claim Hhead12: finite (st 0) /\ (st 0 c= R).
						        { exact (andEL
						                  (finite (st 0) /\ (st 0 c= R))
						                  (total_function_on (st 1) (st 0) Tx)
						                  Hhead123). }
						        claim Htot: total_function_on (st 1) (st 0) Tx.
						        { exact (andER
						                  (finite (st 0) /\ (st 0 c= R))
						                  (total_function_on (st 1) (st 0) Tx)
						                  Hhead123). }
						        claim HfinF: finite (st 0).
						        { exact (andEL (finite (st 0)) (st 0 c= R) Hhead12). }
						        claim HFsubR0: st 0 c= R.
						        { exact (andER (finite (st 0)) (st 0 c= R) Hhead12). }
						        (** obtain Ur_of from normal_extend_nested_open_family_by_point **)
						        set F := (st 0).
						        set Uof := (fun p:set => apply_fun (st 1) p).
						        claim HUofTx: forall p:set, p :e F -> Uof p :e Tx.
						        { claim Hfunon: function_on (st 1) F Tx.
						          { exact (andEL (function_on (st 1) F Tx)
						                       (forall x:set, x :e F -> exists y:set, y :e Tx /\ (x,y) :e (st 1))
						                       Htot). }
						          let p. assume HpF: p :e F.
						          exact (Hfunon p HpF). }
						        claim HnestU: forall p q:set, p :e F -> q :e F -> Rlt p q -> closure_of X Tx (Uof p) c= Uof q.
						        { let p q. assume HpF: p :e F.
						          assume HqF: q :e F.
						          assume Hpq: Rlt p q.
						          exact (Hnest p q HpF HqF Hpq). }
						        claim HrP: pnew n :e P.
						        { exact (andEL (pnew n :e P) (code (pnew n) = n) (Hpnew_spec n Hex)). }
						        claim HrR: pnew n :e R.
						        { exact (HP_sub_R (pnew n) HrP). }
						        claim HexU: exists U:set,
						          U :e Tx /\
						          (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= U) /\
						          (forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx U c= Uof q0).
						        { exact (normal_extend_nested_open_family_by_point X Tx Hnorm F HfinF HFsubR0 Uof HUofTx HnestU (pnew n) HrR). }
							        claim HUr_of:
							          (Ur_of n st) :e Tx /\
							          (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st)) /\
							          (forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx (Ur_of n st) c= Uof q0).
							        { set Pred := (fun U:set =>
						            U :e Tx /\
						            (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= U) /\
						            (forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx U c= Uof q0)).
							          claim HexPred: exists U:set, Pred U.
							          { exact HexU. }
							          exact (Eps_i_ex Pred HexPred). }
							        (** destruct HUr_of (left-associative conjunction) **)
							        claim HUr_head:
							          (Ur_of n st) :e Tx /\
							          (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st)).
							        { exact (andEL
							                  ((Ur_of n st) :e Tx /\
							                   (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st)))
							                  (forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx (Ur_of n st) c= Uof q0)
							                  HUr_of). }
							        claim HUrTx: (Ur_of n st) :e Tx.
							        { exact (andEL
							                  ((Ur_of n st) :e Tx)
							                  (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st))
							                  HUr_head). }
							        claim HUrLower:
							          forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st).
							        { exact (andER
							                  ((Ur_of n st) :e Tx)
							                  (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st))
							                  HUr_head). }
							        claim HUrUpper:
							          forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx (Ur_of n st) c= Uof q0.
							        { exact (andER
							                  ((Ur_of n st) :e Tx /\
							                   (forall p0:set, p0 :e F -> Rlt p0 (pnew n) -> closure_of X Tx (Uof p0) c= (Ur_of n st)))
							                  (forall q0:set, q0 :e F -> Rlt (pnew n) q0 -> closure_of X Tx (Ur_of n st) c= Uof q0)
							                  HUr_of). }
							        (** prove Inv for the new tuple up to the nesting clause **)
							        claim HInvUnfoldNew:
							          Inv ((st 0) :\/: {pnew n}, Gext n st) =
							            (finite (((st 0) :\/: {pnew n}, Gext n st) 0) /\
							             (((st 0) :\/: {pnew n}, Gext n st) 0 c= R) /\
							             total_function_on (((st 0) :\/: {pnew n}, Gext n st) 1) (((st 0) :\/: {pnew n}, Gext n st) 0) Tx /\
							             functional_graph (((st 0) :\/: {pnew n}, Gext n st) 1) /\
							             graph_domain_subset (((st 0) :\/: {pnew n}, Gext n st) 1) (((st 0) :\/: {pnew n}, Gext n st) 0) /\
							               forall p q:set, p :e (((st 0) :\/: {pnew n}, Gext n st) 0) ->
							                 q :e (((st 0) :\/: {pnew n}, Gext n st) 0) -> Rlt p q ->
							                   closure_of X Tx (apply_fun (((st 0) :\/: {pnew n}, Gext n st) 1) p) c=
							                     apply_fun (((st 0) :\/: {pnew n}, Gext n st) 1) q).
							        { reflexivity. }
							        rewrite HInvUnfoldNew.
							        claim Htmp0: ((st 0) :\/: {pnew n}, Gext n st) 0 = ((st 0) :\/: {pnew n}).
							        { exact (tuple_2_0_eq ((st 0) :\/: {pnew n}) (Gext n st)). }
							        claim Htmp1: ((st 0) :\/: {pnew n}, Gext n st) 1 = (Gext n st).
							        { exact (tuple_2_1_eq ((st 0) :\/: {pnew n}) (Gext n st)). }
							        claim HFdef: (st 0) = F.
							        { reflexivity. }
							        rewrite Htmp0.
							        rewrite Htmp1.
							        rewrite HFdef.
							        claim HGextDef:
							          Gext n st =
							            graph (F :\/: {pnew n})
							              (fun p:set => if p = pnew n then Ur_of n st else apply_fun (st 1) p).
							        { reflexivity. }
							        apply andI.
							        - prove ((((finite (F :\/: {pnew n}) /\ ((F :\/: {pnew n}) c= R)) /\
							                 total_function_on (Gext n st) (F :\/: {pnew n}) Tx) /\
							                functional_graph (Gext n st)) /\
							               graph_domain_subset (Gext n st) (F :\/: {pnew n})).
							          apply andI.
							          + prove (((finite (F :\/: {pnew n}) /\ ((F :\/: {pnew n}) c= R)) /\
							                   total_function_on (Gext n st) (F :\/: {pnew n}) Tx) /\
							                  functional_graph (Gext n st)).
							            apply andI.
							            * prove ((finite (F :\/: {pnew n}) /\ ((F :\/: {pnew n}) c= R)) /\
							                     total_function_on (Gext n st) (F :\/: {pnew n}) Tx).
							              apply andI.
							              - prove finite (F :\/: {pnew n}) /\ ((F :\/: {pnew n}) c= R).
							                 apply andI.
							                 - exact (binunion_finite F HfinF {pnew n} (Sing_finite (pnew n))).
							                 - let x. assume Hx: x :e (F :\/: {pnew n}).
							                    claim Hx_cases: x :e F \/ x :e {pnew n}.
							                    { exact (binunionE F {pnew n} x Hx). }
							                    apply Hx_cases.
							                    - assume HxF: x :e F.
							                      exact (HFsubR0 x HxF).
							                    - assume Hxr: x :e {pnew n}.
							                      claim Hxeq: x = pnew n.
							                      { exact (SingE (pnew n) x Hxr). }
							                      rewrite Hxeq.
							                      exact HrR.
							              - (** total_function_on for the extended graph **)
							                 rewrite HGextDef.
							                 apply (total_function_on_graph (F :\/: {pnew n}) Tx
							                   (fun p:set => if p = pnew n then Ur_of n st else apply_fun (st 1) p)).
							                 let p. assume Hp: p :e (F :\/: {pnew n}).
							                 claim Hbeta_if:
							                   (fun p0:set => if p0 = pnew n then Ur_of n st else apply_fun (st 1) p0) p =
							                     (if p = pnew n then Ur_of n st else apply_fun (st 1) p).
							                 { reflexivity. }
							                 rewrite Hbeta_if.
							                 claim Hp_cases: p :e F \/ p :e {pnew n}.
							                 { exact (binunionE F {pnew n} p Hp). }
							                 apply Hp_cases.
							                 - assume HpF: p :e F.
							                   apply (xm (p = pnew n)).
							                   + assume Heq: p = pnew n.
							                     rewrite Heq.
							                     claim Hrfl: pnew n = pnew n.
							                     { reflexivity. }
							                     claim HIfEq1:
							                       (if pnew n = pnew n then Ur_of n st else apply_fun (st 1) (pnew n)) = Ur_of n st.
							                     { exact (If_i_1 (pnew n = pnew n) (Ur_of n st) (apply_fun (st 1) (pnew n)) Hrfl). }
							                     rewrite HIfEq1.
							                     exact HUrTx.
							                   + assume Hneq: ~(p = pnew n).
							                     claim HIfEq:
							                       (if p = pnew n then Ur_of n st else apply_fun (st 1) p) = apply_fun (st 1) p.
							                     { exact (If_i_0 (p = pnew n) (Ur_of n st) (apply_fun (st 1) p) Hneq). }
							                     rewrite HIfEq.
							                     exact (HUofTx p HpF).
							                 - assume Hpr: p :e {pnew n}.
							                   claim Hpeq: p = pnew n.
							                   { exact (SingE (pnew n) p Hpr). }
								                   rewrite Hpeq.
								                   claim Hrfl: pnew n = pnew n.
								                   { reflexivity. }
								                   claim HIfEq1b:
								                     (if pnew n = pnew n then Ur_of n st else apply_fun (st 1) (pnew n)) = Ur_of n st.
								                   { exact (If_i_1 (pnew n = pnew n) (Ur_of n st) (apply_fun (st 1) (pnew n)) Hrfl). }
								                   rewrite HIfEq1b.
								                   exact HUrTx.
							            * (** functional_graph for the extended graph **)
							              rewrite HGextDef.
							              exact (functional_graph_graph (F :\/: {pnew n})
							                       (fun p:set => if p = pnew n then Ur_of n st else apply_fun (st 1) p)).
							          + (** graph_domain_subset for the extended graph **)
							            rewrite HGextDef.
							            exact (graph_domain_subset_graph (F :\/: {pnew n})
							                     (fun p:set => if p = pnew n then Ur_of n st else apply_fun (st 1) p)).
								        - let p q.
								          assume Hp: p :e (F :\/: {pnew n}).
								          assume Hq: q :e (F :\/: {pnew n}).
								          assume Hpq: Rlt p q.
								          (** rewrite apply_fun of the graph-defined extension **)
								          rewrite HGextDef.
								          claim Hap_p:
								            apply_fun (graph (F :\/: {pnew n})
								              (fun p0:set => if p0 = pnew n then Ur_of n st else apply_fun (st 1) p0)) p =
								              (if p = pnew n then Ur_of n st else apply_fun (st 1) p).
								          { exact (apply_fun_graph (F :\/: {pnew n})
								                     (fun p0:set => if p0 = pnew n then Ur_of n st else apply_fun (st 1) p0) p Hp). }
								          claim Hap_q:
								            apply_fun (graph (F :\/: {pnew n})
								              (fun p0:set => if p0 = pnew n then Ur_of n st else apply_fun (st 1) p0)) q =
								              (if q = pnew n then Ur_of n st else apply_fun (st 1) q).
								          { exact (apply_fun_graph (F :\/: {pnew n})
								                     (fun p0:set => if p0 = pnew n then Ur_of n st else apply_fun (st 1) p0) q Hq). }
								          rewrite Hap_p.
								          rewrite Hap_q.
								          claim Hp_cases: p :e F \/ p :e {pnew n}.
								          { exact (binunionE F {pnew n} p Hp). }
								          claim Hq_cases: q :e F \/ q :e {pnew n}.
								          { exact (binunionE F {pnew n} q Hq). }
								          apply Hp_cases.
								          - assume HpF: p :e F.
								            apply Hq_cases.
								            + assume HqF: q :e F.
								              (** both p and q are from the old domain **)
								              claim Hpneq: ~(p = pnew n).
								              { assume Heq: p = pnew n.
								                apply Hnotin.
								                claim HpnewInF: pnew n :e F.
								                { claim Heq': pnew n = p.
								                  { symmetry. exact Heq. }
								                  rewrite Heq'.
								                  exact HpF. }
								                exact HpnewInF. }
								              claim Hqneq: ~(q = pnew n).
								              { assume Heq: q = pnew n.
								                apply Hnotin.
								                claim HpnewInF: pnew n :e F.
								                { claim Heq': pnew n = q.
								                  { symmetry. exact Heq. }
								                  rewrite Heq'.
								                  exact HqF. }
								                exact HpnewInF. }
								              claim Hifp:
								                (if p = pnew n then Ur_of n st else apply_fun (st 1) p) = apply_fun (st 1) p.
								              { exact (If_i_0 (p = pnew n) (Ur_of n st) (apply_fun (st 1) p) Hpneq). }
								              claim Hifq:
								                (if q = pnew n then Ur_of n st else apply_fun (st 1) q) = apply_fun (st 1) q.
								              { exact (If_i_0 (q = pnew n) (Ur_of n st) (apply_fun (st 1) q) Hqneq). }
								              rewrite Hifp.
								              rewrite Hifq.
								              exact (Hnest p q HpF HqF Hpq).
								            + assume Hqr: q :e {pnew n}.
								              claim Hqeq: q = pnew n.
								              { exact (SingE (pnew n) q Hqr). }
								              rewrite Hqeq.
								              claim Hrfl: pnew n = pnew n.
								              { reflexivity. }
								              claim Hifq:
								                (if pnew n = pnew n then Ur_of n st else apply_fun (st 1) (pnew n)) = Ur_of n st.
								              { exact (If_i_1 (pnew n = pnew n) (Ur_of n st) (apply_fun (st 1) (pnew n)) Hrfl). }
								              rewrite Hifq.
								              claim Hpneq: ~(p = pnew n).
								              { assume Heq: p = pnew n.
								                apply Hnotin.
								                claim HpnewInF: pnew n :e F.
								                { claim Heq': pnew n = p.
								                  { symmetry. exact Heq. }
								                  rewrite Heq'.
								                  exact HpF. }
								                exact HpnewInF. }
								              claim Hifp:
								                (if p = pnew n then Ur_of n st else apply_fun (st 1) p) = apply_fun (st 1) p.
								              { exact (If_i_0 (p = pnew n) (Ur_of n st) (apply_fun (st 1) p) Hpneq). }
								              rewrite Hifp.
								              claim Hpq': Rlt p (pnew n).
								              { rewrite <- Hqeq.
								                exact Hpq. }
								              exact (HUrLower p HpF Hpq').
								          - assume Hpr: p :e {pnew n}.
								            claim Hpeq: p = pnew n.
								            { exact (SingE (pnew n) p Hpr). }
								            rewrite Hpeq.
								            apply Hq_cases.
								            + assume HqF: q :e F.
								              claim Hrfl: pnew n = pnew n.
								              { reflexivity. }
								              claim Hifp:
								                (if pnew n = pnew n then Ur_of n st else apply_fun (st 1) (pnew n)) = Ur_of n st.
								              { exact (If_i_1 (pnew n = pnew n) (Ur_of n st) (apply_fun (st 1) (pnew n)) Hrfl). }
								              rewrite Hifp.
								              claim Hqneq: ~(q = pnew n).
								              { assume Heq: q = pnew n.
								                apply Hnotin.
								                claim HpnewInF: pnew n :e F.
								                { claim Heq': pnew n = q.
								                  { symmetry. exact Heq. }
								                  rewrite Heq'.
								                  exact HqF. }
								                exact HpnewInF. }
								              claim Hifq:
								                (if q = pnew n then Ur_of n st else apply_fun (st 1) q) = apply_fun (st 1) q.
								              { exact (If_i_0 (q = pnew n) (Ur_of n st) (apply_fun (st 1) q) Hqneq). }
								              rewrite Hifq.
								              claim Hpq': Rlt (pnew n) q.
								              { rewrite <- Hpeq.
								                exact Hpq. }
								              exact (HUrUpper q HqF Hpq').
									            + assume Hqr: q :e {pnew n}.
									              claim Hqeq: q = pnew n.
									              { exact (SingE (pnew n) q Hqr). }
									              apply FalseE.
									              claim Hbad: Rlt (pnew n) (pnew n).
									              { rewrite <- Hqeq at 2.
									                rewrite <- Hpeq at 1.
									                exact Hpq. }
									              exact (not_Rlt_refl (pnew n) HrR Hbad).
						    - assume Hnone: ~(exists p:set, p :e P /\ code p = n).
						      claim Hbeta: StepState n st =
						        if (exists p:set, p :e P /\ code p = n)
						        then (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						        else st.
						      { reflexivity. }
						      claim Heq: StepState n st = st.
						      { rewrite Hbeta.
						        exact (If_i_0 (exists p:set, p :e P /\ code p = n)
						                 (if (pnew n :e (st 0)) then st else ((st 0) :\/: {pnew n}, Gext n st))
						                 st Hnone). }
						      rewrite Heq.
						      exact HInvst. }
						  claim HInvAll: forall n:set, nat_p n -> Inv (State n).
						  { let n. assume HnNat: nat_p n.
						    claim Hbase: Inv (State 0).
						    { claim H0: State 0 = BaseState.
						      { exact (nat_primrec_0 BaseState StepState). }
						      rewrite H0.
						      exact HInvBase. }
						    claim Hstep: forall k:set, nat_p k -> Inv (State k) -> Inv (State (ordsucc k)).
						    { let k. assume HkNat: nat_p k.
						      assume HInvk: Inv (State k).
						      claim HS: State (ordsucc k) = StepState k (State k).
						      { exact (nat_primrec_S BaseState StepState k HkNat). }
						      rewrite HS.
						      exact (HInvStep k (State k) HInvk). }
						    exact (nat_ind (fun k:set => Inv (State k)) Hbase Hstep n HnNat). }
							  (** Step 2–4 (TeX): extend U_p to all rationals, define f(x)=inf Q(x), prove endpoints and continuity. **)
								  (** Step 2: define U_Q on all rationals by empty below a and X above b. **)
								  set U_Q := (fun p:set =>
								    if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p)).
							  (** Step 3: Q(x) := {p ∈ Q | x ∈ U_p}. **)
							  set Qx := (fun x:set => {p :e rational_numbers | x :e U_Q p}).
							  (** Lower bounds of Qx(x), used to define inf as a least upper bound. **)
							  set LB := (fun x:set => {l :e R | forall p:set, p :e Qx x -> p :e R -> Rle l p}).
							  (** For each x, define f(x) as the lub of LB(x). **)
							  set fx := (fun x:set => Eps_i (fun r:set => R_lub (LB x) r)).
							  set f := graph X (fun x:set => fx x).

							  (** Basic helper: any p ∈ P appears in the domain at stage ordsucc(code p). **)
							  claim Hp_in_dom_succ_code: forall p:set, p :e P -> p :e Fof (ordsucc (code p)).
							  { let p. assume HpP: p :e P.
							    set n := code p.
								    claim HnO: n :e omega.
								    { exact (Hcode_in_omega p HpP). }
								    claim HnNat: nat_p n.
								    { exact (omega_nat_p n HnO). }
							    claim HStS: State (ordsucc n) = StepState n (State n).
							    { exact (nat_primrec_S BaseState StepState n HnNat). }
							    claim Hex: exists p0:set, p0 :e P /\ code p0 = n.
							    { witness p.
							      apply andI.
							      - exact HpP.
							      - reflexivity. }
								    claim Hcodep: code p = n.
								    { reflexivity. }
								    claim HpnewEq: pnew n = p.
								    { exact (Hpnew_eq_of_code n p HpP Hcodep Hex). }
							    (** show pnew n ∈ (StepState n (State n)) 0, then rewrite **)
							    apply (xm (pnew n :e ((State n) 0))).
							    - assume Hin: pnew n :e ((State n) 0).
							      claim Hbeta: StepState n (State n) =
							        if (exists p0:set, p0 :e P /\ code p0 = n)
							        then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							        else (State n).
							      { reflexivity. }
							      claim Houter: StepState n (State n) =
							        if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
							      { rewrite Hbeta.
							        exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
							                 (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							                 (State n)
							                 Hex). }
							      claim Heq: StepState n (State n) = State n.
							      { rewrite Houter.
							        exact (If_i_1 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hin). }
								      claim HFofDef: Fof (ordsucc n) = (State (ordsucc n)) 0.
								      { reflexivity. }
								      rewrite HFofDef.
								      rewrite HStS at 1.
								      rewrite Heq at 1.
								      rewrite <- HpnewEq at 1.
								      exact Hin.
							    - assume Hnotin: ~(pnew n :e ((State n) 0)).
							      claim Hbeta: StepState n (State n) =
							        if (exists p0:set, p0 :e P /\ code p0 = n)
							        then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							        else (State n).
							      { reflexivity. }
							      claim Houter: StepState n (State n) =
							        if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
							      { rewrite Hbeta.
							        exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
							                 (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							                 (State n)
							                 Hex). }
							      claim Heq: StepState n (State n) = (((State n) 0) :\/: {pnew n}, Gext n (State n)).
							      { rewrite Houter.
							        exact (If_i_0 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hnotin). }
								      claim HFofDef: Fof (ordsucc n) = (State (ordsucc n)) 0.
								      { reflexivity. }
								      rewrite HFofDef.
								      rewrite HStS at 1.
								      rewrite Heq at 1.
									      (** domain is ((State n)0 :\/: {pnew n}) **)
									      claim HpInSing: p :e {pnew n}.
									      { rewrite HpnewEq.
									        exact (SingI p). }
									      claim HdomEq: (((State n) 0) :\/: {pnew n}, Gext n (State n)) 0 = ((State n) 0) :\/: {pnew n}.
									      { exact (tuple_2_0_eq (((State n) 0) :\/: {pnew n}) (Gext n (State n))). }
									      rewrite HdomEq at 1.
									      exact (binunionI2 ((State n) 0) {pnew n} p HpInSing).
								  }

							  (** One-step preservation: once p is in the domain, its value does not change at the next stage. **)
							  claim Gof_preserve_old: forall n p:set, nat_p n -> p :e Fof n ->
							    apply_fun (Gof (ordsucc n)) p = apply_fun (Gof n) p.
							  { let n p.
							    assume HnNat: nat_p n.
							    assume HpF: p :e Fof n.
							    claim HStS: State (ordsucc n) = StepState n (State n).
							    { exact (nat_primrec_S BaseState StepState n HnNat). }
							    (** case split on whether StepState extends or not **)
							    apply (xm (exists p0:set, p0 :e P /\ code p0 = n)).
							    - assume Hex: exists p0:set, p0 :e P /\ code p0 = n.
							      apply (xm (pnew n :e ((State n) 0))).
							      + assume Hin: pnew n :e ((State n) 0).
							        claim Hbeta: StepState n (State n) =
							          if (exists p0:set, p0 :e P /\ code p0 = n)
							          then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							          else (State n).
							        { reflexivity. }
							        claim Houter: StepState n (State n) =
							          if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
							        { rewrite Hbeta.
							          exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
							                   (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							                   (State n)
							                   Hex). }
								        claim Heq: StepState n (State n) = State n.
								        { rewrite Houter.
								          exact (If_i_1 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hin). }
								        claim HGofS: Gof (ordsucc n) = (State (ordsucc n)) 1.
								        { reflexivity. }
								        claim HGofN: Gof n = (State n) 1.
								        { reflexivity. }
								        claim HStS1: (State (ordsucc n)) 1 = (StepState n (State n)) 1.
								        { rewrite HStS. reflexivity. }
								        claim Heq1: (StepState n (State n)) 1 = (State n) 1.
								        { rewrite Heq. reflexivity. }
								        rewrite HGofS at 1.
								        rewrite HGofN.
								        rewrite HStS1 at 1.
								        rewrite Heq1 at 1.
								        reflexivity.
							      + assume Hnotin: ~(pnew n :e ((State n) 0)).
							        claim Hbeta: StepState n (State n) =
							          if (exists p0:set, p0 :e P /\ code p0 = n)
							          then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							          else (State n).
							        { reflexivity. }
							        claim Houter: StepState n (State n) =
							          if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
							        { rewrite Hbeta.
							          exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
							                   (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							                   (State n)
							                   Hex). }
								        claim Heq: StepState n (State n) = (((State n) 0) :\/: {pnew n}, Gext n (State n)).
								        { rewrite Houter.
								          exact (If_i_0 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hnotin). }
								        claim HGofS: Gof (ordsucc n) = (State (ordsucc n)) 1.
								        { reflexivity. }
								        claim HGofN: Gof n = (State n) 1.
								        { reflexivity. }
								        claim HStS1: (State (ordsucc n)) 1 = (StepState n (State n)) 1.
								        { rewrite HStS. reflexivity. }
								        claim Heq1: (StepState n (State n)) 1 = Gext n (State n).
								        { rewrite Heq.
								          exact (tuple_2_1_eq (((State n) 0) :\/: {pnew n}) (Gext n (State n))). }
								        rewrite HGofS at 1.
								        rewrite HGofN.
								        rewrite HStS1 at 1.
								        rewrite Heq1 at 1.
								        (** p is an old domain element, so p ≠ pnew n here **)
								        claim HpDom': p :e ((State n) 0 :\/: {pnew n}).
								        { exact (binunionI1 ((State n) 0) {pnew n} p HpF). }
								        claim HpNe: ~(p = pnew n).
								        { assume HpEq: p = pnew n.
								          claim HpnewF: pnew n :e Fof n.
								          { rewrite <- HpEq.
								            exact HpF. }
								          claim HFofDef: Fof n = (State n) 0.
								          { reflexivity. }
								          claim HpnewDom: pnew n :e ((State n) 0).
								          { rewrite <- HFofDef.
								            exact HpnewF. }
								          apply Hnotin.
								          exact HpnewDom. }
								        claim HGextDef:
								          Gext n (State n) =
								            graph ((State n) 0 :\/: {pnew n})
								              (fun q:set => if q = pnew n then Ur_of n (State n) else apply_fun ((State n) 1) q).
								        { reflexivity. }
								        rewrite HGextDef at 1.
								        set gextfun := (fun q:set => if q = pnew n then Ur_of n (State n) else apply_fun ((State n) 1) q).
								        claim Happ: apply_fun (graph ((State n) 0 :\/: {pnew n}) gextfun) p = gextfun p.
								        { exact (apply_fun_graph ((State n) 0 :\/: {pnew n}) gextfun p HpDom'). }
								        rewrite Happ at 1.
								        claim Hgextfunp: gextfun p =
								          (if p = pnew n then Ur_of n (State n) else apply_fun ((State n) 1) p).
								        { reflexivity. }
								        rewrite Hgextfunp at 1.
								        claim Hif: (if p = pnew n then Ur_of n (State n) else apply_fun ((State n) 1) p)
								          = apply_fun ((State n) 1) p.
								        { exact (If_i_0 (p = pnew n) (Ur_of n (State n)) (apply_fun ((State n) 1) p) HpNe). }
								        rewrite Hif.
							        reflexivity.
							    - assume Hnone: ~(exists p0:set, p0 :e P /\ code p0 = n).
							      claim Hbeta: StepState n (State n) =
							        if (exists p0:set, p0 :e P /\ code p0 = n)
							        then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
							        else (State n).
							      { reflexivity. }
								      claim Heq: StepState n (State n) = State n.
								      { rewrite Hbeta.
								        exact (If_i_0 (exists p0:set, p0 :e P /\ code p0 = n)
								                 (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								                 (State n)
								                 Hnone). }
								      claim HGofS: Gof (ordsucc n) = (State (ordsucc n)) 1.
								      { reflexivity. }
								      claim HGofN: Gof n = (State n) 1.
								      { reflexivity. }
								      claim HStS1: (State (ordsucc n)) 1 = (StepState n (State n)) 1.
								      { rewrite HStS. reflexivity. }
								      claim Heq1: (StepState n (State n)) 1 = (State n) 1.
								      { rewrite Heq. reflexivity. }
								      rewrite HGofS at 1.
								      rewrite HGofN.
								      rewrite HStS1 at 1.
								      rewrite Heq1 at 1.
								      reflexivity. }

								  (** Domain monotonicity for the finite-stage construction. **)
								  claim Fof_mono_succ: forall n:set, nat_p n -> Fof n c= Fof (ordsucc n).
								  { let n. assume HnNat: nat_p n.
								    let p. assume HpF: p :e Fof n.
								    prove p :e Fof (ordsucc n).
								    claim HFofS: Fof (ordsucc n) = (State (ordsucc n)) 0.
								    { reflexivity. }
								    rewrite HFofS.
								    claim HStS: State (ordsucc n) = StepState n (State n).
								    { exact (nat_primrec_S BaseState StepState n HnNat). }
								    rewrite HStS at 1.
								    apply (xm (exists p0:set, p0 :e P /\ code p0 = n)).
								    - assume Hex: exists p0:set, p0 :e P /\ code p0 = n.
								      apply (xm (pnew n :e ((State n) 0))).
								      + assume Hin: pnew n :e ((State n) 0).
								        claim Hbeta: StepState n (State n) =
								          if (exists p0:set, p0 :e P /\ code p0 = n)
								          then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								          else (State n).
								        { reflexivity. }
								        claim Houter: StepState n (State n) =
								          if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
								        { rewrite Hbeta.
								          exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
								                   (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								                   (State n)
								                   Hex). }
								        claim Heq: StepState n (State n) = State n.
								        { rewrite Houter.
								          exact (If_i_1 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hin). }
								        rewrite Heq.
								        claim HFofN: Fof n = (State n) 0.
								        { reflexivity. }
								        rewrite <- HFofN at 1.
								        exact HpF.
								      + assume Hnotin: ~(pnew n :e ((State n) 0)).
								        claim Hbeta: StepState n (State n) =
								          if (exists p0:set, p0 :e P /\ code p0 = n)
								          then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								          else (State n).
								        { reflexivity. }
								        claim Houter: StepState n (State n) =
								          if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)).
								        { rewrite Hbeta.
								          exact (If_i_1 (exists p0:set, p0 :e P /\ code p0 = n)
								                   (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								                   (State n)
								                   Hex). }
								        claim Heq: StepState n (State n) = (((State n) 0) :\/: {pnew n}, Gext n (State n)).
								        { rewrite Houter.
								          exact (If_i_0 (pnew n :e ((State n) 0)) (State n) (((State n) 0) :\/: {pnew n}, Gext n (State n)) Hnotin). }
								        rewrite Heq.
								        claim HdomEq: (((State n) 0) :\/: {pnew n}, Gext n (State n)) 0 = ((State n) 0) :\/: {pnew n}.
								        { exact (tuple_2_0_eq (((State n) 0) :\/: {pnew n}) (Gext n (State n))). }
								        rewrite HdomEq at 1.
								        claim HFofN: Fof n = (State n) 0.
								        { reflexivity. }
								        claim HpDom: p :e ((State n) 0).
								        { rewrite <- HFofN at 1.
								          exact HpF. }
								        exact (binunionI1 ((State n) 0) {pnew n} p HpDom).
								    - assume Hnone: ~(exists p0:set, p0 :e P /\ code p0 = n).
								      claim Hbeta: StepState n (State n) =
								        if (exists p0:set, p0 :e P /\ code p0 = n)
								        then (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								        else (State n).
								      { reflexivity. }
								      claim Heq: StepState n (State n) = State n.
								      { rewrite Hbeta.
								        exact (If_i_0 (exists p0:set, p0 :e P /\ code p0 = n)
								                 (if (pnew n :e ((State n) 0)) then (State n) else (((State n) 0) :\/: {pnew n}, Gext n (State n)))
								                 (State n)
								                 Hnone). }
								      rewrite Heq.
								      claim HFofN: Fof n = (State n) 0.
								      { reflexivity. }
								      rewrite <- HFofN at 1.
								      exact HpF. }

								  (** Lift domain membership along addition. **)
								  claim Fof_increase_by_add: forall n k p:set, nat_p n -> nat_p k -> p :e Fof n -> p :e Fof (add_nat n k).
								  { let n k p.
								    assume HnNat: nat_p n.
								    assume HkNat: nat_p k.
								    assume HpF: p :e Fof n.
								    claim Hbase: p :e Fof (add_nat n 0).
								    { claim Hadd0: add_nat n 0 = n.
								      { exact (add_nat_0R n). }
								      rewrite Hadd0.
								      exact HpF. }
								    claim Hstep: forall t:set, nat_p t -> (p :e Fof (add_nat n t)) -> p :e Fof (add_nat n (ordsucc t)).
								    { let t. assume HtNat: nat_p t.
								      assume HtIH: p :e Fof (add_nat n t).
								      claim HaddS: add_nat n (ordsucc t) = ordsucc (add_nat n t).
								      { exact (add_nat_SR n t HtNat). }
								      claim HntNat: nat_p (add_nat n t).
								      { exact (add_nat_p n HnNat t HtNat). }
								      rewrite HaddS.
								      exact (Fof_mono_succ (add_nat n t) HntNat p HtIH). }
								    exact (nat_ind (fun t:set => p :e Fof (add_nat n t)) Hbase Hstep k HkNat). }

								  (** Lift graph values along addition (values are preserved for old domain elements). **)
								  claim Gof_preserve_add: forall n k p:set, nat_p n -> nat_p k -> p :e Fof n ->
								    apply_fun (Gof (add_nat n k)) p = apply_fun (Gof n) p.
								  { let n k p.
								    assume HnNat: nat_p n.
								    assume HkNat: nat_p k.
								    assume HpF: p :e Fof n.
								    claim Hbase: apply_fun (Gof (add_nat n 0)) p = apply_fun (Gof n) p.
								    { claim Hadd0: add_nat n 0 = n.
								      { exact (add_nat_0R n). }
								      rewrite Hadd0.
								      reflexivity. }
								    claim Hstep: forall t:set, nat_p t ->
								      (apply_fun (Gof (add_nat n t)) p = apply_fun (Gof n) p) ->
								      (apply_fun (Gof (add_nat n (ordsucc t))) p = apply_fun (Gof n) p).
								    { let t. assume HtNat: nat_p t.
								      assume HtIH: apply_fun (Gof (add_nat n t)) p = apply_fun (Gof n) p.
								      claim HaddS: add_nat n (ordsucc t) = ordsucc (add_nat n t).
								      { exact (add_nat_SR n t HtNat). }
								      claim HntNat: nat_p (add_nat n t).
								      { exact (add_nat_p n HnNat t HtNat). }
								      claim HpFnt: p :e Fof (add_nat n t).
								      { exact (Fof_increase_by_add n t p HnNat HtNat HpF). }
								      rewrite HaddS.
								      claim Hpres: apply_fun (Gof (ordsucc (add_nat n t))) p = apply_fun (Gof (add_nat n t)) p.
								      { exact (Gof_preserve_old (add_nat n t) p HntNat HpFnt). }
								      rewrite Hpres.
								      exact HtIH. }
								    exact (nat_ind (fun t:set => apply_fun (Gof (add_nat n t)) p = apply_fun (Gof n) p) Hbase Hstep k HkNat). }

								  (** The nesting property extracted from Inv at a given stage. **)
								  claim Inv_nesting_at: forall n p q:set, nat_p n -> p :e Fof n -> q :e Fof n -> Rlt p q ->
								    closure_of X Tx (apply_fun (Gof n) p) c= apply_fun (Gof n) q.
								  { let n p q.
								    assume HnNat: nat_p n.
								    assume HpF: p :e Fof n.
								    assume HqF: q :e Fof n.
								    assume Hpq: Rlt p q.
								    claim HInvStage: Inv (State n).
								    { exact (HInvAll n HnNat). }
								    apply (and6E (finite ((State n) 0))
								                  (((State n) 0 c= R))
								                  (total_function_on ((State n) 1) ((State n) 0) Tx)
								                  (functional_graph ((State n) 1))
								                  (graph_domain_subset ((State n) 1) ((State n) 0))
								                  (forall p0 q0:set, p0 :e ((State n) 0) -> q0 :e ((State n) 0) -> Rlt p0 q0 ->
								                    closure_of X Tx (apply_fun ((State n) 1) p0) c= apply_fun ((State n) 1) q0)
								                  HInvStage
								                  (closure_of X Tx (apply_fun (Gof n) p) c= apply_fun (Gof n) q)).
								    assume Hfin Hsub Htot Hfg Hgd Hnest.
								    claim HFofDef: Fof n = (State n) 0.
								    { reflexivity. }
								    claim HGofDef: Gof n = (State n) 1.
								    { reflexivity. }
								    claim HpDom: p :e ((State n) 0).
								    { rewrite <- HFofDef at 1.
								      exact HpF. }
								    claim HqDom: q :e ((State n) 0).
								    { rewrite <- HFofDef at 1.
								      exact HqF. }
								    rewrite HGofDef at 1.
								    rewrite HGofDef.
								    exact (Hnest p q HpDom HqDom Hpq). }

								  (** Closure nesting for U_Q on rationals inside the closed interval. **)
								  claim U_Q_closure_mono_I: forall p q:set,
								    p :e rational_numbers -> q :e rational_numbers ->
								    p :e I -> q :e I -> Rlt p q ->
								      closure_of X Tx (U_Q p) c= U_Q q.
								  { let p q.
								    assume HpQ: p :e rational_numbers.
								    assume HqQ: q :e rational_numbers.
								    assume HpI: p :e I.
								    assume HqI: q :e I.
								    assume Hpq: Rlt p q.
								    claim HpR: p :e R.
								    { exact (rational_numbers_in_R p HpQ). }
								    claim HqR: q :e R.
								    { exact (rational_numbers_in_R q HqQ). }
								    claim HpP0: p :e P0.
								    { exact (binintersectI rational_numbers I p HpQ HpI). }
								    claim HqP0: q :e P0.
								    { exact (binintersectI rational_numbers I q HqQ HqI). }
								    claim HpP: p :e P.
								    { exact (binunionI1 P0 (UPair a b) p HpP0). }
								    claim HqP: q :e P.
								    { exact (binunionI1 P0 (UPair a b) q HqP0). }

								    set np := ordsucc (code p).
								    set nq := ordsucc (code q).
								    claim HcodepO: code p :e omega.
								    { exact (Hcode_in_omega p HpP). }
								    claim HcodeqO: code q :e omega.
								    { exact (Hcode_in_omega q HqP). }
								    claim HnpNat: nat_p np.
								    { exact (omega_nat_p np (omega_ordsucc (code p) HcodepO)). }
								    claim HnqNat: nat_p nq.
								    { exact (omega_nat_p nq (omega_ordsucc (code q) HcodeqO)). }
								    set n := add_nat np nq.
								    claim HnNat: nat_p n.
								    { exact (add_nat_p np HnpNat nq HnqNat). }

								    claim HpDomNp: p :e Fof np.
								    { exact (Hp_in_dom_succ_code p HpP). }
								    claim HqDomNq: q :e Fof nq.
								    { exact (Hp_in_dom_succ_code q HqP). }
								    claim HpDomN: p :e Fof n.
								    { exact (Fof_increase_by_add np nq p HnpNat HnqNat HpDomNp). }
								    claim HnCom: add_nat np nq = add_nat nq np.
								    { exact (add_nat_com np HnpNat nq HnqNat). }
								    claim HqDomN': q :e Fof (add_nat nq np).
								    { exact (Fof_increase_by_add nq np q HnqNat HnpNat HqDomNq). }
								    claim HqDomN: q :e Fof n.
								    { rewrite HnCom at 1.
								      exact HqDomN'. }

								    (** relate U_Q p and U_Q q to stage-n values **)
								    claim Hpi: ~(Rlt p a) /\ ~(Rlt b p).
								    { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) p HpI). }
								    claim Hnpa: ~(Rlt p a).
								    { exact (andEL (~(Rlt p a)) (~(Rlt b p)) Hpi). }
								    claim Hnbp: ~(Rlt b p).
								    { exact (andER (~(Rlt p a)) (~(Rlt b p)) Hpi). }
								    claim Hqi: ~(Rlt q a) /\ ~(Rlt b q).
								    { exact (SepE2 R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) q HqI). }
								    claim Hnqa: ~(Rlt q a).
								    { exact (andEL (~(Rlt q a)) (~(Rlt b q)) Hqi). }
								    claim Hnbq: ~(Rlt b q).
								    { exact (andER (~(Rlt q a)) (~(Rlt b q)) Hqi). }

								    claim HUQp: U_Q p = apply_fun (Gof np) p.
								    { claim Hbeta: U_Q p =
								        if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								      { reflexivity. }
								      rewrite Hbeta.
								      claim Hstep1:
								        (if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p))
								          = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								      { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hnpa). }
								      rewrite Hstep1.
								      claim Hstep2:
								        (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) = apply_fun (Gof (ordsucc (code p))) p.
								      { exact (If_i_0 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hnbp). }
								      rewrite Hstep2.
								      reflexivity. }
								    claim HUQq: U_Q q = apply_fun (Gof nq) q.
								    { claim Hbeta: U_Q q =
								        if (Rlt q a) then Empty else (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								      { reflexivity. }
								      rewrite Hbeta.
								      claim Hstep1:
								        (if (Rlt q a) then Empty else (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q))
								          = (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								      { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
								      rewrite Hstep1.
								      claim Hstep2:
								        (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) = apply_fun (Gof (ordsucc (code q))) q.
								      { exact (If_i_0 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hnbq). }
								      rewrite Hstep2.
								      reflexivity. }

								    claim Hpn: apply_fun (Gof n) p = apply_fun (Gof np) p.
								    { exact (Gof_preserve_add np nq p HnpNat HnqNat HpDomNp). }
								    claim Hqn': apply_fun (Gof (add_nat nq np)) q = apply_fun (Gof nq) q.
								    { exact (Gof_preserve_add nq np q HnqNat HnpNat HqDomNq). }
								    claim Hqn: apply_fun (Gof n) q = apply_fun (Gof nq) q.
								    { rewrite HnCom at 1.
								      exact Hqn'. }

								    (** apply Inv nesting at stage n and rewrite back to U_Q **)
								    claim Hnest: closure_of X Tx (apply_fun (Gof n) p) c= apply_fun (Gof n) q.
								    { exact (Inv_nesting_at n p q HnNat HpDomN HqDomN Hpq). }
								    let x. assume Hx: x :e closure_of X Tx (U_Q p).
								    prove x :e U_Q q.
								    claim HUQpN: U_Q p = apply_fun (Gof n) p.
								    { rewrite HUQp.
								      symmetry. exact Hpn. }
								    claim HUQqN: U_Q q = apply_fun (Gof n) q.
								    { rewrite HUQq.
								      symmetry. exact Hqn. }
								    claim Hx': x :e closure_of X Tx (apply_fun (Gof n) p).
								    { rewrite <- HUQpN at 1.
								      exact Hx. }
								    claim HxIn: x :e apply_fun (Gof n) q.
								    { exact (Hnest x Hx'). }
								    rewrite HUQqN at 1.
								    exact HxIn. }

								  (** Key: U_Q p is open for each rational p. **)
								  claim HU_Q_open: forall p:set, p :e rational_numbers -> U_Q p :e Tx.
								  { let p. assume HpQ: p :e rational_numbers.
								    claim HpR: p :e R.
							    { exact (rational_numbers_in_R p HpQ). }
							    apply (xm (Rlt p a)).
								    - assume Hpa: Rlt p a.
								      claim Hbeta: U_Q p =
								        if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								      { reflexivity. }
								      claim HU: U_Q p = Empty.
								      { rewrite Hbeta.
								        exact (If_i_1 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hpa). }
								      rewrite HU at 1.
								      exact (topology_has_empty X Tx HTx).
							    - assume Hnpa: ~(Rlt p a).
							      apply (xm (Rlt b p)).
								      + assume Hbp: Rlt b p.
									        claim Hbeta: U_Q p =
									          if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								        { reflexivity. }
								        claim HU: U_Q p = X.
								        { rewrite Hbeta.
								          claim Hstep:
								            (if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p))
								              = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								          { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hnpa). }
								          rewrite Hstep.
								          exact (If_i_1 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hbp). }
								        rewrite HU at 1.
								        exact (topology_has_X X Tx HTx).
							      + assume Hnbp: ~(Rlt b p).
							        (** p is a rational in the closed interval [a,b], hence in P. **)
							        claim HpI: p :e I.
							        { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) p HpR
							                 (andI (~(Rlt p a)) (~(Rlt b p)) Hnpa Hnbp)). }
							        claim HpP0: p :e P0.
							        { exact (binintersectI rational_numbers I p HpQ HpI). }
							        claim HpP: p :e P.
							        { exact (binunionI1 P0 (UPair a b) p HpP0). }
							        claim HpDom: p :e Fof (ordsucc (code p)).
							        { exact (Hp_in_dom_succ_code p HpP). }
								        claim HcodepO: code p :e omega.
								        { exact (Hcode_in_omega p HpP). }
								        claim HstageNat: nat_p (ordsucc (code p)).
								        { exact (omega_nat_p (ordsucc (code p)) (omega_ordsucc (code p) HcodepO)). }
								        claim HInvStage: Inv (State (ordsucc (code p))).
								        { exact (HInvAll (ordsucc (code p)) HstageNat). }
								        (** extract total_function_on from Inv (State stage) **)
								        claim HtotState: total_function_on ((State (ordsucc (code p))) 1) ((State (ordsucc (code p))) 0) Tx.
								        { apply (and6E (finite ((State (ordsucc (code p))) 0))
								                      (((State (ordsucc (code p))) 0 c= R))
								                      (total_function_on ((State (ordsucc (code p))) 1) ((State (ordsucc (code p))) 0) Tx)
								                      (functional_graph ((State (ordsucc (code p))) 1))
								                      (graph_domain_subset ((State (ordsucc (code p))) 1) ((State (ordsucc (code p))) 0))
								                      (forall p0 q0:set, p0 :e ((State (ordsucc (code p))) 0) -> q0 :e ((State (ordsucc (code p))) 0) -> Rlt p0 q0 ->
								                        closure_of X Tx (apply_fun ((State (ordsucc (code p))) 1) p0) c= apply_fun ((State (ordsucc (code p))) 1) q0)
								                      HInvStage
								                      (total_function_on ((State (ordsucc (code p))) 1) ((State (ordsucc (code p))) 0) Tx)).
								          assume Hfin Hsub Htot Hfg Hgd Hnest.
								          exact Htot. }
								        claim Htot: total_function_on (Gof (ordsucc (code p))) (Fof (ordsucc (code p))) Tx.
								        { claim HGofDef: Gof (ordsucc (code p)) = (State (ordsucc (code p))) 1.
								          { reflexivity. }
								          claim HFofDef: Fof (ordsucc (code p)) = (State (ordsucc (code p))) 0.
								          { reflexivity. }
								          rewrite HGofDef.
								          rewrite HFofDef.
								          exact HtotState. }
							        (** use total_function_on to get U_Q p ∈ Tx, then rewrite the if-branches **)
							        claim Hbeta: U_Q p =
							          if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
							        { reflexivity. }
							        rewrite Hbeta.
							        claim Hif1: (if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p)
							          = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
							        { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hnpa). }
							        rewrite Hif1.
								        claim Hif2: (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p)
								          = apply_fun (Gof (ordsucc (code p))) p.
								        { exact (If_i_0 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hnbp). }
								        rewrite Hif2.
									        exact (total_function_on_apply_fun_in_Y (Gof (ordsucc (code p))) (Fof (ordsucc (code p))) Tx p Htot HpDom). }

							  (** Each fx x is indeed a real number (lub in R). **)
								  claim HfxRlub: forall x:set, x :e X -> R_lub (LB x) (fx x).
								  { let x. assume HxX: x :e X.
								    (** show LB x satisfies R_lub_exists prerequisites **)
								    claim HLB_nonempty: exists l0:set, l0 :e LB x.
								    { witness a.
								      claim HLBdef: LB x = {l :e R | forall p:set, p :e Qx x -> p :e R -> Rle l p}.
								      { reflexivity. }
								      rewrite HLBdef.
								      claim Hprop: forall p:set, p :e Qx x -> p :e R -> Rle a p.
								      { let p. assume HpQx: p :e Qx x.
								        assume HpR: p :e R.
								        claim HQxDef: Qx x = {p :e rational_numbers | x :e U_Q p}.
								        { reflexivity. }
								        claim HpQx': p :e {p :e rational_numbers | x :e U_Q p}.
								        { rewrite <- HQxDef.
								          exact HpQx. }
								        claim HxUp: x :e U_Q p.
								        { exact (SepE2 rational_numbers (fun p0:set => x :e U_Q p0) p HpQx'). }
								        apply (xm (Rlt p a)).
								        - assume Hpa: Rlt p a.
								          claim HUeq: U_Q p =
								            if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
								          { reflexivity. }
								          claim HUempty: U_Q p = Empty.
								          { rewrite HUeq.
								            exact (If_i_1 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hpa). }
									          claim HxEmpty: x :e Empty.
									          { rewrite <- HUempty at 1.
									            exact HxUp. }
									          exact (FalseE (EmptyE x HxEmpty) (Rle a p)).
								        - assume Hnpa: ~(Rlt p a).
								          exact (RleI a p HaR HpR Hnpa). }
								      exact (SepI R (fun l:set => forall p:set, p :e Qx x -> p :e R -> Rle l p) a HaR Hprop). }
							    claim HLB_in_R: forall l:set, l :e LB x -> l :e R.
							    { let l. assume Hl: l :e LB x.
							      exact (SepE1 R (fun l0:set => forall p:set, p :e Qx x -> p :e R -> Rle l0 p) l Hl). }
							    (** build a rational q0 with b < q0, so q0 ∈ Qx x and bounds LB x above **)
							    claim HbS: SNo b.
							    { exact (real_SNo b HbR). }
							    set bp1 := add_SNo b 1.
							    claim Hbp1R: bp1 :e R.
							    { exact (real_add_SNo b HbR 1 real_1). }
							    claim Hbinpm: b :e open_interval (add_SNo b (minus_SNo 1)) (add_SNo b 1).
							    { exact (real_in_open_interval_minus1_plus1 b HbR). }
							    claim HbinpmProp: Rlt (add_SNo b (minus_SNo 1)) b /\ Rlt b bp1.
							    { exact (SepE2 R (fun z : set => Rlt (add_SNo b (minus_SNo 1)) z /\ Rlt z (add_SNo b 1)) b Hbinpm). }
							    claim Hb_lt_bp1: Rlt b bp1.
							    { exact (andER (Rlt (add_SNo b (minus_SNo 1)) b) (Rlt b bp1) HbinpmProp). }
							    apply (rational_dense_between_reals b bp1 HbR Hbp1R Hb_lt_bp1).
							    let q0. assume Hq0pair. apply Hq0pair.
							    assume Hq0Q: q0 :e rational_numbers.
							    assume Hq0Prop: Rlt b q0 /\ Rlt q0 bp1.
							    claim Hq0R: q0 :e R.
							    { exact (rational_numbers_in_R q0 Hq0Q). }
								    claim Hbq0: Rlt b q0.
								    { exact (andEL (Rlt b q0) (Rlt q0 bp1) Hq0Prop). }
										    claim Hq0InQx: q0 :e Qx x.
										    { claim HQxDef: Qx x = {p :e rational_numbers | x :e U_Q p}.
											      { reflexivity. }
											      claim Hq0Sep: q0 :e {p :e rational_numbers | x :e U_Q p}.
											      { claim HxU: x :e U_Q q0.
											        { (** U_Q q0 = X since b<q0 **)
											          claim HUeq: U_Q q0 =
											            if (Rlt q0 a) then Empty else if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0.
											          { reflexivity. }
												          rewrite HUeq.
												          apply (xm (Rlt q0 a)).
												          - assume Hqa: Rlt q0 a.
												            claim HifEmpty:
												              (if (Rlt q0 a) then Empty else if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0) = Empty.
												            { exact (If_i_1 (Rlt q0 a) Empty (if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0) Hqa). }
												            rewrite HifEmpty at 1.
												            claim Hba: Rlt b a.
												            { exact (Rlt_tra b q0 a Hbq0 Hqa). }
												            exact (FalseE ((RleE_nlt a b Hab) Hba) (x :e Empty)).
												          - assume Hnqa: ~(Rlt q0 a).
												            claim HifStep:
												              (if (Rlt q0 a) then Empty else if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0)
												                = (if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0).
												            { exact (If_i_0 (Rlt q0 a) Empty (if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0) Hnqa). }
												            rewrite HifStep at 1.
												            claim HifX:
												              (if (Rlt b q0) then X else apply_fun (Gof (ordsucc (code q0))) q0) = X.
												            { exact (If_i_1 (Rlt b q0) X (apply_fun (Gof (ordsucc (code q0))) q0) Hbq0). }
												            rewrite HifX at 1.
												            exact HxX. }
											        exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) q0 Hq0Q HxU). }
										      rewrite HQxDef at 1.
										      exact Hq0Sep. }
							    claim HLB_upper: exists u:set, u :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l u.
							    { witness q0.
							      apply andI.
							      - exact Hq0R.
							      - let l. assume HlLB: l :e LB x. assume HlR: l :e R.
							        claim Hlprop: forall p:set, p :e Qx x -> p :e R -> Rle l p.
							        { exact (SepE2 R (fun l0:set => forall p:set, p :e Qx x -> p :e R -> Rle l0 p) l HlLB). }
							        exact (Hlprop q0 Hq0InQx Hq0R). }
							    (** choose lub using R_lub_exists and define fx x using Eps_i **)
							    claim Hexlub: exists r:set, R_lub (LB x) r.
							    { exact (R_lub_exists (LB x) HLB_nonempty HLB_in_R HLB_upper). }
							    exact (Eps_i_ex (fun r:set => R_lub (LB x) r) Hexlub). }

							  claim Hfx_in_R: forall x:set, x :e X -> fx x :e R.
							  { let x. assume HxX: x :e X.
							    exact (R_lub_in_R (LB x) (fx x) (HfxRlub x HxX)). }

								  (** f is a function X -> R, and continuous into R_standard_topology via open rays subbasis. **)
								  claim HfunXR: function_on f X R.
								  { let x. assume HxX: x :e X.
								    rewrite (apply_fun_graph X (fun x0:set => fx x0) x HxX).
								    exact (Hfx_in_R x HxX). }

							  claim HcontR: continuous_map X Tx R R_standard_topology f.
							  { set S := open_rays_subbasis R.
							    claim HS: subbasis_on R S.
							    { exact (open_rays_subbasis_is_subbasis R). }
							    claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
							    { rewrite open_rays_subbasis_for_order_topology_R.
							      rewrite standard_topology_is_order_topology.
							      reflexivity. }
							    rewrite <- Hgen.
							    apply (continuous_map_from_subbasis X Tx R S f HTx HfunXR HS).
							    let s. assume HsS: s :e S.
							    (** split s in the open rays subbasis **)
							    apply (binunionE' ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
							                      :\/:
							                      {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
							                     {R}
							                     s
							                     (preimage_of X f s :e Tx)).
							    - assume Hs0: s :e ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
							                        :\/:
							                        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}).
							      apply (binunionE' {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
							                        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}
							                        s
							                        (preimage_of X f s :e Tx)).
							      + assume Hsup: s :e {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}.
							        (** s = (a0,∞) **)
							        claim Hexa0: exists a0 :e R, s = open_ray_upper R a0.
							        { exact (SepE2 (Power R) (fun I:set => exists a0 :e R, I = open_ray_upper R a0) s Hsup). }
							        apply Hexa0.
							        let a0. assume Ha0pair.
							        claim Ha0R: a0 :e R.
							        { exact (andEL (a0 :e R) (s = open_ray_upper R a0) Ha0pair). }
							        claim Hseq: s = open_ray_upper R a0.
							        { exact (andER (a0 :e R) (s = open_ray_upper R a0) Ha0pair). }
							        rewrite Hseq.
							        (** show preimage is a union of complements of closures: ⋃_{q>a0} (X\\cl(U_q)) **)
							        set Qgt := {q :e rational_numbers | Rlt a0 q}.
							        set Fam := {X :\: closure_of X Tx (U_Q q) | q :e Qgt}.
							        claim HFamPow: Fam :e Power Tx.
							        { apply PowerI.
							          let U. assume HU: U :e Fam.
							          apply (ReplE_impred Qgt (fun q:set => X :\: closure_of X Tx (U_Q q)) U HU (U :e Tx)).
							          let q. assume HqQgt: q :e Qgt.
							          assume HUeq: U = X :\: closure_of X Tx (U_Q q).
							          rewrite HUeq.
							          claim HqQ: q :e rational_numbers.
							          { exact (SepE1 rational_numbers (fun q0:set => Rlt a0 q0) q HqQgt). }
							          claim HUopen: U_Q q :e Tx.
							          { exact (HU_Q_open q HqQ). }
							          claim HUsubX: U_Q q c= X.
							          { exact (topology_elem_subset X Tx (U_Q q) HTx HUopen). }
							          claim HclClosed: closed_in X Tx (closure_of X Tx (U_Q q)).
							          { exact (closure_is_closed X Tx (U_Q q) HTx HUsubX). }
							          exact (open_in_elem X Tx (X :\: closure_of X Tx (U_Q q))
							                             (open_of_closed_complement X Tx (closure_of X Tx (U_Q q)) HclClosed)). }
							        claim HpreEq: preimage_of X f (open_ray_upper R a0) = Union Fam.
							        { apply set_ext.
							          - let x. assume Hx: x :e preimage_of X f (open_ray_upper R a0).
							            prove x :e Union Fam.
							            claim HxX: x :e X.
							            { exact (SepE1 X (fun u:set => apply_fun f u :e open_ray_upper R a0) x Hx). }
							            claim HfxIn: apply_fun f x :e open_ray_upper R a0.
							            { exact (SepE2 X (fun u:set => apply_fun f u :e open_ray_upper R a0) x Hx). }
							            claim HfxR: apply_fun f x :e R.
							            { exact (HfunXR x HxX). }
							            claim HltRel: order_rel R a0 (apply_fun f x).
							            { exact (SepE2 R (fun y:set => order_rel R a0 y) (apply_fun f x) HfxIn). }
							            claim Hlt: Rlt a0 (apply_fun f x).
							            { exact (order_rel_R_implies_Rlt a0 (apply_fun f x) HltRel). }
							            (** choose rational q with a0 < q < f(x) **)
							            apply (rational_dense_between_reals a0 (apply_fun f x) Ha0R HfxR Hlt).
							            let q. assume Hqpair. apply Hqpair.
							            assume HqQ: q :e rational_numbers.
							            assume HqProp: Rlt a0 q /\ Rlt q (apply_fun f x).
							            claim Ha0q: Rlt a0 q.
							            { exact (andEL (Rlt a0 q) (Rlt q (apply_fun f x)) HqProp). }
							            claim Hqltfx: Rlt q (apply_fun f x).
							            { exact (andER (Rlt a0 q) (Rlt q (apply_fun f x)) HqProp). }
								            claim HqInQgt: q :e Qgt.
								            { exact (SepI rational_numbers (fun q0:set => Rlt a0 q0) q HqQ Ha0q). }
									            claim HclNot: x :e (X :\: closure_of X Tx (U_Q q)).
									            { claim Hnotcl: x /:e closure_of X Tx (U_Q q).
									              { assume Hxcl: x :e closure_of X Tx (U_Q q).
									              (** from x∈cl(U_q) we would get f(x) ≤ q, contradicting q < f(x) **)
									              claim Hfxlub: R_lub (LB x) (fx x).
									              { exact (HfxRlub x HxX). }
									              claim HfxEq: apply_fun f x = fx x.
									              { claim HfDef: f = graph X (fun x0:set => fx x0).
									                { reflexivity. }
									                rewrite HfDef at 1.
									                exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
										              claim Hqltfx_fx: Rlt q (fx x).
										              { rewrite <- HfxEq at 1.
										                exact Hqltfx. }
										              (** show fx x <= q from x∈cl(U_Q q) by a standard lower-bound argument **)
										              claim Hcore: (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x)).
										              { exact (andEL (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
										                           (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
										                           Hfxlub). }
										              claim HfxR: fx x :e R.
										              { exact (andEL (fx x :e R) (forall l:set, l :e LB x -> l :e R -> Rle l (fx x)) Hcore). }
										              claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
										              { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
										                           (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
										                           Hfxlub). }
										              claim HqR: q :e R.
										              { exact (rational_numbers_in_R q HqQ). }

										              (** any l ∈ LB x satisfies l ≤ b, since Qx x contains rationals arbitrarily close above b **)
										              claim HLB_le_b: forall l:set, l :e LB x -> l :e R -> Rle l b.
										              { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
										                apply (xm (Rlt b l)).
										                - assume Hbl: Rlt b l.
										                  apply (rational_dense_between_reals b l HbR HlR Hbl).
										                  let p. assume HpPair. apply HpPair.
										                  assume HpQ: p :e rational_numbers.
										                  assume HpProp: Rlt b p /\ Rlt p l.
										                  claim Hbp: Rlt b p.
										                  { exact (andEL (Rlt b p) (Rlt p l) HpProp). }
										                  claim Hpl: Rlt p l.
										                  { exact (andER (Rlt b p) (Rlt p l) HpProp). }
										                  claim HpR: p :e R.
										                  { exact (rational_numbers_in_R p HpQ). }
										                  claim Hnpa: ~(Rlt p a).
										                  { assume Hpa: Rlt p a.
										                    claim Hpb: Rlt p b.
										                    { exact (Rlt_Rle_tra p a b Hpa Hab). }
										                    claim Hbb: Rlt b b.
										                    { exact (Rlt_tra b p b Hbp Hpb). }
										                    exact (not_Rlt_refl b HbR Hbb). }
										                  claim HUeq: U_Q p =
										                    if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
										                  { reflexivity. }
										                  claim Hstep: (if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p)
										                    = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
										                  { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hnpa). }
										                  claim HUX: U_Q p = X.
										                  { rewrite HUeq.
										                    rewrite Hstep.
										                    exact (If_i_1 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hbp). }
										                  claim HxUp: x :e U_Q p.
										                  { rewrite HUX at 1.
										                    exact HxX. }
										                  claim HpQx: p :e Qx x.
										                  { exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) p HpQ HxUp). }
										                  claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
										                  { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
										                  claim Hlelp: Rle l p.
										                  { exact (HlProp p HpQx HpR). }
										                  claim Hcontra: False.
										                  { exact ((RleE_nlt l p Hlelp) Hpl). }
										                  exact (FalseE Hcontra (Rle l b)).
										                - assume Hnbl: ~(Rlt b l).
										                  exact (RleI l b HlR HbR Hnbl). }

										              claim Hfxleb: Rle (fx x) b.
										              { exact (HminLB b HbR HLB_le_b). }

										              (** q < fx x ≤ b, so q < b and hence q ∈ I once we also have q ≥ a **)
										              claim Hqltb: Rlt q b.
										              { exact (Rlt_Rle_tra q (fx x) b Hqltfx_fx Hfxleb). }
										              claim Hnbq: ~(Rlt b q).
										              { assume Hbq': Rlt b q.
										                claim Hbb: Rlt b b.
										                { exact (Rlt_tra b q b Hbq' Hqltb). }
										                exact (not_Rlt_refl b HbR Hbb). }
										              claim Hnqa: ~(Rlt q a).
										              { apply (xm (Rlt q a)).
										                - assume Hqa: Rlt q a.
										                  claim HUeq: U_Q q =
										                    if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q.
										                  { reflexivity. }
										                  claim HUempty: U_Q q = Empty.
										                  { rewrite HUeq.
										                    exact (If_i_1 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hqa). }
										                  claim Hclq: closure_of X Tx (U_Q q) = Empty.
										                  { rewrite HUempty.
										                    exact (closure_of_empty X Tx HTx). }
										                  claim HxE: x :e Empty.
										                  { rewrite <- Hclq at 1.
										                    exact Hxcl. }
										                  exact (FalseE (EmptyE x HxE) (~(Rlt q a))).
										                - assume Hnqa': ~(Rlt q a).
										                  exact Hnqa'. }

										              claim HqI: q :e I.
										              { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) q HqR
										                       (andI (~(Rlt q a)) (~(Rlt b q)) Hnqa Hnbq)). }

										              (** show q is an upper bound of LB x **)
										              claim Hub_q: forall l:set, l :e LB x -> l :e R -> Rle l q.
										              { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
										                apply (xm (Rlt q l)).
										                - assume Hql: Rlt q l.
										                  claim Hleb: Rle l b.
										                  { exact (HLB_le_b l HlLB HlR). }
										                  apply (rational_dense_between_reals q l HqR HlR Hql).
										                  let r. assume HrPair. apply HrPair.
										                  assume HrQ: r :e rational_numbers.
										                  assume HrProp: Rlt q r /\ Rlt r l.
										                  claim Hqr: Rlt q r.
										                  { exact (andEL (Rlt q r) (Rlt r l) HrProp). }
										                  claim Hrl: Rlt r l.
										                  { exact (andER (Rlt q r) (Rlt r l) HrProp). }
										                  claim HrR: r :e R.
										                  { exact (rational_numbers_in_R r HrQ). }
										                  claim Hrlb: Rlt r b.
										                  { exact (Rlt_Rle_tra r l b Hrl Hleb). }
										                  claim Hnbr: ~(Rlt b r).
										                  { assume Hbr: Rlt b r.
										                    claim Hbb: Rlt b b.
										                    { exact (Rlt_tra b r b Hbr Hrlb). }
										                    exact (not_Rlt_refl b HbR Hbb). }
										                  claim Hnra: ~(Rlt r a).
										                  { assume Hra: Rlt r a.
										                    claim Hqa: Rlt q a.
										                    { exact (Rlt_tra q r a Hqr Hra). }
										                    exact (Hnqa Hqa). }
										                  claim HrI: r :e I.
										                  { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) r HrR
										                           (andI (~(Rlt r a)) (~(Rlt b r)) Hnra Hnbr)). }
										                  claim HclSub: closure_of X Tx (U_Q q) c= U_Q r.
										                  { exact (U_Q_closure_mono_I q r HqQ HrQ HqI HrI Hqr). }
										                  claim HxUr: x :e U_Q r.
										                  { exact (HclSub x Hxcl). }
										                  claim HrQx: r :e Qx x.
										                  { exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) r HrQ HxUr). }
										                  claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
										                  { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
										                  claim Hlelr: Rle l r.
										                  { exact (HlProp r HrQx HrR). }
										                  claim Hcontra: False.
										                  { exact ((RleE_nlt l r Hlelr) Hrl). }
										                  exact (FalseE Hcontra (Rle l q)).
										                - assume Hnql: ~(Rlt q l).
										                  exact (RleI l q HlR HqR Hnql). }

										              claim Hfxleq: Rle (fx x) q.
										              { exact (HminLB q HqR Hub_q). }
										              exact ((RleE_nlt (fx x) q Hfxleq) Hqltfx_fx). }
										              exact (setminusI X (closure_of X Tx (U_Q q)) x HxX Hnotcl). }
							            claim HFam: (X :\: closure_of X Tx (U_Q q)) :e Fam.
							            { exact (ReplI Qgt (fun q0:set => X :\: closure_of X Tx (U_Q q0)) q HqInQgt). }
							            exact (UnionI Fam x (X :\: closure_of X Tx (U_Q q)) HclNot HFam).
							          - let x. assume Hx: x :e Union Fam.
							            prove x :e preimage_of X f (open_ray_upper R a0).
							            apply (UnionE_impred Fam x Hx).
							            let U. assume HxU: x :e U. assume HUin: U :e Fam.
							            apply (ReplE_impred Qgt (fun q:set => X :\: closure_of X Tx (U_Q q)) U HUin (x :e preimage_of X f (open_ray_upper R a0))).
								            let q. assume HqIn: q :e Qgt.
								            assume HUeq: U = X :\: closure_of X Tx (U_Q q).
								            claim HxUdiff: x :e X :\: closure_of X Tx (U_Q q).
								            { rewrite <- HUeq at 1.
								              exact HxU. }
								            claim HxX: x :e X.
								            { exact (setminusE1 X (closure_of X Tx (U_Q q)) x HxUdiff). }
								            claim HxNotCl: x /:e closure_of X Tx (U_Q q).
								            { exact (setminusE2 X (closure_of X Tx (U_Q q)) x HxUdiff). }
							            (** since x ∉ U_q, we have f(x) ≥ q, so in particular a0 < f(x) because a0 < q **)
							            claim HqQ: q :e rational_numbers.
							            { exact (SepE1 rational_numbers (fun q0:set => Rlt a0 q0) q HqIn). }
							            claim Ha0q: Rlt a0 q.
							            { exact (SepE2 rational_numbers (fun q0:set => Rlt a0 q0) q HqIn). }
							            claim HqR: q :e R.
							            { exact (rational_numbers_in_R q HqQ). }
								            claim HfxEq: apply_fun f x = fx x.
								            { claim HfDef: f = graph X (fun x0:set => fx x0).
								              { reflexivity. }
								              rewrite HfDef at 1.
								              exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
							            claim Hfxlub: R_lub (LB x) (fx x).
							            { exact (HfxRlub x HxX). }
							            (** from x ∉ U_Q q we show Rle q (fx x) **)
								            claim HQx_no_small: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle q p0.
								            { let p0. assume Hp0Qx: p0 :e Qx x. assume Hp0R: p0 :e R.
								              (** if p0<q then x∈U_p0 ⊆ U_q ⊆ cl(U_q), contradict x∉cl(U_q) **)
										              apply (xm (Rlt p0 q)).
										              - assume Hp0lt: Rlt p0 q.
										                apply FalseE.
										                (** show x :e closure_of X Tx (U_Q q), contradicting HxNotCl **)
										                claim Hp0Q: p0 :e rational_numbers.
										                { exact (SepE1 rational_numbers (fun p1:set => x :e U_Q p1) p0 Hp0Qx). }
										                claim HxUp0: x :e U_Q p0.
										                { exact (SepE2 rational_numbers (fun p1:set => x :e U_Q p1) p0 Hp0Qx). }
										                (** first show q ∈ I using p0<q and x∉cl(U_Q q) **)
										                claim HqQ': q :e rational_numbers.
										                { exact HqQ. }
										                claim HqR': q :e R.
										                { exact (rational_numbers_in_R q HqQ'). }
										                claim Hnqa: ~(Rlt q a).
										                { assume Hqa: Rlt q a.
										                  claim Hp0a: Rlt p0 a.
										                  { exact (Rlt_tra p0 q a Hp0lt Hqa). }
										                  claim HUeq: U_Q p0 =
										                    if (Rlt p0 a) then Empty else if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0.
										                  { reflexivity. }
										                  claim HUempty: U_Q p0 = Empty.
										                  { rewrite HUeq.
										                    exact (If_i_1 (Rlt p0 a) Empty (if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0) Hp0a). }
										                  claim HxE: x :e Empty.
										                  { rewrite <- HUempty at 1.
										                    exact HxUp0. }
										                  exact (EmptyE x HxE). }
										                claim Hnbq: ~(Rlt b q).
										                { assume Hbq: Rlt b q.
										                  claim HUeq: U_Q q =
										                    if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q.
										                  { reflexivity. }
										                  claim Hnq1: (if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q)
										                    = (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
										                  { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
										                  claim HUX: U_Q q = X.
										                  { rewrite HUeq.
										                    rewrite Hnq1.
										                    exact (If_i_1 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hbq). }
										                  claim Hclq: closure_of X Tx (U_Q q) = X.
										                  { rewrite HUX.
										                    exact (closure_of_space X Tx HTx). }
										                  claim Hxcl: x :e closure_of X Tx (U_Q q).
										                  { rewrite Hclq at 1.
										                    exact HxX. }
										                  exact (HxNotCl Hxcl). }
										                claim HqI: q :e I.
										                { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) q HqR'
										                         (andI (~(Rlt q a)) (~(Rlt b q)) Hnqa Hnbq)). }
										                (** now p0 ∈ I as well **)
										                claim Hp0R': p0 :e R.
										                { exact Hp0R. }
										                claim Hnp0a: ~(Rlt p0 a).
										                { assume Hp0a: Rlt p0 a.
										                  claim HUeq: U_Q p0 =
										                    if (Rlt p0 a) then Empty else if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0.
										                  { reflexivity. }
										                  claim HUempty: U_Q p0 = Empty.
										                  { rewrite HUeq.
										                    exact (If_i_1 (Rlt p0 a) Empty (if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0) Hp0a). }
										                  claim HxE: x :e Empty.
										                  { rewrite <- HUempty at 1.
										                    exact HxUp0. }
										                  exact (EmptyE x HxE). }
										                claim Hnbp0: ~(Rlt b p0).
										                { assume Hbp0: Rlt b p0.
										                  claim Hbq: Rlt b q.
										                  { exact (Rlt_tra b p0 q Hbp0 Hp0lt). }
										                  exact (Hnbq Hbq). }
										                claim Hp0I: p0 :e I.
										                { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) p0 Hp0R'
										                         (andI (~(Rlt p0 a)) (~(Rlt b p0)) Hnp0a Hnbp0)). }
										                (** closure nesting: cl(U_p0) ⊆ U_q **)
										                claim HclSub: closure_of X Tx (U_Q p0) c= U_Q q.
										                { exact (U_Q_closure_mono_I p0 q Hp0Q HqQ' Hp0I HqI Hp0lt). }
										                (** x ∈ U_p0 ⊆ cl(U_p0) ⊆ U_q ⊆ cl(U_q) **)
										                claim HUopen: U_Q p0 :e Tx.
										                { exact (HU_Q_open p0 Hp0Q). }
										                claim HUsubX: U_Q p0 c= X.
										                { exact (topology_elem_subset X Tx (U_Q p0) HTx HUopen). }
										                claim Hsubcl: U_Q p0 c= closure_of X Tx (U_Q p0).
										                { exact (subset_of_closure X Tx (U_Q p0) HTx HUsubX). }
										                claim Hxclp0: x :e closure_of X Tx (U_Q p0).
										                { exact (Hsubcl x HxUp0). }
										                claim HxUq: x :e U_Q q.
										                { exact (HclSub x Hxclp0). }
										                claim HUqOpen: U_Q q :e Tx.
										                { exact (HU_Q_open q HqQ'). }
										                claim HUqSubX: U_Q q c= X.
										                { exact (topology_elem_subset X Tx (U_Q q) HTx HUqOpen). }
										                claim Hxclq: x :e closure_of X Tx (U_Q q).
										                { exact ((subset_of_closure X Tx (U_Q q) HTx HUqSubX) x HxUq). }
										                exact (HxNotCl Hxclq).
										              - assume Hnlt: ~(Rlt p0 q).
										                exact (RleI q p0 HqR Hp0R Hnlt). }
									            claim HqInLB: q :e LB x.
									            { exact (SepI R (fun l:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0) q HqR HQx_no_small). }
								            claim Hub: Rle q (fx x).
								            { exact (andER (fx x :e R) (forall a1:set, a1 :e LB x -> a1 :e R -> Rle a1 (fx x))
							                           (andEL (fx x :e R /\ (forall a1:set, a1 :e LB x -> a1 :e R -> Rle a1 (fx x)))
							                                  (forall u:set, u :e R -> (forall a1:set, a1 :e LB x -> a1 :e R -> Rle a1 u) -> Rle (fx x) u)
							                                  Hfxlub)
							                           q HqInLB HqR). }
								            claim Ha0fx: Rlt a0 (fx x).
								            { exact (Rlt_Rle_tra a0 q (fx x) Ha0q Hub). }
										            claim Ha0fxrel: order_rel R a0 (apply_fun f x).
										            { rewrite HfxEq.
										              exact (Rlt_implies_order_rel_R a0 (fx x) Ha0fx). }
									            claim HfxIn: apply_fun f x :e open_ray_upper R a0.
									            { exact (SepI R (fun y:set => order_rel R a0 y) (apply_fun f x) (HfunXR x HxX) Ha0fxrel). }
									            exact (SepI X (fun u:set => apply_fun f u :e open_ray_upper R a0) x HxX HfxIn). }
							        rewrite HpreEq.
							        exact (topology_union_closed_pow X Tx Fam HTx HFamPow).
								      + assume Hslo: s :e {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}.
								        (** s = (-∞,b0) **)
								        claim Hexb0: exists b0 :e R, s = open_ray_lower R b0.
								        { exact (SepE2 (Power R) (fun I:set => exists b0 :e R, I = open_ray_lower R b0) s Hslo). }
								        apply Hexb0.
								        let b0. assume Hb0pair.
								        claim Hb0R: b0 :e R.
								        { exact (andEL (b0 :e R) (s = open_ray_lower R b0) Hb0pair). }
								        claim Hseq: s = open_ray_lower R b0.
								        { exact (andER (b0 :e R) (s = open_ray_lower R b0) Hb0pair). }
								        rewrite Hseq.

								        set Qlt := {q :e rational_numbers | Rlt q b0}.
								        set FamL := {U_Q q | q :e Qlt}.
								        claim HFamPow: FamL :e Power Tx.
								        { apply PowerI.
								          let U. assume HU: U :e FamL.
								          apply (ReplE_impred Qlt (fun q:set => U_Q q) U HU (U :e Tx)).
								          let q. assume HqQlt: q :e Qlt.
								          assume HUeq: U = U_Q q.
								          rewrite HUeq.
								          claim HqQ: q :e rational_numbers.
								          { exact (SepE1 rational_numbers (fun q0:set => Rlt q0 b0) q HqQlt). }
								          exact (HU_Q_open q HqQ). }

								        claim HpreEq: preimage_of X f (open_ray_lower R b0) = Union FamL.
								        { apply set_ext.
								          - let x. assume Hx: x :e preimage_of X f (open_ray_lower R b0).
								            prove x :e Union FamL.
								            claim HxX: x :e X.
								            { exact (SepE1 X (fun u:set => apply_fun f u :e open_ray_lower R b0) x Hx). }
								            claim HfxIn: apply_fun f x :e open_ray_lower R b0.
								            { exact (SepE2 X (fun u:set => apply_fun f u :e open_ray_lower R b0) x Hx). }
								            claim HfxR: apply_fun f x :e R.
								            { exact (HfunXR x HxX). }
								            claim HltRel: order_rel R (apply_fun f x) b0.
								            { exact (SepE2 R (fun y:set => order_rel R y b0) (apply_fun f x) HfxIn). }
								            claim Hlt: Rlt (apply_fun f x) b0.
								            { exact (order_rel_R_implies_Rlt (apply_fun f x) b0 HltRel). }
								            (** pick rational q with f(x) < q < b0 **)
								            apply (rational_dense_between_reals (apply_fun f x) b0 HfxR Hb0R Hlt).
								            let q. assume Hqpair. apply Hqpair.
								            assume HqQ: q :e rational_numbers.
								            assume HqProp: Rlt (apply_fun f x) q /\ Rlt q b0.
								            claim Hfxltq: Rlt (apply_fun f x) q.
								            { exact (andEL (Rlt (apply_fun f x) q) (Rlt q b0) HqProp). }
								            claim Hqltb0: Rlt q b0.
								            { exact (andER (Rlt (apply_fun f x) q) (Rlt q b0) HqProp). }

								            (** show x :e U_Q q by finding some p0 ∈ Qx x with p0 < q and using nesting **)
								            claim HfxEq: apply_fun f x = fx x.
								            { claim HfDef: f = graph X (fun x0:set => fx x0).
								              { reflexivity. }
								              rewrite HfDef at 1.
								              exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
								            claim Hfxlub: R_lub (LB x) (fx x).
								            { exact (HfxRlub x HxX). }
								            claim Hcore: (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x)).
								            { exact (andEL (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                         (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                         Hfxlub). }
								            claim HfxR': fx x :e R.
								            { exact (andEL (fx x :e R) (forall l:set, l :e LB x -> l :e R -> Rle l (fx x)) Hcore). }
								            claim HubLB: forall l:set, l :e LB x -> l :e R -> Rle l (fx x).
								            { exact (andER (fx x :e R) (forall l:set, l :e LB x -> l :e R -> Rle l (fx x)) Hcore). }
								            claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
								            { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                         (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                         Hfxlub). }
								            claim Hqltfx: Rlt (fx x) q.
								            { rewrite <- HfxEq at 1.
								              exact Hfxltq. }
								            (** q is not a lower bound, so obtain p0 ∈ Qx x with p0 < q **)
								            claim HqR: q :e R.
								            { exact (rational_numbers_in_R q HqQ). }
								            claim HnotLB: q /:e LB x.
								            { assume HqLB: q :e LB x.
								              claim Hle: Rle q (fx x).
								              { exact (HubLB q HqLB HqR). }
								              exact ((RleE_nlt q (fx x) Hle) Hqltfx). }
								            claim HnotForall: ~(forall p0:set, p0 :e Qx x -> p0 :e R -> Rle q p0).
								            { assume Hall: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle q p0.
								              claim HqLB: q :e LB x.
								              { exact (SepI R (fun l:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0) q HqR Hall). }
								              exact (HnotLB HqLB). }
								            apply (not_all_ex_demorgan_i (fun p0:set => p0 :e Qx x -> p0 :e R -> Rle q p0) HnotForall).
								            let p0. assume Hnp0.
								            claim Hnp0imp: ~(p0 :e Qx x -> p0 :e R -> Rle q p0).
								            { exact Hnp0. }
								            apply (not_imp (p0 :e Qx x) (p0 :e R -> Rle q p0) Hnp0imp).
								            assume Hp0Qx: p0 :e Qx x.
								            assume Hnimp2: ~(p0 :e R -> Rle q p0).
								            apply (not_imp (p0 :e R) (Rle q p0) Hnimp2).
								            assume Hp0R: p0 :e R.
								            assume Hnle: ~(Rle q p0).
								            (** show p0 < q by contradiction with totality **)
										            apply (xm (Rlt p0 q)).
										            + assume Hp0ltq: Rlt p0 q.
									              (** now show x ∈ U_Q q **)
									              claim Hp0Q: p0 :e rational_numbers.
									              { exact (SepE1 rational_numbers (fun p1:set => x :e U_Q p1) p0 Hp0Qx). }
									              claim HxUp0: x :e U_Q p0.
									              { exact (SepE2 rational_numbers (fun p1:set => x :e U_Q p1) p0 Hp0Qx). }
										              apply (xm (Rlt b q)).
										              * assume Hbq: Rlt b q.
									                (** U_Q q = X since b < q, and q < a would contradict a < b **)
									                claim Hnqa: ~(Rlt q a).
										                { assume Hqa: Rlt q a.
										                  claim Hba: Rlt b a.
										                  { exact (Rlt_tra b q a Hbq Hqa). }
										                  exact ((RleE_nlt a b Hab) Hba). }
									                claim HUeq: U_Q q =
									                  if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q.
									                { reflexivity. }
										                claim HUqX: U_Q q = X.
										                { rewrite HUeq.
										                  claim Hstep:
										                    (if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q)
										                    =
										                    (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
										                  { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
										                  rewrite Hstep.
										                  exact (If_i_1 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hbq). }
									                claim HxUq: x :e U_Q q.
									                { rewrite HUqX.
									                  exact HxX. }
									                claim HqInQlt: q :e Qlt.
									                { exact (SepI rational_numbers (fun q0:set => Rlt q0 b0) q HqQ Hqltb0). }
									                claim HqFam: U_Q q :e FamL.
									                { exact (ReplI Qlt (fun q0:set => U_Q q0) q HqInQlt). }
									                exact (UnionI FamL x (U_Q q) HxUq HqFam).
										              * assume Hnbq: ~(Rlt b q).
									                (** now q,p0 ∈ I and closure nesting gives U_Q p0 ⊆ cl(U_Q p0) ⊆ U_Q q **)
									                claim Hnqa: ~(Rlt q a).
									                { assume Hqa: Rlt q a.
									                  claim Hp0a: Rlt p0 a.
									                  { exact (Rlt_tra p0 q a Hp0ltq Hqa). }
									                  claim HUeq: U_Q p0 =
									                    if (Rlt p0 a) then Empty else if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0.
									                  { reflexivity. }
									                  claim HUempty: U_Q p0 = Empty.
									                  { rewrite HUeq.
									                    exact (If_i_1 (Rlt p0 a) Empty (if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0) Hp0a). }
									                  claim HxE: x :e Empty.
									                  { rewrite <- HUempty at 1.
									                    exact HxUp0. }
									                  exact (EmptyE x HxE). }
									                claim HqI: q :e I.
									                { exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) q HqR
									                              (andI (~(Rlt q a)) (~(Rlt b q)) Hnqa Hnbq)). }
									                claim Hp0I: p0 :e I.
									                { claim Hnp0a: ~(Rlt p0 a).
									                  { assume Hp0a: Rlt p0 a.
									                    claim HUeq: U_Q p0 =
									                      if (Rlt p0 a) then Empty else if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0.
									                    { reflexivity. }
									                    claim HUempty: U_Q p0 = Empty.
									                    { rewrite HUeq.
									                      exact (If_i_1 (Rlt p0 a) Empty (if (Rlt b p0) then X else apply_fun (Gof (ordsucc (code p0))) p0) Hp0a). }
									                    claim HxE: x :e Empty.
									                    { rewrite <- HUempty at 1.
									                      exact HxUp0. }
									                    exact (EmptyE x HxE). }
									                  claim Hnbp0: ~(Rlt b p0).
									                  { assume Hbp0: Rlt b p0.
									                    claim Hbq': Rlt b q.
									                    { exact (Rlt_tra b p0 q Hbp0 Hp0ltq). }
									                    exact (Hnbq Hbq'). }
									                  exact (SepI R (fun x0:set => ~(Rlt x0 a) /\ ~(Rlt b x0)) p0 Hp0R
									                           (andI (~(Rlt p0 a)) (~(Rlt b p0)) Hnp0a Hnbp0)). }
									                claim HclSub: closure_of X Tx (U_Q p0) c= U_Q q.
									                { exact (U_Q_closure_mono_I p0 q Hp0Q HqQ Hp0I HqI Hp0ltq). }
									                claim HUopen: U_Q p0 :e Tx.
									                { exact (HU_Q_open p0 Hp0Q). }
									                claim HUsubX: U_Q p0 c= X.
									                { exact (topology_elem_subset X Tx (U_Q p0) HTx HUopen). }
									                claim Hxclp0: x :e closure_of X Tx (U_Q p0).
									                { exact ((subset_of_closure X Tx (U_Q p0) HTx HUsubX) x HxUp0). }
									                claim HxUq: x :e U_Q q.
									                { exact (HclSub x Hxclp0). }
									                claim HqInQlt: q :e Qlt.
									                { exact (SepI rational_numbers (fun q0:set => Rlt q0 b0) q HqQ Hqltb0). }
									                claim HqFam: U_Q q :e FamL.
									                { exact (ReplI Qlt (fun q0:set => U_Q q0) q HqInQlt). }
									                exact (UnionI FamL x (U_Q q) HxUq HqFam).
										            + assume Hnlt: ~(Rlt p0 q).
									              claim Hle: Rle q p0.
									              { exact (RleI q p0 HqR Hp0R Hnlt). }
									              exact (FalseE (Hnle Hle) (x :e Union FamL)). 
								          - let x. assume Hx: x :e Union FamL.
								            prove x :e preimage_of X f (open_ray_lower R b0).
								            apply (UnionE_impred FamL x Hx).
								            let U. assume HxU: x :e U. assume HUin: U :e FamL.
								            apply (ReplE_impred Qlt (fun q:set => U_Q q) U HUin (x :e preimage_of X f (open_ray_lower R b0))).
								            let q. assume HqIn: q :e Qlt.
								            assume HUeq: U = U_Q q.
								            claim HqQ: q :e rational_numbers.
								            { exact (SepE1 rational_numbers (fun q0:set => Rlt q0 b0) q HqIn). }
								            claim Hqltb0: Rlt q b0.
								            { exact (SepE2 rational_numbers (fun q0:set => Rlt q0 b0) q HqIn). }
								            claim HqR: q :e R.
								            { exact (rational_numbers_in_R q HqQ). }
								            claim HxUq: x :e U_Q q.
								            { rewrite <- HUeq at 1.
								              exact HxU. }
								            claim HxX: x :e X.
								            { claim HUopen: U_Q q :e Tx.
								              { exact (HU_Q_open q HqQ). }
								              exact (topology_elem_subset X Tx (U_Q q) HTx HUopen x HxUq). }
								            claim HfxEq: apply_fun f x = fx x.
								            { claim HfDef: f = graph X (fun x0:set => fx x0).
								              { reflexivity. }
								              rewrite HfDef at 1.
								              exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
								            claim Hfxlub: R_lub (LB x) (fx x).
								            { exact (HfxRlub x HxX). }
								            claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
								            { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                         (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                         Hfxlub). }
								            claim HqUpper: forall l:set, l :e LB x -> l :e R -> Rle l q.
								            { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
								              claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
								              { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
								              (** q ∈ Qx x since x ∈ U_Q q **)
								              claim HqQx: q :e Qx x.
								              { exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) q HqQ HxUq). }
								              exact (HlProp q HqQx HqR). }
								            claim Hfxleq: Rle (fx x) q.
								            { exact (HminLB q HqR HqUpper). }
								            claim Hfxltb0: Rlt (apply_fun f x) b0.
								            { rewrite HfxEq.
								              exact (Rle_Rlt_tra (fx x) q b0 Hfxleq Hqltb0). }
								            claim HfxRel: order_rel R (apply_fun f x) b0.
								            { exact (Rlt_implies_order_rel_R (apply_fun f x) b0 Hfxltb0). }
								            exact (SepI X (fun u:set => apply_fun f u :e open_ray_lower R b0) x HxX
								                     (SepI R (fun y:set => order_rel R y b0) (apply_fun f x) (HfunXR x HxX) HfxRel)). }
								        rewrite HpreEq.
									        exact (topology_union_closed_pow X Tx FamL HTx HFamPow).
							      + exact Hs0.
							    - assume HsR: s :e {R}.
							      claim Hseq: s = R.
								      { exact (SingE R s HsR). }
								      rewrite Hseq.
								      claim HpreWhole: preimage_of X f R = X.
								      { exact (preimage_of_whole X R f HfunXR). }
								      rewrite HpreWhole.
								      exact (topology_has_X X Tx HTx).
							    - exact HsS. }

								  (** Now restrict the range to the closed interval I. **)
								  claim HimgI: forall x:set, x :e X -> apply_fun f x :e I.
								  { let x. assume HxX: x :e X.
								    (** show a <= f(x) <= b using the inf construction **)
								    claim HfxEq: apply_fun f x = fx x.
								    { claim HfDef: f = graph X (fun x0:set => fx x0).
								      { reflexivity. }
								      rewrite HfDef at 1.
								      exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
								    rewrite HfxEq at 1.

								    claim Hfxlub: R_lub (LB x) (fx x).
								    { exact (HfxRlub x HxX). }
								    claim Hcore: (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x)).
								    { exact (andEL (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                 (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                 Hfxlub). }
								    claim HubLB: forall l:set, l :e LB x -> l :e R -> Rle l (fx x).
								    { exact (andER (fx x :e R) (forall l:set, l :e LB x -> l :e R -> Rle l (fx x)) Hcore). }
								    claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
								    { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                 (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                 Hfxlub). }

								    (** lower bound: a <= fx x because a ∈ LB x **)
								    claim HaLB: a :e LB x.
								    { claim Hprop: forall p:set, p :e Qx x -> p :e R -> Rle a p.
								      { let p. assume HpQx: p :e Qx x. assume HpR: p :e R.
								        claim HQxDef: Qx x = {p0 :e rational_numbers | x :e U_Q p0}.
								        { reflexivity. }
								        claim HpSep: p :e {p0 :e rational_numbers | x :e U_Q p0}.
								        { rewrite <- HQxDef at 1.
								          exact HpQx. }
								        claim HxUp: x :e U_Q p.
								        { exact (SepE2 rational_numbers (fun p0:set => x :e U_Q p0) p HpSep). }
								        apply (xm (Rlt p a)).
								        - assume Hpa: Rlt p a.
								          claim HUeq: U_Q p =
								            if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
								          { reflexivity. }
								          claim HUempty: U_Q p = Empty.
								          { rewrite HUeq.
								            exact (If_i_1 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hpa). }
								          claim HxEmpty: x :e Empty.
								          { rewrite <- HUempty at 1.
								            exact HxUp. }
								          exact (FalseE (EmptyE x HxEmpty) (Rle a p)).
								        - assume Hnpa: ~(Rlt p a).
								          exact (RleI a p HaR HpR Hnpa). }
								      exact (SepI R (fun l:set => forall p:set, p :e Qx x -> p :e R -> Rle l p) a HaR Hprop). }
								    claim Hale: Rle a (fx x).
								    { exact (HubLB a HaLB HaR). }

								    (** upper bound: fx x <= b because any l>b is not a lower bound (choose p with b<p<l) **)
								    claim HLB_le_b: forall l:set, l :e LB x -> l :e R -> Rle l b.
								    { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
								      apply (xm (Rlt b l)).
								      - assume Hbl: Rlt b l.
								        (** pick rational p with b < p < l; since b<p, U_Q p = X, so p ∈ Qx x, contradict l being a lower bound **)
								        apply (rational_dense_between_reals b l HbR HlR Hbl).
								        let p. assume HpPair. apply HpPair.
								        assume HpQ: p :e rational_numbers.
								        assume HpProp: Rlt b p /\ Rlt p l.
								        claim Hbp: Rlt b p.
								        { exact (andEL (Rlt b p) (Rlt p l) HpProp). }
								        claim Hpl: Rlt p l.
								        { exact (andER (Rlt b p) (Rlt p l) HpProp). }
								        claim HpR: p :e R.
								        { exact (rational_numbers_in_R p HpQ). }
								        claim HUeq: U_Q p =
								          if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
								        { reflexivity. }
								        claim Hnpa: ~(Rlt p a).
								        { assume Hpa: Rlt p a.
								          claim Hpb: Rlt p b.
								          { exact (Rlt_Rle_tra p a b Hpa Hab). }
								          claim Hbb: Rlt b b.
								          { exact (Rlt_tra b p b Hbp Hpb). }
								          exact (not_Rlt_refl b HbR Hbb). }
								        claim Hstep: (if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p)
								          = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								        { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hnpa). }
								        claim HUX: U_Q p = X.
								        { rewrite HUeq.
								          rewrite Hstep.
								          exact (If_i_1 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hbp). }
								        claim HxUp: x :e U_Q p.
								        { rewrite HUX at 1.
								          exact HxX. }
								        claim HQxDef: Qx x = {p0 :e rational_numbers | x :e U_Q p0}.
								        { reflexivity. }
								        claim HpQx: p :e Qx x.
								        { rewrite HQxDef at 1.
								          exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) p HpQ HxUp). }
								        claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
								        { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
									        claim Hlelp: Rle l p.
									        { exact (HlProp p HpQx HpR). }
									        claim Hcontra: False.
									        { exact ((RleE_nlt l p Hlelp) Hpl). }
									        exact (FalseE Hcontra (Rle l b)).
								      - assume Hnbl: ~(Rlt b l).
								        exact (RleI l b HlR HbR Hnbl). }
									    claim Hleb: Rle (fx x) b.
									    { exact (HminLB b HbR HLB_le_b). }

									    (** package membership in [a,b] **)
									    claim Hnfxa: ~(Rlt (fx x) a).
									    { exact (RleE_nlt a (fx x) Hale). }
									    claim Hnbfx: ~(Rlt b (fx x)).
									    { exact (RleE_nlt (fx x) b Hleb). }
									    exact (SepI R (fun r:set => ~(Rlt r a) /\ ~(Rlt b r))
									               (fx x)
									               (Hfx_in_R x HxX)
									               (andI (~(Rlt (fx x) a)) (~(Rlt b (fx x))) Hnfxa Hnbfx)). }
							  claim HcontI: continuous_map X Tx I Ti f.
							  { exact (continuous_map_range_restrict X Tx R R_standard_topology f I HcontR HISubR HimgI). }

								  witness f.
								  apply andI.
								  - apply andI.
								    + exact HcontI.
								    + let x. assume HxA: x :e A.
								      claim HxX: x :e X.
								      { exact (HAsubX x HxA). }
								      claim HfxEq: apply_fun f x = fx x.
								      { claim HfDef: f = graph X (fun x0:set => fx x0).
								        { reflexivity. }
								        rewrite HfDef at 1.
								        exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
								      (** show fx x = a **)
								      claim HfxR: fx x :e R.
								      { exact (Hfx_in_R x HxX). }
								      claim Hfxlub: R_lub (LB x) (fx x).
								      { exact (HfxRlub x HxX). }
								      claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
								      { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                   (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                   Hfxlub). }
								      claim HfxI: fx x :e I.
								      { rewrite <- HfxEq at 1.
								        exact (HimgI x HxX). }
								      claim HfxIcore: ~(Rlt (fx x) a) /\ ~(Rlt b (fx x)).
								      { exact (SepE2 R (fun r:set => ~(Rlt r a) /\ ~(Rlt b r)) (fx x) HfxI). }
								      claim Hnfxa: ~(Rlt (fx x) a).
								      { exact (andEL (~(Rlt (fx x) a)) (~(Rlt b (fx x))) HfxIcore). }
								      claim Hale: Rle a (fx x).
								      { exact (RleI a (fx x) HaR HfxR Hnfxa). }

								      (** For x∈A, any rational q>a satisfies x∈U_Q q. **)
								      claim HxA_in_UQ_gt_a: forall q:set, q :e rational_numbers -> Rlt a q -> x :e U_Q q.
								      { let q. assume HqQ: q :e rational_numbers.
								        assume Haq: Rlt a q.
								        claim HqR: q :e R.
								        { exact (rational_numbers_in_R q HqQ). }
								        claim Hnqa: ~(Rlt q a).
								        { exact (not_Rlt_sym a q Haq). }
								        apply (xm (Rlt b q)).
								        - assume Hbq: Rlt b q.
								          (** U_Q q = X **)
								          claim HUeq: U_Q q =
								            if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q.
								          { reflexivity. }
								          claim Hstep: (if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q)
								            = (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								          { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
								          claim HUX: U_Q q = X.
								          { rewrite HUeq.
								            rewrite Hstep.
								            exact (If_i_1 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hbq). }
								          rewrite HUX.
								          exact HxX.
								        - assume Hnbq: ~(Rlt b q).
								          (** q ∈ I, then use Inv nesting between a and q at stage ordsucc(code q) **)
								          claim HqI: q :e I.
								          { exact (SepI R (fun r:set => ~(Rlt r a) /\ ~(Rlt b r)) q HqR
								                    (andI (~(Rlt q a)) (~(Rlt b q)) Hnqa Hnbq)). }
								          claim HqP0: q :e P0.
								          { exact (binintersectI rational_numbers I q HqQ HqI). }
								          claim HqP: q :e P.
								          { exact (binunionI1 P0 (UPair a b) q HqP0). }
								          set nq := ordsucc (code q).
								          claim HcodeqO: code q :e omega.
								          { exact (Hcode_in_omega q HqP). }
								          claim HnqNat: nat_p nq.
								          { exact (omega_nat_p nq (omega_ordsucc (code q) HcodeqO)). }
								          claim HqDom: q :e Fof nq.
								          { exact (Hp_in_dom_succ_code q HqP). }
								          (** a is in the base domain, hence in every later Fof **)
								          claim HSt0: State 0 = BaseState.
								          { exact (nat_primrec_0 BaseState StepState). }
								          claim HFof0: Fof 0 = BaseF.
								          { claim HFdef: Fof 0 = (State 0) 0.
								            { reflexivity. }
								            rewrite HFdef.
								            rewrite HSt0.
								            rewrite (tuple_2_0_eq BaseF BaseG).
								            reflexivity. }
								          claim HaF0: a :e Fof 0.
								          { rewrite HFof0.
								            exact (UPairI1 a b). }
								          claim HaFq': a :e Fof (add_nat 0 nq).
								          { exact (Fof_increase_by_add 0 nq a nat_0 HnqNat HaF0). }
								          claim Hadd0: add_nat 0 nq = nq.
								          { exact (add_nat_0L nq HnqNat). }
								          claim HaDom: a :e Fof nq.
								          { rewrite <- Hadd0 at 1.
								            exact HaFq'. }
								          claim Hnest: closure_of X Tx (apply_fun (Gof nq) a) c= apply_fun (Gof nq) q.
								          { exact (Inv_nesting_at nq a q HnqNat HaDom HqDom Haq). }

								          (** rewrite stage values: apply_fun(Gof nq) a = U_a and apply_fun(Gof nq) q = U_Q q **)
								          claim HGof0: Gof 0 = BaseG.
								          { claim HGdef: Gof 0 = (State 0) 1.
								            { reflexivity. }
								            rewrite HGdef.
								            rewrite HSt0.
								            rewrite (tuple_2_1_eq BaseF BaseG).
								            reflexivity. }
								          claim HGa0: apply_fun (Gof 0) a = U_a.
								          { rewrite HGof0.
								            exact HBaseGa. }
								          claim HGa: apply_fun (Gof nq) a = U_a.
								          { claim Hpres: apply_fun (Gof (add_nat 0 nq)) a = apply_fun (Gof 0) a.
								            { exact (Gof_preserve_add 0 nq a nat_0 HnqNat HaF0). }
								            rewrite <- Hadd0 at 1.
								            rewrite Hpres.
								            exact HGa0. }
								          claim HUQq: U_Q q = apply_fun (Gof nq) q.
								          { claim Hbeta: U_Q q =
								              if (Rlt q a) then Empty else (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								            { reflexivity. }
								            rewrite Hbeta.
								            claim Hstep1: (if (Rlt q a) then Empty else (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q))
								              = (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								            { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
								            rewrite Hstep1.
								            claim Hstep2: (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) =
								              apply_fun (Gof (ordsucc (code q))) q.
								            { exact (If_i_0 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hnbq). }
								            rewrite Hstep2.
								            reflexivity. }

								          (** x ∈ A ⊆ U_a ⊆ cl(U_a) ⊆ U_Q q **)
								          claim HU_a12: U_a :e Tx /\ A c= U_a.
								          { exact (andEL (U_a :e Tx /\ A c= U_a) (closure_of X Tx U_a c= U_b) HU_a). }
								          claim HAsubUa: A c= U_a.
								          { exact (andER (U_a :e Tx) (A c= U_a) HU_a12). }
								          claim HxUa: x :e U_a.
								          { exact (HAsubUa x HxA). }
								          claim HU_aTx': U_a :e Tx.
								          { exact (andEL (U_a :e Tx) (A c= U_a) HU_a12). }
								          claim HU_aSubX: U_a c= X.
								          { exact (topology_elem_subset X Tx U_a HTx HU_aTx'). }
								          claim HxclUa: x :e closure_of X Tx U_a.
								          { exact ((subset_of_closure X Tx U_a HTx HU_aSubX) x HxUa). }
									          claim HclSub: closure_of X Tx U_a c= U_Q q.
									          { rewrite <- HGa at 1.
									            rewrite HUQq.
									            exact Hnest. }
								          exact (HclSub x HxclUa). }

								      (** Any lower bound l of Qx(x) must satisfy l <= a. **)
								      claim HLB_le_a: forall l:set, l :e LB x -> l :e R -> Rle l a.
								      { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
								        apply (xm (Rlt a l)).
								        - assume Halt: Rlt a l.
								          apply (rational_dense_between_reals a l HaR HlR Halt).
								          let q. assume Hqpair. apply Hqpair.
								          assume HqQ: q :e rational_numbers.
								          assume HqProp: Rlt a q /\ Rlt q l.
								          claim Haq: Rlt a q.
								          { exact (andEL (Rlt a q) (Rlt q l) HqProp). }
								          claim Hql: Rlt q l.
								          { exact (andER (Rlt a q) (Rlt q l) HqProp). }
								          claim HqR: q :e R.
								          { exact (rational_numbers_in_R q HqQ). }
								          claim HxUq: x :e U_Q q.
								          { exact (HxA_in_UQ_gt_a q HqQ Haq). }
								          claim HqQx: q :e Qx x.
								          { exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) q HqQ HxUq). }
								          claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
								          { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
								          claim Hle: Rle l q.
								          { exact (HlProp q HqQx HqR). }
								          claim Hcontra: False.
								          { exact ((RleE_nlt l q Hle) Hql). }
								          exact (FalseE Hcontra (Rle l a)).
								        - assume Hnalt: ~(Rlt a l).
								          exact (RleI l a HlR HaR Hnalt). }
								      claim Hfxlea: Rle (fx x) a.
								      { exact (HminLB a HaR HLB_le_a). }
								      claim HfxEqA: fx x = a.
								      { exact (Rle_antisym (fx x) a Hfxlea Hale). }
								      rewrite HfxEq.
								      rewrite HfxEqA.
								      reflexivity.
								  - let x. assume HxB: x :e B.
								    claim HxX: x :e X.
								    { exact (HBsubX x HxB). }
								    claim HfxEq: apply_fun f x = fx x.
								    { claim HfDef: f = graph X (fun x0:set => fx x0).
								      { reflexivity. }
								      rewrite HfDef at 1.
								      exact (apply_fun_graph X (fun x0:set => fx x0) x HxX). }
								    claim HfxR: fx x :e R.
								    { exact (Hfx_in_R x HxX). }
								    claim Hfxlub: R_lub (LB x) (fx x).
								    { exact (HfxRlub x HxX). }
								    claim HubLB: forall l:set, l :e LB x -> l :e R -> Rle l (fx x).
								    { exact (andER (fx x :e R) (forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                 (andEL (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                        (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                        Hfxlub)). }
								    claim HminLB: forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u.
								    { exact (andER (fx x :e R /\ forall l:set, l :e LB x -> l :e R -> Rle l (fx x))
								                 (forall u:set, u :e R -> (forall l:set, l :e LB x -> l :e R -> Rle l u) -> Rle (fx x) u)
								                 Hfxlub). }

								    (** b is a lower bound of Qx(x) for x∈B **)
								    claim HbLB: b :e LB x.
								    { claim HLBDef: LB x = {l :e R | forall p:set, p :e Qx x -> p :e R -> Rle l p}.
								      { reflexivity. }
								      rewrite HLBDef at 1.
								      claim Hbprop: forall p:set, p :e Qx x -> p :e R -> Rle b p.
								      { let p. assume HpQx: p :e Qx x. assume HpR: p :e R.
								        claim HpQ: p :e rational_numbers.
								        { exact (SepE1 rational_numbers (fun p0:set => x :e U_Q p0) p HpQx). }
								        claim HxUp: x :e U_Q p.
								        { exact (SepE2 rational_numbers (fun p0:set => x :e U_Q p0) p HpQx). }
								        apply (xm (Rlt p b)).
								        + assume Hpb: Rlt p b.
								          (** show contradiction: x ∈ B implies x ∉ U_b, but cl(U_Q p) ⊆ U_b when p<b **)
								          claim HnpA: ~(Rlt p a).
								          { assume Hpa: Rlt p a.
								            claim HUeq: U_Q p =
								              if (Rlt p a) then Empty else if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p.
								            { reflexivity. }
								            claim HUempty: U_Q p = Empty.
								            { rewrite HUeq.
								              exact (If_i_1 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) Hpa). }
								            claim HxE: x :e Empty.
								            { rewrite <- HUempty at 1.
								              exact HxUp. }
								            exact (EmptyE x HxE). }
								          claim Hnbp: ~(Rlt b p).
								          { exact (not_Rlt_sym p b Hpb). }
								          claim HpI: p :e I.
								          { exact (SepI R (fun r:set => ~(Rlt r a) /\ ~(Rlt b r)) p HpR
								                    (andI (~(Rlt p a)) (~(Rlt b p)) HnpA Hnbp)). }
								          claim HpP0: p :e P0.
								          { exact (binintersectI rational_numbers I p HpQ HpI). }
								          claim HpP: p :e P.
								          { exact (binunionI1 P0 (UPair a b) p HpP0). }
								          set np := ordsucc (code p).
								          claim HcodepO: code p :e omega.
								          { exact (Hcode_in_omega p HpP). }
								          claim HnpNat: nat_p np.
								          { exact (omega_nat_p np (omega_ordsucc (code p) HcodepO)). }
								          claim HpDom: p :e Fof np.
								          { exact (Hp_in_dom_succ_code p HpP). }
								          (** b is in the base domain, hence in every later Fof **)
								          claim HSt0: State 0 = BaseState.
								          { exact (nat_primrec_0 BaseState StepState). }
								          claim HFof0: Fof 0 = BaseF.
								          { claim HFdef: Fof 0 = (State 0) 0.
								            { reflexivity. }
								            rewrite HFdef.
								            rewrite HSt0.
								            rewrite (tuple_2_0_eq BaseF BaseG).
								            reflexivity. }
								          claim HbF0: b :e Fof 0.
								          { rewrite HFof0.
								            exact (UPairI2 a b). }
								          claim HbFp': b :e Fof (add_nat 0 np).
								          { exact (Fof_increase_by_add 0 np b nat_0 HnpNat HbF0). }
								          claim Hadd0: add_nat 0 np = np.
								          { exact (add_nat_0L np HnpNat). }
								          claim HbDom: b :e Fof np.
								          { rewrite <- Hadd0 at 1.
								            exact HbFp'. }
								          claim Hnest: closure_of X Tx (apply_fun (Gof np) p) c= apply_fun (Gof np) b.
								          { exact (Inv_nesting_at np p b HnpNat HpDom HbDom Hpb). }
								          (** rewrite stage values to U_Q p and U_b **)
								          claim HUQp: U_Q p = apply_fun (Gof np) p.
								          { claim Hbeta: U_Q p =
								              if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								            { reflexivity. }
								            rewrite Hbeta.
								            claim Hstep1: (if (Rlt p a) then Empty else (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p))
								              = (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p).
								            { exact (If_i_0 (Rlt p a) Empty (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) HnpA). }
								            rewrite Hstep1.
								            claim Hstep2: (if (Rlt b p) then X else apply_fun (Gof (ordsucc (code p))) p) =
								              apply_fun (Gof (ordsucc (code p))) p.
								            { exact (If_i_0 (Rlt b p) X (apply_fun (Gof (ordsucc (code p))) p) Hnbp). }
								            rewrite Hstep2.
								            reflexivity. }
								          claim HGof0: Gof 0 = BaseG.
								          { claim HGdef: Gof 0 = (State 0) 1.
								            { reflexivity. }
								            rewrite HGdef.
								            rewrite HSt0.
								            rewrite (tuple_2_1_eq BaseF BaseG).
								            reflexivity. }
								          claim HGb0: apply_fun (Gof 0) b = U_b.
								          { rewrite HGof0.
								            exact HBaseGb. }
								          claim HGb: apply_fun (Gof np) b = U_b.
								          { claim Hpres: apply_fun (Gof (add_nat 0 np)) b = apply_fun (Gof 0) b.
								            { exact (Gof_preserve_add 0 np b nat_0 HnpNat HbF0). }
								            rewrite <- Hadd0 at 1.
								            rewrite Hpres.
								            exact HGb0. }
									          claim HclSub: closure_of X Tx (U_Q p) c= U_b.
									          { let y. assume Hy: y :e closure_of X Tx (U_Q p).
									            prove y :e U_b.
									            claim Hy': y :e closure_of X Tx (apply_fun (Gof np) p).
									            { rewrite <- HUQp at 1.
									              exact Hy. }
									            claim Hyb: y :e apply_fun (Gof np) b.
									            { exact (Hnest y Hy'). }
									            rewrite <- HGb at 1.
									            exact Hyb. }
								          (** x ∈ U_Q p ⊆ cl(U_Q p) ⊆ U_b, but x ∈ B so x ∉ U_b **)
								          claim HUopen: U_Q p :e Tx.
								          { exact (HU_Q_open p HpQ). }
								          claim HUpSubX: U_Q p c= X.
								          { exact (topology_elem_subset X Tx (U_Q p) HTx HUopen). }
								          claim Hxclp: x :e closure_of X Tx (U_Q p).
								          { exact ((subset_of_closure X Tx (U_Q p) HTx HUpSubX) x HxUp). }
								          claim HxUb: x :e U_b.
								          { exact (HclSub x Hxclp). }
								          claim HxNotUb: x /:e U_b.
								          { assume HxUb': x :e U_b.
								            claim HxNotB: x /:e B.
								            { exact (setminusE2 X B x HxUb'). }
								            exact (HxNotB HxB). }
								          exact (FalseE (HxNotUb HxUb) (Rle b p)).
								        + assume Hnpb: ~(Rlt p b).
								          exact (RleI b p HbR HpR Hnpb). }
								      exact (SepI R (fun l:set => forall p:set, p :e Qx x -> p :e R -> Rle l p) b HbR Hbprop). }
								    claim Hleb: Rle b (fx x).
								    { exact (HubLB b HbLB HbR). }
								    (** b is an upper bound of LB x: any l∈LB x must be <= b (use q with b<q<l, and U_Q q = X) **)
								    claim HLB_le_b: forall l:set, l :e LB x -> l :e R -> Rle l b.
								    { let l. assume HlLB: l :e LB x. assume HlR: l :e R.
								      apply (xm (Rlt b l)).
								      - assume Hbl: Rlt b l.
								        apply (rational_dense_between_reals b l HbR HlR Hbl).
								        let q. assume HqPair. apply HqPair.
								        assume HqQ: q :e rational_numbers.
								        assume HqProp: Rlt b q /\ Rlt q l.
								        claim Hbq: Rlt b q.
								        { exact (andEL (Rlt b q) (Rlt q l) HqProp). }
								        claim Hql: Rlt q l.
								        { exact (andER (Rlt b q) (Rlt q l) HqProp). }
								        claim HqR: q :e R.
								        { exact (rational_numbers_in_R q HqQ). }
								        (** x ∈ U_Q q since U_Q q = X **)
								        claim Hnqa: ~(Rlt q a).
								        { assume Hqa: Rlt q a.
								          claim Hba': Rlt b a.
								          { exact (Rlt_tra b q a Hbq Hqa). }
								          exact ((RleE_nlt a b Hab) Hba'). }
								        claim HUeq: U_Q q =
								          if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q.
								        { reflexivity. }
								        claim Hstep: (if (Rlt q a) then Empty else if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q)
								          = (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q).
								        { exact (If_i_0 (Rlt q a) Empty (if (Rlt b q) then X else apply_fun (Gof (ordsucc (code q))) q) Hnqa). }
								        claim HUX: U_Q q = X.
								        { rewrite HUeq.
								          rewrite Hstep.
								          exact (If_i_1 (Rlt b q) X (apply_fun (Gof (ordsucc (code q))) q) Hbq). }
								        claim HxUq: x :e U_Q q.
								        { rewrite HUX at 1.
								          exact HxX. }
								        claim HqQx: q :e Qx x.
								        { exact (SepI rational_numbers (fun p0:set => x :e U_Q p0) q HqQ HxUq). }
								        claim HlProp: forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l p0.
								        { exact (SepE2 R (fun l0:set => forall p0:set, p0 :e Qx x -> p0 :e R -> Rle l0 p0) l HlLB). }
								        claim Hle: Rle l q.
								        { exact (HlProp q HqQx HqR). }
								        claim Hcontra: False.
								        { exact ((RleE_nlt l q Hle) Hql). }
								        exact (FalseE Hcontra (Rle l b)).
								      - assume Hnbl: ~(Rlt b l).
								        exact (RleI l b HlR HbR Hnbl). }
								    claim Hfxleb: Rle (fx x) b.
								    { exact (HminLB b HbR HLB_le_b). }
								    claim HfxEqB: fx x = b.
								    { exact (Rle_antisym (fx x) b Hfxleb Hleb). }
								    rewrite HfxEq.
								    rewrite HfxEqB.
								    reflexivity.
Qed.

(** from §33 Definition: completely regular space **) 
(** LATEX VERSION: Completely regular (Tikhonov) spaces admit continuous [0,1]-valued functions separating point and closed set. **)
Definition completely_regular_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  (one_point_sets_closed X Tx /\
   forall x:set, x :e X ->
     forall F:set, closed_in X Tx F -> x /:e F ->
       exists f:set,
         continuous_map X Tx R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).

(** helper for §34 Corollary 34.3: open-set version of complete regularity **)
(** LATEX VERSION: If x∈U is open, there exists continuous g with g(x)=1 and g=0 on X\\U. **)
Theorem completely_regular_space_open_separator : forall X Tx x U:set,
  completely_regular_space X Tx ->
  x :e X -> U :e Tx -> x :e U ->
  exists g:set,
    continuous_map X Tx R R_standard_topology g /\
    apply_fun g x = 1 /\
    forall y:set, y :e X :\: U -> apply_fun g y = 0.
let X Tx x U.
assume Hcr: completely_regular_space X Tx.
assume HxX: x :e X.
assume HU: U :e Tx.
assume HxU: x :e U.
prove exists g:set,
  continuous_map X Tx R R_standard_topology g /\
  apply_fun g x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun g y = 0.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (one_point_sets_closed X Tx /\
                forall x0:set, x0 :e X ->
                  forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                    exists f:set,
                      continuous_map X Tx R R_standard_topology f /\
                      apply_fun f x0 = 0 /\ forall y:set, y :e F0 -> apply_fun f y = 1)
               Hcr). }
set F := X :\: U.
claim HFcl: closed_in X Tx F.
{ exact (closed_of_open_complement X Tx U HTx HU). }
claim HxnotF: x /:e F.
{ assume HxF: x :e F.
  claim HxU': x /:e U.
  { exact (andER (x :e X) (x /:e U) (setminusE X U x HxF)). }
  exact (HxU' HxU). }
claim Hrest:
  one_point_sets_closed X Tx /\
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f:set,
        continuous_map X Tx R R_standard_topology f /\
        apply_fun f x0 = 0 /\ forall y:set, y :e F0 -> apply_fun f y = 1.
{ exact (andER (topology_on X Tx)
               (one_point_sets_closed X Tx /\
                forall x0:set, x0 :e X ->
                  forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                    exists f:set,
                      continuous_map X Tx R R_standard_topology f /\
                      apply_fun f x0 = 0 /\ forall y:set, y :e F0 -> apply_fun f y = 1)
               Hcr). }
claim Hsep:
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f:set,
        continuous_map X Tx R R_standard_topology f /\
        apply_fun f x0 = 0 /\ forall y:set, y :e F0 -> apply_fun f y = 1.
{ exact (andER (one_point_sets_closed X Tx)
               (forall x0:set, x0 :e X ->
                 forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                   exists f:set,
                     continuous_map X Tx R R_standard_topology f /\
                     apply_fun f x0 = 0 /\ forall y:set, y :e F0 -> apply_fun f y = 1)
               Hrest). }
apply (Hsep x HxX F HFcl HxnotF).
let f.
assume Hfpack: continuous_map X Tx R R_standard_topology f /\
  apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
claim Hcontf: continuous_map X Tx R R_standard_topology f.
{ claim Hpair: continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
  { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  exact (andEL (continuous_map X Tx R R_standard_topology f)
               (apply_fun f x = 0)
               Hpair). }
claim Hfx0: apply_fun f x = 0.
{ claim Hpair: continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
  { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  exact (andER (continuous_map X Tx R R_standard_topology f)
               (apply_fun f x = 0)
               Hpair). }
claim HfF1: forall y:set, y :e F -> apply_fun f y = 1.
{ exact (andER (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
               (forall y:set, y :e F -> apply_fun f y = 1)
               Hfpack). }
witness (compose_fun X f one_minus_fun).
apply andI.
- apply andI.
  + (** continuity **)
    claim Hone: continuous_map R R_standard_topology R R_standard_topology one_minus_fun.
    { exact one_minus_fun_continuous. }
    exact (composition_continuous X Tx R R_standard_topology R R_standard_topology f one_minus_fun Hcontf Hone).
  + (** value at x **)
    prove apply_fun (compose_fun X f one_minus_fun) x = 1.
    claim Hgx: apply_fun (compose_fun X f one_minus_fun) x =
      apply_fun one_minus_fun (apply_fun f x).
    { exact (compose_fun_apply X f one_minus_fun x HxX). }
    rewrite Hgx.
    rewrite Hfx0.
    exact one_minus_fun_0.
- let y. assume HyF: y :e X :\: U.
  prove apply_fun (compose_fun X f one_minus_fun) y = 0.
  claim HyX: y :e X.
  { exact (andEL (y :e X) (y /:e U) (setminusE X U y HyF)). }
  claim Hgy: apply_fun (compose_fun X f one_minus_fun) y =
    apply_fun one_minus_fun (apply_fun f y).
  { exact (compose_fun_apply X f one_minus_fun y HyX). }
  rewrite Hgy.
  rewrite (HfF1 y HyF).
  exact one_minus_fun_1.
Qed.

(** helper for cube constructions: open-set separator with unit_interval range **)
Theorem completely_regular_space_open_separator_unit_interval : forall X Tx x U:set,
  completely_regular_space X Tx ->
  x :e X -> U :e Tx -> x :e U ->
  exists h:set,
    continuous_map X Tx unit_interval unit_interval_topology h /\
    apply_fun h x = 1 /\
    forall y:set, y :e X :\: U -> apply_fun h y = 0.
let X Tx x U.
assume Hcr: completely_regular_space X Tx.
assume HxX: x :e X.
assume HU: U :e Tx.
assume HxU: x :e U.
prove exists h:set,
  continuous_map X Tx unit_interval unit_interval_topology h /\
  apply_fun h x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun h y = 0.
claim Hex: exists g:set,
  continuous_map X Tx R R_standard_topology g /\
  apply_fun g x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun g y = 0.
{ exact (completely_regular_space_open_separator X Tx x U Hcr HxX HU HxU). }
apply Hex.
let g. assume Hgpack:
  continuous_map X Tx R R_standard_topology g /\
  apply_fun g x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun g y = 0.
witness (compose_fun X g normalize01_fun).
apply andI.
- apply andI.
  + claim Hgpair: (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1).
    { exact (andEL (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1)
                   (forall y:set, y :e X :\: U -> apply_fun g y = 0)
                   Hgpack). }
    claim Hgcont: continuous_map X Tx R R_standard_topology g.
    { exact (andEL (continuous_map X Tx R R_standard_topology g) (apply_fun g x = 1) Hgpair). }
    claim Hnorm: continuous_map R R_standard_topology unit_interval unit_interval_topology normalize01_fun.
    { exact normalize01_fun_continuous_to_unit_interval. }
    exact (composition_continuous X Tx R R_standard_topology unit_interval unit_interval_topology g normalize01_fun Hgcont Hnorm).
  + claim Hgpair: (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1).
    { exact (andEL (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1)
                   (forall y:set, y :e X :\: U -> apply_fun g y = 0)
                   Hgpack). }
    claim Hgx1: apply_fun g x = 1.
    { exact (andER (continuous_map X Tx R R_standard_topology g) (apply_fun g x = 1) Hgpair). }
    claim Happ: apply_fun (compose_fun X g normalize01_fun) x = apply_fun normalize01_fun (apply_fun g x).
    { exact (compose_fun_apply X g normalize01_fun x HxX). }
    rewrite Happ.
    rewrite Hgx1.
    exact normalize01_fun_1.
- let y. assume HyOut: y :e X :\: U.
  prove apply_fun (compose_fun X g normalize01_fun) y = 0.
  claim HyX: y :e X.
  { exact (andEL (y :e X) (y /:e U) (setminusE X U y HyOut)). }
  claim Hgzero: forall y0:set, y0 :e X :\: U -> apply_fun g y0 = 0.
  { exact (andER (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1)
                 (forall y0:set, y0 :e X :\: U -> apply_fun g y0 = 0)
                 Hgpack). }
  claim Hgy0: apply_fun g y = 0.
  { exact (Hgzero y HyOut). }
  claim Happ: apply_fun (compose_fun X g normalize01_fun) y = apply_fun normalize01_fun (apply_fun g y).
  { exact (compose_fun_apply X g normalize01_fun y HyX). }
  rewrite Happ.
  rewrite Hgy0.
  exact normalize01_fun_0.
Qed.

(** helper: open-set separator as an element of function_space X unit_interval **)
Theorem completely_regular_space_open_separator_unit_interval_in_function_space : forall X Tx x U:set,
  completely_regular_space X Tx ->
  x :e X -> U :e Tx -> x :e U ->
  exists h:set,
    h :e function_space X unit_interval /\
    continuous_map X Tx unit_interval unit_interval_topology h /\
    apply_fun h x = 1 /\
    forall y:set, y :e X :\: U -> apply_fun h y = 0.
let X Tx x U.
assume Hcr: completely_regular_space X Tx.
assume HxX: x :e X.
assume HU: U :e Tx.
assume HxU: x :e U.
prove exists h:set,
  h :e function_space X unit_interval /\
  continuous_map X Tx unit_interval unit_interval_topology h /\
  apply_fun h x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun h y = 0.
claim Hex: exists g:set,
  continuous_map X Tx R R_standard_topology g /\
  apply_fun g x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun g y = 0.
{ exact (completely_regular_space_open_separator X Tx x U Hcr HxX HU HxU). }
apply Hex.
let g. assume Hgpack:
  continuous_map X Tx R R_standard_topology g /\
  apply_fun g x = 1 /\
  forall y:set, y :e X :\: U -> apply_fun g y = 0.
set h := compose_fun X g normalize01_fun.
witness h.
claim Hgpair: continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1.
{ exact (andEL (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1)
               (forall y:set, y :e X :\: U -> apply_fun g y = 0)
               Hgpack). }
claim Hgcont: continuous_map X Tx R R_standard_topology g.
{ exact (andEL (continuous_map X Tx R R_standard_topology g) (apply_fun g x = 1) Hgpair). }
claim Hgx1: apply_fun g x = 1.
{ exact (andER (continuous_map X Tx R R_standard_topology g) (apply_fun g x = 1) Hgpair). }
claim Hgzero: forall y:set, y :e X :\: U -> apply_fun g y = 0.
{ exact (andER (continuous_map X Tx R R_standard_topology g /\ apply_fun g x = 1)
               (forall y:set, y :e X :\: U -> apply_fun g y = 0)
               Hgpack). }

claim Hnorm: continuous_map R R_standard_topology unit_interval unit_interval_topology normalize01_fun.
{ exact normalize01_fun_continuous_to_unit_interval. }
claim Hhcont: continuous_map X Tx unit_interval unit_interval_topology h.
{ exact (composition_continuous X Tx R R_standard_topology unit_interval unit_interval_topology g normalize01_fun Hgcont Hnorm). }

claim Hhfun: function_on h X unit_interval.
{ exact (continuous_map_function_on X Tx unit_interval unit_interval_topology h Hhcont). }
claim Hhsub: h c= setprod X unit_interval.
{ let q. assume Hq: q :e h.
  prove q :e setprod X unit_interval.
  apply (ReplE_impred X (fun a0:set => (a0, apply_fun normalize01_fun (apply_fun g a0))) q Hq (q :e setprod X unit_interval)).
  let a. assume HaX: a :e X.
  assume Heq: q = (a, apply_fun normalize01_fun (apply_fun g a)).
  rewrite Heq.
  claim HgR: apply_fun g a :e R.
  { exact (continuous_map_function_on X Tx R R_standard_topology g Hgcont a HaX). }
  claim HhaI: apply_fun normalize01_fun (apply_fun g a) :e unit_interval.
  { exact (normalize01_fun_range_in_unit_interval (apply_fun g a) HgR). }
  exact (tuple_2_setprod_by_pair_Sigma X unit_interval a (apply_fun normalize01_fun (apply_fun g a)) HaX HhaI). }
claim Hhpow: h :e Power (setprod X unit_interval).
{ exact (PowerI (setprod X unit_interval) h Hhsub). }
claim HhFS: h :e function_space X unit_interval.
{ exact (SepI (Power (setprod X unit_interval)) (fun f0:set => function_on f0 X unit_interval) h Hhpow Hhfun). }

apply andI.
- apply andI.
  + apply andI.
    * exact HhFS.
    * exact Hhcont.
  + (** value at x **)
    claim Happx: apply_fun h x = apply_fun normalize01_fun (apply_fun g x).
    { exact (compose_fun_apply X g normalize01_fun x HxX). }
    rewrite Happx.
    rewrite Hgx1.
    exact normalize01_fun_1.
- (** vanishing off U **)
  let y. assume HyOut: y :e X :\: U.
  prove apply_fun h y = 0.
  claim HyX: y :e X.
  { exact (andEL (y :e X) (y /:e U) (setminusE X U y HyOut)). }
  claim Hgy0: apply_fun g y = 0.
  { exact (Hgzero y HyOut). }
  claim Happy: apply_fun h y = apply_fun normalize01_fun (apply_fun g y).
  { exact (compose_fun_apply X g normalize01_fun y HyX). }
  rewrite Happy.
  rewrite Hgy0.
  exact normalize01_fun_0.
Qed.

(** helper for §34 Corollary 34.3: point separation by complete regularity **)
(** LATEX VERSION: In a completely regular space, for x!=y there exists continuous f with f(x)=0 and f(y)=1. **)
Theorem completely_regular_space_separates_points : forall X Tx x y:set,
  completely_regular_space X Tx ->
  x :e X -> y :e X -> x <> y ->
  exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    apply_fun f x = 0 /\ apply_fun f y = 1.
let X Tx x y.
assume Hcr: completely_regular_space X Tx.
assume HxX: x :e X.
assume HyX: y :e X.
assume Hxy: x <> y.
prove exists f:set,
  continuous_map X Tx R R_standard_topology f /\
  apply_fun f x = 0 /\ apply_fun f y = 1.
claim Hrest: one_point_sets_closed X Tx /\
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f0:set,
        continuous_map X Tx R R_standard_topology f0 /\
        apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1.
{ exact (andER (topology_on X Tx)
               (one_point_sets_closed X Tx /\
                forall x0:set, x0 :e X ->
                  forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                    exists f0:set,
                      continuous_map X Tx R R_standard_topology f0 /\
                      apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1)
               Hcr). }
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x0:set, x0 :e X ->
                 forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                   exists f0:set,
                     continuous_map X Tx R R_standard_topology f0 /\
                     apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1)
               Hrest). }
claim HyCl: closed_in X Tx {y}.
{ exact (andER (topology_on X Tx)
               (forall z:set, z :e X -> closed_in X Tx {z})
               HT1 y HyX). }
claim Hxnoty: x /:e {y}.
{ assume Hxy0: x :e {y}.
  claim Heq: x = y.
  { exact (SingE y x Hxy0). }
  exact (Hxy Heq). }
claim Hsep:
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f0:set,
        continuous_map X Tx R R_standard_topology f0 /\
        apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1.
{ exact (andER (one_point_sets_closed X Tx)
               (forall x0:set, x0 :e X ->
                 forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                   exists f0:set,
                     continuous_map X Tx R R_standard_topology f0 /\
                     apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1)
               Hrest). }
apply (Hsep x HxX {y} HyCl Hxnoty).
let f.
assume Hfpack:
  continuous_map X Tx R R_standard_topology f /\
  apply_fun f x = 0 /\ forall z:set, z :e {y} -> apply_fun f z = 1.
witness f.
claim Hcont: continuous_map X Tx R R_standard_topology f.
{ claim Hpair: continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
  { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall z:set, z :e {y} -> apply_fun f z = 1)
                 Hfpack). }
  exact (andEL (continuous_map X Tx R R_standard_topology f)
               (apply_fun f x = 0)
               Hpair). }
claim Hfx0: apply_fun f x = 0.
{ claim Hpair: continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
  { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall z:set, z :e {y} -> apply_fun f z = 1)
                 Hfpack). }
  exact (andER (continuous_map X Tx R R_standard_topology f)
               (apply_fun f x = 0)
               Hpair). }
claim Hfy1: apply_fun f y = 1.
{ claim Hfor: forall z:set, z :e {y} -> apply_fun f z = 1.
  { exact (andER (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall z:set, z :e {y} -> apply_fun f z = 1)
                 Hfpack). }
  exact (Hfor y (SingI y)). }
apply andI.
- apply andI.
  + exact Hcont.
  + exact Hfx0.
- exact Hfy1.
Qed.

(** helper: extract topology_on from completely_regular_space **)
(** LATEX VERSION: Any completely regular space carries a topology. **)
Theorem completely_regular_space_topology_on : forall X Tx:set,
  completely_regular_space X Tx -> topology_on X Tx.
let X Tx.
assume Hcr: completely_regular_space X Tx.
prove topology_on X Tx.
claim Hdef: topology_on X Tx /\ (one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists f:set,
        continuous_map X Tx R R_standard_topology f /\
        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
{ exact Hcr. }
exact (andEL (topology_on X Tx)
             (one_point_sets_closed X Tx /\
              forall x:set, x :e X ->
                forall F:set, closed_in X Tx F -> x /:e F ->
                  exists f:set,
                    continuous_map X Tx R R_standard_topology f /\
                    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
             Hdef).
Qed.

(** helper: extract one_point_sets_closed from completely_regular_space **)
(** LATEX VERSION: Completely regular implies T1. **)
Theorem completely_regular_space_one_point_sets_closed : forall X Tx:set,
  completely_regular_space X Tx -> one_point_sets_closed X Tx.
let X Tx.
assume Hcr: completely_regular_space X Tx.
prove one_point_sets_closed X Tx.
claim Hdef: topology_on X Tx /\ (one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists f:set,
        continuous_map X Tx R R_standard_topology f /\
        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
{ exact Hcr. }
claim Hrest: one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists f:set,
        continuous_map X Tx R R_standard_topology f /\
        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
{ exact (andER (topology_on X Tx)
               (one_point_sets_closed X Tx /\
                forall x:set, x :e X ->
                  forall F:set, closed_in X Tx F -> x /:e F ->
                    exists f:set,
                      continuous_map X Tx R R_standard_topology f /\
                      apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
               Hdef). }
exact (andEL (one_point_sets_closed X Tx)
             (forall x:set, x :e X ->
               forall F:set, closed_in X Tx F -> x /:e F ->
                 exists f:set,
                   continuous_map X Tx R R_standard_topology f /\
                   apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
             Hrest).
Qed.

(** helper: extract the separation map property from completely_regular_space **)
(** LATEX VERSION: Completely regular provides continuous functions separating points from closed sets. **)
Theorem completely_regular_space_separation : forall X Tx x F:set,
  completely_regular_space X Tx ->
  x :e X ->
  closed_in X Tx F ->
  x /:e F ->
  exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
let X Tx x F.
assume Hcr: completely_regular_space X Tx.
assume HxX: x :e X.
assume HFcl: closed_in X Tx F.
assume HxnotF: x /:e F.
prove exists f:set,
  continuous_map X Tx R R_standard_topology f /\
  apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
claim Hdef: topology_on X Tx /\ (one_point_sets_closed X Tx /\
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f0:set,
        continuous_map X Tx R R_standard_topology f0 /\
        apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1).
{ exact Hcr. }
claim Hrest: one_point_sets_closed X Tx /\
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f0:set,
        continuous_map X Tx R R_standard_topology f0 /\
        apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1.
{ exact (andER (topology_on X Tx)
               (one_point_sets_closed X Tx /\
                forall x0:set, x0 :e X ->
                  forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                    exists f0:set,
                      continuous_map X Tx R R_standard_topology f0 /\
                      apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1)
               Hdef). }
claim Hforall:
  forall x0:set, x0 :e X ->
    forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
      exists f0:set,
        continuous_map X Tx R R_standard_topology f0 /\
        apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1.
{ exact (andER (one_point_sets_closed X Tx)
               (forall x0:set, x0 :e X ->
                 forall F0:set, closed_in X Tx F0 -> x0 /:e F0 ->
                   exists f0:set,
                     continuous_map X Tx R R_standard_topology f0 /\
                     apply_fun f0 x0 = 0 /\ forall y0:set, y0 :e F0 -> apply_fun f0 y0 = 1)
               Hrest). }
exact (Hforall x HxX F HFcl HxnotF).
Qed.

(** helper: completely regular implies regular **)
(** LATEX VERSION: Completely regular (T1) implies regular. **)
Theorem completely_regular_space_implies_regular : forall X Tx:set,
  completely_regular_space X Tx -> regular_space X Tx.
let X Tx.
assume Hcr: completely_regular_space X Tx.
prove regular_space X Tx.
prove one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- exact (completely_regular_space_one_point_sets_closed X Tx Hcr).
- let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  set b := inv_nat 2.
  claim H2omega: 2 :e omega.
  { exact (nat_p_omega 2 nat_2). }
  claim HbR: b :e R.
  { exact (inv_nat_real 2 H2omega). }
  claim H2Zp: 2 :e omega :\: {0}.
  { exact two_in_Zplus. }
  claim H0ltb: Rlt 0 b.
  { exact (inv_nat_pos 2 H2Zp). }
  claim Hblt1: Rlt b 1.
  { exact inv_nat_2_lt_1. }
  claim HopenLower: open_ray_lower R b :e R_standard_topology.
  { rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_lower R b :e open_rays_subbasis R.
    { exact (open_ray_lower_in_open_rays_subbasis R b HbR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R b) HsRay). }
  claim HopenUpper: open_ray_upper R b :e R_standard_topology.
  { rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_upper R b :e open_rays_subbasis R.
    { exact (open_ray_upper_in_open_rays_subbasis R b HbR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R b) HsRay). }
  apply (completely_regular_space_separation X Tx x F Hcr HxX HFcl HxnotF).
  let f. assume Hfpack.
  claim Hfleft: continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
  { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  claim Hfcont: continuous_map X Tx R R_standard_topology f.
  { exact (andEL (continuous_map X Tx R R_standard_topology f)
                 (apply_fun f x = 0)
                 Hfleft). }
  claim Hfx0: apply_fun f x = 0.
  { exact (andER (continuous_map X Tx R R_standard_topology f)
                 (apply_fun f x = 0)
                 Hfleft). }
  claim HfF: forall y:set, y :e F -> apply_fun f y = 1.
  { exact (andER (continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0)
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  set U := preimage_of X f (open_ray_lower R b).
  set V := preimage_of X f (open_ray_upper R b).
  claim HUinTx: U :e Tx.
  { exact (continuous_map_preimage X Tx R R_standard_topology f Hfcont (open_ray_lower R b) HopenLower). }
  claim HVinTx: V :e Tx.
  { exact (continuous_map_preimage X Tx R R_standard_topology f Hfcont (open_ray_upper R b) HopenUpper). }
  claim H0ray: 0 :e open_ray_lower R b.
  { exact (SepI R (fun t:set => order_rel R t b) 0 real_0 (Rlt_implies_order_rel_R 0 b H0ltb)). }
  claim Hfxray: apply_fun f x :e open_ray_lower R b.
  { rewrite Hfx0 at 1.
    exact H0ray. }
  claim HxU: x :e U.
  { exact (SepI X (fun t:set => apply_fun f t :e open_ray_lower R b) x HxX Hfxray). }
  claim H1ray: 1 :e open_ray_upper R b.
  { exact (SepI R (fun t:set => order_rel R b t) 1 real_1 (Rlt_implies_order_rel_R b 1 Hblt1)). }
  claim HFsub: F c= X.
  { exact (closed_in_subset X Tx F HFcl). }
  claim HFsubV: F c= V.
  { let y. assume HyF: y :e F.
    prove y :e V.
    claim HyX: y :e X.
    { exact (HFsub y HyF). }
    claim Hfy1: apply_fun f y = 1.
    { exact (HfF y HyF). }
    claim Hfyray: apply_fun f y :e open_ray_upper R b.
    { rewrite Hfy1 at 1.
      exact H1ray. }
    exact (SepI X (fun t:set => apply_fun f t :e open_ray_upper R b) y HyX Hfyray). }
  claim Hdisj: U :/\: V = Empty.
  { apply set_ext.
    - let z. assume Hz: z :e U :/\: V.
      apply FalseE.
      claim HzU: z :e U.
      { exact (binintersectE1 U V z Hz). }
      claim HzV: z :e V.
      { exact (binintersectE2 U V z Hz). }
      claim HzUray: apply_fun f z :e open_ray_lower R b.
      { exact (SepE2 X (fun t:set => apply_fun f t :e open_ray_lower R b) z HzU). }
      claim HzVray: apply_fun f z :e open_ray_upper R b.
      { exact (SepE2 X (fun t:set => apply_fun f t :e open_ray_upper R b) z HzV). }
      claim Hzltb: Rlt (apply_fun f z) b.
      { exact (order_rel_R_implies_Rlt (apply_fun f z) b (SepE2 R (fun t:set => order_rel R t b) (apply_fun f z) HzUray)). }
      claim Hbltz: Rlt b (apply_fun f z).
      { exact (order_rel_R_implies_Rlt b (apply_fun f z) (SepE2 R (fun t:set => order_rel R b t) (apply_fun f z) HzVray)). }
      exact ((not_Rlt_sym (apply_fun f z) b Hzltb) Hbltz).
    - let z. assume Hz: z :e Empty.
      apply FalseE.
      exact (EmptyE z Hz). }
  witness U.
  witness V.
  prove U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  prove (((U :e Tx /\ V :e Tx) /\ x :e U) /\ F c= V) /\ U :/\: V = Empty.
  apply andI.
  * prove ((U :e Tx /\ V :e Tx) /\ x :e U) /\ F c= V.
    apply andI.
    + prove (U :e Tx /\ V :e Tx) /\ x :e U.
      apply andI.
      - prove U :e Tx /\ V :e Tx.
        apply andI.
        * exact HUinTx.
        * exact HVinTx.
      - exact HxU.
    + exact HFsubV.
  * exact Hdisj.
Qed.

(** LATEX VERSION: Completely regular family helper. **)
Definition completely_regular_spaces_family : set -> set -> prop := fun I Xi =>
  forall i:set, i :e I ->
    completely_regular_space (product_component Xi i) (product_component_topology Xi i).

(** Helper: any function is continuous from a discrete domain **)
Theorem continuous_from_discrete : forall X Y Ty f:set,
  topology_on Y Ty ->
  function_on f X Y ->
  continuous_map X (discrete_topology X) Y Ty f.
let X Y Ty f.
assume HTy: topology_on Y Ty.
assume Hfun: function_on f X Y.
prove continuous_map X (discrete_topology X) Y Ty f.
claim HTx: topology_on X (discrete_topology X).
{ exact (discrete_topology_on X). }
prove topology_on X (discrete_topology X) /\ topology_on Y Ty /\ function_on f X Y /\
  forall V:set, V :e Ty -> preimage_of X f V :e discrete_topology X.
apply andI.
- prove (topology_on X (discrete_topology X) /\ topology_on Y Ty) /\ function_on f X Y.
  apply andI.
  * apply andI.
    - exact HTx.
    - exact HTy.
  * exact Hfun.
- let V. assume HV: V :e Ty.
  prove preimage_of X f V :e discrete_topology X.
  claim Hsub: preimage_of X f V c= X.
  { let x. assume Hx: x :e preimage_of X f V.
    exact (SepE1 X (fun u => apply_fun f u :e V) x Hx). }
  exact (discrete_open_all X (preimage_of X f V) Hsub).
Qed.

(** Helper: congruence for tuple coordinates **)
Theorem tuple_2_0_congr : forall a b c d:set, (a,b) = (c,d) -> a = c.
let a b c d.
assume Heq: (a,b) = (c,d).
prove a = c.
rewrite <- (tuple_2_0_eq a b) at 1.
rewrite <- (tuple_2_0_eq c d).
rewrite Heq.
reflexivity.
Qed.

Theorem tuple_2_1_congr : forall a b c d:set, (a,b) = (c,d) -> b = d.
let a b c d.
assume Heq: (a,b) = (c,d).
prove b = d.
rewrite <- (tuple_2_1_eq a b) at 1.
rewrite <- (tuple_2_1_eq c d).
rewrite Heq.
reflexivity.
Qed.

(** Helper: projections from membership in const_fun graphs **)
Theorem const_fun_pair_first : forall A x a y:set, (a,y) :e const_fun A x -> a :e A.
let A x a y.
assume H: (a,y) :e const_fun A x.
prove a :e A.
apply (ReplE_impred A (fun a0:set => (a0,x)) (a,y) H (a :e A)).
let a0. assume Ha0: a0 :e A.
assume Heq: (a,y) = (a0,x).
claim Ha: a = a0.
{ exact (tuple_2_0_congr a y a0 x Heq). }
rewrite Ha.
exact Ha0.
Qed.

Theorem const_fun_pair_second : forall A x a y:set, (a,y) :e const_fun A x -> y = x.
let A x a y.
assume H: (a,y) :e const_fun A x.
prove y = x.
apply (ReplE_impred A (fun a0:set => (a0,x)) (a,y) H (y = x)).
let a0. assume _: a0 :e A.
assume Heq: (a,y) = (a0,x).
exact (tuple_2_1_congr a y a0 x Heq).
Qed.

(** Helper: discrete topology is completely regular **)
Theorem discrete_completely_regular_space : forall X:set,
  completely_regular_space X (discrete_topology X).
let X.
prove completely_regular_space X (discrete_topology X).
claim HTx: topology_on X (discrete_topology X).
{ exact (discrete_topology_on X). }
prove topology_on X (discrete_topology X) /\
  (one_point_sets_closed X (discrete_topology X) /\
   forall x:set, x :e X ->
     forall F:set, closed_in X (discrete_topology X) F -> x /:e F ->
       exists f:set,
         continuous_map X (discrete_topology X) R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
apply andI.
- exact HTx.
- apply andI.
  + exact (andEL (one_point_sets_closed X (discrete_topology X))
                 (forall A B:set, closed_in X (discrete_topology X) A -> closed_in X (discrete_topology X) B -> A :/\: B = Empty ->
                   exists U V:set, U :e discrete_topology X /\ V :e discrete_topology X /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 (discrete_normal_space X)).
  + let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X (discrete_topology X) F.
  assume HxnotF: x /:e F.
  prove exists f:set,
    continuous_map X (discrete_topology X) R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  claim HFsubX: F c= X.
  { exact (closed_in_subset X (discrete_topology X) F HFcl). }
  set A0 := X :\: F.
  claim HA0def: A0 = X :\: F.
  { reflexivity. }
  set f := (const_fun A0 0) :\/: (const_fun F 1).
  witness f.
  claim HRtop: topology_on R R_standard_topology.
  { exact R_standard_topology_is_topology. }
  claim H0R: 0 :e R.
  { exact real_0. }
  claim H1R: 1 :e R.
  { exact real_1. }

  claim Happ0: forall z:set, z :e X -> z /:e F -> apply_fun f z = 0.
  { let z. assume HzX: z :e X.
    assume HznotF: z /:e F.
    prove apply_fun f z = 0.
    claim HzA0: z :e A0.
    { rewrite HA0def.
      exact (setminusI X F z HzX HznotF). }
    claim Hpair0: (z,0) :e f.
    { apply binunionI1.
      exact (ReplI A0 (fun a0:set => (a0,0)) z HzA0). }
    claim Hzgraph: (z, apply_fun f z) :e f.
    { exact (Eps_i_ax (fun y:set => (z,y) :e f) 0 Hpair0). }
    apply (binunionE' (const_fun A0 0) (const_fun F 1) (z, apply_fun f z) (apply_fun f z = 0)).
    - assume Hleft: (z, apply_fun f z) :e const_fun A0 0.
      exact (const_fun_pair_second A0 0 z (apply_fun f z) Hleft).
    - assume Hright: (z, apply_fun f z) :e const_fun F 1.
      claim HzF: z :e F.
      { exact (const_fun_pair_first F 1 z (apply_fun f z) Hright). }
      apply FalseE.
      exact (HznotF HzF).
    - exact Hzgraph. }

  claim Happ1: forall z:set, z :e X -> z :e F -> apply_fun f z = 1.
  { let z. assume HzX: z :e X.
    assume HzF: z :e F.
    prove apply_fun f z = 1.
    claim Hpair1: (z,1) :e f.
    { apply binunionI2.
      exact (ReplI F (fun a0:set => (a0,1)) z HzF). }
    claim Hzgraph: (z, apply_fun f z) :e f.
    { exact (Eps_i_ax (fun y:set => (z,y) :e f) 1 Hpair1). }
    apply (binunionE' (const_fun A0 0) (const_fun F 1) (z, apply_fun f z) (apply_fun f z = 1)).
    - assume Hleft: (z, apply_fun f z) :e const_fun A0 0.
      claim HzA0: z :e A0.
      { exact (const_fun_pair_first A0 0 z (apply_fun f z) Hleft). }
      claim HznotF: z /:e F.
      { claim HzXF: z :e X :\: F.
        { rewrite <- HA0def.
          exact HzA0. }
        exact (setminusE2 X F z HzXF). }
      apply FalseE.
      exact (HznotF HzF).
    - assume Hright: (z, apply_fun f z) :e const_fun F 1.
      exact (const_fun_pair_second F 1 z (apply_fun f z) Hright).
    - exact Hzgraph. }

  claim Hfun: function_on f X R.
  { let z. assume HzX: z :e X.
    prove apply_fun f z :e R.
    apply (xm (z :e F)).
    - assume HzF: z :e F.
      claim Hz1: apply_fun f z = 1.
      { exact (Happ1 z HzX HzF). }
      rewrite Hz1.
      exact H1R.
    - assume HznotF: z /:e F.
      claim Hz0: apply_fun f z = 0.
      { exact (Happ0 z HzX HznotF). }
      rewrite Hz0.
      exact H0R. }

  claim Hcont: continuous_map X (discrete_topology X) R R_standard_topology f.
  { exact (continuous_from_discrete X R R_standard_topology f HRtop Hfun). }

  claim Hfx0: apply_fun f x = 0.
  { exact (Happ0 x HxX HxnotF). }
  claim HfF1: forall y:set, y :e F -> apply_fun f y = 1.
  { let y. assume HyF: y :e F.
    claim HyX: y :e X.
    { exact (HFsubX y HyF). }
    exact (Happ1 y HyX HyF). }

  apply andI.
  * prove continuous_map X (discrete_topology X) R R_standard_topology f /\ apply_fun f x = 0.
    apply andI.
    - exact Hcont.
    - exact Hfx0.
  * exact HfF1.
Qed.

(** Helper: discrete topology is Hausdorff **)
Theorem discrete_Hausdorff_space : forall X:set,
  Hausdorff_space X (discrete_topology X).
let X.
prove Hausdorff_space X (discrete_topology X).
claim HTx: topology_on X (discrete_topology X).
{ exact (discrete_topology_on X). }
prove topology_on X (discrete_topology X) /\
  forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e discrete_topology X /\ V :e discrete_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact HTx.
- let x1 x2.
  assume Hx1X: x1 :e X.
  assume Hx2X: x2 :e X.
  assume Hneq: x1 <> x2.
  prove exists U V:set,
    U :e discrete_topology X /\ V :e discrete_topology X /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  witness {x1}.
  witness {x2}.
  claim HUopen: {x1} :e discrete_topology X.
  { claim Hsx1: {x1} c= X.
    { exact (singleton_subset x1 X Hx1X). }
    exact (discrete_open_all X {x1} Hsx1). }
  claim HVopen: {x2} :e discrete_topology X.
  { claim Hsx2: {x2} c= X.
    { exact (singleton_subset x2 X Hx2X). }
    exact (discrete_open_all X {x2} Hsx2). }
  claim Hdisj: {x1} :/\: {x2} = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e {x1} :/\: {x2}.
    prove z :e Empty.
    claim Hz1: z :e {x1}.
    { exact (binintersectE1 {x1} {x2} z Hz). }
    claim Hz2: z :e {x2}.
    { exact (binintersectE2 {x1} {x2} z Hz). }
    claim Hzx1: z = x1.
    { exact (SingE x1 z Hz1). }
    claim Hzx2: z = x2.
    { exact (SingE x2 z Hz2). }
    claim Hx1x2: x1 = x2.
    { rewrite <- Hzx1.
      rewrite <- Hzx2.
      reflexivity. }
    apply FalseE.
    exact (Hneq Hx1x2). }
  apply and5I.
  - exact HUopen.
  - exact HVopen.
  - exact (SingI x1).
  - exact (SingI x2).
  - exact Hdisj.
Qed.

(** from §33 Definition: Tychonoff space **) 
(** LATEX VERSION: Tychonoff = completely regular and Hausdorff. **)
Definition Tychonoff_space : set -> set -> prop := fun X Tx =>
  completely_regular_space X Tx /\ Hausdorff_space X Tx.

(** Helper: local basis element from generated_topology_from_subbasis **)
(** LATEX VERSION: If U is open in the topology generated from a subbasis, then every point of U lies in some nonempty finite intersection of subbasis elements contained in U. **)
Theorem generated_topology_from_subbasis_local_basis : forall X S U x:set,
  U :e generated_topology_from_subbasis X S ->
  x :e U ->
  exists b:set, b :e basis_of_subbasis X S /\ x :e b /\ b c= U.
let X S U x.
assume HU: U :e generated_topology_from_subbasis X S.
assume HxU: x :e U.
prove exists b:set, b :e basis_of_subbasis X S /\ x :e b /\ b c= U.
claim Hloc: forall z :e U, exists b :e basis_of_subbasis X S, z :e b /\ b c= U.
{ exact (SepE2 (Power X)
               (fun U0:set => forall z :e U0, exists b :e basis_of_subbasis X S, z :e b /\ b c= U0)
               U HU). }
claim Hexb: exists b :e basis_of_subbasis X S, x :e b /\ b c= U.
{ exact (Hloc x HxU). }
apply Hexb.
let b. assume Hbprop.
witness b.
exact (and_assoc_rev (b :e basis_of_subbasis X S) (x :e b) (b c= U) Hbprop).
Qed.

(** Helper: unfold a basis_of_subbasis member into a finite subcollection intersection **)
(** LATEX VERSION: Every basis element is a nonempty finite intersection of subbasis elements. **)
Theorem basis_of_subbasisE : forall X S b:set,
  b :e basis_of_subbasis X S ->
  exists F:set, F :e finite_subcollections S /\ b = intersection_of_family X F /\ b <> Empty.
let X S b.
assume Hb: b :e basis_of_subbasis X S.
prove exists F:set, F :e finite_subcollections S /\ b = intersection_of_family X F /\ b <> Empty.
claim HbFin: b :e finite_intersections_of X S.
{ exact (SepE1 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b Hb). }
claim HbNe: b <> Empty.
{ exact (SepE2 (finite_intersections_of X S) (fun b0:set => b0 <> Empty) b Hb). }
claim HexF: exists F :e finite_subcollections S, b = intersection_of_family X F.
{ exact (ReplE (finite_subcollections S) (fun F0:set => intersection_of_family X F0) b HbFin). }
apply HexF.
let F. assume HFand.
witness F.
apply andI.
- apply andI.
  + exact (andEL (F :e finite_subcollections S) (b = intersection_of_family X F) HFand).
  + exact (andER (F :e finite_subcollections S) (b = intersection_of_family X F) HFand).
- exact HbNe.
Qed.

(** Helper: subbasis elements are open in the topology generated from that subbasis **)
(** LATEX VERSION: Each subbasis element belongs to the generated topology. **)
Theorem generated_topology_from_subbasis_contains_subbasis_elem : forall X S s:set,
  subbasis_on X S ->
  s :e S ->
  s :e generated_topology_from_subbasis X S.
let X S s.
assume HS: subbasis_on X S.
assume Hs: s :e S.
prove s :e generated_topology_from_subbasis X S.
claim HT: topology_on X (generated_topology_from_subbasis X S).
{ exact (topology_from_subbasis_is_topology X S HS). }
apply (xm (s = Empty)).
- assume Hseq: s = Empty.
  rewrite Hseq.
  exact (topology_has_empty X (generated_topology_from_subbasis X S) HT).
- assume Hsne: ~(s = Empty).
  (** show s is a basis element of basis_of_subbasis X S **)
  claim HsSubX: s c= X.
  { claim HSsubPow: S c= Power X.
    { exact (andEL (S c= Power X) (Union S = X) HS). }
    claim HsPow: s :e Power X.
    { exact (HSsubPow s Hs). }
    exact (PowerE X s HsPow). }
  claim Hints: intersection_of_family X {s} = s.
  { exact (intersection_of_family_singleton_eq X s HsSubX). }
  claim HsingSub: {s} c= S.
  { let t. assume Ht: t :e {s}.
    claim Hteq: t = s.
    { exact (SingE s t Ht). }
    rewrite Hteq.
    exact Hs. }
  claim HsingPow: {s} :e Power S.
  { exact (PowerI S {s} HsingSub). }
  claim HsingFin: finite {s}.
  { exact (Sing_finite s). }
  claim HsingFS: {s} :e finite_subcollections S.
  { exact (SepI (Power S) (fun F0:set => finite F0) {s} HsingPow HsingFin). }
  claim HsInFinInt: s :e finite_intersections_of X S.
  { rewrite <- Hints.
    exact (ReplI (finite_subcollections S) (fun F0:set => intersection_of_family X F0) {s} HsingFS). }
  claim HsInBasis: s :e basis_of_subbasis X S.
  { exact (SepI (finite_intersections_of X S) (fun b0:set => b0 <> Empty) s HsInFinInt Hsne). }
  (** basis_of_subbasis X S is a basis under HS, hence its elements are open in the generated topology **)
  claim HBasis: basis_on X (basis_of_subbasis X S).
  { exact (finite_intersections_basis_of_subbasis X S HS). }
  claim HopenGen: s :e generated_topology X (basis_of_subbasis X S).
  { exact (generated_topology_contains_basis X (basis_of_subbasis X S) HBasis s HsInBasis). }
  exact HopenGen.
Qed.

(** Helper: evaluation map at coordinate i on a product_space **)
(** LATEX VERSION: The evaluation map ev_i:∏ X_j -> X_i is given by ev_i(f)=f(i). **)
Definition product_eval_map : set -> set -> set -> set := fun I Xi i =>
  graph (product_space I Xi) (fun f:set => apply_fun f i).

(** Helper: evaluation is continuous in the product_topology_full **)
(** LATEX VERSION: For product topology generated by cylinders, each evaluation map is continuous. **)
Theorem product_eval_map_continuous : forall I Xi i:set,
  (forall j:set, j :e I -> topology_on (space_family_set Xi j) (space_family_topology Xi j)) ->
  i :e I ->
  continuous_map (product_space I Xi) (product_topology_full I Xi)
    (space_family_set Xi i) (space_family_topology Xi i) (product_eval_map I Xi i).
let I Xi i.
assume HcompTop: forall j:set, j :e I -> topology_on (space_family_set Xi j) (space_family_topology Xi j).
assume HiI: i :e I.
set X := product_space I Xi.
set Tx := product_topology_full I Xi.
set Y := space_family_set Xi i.
set Ty := space_family_topology Xi i.
set f := product_eval_map I Xi i.
claim HIne: I <> Empty.
{ assume HI0: I = Empty.
  claim HiE: i :e Empty.
  { rewrite <- HI0 at 1. exact HiI. }
  exact (EmptyE i HiE). }
claim HSsub: subbasis_on X (product_subbasis_full I Xi).
{ exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
claim HTx: topology_on X Tx.
{ exact (topology_from_subbasis_is_topology X (product_subbasis_full I Xi) HSsub). }
claim Hfun: function_on f X Y.
{ let g. assume HgX: g :e X.
  prove apply_fun f g :e Y.
  claim Hfg: apply_fun f g = apply_fun g i.
  { exact (apply_fun_graph X (fun u:set => apply_fun u i) g HgX). }
  rewrite Hfg.
  claim HgProp:
    total_function_on g I (space_family_union I Xi) /\ functional_graph g /\
    forall j:set, j :e I -> apply_fun g j :e space_family_set Xi j.
  { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                 (fun g0:set =>
                   total_function_on g0 I (space_family_union I Xi) /\ functional_graph g0 /\
                   forall j:set, j :e I -> apply_fun g0 j :e space_family_set Xi j)
                 g HgX). }
  claim HgCoords: forall j:set, j :e I -> apply_fun g j :e space_family_set Xi j.
  { exact (andER (total_function_on g I (space_family_union I Xi) /\ functional_graph g)
                 (forall j:set, j :e I -> apply_fun g j :e space_family_set Xi j)
                 HgProp). }
  exact (HgCoords i HiI). }
prove continuous_map X Tx Y Ty f.
(** continuity: preimage of each open U in Ty is the cylinder product_cylinder I Xi i U, which is in the subbasis **)
prove topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
  forall U:set, U :e Ty -> preimage_of X f U :e Tx.
apply andI.
- apply andI.
  + apply andI.
    * exact HTx.
    * exact (HcompTop i HiI).
  + exact Hfun.
- let U. assume HU: U :e Ty.
  prove preimage_of X f U :e Tx.
  claim HcylEq: preimage_of X f U = product_cylinder I Xi i U.
  { apply set_ext.
    - let g. assume HgPre: g :e preimage_of X f U.
      prove g :e product_cylinder I Xi i U.
      claim HgX: g :e X.
      { exact (SepE1 X (fun u0:set => apply_fun f u0 :e U) g HgPre). }
      claim HfgU: apply_fun f g :e U.
      { exact (SepE2 X (fun u0:set => apply_fun f u0 :e U) g HgPre). }
      claim Hfg: apply_fun f g = apply_fun g i.
      { exact (apply_fun_graph X (fun u0:set => apply_fun u0 i) g HgX). }
      claim HgiU: apply_fun g i :e U.
      { rewrite <- Hfg. exact HfgU. }
      exact (SepI X (fun u0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun u0 i :e U) g HgX
              (andI (i :e I /\ U :e space_family_topology Xi i) (apply_fun g i :e U)
                    (andI (i :e I) (U :e space_family_topology Xi i) HiI HU) HgiU)).
    - let g. assume HgCyl: g :e product_cylinder I Xi i U.
      prove g :e preimage_of X f U.
      claim HgX: g :e X.
      { exact (SepE1 X (fun u0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun u0 i :e U) g HgCyl). }
      claim HgProp: i :e I /\ U :e space_family_topology Xi i /\ apply_fun g i :e U.
      { exact (SepE2 X (fun u0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun u0 i :e U) g HgCyl). }
      claim HgiU: apply_fun g i :e U.
      { exact (andER (i :e I /\ U :e space_family_topology Xi i) (apply_fun g i :e U) HgProp). }
      claim Hpre_def: preimage_of X f U = {x0 :e X | apply_fun f x0 :e U}.
      { reflexivity. }
      rewrite Hpre_def at 1.
      apply (SepI X (fun x0:set => apply_fun f x0 :e U) g HgX).
      claim Hfg: apply_fun f g = apply_fun g i.
      { exact (apply_fun_graph X (fun u0:set => apply_fun u0 i) g HgX). }
      rewrite Hfg.
      exact HgiU. }
  rewrite HcylEq.
  (** cylinder is a subbasis element, hence open in the generated topology **)
  claim HcylSub: product_cylinder I Xi i U :e product_subbasis_full I Xi.
  { set Fam := (fun j:set => {product_cylinder I Xi j V|V :e space_family_topology Xi j}).
    claim HcylFam: product_cylinder I Xi i U :e Fam i.
    { exact (ReplI (space_family_topology Xi i) (fun V0:set => product_cylinder I Xi i V0) U HU). }
    exact (famunionI I Fam i (product_cylinder I Xi i U) HiI HcylFam). }
  exact (generated_topology_from_subbasis_contains_subbasis_elem X (product_subbasis_full I Xi) (product_cylinder I Xi i U) HSsub HcylSub).
Qed.

(** Helper: finite-subcollection subbasis neighborhood inside an open set **)
(** LATEX VERSION: In a topology generated by a subbasis, every open neighborhood contains a finite intersection of subbasis elements containing the point. **)
Theorem generated_topology_from_subbasis_finite_neighborhood : forall X S U x:set,
  subbasis_on X S ->
  U :e generated_topology_from_subbasis X S ->
  x :e U ->
  exists F:set, F :e finite_subcollections S /\
    x :e intersection_of_family X F /\ intersection_of_family X F c= U.
let X S U x.
assume HS: subbasis_on X S.
assume HU: U :e generated_topology_from_subbasis X S.
assume HxU: x :e U.
prove exists F:set, F :e finite_subcollections S /\
  x :e intersection_of_family X F /\ intersection_of_family X F c= U.
claim Hexb: exists b:set, b :e basis_of_subbasis X S /\ x :e b /\ b c= U.
{ exact (generated_topology_from_subbasis_local_basis X S U x HU HxU). }
apply Hexb.
let b. assume Hbtrip.
claim Hb12: b :e basis_of_subbasis X S /\ x :e b.
{ exact (andEL (b :e basis_of_subbasis X S /\ x :e b) (b c= U) Hbtrip). }
claim HbB: b :e basis_of_subbasis X S.
{ exact (andEL (b :e basis_of_subbasis X S) (x :e b) Hb12). }
claim Hxb: x :e b.
{ exact (andER (b :e basis_of_subbasis X S) (x :e b) Hb12). }
claim HbSubU: b c= U.
{ exact (andER (b :e basis_of_subbasis X S /\ x :e b) (b c= U) Hbtrip). }
claim HexF: exists F:set, F :e finite_subcollections S /\ b = intersection_of_family X F /\ b <> Empty.
{ exact (basis_of_subbasisE X S b HbB). }
apply HexF.
let F. assume HFpack.
witness F.
claim HF12: F :e finite_subcollections S /\ b = intersection_of_family X F.
{ exact (andEL (F :e finite_subcollections S /\ b = intersection_of_family X F) (b <> Empty) HFpack). }
claim HbNe: b <> Empty.
{ exact (andER (F :e finite_subcollections S /\ b = intersection_of_family X F) (b <> Empty) HFpack). }
claim HFfin: F :e finite_subcollections S.
{ exact (andEL (F :e finite_subcollections S) (b = intersection_of_family X F) HF12). }
claim HbEq: b = intersection_of_family X F.
{ exact (andER (F :e finite_subcollections S) (b = intersection_of_family X F) HF12). }
claim HxInt: x :e intersection_of_family X F.
{ rewrite <- HbEq at 1.
  exact Hxb. }
claim HintSubU: intersection_of_family X F c= U.
{ let y. assume Hy: y :e intersection_of_family X F.
  prove y :e U.
  claim Hyb: y :e b.
  { rewrite HbEq at 1.
    exact Hy. }
  exact (HbSubU y Hyb). }
claim Hleft: F :e finite_subcollections S /\ x :e intersection_of_family X F.
{ exact (andI (F :e finite_subcollections S) (x :e intersection_of_family X F) HFfin HxInt). }
exact (andI (F :e finite_subcollections S /\ x :e intersection_of_family X F)
            (intersection_of_family X F c= U)
            Hleft HintSubU).
Qed.

(** Helper: unpack a product subbasis element as a cylinder **)
(** LATEX VERSION: Every element of the product subbasis has the form pi_i^{-1}(U_i). **)
Theorem product_subbasis_fullE : forall I Xi s:set,
  s :e product_subbasis_full I Xi ->
  exists i:set, i :e I /\ exists U:set, U :e space_family_topology Xi i /\ s = product_cylinder I Xi i U.
let I Xi s.
assume Hs: s :e product_subbasis_full I Xi.
prove exists i:set, i :e I /\ exists U:set, U :e space_family_topology Xi i /\ s = product_cylinder I Xi i U.
set Fam := (fun i:set => {product_cylinder I Xi i U|U :e space_family_topology Xi i}).
claim Hexi: exists i :e I, s :e Fam i.
{ exact (famunionE I Fam s Hs). }
apply Hexi.
let i. assume Hipack.
claim HiI: i :e I.
{ exact (andEL (i :e I) (s :e Fam i) Hipack). }
claim HsFam: s :e Fam i.
{ exact (andER (i :e I) (s :e Fam i) Hipack). }
witness i.
apply andI.
- exact HiI.
- exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0) s HsFam).
Qed.

(** Helper: combine two continuous 0-1 separators **)
(** LATEX VERSION: If f and g are continuous, then a continuous max-like combination can be used to propagate 0 at a point and 1 on the union of the 1-sets. **)
Theorem continuous_combine_or_01 : forall X Tx f g x0:set,
  topology_on X Tx ->
  continuous_map X Tx R R_standard_topology f ->
  continuous_map X Tx R R_standard_topology g ->
  x0 :e X ->
  apply_fun f x0 = 0 ->
  apply_fun g x0 = 0 ->
  exists h:set,
    continuous_map X Tx R R_standard_topology h /\
    apply_fun h x0 = 0 /\
    forall y:set, y :e X -> (apply_fun f y = 1 \/ apply_fun g y = 1) -> apply_fun h y = 1.
let X Tx f g x0.
assume HTx: topology_on X Tx.
assume Hfcont: continuous_map X Tx R R_standard_topology f.
assume Hgcont: continuous_map X Tx R R_standard_topology g.
assume Hx0X: x0 :e X.
assume Hfx0: apply_fun f x0 = 0.
assume Hgx0: apply_fun g x0 = 0.
prove exists h:set,
  continuous_map X Tx R R_standard_topology h /\
  apply_fun h x0 = 0 /\
  forall y:set, y :e X -> (apply_fun f y = 1 \/ apply_fun g y = 1) -> apply_fun h y = 1.

claim HfFun: function_on f X R.
{ exact (continuous_map_function_on X Tx R R_standard_topology f Hfcont). }
claim HgFun: function_on g X R.
{ exact (continuous_map_function_on X Tx R R_standard_topology g Hgcont). }

(** h0 x is min(1, max(fx,gx)) implemented via If_i and Rlt **)
set maxfg := (fun x:set => if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
set h0 := (fun x:set => if (Rlt 1 (maxfg x)) then 1 else (maxfg x)).
set h := graph X (fun x:set => h0 x).
witness h.
apply andI.
- (** continuity and h(x0)=0 **)
  apply andI.
  + (** continuity of h **)
    claim Hfunh: function_on h X R.
    { let x. assume HxX: x :e X.
      rewrite (apply_fun_graph X (fun u:set => h0 u) x HxX).
      claim HfxR: apply_fun f x :e R.
      { exact (HfFun x HxX). }
      claim HgxR: apply_fun g x :e R.
      { exact (HgFun x HxX). }
      claim HmaxR: maxfg x :e R.
      { claim Hdef: maxfg x =
          (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
        { reflexivity. }
        rewrite Hdef.
        apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
        - assume Hlt: Rlt (apply_fun f x) (apply_fun g x).
          rewrite (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hlt).
          exact HgxR.
        - assume Hnlt: ~(Rlt (apply_fun f x) (apply_fun g x)).
          rewrite (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnlt).
          exact HfxR. }
      apply (xm (Rlt 1 (maxfg x))).
      - assume H1lt: Rlt 1 (maxfg x).
        rewrite (If_i_1 (Rlt 1 (maxfg x)) 1 (maxfg x) H1lt).
        exact real_1.
      - assume Hn1lt: ~(Rlt 1 (maxfg x)).
        rewrite (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt).
        exact HmaxR. }

    set S := open_rays_subbasis R.
    claim HS: subbasis_on R S.
    { exact (open_rays_subbasis_is_subbasis R). }
    claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
    { rewrite open_rays_subbasis_for_order_topology_R.
      rewrite standard_topology_is_order_topology.
      reflexivity. }
    rewrite <- Hgen.
    apply (continuous_map_from_subbasis X Tx R S h HTx Hfunh HS).
    let s. assume HsS: s :e S.
    prove preimage_of X h s :e Tx.
    apply (binunionE' ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
                       :\/:
                       {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
                      {R}
                      s
                      (preimage_of X h s :e Tx)).
    - assume Hs0: s :e ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
                        :\/:
                        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}).
      apply (binunionE' {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
                        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}
                        s
                        (preimage_of X h s :e Tx)).
      + (** upper ray **)
        assume Hsup: s :e {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}.
        claim Hexa0: exists a0 :e R, s = open_ray_upper R a0.
        { exact (SepE2 (Power R) (fun I0:set => exists a0 :e R, I0 = open_ray_upper R a0) s Hsup). }
        apply Hexa0.
        let a. assume Hapack.
        apply Hapack.
        assume HaR: a :e R.
        assume Hseq: s = open_ray_upper R a.
        rewrite Hseq.

        set Uf := preimage_of X f (open_ray_upper R a).
        set Ug := preimage_of X g (open_ray_upper R a).
        claim HopenRay: open_ray_upper R a :e R_standard_topology.
        { rewrite <- standard_topology_is_order_topology.
          claim HsRay: open_ray_upper R a :e open_rays_subbasis R.
          { exact (open_ray_upper_in_open_rays_subbasis R a HaR). }
          exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R a) HsRay). }
        claim HUf: Uf :e Tx.
        { exact (continuous_map_preimage X Tx R R_standard_topology f Hfcont (open_ray_upper R a) HopenRay). }
        claim HUg: Ug :e Tx.
        { exact (continuous_map_preimage X Tx R R_standard_topology g Hgcont (open_ray_upper R a) HopenRay). }

        apply (xm (Rlt a 1)).
        * (** a < 1: preimage is Uf ∪ Ug **)
          assume Halt: Rlt a 1.
          claim HpreEq: preimage_of X h (open_ray_upper R a) = Uf :\/: Ug.
          { apply set_ext.
            - let x. assume Hx: x :e preimage_of X h (open_ray_upper R a).
              prove x :e Uf :\/: Ug.
              claim HxX: x :e X.
              { exact (SepE1 X (fun u:set => apply_fun h u :e open_ray_upper R a) x Hx). }
              claim HhxRay: apply_fun h x :e open_ray_upper R a.
              { exact (SepE2 X (fun u:set => apply_fun h u :e open_ray_upper R a) x Hx). }
              claim HhxEq: apply_fun h x = h0 x.
              { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
              claim Hrel: order_rel R a (apply_fun h x).
              { exact (SepE2 R (fun r:set => order_rel R a r) (apply_fun h x) HhxRay). }
              claim Halt_h: Rlt a (apply_fun h x).
              { exact (order_rel_R_implies_Rlt a (apply_fun h x) Hrel). }
	              claim Halt_h0: Rlt a (h0 x).
	              { rewrite <- HhxEq.
	                exact Halt_h. }
              claim HaxMax: Rlt a (maxfg x).
              { apply (xm (Rlt 1 (maxfg x))).
                - assume H1lt: Rlt 1 (maxfg x).
                  exact (Rlt_tra a 1 (maxfg x) Halt H1lt).
                - assume Hn1lt: ~(Rlt 1 (maxfg x)).
                  claim Heq: h0 x = maxfg x.
                  { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
                  rewrite <- Heq at 1.
                  exact Halt_h0. }
	              claim Hor: Rlt a (apply_fun f x) \/ Rlt a (apply_fun g x).
	              { apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
	                - assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
	                  claim Heq: maxfg x = apply_fun g x.
	                  { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
	                  claim Hag: Rlt a (apply_fun g x).
	                  { rewrite <- Heq.
	                    exact HaxMax. }
	                  exact (orIR (Rlt a (apply_fun f x)) (Rlt a (apply_fun g x)) Hag).
	                - assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
	                  claim Heq: maxfg x = apply_fun f x.
	                  { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
	                  claim Haf: Rlt a (apply_fun f x).
	                  { rewrite <- Heq.
	                    exact HaxMax. }
	                  exact (orIL (Rlt a (apply_fun f x)) (Rlt a (apply_fun g x)) Haf). }
              apply Hor.
              - assume Haf: Rlt a (apply_fun f x).
                prove x :e Uf :\/: Ug.
                claim HfxR: apply_fun f x :e R.
                { exact (HfFun x HxX). }
                claim HfxRay: apply_fun f x :e open_ray_upper R a.
                { exact (SepI R (fun r:set => order_rel R a r) (apply_fun f x) HfxR (Rlt_implies_order_rel_R a (apply_fun f x) Haf)). }
                claim HxUf: x :e Uf.
                { exact (SepI X (fun u:set => apply_fun f u :e open_ray_upper R a) x HxX HfxRay). }
                exact (binunionI1 Uf Ug x HxUf).
              - assume Hag: Rlt a (apply_fun g x).
                prove x :e Uf :\/: Ug.
                claim HgxR: apply_fun g x :e R.
                { exact (HgFun x HxX). }
                claim HgxRay: apply_fun g x :e open_ray_upper R a.
                { exact (SepI R (fun r:set => order_rel R a r) (apply_fun g x) HgxR (Rlt_implies_order_rel_R a (apply_fun g x) Hag)). }
                claim HxUg: x :e Ug.
                { exact (SepI X (fun u:set => apply_fun g u :e open_ray_upper R a) x HxX HgxRay). }
                exact (binunionI2 Uf Ug x HxUg).
            - let x. assume Hx: x :e Uf :\/: Ug.
              prove x :e preimage_of X h (open_ray_upper R a).
              claim HxX: x :e X.
              { apply (binunionE' Uf Ug x (x :e X)).
                - assume HxUf: x :e Uf.
                  exact (SepE1 X (fun u:set => apply_fun f u :e open_ray_upper R a) x HxUf).
                - assume HxUg: x :e Ug.
                  exact (SepE1 X (fun u:set => apply_fun g u :e open_ray_upper R a) x HxUg).
                - exact Hx. }
              claim Hor: Rlt a (apply_fun f x) \/ Rlt a (apply_fun g x).
              { apply (binunionE' Uf Ug x (Rlt a (apply_fun f x) \/ Rlt a (apply_fun g x))).
                - assume HxUf: x :e Uf.
                  claim HfxRay: apply_fun f x :e open_ray_upper R a.
                  { exact (SepE2 X (fun u:set => apply_fun f u :e open_ray_upper R a) x HxUf). }
                  claim Hrel: order_rel R a (apply_fun f x).
                  { exact (SepE2 R (fun r:set => order_rel R a r) (apply_fun f x) HfxRay). }
                  exact (orIL (Rlt a (apply_fun f x)) (Rlt a (apply_fun g x)) (order_rel_R_implies_Rlt a (apply_fun f x) Hrel)).
                - assume HxUg: x :e Ug.
                  claim HgxRay: apply_fun g x :e open_ray_upper R a.
                  { exact (SepE2 X (fun u:set => apply_fun g u :e open_ray_upper R a) x HxUg). }
                  claim Hrel: order_rel R a (apply_fun g x).
                  { exact (SepE2 R (fun r:set => order_rel R a r) (apply_fun g x) HgxRay). }
                  exact (orIR (Rlt a (apply_fun f x)) (Rlt a (apply_fun g x)) (order_rel_R_implies_Rlt a (apply_fun g x) Hrel)).
                - exact Hx. }
	              claim HaxMax: Rlt a (maxfg x).
	              { apply Hor.
	                - assume Haf: Rlt a (apply_fun f x).
	                  prove Rlt a (maxfg x).
	                  apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
	                  + assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
	                    claim Heq: maxfg x = apply_fun g x.
	                    { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
	                    rewrite Heq.
	                    exact (Rlt_tra a (apply_fun f x) (apply_fun g x) Haf Hfg).
	                  + assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
	                    claim Heq: maxfg x = apply_fun f x.
	                    { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
	                    rewrite Heq.
	                    exact Haf.
	                - assume Hag: Rlt a (apply_fun g x).
	                  prove Rlt a (maxfg x).
	                  apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
	                  + assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
	                    claim Heq: maxfg x = apply_fun g x.
	                    { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
	                    rewrite Heq.
	                    exact Hag.
	                  + assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
	                    claim Heq: maxfg x = apply_fun f x.
	                    { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
	                    rewrite Heq.
	                    claim HgxR: apply_fun g x :e R.
	                    { exact (HgFun x HxX). }
	                    claim HfxR: apply_fun f x :e R.
	                    { exact (HfFun x HxX). }
	                    claim Hle: Rle (apply_fun g x) (apply_fun f x).
	                    { exact (RleI (apply_fun g x) (apply_fun f x) HgxR HfxR Hnfg). }
	                    exact (Rlt_Rle_tra a (apply_fun g x) (apply_fun f x) Hag Hle). }
              claim Himg: apply_fun h x :e open_ray_upper R a.
	              { claim HhxEq: apply_fun h x = h0 x.
	                { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
	                rewrite HhxEq.
	                claim Hdef0: h0 x = (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)).
	                { reflexivity. }
	                rewrite Hdef0.
	                apply (xm (Rlt 1 (maxfg x))).
                - assume H1lt: Rlt 1 (maxfg x).
                  claim Heq: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = 1.
                  { exact (If_i_1 (Rlt 1 (maxfg x)) 1 (maxfg x) H1lt). }
                  rewrite Heq.
                  exact (SepI R (fun r:set => order_rel R a r) 1 real_1 (Rlt_implies_order_rel_R a 1 Halt)).
                - assume Hn1lt: ~(Rlt 1 (maxfg x)).
                  claim Heq: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = (maxfg x).
                  { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
                  rewrite Heq.
                  claim HmaxR: maxfg x :e R.
                  { claim Hdef: maxfg x =
                      (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
                    { reflexivity. }
                    rewrite Hdef.
                    apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
                    + assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
                      rewrite (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg).
                      exact (HgFun x HxX).
                    + assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
                      rewrite (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg).
                      exact (HfFun x HxX). }
                  exact (SepI R (fun r:set => order_rel R a r) (maxfg x) HmaxR (Rlt_implies_order_rel_R a (maxfg x) HaxMax)). }
              exact (SepI X (fun u:set => apply_fun h u :e open_ray_upper R a) x HxX Himg). }
          rewrite HpreEq.
          exact (topology_binunion_closed X Tx Uf Ug HTx HUf HUg).
        * (** a >= 1: preimage is empty **)
          assume Hnalt: ~(Rlt a 1).
          claim HpreEq: preimage_of X h (open_ray_upper R a) = Empty.
          { apply set_ext.
            - let x. assume Hx: x :e preimage_of X h (open_ray_upper R a).
              prove x :e Empty.
              apply FalseE.
              claim HxX: x :e X.
              { exact (SepE1 X (fun u:set => apply_fun h u :e open_ray_upper R a) x Hx). }
              claim HhxRay: apply_fun h x :e open_ray_upper R a.
              { exact (SepE2 X (fun u:set => apply_fun h u :e open_ray_upper R a) x Hx). }
              claim Hrel: order_rel R a (apply_fun h x).
              { exact (SepE2 R (fun r:set => order_rel R a r) (apply_fun h x) HhxRay). }
              claim Halt_h: Rlt a (apply_fun h x).
              { exact (order_rel_R_implies_Rlt a (apply_fun h x) Hrel). }
              claim HhxEq: apply_fun h x = h0 x.
              { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
	              claim Halt_h0: Rlt a (h0 x).
	              { rewrite <- HhxEq.
	                exact Halt_h. }
              apply (xm (Rlt 1 (maxfg x))).
              + assume H1lt: Rlt 1 (maxfg x).
                claim Heq: h0 x = 1.
                { exact (If_i_1 (Rlt 1 (maxfg x)) 1 (maxfg x) H1lt). }
	                claim Halt1: Rlt a 1.
	                { rewrite <- Heq.
	                  exact Halt_h0. }
                exact (Hnalt Halt1).
              + assume Hn1lt: ~(Rlt 1 (maxfg x)).
	                claim Heq: h0 x = maxfg x.
	                { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
	                claim HmaxR: maxfg x :e R.
	                { claim Hdef: maxfg x =
	                    (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
	                  { reflexivity. }
	                  rewrite Hdef.
		                  apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
		                  * assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
		                    rewrite (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg).
		                    exact (HgFun x HxX).
		                  * assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
		                    rewrite (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg).
		                    exact (HfFun x HxX). }
	                claim Hle: Rle (maxfg x) 1.
	                { exact (RleI (maxfg x) 1 HmaxR real_1 Hn1lt). }
	                claim Halt1: Rlt a 1.
	                { claim HaltMax: Rlt a (maxfg x).
	                  { rewrite <- Heq.
	                    exact Halt_h0. }
	                  exact (Rlt_Rle_tra a (maxfg x) 1 HaltMax Hle). }
	                exact (Hnalt Halt1).
            - let x. assume HxE: x :e Empty.
              exact (FalseE (EmptyE x HxE) (x :e preimage_of X h (open_ray_upper R a))). }
          rewrite HpreEq.
          exact (topology_has_empty X Tx HTx).
      + (** lower ray **)
        assume Hslo: s :e {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}.
        claim Hexb0: exists b0 :e R, s = open_ray_lower R b0.
        { exact (SepE2 (Power R) (fun I0:set => exists b0 :e R, I0 = open_ray_lower R b0) s Hslo). }
        apply Hexb0.
        let b. assume Hbpack.
        apply Hbpack.
        assume HbR: b :e R.
        assume Hseq: s = open_ray_lower R b.
        rewrite Hseq.

        set Lf := preimage_of X f (open_ray_lower R b).
        set Lg := preimage_of X g (open_ray_lower R b).
        claim HopenRay: open_ray_lower R b :e R_standard_topology.
        { rewrite <- standard_topology_is_order_topology.
          claim HsRay: open_ray_lower R b :e open_rays_subbasis R.
          { exact (open_ray_lower_in_open_rays_subbasis R b HbR). }
          exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R b) HsRay). }
        claim HLf: Lf :e Tx.
        { exact (continuous_map_preimage X Tx R R_standard_topology f Hfcont (open_ray_lower R b) HopenRay). }
        claim HLg: Lg :e Tx.
        { exact (continuous_map_preimage X Tx R R_standard_topology g Hgcont (open_ray_lower R b) HopenRay). }

        apply (xm (Rlt 1 b)).
        * (** 1 < b: preimage is X **)
          assume H1ltb: Rlt 1 b.
          claim HpreEq: preimage_of X h (open_ray_lower R b) = X.
          { apply set_ext.
		            - let x. assume Hx: x :e preimage_of X h (open_ray_lower R b).
		              exact (SepE1 X (fun u:set => apply_fun h u :e open_ray_lower R b) x Hx).
		            - let x. assume HxX: x :e X.
		              claim HhxRay: apply_fun h x :e open_ray_lower R b.
			              { claim HhxEq: apply_fun h x = h0 x.
			                { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
			                rewrite HhxEq.
			                claim Hdef0: h0 x = (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)).
			                { reflexivity. }
			                rewrite Hdef0.
			                apply (xm (Rlt 1 (maxfg x))).
			                - assume H1lt: Rlt 1 (maxfg x).
			                  claim Heq: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = 1.
			                  { exact (If_i_1 (Rlt 1 (maxfg x)) 1 (maxfg x) H1lt). }
			                  rewrite Heq at 1.
			                  exact (SepI R (fun r:set => order_rel R r b) 1 real_1 (Rlt_implies_order_rel_R 1 b H1ltb)).
		                - assume Hn1lt: ~(Rlt 1 (maxfg x)).
		                  claim HmaxR: maxfg x :e R.
		                  { claim Hdef: maxfg x =
		                      (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
		                    { reflexivity. }
		                    rewrite Hdef at 1.
		                    apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
		                    * assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
		                      claim Heq: (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)) = (apply_fun g x).
		                      { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
		                      rewrite Heq at 1.
		                      exact (HgFun x HxX).
		                    * assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
		                      claim Heq: (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)) = (apply_fun f x).
		                      { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
		                      rewrite Heq at 1.
		                      exact (HfFun x HxX). }
		                  claim Hle: Rle (maxfg x) 1.
		                  { exact (RleI (maxfg x) 1 HmaxR real_1 Hn1lt). }
		                  claim Hlt: Rlt (maxfg x) b.
		                  { exact (Rle_Rlt_tra (maxfg x) 1 b Hle H1ltb). }
			                  claim Heq: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = (maxfg x).
			                  { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
			                  rewrite Heq at 1.
		                  exact (SepI R (fun r:set => order_rel R r b) (maxfg x) HmaxR (Rlt_implies_order_rel_R (maxfg x) b Hlt)). }
		              exact (SepI X (fun u:set => apply_fun h u :e open_ray_lower R b) x HxX HhxRay). }
          rewrite HpreEq.
          exact (topology_has_X X Tx HTx).
        * (** b <= 1: preimage is Lf ∩ Lg **)
          assume Hn1ltb: ~(Rlt 1 b).
          claim HbLe1: Rle b 1.
          { exact (RleI b 1 HbR real_1 Hn1ltb). }
          claim HpreEq: preimage_of X h (open_ray_lower R b) = Lf :/\: Lg.
          { apply set_ext.
            - let x. assume Hx: x :e preimage_of X h (open_ray_lower R b).
              prove x :e Lf :/\: Lg.
              claim HxX: x :e X.
              { exact (SepE1 X (fun u:set => apply_fun h u :e open_ray_lower R b) x Hx). }
              claim HhxRay: apply_fun h x :e open_ray_lower R b.
              { exact (SepE2 X (fun u:set => apply_fun h u :e open_ray_lower R b) x Hx). }
              claim Hrel: order_rel R (apply_fun h x) b.
              { exact (SepE2 R (fun r:set => order_rel R r b) (apply_fun h x) HhxRay). }
              claim Hlt: Rlt (apply_fun h x) b.
              { exact (order_rel_R_implies_Rlt (apply_fun h x) b Hrel). }
              claim HhxEq: apply_fun h x = h0 x.
              { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
              claim Hlt0: Rlt (h0 x) b.
              { rewrite <- HhxEq at 1.
                exact Hlt. }
              claim Hdef0: h0 x = (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)).
              { reflexivity. }
              (** since b <= 1, h0 x < b forces h0 x = maxfg x and maxfg x < b **)
              claim Hn1lt: ~(Rlt 1 (maxfg x)).
              { assume H1lt: Rlt 1 (maxfg x).
                claim HeqIf: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = 1.
                { exact (If_i_1 (Rlt 1 (maxfg x)) 1 (maxfg x) H1lt). }
                claim Heq: h0 x = 1.
                { rewrite Hdef0 at 1.
                  exact HeqIf. }
                claim H1ltb: Rlt 1 b.
                { rewrite <- Heq at 1.
                  exact Hlt0. }
                exact (Hn1ltb H1ltb). }
              claim HeqIf: (if (Rlt 1 (maxfg x)) then 1 else (maxfg x)) = (maxfg x).
              { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
              claim Heq: h0 x = maxfg x.
              { rewrite Hdef0 at 1.
                exact HeqIf. }
              claim Hmaxlt: Rlt (maxfg x) b.
              { rewrite <- Heq at 1.
                exact Hlt0. }
              (** max < b implies both f(x)<b and g(x)<b **)
              claim Hfb: Rlt (apply_fun f x) b.
              { apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
                - assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
                  claim HeqM: maxfg x = apply_fun g x.
                  { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
                  claim HgbLt: Rlt (apply_fun g x) b.
                  { rewrite <- HeqM at 1.
                    exact Hmaxlt. }
                  exact (Rlt_tra (apply_fun f x) (apply_fun g x) b Hfg HgbLt).
                - assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
                  claim HeqM: maxfg x = apply_fun f x.
                  { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
                  claim HfbLt: Rlt (apply_fun f x) b.
                  { rewrite <- HeqM at 1.
                    exact Hmaxlt. }
                  exact HfbLt. }
              claim Hgb: Rlt (apply_fun g x) b.
              { apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
                - assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
                  claim HeqM: maxfg x = apply_fun g x.
                  { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
                  claim HgbLt: Rlt (apply_fun g x) b.
                  { rewrite <- HeqM at 1.
                    exact Hmaxlt. }
                  exact HgbLt.
                - assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
                  claim HeqM: maxfg x = apply_fun f x.
                  { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
                  claim HfbLt: Rlt (apply_fun f x) b.
                  { rewrite <- HeqM at 1.
                    exact Hmaxlt. }
                  claim HgxR: apply_fun g x :e R.
                  { exact (HgFun x HxX). }
                  claim HfxR: apply_fun f x :e R.
                  { exact (HfFun x HxX). }
                  claim Hle: Rle (apply_fun g x) (apply_fun f x).
                  { exact (RleI (apply_fun g x) (apply_fun f x) HgxR HfxR Hnfg). }
	                  exact (Rle_Rlt_tra (apply_fun g x) (apply_fun f x) b Hle HfbLt). }
              claim HfxR: apply_fun f x :e R.
              { exact (HfFun x HxX). }
              claim HgxR: apply_fun g x :e R.
              { exact (HgFun x HxX). }
              claim HfxRay: apply_fun f x :e open_ray_lower R b.
              { exact (SepI R (fun r:set => order_rel R r b) (apply_fun f x) HfxR (Rlt_implies_order_rel_R (apply_fun f x) b Hfb)). }
              claim HgxRay: apply_fun g x :e open_ray_lower R b.
              { exact (SepI R (fun r:set => order_rel R r b) (apply_fun g x) HgxR (Rlt_implies_order_rel_R (apply_fun g x) b Hgb)). }
              claim HxLf: x :e Lf.
              { exact (SepI X (fun u:set => apply_fun f u :e open_ray_lower R b) x HxX HfxRay). }
              claim HxLg: x :e Lg.
              { exact (SepI X (fun u:set => apply_fun g u :e open_ray_lower R b) x HxX HgxRay). }
              exact (binintersectI Lf Lg x HxLf HxLg).
            - let x. assume Hx: x :e Lf :/\: Lg.
              prove x :e preimage_of X h (open_ray_lower R b).
              claim HxLf: x :e Lf.
              { exact (binintersectE1 Lf Lg x Hx). }
              claim HxLg: x :e Lg.
              { exact (binintersectE2 Lf Lg x Hx). }
              claim HxX: x :e X.
              { exact (SepE1 X (fun u:set => apply_fun f u :e open_ray_lower R b) x HxLf). }
              claim HfxRay: apply_fun f x :e open_ray_lower R b.
              { exact (SepE2 X (fun u:set => apply_fun f u :e open_ray_lower R b) x HxLf). }
              claim HgxRay: apply_fun g x :e open_ray_lower R b.
              { exact (SepE2 X (fun u:set => apply_fun g u :e open_ray_lower R b) x HxLg). }
              claim Hfb: Rlt (apply_fun f x) b.
              { exact (order_rel_R_implies_Rlt (apply_fun f x) b (SepE2 R (fun r:set => order_rel R r b) (apply_fun f x) HfxRay)). }
              claim Hgb: Rlt (apply_fun g x) b.
              { exact (order_rel_R_implies_Rlt (apply_fun g x) b (SepE2 R (fun r:set => order_rel R r b) (apply_fun g x) HgxRay)). }
              (** show maxfg x < b from both < b **)
              claim Hmaxlt: Rlt (maxfg x) b.
              { apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
                - assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
                  claim HeqM: maxfg x = apply_fun g x.
                  { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
                  rewrite HeqM.
                  exact Hgb.
                - assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
                  claim HeqM: maxfg x = apply_fun f x.
                  { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
                  rewrite HeqM.
                  exact Hfb. }
              (** since maxfg x < b <= 1, we have not(1 < maxfg x) and h0 x = maxfg x **)
              claim HmaxR: maxfg x :e R.
              { claim Hdef: maxfg x =
                  (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)).
                { reflexivity. }
                rewrite Hdef at 1.
                apply (xm (Rlt (apply_fun f x) (apply_fun g x))).
                - assume Hfg: Rlt (apply_fun f x) (apply_fun g x).
                  claim Heq: (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)) = (apply_fun g x).
                  { exact (If_i_1 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hfg). }
                  rewrite Heq at 1.
                  exact (HgFun x HxX).
                - assume Hnfg: ~(Rlt (apply_fun f x) (apply_fun g x)).
                  claim Heq: (if (Rlt (apply_fun f x) (apply_fun g x)) then (apply_fun g x) else (apply_fun f x)) = (apply_fun f x).
                  { exact (If_i_0 (Rlt (apply_fun f x) (apply_fun g x)) (apply_fun g x) (apply_fun f x) Hnfg). }
                  rewrite Heq at 1.
                  exact (HfFun x HxX). }
              claim HmaxLe1: Rle (maxfg x) 1.
              { claim HmaxLt1: Rlt (maxfg x) 1.
                { exact (Rlt_Rle_tra (maxfg x) b 1 Hmaxlt HbLe1). }
                exact (Rlt_implies_Rle (maxfg x) 1 HmaxLt1). }
              claim Hn1lt: ~(Rlt 1 (maxfg x)).
              { assume H1lt: Rlt 1 (maxfg x).
                exact ((RleE_nlt (maxfg x) 1 HmaxLe1) H1lt). }
              claim Heq0: h0 x = maxfg x.
              { exact (If_i_0 (Rlt 1 (maxfg x)) 1 (maxfg x) Hn1lt). }
              claim HhxRay: apply_fun h x :e open_ray_lower R b.
              { claim HhxEq: apply_fun h x = h0 x.
                { exact (apply_fun_graph X (fun u:set => h0 u) x HxX). }
                rewrite HhxEq.
                rewrite Heq0 at 1.
                exact (SepI R (fun r:set => order_rel R r b) (maxfg x) HmaxR (Rlt_implies_order_rel_R (maxfg x) b Hmaxlt)). }
              exact (SepI X (fun u:set => apply_fun h u :e open_ray_lower R b) x HxX HhxRay). }
          rewrite HpreEq.
          exact (topology_binintersect_closed X Tx Lf Lg HTx HLf HLg).
      + exact Hs0.
    - assume HsR: s :e {R}.
      claim Hseq: s = R.
      { exact (SingE R s HsR). }
      rewrite Hseq.
      claim HpreEq: preimage_of X h R = X.
      { exact (preimage_of_whole X R h Hfunh). }
      rewrite HpreEq at 1.
      exact (topology_has_X X Tx HTx).
    - exact HsS.

  + (** h(x0)=0 **)
    claim Hhx0: apply_fun h x0 = h0 x0.
    { exact (apply_fun_graph X (fun u:set => h0 u) x0 Hx0X). }
    rewrite Hhx0.
    claim Hmax0: maxfg x0 = 0.
    { claim HdefM: maxfg x0 =
        (if (Rlt (apply_fun f x0) (apply_fun g x0)) then (apply_fun g x0) else (apply_fun f x0)).
      { reflexivity. }
      rewrite HdefM.
      rewrite Hfx0.
      rewrite Hgx0.
      claim Hnlt00: ~(Rlt 0 0).
      { exact (not_Rlt_refl 0 real_0). }
      rewrite (If_i_0 (Rlt 0 0) 0 0 Hnlt00).
      reflexivity. }
    claim Hdef0: h0 x0 = (if (Rlt 1 (maxfg x0)) then 1 else (maxfg x0)).
    { reflexivity. }
    rewrite Hdef0.
    rewrite Hmax0.
    claim Hnlt10: ~(Rlt 1 0).
    { exact (not_Rlt_sym 0 1 Rlt_0_1). }
    rewrite (If_i_0 (Rlt 1 0) 1 0 Hnlt10).
    reflexivity.
- (** separator property: if f=1 or g=1 then h=1 **)
  let y. assume HyX: y :e X.
  assume Hor: apply_fun f y = 1 \/ apply_fun g y = 1.
  prove (apply_fun h y = 1).
  claim Hhy: apply_fun h y = h0 y.
  { exact (apply_fun_graph X (fun u:set => h0 u) y HyX). }
  rewrite Hhy.
  claim Hdef0y: h0 y = (if (Rlt 1 (maxfg y)) then 1 else (maxfg y)).
  { reflexivity. }
  rewrite Hdef0y.
  apply (xm (Rlt 1 (maxfg y))).
  + assume H1ltMax: Rlt 1 (maxfg y).
    claim Heq: (if (Rlt 1 (maxfg y)) then 1 else (maxfg y)) = 1.
    { exact (If_i_1 (Rlt 1 (maxfg y)) 1 (maxfg y) H1ltMax). }
    rewrite Heq at 1.
    reflexivity.
  + assume Hn1ltMax: ~(Rlt 1 (maxfg y)).
    claim Heq: (if (Rlt 1 (maxfg y)) then 1 else (maxfg y)) = (maxfg y).
    { exact (If_i_0 (Rlt 1 (maxfg y)) 1 (maxfg y) Hn1ltMax). }
    rewrite Heq at 1.
    apply Hor.
    - assume Hfy1: apply_fun f y = 1.
      claim HdefM: maxfg y =
          (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)).
      { reflexivity. }
      rewrite HdefM.
      apply (xm (Rlt (apply_fun f y) (apply_fun g y))).
      + assume Hfg: Rlt (apply_fun f y) (apply_fun g y).
        claim HeqIf: (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)) = (apply_fun g y).
        { exact (If_i_1 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hfg). }
        rewrite HeqIf at 1.
        claim H1ltg: Rlt 1 (apply_fun g y).
        { rewrite <- Hfy1 at 1.
          exact Hfg. }
        claim HmaxEq: maxfg y = apply_fun g y.
        { rewrite HdefM at 1.
          exact (If_i_1 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hfg). }
        claim H1ltMax': Rlt 1 (maxfg y).
        { rewrite HmaxEq.
          exact H1ltg. }
        exact (FalseE (Hn1ltMax H1ltMax') (apply_fun g y = 1)).
      + assume Hnfg: ~(Rlt (apply_fun f y) (apply_fun g y)).
        claim HeqIf: (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)) = (apply_fun f y).
        { exact (If_i_0 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hnfg). }
        rewrite HeqIf at 1.
        rewrite Hfy1.
        reflexivity.
    - assume Hgy1: apply_fun g y = 1.
      claim HdefM: maxfg y =
          (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)).
      { reflexivity. }
      rewrite HdefM.
      apply (xm (Rlt (apply_fun f y) (apply_fun g y))).
      + assume Hfg: Rlt (apply_fun f y) (apply_fun g y).
        claim HeqIf: (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)) = (apply_fun g y).
        { exact (If_i_1 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hfg). }
        rewrite HeqIf at 1.
        rewrite Hgy1.
        reflexivity.
      + assume Hnfg: ~(Rlt (apply_fun f y) (apply_fun g y)).
        claim HeqIf: (if (Rlt (apply_fun f y) (apply_fun g y)) then (apply_fun g y) else (apply_fun f y)) = (apply_fun f y).
        { exact (If_i_0 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hnfg). }
        rewrite HeqIf at 1.
        claim HfyR: apply_fun f y :e R.
        { exact (HfFun y HyX). }
        claim HgyR: apply_fun g y :e R.
        { exact (HgFun y HyX). }
        claim Hlegf: Rle (apply_fun g y) (apply_fun f y).
        { exact (RleI (apply_fun g y) (apply_fun f y) HgyR HfyR Hnfg). }
        claim Hle1f: Rle 1 (apply_fun f y).
        { rewrite <- Hgy1 at 1.
          exact Hlegf. }
        claim HmaxEq: maxfg y = apply_fun f y.
        { rewrite HdefM at 1.
          exact (If_i_0 (Rlt (apply_fun f y) (apply_fun g y)) (apply_fun g y) (apply_fun f y) Hnfg). }
        claim Hn1ltf: ~(Rlt 1 (apply_fun f y)).
        { assume H1ltf: Rlt 1 (apply_fun f y).
          claim H1ltMax': Rlt 1 (maxfg y).
          { rewrite HmaxEq.
            exact H1ltf. }
          exact (Hn1ltMax H1ltMax'). }
        claim Hlef1: Rle (apply_fun f y) 1.
        { exact (RleI (apply_fun f y) 1 HfyR real_1 Hn1ltf). }
        claim Heqfy1: apply_fun f y = 1.
        { exact (Rle_antisym (apply_fun f y) 1 Hlef1 Hle1f). }
        rewrite Heqfy1.
        reflexivity.
Qed.

(** Helper: finite cylinder family yields a separating continuous function on the product **)
(** LATEX VERSION: A finite family of coordinate-separating continuous functions can be combined into one separating continuous function on the product. **)
Theorem product_finite_subbasis_intersection_separator : forall I Xi F x:set,
  I <> Empty ->
  completely_regular_spaces_family I Xi ->
  F :e finite_subcollections (product_subbasis_full I Xi) ->
  x :e intersection_of_family (product_space I Xi) F ->
  exists f:set,
    continuous_map (product_space I Xi) (product_topology_full I Xi) R R_standard_topology f /\
    apply_fun f x = 0 /\
    forall y:set, y :e product_space I Xi ->
      (exists s:set, s :e F /\ y /:e s) -> apply_fun f y = 1.
let I Xi F x.
assume HIne: I <> Empty.
assume Hfam: completely_regular_spaces_family I Xi.
assume HFsubcol: F :e finite_subcollections (product_subbasis_full I Xi).
assume HxInt: x :e intersection_of_family (product_space I Xi) F.
set Xp := product_space I Xi.
set Tp := product_topology_full I Xi.
set S := product_subbasis_full I Xi.
claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume HiI: i :e I.
  claim Hcri: completely_regular_space (product_component Xi i) (product_component_topology Xi i).
  { exact (Hfam i HiI). }
  claim HsetEq: space_family_set Xi i = product_component Xi i.
  { reflexivity. }
  claim HtopEq: space_family_topology Xi i = product_component_topology Xi i.
  { reflexivity. }
  rewrite HsetEq.
  rewrite HtopEq.
  exact (completely_regular_space_topology_on (product_component Xi i) (product_component_topology Xi i) Hcri). }
claim HSsub: subbasis_on Xp S.
{ exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }
claim HTp: topology_on Xp Tp.
{ exact (topology_from_subbasis_is_topology Xp S HSsub). }
claim HxXp: x :e Xp.
{ exact (intersection_of_familyE1 Xp F x HxInt). }
claim HFpow: F :e Power S.
{ exact (SepE1 (Power S) (fun F0:set => finite F0) F HFsubcol). }
claim HFsub: F c= S.
{ exact (PowerE S F HFpow). }
claim HFfin: finite F.
{ exact (SepE2 (Power S) (fun F0:set => finite F0) F HFsubcol). }

(** Induct on the finite set F, adding one subbasis element at a time. **)
set p := (fun F0:set =>
  F0 c= S ->
  x :e intersection_of_family Xp F0 ->
  exists f:set,
    continuous_map Xp Tp R R_standard_topology f /\
    apply_fun f x = 0 /\
    forall y:set, y :e Xp ->
      (exists s:set, s :e F0 /\ y /:e s) -> apply_fun f y = 1).

claim HpEmpty: p Empty.
{ assume HsubE: Empty c= S.
  assume HxIntE: x :e intersection_of_family Xp Empty.
  prove exists f:set,
    continuous_map Xp Tp R R_standard_topology f /\
    apply_fun f x = 0 /\
    forall y:set, y :e Xp ->
      (exists s:set, s :e Empty /\ y /:e s) -> apply_fun f y = 1.
  witness (const_fun Xp 0).
  apply andI.
  - apply andI.
    + exact (const_fun_continuous Xp Tp R R_standard_topology 0 HTp R_standard_topology_is_topology_local real_0).
    + exact (const_fun_apply Xp 0 x HxXp).
  - let y. assume HyXp: y :e Xp.
    assume Hexs: exists s:set, s :e Empty /\ y /:e s.
    prove apply_fun (const_fun Xp 0) y = 1.
    apply Hexs.
    let s. assume Hsand.
    claim HsE: s :e Empty.
    { exact (andEL (s :e Empty) (y /:e s) Hsand). }
    exact (EmptyE s HsE (apply_fun (const_fun Xp 0) y = 1)). }

claim HpStep: forall X0 y0:set,
  finite X0 -> y0 /:e X0 -> p X0 -> p (X0 :\/: {y0}).
{ let X0 y0.
  assume HX0fin: finite X0.
  assume Hy0notX0: y0 /:e X0.
  assume HpX0: p X0.
  prove p (X0 :\/: {y0}).
  assume HsubX1: X0 :\/: {y0} c= S.
  assume HxIntX1: x :e intersection_of_family Xp (X0 :\/: {y0}).
  (** Derive X0 c= S and y0 :e S **)
  claim HsubX0: X0 c= S.
  { let s. assume HsX0: s :e X0.
    exact (HsubX1 s (binunionI1 X0 {y0} s HsX0)). }
  claim Hy0S: y0 :e S.
  { exact (HsubX1 y0 (binunionI2 X0 {y0} y0 (SingI y0))). }
  (** x is in the smaller intersection and in y0 **)
  claim HxXp1: x :e Xp.
  { exact (intersection_of_familyE1 Xp (X0 :\/: {y0}) x HxIntX1). }
  claim HxIntX0: x :e intersection_of_family Xp X0.
  { apply (intersection_of_familyI Xp X0 x HxXp1).
    let s. assume HsX0: s :e X0.
    claim HsX1: s :e X0 :\/: {y0}.
    { exact (binunionI1 X0 {y0} s HsX0). }
    exact (intersection_of_familyE2 Xp (X0 :\/: {y0}) x HxIntX1 s HsX1). }
  claim Hxy0: x :e y0.
  { claim Hy0X1: y0 :e X0 :\/: {y0}.
    { exact (binunionI2 X0 {y0} y0 (SingI y0)). }
    exact (intersection_of_familyE2 Xp (X0 :\/: {y0}) x HxIntX1 y0 Hy0X1). }
  (** Apply IH to obtain f0 for X0. **)
  claim Hexf0: exists f0:set,
    continuous_map Xp Tp R R_standard_topology f0 /\
    apply_fun f0 x = 0 /\
    forall y:set, y :e Xp ->
      (exists s:set, s :e X0 /\ y /:e s) -> apply_fun f0 y = 1.
  { exact (HpX0 HsubX0 HxIntX0). }
  apply Hexf0.
  let f0. assume Hf0pack.
  (** Build g0 separating x from the complement of the cylinder y0. **)
  claim Hexg0: exists g0:set,
    continuous_map Xp Tp R R_standard_topology g0 /\
    apply_fun g0 x = 0 /\
    forall y:set, y :e Xp -> y /:e y0 -> apply_fun g0 y = 1.
  { (** unpack y0 as a cylinder product_cylinder I Xi i U **)
    claim Hexi: exists i:set, i :e I /\ exists U:set, U :e space_family_topology Xi i /\ y0 = product_cylinder I Xi i U.
    { exact (product_subbasis_fullE I Xi y0 Hy0S). }
    apply Hexi.
    let i. assume Hipack.
    claim HiI: i :e I.
    { exact (andEL (i :e I) (exists U:set, U :e space_family_topology Xi i /\ y0 = product_cylinder I Xi i U) Hipack). }
    claim HexU: exists U:set, U :e space_family_topology Xi i /\ y0 = product_cylinder I Xi i U.
    { exact (andER (i :e I) (exists U:set, U :e space_family_topology Xi i /\ y0 = product_cylinder I Xi i U) Hipack). }
    apply HexU.
    let U. assume HUand.
    claim HUopen: U :e space_family_topology Xi i.
    { exact (andEL (U :e space_family_topology Xi i) (y0 = product_cylinder I Xi i U) HUand). }
	    claim Hy0eq: y0 = product_cylinder I Xi i U.
	    { exact (andER (U :e space_family_topology Xi i) (y0 = product_cylinder I Xi i U) HUand). }
	    claim HxCyl: x :e product_cylinder I Xi i U.
	    { rewrite <- Hy0eq at 1.
	      exact Hxy0. }
    claim HxCylProp: i :e I /\ U :e space_family_topology Xi i /\ apply_fun x i :e U.
    { exact (SepE2 Xp (fun f0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U) x HxCyl). }
    claim HxiU: apply_fun x i :e U.
    { exact (andER (i :e I /\ U :e space_family_topology Xi i) (apply_fun x i :e U) HxCylProp). }
    (** component separator fi on the i-th factor, then lift by evaluation **)
    set Xi_i := space_family_set Xi i.
    set Ti_i := space_family_topology Xi i.
    claim HTi: topology_on Xi_i Ti_i.
    { exact (HcompTop i HiI). }
    claim HUsubXi: U c= Xi_i.
    { exact (topology_elem_subset Xi_i Ti_i U HTi HUopen). }
    claim HxiXi: apply_fun x i :e Xi_i.
    { exact (HUsubXi (apply_fun x i) HxiU). }
    set C := Xi_i :\: U.
    claim HCcl: closed_in Xi_i Ti_i C.
    { exact (closed_of_open_complement Xi_i Ti_i U HTi HUopen). }
    claim HxiNotC: apply_fun x i /:e C.
    { assume HxiC: apply_fun x i :e C.
      claim HxiNotU: apply_fun x i /:e U.
      { exact (setminusE2 Xi_i U (apply_fun x i) HxiC). }
      exact (HxiNotU HxiU). }
    claim Hcri: completely_regular_space Xi_i Ti_i.
    { exact (Hfam i HiI). }
    claim Hsep_i:
      forall xi:set, xi :e Xi_i ->
        forall Fcl:set, closed_in Xi_i Ti_i Fcl -> xi /:e Fcl ->
          exists fi:set,
            continuous_map Xi_i Ti_i R R_standard_topology fi /\
            apply_fun fi xi = 0 /\ forall z:set, z :e Fcl -> apply_fun fi z = 1.
    { let xi. assume Hxi: xi :e Xi_i.
      let Fcl. assume HFcl: closed_in Xi_i Ti_i Fcl.
      assume HxiNotFcl: xi /:e Fcl.
      exact (completely_regular_space_separation Xi_i Ti_i xi Fcl Hcri Hxi HFcl HxiNotFcl). }
    claim Hexfi: exists fi:set,
      continuous_map Xi_i Ti_i R R_standard_topology fi /\
      apply_fun fi (apply_fun x i) = 0 /\ forall z:set, z :e C -> apply_fun fi z = 1.
    { exact (Hsep_i (apply_fun x i) HxiXi C HCcl HxiNotC). }
    apply Hexfi.
    let fi. assume Hfipack.
    set ev := product_eval_map I Xi i.
    set g0 := compose_fun Xp ev fi.
    witness g0.
    (** prove g0 is continuous and separates y0 **)
    apply andI.
    - apply andI.
      + (** continuity **)
	        claim Hevcont: continuous_map Xp Tp Xi_i Ti_i ev.
	        { exact (product_eval_map_continuous I Xi i HcompTop HiI). }
        claim HfiLeft: continuous_map Xi_i Ti_i R R_standard_topology fi /\ apply_fun fi (apply_fun x i) = 0.
        { exact (andEL (continuous_map Xi_i Ti_i R R_standard_topology fi /\ apply_fun fi (apply_fun x i) = 0)
                       (forall z:set, z :e C -> apply_fun fi z = 1)
                       Hfipack). }
        claim HfiCont: continuous_map Xi_i Ti_i R R_standard_topology fi.
        { exact (andEL (continuous_map Xi_i Ti_i R R_standard_topology fi)
                       (apply_fun fi (apply_fun x i) = 0)
                       HfiLeft). }
        exact (composition_continuous Xp Tp Xi_i Ti_i R R_standard_topology ev fi Hevcont HfiCont).
      + (** g0(x)=0 **)
        claim Hg0x: apply_fun g0 x = apply_fun fi (apply_fun ev x).
        { exact (compose_fun_apply Xp ev fi x HxXp). }
        claim Hevx: apply_fun ev x = apply_fun x i.
        { exact (apply_fun_graph Xp (fun u0:set => apply_fun u0 i) x HxXp). }
        claim HfiLeft: continuous_map Xi_i Ti_i R R_standard_topology fi /\ apply_fun fi (apply_fun x i) = 0.
        { exact (andEL (continuous_map Xi_i Ti_i R R_standard_topology fi /\ apply_fun fi (apply_fun x i) = 0)
                       (forall z:set, z :e C -> apply_fun fi z = 1)
                       Hfipack). }
        claim Hfi0: apply_fun fi (apply_fun x i) = 0.
        { exact (andER (continuous_map Xi_i Ti_i R R_standard_topology fi)
                       (apply_fun fi (apply_fun x i) = 0)
                       HfiLeft). }
        rewrite Hg0x.
        rewrite Hevx.
        exact Hfi0.
    - let y. assume HyXp: y :e Xp.
      assume Hynoty0: y /:e y0.
	      prove apply_fun g0 y = 1.
	      claim HynotCyl: y /:e product_cylinder I Xi i U.
	      { rewrite <- Hy0eq at 1.
	        exact Hynoty0. }
      claim HyNotU: apply_fun y i /:e U.
	      { assume HyiU: apply_fun y i :e U.
	        claim HyCyl: y :e product_cylinder I Xi i U.
	        { claim HXpeq: Xp = product_space I Xi.
	          { reflexivity. }
	          claim HyPS: y :e product_space I Xi.
	          { rewrite <- HXpeq at 1.
	            exact HyXp. }
	          claim Hcyldef: product_cylinder I Xi i U =
	            {f :e product_space I Xi | i :e I /\ U :e space_family_topology Xi i /\ apply_fun f i :e U}.
	          { reflexivity. }
	          rewrite Hcyldef at 1.
	          apply (SepI (product_space I Xi)
	                      (fun f0:set => i :e I /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
	                      y HyPS).
	          exact (andI (i :e I /\ U :e space_family_topology Xi i) (apply_fun y i :e U)
	                      (andI (i :e I) (U :e space_family_topology Xi i) HiI HUopen) HyiU). }
	        exact (HynotCyl HyCyl). }
      (** apply fi on the complement set C = Xi_i :\\ U **)
      claim HyProp:
        total_function_on y I (space_family_union I Xi) /\ functional_graph y /\
        forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j.
      { exact (SepE2 (Power (setprod I (space_family_union I Xi)))
                     (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
                       forall j:set, j :e I -> apply_fun f0 j :e space_family_set Xi j)
                     y HyXp). }
      claim HyCoords: forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j.
      { exact (andER (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
                     (forall j:set, j :e I -> apply_fun y j :e space_family_set Xi j)
                     HyProp). }
      claim HyiXi: apply_fun y i :e Xi_i.
      { exact (HyCoords i HiI). }
      claim HyC: apply_fun y i :e C.
      { exact (setminusI Xi_i U (apply_fun y i) HyiXi HyNotU). }
      claim HfiRight: forall z:set, z :e C -> apply_fun fi z = 1.
      { exact (andER (continuous_map Xi_i Ti_i R R_standard_topology fi /\ apply_fun fi (apply_fun x i) = 0)
                     (forall z:set, z :e C -> apply_fun fi z = 1)
                     Hfipack). }
      claim Hfiy: apply_fun fi (apply_fun y i) = 1.
      { exact (HfiRight (apply_fun y i) HyC). }
      claim Hg0y: apply_fun g0 y = apply_fun fi (apply_fun ev y).
      { exact (compose_fun_apply Xp ev fi y HyXp). }
      claim Hevy: apply_fun ev y = apply_fun y i.
      { exact (apply_fun_graph Xp (fun u0:set => apply_fun u0 i) y HyXp). }
	      rewrite Hg0y.
	      rewrite Hevy.
	      exact Hfiy. }
	  apply Hexg0.
	  let g0. assume Hg0pack.
	  (** Combine f0 and g0 so that 1 propagates from either side. **)
  claim Hf0cont: continuous_map Xp Tp R R_standard_topology f0.
  { exact (andEL (continuous_map Xp Tp R R_standard_topology f0)
                 (apply_fun f0 x = 0)
                 (andEL (continuous_map Xp Tp R R_standard_topology f0 /\ apply_fun f0 x = 0)
                        (forall y:set, y :e Xp -> (exists s:set, s :e X0 /\ y /:e s) -> apply_fun f0 y = 1)
                        Hf0pack)). }
  claim Hf0x0: apply_fun f0 x = 0.
  { exact (andER (continuous_map Xp Tp R R_standard_topology f0)
                 (apply_fun f0 x = 0)
                 (andEL (continuous_map Xp Tp R R_standard_topology f0 /\ apply_fun f0 x = 0)
                        (forall y:set, y :e Xp -> (exists s:set, s :e X0 /\ y /:e s) -> apply_fun f0 y = 1)
                        Hf0pack)). }
  claim Hf0sep: forall y:set, y :e Xp -> (exists s:set, s :e X0 /\ y /:e s) -> apply_fun f0 y = 1.
  { exact (andER (continuous_map Xp Tp R R_standard_topology f0 /\ apply_fun f0 x = 0)
                 (forall y:set, y :e Xp -> (exists s:set, s :e X0 /\ y /:e s) -> apply_fun f0 y = 1)
                 Hf0pack). }
  claim Hg0cont: continuous_map Xp Tp R R_standard_topology g0.
  { exact (andEL (continuous_map Xp Tp R R_standard_topology g0)
                 (apply_fun g0 x = 0)
                 (andEL (continuous_map Xp Tp R R_standard_topology g0 /\ apply_fun g0 x = 0)
                        (forall y:set, y :e Xp -> y /:e y0 -> apply_fun g0 y = 1)
                        Hg0pack)). }
  claim Hg0x0: apply_fun g0 x = 0.
  { exact (andER (continuous_map Xp Tp R R_standard_topology g0)
                 (apply_fun g0 x = 0)
                 (andEL (continuous_map Xp Tp R R_standard_topology g0 /\ apply_fun g0 x = 0)
                        (forall y:set, y :e Xp -> y /:e y0 -> apply_fun g0 y = 1)
                        Hg0pack)). }
  claim Hg0sep: forall y:set, y :e Xp -> y /:e y0 -> apply_fun g0 y = 1.
  { exact (andER (continuous_map Xp Tp R R_standard_topology g0 /\ apply_fun g0 x = 0)
                 (forall y:set, y :e Xp -> y /:e y0 -> apply_fun g0 y = 1)
                 Hg0pack). }
  claim Hexh: exists h:set,
    continuous_map Xp Tp R R_standard_topology h /\
    apply_fun h x = 0 /\
    forall y:set, y :e Xp -> (apply_fun f0 y = 1 \/ apply_fun g0 y = 1) -> apply_fun h y = 1.
  { exact (continuous_combine_or_01 Xp Tp f0 g0 x HTp Hf0cont Hg0cont HxXp Hf0x0 Hg0x0). }
  apply Hexh.
  let h. assume Hhpack.
  witness h.
  (** Show h satisfies the separator property for X0 :\/: {y0}. **)
  apply andI.
  - exact (andEL (continuous_map Xp Tp R R_standard_topology h /\ apply_fun h x = 0)
                 (forall y:set, y :e Xp -> (apply_fun f0 y = 1 \/ apply_fun g0 y = 1) -> apply_fun h y = 1)
                 Hhpack).
  - let y. assume HyXp: y :e Xp.
    assume Hexs: exists s:set, s :e X0 :\/: {y0} /\ y /:e s.
    prove apply_fun h y = 1.
    claim HhOr:
      forall y0:set, y0 :e Xp -> (apply_fun f0 y0 = 1 \/ apply_fun g0 y0 = 1) -> apply_fun h y0 = 1.
    { exact (andER (continuous_map Xp Tp R R_standard_topology h /\ apply_fun h x = 0)
                   (forall y0:set, y0 :e Xp -> (apply_fun f0 y0 = 1 \/ apply_fun g0 y0 = 1) -> apply_fun h y0 = 1)
                   Hhpack). }
    apply Hexs.
    let s. assume Hsand.
    claim HsX1: s :e X0 :\/: {y0}.
    { exact (andEL (s :e X0 :\/: {y0}) (y /:e s) Hsand). }
    claim HynotS: y /:e s.
    { exact (andER (s :e X0 :\/: {y0}) (y /:e s) Hsand). }
    claim Hcases: s :e X0 \/ s :e {y0}.
    { exact (binunionE X0 {y0} s HsX1). }
    claim Hcases3: s :e X0 \/ s :e {y0} \/ False.
    { exact (orIL (s :e X0 \/ s :e {y0}) False Hcases). }
    apply (or3E (s :e X0) (s :e {y0}) False Hcases3 (apply_fun h y = 1)).
    + assume HsX0: s :e X0.
      claim Hdisj: exists s0:set, s0 :e X0 /\ y /:e s0.
      { witness s.
        exact (andI (s :e X0) (y /:e s) HsX0 HynotS). }
      claim Hf0y: apply_fun f0 y = 1.
      { exact (Hf0sep y HyXp Hdisj). }
      claim Hor: apply_fun f0 y = 1 \/ apply_fun g0 y = 1.
      { exact (orIL (apply_fun f0 y = 1) (apply_fun g0 y = 1) Hf0y). }
      exact (HhOr y HyXp Hor).
    + assume HsSing: s :e {y0}.
      claim Hseq: s = y0.
      { exact (SingE y0 s HsSing). }
      claim Hynoty0: y /:e y0.
      { rewrite <- Hseq.
        exact HynotS. }
      claim Hg0y: apply_fun g0 y = 1.
      { exact (Hg0sep y HyXp Hynoty0). }
      claim Hor: apply_fun f0 y = 1 \/ apply_fun g0 y = 1.
      { exact (orIR (apply_fun f0 y = 1) (apply_fun g0 y = 1) Hg0y). }
      exact (HhOr y HyXp Hor).
    + assume Hbad: False.
      exact (FalseE Hbad (apply_fun h y = 1)). }

claim HpF: p F.
{ exact (finite_ind p HpEmpty HpStep F HFfin). }
exact (HpF HFsub HxInt).
Qed.

(** from §33 Theorem 33.2: subspaces/products of completely regular spaces **) 
(** LATEX VERSION: Subspaces and products of completely regular spaces remain completely regular. **)
Theorem completely_regular_subspace_product : forall X Tx:set,
  topology_on X Tx ->
  (forall Y:set, Y c= X -> completely_regular_space X Tx -> completely_regular_space Y (subspace_topology X Tx Y)) /\
  (forall I Xi:set, completely_regular_spaces_family I Xi -> completely_regular_space (product_space I Xi) (product_topology_full I Xi)).
let X Tx.
assume HTx: topology_on X Tx.
prove (forall Y:set, Y c= X -> completely_regular_space X Tx -> completely_regular_space Y (subspace_topology X Tx Y)) /\
  (forall I Xi:set, completely_regular_spaces_family I Xi -> completely_regular_space (product_space I Xi) (product_topology_full I Xi)).
apply andI.
- (** subspaces **)
  let Y. assume HYsub: Y c= X.
  assume HcrX: completely_regular_space X Tx.
  prove completely_regular_space Y (subspace_topology X Tx Y).
  claim HTsub: topology_on Y (subspace_topology X Tx Y).
  { exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
  claim HT1X: one_point_sets_closed X Tx.
  { exact (completely_regular_space_one_point_sets_closed X Tx HcrX). }
  claim HsingX: forall x0:set, x0 :e X -> closed_in X Tx {x0}.
  { exact (andER (topology_on X Tx) (forall x0:set, x0 :e X -> closed_in X Tx {x0}) HT1X). }
  prove topology_on Y (subspace_topology X Tx Y) /\
    (one_point_sets_closed Y (subspace_topology X Tx Y) /\
     forall y:set, y :e Y ->
       forall F:set, closed_in Y (subspace_topology X Tx Y) F -> y /:e F ->
         exists f:set,
           continuous_map Y (subspace_topology X Tx Y) R R_standard_topology f /\
           apply_fun f y = 0 /\ forall z:set, z :e F -> apply_fun f z = 1).
  apply andI.
  * exact HTsub.
  * apply andI.
    + (** one_point_sets_closed for the subspace **)
      prove topology_on Y (subspace_topology X Tx Y) /\
        forall y0:set, y0 :e Y -> closed_in Y (subspace_topology X Tx Y) {y0}.
      apply andI.
      - exact HTsub.
      - let y0. assume Hy0Y: y0 :e Y.
        prove closed_in Y (subspace_topology X Tx Y) {y0}.
        claim Hy0X: y0 :e X.
        { exact (HYsub y0 Hy0Y). }
        apply (iffER (closed_in Y (subspace_topology X Tx Y) {y0})
                     (exists C:set, closed_in X Tx C /\ {y0} = C :/\: Y)
                     (closed_in_subspace_iff_intersection X Tx Y {y0} HTx HYsub)).
        witness {y0}.
        apply andI.
        - exact (HsingX y0 Hy0X).
        - apply set_ext.
          + let z. assume Hz: z :e {y0}.
            prove z :e {y0} :/\: Y.
            claim HzEq: z = y0.
            { exact (SingE y0 z Hz). }
            rewrite HzEq.
            exact (binintersectI {y0} Y y0 (SingI y0) Hy0Y).
          + let z. assume Hz: z :e {y0} :/\: Y.
            prove z :e {y0}.
            exact (binintersectE1 {y0} Y z Hz).
    + (** separation property **)
      let y. assume HyY: y :e Y.
    let F. assume HFcl: closed_in Y (subspace_topology X Tx Y) F.
    assume HynotF: y /:e F.
    prove exists f:set,
      continuous_map Y (subspace_topology X Tx Y) R R_standard_topology f /\
      apply_fun f y = 0 /\ forall z:set, z :e F -> apply_fun f z = 1.
    claim HexC: exists C:set, closed_in X Tx C /\ F = C :/\: Y.
    { exact (iffEL (closed_in Y (subspace_topology X Tx Y) F)
                   (exists C:set, closed_in X Tx C /\ F = C :/\: Y)
                   (closed_in_subspace_iff_intersection X Tx Y F HTx HYsub)
                   HFcl). }
    apply HexC.
    let C. assume HCpair.
    claim HCcl: closed_in X Tx C.
    { exact (andEL (closed_in X Tx C) (F = C :/\: Y) HCpair). }
    claim HFeq: F = C :/\: Y.
    { exact (andER (closed_in X Tx C) (F = C :/\: Y) HCpair). }
    claim HyX: y :e X.
    { exact (HYsub y HyY). }
    claim HyNotC: y /:e C.
    { assume HyC: y :e C.
      claim HyCY: y :e C :/\: Y.
      { exact (binintersectI C Y y HyC HyY). }
      claim HyF: y :e F.
      { rewrite HFeq.
        exact HyCY. }
      exact (HynotF HyF). }
    claim Hexf: exists f:set,
      continuous_map X Tx R R_standard_topology f /\
      apply_fun f y = 0 /\ forall z:set, z :e C -> apply_fun f z = 1.
    { exact (completely_regular_space_separation X Tx y C HcrX HyX HCcl HyNotC). }
    apply Hexf.
    let f. assume Hfprop.
    witness f.
    claim Hfleft: continuous_map X Tx R R_standard_topology f /\ apply_fun f y = 0.
    { exact (andEL (continuous_map X Tx R R_standard_topology f /\ apply_fun f y = 0)
                   (forall z:set, z :e C -> apply_fun f z = 1)
                   Hfprop). }
    claim Hfcont: continuous_map X Tx R R_standard_topology f.
    { exact (andEL (continuous_map X Tx R R_standard_topology f) (apply_fun f y = 0) Hfleft). }
    claim Hfy0: apply_fun f y = 0.
    { exact (andER (continuous_map X Tx R R_standard_topology f) (apply_fun f y = 0) Hfleft). }
    claim HfC: forall z:set, z :e C -> apply_fun f z = 1.
    { exact (andER (continuous_map X Tx R R_standard_topology f /\ apply_fun f y = 0)
                   (forall z:set, z :e C -> apply_fun f z = 1)
                   Hfprop). }
    apply andI.
    + prove continuous_map Y (subspace_topology X Tx Y) R R_standard_topology f /\ apply_fun f y = 0.
      apply andI.
      - exact (continuous_on_subspace X Tx R R_standard_topology f Y HTx HYsub Hfcont).
      - exact Hfy0.
    + let z. assume HzF: z :e F.
      prove apply_fun f z = 1.
      claim HzCY: z :e C :/\: Y.
      { rewrite <- HFeq.
        exact HzF. }
      claim HzC: z :e C.
      { exact (binintersectE1 C Y z HzCY). }
      exact (HfC z HzC).
- (** products **)
  let I Xi. assume Hfam: completely_regular_spaces_family I Xi.
  prove completely_regular_space (product_space I Xi) (product_topology_full I Xi).
  apply (xm (I = Empty)).
  - assume HIeq: I = Empty.
    rewrite HIeq.
    claim HTdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
    { reflexivity. }
    rewrite HTdef.
    claim HXpeq: product_space Empty Xi = {Empty}.
    { exact (product_space_empty_index Xi). }
    claim HTp: topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi).
    { exact (countable_product_topology_subbasis_empty_is_topology Xi). }
    (** For the empty index set, the product is the singleton space {Empty}; completely regularity is trivial. **)
    prove topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) /\
      (one_point_sets_closed (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) /\
       forall x:set, x :e product_space Empty Xi ->
         forall F:set, closed_in (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) F -> x /:e F ->
           exists f:set,
             continuous_map (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) R R_standard_topology f /\
             apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
    apply andI.
    * exact HTp.
    * apply andI.
      + (** one_point_sets_closed **)
        prove topology_on (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) /\
          forall x0:set, x0 :e product_space Empty Xi ->
            closed_in (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) {x0}.
        apply andI.
        - exact HTp.
        - let x0. assume Hx0Xp: x0 :e product_space Empty Xi.
          claim Hx0Sing: x0 :e {Empty}.
          { rewrite <- HXpeq.
            exact Hx0Xp. }
          claim Hx0Eq: x0 = Empty.
          { exact (SingE Empty x0 Hx0Sing). }
          rewrite Hx0Eq.
          prove closed_in (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) {Empty}.
          apply (closed_inI (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) {Empty}
                            HTp).
          - claim Hem: Empty :e product_space Empty Xi.
            { rewrite HXpeq.
              exact (SingI Empty). }
            exact (singleton_subset Empty (product_space Empty Xi) Hem).
          - prove exists U :e countable_product_topology_subbasis Empty Xi,
              {Empty} = product_space Empty Xi :\: U.
            witness Empty.
            apply andI.
            * exact (topology_has_empty (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) HTp).
            * rewrite HXpeq.
              rewrite (setminus_Empty_eq {Empty}).
              reflexivity.
      + let x. assume HxXp: x :e product_space Empty Xi.
      let F. assume HFcl: closed_in (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) F.
      assume HxnotF: x /:e F.
      prove exists f:set,
        continuous_map (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) R R_standard_topology f /\
        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
      (** Use the constant 0 map. **)
      witness (const_fun (product_space Empty Xi) 0).
      apply andI.
      + apply andI.
        - exact (const_fun_continuous (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi)
                                      R R_standard_topology 0 HTp R_standard_topology_is_topology_local real_0).
        - (** f(x)=0 **)
          claim Hfx: apply_fun (const_fun (product_space Empty Xi) 0) x = 0.
          { exact (const_fun_apply (product_space Empty Xi) 0 x HxXp). }
          exact Hfx.
      + (** f=1 on F is vacuous if F is empty; otherwise x in F contradicts x /:e F in a singleton space **)
        let y. assume HyF: y :e F.
        prove apply_fun (const_fun (product_space Empty Xi) 0) y = 1.
          claim HFsub: F c= product_space Empty Xi.
          { exact (closed_in_subset (product_space Empty Xi) (countable_product_topology_subbasis Empty Xi) F HFcl). }
          claim HyXp: y :e product_space Empty Xi.
          { exact (HFsub y HyF). }
          claim HxEq: x = Empty.
          { claim HxSing: x :e {Empty}.
            { rewrite <- HXpeq.
              exact HxXp. }
            exact (SingE Empty x HxSing). }
          claim HyEq: y = Empty.
          { claim HySing: y :e {Empty}.
            { rewrite <- HXpeq.
              exact HyXp. }
            exact (SingE Empty y HySing). }
          claim Hyx: y = x.
          { rewrite HyEq.
            rewrite <- HxEq.
            reflexivity. }
          claim HxF: x :e F.
          { rewrite <- Hyx.
            exact HyF. }
          apply FalseE.
          exact (HxnotF HxF).
  - assume HIne: ~(I = Empty).
    set Xp := product_space I Xi.
    set Tp := product_topology_full I Xi.
    claim HIne': I <> Empty.
    { assume HI0: I = Empty.
      exact (HIne HI0). }
    claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
    { let i. assume HiI: i :e I.
      claim Hcri: completely_regular_space (product_component Xi i) (product_component_topology Xi i).
      { exact (Hfam i HiI). }
      claim HsetEq: space_family_set Xi i = product_component Xi i.
      { reflexivity. }
      claim HtopEq: space_family_topology Xi i = product_component_topology Xi i.
      { reflexivity. }
      rewrite HsetEq.
      rewrite HtopEq.
      exact (completely_regular_space_topology_on (product_component Xi i) (product_component_topology Xi i) Hcri). }
    claim HSsub: subbasis_on Xp (product_subbasis_full I Xi).
    { exact (product_subbasis_full_subbasis_on I Xi HIne' HcompTop). }
    claim HTp: topology_on Xp Tp.
    { exact (topology_from_subbasis_is_topology Xp (product_subbasis_full I Xi) HSsub). }
    prove topology_on Xp Tp /\
      (one_point_sets_closed Xp Tp /\
       forall x:set, x :e Xp ->
         forall F:set, closed_in Xp Tp F -> x /:e F ->
           exists f:set,
             continuous_map Xp Tp R R_standard_topology f /\
             apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
    apply andI.
    * exact HTp.
    * apply andI.
      + (** one_point_sets_closed for the product **)
        claim HregFam: regular_spaces_family I Xi.
        { let i. assume HiI: i :e I.
          exact (completely_regular_space_implies_regular (product_component Xi i) (product_component_topology Xi i) (Hfam i HiI)). }
        claim HregProd: regular_space (product_space I Xi) (product_topology_full I Xi).
        { exact (product_topology_full_regular_axiom I Xi HregFam). }
        exact (andEL (one_point_sets_closed (product_space I Xi) (product_topology_full I Xi))
                     (forall x0:set, x0 :e product_space I Xi ->
                       forall F0:set, closed_in (product_space I Xi) (product_topology_full I Xi) F0 -> x0 /:e F0 ->
                         exists U V:set,
                           U :e product_topology_full I Xi /\ V :e product_topology_full I Xi /\
                           x0 :e U /\ F0 c= V /\ U :/\: V = Empty)
                     HregProd).
      + let x. assume HxXp: x :e Xp.
      let F. assume HFcl: closed_in Xp Tp F.
      assume HxnotF: x /:e F.
      prove exists f:set,
        continuous_map Xp Tp R R_standard_topology f /\
        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
      set U := Xp :\: F.
      claim HUopen: open_in Xp Tp U.
      { exact (open_of_closed_complement Xp Tp F HFcl). }
      claim HUinTp: U :e Tp.
      { exact (andER (topology_on Xp Tp) (U :e Tp) HUopen). }
      claim HxU: x :e U.
      { apply setminusI.
        - exact HxXp.
        - exact HxnotF. }
      claim HexFin: exists F0:set, F0 :e finite_subcollections (product_subbasis_full I Xi) /\
        x :e intersection_of_family Xp F0 /\ intersection_of_family Xp F0 c= U.
      { exact (generated_topology_from_subbasis_finite_neighborhood Xp (product_subbasis_full I Xi) U x HSsub HUinTp HxU). }
      apply HexFin.
      let F0. assume HF0pack.
      claim HF0AB: F0 :e finite_subcollections (product_subbasis_full I Xi) /\ x :e intersection_of_family Xp F0.
      { exact (andEL (F0 :e finite_subcollections (product_subbasis_full I Xi) /\ x :e intersection_of_family Xp F0)
                     (intersection_of_family Xp F0 c= U)
                     HF0pack). }
      claim HF0fin: F0 :e finite_subcollections (product_subbasis_full I Xi).
      { exact (andEL (F0 :e finite_subcollections (product_subbasis_full I Xi))
                     (x :e intersection_of_family Xp F0)
                     HF0AB). }
      claim HxW: x :e intersection_of_family Xp F0.
      { exact (andER (F0 :e finite_subcollections (product_subbasis_full I Xi))
                     (x :e intersection_of_family Xp F0)
                     HF0AB). }
      claim HWsubU: intersection_of_family Xp F0 c= U.
      { exact (andER (F0 :e finite_subcollections (product_subbasis_full I Xi) /\ x :e intersection_of_family Xp F0)
                     (intersection_of_family Xp F0 c= U)
                     HF0pack). }
      claim Hexf: exists f:set,
        continuous_map Xp Tp R R_standard_topology f /\
        apply_fun f x = 0 /\
        forall y:set, y :e Xp -> (exists s:set, s :e F0 /\ y /:e s) -> apply_fun f y = 1.
      { exact (product_finite_subbasis_intersection_separator I Xi F0 x HIne' Hfam HF0fin HxW). }
      apply Hexf.
      let f. assume Hfpack.
      witness f.
      claim Hfleft: continuous_map Xp Tp R R_standard_topology f /\ apply_fun f x = 0.
      { exact (andEL (continuous_map Xp Tp R R_standard_topology f /\ apply_fun f x = 0)
                     (forall y:set, y :e Xp -> (exists s:set, s :e F0 /\ y /:e s) -> apply_fun f y = 1)
                     Hfpack). }
      claim Hfsep:
        forall y:set, y :e Xp -> (exists s:set, s :e F0 /\ y /:e s) -> apply_fun f y = 1.
      { exact (andER (continuous_map Xp Tp R R_standard_topology f /\ apply_fun f x = 0)
                     (forall y:set, y :e Xp -> (exists s:set, s :e F0 /\ y /:e s) -> apply_fun f y = 1)
                     Hfpack). }
      apply andI.
      + exact Hfleft.
      + let y. assume HyF: y :e F.
        prove apply_fun f y = 1.
        claim HyXp: y :e Xp.
        { exact (closed_in_subset Xp Tp F HFcl y HyF). }
        claim HyNotU: y /:e U.
        { assume HyU: y :e U.
          claim HyNotF': y /:e F.
          { exact (setminusE2 Xp F y HyU). }
          exact (HyNotF' HyF). }
        claim HyNotW: y /:e intersection_of_family Xp F0.
        { assume HyW: y :e intersection_of_family Xp F0.
          claim HyU: y :e U.
          { exact (HWsubU y HyW). }
          exact (HyNotU HyU). }
        claim Hexs: exists s:set, s :e F0 /\ y /:e s.
        { apply (xm (exists s:set, s :e F0 /\ y /:e s)).
          - assume Hex: exists s:set, s :e F0 /\ y /:e s.
            exact Hex.
          - assume Hno: ~(exists s:set, s :e F0 /\ y /:e s).
            claim Hall: forall s:set, s :e F0 -> y :e s.
            { let s. assume HsF0: s :e F0.
              apply (xm (y :e s)).
              + assume HyS: y :e s.
                exact HyS.
              + assume HyNotS: y /:e s.
                claim Hex0: exists s0:set, s0 :e F0 /\ y /:e s0.
                { witness s.
                  exact (andI (s :e F0) (y /:e s) HsF0 HyNotS). }
                apply FalseE.
                exact (Hno Hex0). }
            claim HyW: y :e intersection_of_family Xp F0.
            { exact (intersection_of_familyI Xp F0 y HyXp Hall). }
            apply FalseE.
            exact (HyNotW HyW). }
        exact (Hfsep y HyXp Hexs).
Qed.

(** Helper: continuous preimage of a closed set is closed **)
(** LATEX VERSION: If f is continuous and C is closed, then f^{-1}(C) is closed. **)
Theorem continuous_map_preimage_closed : forall X Tx Y Ty f C:set,
  continuous_map X Tx Y Ty f ->
  closed_in Y Ty C ->
  closed_in X Tx (preimage_of X f C).
let X Tx Y Ty f C.
assume Hcont: continuous_map X Tx Y Ty f.
assume HCcl: closed_in Y Ty C.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hcont). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim HfunXY: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
(** represent C as a complement of an open set **)
claim Hex: exists U:set, U :e Ty /\ C = Y :\: U.
{ exact (closed_in_exists_open_complement Y Ty C HCcl). }
apply Hex.
let U. assume HUpair.
claim HUopen: U :e Ty.
{ exact (andEL (U :e Ty) (C = Y :\: U) HUpair). }
claim HCe: C = Y :\: U.
{ exact (andER (U :e Ty) (C = Y :\: U) HUpair). }
claim HpreUopen: preimage_of X f U :e Tx.
{ exact (continuous_map_preimage X Tx Y Ty f Hcont U HUopen). }
claim HpreEq: preimage_of X f C = X :\: preimage_of X f U.
{ rewrite HCe.
  exact (preimage_of_complement X Y f U HfunXY). }
rewrite HpreEq.
exact (closed_of_open_complement X Tx (preimage_of X f U) HTx HpreUopen).
Qed.

(** Helper: completely regularity is preserved under homeomorphism **)
(** LATEX VERSION: If X and Y are homeomorphic and Y is completely regular, then X is completely regular. **)
Theorem homeomorphism_preserves_completely_regular : forall X Tx Y Ty f:set,
  homeomorphism X Tx Y Ty f ->
  completely_regular_space Y Ty ->
  completely_regular_space X Tx.
let X Tx Y Ty f.
assume Hhom: homeomorphism X Tx Y Ty f.
assume HcrY: completely_regular_space Y Ty.
claim HTx: topology_on X Tx.
{ exact (homeomorphism_topology_left X Tx Y Ty f Hhom). }
claim HTy: topology_on Y Ty.
{ exact (homeomorphism_topology_right X Tx Y Ty f Hhom). }
claim Hcontf: continuous_map X Tx Y Ty f.
{ exact (homeomorphism_continuous X Tx Y Ty f Hhom). }
claim Hfunf: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcontf). }
claim HsepY:
  forall y:set, y :e Y ->
    forall F:set, closed_in Y Ty F -> y /:e F ->
      exists h:set,
        continuous_map Y Ty R R_standard_topology h /\
        apply_fun h y = 0 /\ forall z:set, z :e F -> apply_fun h z = 1.
{ let y. assume HyY: y :e Y.
  let F. assume HFcl: closed_in Y Ty F.
  assume HynotF: y /:e F.
  exact (completely_regular_space_separation Y Ty y F HcrY HyY HFcl HynotF). }
claim HexInv:
  exists g:set, continuous_map Y Ty X Tx g /\
    (forall x:set, x :e X -> apply_fun g (apply_fun f x) = x) /\
    (forall y:set, y :e Y -> apply_fun f (apply_fun g y) = y).
{ exact (homeomorphism_inverse_package X Tx Y Ty f Hhom). }
prove completely_regular_space X Tx.
prove topology_on X Tx /\
  (one_point_sets_closed X Tx /\
   forall x:set, x :e X ->
     forall F:set, closed_in X Tx F -> x /:e F ->
       exists h:set,
         continuous_map X Tx R R_standard_topology h /\
         apply_fun h x = 0 /\ forall z:set, z :e F -> apply_fun h z = 1).
apply andI.
- exact HTx.
- apply andI.
  + prove one_point_sets_closed X Tx.
    prove topology_on X Tx /\ forall x0:set, x0 :e X -> closed_in X Tx {x0}.
    apply andI.
    * exact HTx.
    * let x0. assume Hx0X: x0 :e X.
      prove closed_in X Tx {x0}.
      set y0 := apply_fun f x0.
      claim Hy0Y: y0 :e Y.
      { exact (Hfunf x0 Hx0X). }
      claim HoneY: one_point_sets_closed Y Ty.
      { exact (completely_regular_space_one_point_sets_closed Y Ty HcrY). }
      claim HsingClosedY: forall y:set, y :e Y -> closed_in Y Ty {y}.
      { exact (andER (topology_on Y Ty)
                     (forall y:set, y :e Y -> closed_in Y Ty {y})
                     HoneY). }
      claim Hy0Closed: closed_in Y Ty {y0}.
      { exact (HsingClosedY y0 Hy0Y). }
      claim HpreClosed: closed_in X Tx (preimage_of X f {y0}).
      { exact (continuous_map_preimage_closed X Tx Y Ty f {y0} Hcontf Hy0Closed). }
      claim HpreEq: preimage_of X f {y0} = {x0}.
      { apply set_ext.
        - let u. assume Hu: u :e preimage_of X f {y0}.
          prove u :e {x0}.
          claim HuX: u :e X.
          { exact (SepE1 X (fun t:set => apply_fun f t :e {y0}) u Hu). }
          claim Hfu: apply_fun f u :e {y0}.
          { exact (SepE2 X (fun t:set => apply_fun f t :e {y0}) u Hu). }
          claim HfuEq: apply_fun f u = y0.
          { exact (SingE y0 (apply_fun f u) Hfu). }
          claim Hfx0Eq: apply_fun f x0 = y0.
          { reflexivity. }
          claim HffEq: apply_fun f u = apply_fun f x0.
          { rewrite HfuEq.
            rewrite <- Hfx0Eq.
            reflexivity. }
          claim HuEq: u = x0.
          { exact (homeomorphism_injective X Tx Y Ty f Hhom u x0 HuX Hx0X HffEq). }
          rewrite HuEq.
          exact (SingI x0).
        - let u. assume Hu: u :e {x0}.
          prove u :e preimage_of X f {y0}.
          claim HuEq: u = x0.
          { exact (SingE x0 u Hu). }
          rewrite HuEq.
          prove x0 :e preimage_of X f {y0}.
          claim Hfy0: apply_fun f x0 :e {y0}.
          { claim Hfx0Eq: apply_fun f x0 = y0.
            { reflexivity. }
            rewrite Hfx0Eq at 1.
            exact (SingI y0). }
          exact (SepI X (fun t:set => apply_fun f t :e {y0}) x0 Hx0X Hfy0). }
      rewrite <- HpreEq.
      exact HpreClosed.
  + let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  prove exists h:set,
    continuous_map X Tx R R_standard_topology h /\
    apply_fun h x = 0 /\ forall z:set, z :e F -> apply_fun h z = 1.
  apply HexInv.
  let g. assume Hgpack.
  claim Hleft:
    continuous_map Y Ty X Tx g /\
      (forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0).
  { exact (andEL (continuous_map Y Ty X Tx g /\
                  (forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0))
                 (forall y0:set, y0 :e Y -> apply_fun f (apply_fun g y0) = y0)
                 Hgpack). }
  claim Hgcont: continuous_map Y Ty X Tx g.
  { exact (andEL (continuous_map Y Ty X Tx g)
                 (forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0)
                 Hleft). }
  claim Hgf: forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0.
  { exact (andER (continuous_map Y Ty X Tx g)
                 (forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0)
                 Hleft). }
  claim Hfg: forall y0:set, y0 :e Y -> apply_fun f (apply_fun g y0) = y0.
  { exact (andER (continuous_map Y Ty X Tx g /\
                  (forall x0:set, x0 :e X -> apply_fun g (apply_fun f x0) = x0))
                 (forall y0:set, y0 :e Y -> apply_fun f (apply_fun g y0) = y0)
                 Hgpack). }
  claim Hgfun: function_on g Y X.
  { exact (continuous_map_function_on Y Ty X Tx g Hgcont). }
  set y := apply_fun f x.
  claim HyY: y :e Y.
  { exact (Hfunf x HxX). }
  set Fy := preimage_of Y g F.
  claim HFyClosed: closed_in Y Ty Fy.
  { exact (continuous_map_preimage_closed Y Ty X Tx g F Hgcont HFcl). }
  claim HynotFy: y /:e Fy.
  { assume HyFy: y :e Fy.
	    claim HgyF: apply_fun g y :e F.
	    { exact (SepE2 Y (fun u:set => apply_fun g u :e F) y HyFy). }
	    claim HgyEq: apply_fun g y = x.
	    { exact (Hgf x HxX). }
	    claim HxF: x :e F.
	    { rewrite <- HgyEq.
	      exact HgyF. }
	    exact (HxnotF HxF). }
  apply (HsepY y HyY Fy HFyClosed HynotFy).
  let h. assume Hhpack.
  witness (compose_fun X f h).
  claim Hhleft: continuous_map Y Ty R R_standard_topology h /\ apply_fun h y = 0.
  { exact (andEL (continuous_map Y Ty R R_standard_topology h /\ apply_fun h y = 0)
                 (forall z:set, z :e Fy -> apply_fun h z = 1)
                 Hhpack). }
  claim Hhcont: continuous_map Y Ty R R_standard_topology h.
  { exact (andEL (continuous_map Y Ty R R_standard_topology h)
                 (apply_fun h y = 0)
                 Hhleft). }
  claim Hhy0: apply_fun h y = 0.
  { exact (andER (continuous_map Y Ty R R_standard_topology h)
                 (apply_fun h y = 0)
                 Hhleft). }
  claim HhFy: forall z:set, z :e Fy -> apply_fun h z = 1.
  { exact (andER (continuous_map Y Ty R R_standard_topology h /\ apply_fun h y = 0)
                 (forall z:set, z :e Fy -> apply_fun h z = 1)
                 Hhpack). }
  apply andI.
  + prove continuous_map X Tx R R_standard_topology (compose_fun X f h) /\ apply_fun (compose_fun X f h) x = 0.
    apply andI.
    - exact (composition_continuous X Tx Y Ty R R_standard_topology f h Hcontf Hhcont).
    - rewrite (compose_fun_apply X f h x HxX).
      rewrite <- Hhy0.
      reflexivity.
  + let z. assume HzF: z :e F.
    prove apply_fun (compose_fun X f h) z = 1.
    claim HzX: z :e X.
    { exact (closed_in_subset X Tx F HFcl z HzF). }
    claim HfzY: apply_fun f z :e Y.
    { exact (Hfunf z HzX). }
	    claim Hgfz: apply_fun g (apply_fun f z) = z.
	    { exact (Hgf z HzX). }
	    claim HfzFy: apply_fun f z :e Fy.
	    { claim HFyDef: Fy = preimage_of Y g F.
	      { reflexivity. }
	      rewrite HFyDef.
	      claim HpreDef: preimage_of Y g F = {u :e Y | apply_fun g u :e F}.
	      { reflexivity. }
	      rewrite HpreDef.
	      apply (SepI Y (fun u:set => apply_fun g u :e F) (apply_fun f z) HfzY).
	      rewrite Hgfz.
	      exact HzF. }
	    rewrite (compose_fun_apply X f h z HzX).
	    exact (HhFy (apply_fun f z) HfzFy).
Qed.

(** Helper: metric spaces are completely regular **)
(** LATEX VERSION: Every metrizable space is completely regular, by applying Urysohn lemma to {x} and a closed F. **)
Theorem metric_spaces_completely_regular : forall X d:set,
  metric_on X d -> completely_regular_space X (metric_topology X d).
let X d.
assume Hd: metric_on X d.
set Tx := metric_topology X d.
prove completely_regular_space X Tx.
claim HTx: topology_on X Tx.
{ exact (metric_topology_is_topology X d Hd). }
claim Hnorm: normal_space X Tx.
{ exact (metrizable_spaces_normal X d Hd). }
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
               Hnorm). }
prove topology_on X Tx /\
  (one_point_sets_closed X Tx /\
   forall x:set, x :e X ->
     forall F:set, closed_in X Tx F -> x /:e F ->
       exists f:set,
         continuous_map X Tx R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
apply andI.
- exact HTx.
- apply andI.
  + exact HT1.
  + let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  prove exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  claim Hxcl: closed_in X Tx {x}.
  { exact (andER (topology_on X Tx)
                 (forall x0:set, x0 :e X -> closed_in X Tx {x0})
                 HT1 x HxX). }
  claim Hdisj: {x} :/\: F = Empty.
  { apply set_ext.
    - let u. assume Hu: u :e {x} :/\: F.
      prove u :e Empty.
      claim Hux: u :e {x}.
      { exact (binintersectE1 {x} F u Hu). }
      claim HuEq: u = x.
      { exact (SingE x u Hux). }
      claim HuF: u :e F.
      { exact (binintersectE2 {x} F u Hu). }
      claim HxF: x :e F.
      { rewrite <- HuEq.
        exact HuF. }
      apply FalseE.
      exact (HxnotF HxF).
    - let u. assume Hu: u :e Empty.
      exact (EmptyE u Hu (u :e {x} :/\: F)). }
  claim H0le1: Rle 0 1.
  { exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
  claim Hex: exists f:set, continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0) /\
    (forall u:set, u :e F -> apply_fun f u = 1).
  { exact (Urysohn_lemma X Tx {x} F 0 1 H0le1 Hnorm Hxcl HFcl Hdisj). }
  apply Hex.
  let f. assume Hfpack.
  witness f.
  claim Hpair1:
    continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0).
  { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall u:set, u :e F -> apply_fun f u = 1)
                 Hfpack). }
  claim HcontI: continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f.
  { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim HAx: forall u:set, u :e {x} -> apply_fun f u = 0.
  { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim Hfx0: apply_fun f x = 0.
  { exact (HAx x (SingI x)). }
  claim HfF1: forall y:set, y :e F -> apply_fun f y = 1.
  { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall u:set, u :e F -> apply_fun f u = 1)
                 Hfpack). }
  claim HISubR: closed_interval 0 1 c= R.
  { exact (closed_interval_sub_R 0 1). }
  claim HTIeq: closed_interval_topology 0 1 =
    subspace_topology R R_standard_topology (closed_interval 0 1).
  { reflexivity. }
  claim HcontR: continuous_map X Tx R R_standard_topology f.
  { exact (continuous_map_range_expand X Tx (closed_interval 0 1) (closed_interval_topology 0 1) R R_standard_topology f
             HcontI HISubR R_standard_topology_is_topology HTIeq). }
  apply andI.
  * prove continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
    apply andI.
    - exact HcontR.
    - exact Hfx0.
  * exact HfF1.
Qed.

(** Helper: the real line is completely regular in the standard topology **)
(** LATEX VERSION: R is metrizable, hence completely regular. **)
(** Note: This theorem is placed later, after the bounded metric on R and the proof that it induces the standard topology. **)

(** Helper: the unit interval is completely regular **)
(** LATEX VERSION: The unit interval [0,1] with the subspace topology from R is completely regular. **)
Theorem unit_interval_completely_regular :
  completely_regular_space unit_interval unit_interval_topology.
prove completely_regular_space unit_interval unit_interval_topology.
claim Hut: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
{ reflexivity. }
claim HH: Hausdorff_space unit_interval unit_interval_topology.
{ rewrite Hut.
  exact (ex17_12_subspace_Hausdorff R R_standard_topology unit_interval
           R_standard_topology_Hausdorff unit_interval_sub_R). }
prove topology_on unit_interval unit_interval_topology /\
  (one_point_sets_closed unit_interval unit_interval_topology /\
   forall x:set, x :e unit_interval ->
     forall F:set, closed_in unit_interval unit_interval_topology F -> x /:e F ->
       exists f:set,
         continuous_map unit_interval unit_interval_topology R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
apply andI.
- exact unit_interval_topology_on.
- apply andI.
  + (** one_point_sets_closed **)
    prove topology_on unit_interval unit_interval_topology /\
      forall x0:set, x0 :e unit_interval -> closed_in unit_interval unit_interval_topology {x0}.
    apply andI.
    - exact unit_interval_topology_on.
    - let x0. assume Hx0I: x0 :e unit_interval.
      exact (Hausdorff_singletons_closed unit_interval unit_interval_topology x0 HH Hx0I).
  + let x. assume HxI: x :e unit_interval.
  let F. assume HFcl: closed_in unit_interval unit_interval_topology F.
  assume HxnotF: x /:e F.
  prove exists f:set,
    continuous_map unit_interval unit_interval_topology R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  claim Hcomp: compact_space unit_interval unit_interval_topology.
  { exact unit_interval_compact_axiom. }
  claim Hnorm: normal_space unit_interval unit_interval_topology.
  { exact (compact_Hausdorff_normal unit_interval unit_interval_topology Hcomp HH). }
  claim Hxcl: closed_in unit_interval unit_interval_topology {x}.
  { exact (Hausdorff_singletons_closed unit_interval unit_interval_topology x HH HxI). }
  claim H0le1: Rle 0 1.
  { exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
  claim Hdisj: {x} :/\: F = Empty.
  { apply set_ext.
    - let z. assume Hz: z :e {x} :/\: F.
      prove z :e Empty.
      claim HzSing: z :e {x}.
      { exact (binintersectE1 {x} F z Hz). }
      claim HzF: z :e F.
      { exact (binintersectE2 {x} F z Hz). }
      claim HzEq: z = x.
      { exact (SingE x z HzSing). }
      claim HxF: x :e F.
      { rewrite <- HzEq.
        exact HzF. }
      claim Hcontra: False.
      { exact (HxnotF HxF). }
      exact (FalseE Hcontra (z :e Empty)).
    - let z. assume Hz: z :e Empty.
      prove z :e {x} :/\: F.
      exact (EmptyE z Hz (z :e {x} :/\: F)). }
  apply (Urysohn_lemma unit_interval unit_interval_topology {x} F 0 1 H0le1 Hnorm Hxcl HFcl Hdisj).
  let f. assume Hfpack:
    continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0) /\
    (forall y:set, y :e F -> apply_fun f y = 1).
  witness f.
  prove continuous_map unit_interval unit_interval_topology R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  claim Hpair1:
    continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0).
  { exact (andEL (continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  claim HcontI: continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f.
  { exact (andEL (continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim HAx: forall u:set, u :e {x} -> apply_fun f u = 0.
  { exact (andER (continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim Hfx0: apply_fun f x = 0.
  { exact (HAx x (SingI x)). }
  claim HfF1: forall y:set, y :e F -> apply_fun f y = 1.
  { exact (andER (continuous_map unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall y:set, y :e F -> apply_fun f y = 1)
                 Hfpack). }
  claim HISubR: closed_interval 0 1 c= R.
  { exact (closed_interval_sub_R 0 1). }
  claim HTIeq: closed_interval_topology 0 1 =
    subspace_topology R R_standard_topology (closed_interval 0 1).
  { reflexivity. }
  claim HcontR: continuous_map unit_interval unit_interval_topology R R_standard_topology f.
  { exact (continuous_map_range_expand unit_interval unit_interval_topology (closed_interval 0 1) (closed_interval_topology 0 1) R R_standard_topology f
             HcontI HISubR R_standard_topology_is_topology HTIeq). }
  apply andI.
  * prove continuous_map unit_interval unit_interval_topology R R_standard_topology f /\ apply_fun f x = 0.
    apply andI.
    - exact HcontR.
    - exact Hfx0.
  * exact HfF1.
Qed.

(** Helper: normal spaces are completely regular **)
(** LATEX VERSION: If X is normal and T1 then Urysohn lemma separates a point and a closed set by a continuous function into [0,1]. **)
Theorem normal_space_implies_completely_regular : forall X Tx:set,
  normal_space X Tx ->
  completely_regular_space X Tx.
let X Tx.
assume Hnorm: normal_space X Tx.
prove completely_regular_space X Tx.
prove topology_on X Tx /\
  (one_point_sets_closed X Tx /\
   forall x:set, x :e X ->
     forall F:set, closed_in X Tx F -> x /:e F ->
       exists f:set,
         continuous_map X Tx R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
apply andI.
- exact (normal_space_topology_on X Tx Hnorm).
- apply andI.
  + exact (andEL (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm).
  + let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  prove exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  claim Hone: one_point_sets_closed X Tx.
  { exact (andEL (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm). }
  claim Hxcl: closed_in X Tx {x}.
  { exact (andER (topology_on X Tx)
                 (forall x0:set, x0 :e X -> closed_in X Tx {x0})
                 Hone x HxX). }
  claim Hdisj: {x} :/\: F = Empty.
  { apply set_ext.
    - let u. assume Hu: u :e {x} :/\: F.
      prove u :e Empty.
      claim Hux: u :e {x}.
      { exact (binintersectE1 {x} F u Hu). }
      claim HuEq: u = x.
      { exact (SingE x u Hux). }
      claim HuF: u :e F.
      { exact (binintersectE2 {x} F u Hu). }
      claim HxF: x :e F.
      { rewrite <- HuEq.
        exact HuF. }
      apply FalseE.
      exact (HxnotF HxF).
    - let u. assume Hu: u :e Empty.
      exact (EmptyE u Hu (u :e {x} :/\: F)). }
  claim H0le1: Rle 0 1.
  { exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
  claim Hex: exists f:set, continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0) /\
    (forall u:set, u :e F -> apply_fun f u = 1).
  { exact (Urysohn_lemma X Tx {x} F 0 1 H0le1 Hnorm Hxcl HFcl Hdisj). }
  apply Hex.
  let f. assume Hfpack.
  witness f.
  claim Hpair1:
    continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
    (forall u:set, u :e {x} -> apply_fun f u = 0).
  { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall u:set, u :e F -> apply_fun f u = 1)
                 Hfpack). }
  claim HcontI: continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f.
  { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim HAx: forall u:set, u :e {x} -> apply_fun f u = 0.
  { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f)
                 (forall u:set, u :e {x} -> apply_fun f u = 0)
                 Hpair1). }
  claim Hfx0: apply_fun f x = 0.
  { exact (HAx x (SingI x)). }
  claim HfF1: forall y:set, y :e F -> apply_fun f y = 1.
  { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) f /\
                  (forall u:set, u :e {x} -> apply_fun f u = 0))
                 (forall u:set, u :e F -> apply_fun f u = 1)
                 Hfpack). }
  claim HISubR: closed_interval 0 1 c= R.
  { exact (closed_interval_sub_R 0 1). }
  claim HTIeq: closed_interval_topology 0 1 =
    subspace_topology R R_standard_topology (closed_interval 0 1).
  { reflexivity. }
  claim HcontR: continuous_map X Tx R R_standard_topology f.
  { exact (continuous_map_range_expand X Tx (closed_interval 0 1) (closed_interval_topology 0 1) R R_standard_topology f
             HcontI HISubR R_standard_topology_is_topology HTIeq). }
  apply andI.
  * prove continuous_map X Tx R R_standard_topology f /\ apply_fun f x = 0.
    apply andI.
    - exact HcontR.
    - exact Hfx0.
  * exact HfF1.
Qed.

(** Helper: completely regular binary product in product_topology **)
(** LATEX VERSION: Product of two completely regular spaces is completely regular. **)
Theorem continuous_map_to_generated_topology : forall X Tx Y B f:set,
  topology_on X Tx ->
  basis_on Y B ->
  function_on f X Y ->
  (forall b:set, b :e B -> preimage_of X f b :e Tx) ->
  continuous_map X Tx Y (generated_topology Y B) f.
let X Tx Y B f.
assume HTx: topology_on X Tx.
assume HBasis: basis_on Y B.
assume Hfun: function_on f X Y.
assume HpreB: forall b:set, b :e B -> preimage_of X f b :e Tx.
set Ty := generated_topology Y B.
claim HTy: topology_on Y Ty.
{ exact (lemma_topology_from_basis Y B HBasis). }
(** Define Tpre as sets whose preimages are open. **)
set TpreFam : set := {U0 :e Power Y| preimage_of X f U0 :e Tx}.
claim HTpre: topology_on Y TpreFam.
{ claim HsubPow: TpreFam c= Power Y.
  { let U. assume HU: U :e TpreFam.
    exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
  claim Hempty: Empty :e TpreFam.
  { apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) Empty (Empty_In_Power Y)).
    rewrite (preimage_of_Empty X f).
    exact (topology_has_empty X Tx HTx). }
  claim HYin: Y :e TpreFam.
  { apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) Y (Self_In_Power Y)).
    rewrite (preimage_of_whole X Y f Hfun).
    exact (topology_has_X X Tx HTx). }
  claim Hunion: forall UFam :e Power TpreFam, Union UFam :e TpreFam.
  { let UFam. assume HUFamPow: UFam :e Power TpreFam.
    claim HUFsub: UFam c= TpreFam.
    { exact (PowerE TpreFam UFam HUFamPow). }
    claim HUnionPowY: Union UFam :e Power Y.
    { apply PowerI.
      let y. assume Hy: y :e Union UFam.
      apply (UnionE_impred UFam y Hy).
      let U. assume HyU: y :e U. assume HUUF: U :e UFam.
      claim HUTpre: U :e TpreFam.
      { exact (HUFsub U HUUF). }
      claim HUPowY: U :e Power Y.
      { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HUTpre). }
      exact (PowerE Y U HUPowY y HyU). }
    apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) (Union UFam) HUnionPowY).
    rewrite (preimage_of_Union X f UFam).
    set PreFam : set := {preimage_of X f U|U :e UFam}.
    claim HPreFamSub: PreFam c= Tx.
    { let W. assume HW: W :e PreFam.
      apply (ReplE_impred UFam (fun U0:set => preimage_of X f U0) W HW (W :e Tx)).
      let U. assume HUUF: U :e UFam. assume HWU: W = preimage_of X f U.
      claim HUTpre: U :e TpreFam.
      { exact (HUFsub U HUUF). }
      claim HpreU: preimage_of X f U :e Tx.
      { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HUTpre). }
      rewrite HWU.
      exact HpreU. }
    exact (topology_union_closed X Tx PreFam HTx HPreFamSub). }
  claim Hinter: forall U :e TpreFam, forall V :e TpreFam, U :/\: V :e TpreFam.
  { let U. assume HU: U :e TpreFam.
    let V. assume HV: V :e TpreFam.
    claim HUPow: U :e Power Y.
    { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
    claim HVPow: V :e Power Y.
    { exact (SepE1 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HV). }
    claim HUVPow: U :/\: V :e Power Y.
    { exact (binintersect_Power Y U V HUPow HVPow). }
    apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) (U :/\: V) HUVPow).
    rewrite (preimage_of_binintersect X f U V).
    claim HpreU: preimage_of X f U :e Tx.
    { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) U HU). }
    claim HpreV: preimage_of X f V :e Tx.
    { exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HV). }
    exact (topology_binintersect_closed X Tx (preimage_of X f U) (preimage_of X f V) HTx HpreU HpreV). }
  claim HTpre_def: topology_on Y TpreFam =
    (TpreFam c= Power Y
     /\ Empty :e TpreFam
     /\ Y :e TpreFam
     /\ (forall UFam :e Power TpreFam, Union UFam :e TpreFam)
     /\ (forall U :e TpreFam, forall V :e TpreFam, U :/\: V :e TpreFam)).
  { reflexivity. }
  rewrite HTpre_def.
  apply and5I.
  - exact HsubPow.
  - exact Hempty.
  - exact HYin.
  - exact Hunion.
  - exact Hinter. }
claim HBsubPow: B c= Power Y.
{ exact (andEL (B c= Power Y)
               (forall x :e Y, exists b :e B, x :e b)
               (andEL (B c= Power Y /\ (forall x :e Y, exists b :e B, x :e b))
                      (forall b1 :e B, forall b2 :e B, forall x:set, x :e b1 -> x :e b2 -> exists b3 :e B, x :e b3 /\ b3 c= b1 :/\: b2)
                      HBasis)). }
claim HBsubTpre: forall b :e B, b :e TpreFam.
{ let b. assume HbB: b :e B.
  prove b :e TpreFam.
  claim HbPow: b :e Power Y.
  { exact (HBsubPow b HbB). }
  apply (SepI (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) b HbPow).
  exact (HpreB b HbB). }
claim HgenSub: Ty c= TpreFam.
{ exact (generated_topology_finer_weak Y B TpreFam HTpre HBsubTpre). }
prove continuous_map X Tx Y Ty f.
prove (topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y /\
  forall V:set, V :e Ty -> preimage_of X f V :e Tx.
apply andI.
- apply andI.
  * apply andI.
    - exact HTx.
    - exact HTy.
  * exact Hfun.
- let V. assume HV: V :e Ty.
  claim HVpre: V :e TpreFam.
  { exact (HgenSub V HV). }
  exact (SepE2 (Power Y) (fun U0:set => preimage_of X f U0 :e Tx) V HVpre).
Qed.

Theorem completely_regular_product_topology : forall X Tx Y Ty:set,
  completely_regular_space X Tx ->
  completely_regular_space Y Ty ->
  completely_regular_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HcrX: completely_regular_space X Tx.
assume HcrY: completely_regular_space Y Ty.
claim HTx: topology_on X Tx.
{ exact (completely_regular_space_topology_on X Tx HcrX). }
claim HTy: topology_on Y Ty.
{ exact (completely_regular_space_topology_on Y Ty HcrY). }
set X0 := setprod X Y.
set B0 := product_subbasis X Tx Y Ty.
set T0 := product_topology X Tx Y Ty.
claim HB0: basis_on X0 B0.
{ exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
claim HT0: topology_on X0 T0.
{ exact (product_topology_is_topology X Tx Y Ty HTx HTy). }

(** Build an indexed-family encoding of the binary product **)
set I := 2.
set Xi := graph I (fun i:set => If_i (i = 0) (X,Tx) (Y,Ty)).
set X1 := product_space I Xi.
set T1 := product_topology_full I Xi.

(** coordinate equalities for the 2-indexed family **)
claim HXi0: apply_fun Xi 0 = (X,Tx).
{ claim H0I: 0 :e I.
  { exact In_0_2. }
  rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (X,Tx) (Y,Ty)) 0 H0I).
  claim H00: 0 = 0.
  { reflexivity. }
  rewrite (If_i_1 (0 = 0) (X,Tx) (Y,Ty) H00).
  reflexivity. }
claim HXi1: apply_fun Xi 1 = (Y,Ty).
{ claim H1I: 1 :e I.
  { exact In_1_2. }
  rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (X,Tx) (Y,Ty)) 1 H1I).
  claim H10: ~(1 = 0).
  { exact neq_1_0. }
  rewrite (If_i_0 (1 = 0) (X,Tx) (Y,Ty) H10).
  reflexivity. }
claim HXset0: space_family_set Xi 0 = X.
{ claim Hsf: space_family_set Xi 0 = (apply_fun Xi 0) 0.
  { reflexivity. }
  rewrite Hsf.
  rewrite HXi0.
  exact (tuple_2_0_eq X Tx). }
claim HXtop0: space_family_topology Xi 0 = Tx.
{ claim Hsf: space_family_topology Xi 0 = (apply_fun Xi 0) 1.
  { reflexivity. }
  rewrite Hsf.
  rewrite HXi0.
  exact (tuple_2_1_eq X Tx). }
claim HXset1: space_family_set Xi 1 = Y.
{ claim Hsf: space_family_set Xi 1 = (apply_fun Xi 1) 0.
  { reflexivity. }
  rewrite Hsf.
  rewrite HXi1.
  exact (tuple_2_0_eq Y Ty). }
claim HXtop1: space_family_topology Xi 1 = Ty.
{ claim Hsf: space_family_topology Xi 1 = (apply_fun Xi 1) 1.
  { reflexivity. }
  rewrite Hsf.
  rewrite HXi1.
  exact (tuple_2_1_eq Y Ty). }

(** Show the cylinder family is a subbasis on X1 **)
claim HIne: I <> Empty.
{ exact (elem_implies_nonempty I 0 In_0_2). }
claim HcompTop: forall i:set, i :e I -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
{ let i. assume HiI: i :e I.
  (** i in 2 implies i=0 or i=1 **)
  claim Hi01: i :e {0,1}.
  { exact (Subq_2_UPair01 i HiI). }
  apply (UPairE i 0 1 Hi01 (topology_on (space_family_set Xi i) (space_family_topology Xi i))).
  - assume Hi0: i = 0.
    rewrite Hi0.
    rewrite HXset0.
    rewrite HXtop0.
    exact HTx.
  - assume Hi1: i = 1.
    rewrite Hi1.
    rewrite HXset1.
    rewrite HXtop1.
    exact HTy. }
claim HSsub: subbasis_on X1 (product_subbasis_full I Xi).
{ exact (product_subbasis_full_subbasis_on I Xi HIne HcompTop). }

(** Define the pair-to-function and function-to-pair maps **)
set pair_fun := graph X0 (fun p:set => graph I (fun i:set => If_i (i = 0) (p 0) (p 1))).
set fun_pair := graph X1 (fun h:set => (apply_fun h 0, apply_fun h 1)).

(** product_space is completely regular by Theorem 33.2 (indexed products) **)
claim HprodLemma: forall J Zeta:set,
  completely_regular_spaces_family J Zeta ->
  completely_regular_space (product_space J Zeta) (product_topology_full J Zeta).
{ exact (andER (forall Y0:set, Y0 c= R -> completely_regular_space R R_standard_topology ->
                 completely_regular_space Y0 (subspace_topology R R_standard_topology Y0))
               (forall I0 Xi0:set, completely_regular_spaces_family I0 Xi0 ->
                 completely_regular_space (product_space I0 Xi0) (product_topology_full I0 Xi0))
               (completely_regular_subspace_product R R_standard_topology R_standard_topology_is_topology)). }
claim Hfam: completely_regular_spaces_family I Xi.
{ let i. assume HiI: i :e I.
  claim Hi01: i :e {0,1}.
  { exact (Subq_2_UPair01 i HiI). }
  apply (UPairE i 0 1 Hi01 (completely_regular_space (product_component Xi i) (product_component_topology Xi i))).
  - assume Hi0: i = 0.
    rewrite Hi0.
    rewrite (product_component_def Xi 0).
    rewrite (product_component_topology_def Xi 0).
    rewrite HXi0.
    rewrite (tuple_2_0_eq X Tx).
    rewrite (tuple_2_1_eq X Tx).
    exact HcrX.
  - assume Hi1: i = 1.
    rewrite Hi1.
    rewrite (product_component_def Xi 1).
    rewrite (product_component_topology_def Xi 1).
    rewrite HXi1.
    rewrite (tuple_2_0_eq Y Ty).
    rewrite (tuple_2_1_eq Y Ty).
    exact HcrY. }
claim HcrX1: completely_regular_space X1 T1.
{ exact (HprodLemma I Xi Hfam). }

(** Homeomorphism between (X0,T0) and (X1,T1) **)
claim Hhom: homeomorphism X0 T0 X1 T1 pair_fun.
{ prove continuous_map X0 T0 X1 T1 pair_fun /\
    exists g:set, continuous_map X1 T1 X0 T0 g /\
      (forall x:set, x :e X0 -> apply_fun g (apply_fun pair_fun x) = x) /\
      (forall y:set, y :e X1 -> apply_fun pair_fun (apply_fun g y) = y).
	  apply andI.
	  - (** pair_fun is continuous into the product topology generated from cylinders **)
		    claim Hfun_pair_fun: function_on pair_fun X0 X1.
		    { let p. assume Hp: p :e X0.
		      prove apply_fun pair_fun p :e X1.
		      rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p Hp).
		      set h := (fun i0:set => If_i (i0 = 0) (p 0) (p 1)).
		      claim Hhdef: h = (fun i0:set => If_i (i0 = 0) (p 0) (p 1)).
		      { reflexivity. }
		      rewrite <- Hhdef.
		      set gp := graph I h.
		      claim Hgpdef: gp = graph I h.
		      { reflexivity. }
		      rewrite <- Hgpdef.
		      claim Hp0X: p 0 :e X.
		      { exact (ap0_Sigma X (fun _ : set => Y) p Hp). }
		      claim Hp1Y: p 1 :e Y.
		      { exact (ap1_Sigma X (fun _ : set => Y) p Hp). }
		      claim Hhj_union: forall j:set, j :e I -> h j :e space_family_union I Xi.
		      { let j. assume HjI: j :e I.
		        claim Hhj_eq: h j = If_i (j = 0) (p 0) (p 1).
		        { reflexivity. }
		        claim Hj01: j :e {0,1}.
		        { exact (Subq_2_UPair01 j HjI). }
		        apply (UPairE j 0 1 Hj01 (h j :e space_family_union I Xi)).
		        - assume Hj0: j = 0.
		          rewrite Hhj_eq.
		          rewrite Hj0.
		          claim H00: 0 = 0.
		          { reflexivity. }
		          rewrite (If_i_1 (0 = 0) (p 0) (p 1) H00).
		          claim Hp0sf: p 0 :e space_family_set Xi 0.
		          { rewrite HXset0. exact Hp0X. }
		          exact (UnionI {space_family_set Xi i0|i0 :e I} (p 0) (space_family_set Xi 0) Hp0sf
		                   (ReplI I (fun i0:set => space_family_set Xi i0) 0 In_0_2)).
		        - assume Hj1: j = 1.
		          rewrite Hhj_eq.
		          rewrite Hj1.
		          claim H10: ~(1 = 0).
		          { exact neq_1_0. }
		          rewrite (If_i_0 (1 = 0) (p 0) (p 1) H10).
		          claim Hp1sf: p 1 :e space_family_set Xi 1.
		          { rewrite HXset1. exact Hp1Y. }
		          exact (UnionI {space_family_set Xi i0|i0 :e I} (p 1) (space_family_set Xi 1) Hp1sf
		                   (ReplI I (fun i0:set => space_family_set Xi i0) 1 In_1_2)). }
		      claim Hgp_sub: gp c= setprod I (space_family_union I Xi).
		      { let z. assume Hz: z :e gp.
		        apply (ReplE_impred I (fun j0:set => (j0, h j0)) z Hz (z :e setprod I (space_family_union I Xi))).
		        let j. assume HjI: j :e I.
		        assume HzEq: z = (j, h j).
		        rewrite HzEq.
		        exact (tuple_2_setprod_by_pair_Sigma I (space_family_union I Xi) j (h j) HjI (Hhj_union j HjI)). }
		      claim Hgp_pow: gp :e Power (setprod I (space_family_union I Xi)).
		      { exact (PowerI (setprod I (space_family_union I Xi)) gp Hgp_sub). }
		      claim Hgp_tot: total_function_on gp I (space_family_union I Xi).
		      { apply (total_function_on_graph I (space_family_union I Xi) h).
		        exact Hhj_union. }
		      claim Hgp_fun: functional_graph gp.
		      { exact (functional_graph_graph I h). }
		      claim Hcoords: forall j:set, j :e I -> apply_fun gp j :e space_family_set Xi j.
		      { let j. assume HjI: j :e I.
		        rewrite (apply_fun_graph I h j HjI).
		        claim Hhj_eq: h j = If_i (j = 0) (p 0) (p 1).
		        { reflexivity. }
		        claim Hj01: j :e {0,1}.
		        { exact (Subq_2_UPair01 j HjI). }
		        apply (UPairE j 0 1 Hj01 (h j :e space_family_set Xi j)).
		        - assume Hj0: j = 0.
		          rewrite Hhj_eq.
		          rewrite Hj0.
		          claim H00: 0 = 0.
		          { reflexivity. }
		          rewrite (If_i_1 (0 = 0) (p 0) (p 1) H00).
		          rewrite HXset0.
		          exact Hp0X.
		        - assume Hj1: j = 1.
		          rewrite Hhj_eq.
		          rewrite Hj1.
		          claim H10: ~(1 = 0).
		          { exact neq_1_0. }
		          rewrite (If_i_0 (1 = 0) (p 0) (p 1) H10).
		          rewrite HXset1.
		          exact Hp1Y. }
		      claim Hpred:
		        total_function_on gp I (space_family_union I Xi) /\ functional_graph gp /\
		          forall j:set, j :e I -> apply_fun gp j :e space_family_set Xi j.
		      { apply andI.
		        - apply andI.
		          * exact Hgp_tot.
		          * exact Hgp_fun.
		        - exact Hcoords. }
		      exact (SepI (Power (setprod I (space_family_union I Xi)))
		                  (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
		                    forall j:set, j :e I -> apply_fun f0 j :e space_family_set Xi j)
		                  gp Hgp_pow Hpred). }
	    apply (continuous_map_from_subbasis X0 T0 X1 (product_subbasis_full I Xi) pair_fun HT0 Hfun_pair_fun HSsub).
    let s. assume HsS: s :e product_subbasis_full I Xi.
    (** preimage of a cylinder is a rectangle, hence open in the product topology **)
    claim Hexi: exists i:set, i :e I /\ s :e {product_cylinder I Xi i U|U :e space_family_topology Xi i}.
    { exact (famunionE I (fun i0:set => {product_cylinder I Xi i0 U|U :e space_family_topology Xi i0}) s HsS). }
    apply Hexi.
    let i. assume Hipair.
    claim HiI: i :e I.
    { exact (andEL (i :e I) (s :e {product_cylinder I Xi i U|U :e space_family_topology Xi i}) Hipair). }
	    claim HsFi: s :e {product_cylinder I Xi i U|U :e space_family_topology Xi i}.
	    { exact (andER (i :e I) (s :e {product_cylinder I Xi i U|U :e space_family_topology Xi i}) Hipair). }
	    apply (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder I Xi i U0) s HsFi).
	    let U. assume HUpair.
		    claim HUin: U :e space_family_topology Xi i.
		    { exact (andEL (U :e space_family_topology Xi i) (s = product_cylinder I Xi i U) HUpair). }
			    claim Hseq: s = product_cylinder I Xi i U.
			    { exact (andER (U :e space_family_topology Xi i) (s = product_cylinder I Xi i U) HUpair). }
			    rewrite Hseq.
			    claim Hi01: i :e {0,1}.
			    { exact (Subq_2_UPair01 i HiI). }
			    apply (UPairE i 0 1 Hi01 (preimage_of X0 pair_fun (product_cylinder I Xi i U) :e T0)).
			    - assume Hi0: i = 0.
			      rewrite Hi0.
			      claim HU0eq: space_family_topology Xi i = space_family_topology Xi 0.
			      { rewrite Hi0. reflexivity. }
			      claim HU0: U :e space_family_topology Xi 0.
			      { rewrite <- HU0eq. exact HUin. }
			      claim HU: U :e Tx.
			      { rewrite <- HXtop0. exact HU0. }
			      claim HTxSub: Tx c= Power X.
			      { exact (topology_subset_axiom X Tx HTx). }
			      claim HUpow: U :e Power X.
			      { exact (HTxSub U HU). }
			      claim HUsubX: U c= X.
			      { exact (PowerE X U HUpow). }
			      set R0 := rectangle_set U Y.
			      claim HYTy: Y :e Ty.
			      { exact (topology_has_X Y Ty HTy). }
			      claim HR0inB: R0 :e B0.
			      { claim HRfam: R0 :e {rectangle_set U V|V :e Ty}.
			        { exact (ReplI Ty (fun V0:set => rectangle_set U V0) Y HYTy). }
			        exact (famunionI Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) U R0 HU HRfam). }
			      claim Heq0: preimage_of X0 pair_fun (product_cylinder I Xi 0 U) = R0.
			      { apply set_ext.
			        - let p0. assume Hp0: p0 :e preimage_of X0 pair_fun (product_cylinder I Xi 0 U).
			          prove p0 :e R0.
			          claim Hp0X0: p0 :e X0.
			          { exact (SepE1 X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 0 U) p0 Hp0). }
			          claim Himg: apply_fun pair_fun p0 :e product_cylinder I Xi 0 U.
			          { exact (SepE2 X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 0 U) p0 Hp0). }
			          claim Hconj:
			            0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun (apply_fun pair_fun p0) 0 :e U.
			          { exact (SepE2 (product_space I Xi)
			                         (fun f0:set => 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun f0 0 :e U)
			                         (apply_fun pair_fun p0) Himg). }
			          claim Hthird: apply_fun (apply_fun pair_fun p0) 0 :e U.
			          { exact (andER (0 :e I /\ U :e space_family_topology Xi 0) (apply_fun (apply_fun pair_fun p0) 0 :e U) Hconj). }
			          claim HcoordEq: apply_fun (apply_fun pair_fun p0) 0 = p0 0.
			          { rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p0 Hp0X0).
			            rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (p0 0) (p0 1)) 0 In_0_2).
			            claim H00: 0 = 0.
			            { reflexivity. }
			            rewrite (If_i_1 (0 = 0) (p0 0) (p0 1) H00).
			            reflexivity. }
			          claim Hp00U: p0 0 :e U.
			          { rewrite <- HcoordEq. exact Hthird. }
				          claim Hp01Y: p0 1 :e Y.
				          { exact (ap1_Sigma X (fun _ : set => Y) p0 Hp0X0). }
				          rewrite rectangle_set_def.
				          claim HpEta: p0 = (p0 0, p0 1).
				          { exact (setprod_eta X Y p0 Hp0X0). }
				          rewrite HpEta.
				          exact (tuple_2_setprod_by_pair_Sigma U Y (p0 0) (p0 1) Hp00U Hp01Y).
			        - let p0. assume Hp0: p0 :e R0.
			          prove p0 :e preimage_of X0 pair_fun (product_cylinder I Xi 0 U).
			          claim HpUV: p0 :e setprod U Y.
			          { rewrite <- rectangle_set_def. exact Hp0. }
			          claim Hp00U: p0 0 :e U.
			          { exact (ap0_Sigma U (fun _ : set => Y) p0 HpUV). }
			          claim Hp01Y: p0 1 :e Y.
			          { exact (ap1_Sigma U (fun _ : set => Y) p0 HpUV). }
				          claim Hp00X: p0 0 :e X.
				          { exact (HUsubX (p0 0) Hp00U). }
				          claim Hp0X0: p0 :e X0.
				          { claim HpEta: p0 = (p0 0, p0 1).
				            { exact (setprod_eta U Y p0 HpUV). }
				            rewrite HpEta.
				            exact (tuple_2_setprod_by_pair_Sigma X Y (p0 0) (p0 1) Hp00X Hp01Y). }
			          claim HfX1: apply_fun pair_fun p0 :e X1.
			          { exact (Hfun_pair_fun p0 Hp0X0). }
			          claim HcoordEq: apply_fun (apply_fun pair_fun p0) 0 = p0 0.
			          { rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p0 Hp0X0).
			            rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (p0 0) (p0 1)) 0 In_0_2).
			            claim H00: 0 = 0.
			            { reflexivity. }
			            rewrite (If_i_1 (0 = 0) (p0 0) (p0 1) H00).
			            reflexivity. }
				          claim Hf0U: apply_fun (apply_fun pair_fun p0) 0 :e U.
				          { rewrite HcoordEq. exact Hp00U. }
				          claim Hcyl: apply_fun pair_fun p0 :e product_cylinder I Xi 0 U.
				          { claim Hpred: 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun (apply_fun pair_fun p0) 0 :e U.
				            { apply andI.
				              - apply andI.
				                + exact In_0_2.
				                + exact HU0.
				              - exact Hf0U. }
				            exact (SepI (product_space I Xi)
				                        (fun f0:set => 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun f0 0 :e U)
				                        (apply_fun pair_fun p0) HfX1 Hpred). }
			          exact (SepI X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 0 U) p0 Hp0X0 Hcyl). }
			      rewrite Heq0.
			      exact (generated_topology_contains_basis X0 B0 HB0 R0 HR0inB).
			    - assume Hi1: i = 1.
			      rewrite Hi1.
			      claim HU1eq: space_family_topology Xi i = space_family_topology Xi 1.
			      { rewrite Hi1. reflexivity. }
			      claim HU1: U :e space_family_topology Xi 1.
			      { rewrite <- HU1eq. exact HUin. }
			      claim HU: U :e Ty.
			      { rewrite <- HXtop1. exact HU1. }
			      claim HTySub: Ty c= Power Y.
			      { exact (topology_subset_axiom Y Ty HTy). }
			      claim HUpow: U :e Power Y.
			      { exact (HTySub U HU). }
			      claim HUsubY: U c= Y.
			      { exact (PowerE Y U HUpow). }
			      set R1 := rectangle_set X U.
			      claim HXTx: X :e Tx.
			      { exact (topology_has_X X Tx HTx). }
			      claim HR1inB: R1 :e B0.
			      { claim HRfam: R1 :e {rectangle_set X V|V :e Ty}.
			        { exact (ReplI Ty (fun V0:set => rectangle_set X V0) U HU). }
			        exact (famunionI Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) X R1 HXTx HRfam). }
			      claim Heq1: preimage_of X0 pair_fun (product_cylinder I Xi 1 U) = R1.
			      { apply set_ext.
			        - let p0. assume Hp0: p0 :e preimage_of X0 pair_fun (product_cylinder I Xi 1 U).
			          prove p0 :e R1.
			          claim Hp0X0: p0 :e X0.
			          { exact (SepE1 X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 1 U) p0 Hp0). }
			          claim Himg: apply_fun pair_fun p0 :e product_cylinder I Xi 1 U.
			          { exact (SepE2 X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 1 U) p0 Hp0). }
			          claim Hconj:
			            1 :e I /\ U :e space_family_topology Xi 1 /\ apply_fun (apply_fun pair_fun p0) 1 :e U.
			          { exact (SepE2 (product_space I Xi)
			                         (fun f0:set => 1 :e I /\ U :e space_family_topology Xi 1 /\ apply_fun f0 1 :e U)
			                         (apply_fun pair_fun p0) Himg). }
			          claim Hthird: apply_fun (apply_fun pair_fun p0) 1 :e U.
			          { exact (andER (1 :e I /\ U :e space_family_topology Xi 1) (apply_fun (apply_fun pair_fun p0) 1 :e U) Hconj). }
			          claim HcoordEq: apply_fun (apply_fun pair_fun p0) 1 = p0 1.
			          { rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p0 Hp0X0).
			            rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (p0 0) (p0 1)) 1 In_1_2).
			            claim H10: ~(1 = 0).
			            { exact neq_1_0. }
			            rewrite (If_i_0 (1 = 0) (p0 0) (p0 1) H10).
			            reflexivity. }
			          claim Hp01U: p0 1 :e U.
			          { rewrite <- HcoordEq. exact Hthird. }
				          claim Hp00X: p0 0 :e X.
				          { exact (ap0_Sigma X (fun _ : set => Y) p0 Hp0X0). }
				          rewrite rectangle_set_def.
				          claim HpEta: p0 = (p0 0, p0 1).
				          { exact (setprod_eta X Y p0 Hp0X0). }
				          rewrite HpEta.
				          exact (tuple_2_setprod_by_pair_Sigma X U (p0 0) (p0 1) Hp00X Hp01U).
			        - let p0. assume Hp0: p0 :e R1.
			          prove p0 :e preimage_of X0 pair_fun (product_cylinder I Xi 1 U).
			          claim HpXU: p0 :e setprod X U.
			          { rewrite <- rectangle_set_def. exact Hp0. }
			          claim Hp00X: p0 0 :e X.
			          { exact (ap0_Sigma X (fun _ : set => U) p0 HpXU). }
			          claim Hp01U: p0 1 :e U.
			          { exact (ap1_Sigma X (fun _ : set => U) p0 HpXU). }
				          claim Hp01Y: p0 1 :e Y.
				          { exact (HUsubY (p0 1) Hp01U). }
				          claim Hp0X0: p0 :e X0.
				          { claim HpEta: p0 = (p0 0, p0 1).
				            { exact (setprod_eta X U p0 HpXU). }
				            rewrite HpEta.
				            exact (tuple_2_setprod_by_pair_Sigma X Y (p0 0) (p0 1) Hp00X Hp01Y). }
			          claim HfX1: apply_fun pair_fun p0 :e X1.
			          { exact (Hfun_pair_fun p0 Hp0X0). }
			          claim HcoordEq: apply_fun (apply_fun pair_fun p0) 1 = p0 1.
			          { rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p0 Hp0X0).
			            rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (p0 0) (p0 1)) 1 In_1_2).
			            claim H10: ~(1 = 0).
			            { exact neq_1_0. }
			            rewrite (If_i_0 (1 = 0) (p0 0) (p0 1) H10).
			            reflexivity. }
				          claim Hf1U: apply_fun (apply_fun pair_fun p0) 1 :e U.
				          { rewrite HcoordEq. exact Hp01U. }
				          claim Hcyl: apply_fun pair_fun p0 :e product_cylinder I Xi 1 U.
				          { claim Hpred: 1 :e I /\ U :e space_family_topology Xi 1 /\ apply_fun (apply_fun pair_fun p0) 1 :e U.
				            { apply andI.
				              - apply andI.
				                + exact In_1_2.
				                + exact HU1.
				              - exact Hf1U. }
				            exact (SepI (product_space I Xi)
				                        (fun f0:set => 1 :e I /\ U :e space_family_topology Xi 1 /\ apply_fun f0 1 :e U)
				                        (apply_fun pair_fun p0) HfX1 Hpred). }
			          exact (SepI X0 (fun x0:set => apply_fun pair_fun x0 :e product_cylinder I Xi 1 U) p0 Hp0X0 Hcyl). }
			      rewrite Heq1.
			      exact (generated_topology_contains_basis X0 B0 HB0 R1 HR1inB).
	  - (** inverse package for homeomorphism **)
	    witness fun_pair.
	    apply andI.
	    + apply andI.
	      - (** fun_pair is continuous into the generated product topology on X0 **)
	      claim Hfun_fun_pair: function_on fun_pair X1 X0.
	      { let h. assume Hh: h :e X1.
	        prove apply_fun fun_pair h :e X0.
	        rewrite (apply_fun_graph X1 (fun h0:set => (apply_fun h0 0, apply_fun h0 1)) h Hh).
        claim Hcoords: forall i0:set, i0 :e I -> apply_fun h i0 :e space_family_set Xi i0.
        { exact (andER (total_function_on h I (space_family_union I Xi) /\ functional_graph h)
                       (forall i0:set, i0 :e I -> apply_fun h i0 :e space_family_set Xi i0)
                       (SepE2 (Power (setprod I (space_family_union I Xi)))
                              (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
                                forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
                              h Hh)). }
        claim Hh0X: apply_fun h 0 :e X.
        { rewrite <- HXset0.
          exact (Hcoords 0 In_0_2). }
        claim Hh1Y: apply_fun h 1 :e Y.
        { rewrite <- HXset1.
          exact (Hcoords 1 In_1_2). }
        exact (tuple_2_setprod_by_pair_Sigma X Y (apply_fun h 0) (apply_fun h 1) Hh0X Hh1Y). }
      claim HB0sub: B0 c= Power X0.
      { exact (andEL (B0 c= Power X0)
                     (forall x0 :e X0, exists b :e B0, x0 :e b)
                     (andEL (B0 c= Power X0 /\ (forall x0 :e X0, exists b :e B0, x0 :e b))
	                            (forall b1 :e B0, forall b2 :e B0, forall x0:set, x0 :e b1 -> x0 :e b2 -> exists b3 :e B0, x0 :e b3 /\ b3 c= b1 :/\: b2)
	                            HB0)). }
	      claim HpreB0: forall b:set, b :e B0 -> preimage_of X1 fun_pair b :e T1.
	      { let b. assume HbB: b :e B0.
	        claim HexU: exists U :e Tx, b :e {rectangle_set U V|V :e Ty}.
		        { exact (famunionE Tx (fun U0:set => {rectangle_set U0 V|V :e Ty}) b HbB). }
		        apply HexU.
		        let U. assume HUpack.
		        claim HU: U :e Tx.
		        { exact (andEL (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUpack). }
		        claim HbFam: b :e {rectangle_set U V|V :e Ty}.
		        { exact (andER (U :e Tx) (b :e {rectangle_set U V|V :e Ty}) HUpack). }
	        claim HexV: exists V:set, V :e Ty /\ b = rectangle_set U V.
	        { exact (ReplE Ty (fun V0:set => rectangle_set U V0) b HbFam). }
	        apply HexV.
	        let V. assume HVconj.
	        claim HV: V :e Ty.
	        { exact (andEL (V :e Ty) (b = rectangle_set U V) HVconj). }
	        claim Hbeq: b = rectangle_set U V.
	        { exact (andER (V :e Ty) (b = rectangle_set U V) HVconj). }
	        claim HU0: U :e space_family_topology Xi 0.
	        { rewrite HXtop0. exact HU. }
	        claim HV1: V :e space_family_topology Xi 1.
	        { rewrite HXtop1. exact HV. }
	        set C0 := product_cylinder I Xi 0 U.
	        set C1 := product_cylinder I Xi 1 V.
	        claim HX1def: X1 = product_space I Xi.
	        { reflexivity. }
	        claim HC0inS: C0 :e product_subbasis_full I Xi.
	        { claim HRepl: C0 :e {product_cylinder I Xi 0 U0|U0 :e space_family_topology Xi 0}.
	          { exact (ReplI (space_family_topology Xi 0) (fun U0:set => product_cylinder I Xi 0 U0) U HU0). }
	          exact (famunionI I (fun i0:set => {product_cylinder I Xi i0 U0|U0 :e space_family_topology Xi i0}) 0 C0 In_0_2 HRepl). }
	        claim HC1inS: C1 :e product_subbasis_full I Xi.
	        { claim HRepl: C1 :e {product_cylinder I Xi 1 U0|U0 :e space_family_topology Xi 1}.
	          { exact (ReplI (space_family_topology Xi 1) (fun U0:set => product_cylinder I Xi 1 U0) V HV1). }
	          exact (famunionI I (fun i0:set => {product_cylinder I Xi i0 U0|U0 :e space_family_topology Xi i0}) 1 C1 In_1_2 HRepl). }
	        claim HC0open: C0 :e T1.
	        { exact (generated_topology_from_subbasis_contains_subbasis_elem X1 (product_subbasis_full I Xi) C0 HSsub HC0inS). }
	        claim HC1open: C1 :e T1.
	        { exact (generated_topology_from_subbasis_contains_subbasis_elem X1 (product_subbasis_full I Xi) C1 HSsub HC1inS). }
	        claim HT1: topology_on X1 T1.
	        { exact (topology_from_subbasis_is_topology X1 (product_subbasis_full I Xi) HSsub). }
		        claim HinterOpen: C0 :/\: C1 :e T1.
		        { exact (topology_binintersect_closed X1 T1 C0 C1 HT1 HC0open HC1open). }
			        claim HpreEq: preimage_of X1 fun_pair b = C0 :/\: C1.
			        { rewrite Hbeq.
			          apply set_ext.
			          - let h. assume Hh: h :e preimage_of X1 fun_pair (rectangle_set U V).
			            prove h :e C0 :/\: C1.
			            claim HhX1: h :e X1.
			            { exact (SepE1 X1 (fun x0:set => apply_fun fun_pair x0 :e rectangle_set U V) h Hh). }
			            claim Himg: apply_fun fun_pair h :e rectangle_set U V.
			            { exact (SepE2 X1 (fun x0:set => apply_fun fun_pair x0 :e rectangle_set U V) h Hh). }
			            claim HimgUV: apply_fun fun_pair h :e setprod U V.
			            { rewrite <- rectangle_set_def.
			              exact Himg. }
			            claim H0U0: (apply_fun fun_pair h) 0 :e U.
			            { exact (ap0_Sigma U (fun _ : set => V) (apply_fun fun_pair h) HimgUV). }
			            claim H1V0: (apply_fun fun_pair h) 1 :e V.
			            { exact (ap1_Sigma U (fun _ : set => V) (apply_fun fun_pair h) HimgUV). }
			            claim HimgEq: apply_fun fun_pair h = (apply_fun h 0, apply_fun h 1).
			            { rewrite (apply_fun_graph X1 (fun h0:set => (apply_fun h0 0, apply_fun h0 1)) h HhX1).
			              reflexivity. }
			            claim H0eq: (apply_fun fun_pair h) 0 = apply_fun h 0.
			            { rewrite HimgEq.
			              rewrite <- (tuple_pair (apply_fun h 0) (apply_fun h 1)) at 1.
			              rewrite (pair_ap_0 (apply_fun h 0) (apply_fun h 1)).
			              reflexivity. }
			            claim H1eq: (apply_fun fun_pair h) 1 = apply_fun h 1.
			            { rewrite HimgEq.
			              rewrite <- (tuple_pair (apply_fun h 0) (apply_fun h 1)) at 1.
			              rewrite (pair_ap_1 (apply_fun h 0) (apply_fun h 1)).
			              reflexivity. }
			            claim H0U: apply_fun h 0 :e U.
			            { rewrite <- H0eq.
			              exact H0U0. }
			            claim H1V: apply_fun h 1 :e V.
			            { rewrite <- H1eq.
			              exact H1V0. }
			            claim Hc0: h :e C0.
			            { claim Hpred: 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun h 0 :e U.
			              { apply andI.
			                - apply andI.
			                  + exact In_0_2.
			                  + exact HU0.
			                - exact H0U. }
			              exact (SepI (product_space I Xi)
			                          (fun f0:set => 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun f0 0 :e U)
			                          h HhX1 Hpred). }
			            claim Hc1: h :e C1.
			            { claim Hpred: 1 :e I /\ V :e space_family_topology Xi 1 /\ apply_fun h 1 :e V.
			              { apply andI.
			                - apply andI.
			                  + exact In_1_2.
			                  + exact HV1.
			                - exact H1V. }
			              exact (SepI (product_space I Xi)
			                          (fun f0:set => 1 :e I /\ V :e space_family_topology Xi 1 /\ apply_fun f0 1 :e V)
			                          h HhX1 Hpred). }
			            exact (binintersectI C0 C1 h Hc0 Hc1).
			          - let h. assume Hh: h :e C0 :/\: C1.
			            prove h :e preimage_of X1 fun_pair (rectangle_set U V).
			            claim HhC0: h :e C0.
			            { exact (binintersectE1 C0 C1 h Hh). }
			            claim HhC1: h :e C1.
			            { exact (binintersectE2 C0 C1 h Hh). }
			            claim HhX1: h :e X1.
			            { exact (SepE1 (product_space I Xi)
			                           (fun f0:set => 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun f0 0 :e U)
			                           h HhC0). }
			            claim Hc0pred:
			              0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun h 0 :e U.
			            { exact (SepE2 (product_space I Xi)
			                           (fun f0:set => 0 :e I /\ U :e space_family_topology Xi 0 /\ apply_fun f0 0 :e U)
			                           h HhC0). }
			            claim Hc1pred:
			              1 :e I /\ V :e space_family_topology Xi 1 /\ apply_fun h 1 :e V.
			            { exact (SepE2 (product_space I Xi)
			                           (fun f0:set => 1 :e I /\ V :e space_family_topology Xi 1 /\ apply_fun f0 1 :e V)
			                           h HhC1). }
			            claim Hh0U: apply_fun h 0 :e U.
			            { exact (andER (0 :e I /\ U :e space_family_topology Xi 0) (apply_fun h 0 :e U) Hc0pred). }
			            claim Hh1V: apply_fun h 1 :e V.
			            { exact (andER (1 :e I /\ V :e space_family_topology Xi 1) (apply_fun h 1 :e V) Hc1pred). }
			            claim HimgEq: apply_fun fun_pair h = (apply_fun h 0, apply_fun h 1).
			            { rewrite (apply_fun_graph X1 (fun h0:set => (apply_fun h0 0, apply_fun h0 1)) h HhX1).
			              reflexivity. }
			            claim Hrect: (apply_fun h 0, apply_fun h 1) :e rectangle_set U V.
			            { exact (tuple_2_rectangle_set U V (apply_fun h 0) (apply_fun h 1) Hh0U Hh1V). }
			            claim Himg: apply_fun fun_pair h :e rectangle_set U V.
			            { rewrite HimgEq.
			              exact Hrect. }
			            exact (SepI X1 (fun x0:set => apply_fun fun_pair x0 :e rectangle_set U V) h HhX1 Himg). }
		        rewrite HpreEq.
		        exact HinterOpen. }
		      claim HT0eq: T0 = generated_topology X0 B0.
		      { reflexivity. }
			      rewrite HT0eq.
				      exact (continuous_map_to_generated_topology X1 T1 X0 B0 fun_pair
					                (topology_from_subbasis_is_topology X1 (product_subbasis_full I Xi) HSsub)
					                HB0 Hfun_fun_pair HpreB0).
		      - let x. assume Hx: x :e X0.
		        prove apply_fun fun_pair (apply_fun pair_fun x) = x.
		        (** show apply_fun pair_fun x :e X1 to use apply_fun_graph for fun_pair **)
		        claim HpxX1: apply_fun pair_fun x :e X1.
		        { rewrite (apply_fun_graph X0 (fun p:set => graph I (fun i0:set => If_i (i0 = 0) (p 0) (p 1))) x Hx).
		          set h := (fun i0:set => If_i (i0 = 0) (x 0) (x 1)).
		          claim Hhdef: h = (fun i0:set => If_i (i0 = 0) (x 0) (x 1)).
		          { reflexivity. }
		          rewrite <- Hhdef.
		          set gp := graph I h.
		          claim Hgpdef: gp = graph I h.
		          { reflexivity. }
		          rewrite <- Hgpdef.
		          (** gp is an element of product_space I Xi **)
		          claim Hx0X: x 0 :e X.
		          { exact (ap0_Sigma X (fun _ : set => Y) x Hx). }
		          claim Hx1Y: x 1 :e Y.
		          { exact (ap1_Sigma X (fun _ : set => Y) x Hx). }
		          claim Hhj_union: forall j:set, j :e I -> h j :e space_family_union I Xi.
		          { let j. assume HjI: j :e I.
		            claim Hhj_eq: h j = If_i (j = 0) (x 0) (x 1).
		            { reflexivity. }
		            claim Hj01: j :e {0,1}.
		            { exact (Subq_2_UPair01 j HjI). }
		            apply (UPairE j 0 1 Hj01 (h j :e space_family_union I Xi)).
		            - assume Hj0: j = 0.
		              rewrite Hhj_eq.
		              rewrite Hj0.
		              claim H00: 0 = 0.
		              { reflexivity. }
		              rewrite (If_i_1 (0 = 0) (x 0) (x 1) H00).
		              claim Hx0sf: x 0 :e space_family_set Xi 0.
		              { rewrite HXset0. exact Hx0X. }
		              exact (UnionI {space_family_set Xi i0|i0 :e I} (x 0) (space_family_set Xi 0) Hx0sf
		                       (ReplI I (fun i0:set => space_family_set Xi i0) 0 In_0_2)).
		            - assume Hj1: j = 1.
		              rewrite Hhj_eq.
		              rewrite Hj1.
		              claim H10: ~(1 = 0).
		              { exact neq_1_0. }
		              rewrite (If_i_0 (1 = 0) (x 0) (x 1) H10).
		              claim Hx1sf: x 1 :e space_family_set Xi 1.
		              { rewrite HXset1. exact Hx1Y. }
		              exact (UnionI {space_family_set Xi i0|i0 :e I} (x 1) (space_family_set Xi 1) Hx1sf
		                       (ReplI I (fun i0:set => space_family_set Xi i0) 1 In_1_2)). }
		          claim Hgp_sub: gp c= setprod I (space_family_union I Xi).
		          { let z. assume Hz: z :e gp.
		            apply (ReplE_impred I (fun j0:set => (j0, h j0)) z Hz (z :e setprod I (space_family_union I Xi))).
		            let j. assume HjI: j :e I.
		            assume HzEq: z = (j, h j).
		            rewrite HzEq.
		            exact (tuple_2_setprod_by_pair_Sigma I (space_family_union I Xi) j (h j) HjI (Hhj_union j HjI)). }
		          claim Hgp_pow: gp :e Power (setprod I (space_family_union I Xi)).
		          { exact (PowerI (setprod I (space_family_union I Xi)) gp Hgp_sub). }
		          claim Hgp_tot: total_function_on gp I (space_family_union I Xi).
		          { apply (total_function_on_graph I (space_family_union I Xi) h).
		            exact Hhj_union. }
		          claim Hgp_fun: functional_graph gp.
		          { exact (functional_graph_graph I h). }
		          claim Hcoords: forall j:set, j :e I -> apply_fun gp j :e space_family_set Xi j.
		          { let j. assume HjI: j :e I.
		            rewrite (apply_fun_graph I h j HjI).
		            claim Hhj_eq: h j = If_i (j = 0) (x 0) (x 1).
		            { reflexivity. }
		            claim Hj01: j :e {0,1}.
		            { exact (Subq_2_UPair01 j HjI). }
		            apply (UPairE j 0 1 Hj01 (h j :e space_family_set Xi j)).
		            - assume Hj0: j = 0.
		              rewrite Hhj_eq.
		              rewrite Hj0.
		              claim H00: 0 = 0.
		              { reflexivity. }
		              rewrite (If_i_1 (0 = 0) (x 0) (x 1) H00).
		              rewrite HXset0.
		              exact Hx0X.
		            - assume Hj1: j = 1.
		              rewrite Hhj_eq.
		              rewrite Hj1.
		              claim H10: ~(1 = 0).
		              { exact neq_1_0. }
		              rewrite (If_i_0 (1 = 0) (x 0) (x 1) H10).
		              rewrite HXset1.
		              exact Hx1Y. }
		          claim Hpred:
		            total_function_on gp I (space_family_union I Xi) /\ functional_graph gp /\
		              forall j:set, j :e I -> apply_fun gp j :e space_family_set Xi j.
		          { apply andI.
		            - apply andI.
		              + exact Hgp_tot.
		              + exact Hgp_fun.
		            - exact Hcoords. }
		          exact (SepI (Power (setprod I (space_family_union I Xi)))
		                      (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
		                        forall j:set, j :e I -> apply_fun f0 j :e space_family_set Xi j)
		                      gp Hgp_pow Hpred). }
		        claim HimgEq: apply_fun fun_pair (apply_fun pair_fun x) =
		          (apply_fun (apply_fun pair_fun x) 0, apply_fun (apply_fun pair_fun x) 1).
		        { rewrite (apply_fun_graph X1 (fun h0:set => (apply_fun h0 0, apply_fun h0 1)) (apply_fun pair_fun x) HpxX1).
		          reflexivity. }
		        rewrite HimgEq.
		        claim Hcoord0: apply_fun (apply_fun pair_fun x) 0 = x 0.
		        { rewrite (apply_fun_graph X0 (fun p:set => graph I (fun i0:set => If_i (i0 = 0) (p 0) (p 1))) x Hx).
		          rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (x 0) (x 1)) 0 In_0_2).
		          claim H00: 0 = 0.
		          { reflexivity. }
		          rewrite (If_i_1 (0 = 0) (x 0) (x 1) H00).
		          reflexivity. }
		        claim Hcoord1: apply_fun (apply_fun pair_fun x) 1 = x 1.
		        { rewrite (apply_fun_graph X0 (fun p:set => graph I (fun i0:set => If_i (i0 = 0) (p 0) (p 1))) x Hx).
		          rewrite (apply_fun_graph I (fun i0:set => If_i (i0 = 0) (x 0) (x 1)) 1 In_1_2).
		          claim H10: ~(1 = 0).
		          { exact neq_1_0. }
		          rewrite (If_i_0 (1 = 0) (x 0) (x 1) H10).
		          reflexivity. }
		        rewrite Hcoord0.
		        rewrite Hcoord1.
		        claim HxEta: x = (x 0, x 1).
		        { exact (setprod_eta X Y x Hx). }
		        rewrite <- HxEta.
		        reflexivity.
		    + let y. assume Hy: y :e X1.
		      prove apply_fun pair_fun (apply_fun fun_pair y) = y.
		      set p := apply_fun fun_pair y.
		      claim HpEq: p = (apply_fun y 0, apply_fun y 1).
		      { rewrite (apply_fun_graph X1 (fun h0:set => (apply_fun h0 0, apply_fun h0 1)) y Hy).
		        reflexivity. }
		      (** show p :e X0 **)
		      claim Hycoords: forall i0:set, i0 :e I -> apply_fun y i0 :e space_family_set Xi i0.
		      { exact (andER (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
		                     (forall i0:set, i0 :e I -> apply_fun y i0 :e space_family_set Xi i0)
		                     (SepE2 (Power (setprod I (space_family_union I Xi)))
		                            (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
		                              forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
		                            y Hy)). }
		      claim Hy0X: apply_fun y 0 :e X.
		      { rewrite <- HXset0.
		        exact (Hycoords 0 In_0_2). }
		      claim Hy1Y: apply_fun y 1 :e Y.
		      { rewrite <- HXset1.
		        exact (Hycoords 1 In_1_2). }
		      claim HpX0: p :e X0.
		      { rewrite HpEq.
		        exact (tuple_2_setprod_by_pair_Sigma X Y (apply_fun y 0) (apply_fun y 1) Hy0X Hy1Y). }
		      (** expand pair_fun on p and reduce to a graph equality **)
		      rewrite (apply_fun_graph X0 (fun q:set => graph I (fun i0:set => If_i (i0 = 0) (q 0) (q 1))) p HpX0).
		      (** rewrite p 0 and p 1 using HpEq **)
		      claim Hp0eq: p 0 = apply_fun y 0.
		      { rewrite HpEq.
		        rewrite <- (tuple_pair (apply_fun y 0) (apply_fun y 1)) at 1.
		        rewrite (pair_ap_0 (apply_fun y 0) (apply_fun y 1)).
		        reflexivity. }
		      claim Hp1eq: p 1 = apply_fun y 1.
		      { rewrite HpEq.
		        rewrite <- (tuple_pair (apply_fun y 0) (apply_fun y 1)) at 1.
		        rewrite (pair_ap_1 (apply_fun y 0) (apply_fun y 1)).
		        reflexivity. }
		      rewrite Hp0eq.
		      rewrite Hp1eq.
		      set h := (fun i0:set => If_i (i0 = 0) (apply_fun y 0) (apply_fun y 1)).
		      claim Hhdef: h = (fun i0:set => If_i (i0 = 0) (apply_fun y 0) (apply_fun y 1)).
		      { reflexivity. }
		      rewrite <- Hhdef.
		      (** show graph I h = y by extensionality, using y :e product_space I Xi **)
		      apply set_ext.
		      - let z. assume Hz: z :e graph I h.
		        prove z :e y.
		        apply (ReplE_impred I (fun j0:set => (j0, h j0)) z Hz (z :e y)).
		        let j. assume HjI: j :e I.
		        assume HzEq: z = (j, h j).
		        rewrite HzEq.
		        claim Htoty: total_function_on y I (space_family_union I Xi).
		        { exact (andEL (total_function_on y I (space_family_union I Xi))
		                       (functional_graph y)
		                       (andEL (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
		                              (forall i0:set, i0 :e I -> apply_fun y i0 :e space_family_set Xi i0)
		                              (SepE2 (Power (setprod I (space_family_union I Xi)))
		                                     (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
		                                       forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
		                                     y Hy))). }
		        claim Hyj: (j, apply_fun y j) :e y.
		        { exact (total_function_on_apply_fun_in_graph y I (space_family_union I Xi) j Htoty HjI). }
		        claim Heqyj: apply_fun y j = h j.
		        { claim Hj01: j :e {0,1}.
		          { exact (Subq_2_UPair01 j HjI). }
			          apply (UPairE j 0 1 Hj01 (apply_fun y j = h j)).
			          - assume Hj0: j = 0.
			            rewrite Hj0.
			            claim Hh0eq: h 0 = If_i (0 = 0) (apply_fun y 0) (apply_fun y 1).
			            { reflexivity. }
			            rewrite Hh0eq.
			            claim H00: 0 = 0.
			            { reflexivity. }
			            rewrite (If_i_1 (0 = 0) (apply_fun y 0) (apply_fun y 1) H00).
			            reflexivity.
			          - assume Hj1: j = 1.
			            rewrite Hj1.
			            claim Hh1eq: h 1 = If_i (1 = 0) (apply_fun y 0) (apply_fun y 1).
			            { reflexivity. }
			            rewrite Hh1eq.
			            claim H10: ~(1 = 0).
			            { exact neq_1_0. }
			            rewrite (If_i_0 (1 = 0) (apply_fun y 0) (apply_fun y 1) H10).
			            reflexivity. }
		        rewrite <- Heqyj.
		        exact Hyj.
		      - let z. assume Hz: z :e y.
		        prove z :e graph I h.
		        (** z is in setprod I (space_family_union I Xi) since y is in Power of it **)
		        claim HyPow: y :e Power (setprod I (space_family_union I Xi)).
		        { exact (SepE1 (Power (setprod I (space_family_union I Xi)))
		                       (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
		                         forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
		                       y Hy). }
		        claim HzUV: z :e setprod I (space_family_union I Xi).
		        { exact (PowerE (setprod I (space_family_union I Xi)) y HyPow z Hz). }
		        claim HjI: z 0 :e I.
		        { exact (ap0_Sigma I (fun _ : set => space_family_union I Xi) z HzUV). }
		        claim HzEta: z = (z 0, z 1).
		        { exact (setprod_eta I (space_family_union I Xi) z HzUV). }
			        claim Htoty: total_function_on y I (space_family_union I Xi).
			        { exact (andEL (total_function_on y I (space_family_union I Xi))
			                       (functional_graph y)
			                       (andEL (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
			                              (forall i0:set, i0 :e I -> apply_fun y i0 :e space_family_set Xi i0)
			                              (SepE2 (Power (setprod I (space_family_union I Xi)))
			                                     (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
			                                       forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
			                                     y Hy))). }
			        claim Hfuny: functional_graph y.
			        { exact (andER (total_function_on y I (space_family_union I Xi))
			                       (functional_graph y)
			                       (andEL (total_function_on y I (space_family_union I Xi) /\ functional_graph y)
			                              (forall i0:set, i0 :e I -> apply_fun y i0 :e space_family_set Xi i0)
			                              (SepE2 (Power (setprod I (space_family_union I Xi)))
			                                     (fun f0:set => total_function_on f0 I (space_family_union I Xi) /\ functional_graph f0 /\
			                                       forall i0:set, i0 :e I -> apply_fun f0 i0 :e space_family_set Xi i0)
			                                     y Hy))). }
		        claim Hyj: (z 0, apply_fun y (z 0)) :e y.
		        { exact (total_function_on_apply_fun_in_graph y I (space_family_union I Xi) (z 0) Htoty HjI). }
		        claim HzPair: (z 0, z 1) :e y.
		        { rewrite <- HzEta.
		          exact Hz. }
		        claim Hap: apply_fun y (z 0) = z 1.
		        { exact (functional_graph_apply_fun_eq y (z 0) (z 1) Hfuny HzPair). }
		        claim Heqyj: apply_fun y (z 0) = h (z 0).
		        { claim Hj01: z 0 :e {0,1}.
		          { exact (Subq_2_UPair01 (z 0) HjI). }
			          apply (UPairE (z 0) 0 1 Hj01 (apply_fun y (z 0) = h (z 0))).
			          - assume Hj0: z 0 = 0.
			            rewrite Hj0.
			            claim Hh0eq: h 0 = If_i (0 = 0) (apply_fun y 0) (apply_fun y 1).
			            { reflexivity. }
			            rewrite Hh0eq.
			            claim H00: 0 = 0.
			            { reflexivity. }
			            rewrite (If_i_1 (0 = 0) (apply_fun y 0) (apply_fun y 1) H00).
			            reflexivity.
			          - assume Hj1: z 0 = 1.
			            rewrite Hj1.
			            claim Hh1eq: h 1 = If_i (1 = 0) (apply_fun y 0) (apply_fun y 1).
			            { reflexivity. }
			            rewrite Hh1eq.
			            claim H10: ~(1 = 0).
			            { exact neq_1_0. }
			            rewrite (If_i_0 (1 = 0) (apply_fun y 0) (apply_fun y 1) H10).
			            reflexivity. }
			        rewrite HzEta.
			        claim Hz1eq: z 1 = h (z 0).
			        { prove z 1 = h (z 0).
			          rewrite <- Hap.
			          exact Heqyj. }
			        rewrite Hz1eq.
			        exact (ReplI I (fun j0:set => (j0, h j0)) (z 0) HjI).
			  }

exact (homeomorphism_preserves_completely_regular X0 T0 X1 T1 pair_fun Hhom HcrX1).
Qed.

(** helper for §33 Example 1: Sorgenfrey line is completely regular **)
(** LATEX VERSION: The Sorgenfrey line is completely regular. **)
Theorem Sorgenfrey_line_completely_regular :
  completely_regular_space Sorgenfrey_line Sorgenfrey_topology.
prove completely_regular_space Sorgenfrey_line Sorgenfrey_topology.
set X := Sorgenfrey_line.
set Tx := Sorgenfrey_topology.
claim Hreg: regular_space X Tx.
{ exact Sorgenfrey_line_regular. }
claim HTx: topology_on X Tx.
{ exact (regular_space_topology_on X Tx Hreg). }
claim Hone: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }

prove topology_on X Tx /\
  (one_point_sets_closed X Tx /\
   forall x:set, x :e X ->
     forall F:set, closed_in X Tx F -> x /:e F ->
       exists f:set,
         continuous_map X Tx R R_standard_topology f /\
         apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1).
apply andI.
- exact HTx.
- apply andI.
  + exact Hone.
  + let x. assume HxX: x :e X.
    let F. assume HFcl: closed_in X Tx F.
    assume HxnotF: x /:e F.
    prove exists f:set,
      continuous_map X Tx R R_standard_topology f /\
      apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
    claim HFsubX: F c= X.
    { exact (closed_in_subset X Tx F HFcl). }

    set U0 := X :\: F.
    claim HU0def: U0 = X :\: F.
    { reflexivity. }
    claim HU0open_in: open_in X Tx U0.
    { rewrite HU0def.
      exact (open_of_closed_complement X Tx F HFcl). }
    claim HU0open: U0 :e Tx.
    { exact (open_in_elem X Tx U0 HU0open_in). }
    claim HxU0: x :e U0.
    { rewrite HU0def.
      exact (setminusI X F x HxX HxnotF). }

    (** choose a basis neighborhood b with x in b and b subset U0 **)
    claim Hexb: exists b :e R_lower_limit_basis, x :e b /\ b c= U0.
    { exact (generated_topology_local_refine R R_lower_limit_basis U0 x HU0open HxU0). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbB: b :e R_lower_limit_basis.
    { exact (andEL (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair). }
    claim Hxb: x :e b.
    { exact (andEL (x :e b) (b c= U0) (andER (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair)). }
    claim HbSubU0: b c= U0.
    { exact (andER (x :e b) (b c= U0) (andER (b :e R_lower_limit_basis) (x :e b /\ b c= U0) Hbpair)). }
    claim Hbopen: b :e Tx.
    { exact (generated_topology_contains_basis R R_lower_limit_basis R_lower_limit_basis_is_basis_local b HbB). }

    (** represent b as a half open interval [a,d) **)
    claim Hexa : exists a :e R, b :e {halfopen_interval_left a d|d :e R}.
    { exact (famunionE R (fun a0:set => {halfopen_interval_left a0 d|d :e R}) b HbB). }
    apply Hexa.
    let a. assume Hapair.
    claim HaR : a :e R.
    { exact (andEL (a :e R) (b :e {halfopen_interval_left a d|d :e R}) Hapair). }
    claim HbFam : b :e {halfopen_interval_left a d|d :e R}.
    { exact (andER (a :e R) (b :e {halfopen_interval_left a d|d :e R}) Hapair). }
    claim Hexd : exists d :e R, b = halfopen_interval_left a d.
    { exact (ReplE R (fun d0 : set => halfopen_interval_left a d0) b HbFam). }
    apply Hexd.
    let d. assume Hdpair.
    claim HdR : d :e R.
    { exact (andEL (d :e R) (b = halfopen_interval_left a d) Hdpair). }
    claim Hbeq : b = halfopen_interval_left a d.
    { exact (andER (d :e R) (b = halfopen_interval_left a d) Hdpair). }

    set A := b.
    set B := X :\: b.
    claim HAdef: A = b.
    { reflexivity. }
    claim HBdef: B = X :\: b.
    { reflexivity. }

    claim HbSubX: b c= X.
    { exact (topology_elem_subset X Tx b HTx Hbopen). }
    claim HAbSubX: A c= X.
    { rewrite HAdef.
      exact HbSubX. }
    claim HBsubX: B c= X.
    { rewrite HBdef.
      exact (setminus_Subq X b). }

    claim HAopen: A :e Tx.
    { rewrite HAdef.
      exact Hbopen. }
    claim HBopen: B :e Tx.
    { rewrite HBdef.
      rewrite Hbeq.
      exact (complement_halfopen_interval_left_in_R_lower_limit_topology a d HaR HdR). }

    claim HclA: closed_in X Tx A.
    { apply (closed_inI X Tx A).
      - exact HTx.
      - exact HAbSubX.
      - witness B.
        apply andI.
        + exact HBopen.
        + rewrite HAdef.
          rewrite HBdef.
          rewrite (setminus_setminus_eq X b HbSubX).
          reflexivity. }

    claim HclB: closed_in X Tx B.
    { apply (closed_inI X Tx B).
      - exact HTx.
      - exact HBsubX.
      - witness A.
        apply andI.
        + exact HAopen.
        + rewrite HBdef.
          rewrite HAdef.
          reflexivity. }

    claim HABeq: A :\/: B = X.
    { apply set_ext.
      - let z. assume Hz: z :e A :\/: B.
        apply (binunionE A B z Hz).
        + assume HzA: z :e A.
          exact (HAbSubX z HzA).
        + assume HzB: z :e B.
          claim HzB': z :e X :\: b.
          { rewrite <- HBdef.
            exact HzB. }
          exact (setminusE1 X b z HzB').
      - let z. assume HzX: z :e X.
        apply (xm (z :e A)).
        + assume HzA: z :e A.
          exact (binunionI1 A B z HzA).
        + assume HznotA: z /:e A.
          claim Hznotb: z /:e b.
          { rewrite <- HAdef.
            exact HznotA. }
          claim HzB: z :e B.
          { rewrite HBdef.
            exact (setminusI X b z HzX Hznotb). }
          exact (binunionI2 A B z HzB). }

    set f0 := const_fun A 0.
    set g1 := const_fun B 1.
    claim HRtop: topology_on R R_standard_topology.
    { exact R_standard_topology_is_topology. }
    claim H0R: 0 :e R.
    { exact real_0. }
    claim H1R: 1 :e R.
    { exact real_1. }
    claim HTA: topology_on A (subspace_topology X Tx A).
    { exact (subspace_topology_is_topology X Tx A HTx HAbSubX). }
    claim HTB: topology_on B (subspace_topology X Tx B).
    { exact (subspace_topology_is_topology X Tx B HTx HBsubX). }
    claim Hf0: continuous_map A (subspace_topology X Tx A) R R_standard_topology f0.
    { exact (const_fun_continuous A (subspace_topology X Tx A) R R_standard_topology 0 HTA HRtop H0R). }
    claim Hg1: continuous_map B (subspace_topology X Tx B) R R_standard_topology g1.
    { exact (const_fun_continuous B (subspace_topology X Tx B) R R_standard_topology 1 HTB HRtop H1R). }
    claim Hagree: forall z:set, z :e (A :/\: B) -> apply_fun f0 z = apply_fun g1 z.
    { let z. assume Hz: z :e (A :/\: B).
      prove apply_fun f0 z = apply_fun g1 z.
      apply FalseE.
      prove False.
      claim HzA: z :e A.
      { exact (binintersectE1 A B z Hz). }
      claim HzB: z :e B.
      { exact (binintersectE2 A B z Hz). }
      claim Hzb: z :e b.
      { rewrite <- HAdef.
        exact HzA. }
      claim HzB': z :e X :\: b.
      { rewrite <- HBdef.
        exact HzB. }
      claim Hznotb: z /:e b.
      { exact (setminusE2 X b z HzB'). }
      exact (Hznotb Hzb). }

    apply (pasting_lemma X A B R Tx R_standard_topology f0 g1 HTx HclA HclB HABeq Hf0 Hg1 Hagree).
    let h. assume Hhpack.
    witness h.
    prove continuous_map X Tx R R_standard_topology h /\ apply_fun h x = 0 /\
      forall y:set, y :e F -> apply_fun h y = 1.
    apply andI.
    - (** continuous_map h /\ apply_fun h x = 0 **)
      apply andI.
      + exact (andEL (continuous_map X Tx R R_standard_topology h)
                     ((forall z:set, z :e A -> apply_fun h z = apply_fun f0 z) /\
                      (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z))
                     Hhpack).
      + (** apply_fun h x = 0 using x in A **)
        claim Hrest:
          (forall z:set, z :e A -> apply_fun h z = apply_fun f0 z) /\
          (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z).
        { exact (andER (continuous_map X Tx R R_standard_topology h)
                       ((forall z:set, z :e A -> apply_fun h z = apply_fun f0 z) /\
                        (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z))
                       Hhpack). }
        claim HhA: forall z:set, z :e A -> apply_fun h z = apply_fun f0 z.
        { exact (andEL (forall z:set, z :e A -> apply_fun h z = apply_fun f0 z)
                       (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z)
                       Hrest). }
        claim HxA: x :e A.
        { rewrite HAdef.
          exact Hxb. }
        claim Hhx: apply_fun h x = apply_fun f0 x.
        { exact (HhA x HxA). }
        rewrite Hhx.
        exact (const_fun_apply A 0 x HxA).
    - let y. assume HyF: y :e F.
      prove apply_fun h y = 1.
      claim Hrest:
        (forall z:set, z :e A -> apply_fun h z = apply_fun f0 z) /\
        (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z).
      { exact (andER (continuous_map X Tx R R_standard_topology h)
                     ((forall z:set, z :e A -> apply_fun h z = apply_fun f0 z) /\
                      (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z))
                     Hhpack). }
      claim HhB: forall z:set, z :e B -> apply_fun h z = apply_fun g1 z.
      { exact (andER (forall z:set, z :e A -> apply_fun h z = apply_fun f0 z)
                     (forall z:set, z :e B -> apply_fun h z = apply_fun g1 z)
                     Hrest). }
      claim HyX: y :e X.
      { exact (HFsubX y HyF). }
      claim HynA: y /:e A.
      { assume HyA: y :e A.
        claim Hyb: y :e b.
        { rewrite <- HAdef.
          exact HyA. }
        claim HyU0: y :e U0.
        { exact (HbSubU0 y Hyb). }
        claim HynF: y /:e F.
        { exact (setminusE2 X F y HyU0). }
        apply FalseE.
        prove False.
        exact (HynF HyF). }
      claim HyB: y :e B.
      { rewrite HBdef.
        exact (setminusI X b y HyX HynA). }
      claim Hhy: apply_fun h y = apply_fun g1 y.
      { exact (HhB y HyB). }
      rewrite Hhy.
      exact (const_fun_apply B 1 y HyB).
Qed.

(** from §33 Example 1: products giving completely regular but not normal spaces **) 
(** LATEX VERSION: Sorgenfrey plane is completely regular but not normal. **)
Theorem Sorgenfrey_plane_completely_regular_not_normal :
  completely_regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology /\
  ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove completely_regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology /\
  ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
apply andI.
- claim HcrS: completely_regular_space Sorgenfrey_line Sorgenfrey_topology.
  { exact Sorgenfrey_line_completely_regular. }
  exact (completely_regular_product_topology Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HcrS HcrS).
- claim Hnot: ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
  { exact (andER (regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology)
                 (~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology)
                 (Sorgenfrey_plane_not_normal)). }
  exact Hnot.
Qed.

(** from §33 Example 1 cont.: SOmega x SbarOmega completely regular not normal **)
(** LATEX VERSION: Another example of completely regular but non-normal product. **)
(** FIXED: Use product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology on S_Omega × Sbar_Omega (not a mismatched topology on a function space). **) 
Theorem SOmega_SbarOmega_completely_regular_not_normal :
  completely_regular_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology) /\
  ~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology).
prove completely_regular_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology) /\
  ~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology).
apply andI.
- claim HnormS: normal_space S_Omega SOmega_topology /\ normal_space Sbar_Omega SbarOmega_topology.
  { exact (andEL (normal_space S_Omega SOmega_topology /\ normal_space Sbar_Omega SbarOmega_topology)
                 (~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology))
                 (SOmega_SbarOmega_not_normal)). }
  claim Hnorm1: normal_space S_Omega SOmega_topology.
  { exact (andEL (normal_space S_Omega SOmega_topology) (normal_space Sbar_Omega SbarOmega_topology) HnormS). }
  claim Hnorm2: normal_space Sbar_Omega SbarOmega_topology.
  { exact (andER (normal_space S_Omega SOmega_topology) (normal_space Sbar_Omega SbarOmega_topology) HnormS). }
  claim Hcr1: completely_regular_space S_Omega SOmega_topology.
  { exact (normal_space_implies_completely_regular S_Omega SOmega_topology Hnorm1). }
  claim Hcr2: completely_regular_space Sbar_Omega SbarOmega_topology.
  { exact (normal_space_implies_completely_regular Sbar_Omega SbarOmega_topology Hnorm2). }
  exact (completely_regular_product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology Hcr1 Hcr2).
- claim Hnot:
    ~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology).
  { exact (andER (normal_space S_Omega SOmega_topology /\ normal_space Sbar_Omega SbarOmega_topology)
                 (~ normal_space (setprod S_Omega Sbar_Omega) (product_topology S_Omega SOmega_topology Sbar_Omega SbarOmega_topology))
                 (SOmega_SbarOmega_not_normal)). }
  exact Hnot.
Qed.

(** from §34 Theorem 34.1: Urysohn metrization theorem **) 
(** LATEX VERSION: Regular second-countable spaces are metrizable (Urysohn). **)
Theorem Urysohn_metrization_theorem : forall X Tx:set,
  regular_space X Tx -> second_countable_space X Tx -> exists d:set, metric_on X d /\ metric_topology X d = Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume Hscc: second_countable_space X Tx.
prove exists d:set, metric_on X d /\ metric_topology X d = Tx.
(** Roadmap (topology.tex §34.1): build a countable separating family of continuous functions, embed into R^omega, then pull back the Romega metric. **)
claim HTx: topology_on X Tx.
{ exact (regular_space_topology_on X Tx Hreg). }
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
claim Hnorm: normal_space X Tx.
{ exact (regular_countable_basis_normal X Tx Hreg Hscc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
apply HexB.
let B.
assume HBpack: basis_on X B /\ countable_set B /\ basis_generates X B Tx.
	set J := omega.
	claim HexSep: exists F:set, separating_family_of_functions X Tx F J.
	{ (** TeX idea: use the countable basis B to build a countable family of Urysohn bump functions indexed by omega. **)
	  claim HBpair: basis_on X B /\ countable_set B.
	  { exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBpack). }
	  claim HB: basis_on X B.
	  { exact (andEL (basis_on X B) (countable_set B) HBpair). }
	  claim HBcount: countable_set B.
	  { exact (andER (basis_on X B) (countable_set B) HBpair). }
	  claim HBgen: basis_generates X B Tx.
	  { exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBpack). }
	  set P := {p :e (B :*: B) | closure_of X Tx (proj0 p) c= proj1 p}.
	  claim HPsub: P c= (B :*: B).
	  { let p. assume HpP: p :e P.
	    exact (SepE1 (B :*: B) (fun p0:set => closure_of X Tx (proj0 p0) c= proj1 p0) p HpP). }
	  claim HBBcount: countable_set (B :*: B).
	  { exact (setprod_countable B B HBcount HBcount). }
	  claim HPcount: countable_set P.
	  { exact (atleastp_tra P (B :*: B) omega (Subq_atleastp P (B :*: B) HPsub) HBBcount). }
	  apply HPcount.
	  let enc. assume Henc: inj P omega enc.
		  (** decode indices n by inv P enc n; for n in enc[P], inv P enc n returns the unique p with enc p = n. **)
		  set pair_of := (fun n:set => inv P enc n).
		  (** for each p=(U,V) in P, Urysohn_lemma provides a continuous f:[0,1] with f=1 on closure(U) and f=0 outside V. **)
		  set bump := (fun p:set =>
		    if p :e P then
		      Eps_i (fun f:set =>
		        f :e function_space X R /\
		        continuous_map X Tx R R_standard_topology f /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
		    else const_fun X 0).
		  set F := graph J (fun n:set => bump (pair_of n)).
		  witness F.
		  prove separating_family_of_functions X Tx F J.
		  claim HgenEq: generated_topology X B = Tx.
		  { exact (andER (basis_on X B) (generated_topology X B = Tx) HBgen). }
		  claim HTyR: topology_on R R_standard_topology.
		  { exact R_standard_topology_is_topology. }
		  claim H0R: 0 :e R.
		  { exact real_0. }
		  claim H1R: 1 :e R.
		  { exact real_1. }
		  claim HconstFS: const_fun X 0 :e function_space X R.
		  { set f0 := const_fun X 0.
		    claim Hsub: f0 c= setprod X R.
		    { let q. assume Hq: q :e f0.
		      prove q :e setprod X R.
		      apply (ReplE_impred X (fun a0:set => (a0,0)) q Hq (q :e setprod X R)).
		      let a. assume HaX: a :e X.
		      assume Heq: q = (a,0).
		      rewrite Heq.
		      exact (tuple_2_setprod_by_pair_Sigma X R a 0 HaX H0R). }
		    claim Hpow: f0 :e Power (setprod X R).
		    { exact (PowerI (setprod X R) f0 Hsub). }
		    claim Hfun: function_on f0 X R.
		    { let x. assume HxX: x :e X.
		      prove apply_fun f0 x :e R.
		      claim Happ: apply_fun f0 x = 0.
		      { exact (const_fun_apply X 0 x HxX). }
		      rewrite Happ.
		      exact H0R. }
		    exact (SepI (Power (setprod X R)) (fun f0:set => function_on f0 X R) f0 Hpow Hfun). }
		  claim HconstCont: continuous_map X Tx R R_standard_topology (const_fun X 0).
		  { exact (const_fun_continuous X Tx R R_standard_topology 0 HTx HTyR H0R). }

		  claim Hbump_ex: forall p:set, p :e P ->
		    exists f:set,
		      f :e function_space X R /\
		      continuous_map X Tx R R_standard_topology f /\
		      (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		      (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1).
		  { let p. assume HpP: p :e P.
		    claim HpBB: p :e (B :*: B).
		    { exact (SepE1 (B :*: B) (fun p0:set => closure_of X Tx (proj0 p0) c= proj1 p0) p HpP). }
		    claim HclSub: closure_of X Tx (proj0 p) c= proj1 p.
		    { exact (SepE2 (B :*: B) (fun p0:set => closure_of X Tx (proj0 p0) c= proj1 p0) p HpP). }
		    claim HUinB: proj0 p :e B.
		    { exact (proj0_Sigma B (fun x0:set => B) p HpBB). }
		    claim HVinB: proj1 p :e B.
		    { exact (proj1_Sigma B (fun x0:set => B) p HpBB). }
		    claim HUgen: proj0 p :e generated_topology X B.
		    { exact (basis_in_generated X B (proj0 p) HB HUinB). }
		    claim HVgen: proj1 p :e generated_topology X B.
		    { exact (basis_in_generated X B (proj1 p) HB HVinB). }
		    claim HUtx: proj0 p :e Tx.
		    { rewrite <- HgenEq. exact HUgen. }
		    claim HVtx: proj1 p :e Tx.
		    { rewrite <- HgenEq. exact HVgen. }
		    claim HclClosed: closed_in X Tx (closure_of X Tx (proj0 p)).
		    { exact (andER (closure_of X Tx (closure_of X Tx (proj0 p)) = closure_of X Tx (proj0 p))
		                   (closed_in X Tx (closure_of X Tx (proj0 p)))
		                   (closure_idempotent_and_closed X Tx (proj0 p) HTx)). }
		    claim HcV: closed_in X Tx (X :\: (proj1 p)).
		    { exact (closed_of_open_complement X Tx (proj1 p) HTx HVtx). }
		    claim Hdisj: (X :\: (proj1 p)) :/\: (closure_of X Tx (proj0 p)) = Empty.
		    { apply Empty_Subq_eq.
		      let z. assume Hz: z :e (X :\: (proj1 p)) :/\: (closure_of X Tx (proj0 p)).
		      prove z :e Empty.
		      claim HzOut: z :e X :\: (proj1 p).
		      { exact (binintersectE1 (X :\: (proj1 p)) (closure_of X Tx (proj0 p)) z Hz). }
		      claim HzCl: z :e closure_of X Tx (proj0 p).
		      { exact (binintersectE2 (X :\: (proj1 p)) (closure_of X Tx (proj0 p)) z Hz). }
		      claim HznotV: z /:e proj1 p.
		      { exact (setminusE2 X (proj1 p) z HzOut). }
		      claim HzV: z :e proj1 p.
		      { exact (HclSub z HzCl). }
		      apply FalseE.
		      exact (HznotV HzV). }
		    claim H01: Rle 0 1.
		    { exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
		    claim Hexg:
		      exists g:set,
		        continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun g x0 = 1).
		    { exact (Urysohn_lemma X Tx (X :\: (proj1 p)) (closure_of X Tx (proj0 p)) 0 1
		              H01 Hnorm HcV HclClosed Hdisj). }
		    apply Hexg.
		    let g. assume Hgpack.
		    claim HgAB:
		      continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g /\
		      (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0).
		    { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g /\
		                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0))
		                   (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun g x0 = 1)
		                   Hgpack). }
		    claim Hg1: forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun g x0 = 1.
		    { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g /\
		                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0))
		                   (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun g x0 = 1)
		                   Hgpack). }
		    claim HgcontI: continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g.
		    { exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g)
		                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0)
		                   HgAB). }
		    claim Hg0: forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0.
		    { exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) g)
		                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun g x0 = 0)
		                   HgAB). }
		    claim HgcontR: continuous_map X Tx R R_standard_topology g.
		    { claim HsubI: closed_interval 0 1 c= R.
		      { exact (closed_interval_sub_R 0 1). }
		      claim HTi: closed_interval_topology 0 1 = subspace_topology R R_standard_topology (closed_interval 0 1).
		      { reflexivity. }
		      exact (continuous_map_range_expand X Tx (closed_interval 0 1) (closed_interval_topology 0 1) R R_standard_topology g
		              HgcontI HsubI HTyR HTi). }
		    set h := (fun x0:set => apply_fun g x0).
		    set f := graph X h.
		    witness f.
		    apply andI.
		    - apply andI.
		      + apply andI.
		        * (** f in function_space X R **)
		          claim Hsub: f c= setprod X R.
		          { let q. assume Hq: q :e f.
		            prove q :e setprod X R.
		            apply (ReplE_impred X (fun a0:set => (a0, h a0)) q Hq (q :e setprod X R)).
		            let a. assume HaX: a :e X.
		            assume Heq: q = (a, h a).
		            rewrite Heq.
		            claim HhaR: h a :e R.
		            { claim Hgfun: function_on g X R.
		              { exact (continuous_map_function_on X Tx R R_standard_topology g HgcontR). }
		              exact (Hgfun a HaX). }
		            exact (tuple_2_setprod_by_pair_Sigma X R a (h a) HaX HhaR). }
		          claim Hpow: f :e Power (setprod X R).
		          { exact (PowerI (setprod X R) f Hsub). }
		          claim Hfun: function_on f X R.
		          { let x0. assume Hx0X: x0 :e X.
		            prove apply_fun f x0 :e R.
		            claim Happ: apply_fun f x0 = h x0.
		            { exact (apply_fun_graph X h x0 Hx0X). }
		            rewrite Happ.
		            claim Hgfun: function_on g X R.
		            { exact (continuous_map_function_on X Tx R R_standard_topology g HgcontR). }
		            exact (Hgfun x0 Hx0X). }
		          exact (SepI (Power (setprod X R)) (fun f0:set => function_on f0 X R) f Hpow Hfun).
		        * (** f continuous **)
		          prove continuous_map X Tx R R_standard_topology f.
		          prove topology_on X Tx /\ topology_on R R_standard_topology /\ function_on f X R /\
		            forall V:set, V :e R_standard_topology -> preimage_of X f V :e Tx.
		          apply andI.
		          - apply andI.
		            + apply andI.
		              * exact HTx.
		              * exact HTyR.
		            + let x0. assume Hx0X: x0 :e X.
		              prove apply_fun f x0 :e R.
		              claim Happ: apply_fun f x0 = h x0.
		              { exact (apply_fun_graph X h x0 Hx0X). }
		              rewrite Happ.
		              claim Hgfun: function_on g X R.
		              { exact (continuous_map_function_on X Tx R R_standard_topology g HgcontR). }
		              exact (Hgfun x0 Hx0X).
		          - let V. assume HV: V :e R_standard_topology.
		            claim HpreEq: preimage_of X f V = preimage_of X g V.
		            { apply set_ext.
		              - let x0. assume Hx0: x0 :e preimage_of X f V.
		                prove x0 :e preimage_of X g V.
		                claim Hx0X: x0 :e X.
		                { exact (SepE1 X (fun x1:set => apply_fun f x1 :e V) x0 Hx0). }
		                claim Hfx0: apply_fun f x0 :e V.
		                { exact (SepE2 X (fun x1:set => apply_fun f x1 :e V) x0 Hx0). }
			              claim Happ: apply_fun f x0 = apply_fun g x0.
			                { claim H1: apply_fun f x0 = h x0.
			                  { exact (apply_fun_graph X h x0 Hx0X). }
			                  rewrite H1.
			                  reflexivity. }
			                claim Hgx0V: apply_fun g x0 :e V.
			                { rewrite <- Happ.
			                  exact Hfx0. }
			                exact (SepI X (fun x1:set => apply_fun g x1 :e V) x0 Hx0X Hgx0V).
			              - let x0. assume Hx0: x0 :e preimage_of X g V.
			                prove x0 :e preimage_of X f V.
			                claim Hx0X: x0 :e X.
			                { exact (SepE1 X (fun x1:set => apply_fun g x1 :e V) x0 Hx0). }
		                claim Hgx0: apply_fun g x0 :e V.
		                { exact (SepE2 X (fun x1:set => apply_fun g x1 :e V) x0 Hx0). }
			              claim Happ: apply_fun f x0 = apply_fun g x0.
			                { claim H1: apply_fun f x0 = h x0.
			                  { exact (apply_fun_graph X h x0 Hx0X). }
			                  rewrite H1.
			                  reflexivity. }
			                claim Hfx0V: apply_fun f x0 :e V.
			                { rewrite Happ.
			                  exact Hgx0. }
			                exact (SepI X (fun x1:set => apply_fun f x1 :e V) x0 Hx0X Hfx0V). }
		            rewrite HpreEq.
		            exact (continuous_map_preimage X Tx R R_standard_topology g HgcontR V HV).
		      + let x0. assume Hx0: x0 :e (X :\: (proj1 p)).
		        prove apply_fun f x0 = 0.
		        claim Hx0X: x0 :e X.
		        { exact (setminusE1 X (proj1 p) x0 Hx0). }
		        claim Happ: apply_fun f x0 = h x0.
		        { exact (apply_fun_graph X h x0 Hx0X). }
		        rewrite Happ.
		        exact (Hg0 x0 Hx0).
		    - let x0. assume Hx0: x0 :e closure_of X Tx (proj0 p).
		      prove apply_fun f x0 = 1.
		      claim Hx0X: x0 :e X.
		      { exact (SepE1 X (fun x1:set => forall U:set, U :e Tx -> x1 :e U -> U :/\: (proj0 p) <> Empty) x0 Hx0). }
		      claim Happ: apply_fun f x0 = h x0.
		      { exact (apply_fun_graph X h x0 Hx0X). }
		      rewrite Happ.
		      exact (Hg1 x0 Hx0). }

		  claim Hbump_mem: forall p:set, bump p :e function_space X R.
		  { let p. apply (xm (p :e P)).
		    - assume HpP: p :e P.
		      claim HbDef: bump p = Eps_i (fun f:set =>
		        f :e function_space X R /\
		        continuous_map X Tx R R_standard_topology f /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)).
		      { claim Hb: bump = (fun p0:set =>
		          if p0 :e P then
		            Eps_i (fun f:set =>
		              f :e function_space X R /\
		              continuous_map X Tx R R_standard_topology f /\
		              (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
		              (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
		          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hb.
			        claim Hbeta_bump:
			          (fun p0:set =>
			            if p0 :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
			                (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
			            else const_fun X 0) p =
			          (if p :e P then
			            Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			              (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
			          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hbeta_bump.
			        rewrite (If_i_1 (p :e P)
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
		                          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		                          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)))
		                        (const_fun X 0) HpP).
		        reflexivity. }
		      rewrite HbDef.
		      claim Hex: exists f:set,
		        f :e function_space X R /\
		        continuous_map X Tx R R_standard_topology f /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1).
		      { exact (Hbump_ex p HpP). }
			      claim Hprop:
			        (Eps_i (fun f:set =>
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)))
			        :e function_space X R.
			      { set Ep := (Eps_i (fun f:set =>
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
			        claim HEp: Ep = (Eps_i (fun f:set =>
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
			        { reflexivity. }
			        rewrite <- HEp.
			        claim Htmp:
			          (fun f:set =>
			            f :e function_space X R /\
			            continuous_map X Tx R R_standard_topology f /\
			            (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			            (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)) Ep.
			        { rewrite HEp.
			          exact (Eps_i_ex (fun f:set =>
			            f :e function_space X R /\
			            continuous_map X Tx R R_standard_topology f /\
			            (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			            (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)) Hex). }
			        claim Htmp123:
			          (Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep) /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0).
			        { exact (andEL ((Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep) /\
			                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0))
			                   (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun Ep x0 = 1)
			                   Htmp). }
			        claim Htmp12: Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep.
			        { exact (andEL (Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep)
			                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0)
			                   Htmp123). }
			        exact (andEL (Ep :e function_space X R) (continuous_map X Tx R R_standard_topology Ep) Htmp12). }
			      exact Hprop.
			    - assume HpN: p /:e P.
			      claim HbDef: bump p = const_fun X 0.
			      { claim Hb: bump = (fun p0:set =>
			          if p0 :e P then
			            Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
			              (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
			          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hb.
			        claim Hbeta_bump0:
			          (fun p0:set =>
			            if p0 :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
			                (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
			            else const_fun X 0) p =
			          (if p :e P then
			            Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			              (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
			          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hbeta_bump0.
			        rewrite (If_i_0 (p :e P)
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
		                          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		                          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)))
		                        (const_fun X 0) HpN).
		        reflexivity. }
		      rewrite HbDef.
		      exact HconstFS. }

		  claim Hbump_cont: forall p:set, continuous_map X Tx R R_standard_topology (bump p).
		  { let p. apply (xm (p :e P)).
		    - assume HpP: p :e P.
		      claim HbDef: bump p = Eps_i (fun f:set =>
		        f :e function_space X R /\
		        continuous_map X Tx R R_standard_topology f /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)).
		      { claim Hb: bump = (fun p0:set =>
		          if p0 :e P then
		            Eps_i (fun f:set =>
		              f :e function_space X R /\
		              continuous_map X Tx R R_standard_topology f /\
		              (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
		              (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
		          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hb.
			        claim Hbeta_bump:
			          (fun p0:set =>
			            if p0 :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
			                (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
			            else const_fun X 0) p =
			          (if p :e P then
			            Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			              (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
			          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hbeta_bump.
			        rewrite (If_i_1 (p :e P)
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
		                          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		                          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)))
		                        (const_fun X 0) HpP).
		        reflexivity. }
		      rewrite HbDef.
		      claim Hex: exists f:set,
		        f :e function_space X R /\
		        continuous_map X Tx R R_standard_topology f /\
		        (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		        (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1).
		      { exact (Hbump_ex p HpP). }
		      claim Htmp:
		        (fun f:set =>
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
		        (Eps_i (fun f:set =>
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
		      { exact (Eps_i_ex (fun f:set =>
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)) Hex). }
			      claim Hcont:
			        continuous_map X Tx R R_standard_topology
			          (Eps_i (fun f:set =>
			            f :e function_space X R /\
			            continuous_map X Tx R R_standard_topology f /\
			            (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			            (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
			      { set Ep := (Eps_i (fun f:set =>
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
			        claim HEp: Ep = (Eps_i (fun f:set =>
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))).
			        { reflexivity. }
			        rewrite <- HEp.
			        claim Htmp0:
			          (fun f:set =>
			            f :e function_space X R /\
			            continuous_map X Tx R R_standard_topology f /\
			            (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			            (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)) Ep.
			        { rewrite HEp. exact Htmp. }
			        claim Htmp123:
			          (Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep) /\
			          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0).
			        { exact (andEL ((Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep) /\
			                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0))
			                   (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun Ep x0 = 1)
			                   Htmp0). }
			        claim Htmp12: Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep.
			        { exact (andEL (Ep :e function_space X R /\ continuous_map X Tx R R_standard_topology Ep)
			                   (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun Ep x0 = 0)
			                   Htmp123). }
			        exact (andER (Ep :e function_space X R) (continuous_map X Tx R R_standard_topology Ep) Htmp12). }
			      exact Hcont.
			    - assume HpN: p /:e P.
		      claim HbDef: bump p = const_fun X 0.
		      { claim Hb: bump = (fun p0:set =>
		          if p0 :e P then
		            Eps_i (fun f:set =>
		              f :e function_space X R /\
		              continuous_map X Tx R R_standard_topology f /\
		              (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
		              (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
		          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hb.
			        claim Hbeta_bump0:
			          (fun p0:set =>
			            if p0 :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x0:set, x0 :e (X :\: (proj1 p0)) -> apply_fun f x0 = 0) /\
			                (forall x0:set, x0 :e closure_of X Tx (proj0 p0) -> apply_fun f x0 = 1))
			            else const_fun X 0) p =
			          (if p :e P then
			            Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
			              (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1))
			          else const_fun X 0).
			        { reflexivity. }
			        rewrite Hbeta_bump0.
			        rewrite (If_i_0 (p :e P)
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
		                          (forall x0:set, x0 :e (X :\: (proj1 p)) -> apply_fun f x0 = 0) /\
		                          (forall x0:set, x0 :e closure_of X Tx (proj0 p) -> apply_fun f x0 = 1)))
		                        (const_fun X 0) HpN).
		        reflexivity. }
		      rewrite HbDef.
		      exact HconstCont. }

		  prove (((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
		         (forall j:set, j :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j))) /\
		        (forall x0:set, x0 :e X ->
		          forall U:set, U :e Tx -> x0 :e U ->
		            exists j:set, j :e J /\
		              Rlt 0 (apply_fun (apply_fun F j) x0) /\
		              forall x:set, x :e X :\: U -> apply_fun (apply_fun F j) x = 0)).
		  apply andI.
		  - apply andI.
		    + apply andI.
		      * exact HTx.
		      * (** total_function_on **)
		        claim Hfun: function_on F J (function_space X R).
		        { let n. assume HnJ: n :e J.
		          prove apply_fun F n :e function_space X R.
		          claim HFdef: F = graph J (fun n0:set => bump (pair_of n0)).
		          { reflexivity. }
		          rewrite HFdef.
		          claim Happ: apply_fun (graph J (fun n0:set => bump (pair_of n0))) n = bump (pair_of n).
		          { exact (apply_fun_graph J (fun n0:set => bump (pair_of n0)) n HnJ). }
		          rewrite Happ.
		          exact (Hbump_mem (pair_of n)). }
		        claim Htot': forall n:set, n :e J -> exists y:set, y :e function_space X R /\ (n,y) :e F.
		        { let n. assume HnJ: n :e J.
		          witness (bump (pair_of n)).
		          apply andI.
		          - exact (Hbump_mem (pair_of n)).
		          - claim HFdef: F = graph J (fun n0:set => bump (pair_of n0)).
		            { reflexivity. }
		            rewrite HFdef.
		            exact (ReplI J (fun a0:set => (a0, bump (pair_of a0))) n HnJ). }
		        exact (andI (function_on F J (function_space X R))
		                    (forall x:set, x :e J -> exists y:set, y :e function_space X R /\ (x,y) :e F)
		                    Hfun Htot').
		    + (** continuity of each coordinate **)
		      let n. assume HnJ: n :e J.
			      prove continuous_map X Tx R R_standard_topology (apply_fun F n).
			      claim HFdef: F = graph J (fun n0:set => bump (pair_of n0)).
			      { reflexivity. }
			      rewrite HFdef.
			      claim Happ:
			        apply_fun (graph J (fun n0:set => bump (pair_of n0))) n =
			          (fun n0:set => bump (pair_of n0)) n.
			      { exact (apply_fun_graph J (fun n0:set => bump (pair_of n0)) n HnJ). }
			      rewrite Happ.
			      claim Hbeta: (fun n0:set => bump (pair_of n0)) n = bump (pair_of n).
			      { reflexivity. }
			      rewrite Hbeta.
			      exact (Hbump_cont (pair_of n)).
			  - (** neighborhood separation **)
		    let x0. assume Hx0X: x0 :e X.
		    let U. assume HUtx: U :e Tx.
			    assume Hx0U: x0 :e U.
			    claim HUgen: U :e generated_topology X B.
			    { rewrite HgenEq. exact HUtx. }
				    claim HUloc: forall x:set, x :e U -> exists b:set, b :e B /\ x :e b /\ b c= U.
				    { let x. assume HxU: x :e U.
				      claim Hprop: forall x1 :e U, exists b :e B, x1 :e b /\ b c= U.
				      { exact (SepE2 (Power X) (fun U0:set => forall x1 :e U0, exists b :e B, x1 :e b /\ b c= U0) U HUgen). }
				      apply (Hprop x HxU).
				      let b. assume Hbpack.
				      witness b.
				      apply andI.
				      - apply andI.
				        + exact (andEL (b :e B) (x :e b /\ b c= U) Hbpack).
				        + claim Hbrest: x :e b /\ b c= U.
				          { exact (andER (b :e B) (x :e b /\ b c= U) Hbpack). }
				          exact (andEL (x :e b) (b c= U) Hbrest).
				      - claim Hbrest: x :e b /\ b c= U.
				        { exact (andER (b :e B) (x :e b /\ b c= U) Hbpack). }
				        exact (andER (x :e b) (b c= U) Hbrest). }
			    apply (HUloc x0 Hx0U).
			    let V. assume HVpack.
			    claim HVpack12: V :e B /\ x0 :e V.
			    { exact (andEL (V :e B /\ x0 :e V) (V c= U) HVpack). }
			    claim HVsubU: V c= U.
			    { exact (andER (V :e B /\ x0 :e V) (V c= U) HVpack). }
			    claim HVB: V :e B.
			    { exact (andEL (V :e B) (x0 :e V) HVpack12). }
			    claim Hx0V: x0 :e V.
			    { exact (andER (V :e B) (x0 :e V) HVpack12). }
			    claim HVgen: V :e generated_topology X B.
			    { exact (basis_in_generated X B V HB HVB). }
		    claim HVtx: V :e Tx.
		    { rewrite <- HgenEq. exact HVgen. }
		    claim HexW: exists W:set, W :e Tx /\ x0 :e W /\ closure_of X Tx W c= V.
		    { exact (regular_space_shrink_neighborhood X Tx x0 V Hreg Hx0X HVtx Hx0V). }
			    apply HexW.
			    let W. assume HWpack.
			    claim HWpack12: W :e Tx /\ x0 :e W.
			    { exact (andEL (W :e Tx /\ x0 :e W) (closure_of X Tx W c= V) HWpack). }
			    claim HclWsubV: closure_of X Tx W c= V.
			    { exact (andER (W :e Tx /\ x0 :e W) (closure_of X Tx W c= V) HWpack). }
			    claim HWtx: W :e Tx.
			    { exact (andEL (W :e Tx) (x0 :e W) HWpack12). }
			    claim Hx0W: x0 :e W.
			    { exact (andER (W :e Tx) (x0 :e W) HWpack12). }
			    claim HWgen: W :e generated_topology X B.
			    { rewrite HgenEq. exact HWtx. }
			    claim HWloc: forall x:set, x :e W -> exists b:set, b :e B /\ x :e b /\ b c= W.
		    { let x. assume HxW: x :e W.
		      claim Hprop: forall x1 :e W, exists b :e B, x1 :e b /\ b c= W.
		      { exact (SepE2 (Power X) (fun U0:set => forall x1 :e U0, exists b :e B, x1 :e b /\ b c= U0) W HWgen). }
			      apply (Hprop x HxW).
			      let b. assume Hbpack.
			      witness b.
			      apply andI.
			      - apply andI.
			        + exact (andEL (b :e B) (x :e b /\ b c= W) Hbpack).
			        + claim Hbrest: x :e b /\ b c= W.
			          { exact (andER (b :e B) (x :e b /\ b c= W) Hbpack). }
			          exact (andEL (x :e b) (b c= W) Hbrest).
			      - claim Hbrest: x :e b /\ b c= W.
			        { exact (andER (b :e B) (x :e b /\ b c= W) Hbpack). }
			        exact (andER (x :e b) (b c= W) Hbrest). }
			    apply (HWloc x0 Hx0W).
			    let U0. assume HU0pack.
			    claim HU0pack12: U0 :e B /\ x0 :e U0.
			    { exact (andEL (U0 :e B /\ x0 :e U0) (U0 c= W) HU0pack). }
			    claim HU0subW: U0 c= W.
			    { exact (andER (U0 :e B /\ x0 :e U0) (U0 c= W) HU0pack). }
			    claim HU0B: U0 :e B.
			    { exact (andEL (U0 :e B) (x0 :e U0) HU0pack12). }
			    claim Hx0U0: x0 :e U0.
			    { exact (andER (U0 :e B) (x0 :e U0) HU0pack12). }
		    claim HWsubX: W c= X.
		    { exact (topology_elem_subset X Tx W HTx HWtx). }
		    claim HclU0subclW: closure_of X Tx U0 c= closure_of X Tx W.
		    { exact (closure_monotone X Tx U0 W HTx HU0subW HWsubX). }
				    claim HclU0subV: closure_of X Tx U0 c= V.
				    { exact (Subq_tra (closure_of X Tx U0) (closure_of X Tx W) V HclU0subclW HclWsubV). }
					    set p := (U0,V).
					    claim Hpdef: p = (U0,V).
					    { reflexivity. }
						    claim HpBB: p :e (B :*: B).
						    { exact (tuple_2_setprod B B U0 HU0B V HVB). }
				    claim HpP: p :e P.
				    { claim HpProp: closure_of X Tx (proj0 p) c= proj1 p.
				      { rewrite Hpdef.
				        rewrite <- (tuple_pair U0 V).
				        rewrite (proj0_pair_eq U0 V).
				        rewrite (proj1_pair_eq U0 V).
				        exact HclU0subV. }
				      exact (SepI (B :*: B) (fun p0:set => closure_of X Tx (proj0 p0) c= proj1 p0) p HpBB HpProp). }
				    set j := enc p.
				    claim Hjdef: j = enc p.
				    { reflexivity. }
				    claim HJdef: J = omega.
				    { reflexivity. }
				    claim Henc_dom: forall u :e P, enc u :e omega.
				    { exact (andEL (forall u :e P, enc u :e omega)
				                   (forall u v :e P, enc u = enc v -> u = v)
				                   Henc). }
				    claim HjJ: j :e J.
				    { rewrite HJdef.
				      rewrite Hjdef.
				      exact (Henc_dom p HpP). }
				    witness j.
				    apply andI.
				    - apply andI.
				      + exact HjJ.
				      + (** positivity at x0 **)
			        claim HFdef: F = graph J (fun n0:set => bump (pair_of n0)).
			        { reflexivity. }
		        claim HpairEq: pair_of j = p.
		        { claim Hinj: forall u v :e P, enc u = enc v -> u = v.
		          { exact (andER (forall u :e P, enc u :e omega)
		                         (forall u v :e P, enc u = enc v -> u = v)
		                         Henc). }
			          claim HinvEq: inv P enc (enc p) = p.
			          { exact (inj_linv P enc Hinj p HpP). }
			          rewrite Hjdef.
			          exact HinvEq. }
				        claim Hfj: apply_fun F j = bump p.
				        { rewrite HFdef.
				          claim Happ: apply_fun (graph J (fun n0:set => bump (pair_of n0))) j =
				            (fun n0:set => bump (pair_of n0)) j.
				          { exact (apply_fun_graph J (fun n0:set => bump (pair_of n0)) j HjJ). }
				          rewrite Happ.
				          claim Hbeta: (fun n0:set => bump (pair_of n0)) j = bump (pair_of j).
				          { reflexivity. }
				          rewrite Hbeta.
				          rewrite HpairEq.
				          reflexivity. }
		        claim Hclx0: x0 :e closure_of X Tx U0.
		        { claim HU0subX: U0 c= X.
		          { exact (basis_elem_subset X B U0 HB HU0B). }
		          exact (subset_of_closure X Tx U0 HTx HU0subX x0 Hx0U0). }
		        claim HbDef: bump p = Eps_i (fun f:set =>
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)).
		        { claim Hb: bump = (fun p0:set =>
		            if p0 :e P then
		              Eps_i (fun f:set =>
		                f :e function_space X R /\
		                continuous_map X Tx R R_standard_topology f /\
		                (forall x1:set, x1 :e (X :\: (proj1 p0)) -> apply_fun f x1 = 0) /\
		                (forall x1:set, x1 :e closure_of X Tx (proj0 p0) -> apply_fun f x1 = 1))
		            else const_fun X 0).
			          { reflexivity. }
			          rewrite Hb.
			          claim Hbeta_bump_p:
			            (fun p0:set =>
			              if p0 :e P then
			                Eps_i (fun f:set =>
			                  f :e function_space X R /\
			                  continuous_map X Tx R R_standard_topology f /\
			                  (forall x1:set, x1 :e (X :\: (proj1 p0)) -> apply_fun f x1 = 0) /\
			                  (forall x1:set, x1 :e closure_of X Tx (proj0 p0) -> apply_fun f x1 = 1))
			              else const_fun X 0) p
			            =
			            (if p :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))
			              else const_fun X 0).
			          { reflexivity. }
			          rewrite Hbeta_bump_p.
			          rewrite (If_i_1 (p :e P)
			                          (Eps_i (fun f:set =>
			                            f :e function_space X R /\
			                            continuous_map X Tx R R_standard_topology f /\
		                            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
		                          (const_fun X 0) HpP).
		          reflexivity. }
			        claim Hex: exists f:set,
			          f :e function_space X R /\
			          continuous_map X Tx R R_standard_topology f /\
		          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1).
		        { exact (Hbump_ex p HpP). }
		        claim Htmp:
		          (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))
		          (Eps_i (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))).
		        { exact (Eps_i_ex (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)) Hex). }
		        claim Hval:
		          apply_fun (Eps_i (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x0 = 1.
		        { claim Hrest:
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
		               apply_fun (Eps_i (fun f:set =>
		                 f :e function_space X R /\
		                 continuous_map X Tx R R_standard_topology f /\
		                 (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                 (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1).
		          { claim Hmid:
		              (Eps_i (fun f:set =>
		                f :e function_space X R /\
		                continuous_map X Tx R R_standard_topology f /\
		                (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
		              :e function_space X R /\
		              continuous_map X Tx R R_standard_topology
		                (Eps_i (fun f:set =>
		                  f :e function_space X R /\
		                  continuous_map X Tx R R_standard_topology f /\
		                  (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                  (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) /\
		              (forall x1:set, x1 :e (X :\: (proj1 p)) ->
		                 apply_fun (Eps_i (fun f:set =>
		                   f :e function_space X R /\
		                   continuous_map X Tx R R_standard_topology f /\
		                   (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                   (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0) /\
		              (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
		                 apply_fun (Eps_i (fun f:set =>
		                   f :e function_space X R /\
		                   continuous_map X Tx R R_standard_topology f /\
		                   (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                   (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1).
		            { exact Htmp. }
		            claim Hrest2:
		              (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
		                 apply_fun (Eps_i (fun f:set =>
		                   f :e function_space X R /\
		                   continuous_map X Tx R R_standard_topology f /\
		                   (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                   (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1).
		            { exact (andER ((Eps_i (fun f:set =>
		                      f :e function_space X R /\
		                      continuous_map X Tx R R_standard_topology f /\
		                      (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                      (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
		                    :e function_space X R /\
		                    continuous_map X Tx R R_standard_topology
		                      (Eps_i (fun f:set =>
		                        f :e function_space X R /\
		                        continuous_map X Tx R R_standard_topology f /\
		                        (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                        (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) /\
		                    (forall x1:set, x1 :e (X :\: (proj1 p)) ->
		                       apply_fun (Eps_i (fun f:set =>
		                         f :e function_space X R /\
		                         continuous_map X Tx R R_standard_topology f /\
		                         (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                         (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0))
		                   (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
		                     apply_fun (Eps_i (fun f:set =>
		                       f :e function_space X R /\
		                       continuous_map X Tx R R_standard_topology f /\
		                       (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                       (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1)
		                   Hmid). }
		            exact Hrest2. }
				          apply (Hrest x0).
				          rewrite Hpdef.
				          rewrite <- (tuple_pair U0 V).
				          rewrite (proj0_pair_eq U0 V).
				          exact Hclx0. }
			        claim Hx01: apply_fun (apply_fun F j) x0 = 1.
			        { rewrite Hfj at 1.
			          rewrite HbDef at 1.
			          exact Hval. }
		        claim Hpos: Rlt 0 (apply_fun (apply_fun F j) x0).
		        { rewrite Hx01.
		          exact Rlt_0_1. }
		        exact Hpos.
				    - (** zero outside U **)
			        let x. assume HxOut: x :e X :\: U.
			        claim HxOutV: x :e X :\: V.
			        { exact (setminus_antimonotone X V U HVsubU x HxOut). }
			        claim HFdef: F = graph J (fun n0:set => bump (pair_of n0)).
			        { reflexivity. }
		        claim HpairEq: pair_of j = p.
		        { claim Hinj: forall u v :e P, enc u = enc v -> u = v.
		          { exact (andER (forall u :e P, enc u :e omega)
		                         (forall u v :e P, enc u = enc v -> u = v)
		                         Henc). }
			          claim HinvEq: inv P enc (enc p) = p.
			          { exact (inj_linv P enc Hinj p HpP). }
			          rewrite Hjdef.
			          exact HinvEq. }
			        claim Hfj: apply_fun F j = bump p.
			        { rewrite HFdef.
			          claim Happ: apply_fun (graph J (fun n0:set => bump (pair_of n0))) j =
			            (fun n0:set => bump (pair_of n0)) j.
			          { exact (apply_fun_graph J (fun n0:set => bump (pair_of n0)) j HjJ). }
			          rewrite Happ.
			          claim Hbeta: (fun n0:set => bump (pair_of n0)) j = bump (pair_of j).
			          { reflexivity. }
			          rewrite Hbeta.
			          rewrite HpairEq.
			          reflexivity. }
		        claim HbDef: bump p = Eps_i (fun f:set =>
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)).
		        { claim Hb: bump = (fun p0:set =>
		            if p0 :e P then
		              Eps_i (fun f:set =>
		                f :e function_space X R /\
		                continuous_map X Tx R R_standard_topology f /\
		                (forall x1:set, x1 :e (X :\: (proj1 p0)) -> apply_fun f x1 = 0) /\
		                (forall x1:set, x1 :e closure_of X Tx (proj0 p0) -> apply_fun f x1 = 1))
		            else const_fun X 0).
			          { reflexivity. }
			          rewrite Hb.
			          claim Hbeta_bump_p:
			            (fun p0:set =>
			              if p0 :e P then
			                Eps_i (fun f:set =>
			                  f :e function_space X R /\
			                  continuous_map X Tx R R_standard_topology f /\
			                  (forall x1:set, x1 :e (X :\: (proj1 p0)) -> apply_fun f x1 = 0) /\
			                  (forall x1:set, x1 :e closure_of X Tx (proj0 p0) -> apply_fun f x1 = 1))
			              else const_fun X 0) p
			            =
			            (if p :e P then
			              Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))
			              else const_fun X 0).
			          { reflexivity. }
			          rewrite Hbeta_bump_p.
			          rewrite (If_i_1 (p :e P)
			                          (Eps_i (fun f:set =>
			                            f :e function_space X R /\
			                            continuous_map X Tx R R_standard_topology f /\
		                            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
		                          (const_fun X 0) HpP).
		          reflexivity. }
		        rewrite Hfj.
		        rewrite HbDef.
		        claim Hex: exists f:set,
		          f :e function_space X R /\
		          continuous_map X Tx R R_standard_topology f /\
		          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1).
		        { exact (Hbump_ex p HpP). }
		        claim Htmp:
		          (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))
		          (Eps_i (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))).
		        { exact (Eps_i_ex (fun f:set =>
		            f :e function_space X R /\
		            continuous_map X Tx R R_standard_topology f /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)) Hex). }
		        claim Hzero:
		          forall x1:set, x1 :e (X :\: (proj1 p)) ->
		            apply_fun (Eps_i (fun f:set =>
		              f :e function_space X R /\
		              continuous_map X Tx R R_standard_topology f /\
		              (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		              (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0.
		        { claim Hmid:
		            (Eps_i (fun f:set =>
		              f :e function_space X R /\
		              continuous_map X Tx R R_standard_topology f /\
		              (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		              (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
		            :e function_space X R /\
		            continuous_map X Tx R R_standard_topology
		              (Eps_i (fun f:set =>
		                f :e function_space X R /\
		                continuous_map X Tx R R_standard_topology f /\
		                (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) /\
		            (forall x1:set, x1 :e (X :\: (proj1 p)) ->
		               apply_fun (Eps_i (fun f:set =>
		                 f :e function_space X R /\
		                 continuous_map X Tx R R_standard_topology f /\
		                 (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                 (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0) /\
		            (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
		               apply_fun (Eps_i (fun f:set =>
		                 f :e function_space X R /\
		                 continuous_map X Tx R R_standard_topology f /\
		                 (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
		                 (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1).
		          { exact Htmp. }
			          claim Hrest:
			            (forall x1:set, x1 :e (X :\: (proj1 p)) ->
			               apply_fun (Eps_i (fun f:set =>
			                 f :e function_space X R /\
			                 continuous_map X Tx R R_standard_topology f /\
			                 (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                 (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0).
			          { claim Hmid123:
			              (Eps_i (fun f:set =>
			                f :e function_space X R /\
			                continuous_map X Tx R R_standard_topology f /\
			                (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
			              :e function_space X R /\
			              continuous_map X Tx R R_standard_topology
			                (Eps_i (fun f:set =>
			                  f :e function_space X R /\
			                  continuous_map X Tx R R_standard_topology f /\
			                  (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                  (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) /\
			              (forall x1:set, x1 :e (X :\: (proj1 p)) ->
			                apply_fun (Eps_i (fun f:set =>
			                  f :e function_space X R /\
			                  continuous_map X Tx R R_standard_topology f /\
			                  (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                  (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0).
			            { exact (andEL ((Eps_i (fun f:set =>
			                        f :e function_space X R /\
			                        continuous_map X Tx R R_standard_topology f /\
			                        (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                        (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
			                      :e function_space X R /\
			                      continuous_map X Tx R R_standard_topology
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
			                          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) /\
			                      (forall x1:set, x1 :e (X :\: (proj1 p)) ->
			                        apply_fun (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
			                          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0))
			                     (forall x1:set, x1 :e closure_of X Tx (proj0 p) ->
			                       apply_fun (Eps_i (fun f:set =>
			                         f :e function_space X R /\
			                         continuous_map X Tx R R_standard_topology f /\
			                         (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                         (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 1)
			                     Hmid). }
			            exact (andER ((Eps_i (fun f:set =>
			                        f :e function_space X R /\
			                        continuous_map X Tx R R_standard_topology f /\
			                        (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                        (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1)))
			                      :e function_space X R /\
			                      continuous_map X Tx R R_standard_topology
			                        (Eps_i (fun f:set =>
			                          f :e function_space X R /\
			                          continuous_map X Tx R R_standard_topology f /\
			                          (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                          (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))))
			                   (forall x1:set, x1 :e (X :\: (proj1 p)) ->
			                     apply_fun (Eps_i (fun f:set =>
			                       f :e function_space X R /\
			                       continuous_map X Tx R R_standard_topology f /\
			                       (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			                       (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x1 = 0)
			                   Hmid123). }
			          exact Hrest. }
			        claim Hx0: apply_fun (Eps_i (fun f:set =>
			              f :e function_space X R /\
			              continuous_map X Tx R R_standard_topology f /\
			              (forall x1:set, x1 :e (X :\: (proj1 p)) -> apply_fun f x1 = 0) /\
			              (forall x1:set, x1 :e closure_of X Tx (proj0 p) -> apply_fun f x1 = 1))) x = 0.
			        { apply (Hzero x).
			          rewrite Hpdef.
			          rewrite <- (tuple_pair U0 V).
			          rewrite (proj1_pair_eq U0 V).
			          exact HxOutV. }
				        exact Hx0.
}
apply HexSep.
let F.
assume Hsep: separating_family_of_functions X Tx F J.

(** Use the diagonal map into R^omega and show it is an embedding. **)
set Fmap := diagonal_map X F J.
claim HFmap: embedding_of X Tx (power_real J) (product_topology_full J (const_space_family J R R_standard_topology)) Fmap.
{ (** This is Theorem 34.2 in topology.tex, proved later as `embedding_via_functions`. Here we inline the key steps. **)
	  set Xi := const_space_family J R R_standard_topology.
	  set Ty0 := product_topology_full J Xi.
	  claim HcontFmap: continuous_map X Tx (power_real J) Ty0 Fmap.
	  { (** continuity of the diagonal map into R^J with the product topology **)
	    claim HpR: power_real J = product_space J Xi.
	    { reflexivity. }
	    claim HTyDef: Ty0 = product_topology_full J Xi.
	    { reflexivity. }
	    rewrite HpR.
	    rewrite HTyDef.
	    prove continuous_map X Tx (product_space J Xi) (product_topology_full J Xi) Fmap.
	    claim HFmapDef: Fmap = diagonal_map X F J.
	    { reflexivity. }
	    claim HdiagDef: diagonal_map X F J =
	      graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
	    { reflexivity. }
	    claim HsepCore:
	      (topology_on X Tx /\ total_function_on F J (function_space X R)) /\
	      (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0)).
	    { exact (andEL ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
	                    (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0)))
	                   (forall x0:set, x0 :e X ->
	                     forall U0:set, U0 :e Tx -> x0 :e U0 ->
	                       exists j0:set, j0 :e J /\
	                         Rlt 0 (apply_fun (apply_fun F j0) x0) /\
	                         forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
	                   Hsep). }
	    claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
	    { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
	                   (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
	                   HsepCore). }
	    claim Htot: total_function_on F J (function_space X R).
	    { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
	    claim HfunPow: function_on Fmap X (power_real J).
	    { rewrite HFmapDef.
	      exact (diagonal_map_function_on_power_real X F J Htot). }
	    claim Hfun: function_on Fmap X (product_space J Xi).
	    { let x. assume HxX: x :e X.
	      prove apply_fun Fmap x :e product_space J Xi.
	      rewrite <- HpR.
	      exact (HfunPow x HxX). }
	    apply (xm (J = Empty)).
	    - assume HJ0: J = Empty.
	      rewrite HJ0.
	      claim HTy0: topology_on (product_space Empty Xi) (product_topology_full Empty Xi).
	      { claim HTdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
	        { reflexivity. }
	        rewrite HTdef.
	        exact (countable_product_topology_subbasis_empty_is_topology Xi). }
	      claim HX0: product_space Empty Xi = {Empty}.
	      { exact (product_space_empty_index Xi). }
	      claim HEmptyY: Empty :e product_space Empty Xi.
	      { rewrite HX0.
	        exact (SingI Empty). }
	      claim HXieq: Xi = const_space_family Empty R R_standard_topology.
	      { claim HXidef: Xi = const_space_family J R R_standard_topology.
	        { reflexivity. }
	        rewrite HXidef.
	        rewrite HJ0.
	        reflexivity. }
	      claim HFmapConst: Fmap = const_fun X Empty.
	      { claim HFmapE: Fmap = diagonal_map X F Empty.
	        { rewrite HFmapDef.
	          rewrite HJ0.
	          reflexivity. }
	        apply set_ext.
	        - let p. assume Hp: p :e Fmap.
	          prove p :e const_fun X Empty.
	          claim HpDiag: p :e diagonal_map X F Empty.
	          { rewrite <- HFmapE.
	            exact Hp. }
	          claim Hdiag0: diagonal_map X F Empty =
	            graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { reflexivity. }
	          claim HpGraph:
	            p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { rewrite <- Hdiag0.
	            exact HpDiag. }
	          apply (ReplE_impred X
	                   (fun x0:set => (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))
	                   p HpGraph
	                   (p :e const_fun X Empty)).
	          let x0. assume Hx0X: x0 :e X.
	          assume Hpeq: p = (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) = Empty.
	          { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) =
	              {(j0, apply_fun (apply_fun F j0) x0) | j0 :e Empty}.
	            { reflexivity. }
	            rewrite HgraphDef.
	            exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x0))). }
	          rewrite Hpeq.
	          rewrite Hem.
	          exact (ReplI X (fun a0:set => (a0, Empty)) x0 Hx0X).
	        - let p. assume Hp: p :e const_fun X Empty.
	          prove p :e Fmap.
	          claim HFmapE: Fmap = diagonal_map X F Empty.
	          { rewrite HFmapDef.
	            rewrite HJ0.
	            reflexivity. }
	          claim Hdiag0: diagonal_map X F Empty =
	            graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { reflexivity. }
	          claim HpGraph:
	            p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { apply (ReplE_impred X (fun a0:set => (a0, Empty)) p Hp
	                   (p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))).
	            let x2. assume Hx2X: x2 :e X.
	            assume Hpeq: p = (x2, Empty).
	            claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) = Empty.
	            { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) =
	                {(j0, apply_fun (apply_fun F j0) x2) | j0 :e Empty}.
	              { reflexivity. }
	              rewrite HgraphDef.
	              exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x2))). }
	            claim HpEq2: p = (x2, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2)).
	            { rewrite Hpeq.
	              rewrite Hem.
	              reflexivity. }
	            rewrite HpEq2.
	            exact (ReplI X
	                         (fun x1:set => (x1, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x1)))
	                         x2 Hx2X). }
	          claim HpDiag: p :e diagonal_map X F Empty.
	          { rewrite Hdiag0.
	            exact HpGraph. }
	          rewrite HFmapE.
	          exact HpDiag. }
	      claim HdiagConst: diagonal_map X F Empty = const_fun X Empty.
	      { apply set_ext.
	        - let p. assume Hp: p :e diagonal_map X F Empty.
	          prove p :e const_fun X Empty.
	          claim Hdiag0: diagonal_map X F Empty =
	            graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { reflexivity. }
	          claim HpGraph:
	            p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { rewrite <- Hdiag0.
	            exact Hp. }
	          apply (ReplE_impred X
	                   (fun x0:set => (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))
	                   p HpGraph
	                   (p :e const_fun X Empty)).
	          let x0. assume Hx0X: x0 :e X.
	          assume Hpeq: p = (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) = Empty.
	          { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) =
	              {(j0, apply_fun (apply_fun F j0) x0) | j0 :e Empty}.
	            { reflexivity. }
	            rewrite HgraphDef.
	            exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x0))). }
	          rewrite Hpeq.
	          rewrite Hem.
	          exact (ReplI X (fun a0:set => (a0, Empty)) x0 Hx0X).
	        - let p. assume Hp: p :e const_fun X Empty.
	          prove p :e diagonal_map X F Empty.
	          claim Hdiag0: diagonal_map X F Empty =
	            graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { reflexivity. }
	          claim HpGraph:
	            p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	          { apply (ReplE_impred X (fun a0:set => (a0, Empty)) p Hp
	                   (p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))).
	            let x2. assume Hx2X: x2 :e X.
	            assume Hpeq: p = (x2, Empty).
	            claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) = Empty.
	            { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) =
	                {(j0, apply_fun (apply_fun F j0) x2) | j0 :e Empty}.
	              { reflexivity. }
	              rewrite HgraphDef.
	              exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x2))). }
	            claim HpEq2: p = (x2, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2)).
	            { rewrite Hpeq.
	              rewrite Hem.
	              reflexivity. }
	            rewrite HpEq2.
	            exact (ReplI X
	                         (fun x1:set => (x1, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x1)))
	                         x2 Hx2X). }
	          rewrite Hdiag0.
	          exact HpGraph. }
	      claim Hconst:
	        continuous_map X Tx (product_space Empty Xi) (product_topology_full Empty Xi) (const_fun X Empty).
	      { exact (const_fun_continuous X Tx (product_space Empty Xi) (product_topology_full Empty Xi) Empty
	                 HTx HTy0 HEmptyY). }
	      rewrite HdiagConst.
	      rewrite <- HXieq.
	      exact Hconst.
	    - assume HJne: J <> Empty.
	      claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
	      { let i. assume HiJ: i :e J.
	        claim Hset: space_family_set Xi i = R.
	        { exact (space_family_set_const_space_family J R R_standard_topology i HiJ). }
	        claim Htop: space_family_topology Xi i = R_standard_topology.
	        { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
	        rewrite Hset.
	        rewrite Htop.
	        exact R_standard_topology_is_topology. }
	      claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
	      { exact (product_subbasis_full_subbasis_on J Xi HJne HcompTop). }
	      claim HcontCoord: forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0).
	      { exact (andER (topology_on X Tx /\ total_function_on F J (function_space X R))
	                     (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
	                     HsepCore). }
	      apply (continuous_map_from_subbasis X Tx (product_space J Xi) (product_subbasis_full J Xi) Fmap HTx Hfun HSsub).
	      let s. assume HsS: s :e product_subbasis_full J Xi.
	      prove preimage_of X Fmap s :e Tx.
	      set Fam := (fun i0:set => {product_cylinder J Xi i0 U0|U0 :e space_family_topology Xi i0}).
	      claim HsFam: s :e (\/_ i0 :e J, Fam i0).
	      { exact HsS. }
	      apply (famunionE_impred J Fam s HsFam (preimage_of X Fmap s :e Tx)).
	      let i. assume HiJ: i :e J.
	      assume HsFi: s :e Fam i.
	      claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder J Xi i U.
	      { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder J Xi i U0) s HsFi). }
	      apply HexU.
	      let U. assume HUand: U :e space_family_topology Xi i /\ s = product_cylinder J Xi i U.
	      claim HUtop: U :e space_family_topology Xi i.
	      { exact (andEL (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
	      claim Hseq: s = product_cylinder J Xi i U.
	      { exact (andER (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
	      rewrite Hseq.
	      claim Hconti: continuous_map X Tx R R_standard_topology (apply_fun F i).
	      { exact (HcontCoord i HiJ). }
	      claim HUstd: U :e R_standard_topology.
	      { claim Htopi: space_family_topology Xi i = R_standard_topology.
	        { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
	        rewrite <- Htopi.
	        exact HUtop. }
	      claim HpreEq: preimage_of X Fmap (product_cylinder J Xi i U) = preimage_of X (apply_fun F i) U.
	      { apply set_ext.
	        - let x. assume HxPre: x :e preimage_of X Fmap (product_cylinder J Xi i U).
	          prove x :e preimage_of X (apply_fun F i) U.
	          claim HxX: x :e X.
	          { exact (SepE1 X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxPre). }
	          claim HfxCyl: apply_fun Fmap x :e product_cylinder J Xi i U.
	          { exact (SepE2 X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxPre). }
	          claim HcylProp:
	            i :e J /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun Fmap x) i :e U.
	          { exact (SepE2 (product_space J Xi)
	                         (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
	                         (apply_fun Fmap x) HfxCyl). }
	          claim HcoordU: apply_fun (apply_fun Fmap x) i :e U.
	          { claim H12: i :e J /\ U :e space_family_topology Xi i.
	            { exact (andEL (i :e J /\ U :e space_family_topology Xi i)
	                           (apply_fun (apply_fun Fmap x) i :e U)
	                           HcylProp). }
	            exact (andER (i :e J /\ U :e space_family_topology Xi i)
	                         (apply_fun (apply_fun Fmap x) i :e U)
	                         HcylProp). }
	          claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
	          { rewrite HFmapDef.
	            rewrite HdiagDef.
	            exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
	          claim HcoordEq: apply_fun (apply_fun Fmap x) i = apply_fun (apply_fun F i) x.
	          { rewrite HFmapx.
	            rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
	            reflexivity. }
	          claim HfiU: apply_fun (apply_fun F i) x :e U.
	          { rewrite <- HcoordEq.
	            exact HcoordU. }
	          exact (SepI X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxX HfiU).
	        - let x. assume HxPre: x :e preimage_of X (apply_fun F i) U.
	          prove x :e preimage_of X Fmap (product_cylinder J Xi i U).
	          claim HxX: x :e X.
	          { exact (SepE1 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
	          claim HfiU: apply_fun (apply_fun F i) x :e U.
	          { exact (SepE2 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
	          claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
	          { rewrite HFmapDef.
	            rewrite HdiagDef.
	            exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
	          claim HcoordEq: apply_fun (apply_fun Fmap x) i = apply_fun (apply_fun F i) x.
	          { rewrite HFmapx.
	            rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
	            reflexivity. }
	          claim HcoordU: apply_fun (apply_fun Fmap x) i :e U.
	          { rewrite HcoordEq.
	            exact HfiU. }
	          claim Hpred: i :e J /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun Fmap x) i :e U.
	          { apply andI.
	            - apply andI.
	              + exact HiJ.
	              + exact HUtop.
	            - exact HcoordU. }
	          claim HfxCyl: apply_fun Fmap x :e product_cylinder J Xi i U.
	          { exact (SepI (product_space J Xi)
	                        (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
	                        (apply_fun Fmap x)
	                        (Hfun x HxX)
	                        Hpred). }
	          exact (SepI X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxX HfxCyl). }
	      rewrite HpreEq.
	      exact (continuous_map_preimage X Tx R R_standard_topology (apply_fun F i) Hconti U HUstd). }
	  claim HlocFmap:
	    forall x U:set, x :e X -> U :e Tx -> x :e U ->
	      exists V:set, V :e Ty0 /\ apply_fun Fmap x :e V /\ preimage_of X Fmap V c= U.
	  { let x. let U.
	    assume HxX: x :e X.
	    assume HU: U :e Tx.
	    assume HxU: x :e U.
	    claim HsepCore:
	      ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
	       (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))).
	    { exact (andEL (((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
	                     (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))))
	                   (forall x0:set, x0 :e X ->
	                     forall U0:set, U0 :e Tx -> x0 :e U0 ->
	                       exists j0:set, j0 :e J /\
	                         Rlt 0 (apply_fun (apply_fun F j0) x0) /\
	                         forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
	                   Hsep). }
	    claim Hneigh:
	      forall x0:set, x0 :e X ->
	        forall U0:set, U0 :e Tx -> x0 :e U0 ->
	          exists j0:set, j0 :e J /\
	            Rlt 0 (apply_fun (apply_fun F j0) x0) /\
	            forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0.
	    { exact (andER (((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
	                     (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))))
	                   (forall x0:set, x0 :e X ->
	                     forall U0:set, U0 :e Tx -> x0 :e U0 ->
	                       exists j0:set, j0 :e J /\
	                         Rlt 0 (apply_fun (apply_fun F j0) x0) /\
	                         forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
	                   Hsep). }
	    claim Hexj:
	      exists j0:set, j0 :e J /\
	        Rlt 0 (apply_fun (apply_fun F j0) x) /\
	        forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j0) x1 = 0.
	    { exact (Hneigh x HxX U HU HxU). }
	    apply Hexj.
	    let j. assume Hjpack.
	    claim Hj12: j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x).
	    { exact (andEL (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
	                   (forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0)
	                   Hjpack). }
	    claim HjJ: j :e J.
	    { exact (andEL (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
	    claim Hjpos: Rlt 0 (apply_fun (apply_fun F j) x).
	    { exact (andER (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
	    claim Hjzero:
	      forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0.
	    { exact (andER (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
	                   (forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0)
	                   Hjpack). }
	    set V := product_cylinder J Xi j (open_ray_upper R 0).
	    witness V.
	    apply andI.
	    - apply andI.
	      + claim HTyDef: Ty0 = product_topology_full J Xi.
	        { reflexivity. }
	        rewrite HTyDef.
	        claim HprodDef: product_topology_full J Xi =
	          generated_topology_from_subbasis (product_space J Xi) (product_subbasis_full J Xi).
	        { reflexivity. }
	        rewrite HprodDef.
	        claim HJne: J <> Empty.
	        { exact (elem_implies_nonempty J j HjJ). }
	        claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
	        { let i. assume HiJ: i :e J.
	          claim Hset: space_family_set Xi i = R.
	          { exact (space_family_set_const_space_family J R R_standard_topology i HiJ). }
	          claim Htop: space_family_topology Xi i = R_standard_topology.
	          { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
	          rewrite Hset.
	          rewrite Htop.
	          exact R_standard_topology_is_topology. }
	        claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
	        { exact (product_subbasis_full_subbasis_on J Xi HJne HcompTop). }
	        claim H0R: 0 :e R.
	        { exact real_0. }
	        claim HopenRay: open_ray_upper R 0 :e R_standard_topology.
	        { rewrite <- standard_topology_is_order_topology.
	          claim HsRay: open_ray_upper R 0 :e open_rays_subbasis R.
	          { exact (open_ray_upper_in_open_rays_subbasis R 0 H0R). }
	          exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R 0) HsRay). }
	        claim Htopj: space_family_topology Xi j = R_standard_topology.
	        { exact (space_family_topology_const_space_family J R R_standard_topology j HjJ). }
	        claim HUtop: open_ray_upper R 0 :e space_family_topology Xi j.
	        { rewrite Htopj.
	          exact HopenRay. }
	        claim HVsub: V :e product_subbasis_full J Xi.
	        { set Fam := (fun i0:set => {product_cylinder J Xi i0 U0|U0 :e space_family_topology Xi i0}).
	          claim HVfam: V :e Fam j.
	          { exact (ReplI (space_family_topology Xi j) (fun U0:set => product_cylinder J Xi j U0)
	                         (open_ray_upper R 0) HUtop). }
	          exact (famunionI J Fam j V HjJ HVfam). }
	        exact (subbasis_elem_open_in_generated_from_subbasis (product_space J Xi) (product_subbasis_full J Xi) V HSsub HVsub).
	      + claim HFmapDef: Fmap = diagonal_map X F J.
	        { reflexivity. }
	        claim HdiagDef: diagonal_map X F J =
	          graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
	        { reflexivity. }
	        claim Hfx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
	        { rewrite HFmapDef.
	          rewrite HdiagDef.
	          exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
	        claim Hval:
	          apply_fun (apply_fun Fmap x) j :e open_ray_upper R 0.
	        { rewrite Hfx.
	          rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) j HjJ).
	          claim HxjR: apply_fun (apply_fun F j) x :e R.
	          { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
	            { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
	                           (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
	                           HsepCore). }
	            claim Htot: total_function_on F J (function_space X R).
	            { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
	            claim HfjFS: apply_fun F j :e function_space X R.
	            { exact (total_function_on_apply_fun_in_Y F J (function_space X R) j Htot HjJ). }
	            claim HfjFun: function_on (apply_fun F j) X R.
	            { exact (SepE2 (Power (setprod X R)) (fun f0:set => function_on f0 X R) (apply_fun F j) HfjFS). }
	            exact (HfjFun x HxX). }
	          claim Hord: order_rel R 0 (apply_fun (apply_fun F j) x).
	          { exact (Rlt_implies_order_rel_R 0 (apply_fun (apply_fun F j) x) Hjpos). }
	          exact (SepI R (fun t:set => order_rel R 0 t) (apply_fun (apply_fun F j) x) HxjR Hord). }
	        claim HVdef: V =
	          {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
	        { reflexivity. }
	        rewrite HVdef.
	        claim Htot: total_function_on F J (function_space X R).
	        { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
	          { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
	                         (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
	                         HsepCore). }
	          exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
	        claim HfunF: function_on Fmap X (power_real J).
	        { rewrite HFmapDef.
	          exact (diagonal_map_function_on_power_real X F J Htot). }
	        claim HpR: power_real J = product_space J Xi.
	        { reflexivity. }
	        claim HfxProd: apply_fun Fmap x :e product_space J Xi.
	        { rewrite <- HpR.
	          exact (HfunF x HxX). }
	        apply (SepI (product_space J Xi)
	                    (fun f0:set => j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0)
	                    (apply_fun Fmap x) HfxProd).
	        apply andI.
	        - apply andI.
	          + exact HjJ.
	          + claim H0R: 0 :e R.
	            { exact real_0. }
	            claim HopenRay: open_ray_upper R 0 :e R_standard_topology.
	            { rewrite <- standard_topology_is_order_topology.
	              claim HsRay: open_ray_upper R 0 :e open_rays_subbasis R.
	              { exact (open_ray_upper_in_open_rays_subbasis R 0 H0R). }
	              exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R 0) HsRay). }
	            claim Htopj: space_family_topology Xi j = R_standard_topology.
	            { exact (space_family_topology_const_space_family J R R_standard_topology j HjJ). }
	            rewrite Htopj.
	            exact HopenRay.
	        - claim Hcoord: apply_fun (apply_fun Fmap x) j :e open_ray_upper R 0.
	          { exact Hval. }
	          exact Hcoord.
	    - let z. assume HzPre: z :e preimage_of X Fmap V.
	      prove z :e U.
	      claim HzX: z :e X.
	      { exact (SepE1 X (fun x0:set => apply_fun Fmap x0 :e V) z HzPre). }
	      claim HzV: apply_fun Fmap z :e V.
	      { exact (SepE2 X (fun x0:set => apply_fun Fmap x0 :e V) z HzPre). }
	      claim HVdef: V =
	        {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
	      { reflexivity. }
	      claim HzV2: apply_fun Fmap z :e {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
	      { rewrite <- HVdef.
	        exact HzV. }
	      claim Hcore: j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0.
	      { exact (SepE2 (product_space J Xi)
	                     (fun f0:set => j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0)
	                     (apply_fun Fmap z) HzV2). }
	      claim Hzcoord: apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0.
	      { claim H12: j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j.
	        { exact (andEL (j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j)
	                       (apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0)
	                       Hcore). }
	        exact (andER (j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j)
	                     (apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0)
	                     Hcore). }
	      claim HFmapDef: Fmap = diagonal_map X F J.
	      { reflexivity. }
	      claim HdiagDef: diagonal_map X F J =
	        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
	      { reflexivity. }
	      claim HFmapz: apply_fun Fmap z = graph J (fun j0:set => apply_fun (apply_fun F j0) z).
	      { rewrite HFmapDef.
	        rewrite HdiagDef.
	        exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) z HzX). }
	      claim Hzcoord2: apply_fun (apply_fun F j) z :e open_ray_upper R 0.
	      { claim HcoordEq: apply_fun (apply_fun Fmap z) j = apply_fun (apply_fun F j) z.
	        { rewrite HFmapz.
	          rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) z) j HjJ).
	          reflexivity. }
	        rewrite <- HcoordEq.
	        exact Hzcoord. }
	      claim HzR: apply_fun (apply_fun F j) z :e R.
	      { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
	        { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
	                       (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
	                       HsepCore). }
	        claim Htot: total_function_on F J (function_space X R).
	        { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
	        claim HfjFS: apply_fun F j :e function_space X R.
	        { exact (total_function_on_apply_fun_in_Y F J (function_space X R) j Htot HjJ). }
	        claim HfjFun: function_on (apply_fun F j) X R.
	        { exact (SepE2 (Power (setprod X R)) (fun f0:set => function_on f0 X R) (apply_fun F j) HfjFS). }
	        exact (HfjFun z HzX). }
	      claim H0R: 0 :e R.
	      { exact real_0. }
	      claim Hzord: order_rel R 0 (apply_fun (apply_fun F j) z).
	      { exact (SepE2 R (fun t:set => order_rel R 0 t) (apply_fun (apply_fun F j) z) Hzcoord2). }
	      claim Hzpos: Rlt 0 (apply_fun (apply_fun F j) z).
	      { exact (order_rel_R_implies_Rlt 0 (apply_fun (apply_fun F j) z) Hzord). }
	      apply (xm (z :e U)).
	      * assume HzU: z :e U.
	        exact HzU.
	      * assume HznotU: z /:e U.
	        claim HzOut: z :e X :\: U.
	        { apply setminusI.
	          - exact HzX.
	          - exact HznotU. }
	        claim Hz0: apply_fun (apply_fun F j) z = 0.
	        { exact (Hjzero z HzOut). }
	        claim Hbad: False.
	        { claim Hzpos0: Rlt 0 0.
	          { rewrite <- Hz0 at 2.
	            exact Hzpos. }
	          exact ((not_Rlt_refl 0 H0R) Hzpos0). }
	        exact (FalseE Hbad (z :e U)). }
  claim HinjFmap:
    forall x y:set, x :e X -> y :e X -> apply_fun Fmap x = apply_fun Fmap y -> x = y.
  { let x y.
    assume HxX: x :e X.
    assume HyX: y :e X.
    assume Heq: apply_fun Fmap x = apply_fun Fmap y.
    apply (xm (x = y)).
    - assume Hxy: x = y.
      exact Hxy.
    - assume Hne: x <> y.
      claim Hexj: exists j:set, j :e J /\ apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
      { exact (separating_family_of_functions_separates_points X Tx F J x y HTx HT1 Hsep HxX HyX Hne). }
      apply Hexj.
      let j. assume Hjpair.
      claim HjJ: j :e J.
      { exact (andEL (j :e J) (apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y) Hjpair). }
      claim Hneq: apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
      { exact (andER (j :e J) (apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y) Hjpair). }
      claim HFmapDef: Fmap = diagonal_map X F J.
      { reflexivity. }
      claim HdiagDef: diagonal_map X F J =
        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
      { reflexivity. }
      claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
      { rewrite HFmapDef.
        rewrite HdiagDef.
        exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
      claim HFmapy: apply_fun Fmap y = graph J (fun j0:set => apply_fun (apply_fun F j0) y).
      { rewrite HFmapDef.
        rewrite HdiagDef.
        exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) y HyX). }
      claim HgraphEq:
        graph J (fun j0:set => apply_fun (apply_fun F j0) x) =
        graph J (fun j0:set => apply_fun (apply_fun F j0) y).
      { rewrite <- HFmapx at 1.
        rewrite <- HFmapy at 1.
        exact Heq. }
      claim Heqj:
        apply_fun (apply_fun F j) x = apply_fun (apply_fun F j) y.
      { claim HapplyEq:
          apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) x)) j =
          apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) y)) j.
        { rewrite HgraphEq.
          reflexivity. }
        claim Hleft:
          apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) x)) j =
          apply_fun (apply_fun F j) x.
        { rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) j HjJ).
          reflexivity. }
        claim Hright:
          apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) y)) j =
          apply_fun (apply_fun F j) y.
        { rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) y) j HjJ).
          reflexivity. }
        rewrite <- Hleft at 1.
        rewrite <- Hright at 1.
        exact HapplyEq. }
      claim Hbad: False.
      { exact (Hneq Heqj). }
      exact (FalseE Hbad (x = y)). }
  exact (embedding_of_from_local_refinement X Tx (power_real J) Ty0 Fmap HcontFmap HlocFmap HinjFmap). }

(** Identify the target with R^omega and use the Romega D-metric. **)
set Y := R_omega_space.
set Ty := R_omega_product_topology.
claim HYeq: power_real J = Y.
{ exact power_real_omega_eq_Romega_space. }
claim HTyeq: product_topology_full J (const_space_family J R R_standard_topology) = Ty.
{ reflexivity. }
claim HmTy: metric_on Y Romega_D_metric /\ Romega_D_metric_topology = Ty.
{ exact Romega_D_metric_induces_product_topology. }

(** Final step: pull back the Romega metric along the embedding homeomorphism onto its image. **)
(** This requires a general lemma: an embedding into a metrizable space makes the domain metrizable. **)
claim HFemb: embedding_of X Tx Y Ty Fmap.
{ rewrite <- HYeq.
  rewrite <- HTyeq.
  exact HFmap. }
claim HcontFmapY: continuous_map X Tx Y Ty Fmap.
{ exact (embedding_of_continuous X Tx Y Ty Fmap HFemb). }
claim HFmapfun: function_on Fmap X Y.
{ exact (continuous_map_function_on X Tx Y Ty Fmap HcontFmapY). }
claim HmY: metric_on Y Romega_D_metric.
{ exact (andEL (metric_on Y Romega_D_metric) (Romega_D_metric_topology = Ty) HmTy). }
set d := graph (setprod X X)
  (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
witness d.
apply andI.
- (** metric_on X d **)
  prove metric_on X d.
  prove function_on d (setprod X X) R /\
    (forall x y:set, x :e X -> y :e X -> apply_fun d (x,y) = apply_fun d (y,x)) /\
    (forall x:set, x :e X -> apply_fun d (x,x) = 0) /\
    (forall x y:set, x :e X -> y :e X ->
       ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y)) /\
    (forall x y z:set, x :e X -> y :e X -> z :e X ->
       ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
             (apply_fun d (x,z)))).
  apply andI.
  - (** first four axioms packed as (((A /\ B) /\ C) /\ D) **)
    apply andI.
    + (** ((A /\ B) /\ C) **)
      apply andI.
      * (** (A /\ B) **)
        apply andI.
        - (** function_on d (X×X) R **)
           claim HdYfun: function_on Romega_D_metric (setprod Y Y) R.
           { exact (metric_on_function_on Y Romega_D_metric HmY). }
           let pq. assume Hpq: pq :e (setprod X X).
           prove apply_fun d pq :e R.
           claim HxX: (pq 0) :e X.
           { exact (ap0_Sigma X (fun _:set => X) pq Hpq). }
           claim HyX: (pq 1) :e X.
           { exact (ap1_Sigma X (fun _:set => X) pq Hpq). }
           claim HfxY: apply_fun Fmap (pq 0) :e Y.
           { exact (HFmapfun (pq 0) HxX). }
           claim HfyY: apply_fun Fmap (pq 1) :e Y.
           { exact (HFmapfun (pq 1) HyX). }
           claim HfxyIn: (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1)) :e setprod Y Y.
           { exact (tuple_2_setprod_by_pair_Sigma Y Y
                    (apply_fun Fmap (pq 0)) (apply_fun Fmap (pq 1)) HfxY HfyY). }
           rewrite (apply_fun_graph (setprod X X)
                    (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                    pq Hpq).
           exact (HdYfun (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1)) HfxyIn).
        - (** symmetry **)
           let x y.
           assume HxX: x :e X.
           assume HyX: y :e X.
           claim HfxY: apply_fun Fmap x :e Y.
           { exact (HFmapfun x HxX). }
           claim HfyY: apply_fun Fmap y :e Y.
           { exact (HFmapfun y HyX). }
           claim HxyIn: (x,y) :e setprod X X.
           { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
           claim HyxIn: (y,x) :e setprod X X.
           { exact (tuple_2_setprod_by_pair_Sigma X X y x HyX HxX). }
           rewrite (apply_fun_graph (setprod X X)
                    (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                    (x,y) HxyIn).
           rewrite (apply_fun_graph (setprod X X)
                    (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                    (y,x) HyxIn).
           rewrite (tuple_2_0_eq x y).
           rewrite (tuple_2_1_eq x y).
           rewrite (tuple_2_0_eq y x).
           rewrite (tuple_2_1_eq y x).
           exact (metric_on_symmetric Y Romega_D_metric (apply_fun Fmap x) (apply_fun Fmap y) HmY HfxY HfyY).
      * (** diag = 0 **)
        let x. assume HxX: x :e X.
        claim HxxIn: (x,x) :e setprod X X.
        { exact (tuple_2_setprod_by_pair_Sigma X X x x HxX HxX). }
        claim HfxY: apply_fun Fmap x :e Y.
        { exact (HFmapfun x HxX). }
        rewrite (apply_fun_graph (setprod X X)
                 (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                 (x,x) HxxIn).
        rewrite (tuple_2_0_eq x x).
        rewrite (tuple_2_1_eq x x).
        exact (metric_on_diag_zero Y Romega_D_metric (apply_fun Fmap x) HmY HfxY).
    + (** nonneg and zero implies equality **)
      let x y.
      assume HxX: x :e X.
      assume HyX: y :e X.
      prove ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y).
      apply andI.
      * (** nonneg **)
        claim HxyIn: (x,y) :e setprod X X.
        { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
        claim HfxY: apply_fun Fmap x :e Y.
        { exact (HFmapfun x HxX). }
        claim HfyY: apply_fun Fmap y :e Y.
        { exact (HFmapfun y HyX). }
        rewrite (apply_fun_graph (setprod X X)
                 (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                 (x,y) HxyIn).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        exact (metric_on_nonneg Y Romega_D_metric (apply_fun Fmap x) (apply_fun Fmap y) HmY HfxY HfyY).
      * (** zero implies x=y **)
        assume Hd0: apply_fun d (x,y) = 0.
        set Im := image_of Fmap X.
        set Tim := subspace_topology Y Ty Im.
        claim Hhom: homeomorphism X Tx Im Tim Fmap.
        { exact (embedding_of_homeomorphism X Tx Y Ty Fmap HFemb). }
        claim Hinj: forall x1 x2:set, x1 :e X -> x2 :e X -> apply_fun Fmap x1 = apply_fun Fmap x2 -> x1 = x2.
        { exact (homeomorphism_injective X Tx Im Tim Fmap Hhom). }
        claim HxyIn: (x,y) :e setprod X X.
        { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
        claim HfxY: apply_fun Fmap x :e Y.
        { exact (HFmapfun x HxX). }
        claim HfyY: apply_fun Fmap y :e Y.
        { exact (HFmapfun y HyX). }
	        claim HfyEq0:
	          apply_fun Romega_D_metric (apply_fun Fmap x, apply_fun Fmap y) = 0.
	        { claim HdxyEq: apply_fun d (x,y) = apply_fun Romega_D_metric (apply_fun Fmap x, apply_fun Fmap y).
	          { claim Hddef: d = graph (setprod X X)
	              (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
	            { reflexivity. }
	            rewrite Hddef.
	            rewrite (apply_fun_graph (setprod X X)
	                     (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
	                     (x,y) HxyIn).
		            rewrite (tuple_2_0_eq x y).
		            rewrite (tuple_2_1_eq x y).
		            reflexivity. }
	          rewrite <- HdxyEq.
	          exact Hd0. }
        claim HfyEq: apply_fun Fmap x = apply_fun Fmap y.
        { exact (metric_on_zero_eq Y Romega_D_metric (apply_fun Fmap x) (apply_fun Fmap y) HmY HfxY HfyY HfyEq0). }
        exact (Hinj x y HxX HyX HfyEq).
  - (** triangle inequality **)
    let x y z.
    assume HxX: x :e X.
    assume HyX: y :e X.
    assume HzX: z :e X.
    prove ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z)))
               (apply_fun d (x,z))).
    claim HxyIn: (x,y) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x y HxX HyX). }
    claim HyzIn: (y,z) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X y z HyX HzX). }
    claim HxzIn: (x,z) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X x z HxX HzX). }
    claim HfxY: apply_fun Fmap x :e Y.
    { exact (HFmapfun x HxX). }
    claim HfyY: apply_fun Fmap y :e Y.
    { exact (HFmapfun y HyX). }
    claim HfzY: apply_fun Fmap z :e Y.
    { exact (HFmapfun z HzX). }
    rewrite (apply_fun_graph (setprod X X)
             (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
             (x,y) HxyIn).
    rewrite (apply_fun_graph (setprod X X)
             (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
             (y,z) HyzIn).
    rewrite (apply_fun_graph (setprod X X)
             (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
             (x,z) HxzIn).
    rewrite (tuple_2_0_eq x y).
    rewrite (tuple_2_1_eq x y).
    rewrite (tuple_2_0_eq y z).
    rewrite (tuple_2_1_eq y z).
    rewrite (tuple_2_0_eq x z).
    rewrite (tuple_2_1_eq x z).
    exact (metric_on_triangle Y Romega_D_metric (apply_fun Fmap x) (apply_fun Fmap y) (apply_fun Fmap z) HmY HfxY HfyY HfzY).
- (** metric_topology X d = Tx (pullback of Romega metric along the embedding) **)
  prove metric_topology X d = Tx.
  apply set_ext.
  - let U. assume HU: U :e metric_topology X d.
    prove U :e Tx.
    set Bx := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
    claim HUgen: U :e generated_topology X Bx.
    { claim Hdef: metric_topology X d = generated_topology X Bx.
      { reflexivity. }
      rewrite <- Hdef.
      exact HU. }
    claim HBxSub: forall b :e Bx, b :e Tx.
    { let b. assume Hb: b :e Bx.
      apply (famunionE_impred X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}) b Hb (b :e Tx)).
      let x0. assume Hx0X: x0 :e X.
      assume HbIn: b :e {open_ball X d x0 r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x0 r0) b HbIn (b :e Tx)).
      let r0. assume Hr0R: r0 :e R.
      assume Hr0pos: Rlt 0 r0.
      assume Hbeq: b = open_ball X d x0 r0.
      rewrite Hbeq.
      claim Hx0Y: apply_fun Fmap x0 :e Y.
      { exact (HFmapfun x0 Hx0X). }
      claim HballYTy: open_ball Y Romega_D_metric (apply_fun Fmap x0) r0 :e Ty.
      { claim HTyEq: Romega_D_metric_topology = Ty.
        { exact (andER (metric_on Y Romega_D_metric) (Romega_D_metric_topology = Ty) HmTy). }
        prove open_ball Y Romega_D_metric (apply_fun Fmap x0) r0 :e Ty.
        rewrite <- HTyEq.
        claim HMTdefY: metric_topology Y Romega_D_metric = Romega_D_metric_topology.
        { reflexivity. }
        rewrite <- HMTdefY.
        exact (open_ball_in_metric_topology Y Romega_D_metric (apply_fun Fmap x0) r0 HmY Hx0Y Hr0pos). }
      claim HballPre:
        preimage_of X Fmap (open_ball Y Romega_D_metric (apply_fun Fmap x0) r0) =
        open_ball X d x0 r0.
      { apply set_ext.
        - let z. assume Hz: z :e preimage_of X Fmap (open_ball Y Romega_D_metric (apply_fun Fmap x0) r0).
          prove z :e open_ball X d x0 r0.
          claim HzX: z :e X.
          { exact (SepE1 X (fun t:set => apply_fun Fmap t :e open_ball Y Romega_D_metric (apply_fun Fmap x0) r0) z Hz). }
          claim HfzBall: apply_fun Fmap z :e open_ball Y Romega_D_metric (apply_fun Fmap x0) r0.
          { exact (SepE2 X (fun t:set => apply_fun Fmap t :e open_ball Y Romega_D_metric (apply_fun Fmap x0) r0) z Hz). }
          claim HltY:
            Rlt (apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap z)) r0.
          { exact (SepE2 Y (fun y0:set => Rlt (apply_fun Romega_D_metric (apply_fun Fmap x0,y0)) r0) (apply_fun Fmap z) HfzBall). }
          claim HdEq: apply_fun d (x0,z) =
            apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap z).
          { claim HxzIn: (x0,z) :e setprod X X.
            { exact (tuple_2_setprod_by_pair_Sigma X X x0 z Hx0X HzX). }
            claim Hddef: d = graph (setprod X X)
              (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
            { reflexivity. }
            rewrite Hddef.
            rewrite (apply_fun_graph (setprod X X)
                     (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                     (x0,z) HxzIn).
            rewrite (tuple_2_0_eq x0 z).
            rewrite (tuple_2_1_eq x0 z).
            reflexivity. }
          claim Hlt: Rlt (apply_fun d (x0,z)) r0.
          { rewrite HdEq.
            exact HltY. }
          exact (open_ballI X d x0 r0 z HzX Hlt).
        - let z. assume Hz: z :e open_ball X d x0 r0.
          prove z :e preimage_of X Fmap (open_ball Y Romega_D_metric (apply_fun Fmap x0) r0).
          claim HzX: z :e X.
          { exact (SepE1 X (fun t:set => Rlt (apply_fun d (x0,t)) r0) z Hz). }
          claim HltX: Rlt (apply_fun d (x0,z)) r0.
          { exact (SepE2 X (fun t:set => Rlt (apply_fun d (x0,t)) r0) z Hz). }
          claim HdEq: apply_fun d (x0,z) =
            apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap z).
          { claim HxzIn: (x0,z) :e setprod X X.
            { exact (tuple_2_setprod_by_pair_Sigma X X x0 z Hx0X HzX). }
            claim Hddef: d = graph (setprod X X)
              (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
            { reflexivity. }
            rewrite Hddef.
            rewrite (apply_fun_graph (setprod X X)
                     (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                     (x0,z) HxzIn).
            rewrite (tuple_2_0_eq x0 z).
            rewrite (tuple_2_1_eq x0 z).
            reflexivity. }
          claim HzY: apply_fun Fmap z :e Y.
          { exact (HFmapfun z HzX). }
          claim HballMem:
            apply_fun Fmap z :e open_ball Y Romega_D_metric (apply_fun Fmap x0) r0.
          { claim HltY0: Rlt (apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap z)) r0.
            { rewrite <- HdEq.
              exact HltX. }
            exact (open_ballI Y Romega_D_metric (apply_fun Fmap x0) r0 (apply_fun Fmap z) HzY HltY0). }
          exact (SepI X (fun t:set => apply_fun Fmap t :e open_ball Y Romega_D_metric (apply_fun Fmap x0) r0) z HzX HballMem). }
      rewrite <- HballPre.
      exact (continuous_map_preimage X Tx Y Ty Fmap HcontFmapY (open_ball Y Romega_D_metric (apply_fun Fmap x0) r0) HballYTy). }
    claim Hinc: generated_topology X Bx c= Tx.
    { exact (generated_topology_finer_weak X Bx Tx HTx HBxSub). }
    exact (Hinc U HUgen).
  - let U. assume HU: U :e Tx.
    prove U :e metric_topology X d.
    set Bx := famunion X (fun x0:set => {open_ball X d x0 r|r :e R, Rlt 0 r}).
    claim Hdef: metric_topology X d = generated_topology X Bx.
    { reflexivity. }
    rewrite Hdef.
    claim HUsubX: U c= X.
    { exact (topology_elem_subset X Tx U HTx HU). }
    claim HUPower: U :e Power X.
    { exact (PowerI X U HUsubX). }
    set Im := image_of Fmap X.
    set Tim := subspace_topology Y Ty Im.
    claim Hhom: homeomorphism X Tx Im Tim Fmap.
    { exact (embedding_of_homeomorphism X Tx Y Ty Fmap HFemb). }
    claim Hexg:
      exists g:set, continuous_map Im Tim X Tx g /\
        (forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x) /\
        (forall y:set, y :e Im -> apply_fun Fmap (apply_fun g y) = y).
    { exact (homeomorphism_inverse_package X Tx Im Tim Fmap Hhom). }
    apply Hexg.
    let g. assume Hgpack.
    claim Hgpair1:
      continuous_map Im Tim X Tx g /\ (forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x).
    { exact (andEL (continuous_map Im Tim X Tx g /\ (forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x))
                   (forall y:set, y :e Im -> apply_fun Fmap (apply_fun g y) = y)
                   Hgpack). }
    claim Hgcont: continuous_map Im Tim X Tx g.
    { exact (andEL (continuous_map Im Tim X Tx g)
                   (forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x)
                   Hgpair1). }
    claim Hginv: forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x.
    { exact (andER (continuous_map Im Tim X Tx g)
                   (forall x:set, x :e X -> apply_fun g (apply_fun Fmap x) = x)
                   Hgpair1). }
    claim HUprop: forall x0 :e U, exists b0 :e Bx, x0 :e b0 /\ b0 c= U.
    { let x0. assume Hx0U: x0 :e U.
      claim Hx0X: x0 :e X.
      { exact (HUsubX x0 Hx0U). }
      claim Hfx0Y: apply_fun Fmap x0 :e Y.
      { exact (HFmapfun x0 Hx0X). }
      claim Hfx0Im: apply_fun Fmap x0 :e Im.
      { exact (ReplI X (fun x1:set => apply_fun Fmap x1) x0 Hx0X). }
      set V := preimage_of Im g U.
      claim HVopen: V :e Tim.
      { exact (continuous_map_preimage Im Tim X Tx g Hgcont U HU). }
      claim Hgx0U: apply_fun g (apply_fun Fmap x0) :e U.
      { rewrite (Hginv x0 Hx0X).
        exact Hx0U. }
      claim Hfx0V: apply_fun Fmap x0 :e V.
      { exact (SepI Im (fun y0:set => apply_fun g y0 :e U) (apply_fun Fmap x0) Hfx0Im Hgx0U). }
      claim HexW: exists W :e Ty, V = W :/\: Im.
      { exact (subspace_topologyE Y Ty Im V HVopen). }
      apply HexW.
      let W. assume HWpair.
      claim HWopen: W :e Ty.
      { exact (andEL (W :e Ty) (V = W :/\: Im) HWpair). }
      claim HVequiv: V = W :/\: Im.
      { exact (andER (W :e Ty) (V = W :/\: Im) HWpair). }
      claim Hfx0W: apply_fun Fmap x0 :e W.
      { claim Hfx0WIm: apply_fun Fmap x0 :e W :/\: Im.
        { rewrite <- HVequiv.
          exact Hfx0V. }
        exact (binintersectE1 W Im (apply_fun Fmap x0) Hfx0WIm). }
      claim HTyEq: Romega_D_metric_topology = Ty.
      { exact (andER (metric_on Y Romega_D_metric) (Romega_D_metric_topology = Ty) HmTy). }
      claim HWrtop: W :e Romega_D_metric_topology.
      { rewrite HTyEq.
        exact HWopen. }
      claim HMTdefY: metric_topology Y Romega_D_metric = Romega_D_metric_topology.
      { reflexivity. }
      claim HWmt: W :e metric_topology Y Romega_D_metric.
      { rewrite HMTdefY.
        exact HWrtop. }
      set By := famunion Y (fun y0:set => {open_ball Y Romega_D_metric y0 r|r :e R, Rlt 0 r}).
      claim HWgen: W :e generated_topology Y By.
      { claim HMTgen: metric_topology Y Romega_D_metric = generated_topology Y By.
        { reflexivity. }
        rewrite <- HMTgen.
        exact HWmt. }
      claim HWprop: forall y0 :e W, exists bY :e By, y0 :e bY /\ bY c= W.
      { exact (SepE2 (Power Y) (fun U0:set => forall y0 :e U0, exists bY :e By, y0 :e bY /\ bY c= U0) W HWgen). }
      apply (HWprop (apply_fun Fmap x0) Hfx0W).
      let bY. assume HbYpack.
      claim HbYIn: bY :e By.
      { exact (andEL (bY :e By) (apply_fun Fmap x0 :e bY /\ bY c= W) HbYpack). }
      claim HbYpair: apply_fun Fmap x0 :e bY /\ bY c= W.
      { exact (andER (bY :e By) (apply_fun Fmap x0 :e bY /\ bY c= W) HbYpack). }
      claim Hfx0bY: apply_fun Fmap x0 :e bY.
      { exact (andEL (apply_fun Fmap x0 :e bY) (bY c= W) HbYpair). }
      claim HbYsubW: bY c= W.
      { exact (andER (apply_fun Fmap x0 :e bY) (bY c= W) HbYpair). }
      apply (famunionE_impred Y (fun c0:set => {open_ball Y Romega_D_metric c0 r|r :e R, Rlt 0 r}) bY HbYIn
             (exists b0 :e Bx, x0 :e b0 /\ b0 c= U)).
      let c0. assume Hc0Y: c0 :e Y.
      assume HbYIn2: bY :e {open_ball Y Romega_D_metric c0 r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball Y Romega_D_metric c0 r0) bY HbYIn2
             (exists b0 :e Bx, x0 :e b0 /\ b0 c= U)).
      let r0. assume Hr0R: r0 :e R.
      assume Hr0pos: Rlt 0 r0.
      assume HbYeq: bY = open_ball Y Romega_D_metric c0 r0.
      claim Hfx0inBall: apply_fun Fmap x0 :e open_ball Y Romega_D_metric c0 r0.
      { rewrite <- HbYeq.
        exact Hfx0bY. }
      claim HballSubW: open_ball Y Romega_D_metric c0 r0 c= W.
      { rewrite <- HbYeq.
        exact HbYsubW. }
      claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\
        open_ball Y Romega_D_metric (apply_fun Fmap x0) s c= open_ball Y Romega_D_metric c0 r0.
      { exact (open_ball_refine_center Y Romega_D_metric c0 (apply_fun Fmap x0) r0 HmY Hc0Y Hfx0Y Hr0R Hr0pos Hfx0inBall). }
      apply Hexs.
      let s. assume Hspack.
      claim Hs1: s :e R /\ Rlt 0 s.
      { exact (andEL (s :e R /\ Rlt 0 s)
                     (open_ball Y Romega_D_metric (apply_fun Fmap x0) s c= open_ball Y Romega_D_metric c0 r0)
                     Hspack). }
      claim HsR: s :e R.
      { exact (andEL (s :e R) (Rlt 0 s) Hs1). }
      claim Hspos: Rlt 0 s.
      { exact (andER (s :e R) (Rlt 0 s) Hs1). }
      claim HsSubBall: open_ball Y Romega_D_metric (apply_fun Fmap x0) s c= open_ball Y Romega_D_metric c0 r0.
      { exact (andER (s :e R /\ Rlt 0 s)
                     (open_ball Y Romega_D_metric (apply_fun Fmap x0) s c= open_ball Y Romega_D_metric c0 r0)
                     Hspack). }
      claim HballSubW2: open_ball Y Romega_D_metric (apply_fun Fmap x0) s c= W.
      { exact (Subq_tra (open_ball Y Romega_D_metric (apply_fun Fmap x0) s)
                        (open_ball Y Romega_D_metric c0 r0) W HsSubBall HballSubW). }
      witness (open_ball X d x0 s).
      apply andI.
      - claim HbIn: open_ball X d x0 s :e {open_ball X d x0 r|r :e R, Rlt 0 r}.
        { exact (ReplSepI R (fun r1:set => Rlt 0 r1) (fun r1:set => open_ball X d x0 r1) s HsR Hspos). }
        exact (famunionI X (fun x1:set => {open_ball X d x1 r|r :e R, Rlt 0 r}) x0 (open_ball X d x0 s) Hx0X HbIn).
      - apply andI.
        + claim HdEq0: apply_fun d (x0,x0) =
            apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap x0).
          { claim HxxIn: (x0,x0) :e setprod X X.
            { exact (tuple_2_setprod_by_pair_Sigma X X x0 x0 Hx0X Hx0X). }
            claim Hddef: d = graph (setprod X X)
              (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
            { reflexivity. }
            rewrite Hddef.
            rewrite (apply_fun_graph (setprod X X)
                     (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                     (x0,x0) HxxIn).
            rewrite (tuple_2_0_eq x0 x0).
            rewrite (tuple_2_1_eq x0 x0).
            reflexivity. }
          claim Hdiag0: apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap x0) = 0.
          { exact (metric_on_diag_zero Y Romega_D_metric (apply_fun Fmap x0) HmY Hfx0Y). }
          claim Hlt0: Rlt (apply_fun d (x0,x0)) s.
          { rewrite HdEq0.
            rewrite Hdiag0.
            exact Hspos. }
          exact (open_ballI X d x0 s x0 Hx0X Hlt0).
        + let y. assume Hy: y :e open_ball X d x0 s.
          prove y :e U.
          claim HyX: y :e X.
          { exact (open_ballE1 X d x0 s y Hy). }
          claim HltX: Rlt (apply_fun d (x0,y)) s.
          { exact (open_ballE2 X d x0 s y Hy). }
          claim HfyY: apply_fun Fmap y :e Y.
          { exact (HFmapfun y HyX). }
          claim HdEq: apply_fun d (x0,y) =
            apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap y).
          { claim HxyIn: (x0,y) :e setprod X X.
            { exact (tuple_2_setprod_by_pair_Sigma X X x0 y Hx0X HyX). }
            claim Hddef: d = graph (setprod X X)
              (fun pq:set => apply_fun Romega_D_metric (apply_fun Fmap (pq 0), apply_fun Fmap (pq 1))).
            { reflexivity. }
            rewrite Hddef.
            rewrite (apply_fun_graph (setprod X X)
                     (fun pq0:set => apply_fun Romega_D_metric (apply_fun Fmap (pq0 0), apply_fun Fmap (pq0 1)))
                     (x0,y) HxyIn).
            rewrite (tuple_2_0_eq x0 y).
            rewrite (tuple_2_1_eq x0 y).
            reflexivity. }
          claim HballYmem: apply_fun Fmap y :e open_ball Y Romega_D_metric (apply_fun Fmap x0) s.
          { claim HltY: Rlt (apply_fun Romega_D_metric (apply_fun Fmap x0, apply_fun Fmap y)) s.
            { rewrite <- HdEq.
              exact HltX. }
            exact (open_ballI Y Romega_D_metric (apply_fun Fmap x0) s (apply_fun Fmap y) HfyY HltY). }
          claim HfyW: apply_fun Fmap y :e W.
          { exact (HballSubW2 (apply_fun Fmap y) HballYmem). }
          claim HfyIm: apply_fun Fmap y :e Im.
          { exact (ReplI X (fun x1:set => apply_fun Fmap x1) y HyX). }
          claim HfyV: apply_fun Fmap y :e V.
          { rewrite HVequiv.
            exact (binintersectI W Im (apply_fun Fmap y) HfyW HfyIm). }
          claim HgyU: apply_fun g (apply_fun Fmap y) :e U.
          { exact (SepE2 Im (fun y0:set => apply_fun g y0 :e U) (apply_fun Fmap y) HfyV). }
          rewrite <- (Hginv y HyX).
          exact HgyU. }
    exact (SepI (Power X) (fun U0:set => forall x0 :e U0, exists b0 :e Bx, x0 :e b0 /\ b0 c= U0) U HUPower HUprop).
Qed.

(** from §34 Theorem 34.2: Imbedding via separating family of functions **) 
(** LATEX VERSION: Embedding into product of reals via separating family of continuous functions. **)
Theorem embedding_via_functions : forall X Tx:set,
  topology_on X Tx -> one_point_sets_closed X Tx ->
  forall F J:set, separating_family_of_functions X Tx F J ->
    exists Fmap:set, embedding_of X Tx (power_real J) (product_topology_full J (const_space_family J R R_standard_topology)) Fmap.
let X Tx.
assume HTx: topology_on X Tx.
assume Hclosed: one_point_sets_closed X Tx.
let F J.
assume Hsep: separating_family_of_functions X Tx F J.
prove exists Fmap:set, embedding_of X Tx (power_real J) (product_topology_full J (const_space_family J R R_standard_topology)) Fmap.
(** TeX §34.2: define the diagonal map F(x) = (f_j(x))_{j in J}. **)
set Fmap := diagonal_map X F J.
witness Fmap.
(** Pending: show Fmap is a homeomorphism onto its image in R^J with the product topology, using the neighborhood separation property in separating_family_of_functions. **)
set Xi := const_space_family J R R_standard_topology.
set Ty := product_topology_full J Xi.
claim HcontFmap: continuous_map X Tx (power_real J) Ty Fmap.
{ (** continuity of the diagonal map into R^J with the product topology **)
  claim HpR: power_real J = product_space J Xi.
  { reflexivity. }
  claim HTyDef: Ty = product_topology_full J Xi.
  { reflexivity. }
  rewrite HpR.
  rewrite HTyDef.
  prove continuous_map X Tx (product_space J Xi) (product_topology_full J Xi) Fmap.
  claim HFmapDef: Fmap = diagonal_map X F J.
  { reflexivity. }
  claim HdiagDef: diagonal_map X F J =
    graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
  { reflexivity. }
  claim HsepCore:
    (topology_on X Tx /\ total_function_on F J (function_space X R)) /\
    (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0)).
  { exact (andEL ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
                  (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0)))
                 (forall x0:set, x0 :e X ->
                   forall U0:set, U0 :e Tx -> x0 :e U0 ->
                     exists j0:set, j0 :e J /\
                       Rlt 0 (apply_fun (apply_fun F j0) x0) /\
                       forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
                 Hsep). }
  claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
  { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
                 (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
                 HsepCore). }
  claim Htot: total_function_on F J (function_space X R).
  { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
  claim HfunPow: function_on Fmap X (power_real J).
  { rewrite HFmapDef.
    exact (diagonal_map_function_on_power_real X F J Htot). }
  claim Hfun: function_on Fmap X (product_space J Xi).
  { let x. assume HxX: x :e X.
    prove apply_fun Fmap x :e product_space J Xi.
    rewrite <- HpR.
    exact (HfunPow x HxX). }
  apply (xm (J = Empty)).
  - assume HJ0: J = Empty.
    rewrite HJ0.
    (** for Empty index set, the diagonal map is constant to Empty **)
    claim HTy0: topology_on (product_space Empty Xi) (product_topology_full Empty Xi).
    { claim HTdef: product_topology_full Empty Xi = countable_product_topology_subbasis Empty Xi.
      { reflexivity. }
      rewrite HTdef.
      exact (countable_product_topology_subbasis_empty_is_topology Xi). }
    claim HX0: product_space Empty Xi = {Empty}.
    { exact (product_space_empty_index Xi). }
    claim HEmptyY: Empty :e product_space Empty Xi.
    { rewrite HX0.
      exact (SingI Empty). }
    (** Align Xi with the Empty-index constant family if needed. **)
    claim HXieq: Xi = const_space_family Empty R R_standard_topology.
    { claim HXidef: Xi = const_space_family J R R_standard_topology.
      { reflexivity. }
      rewrite HXidef.
      rewrite HJ0.
      reflexivity. }
    claim HFmapConst: Fmap = const_fun X Empty.
    { claim HFmapE: Fmap = diagonal_map X F Empty.
      { rewrite HFmapDef.
        rewrite HJ0.
        reflexivity. }
      apply set_ext.
      - let p. assume Hp: p :e Fmap.
        prove p :e const_fun X Empty.
        claim HpDiag: p :e diagonal_map X F Empty.
        { rewrite <- HFmapE.
          exact Hp. }
        claim Hdiag0: diagonal_map X F Empty =
          graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { reflexivity. }
        claim HpGraph:
          p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { rewrite <- Hdiag0.
          exact HpDiag. }
        apply (ReplE_impred X
                 (fun x0:set => (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))
                 p HpGraph
                 (p :e const_fun X Empty)).
        let x0. assume Hx0X: x0 :e X.
	        assume Hpeq: p = (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	        claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) = Empty.
	        { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) =
	            {(j0, apply_fun (apply_fun F j0) x0) | j0 :e Empty}.
	          { reflexivity. }
	          rewrite HgraphDef.
	          exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x0))). }
	        rewrite Hpeq.
	        rewrite Hem.
	        exact (ReplI X (fun a0:set => (a0, Empty)) x0 Hx0X).
      - let p. assume Hp: p :e const_fun X Empty.
        prove p :e Fmap.
        claim HFmapE: Fmap = diagonal_map X F Empty.
        { rewrite HFmapDef.
          rewrite HJ0.
          reflexivity. }
        claim Hdiag0: diagonal_map X F Empty =
          graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { reflexivity. }
	        claim HpGraph:
	          p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
	        { apply (ReplE_impred X (fun a0:set => (a0, Empty)) p Hp
	                 (p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))).
		          let x2. assume Hx2X: x2 :e X.
		          assume Hpeq: p = (x2, Empty).
		          claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) = Empty.
		          { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) =
		              {(j0, apply_fun (apply_fun F j0) x2) | j0 :e Empty}.
		            { reflexivity. }
		          rewrite HgraphDef.
		          exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x2))). }
		          claim HpEq2: p = (x2, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2)).
		          { rewrite Hpeq.
		            rewrite Hem.
		            reflexivity. }
		          rewrite HpEq2.
		          exact (ReplI X
		                       (fun x1:set => (x1, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x1)))
		                       x2 Hx2X). }
	        claim HpDiag: p :e diagonal_map X F Empty.
	        { rewrite Hdiag0.
	          exact HpGraph. }
	        rewrite HFmapE.
	        exact HpDiag. }
    claim HdiagConst: diagonal_map X F Empty = const_fun X Empty.
    { apply set_ext.
      - let p. assume Hp: p :e diagonal_map X F Empty.
        prove p :e const_fun X Empty.
        claim Hdiag0: diagonal_map X F Empty =
          graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { reflexivity. }
        claim HpGraph:
          p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { rewrite <- Hdiag0.
          exact Hp. }
        apply (ReplE_impred X
                 (fun x0:set => (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))
                 p HpGraph
                 (p :e const_fun X Empty)).
        let x0. assume Hx0X: x0 :e X.
        assume Hpeq: p = (x0, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) = Empty.
        { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0) =
            {(j0, apply_fun (apply_fun F j0) x0) | j0 :e Empty}.
          { reflexivity. }
          rewrite HgraphDef.
          exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x0))). }
        rewrite Hpeq.
        rewrite Hem.
        exact (ReplI X (fun a0:set => (a0, Empty)) x0 Hx0X).
      - let p. assume Hp: p :e const_fun X Empty.
        prove p :e diagonal_map X F Empty.
        claim Hdiag0: diagonal_map X F Empty =
          graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { reflexivity. }
        claim HpGraph:
          p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)).
        { apply (ReplE_impred X (fun a0:set => (a0, Empty)) p Hp
                 (p :e graph X (fun x0:set => graph Empty (fun j0:set => apply_fun (apply_fun F j0) x0)))).
          let x2. assume Hx2X: x2 :e X.
          assume Hpeq: p = (x2, Empty).
          claim Hem: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) = Empty.
          { claim HgraphDef: graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2) =
              {(j0, apply_fun (apply_fun F j0) x2) | j0 :e Empty}.
            { reflexivity. }
            rewrite HgraphDef.
            exact (Repl_Empty (fun j0:set => (j0, apply_fun (apply_fun F j0) x2))). }
          claim HpEq2: p = (x2, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x2)).
          { rewrite Hpeq.
            rewrite Hem.
            reflexivity. }
          rewrite HpEq2.
          exact (ReplI X
                       (fun x1:set => (x1, graph Empty (fun j0:set => apply_fun (apply_fun F j0) x1)))
                       x2 Hx2X). }
        rewrite Hdiag0.
        exact HpGraph. }
    (** Use the constancy of Fmap for continuity into the empty product. **)
    claim Hconst:
      continuous_map X Tx (product_space Empty Xi) (product_topology_full Empty Xi) (const_fun X Empty).
    { exact (const_fun_continuous X Tx (product_space Empty Xi) (product_topology_full Empty Xi) Empty
               HTx HTy0 HEmptyY). }
    rewrite HdiagConst.
    rewrite <- HXieq.
    exact Hconst.
		  - assume HJne: J <> Empty.
		    (** use the cylinder subbasis criterion for continuity **)
	    claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
	    { let i. assume HiJ: i :e J.
      claim Hset: space_family_set Xi i = R.
      { exact (space_family_set_const_space_family J R R_standard_topology i HiJ). }
      claim Htop: space_family_topology Xi i = R_standard_topology.
      { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
      rewrite Hset.
      rewrite Htop.
      exact R_standard_topology_is_topology. }
    claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
    { exact (product_subbasis_full_subbasis_on J Xi HJne HcompTop). }
    claim HcontCoord: forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0).
    { exact (andER (topology_on X Tx /\ total_function_on F J (function_space X R))
                   (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
                   HsepCore). }
    apply (continuous_map_from_subbasis X Tx (product_space J Xi) (product_subbasis_full J Xi) Fmap HTx Hfun HSsub).
    let s. assume HsS: s :e product_subbasis_full J Xi.
    prove preimage_of X Fmap s :e Tx.
    set Fam := (fun i0:set => {product_cylinder J Xi i0 U0|U0 :e space_family_topology Xi i0}).
    claim HsFam: s :e (\/_ i0 :e J, Fam i0).
    { exact HsS. }
    apply (famunionE_impred J Fam s HsFam (preimage_of X Fmap s :e Tx)).
    let i. assume HiJ: i :e J.
    assume HsFi: s :e Fam i.
    claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder J Xi i U.
    { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder J Xi i U0) s HsFi). }
    apply HexU.
    let U. assume HUand: U :e space_family_topology Xi i /\ s = product_cylinder J Xi i U.
    claim HUtop: U :e space_family_topology Xi i.
    { exact (andEL (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
    claim Hseq: s = product_cylinder J Xi i U.
    { exact (andER (U :e space_family_topology Xi i) (s = product_cylinder J Xi i U) HUand). }
    rewrite Hseq.
    claim Hconti: continuous_map X Tx R R_standard_topology (apply_fun F i).
    { exact (HcontCoord i HiJ). }
    claim HUstd: U :e R_standard_topology.
    { claim Htopi: space_family_topology Xi i = R_standard_topology.
      { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
      rewrite <- Htopi.
      exact HUtop. }
    claim HpreEq: preimage_of X Fmap (product_cylinder J Xi i U) = preimage_of X (apply_fun F i) U.
    { apply set_ext.
      - let x. assume HxPre: x :e preimage_of X Fmap (product_cylinder J Xi i U).
        prove x :e preimage_of X (apply_fun F i) U.
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxPre). }
        claim HfxCyl: apply_fun Fmap x :e product_cylinder J Xi i U.
        { exact (SepE2 X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxPre). }
        claim HcylProp:
          i :e J /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun Fmap x) i :e U.
        { exact (SepE2 (product_space J Xi)
                       (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                       (apply_fun Fmap x) HfxCyl). }
        claim HcoordU: apply_fun (apply_fun Fmap x) i :e U.
        { claim H12: i :e J /\ U :e space_family_topology Xi i.
          { exact (andEL (i :e J /\ U :e space_family_topology Xi i)
                         (apply_fun (apply_fun Fmap x) i :e U)
                         HcylProp). }
          exact (andER (i :e J /\ U :e space_family_topology Xi i)
                       (apply_fun (apply_fun Fmap x) i :e U)
                       HcylProp). }
        claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
        { rewrite HFmapDef.
          rewrite HdiagDef.
          exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
        claim HcoordEq: apply_fun (apply_fun Fmap x) i = apply_fun (apply_fun F i) x.
        { rewrite HFmapx.
          rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
          reflexivity. }
	        claim HfiU: apply_fun (apply_fun F i) x :e U.
	        { rewrite <- HcoordEq.
	          exact HcoordU. }
	        exact (SepI X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxX HfiU).
      - let x. assume HxPre: x :e preimage_of X (apply_fun F i) U.
        prove x :e preimage_of X Fmap (product_cylinder J Xi i U).
        claim HxX: x :e X.
        { exact (SepE1 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
        claim HfiU: apply_fun (apply_fun F i) x :e U.
        { exact (SepE2 X (fun x0:set => apply_fun (apply_fun F i) x0 :e U) x HxPre). }
        claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
        { rewrite HFmapDef.
          rewrite HdiagDef.
          exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
        claim HcoordEq: apply_fun (apply_fun Fmap x) i = apply_fun (apply_fun F i) x.
        { rewrite HFmapx.
          rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) i HiJ).
          reflexivity. }
        claim HcoordU: apply_fun (apply_fun Fmap x) i :e U.
        { rewrite HcoordEq.
          exact HfiU. }
        claim Hpred: i :e J /\ U :e space_family_topology Xi i /\ apply_fun (apply_fun Fmap x) i :e U.
        { apply andI.
          - apply andI.
            + exact HiJ.
            + exact HUtop.
          - exact HcoordU. }
        claim HfxCyl: apply_fun Fmap x :e product_cylinder J Xi i U.
        { exact (SepI (product_space J Xi)
                      (fun f0:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f0 i :e U)
                      (apply_fun Fmap x)
                      (Hfun x HxX)
                      Hpred). }
        exact (SepI X (fun x0:set => apply_fun Fmap x0 :e product_cylinder J Xi i U) x HxX HfxCyl). }
    rewrite HpreEq.
    exact (continuous_map_preimage X Tx R R_standard_topology (apply_fun F i) Hconti U HUstd). }
claim HlocFmap:
  forall x U:set, x :e X -> U :e Tx -> x :e U ->
    exists V:set, V :e Ty /\ apply_fun Fmap x :e V /\ preimage_of X Fmap V c= U.
{ let x. let U.
  assume HxX: x :e X.
  assume HU: U :e Tx.
  assume HxU: x :e U.
  (** extract the neighborhood-separation clause from Hsep **)
  claim HsepCore:
    ((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
     (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))).
  { exact (andEL (((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
                   (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))))
                 (forall x0:set, x0 :e X ->
                   forall U0:set, U0 :e Tx -> x0 :e U0 ->
                     exists j0:set, j0 :e J /\
                       Rlt 0 (apply_fun (apply_fun F j0) x0) /\
                       forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
                 Hsep). }
  claim Hneigh:
    forall x0:set, x0 :e X ->
      forall U0:set, U0 :e Tx -> x0 :e U0 ->
        exists j0:set, j0 :e J /\
          Rlt 0 (apply_fun (apply_fun F j0) x0) /\
          forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0.
  { exact (andER (((topology_on X Tx /\ total_function_on F J (function_space X R)) /\
                   (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))))
                 (forall x0:set, x0 :e X ->
                   forall U0:set, U0 :e Tx -> x0 :e U0 ->
                     exists j0:set, j0 :e J /\
                       Rlt 0 (apply_fun (apply_fun F j0) x0) /\
                       forall x1:set, x1 :e X :\: U0 -> apply_fun (apply_fun F j0) x1 = 0)
                 Hsep). }

  claim Hexj:
    exists j0:set, j0 :e J /\
      Rlt 0 (apply_fun (apply_fun F j0) x) /\
      forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j0) x1 = 0.
  { exact (Hneigh x HxX U HU HxU). }
  apply Hexj.
  let j. assume Hjpack.
  claim Hj12: j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x).
  { exact (andEL (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
                 (forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0)
                 Hjpack). }
  claim HjJ: j :e J.
  { exact (andEL (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
  claim Hjpos: Rlt 0 (apply_fun (apply_fun F j) x).
  { exact (andER (j :e J) (Rlt 0 (apply_fun (apply_fun F j) x)) Hj12). }
  claim Hjzero:
    forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0.
  { exact (andER (j :e J /\ Rlt 0 (apply_fun (apply_fun F j) x))
                 (forall x1:set, x1 :e X :\: U -> apply_fun (apply_fun F j) x1 = 0)
                 Hjpack). }

  (** define the cylinder V = {f in R^J | f(j) in (0,∞)} **)
  set V := product_cylinder J Xi j (open_ray_upper R 0).
  witness V.
  apply andI.
  - apply andI.
    + (** V is open in the product topology Ty **)
      claim HTyDef: Ty = product_topology_full J Xi.
      { reflexivity. }
      rewrite HTyDef.
      claim HprodDef: product_topology_full J Xi =
        generated_topology_from_subbasis (product_space J Xi) (product_subbasis_full J Xi).
      { reflexivity. }
      rewrite HprodDef.
      claim HJne: J <> Empty.
      { exact (elem_implies_nonempty J j HjJ). }
      claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
      { let i. assume HiJ: i :e J.
        claim Hset: space_family_set Xi i = R.
        { exact (space_family_set_const_space_family J R R_standard_topology i HiJ). }
        claim Htop: space_family_topology Xi i = R_standard_topology.
        { exact (space_family_topology_const_space_family J R R_standard_topology i HiJ). }
        rewrite Hset.
        rewrite Htop.
        exact R_standard_topology_is_topology. }
      claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
      { exact (product_subbasis_full_subbasis_on J Xi HJne HcompTop). }
      claim H0R: 0 :e R.
      { exact real_0. }
      claim HopenRay: open_ray_upper R 0 :e R_standard_topology.
      { rewrite <- standard_topology_is_order_topology.
        claim HsRay: open_ray_upper R 0 :e open_rays_subbasis R.
        { exact (open_ray_upper_in_open_rays_subbasis R 0 H0R). }
        exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R 0) HsRay). }
      claim Htopj: space_family_topology Xi j = R_standard_topology.
      { exact (space_family_topology_const_space_family J R R_standard_topology j HjJ). }
      claim HUtop: open_ray_upper R 0 :e space_family_topology Xi j.
      { rewrite Htopj.
        exact HopenRay. }
      claim HVsub: V :e product_subbasis_full J Xi.
      { set Fam := (fun i0:set => {product_cylinder J Xi i0 U0|U0 :e space_family_topology Xi i0}).
        claim HVfam: V :e Fam j.
        { exact (ReplI (space_family_topology Xi j) (fun U0:set => product_cylinder J Xi j U0)
                       (open_ray_upper R 0) HUtop). }
        exact (famunionI J Fam j V HjJ HVfam). }
      exact (subbasis_elem_open_in_generated_from_subbasis (product_space J Xi) (product_subbasis_full J Xi) V HSsub HVsub).
    + (** Fmap(x) lies in V **)
      claim HFmapDef: Fmap = diagonal_map X F J.
      { reflexivity. }
      claim HdiagDef: diagonal_map X F J =
        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
      { reflexivity. }
      claim Hfx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
      { rewrite HFmapDef.
        rewrite HdiagDef.
        exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
      claim Hval:
        apply_fun (apply_fun Fmap x) j :e open_ray_upper R 0.
      { rewrite Hfx.
        rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) j HjJ).
        claim HxjR: apply_fun (apply_fun F j) x :e R.
        { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
          { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
                         (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
                         HsepCore). }
          claim Htot: total_function_on F J (function_space X R).
          { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
          claim HfjFS: apply_fun F j :e function_space X R.
          { exact (total_function_on_apply_fun_in_Y F J (function_space X R) j Htot HjJ). }
          claim HfjFun: function_on (apply_fun F j) X R.
          { exact (SepE2 (Power (setprod X R)) (fun f0:set => function_on f0 X R) (apply_fun F j) HfjFS). }
          exact (HfjFun x HxX). }
        claim Hord: order_rel R 0 (apply_fun (apply_fun F j) x).
        { exact (Rlt_implies_order_rel_R 0 (apply_fun (apply_fun F j) x) Hjpos). }
        exact (SepI R (fun t:set => order_rel R 0 t) (apply_fun (apply_fun F j) x) HxjR Hord). }
      claim HVdef: V =
        {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
      { reflexivity. }
      rewrite HVdef.
      (** need Fmap(x) ∈ product_space J Xi; use diagonal_map_function_on_power_real **)
      claim Htot: total_function_on F J (function_space X R).
      { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
        { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
                       (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
                       HsepCore). }
        exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
      claim HfunF: function_on Fmap X (power_real J).
      { rewrite HFmapDef.
        exact (diagonal_map_function_on_power_real X F J Htot). }
      claim HpR: power_real J = product_space J Xi.
      { reflexivity. }
      claim HfxProd: apply_fun Fmap x :e product_space J Xi.
      { rewrite <- HpR.
        exact (HfunF x HxX). }
      apply (SepI (product_space J Xi)
                  (fun f0:set => j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0)
                  (apply_fun Fmap x) HfxProd).
      apply andI.
      - apply andI.
        + exact HjJ.
        + (** open_ray_upper R 0 open in the j-th factor **)
          claim H0R: 0 :e R.
          { exact real_0. }
          claim HopenRay: open_ray_upper R 0 :e R_standard_topology.
          { rewrite <- standard_topology_is_order_topology.
            claim HsRay: open_ray_upper R 0 :e open_rays_subbasis R.
            { exact (open_ray_upper_in_open_rays_subbasis R 0 H0R). }
            exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R 0) HsRay). }
          claim Htopj: space_family_topology Xi j = R_standard_topology.
          { exact (space_family_topology_const_space_family J R R_standard_topology j HjJ). }
          rewrite Htopj.
          exact HopenRay.
      - (** coordinate condition **)
        claim Hcoord: apply_fun (apply_fun Fmap x) j :e open_ray_upper R 0.
        { exact Hval. }
        exact Hcoord.
  - (** preimage of V is contained in U **)
    let z. assume HzPre: z :e preimage_of X Fmap V.
    prove z :e U.
      claim HzX: z :e X.
      { exact (SepE1 X (fun x0:set => apply_fun Fmap x0 :e V) z HzPre). }
      claim HzV: apply_fun Fmap z :e V.
      { exact (SepE2 X (fun x0:set => apply_fun Fmap x0 :e V) z HzPre). }
      claim HVdef: V =
        {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
      { reflexivity. }
      claim HzV2: apply_fun Fmap z :e {f0 :e product_space J Xi | j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0}.
      { rewrite <- HVdef.
        exact HzV. }
      claim Hcore: j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0.
      { exact (SepE2 (product_space J Xi)
                     (fun f0:set => j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j /\ apply_fun f0 j :e open_ray_upper R 0)
                     (apply_fun Fmap z) HzV2). }
      claim Hzcoord: apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0.
      { claim H12: j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j.
        { exact (andEL (j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j)
                       (apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0)
                       Hcore). }
        exact (andER (j :e J /\ open_ray_upper R 0 :e space_family_topology Xi j)
                     (apply_fun (apply_fun Fmap z) j :e open_ray_upper R 0)
                     Hcore). }
      (** turn this into Rlt 0 (f_j z) and use the vanishing clause **)
      claim HFmapDef: Fmap = diagonal_map X F J.
      { reflexivity. }
      claim HdiagDef: diagonal_map X F J =
        graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
      { reflexivity. }
      claim HFmapz: apply_fun Fmap z = graph J (fun j0:set => apply_fun (apply_fun F j0) z).
      { rewrite HFmapDef.
        rewrite HdiagDef.
        exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) z HzX). }
      claim Hzcoord2: apply_fun (apply_fun F j) z :e open_ray_upper R 0.
      { claim HcoordEq: apply_fun (apply_fun Fmap z) j = apply_fun (apply_fun F j) z.
        { rewrite HFmapz.
          rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) z) j HjJ).
          reflexivity. }
      rewrite <- HcoordEq.
      exact Hzcoord. }
      claim HzR: apply_fun (apply_fun F j) z :e R.
      { claim HtopTot: topology_on X Tx /\ total_function_on F J (function_space X R).
        { exact (andEL (topology_on X Tx /\ total_function_on F J (function_space X R))
                       (forall j0:set, j0 :e J -> continuous_map X Tx R R_standard_topology (apply_fun F j0))
                       HsepCore). }
        claim Htot: total_function_on F J (function_space X R).
        { exact (andER (topology_on X Tx) (total_function_on F J (function_space X R)) HtopTot). }
        claim HfjFS: apply_fun F j :e function_space X R.
        { exact (total_function_on_apply_fun_in_Y F J (function_space X R) j Htot HjJ). }
        claim HfjFun: function_on (apply_fun F j) X R.
        { exact (SepE2 (Power (setprod X R)) (fun f0:set => function_on f0 X R) (apply_fun F j) HfjFS). }
        exact (HfjFun z HzX). }
      claim H0R: 0 :e R.
      { exact real_0. }
      claim Hzord: order_rel R 0 (apply_fun (apply_fun F j) z).
      { exact (SepE2 R (fun t:set => order_rel R 0 t) (apply_fun (apply_fun F j) z) Hzcoord2). }
      claim Hzpos: Rlt 0 (apply_fun (apply_fun F j) z).
      { exact (order_rel_R_implies_Rlt 0 (apply_fun (apply_fun F j) z) Hzord). }
      apply (xm (z :e U)).
      * assume HzU: z :e U.
        exact HzU.
      * assume HznotU: z /:e U.
        claim HzOut: z :e X :\: U.
        { apply setminusI.
          - exact HzX.
          - exact HznotU. }
        claim Hz0: apply_fun (apply_fun F j) z = 0.
        { exact (Hjzero z HzOut). }
        claim Hbad: False.
        { claim Hzpos0: Rlt 0 0.
          { rewrite <- Hz0 at 2.
            exact Hzpos. }
          exact ((not_Rlt_refl 0 H0R) Hzpos0). }
        exact (FalseE Hbad (z :e U)). }
claim HinjFmap:
  forall x y:set, x :e X -> y :e X -> apply_fun Fmap x = apply_fun Fmap y -> x = y.
{ let x y.
  assume HxX: x :e X.
  assume HyX: y :e X.
  assume Heq: apply_fun Fmap x = apply_fun Fmap y.
  apply (xm (x = y)).
  - assume Hxy: x = y.
    exact Hxy.
  - assume Hxyne: x <> y.
    (** obtain a coordinate j with f_j(x) <> f_j(y) **)
    claim Hexj: exists j:set, j :e J /\ apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
    { exact (separating_family_of_functions_separates_points X Tx F J x y HTx Hclosed Hsep HxX HyX Hxyne). }
    apply Hexj.
    let j. assume Hjpair.
    claim HjJ: j :e J.
    { exact (andEL (j :e J) (apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y) Hjpair). }
    claim Hneq: apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y.
    { exact (andER (j :e J) (apply_fun (apply_fun F j) x <> apply_fun (apply_fun F j) y) Hjpair). }

    (** compute the diagonal map values and use equality to deduce coordinate equality **)
    claim HFmapDef: Fmap = diagonal_map X F J.
    { reflexivity. }
    claim HdiagDef: diagonal_map X F J =
      graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)).
    { reflexivity. }
    claim HFmapx: apply_fun Fmap x = graph J (fun j0:set => apply_fun (apply_fun F j0) x).
    { rewrite HFmapDef.
      rewrite HdiagDef.
      exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) x HxX). }
    claim HFmapy: apply_fun Fmap y = graph J (fun j0:set => apply_fun (apply_fun F j0) y).
    { rewrite HFmapDef.
      rewrite HdiagDef.
      exact (apply_fun_graph X (fun x0:set => graph J (fun j0:set => apply_fun (apply_fun F j0) x0)) y HyX). }
    claim HgraphEq:
      graph J (fun j0:set => apply_fun (apply_fun F j0) x) =
      graph J (fun j0:set => apply_fun (apply_fun F j0) y).
    { rewrite <- HFmapx at 1.
      rewrite <- HFmapy at 1.
      exact Heq. }
    claim Heqj:
      apply_fun (apply_fun F j) x = apply_fun (apply_fun F j) y.
    { claim HapplyEq:
        apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) x)) j =
        apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) y)) j.
      { rewrite HgraphEq.
        reflexivity. }
      claim Hleft:
        apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) x)) j =
        apply_fun (apply_fun F j) x.
      { rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) x) j HjJ).
        reflexivity. }
      claim Hright:
        apply_fun (graph J (fun j0:set => apply_fun (apply_fun F j0) y)) j =
        apply_fun (apply_fun F j) y.
      { rewrite (apply_fun_graph J (fun j0:set => apply_fun (apply_fun F j0) y) j HjJ).
        reflexivity. }
      rewrite <- Hleft at 1.
      rewrite <- Hright at 1.
      exact HapplyEq. }
    claim Hbad: False.
    { exact (Hneq Heqj). }
    exact (FalseE Hbad (x = y)). }
exact (embedding_of_from_local_refinement X Tx (power_real J) Ty Fmap HcontFmap HlocFmap HinjFmap).
Qed.

(** from §34 Corollary 34.3: completely regular iff embeds in [0,1]^J **) 
(** LATEX VERSION: Completely regular iff embeds into a Tychonoff cube [0,1]^J. **)
Theorem completely_regular_iff_embeds_in_cube : forall X Tx:set,
  (completely_regular_space X Tx <->
    exists J:set, exists Fmap:set, embedding_of X Tx (unit_interval_power J) (product_topology_full J (const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval))) Fmap).
let X Tx.
prove (completely_regular_space X Tx <->
    exists J:set, exists Fmap:set, embedding_of X Tx (unit_interval_power J) (product_topology_full J (const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval))) Fmap).
apply iffI.
- assume Hcr: completely_regular_space X Tx.
  (** Roadmap: TeX §34.3 forward direction. Use all continuous maps X -> [0,1] as coordinates. **)
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (one_point_sets_closed X Tx /\
                  forall x:set, x :e X ->
                    forall F:set, closed_in X Tx F -> x /:e F ->
                      exists f:set,
                        continuous_map X Tx R R_standard_topology f /\
                        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
                 Hcr). }
  claim Hrest:
    one_point_sets_closed X Tx /\
    forall x:set, x :e X ->
      forall F:set, closed_in X Tx F -> x /:e F ->
        exists f:set,
          continuous_map X Tx R R_standard_topology f /\
          apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1.
  { exact (andER (topology_on X Tx)
                 (one_point_sets_closed X Tx /\
                  forall x:set, x :e X ->
                    forall F:set, closed_in X Tx F -> x /:e F ->
                      exists f:set,
                        continuous_map X Tx R R_standard_topology f /\
                        apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
                 Hcr). }
  claim HT1: one_point_sets_closed X Tx.
  { exact (andEL (one_point_sets_closed X Tx)
                 (forall x:set, x :e X ->
                   forall F:set, closed_in X Tx F -> x /:e F ->
                     exists f:set,
                       continuous_map X Tx R R_standard_topology f /\
                       apply_fun f x = 0 /\ forall y:set, y :e F -> apply_fun f y = 1)
                 Hrest). }

  set J := {f :e function_space X unit_interval | continuous_map X Tx unit_interval unit_interval_topology f}.
  set F := graph J (fun f:set => f).
  set Fmap := diagonal_map X F J.
  witness J.
  witness Fmap.

  set Xi := const_space_family J unit_interval unit_interval_topology.
  claim HTyEq:
    product_topology_full J (const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval))
    = product_topology_full J Xi.
  { reflexivity. }
  rewrite HTyEq.
  set Ty := product_topology_full J Xi.

  (** J is nonempty: it contains a constant function **)
  claim HJne: J <> Empty.
  { claim H0I: 0 :e unit_interval.
    { exact zero_in_unit_interval. }
    claim HTui: topology_on unit_interval unit_interval_topology.
    { exact unit_interval_topology_on. }
    claim HconstCont: continuous_map X Tx unit_interval unit_interval_topology (const_fun X 0).
    { exact (const_fun_continuous X Tx unit_interval unit_interval_topology 0 HTx HTui H0I). }
    claim HconstFS: const_fun X 0 :e function_space X unit_interval.
    { set f0 := const_fun X 0.
      claim Hsub: f0 c= setprod X unit_interval.
      { let q. assume Hq: q :e f0.
        prove q :e setprod X unit_interval.
        apply (ReplE_impred X (fun a0:set => (a0,0)) q Hq (q :e setprod X unit_interval)).
        let a. assume HaX: a :e X.
        assume Heq: q = (a,0).
        rewrite Heq.
        exact (tuple_2_setprod_by_pair_Sigma X unit_interval a 0 HaX H0I). }
      claim Hpow: f0 :e Power (setprod X unit_interval).
      { exact (PowerI (setprod X unit_interval) f0 Hsub). }
      claim Hfun: function_on f0 X unit_interval.
      { let x. assume HxX: x :e X.
        prove apply_fun f0 x :e unit_interval.
        claim Happ: apply_fun f0 x = 0.
        { exact (const_fun_apply X 0 x HxX). }
        rewrite Happ.
        exact H0I. }
      exact (SepI (Power (setprod X unit_interval)) (fun f0:set => function_on f0 X unit_interval) f0 Hpow Hfun). }
    claim HconstJ: const_fun X 0 :e J.
    { apply (SepI (function_space X unit_interval)
                 (fun f0:set => continuous_map X Tx unit_interval unit_interval_topology f0)
                 (const_fun X 0)
                 HconstFS
                 HconstCont). }
    assume HJ0: J = Empty.
    claim Hbad: const_fun X 0 :e Empty.
    { rewrite <- HJ0 at 2.
      exact HconstJ. }
    exact (EmptyE (const_fun X 0) Hbad). }

  (** totality of F:J->function_space X unit_interval **)
  claim HtotF: total_function_on F J (function_space X unit_interval).
  { claim HFdef: F = graph J (fun f0:set => f0).
    { reflexivity. }
    rewrite HFdef.
    apply (total_function_on_graph J (function_space X unit_interval) (fun f0:set => f0)).
    let f0. assume HfJ: f0 :e J.
    exact (SepE1 (function_space X unit_interval)
                 (fun f1:set => continuous_map X Tx unit_interval unit_interval_topology f1)
                 f0
                 HfJ). }

  (** coordinate maps are continuous **)
  claim HcoordCont: forall j:set, j :e J -> continuous_map X Tx unit_interval unit_interval_topology (apply_fun F j).
  { let j. assume HjJ: j :e J.
    claim HFdef: F = graph J (fun f0:set => f0).
    { reflexivity. }
    rewrite HFdef.
    rewrite (apply_fun_graph J (fun f0:set => f0) j HjJ).
    exact (SepE2 (function_space X unit_interval)
                 (fun f1:set => continuous_map X Tx unit_interval unit_interval_topology f1)
                 j
                 HjJ). }

  (** continuity of the diagonal map into the cube **)
  claim HcontFmap:
    continuous_map X Tx (unit_interval_power J) (product_topology_full J Xi) Fmap.
  { exact (diagonal_map_continuous_unit_interval_power X Tx F J HTx HJne HtotF HcoordCont). }

  (** local refinement property **)
  claim Hloc:
    forall x U:set, x :e X -> U :e Tx -> x :e U ->
      exists V:set, V :e (product_topology_full J Xi) /\ apply_fun Fmap x :e V /\ preimage_of X Fmap V c= U.
  { let x U.
    assume HxX: x :e X.
    assume HU: U :e Tx.
    assume HxU: x :e U.
	    (** pick a separator h with h(x)=1 and h=0 outside U, then use a cylinder neighborhood **)
	    claim Hexh: exists h:set,
	      h :e function_space X unit_interval /\
	      continuous_map X Tx unit_interval unit_interval_topology h /\
	      apply_fun h x = 1 /\
	      forall y:set, y :e X :\: U -> apply_fun h y = 0.
	    { exact (completely_regular_space_open_separator_unit_interval_in_function_space X Tx x U Hcr HxX HU HxU). }
	    apply Hexh.
	    let h. assume Hhpack:
	      h :e function_space X unit_interval /\
	      continuous_map X Tx unit_interval unit_interval_topology h /\
	      apply_fun h x = 1 /\
	      forall y:set, y :e X :\: U -> apply_fun h y = 0.
	    claim Hhpair: (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1.
	    { exact (andEL ((h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1)
	                   (forall y:set, y :e X :\: U -> apply_fun h y = 0)
	                   Hhpack). }
	    claim Hhzero: forall y:set, y :e X :\: U -> apply_fun h y = 0.
	    { exact (andER ((h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1)
	                   (forall y:set, y :e X :\: U -> apply_fun h y = 0)
	                   Hhpack). }
	    claim Hhpair2: h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h.
	    { exact (andEL (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h)
	                   (apply_fun h x = 1)
	                   Hhpair). }
	    claim HhFS: h :e function_space X unit_interval.
	    { exact (andEL (h :e function_space X unit_interval)
	                   (continuous_map X Tx unit_interval unit_interval_topology h)
	                   Hhpair2). }
	    claim Hhcont: continuous_map X Tx unit_interval unit_interval_topology h.
	    { exact (andER (h :e function_space X unit_interval)
	                   (continuous_map X Tx unit_interval unit_interval_topology h)
	                   Hhpair2). }
	    claim Hhx1: apply_fun h x = 1.
	    { exact (andER (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h)
	                   (apply_fun h x = 1)
	                   Hhpair). }
	    claim HhJ: h :e J.
	    { exact (SepI (function_space X unit_interval)
	                  (fun f0:set => continuous_map X Tx unit_interval unit_interval_topology f0)
	                  h
                  HhFS
                  Hhcont). }
    (** open neighborhood of 1 avoiding 0 in unit_interval_topology **)
    set V0 := (open_interval 0 2) :/\: unit_interval.
    claim HV0openR: open_interval 0 2 :e R_standard_topology.
    { claim HRlt02: Rlt 0 2.
      { exact (RltI 0 2 real_0 real_2 SNoLt_0_2). }
      exact (open_interval_in_R_standard_topology 0 2 HRlt02). }
	    claim HV0: V0 :e unit_interval_topology.
	    { exact (subspace_topologyI R R_standard_topology unit_interval (open_interval 0 2) HV0openR). }
	    set V := product_cylinder J Xi h V0.
	    claim HXiTop: forall i0:set, i0 :e J ->
	      topology_on (space_family_set Xi i0) (space_family_topology Xi i0).
	    { let i0. assume Hi0J: i0 :e J.
	      prove topology_on (space_family_set Xi i0) (space_family_topology Xi i0).
	      rewrite (space_family_set_const_space_family J unit_interval unit_interval_topology i0 Hi0J).
	      rewrite (space_family_topology_const_space_family J unit_interval unit_interval_topology i0 Hi0J).
	      exact unit_interval_topology_on. }
		    claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
		    { exact (product_subbasis_full_subbasis_on J Xi HJne HXiTop). }
		    witness V.
		    apply andI.
		    - apply andI.
		      + (** V is open in the product topology **)
		        claim HVsub: V :e product_subbasis_full J Xi.
		        { set Fam := (fun j0:set => {product_cylinder J Xi j0 U0|U0 :e space_family_topology Xi j0}).
		          claim HV0top: V0 :e space_family_topology Xi h.
		          { rewrite (space_family_topology_const_space_family J unit_interval unit_interval_topology h HhJ).
		            exact HV0. }
		          claim HVFam: V :e Fam h.
		          { exact (ReplI (space_family_topology Xi h) (fun U0:set => product_cylinder J Xi h U0) V0 HV0top). }
		          exact (famunionI J Fam h V HhJ HVFam). }
		        exact (generated_topology_from_subbasis_contains_subbasis_elem
		          (product_space J Xi) (product_subbasis_full J Xi) V HSsub HVsub).
		      + (** Fmap x lies in the cylinder V **)
		        claim HYdef: unit_interval_power J = product_space J Xi.
		        { reflexivity. }
		        claim HfunPow0: function_on Fmap X (unit_interval_power J).
		        { exact (diagonal_map_function_on_unit_interval_power X F J HtotF). }
		        claim HfunPow: function_on Fmap X (product_space J Xi).
		        { rewrite <- HYdef.
		          exact HfunPow0. }
		        claim HFmapxY: apply_fun Fmap x :e product_space J Xi.
		        { exact (HfunPow x HxX). }
		        claim HcylDef: product_cylinder J Xi h V0 =
		          {f0 :e product_space J Xi | h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun f0 h :e V0}.
		        { reflexivity. }
		        rewrite HcylDef.
		        apply (SepI (product_space J Xi)
		          (fun f0:set => h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun f0 h :e V0)
		          (apply_fun Fmap x)
		          HFmapxY).
		        apply andI.
		        - apply andI.
		          + exact HhJ.
		          + claim HV0top: V0 :e space_family_topology Xi h.
		            { rewrite (space_family_topology_const_space_family J unit_interval unit_interval_topology h HhJ).
		              exact HV0. }
		            exact HV0top.
		        - (** coordinate value is 1, hence in V0 **)
		          claim HcoordEq: apply_fun (apply_fun Fmap x) h = apply_fun h x.
		          { rewrite (diagonal_map_coord_apply X F J x h HxX HhJ).
		            claim HFdef: F = graph J (fun f0:set => f0).
		            { reflexivity. }
		            rewrite HFdef.
		            rewrite (apply_fun_graph J (fun f0:set => f0) h HhJ).
		            reflexivity. }
		          claim H1V0: 1 :e V0.
		          { apply (binintersectI (open_interval 0 2) unit_interval 1).
		            - (** 1 is in (0,2) **)
		              claim HdefOI: open_interval 0 2 = {t :e R|Rlt 0 t /\ Rlt t 2}.
		              { reflexivity. }
		              rewrite HdefOI.
		              claim H1R: 1 :e R.
		              { claim HRdef: R = real.
		                { reflexivity. }
		                rewrite HRdef.
		                exact real_1. }
		              apply (SepI R (fun t:set => Rlt 0 t /\ Rlt t 2) 1 H1R).
		              apply andI.
		              + exact (RltI 0 1 real_0 real_1 SNoLt_0_1).
		              + exact (RltI 1 2 real_1 real_2 SNoLt_1_2).
		            - exact one_in_unit_interval. }
		          rewrite HcoordEq.
		          rewrite Hhx1.
		          exact H1V0.
		    - (** preimage of V is contained in U **)
		      let y. assume HyPre: y :e preimage_of X Fmap V.
		      prove y :e U.
		      claim HyX: y :e X.
		      { exact (SepE1 X (fun y0:set => apply_fun Fmap y0 :e V) y HyPre). }
		      claim HFmapyV: apply_fun Fmap y :e V.
		      { exact (SepE2 X (fun y0:set => apply_fun Fmap y0 :e V) y HyPre). }
		      apply (xm (y :e U)).
		      + assume HyU: y :e U.
		        exact HyU.
		      + assume HyNotU: y /:e U.
		        apply FalseE.
		        prove False.
		        claim HyOut: y :e X :\: U.
		        { exact (setminusI X U y HyX HyNotU). }
		        claim Hhy0: apply_fun h y = 0.
		        { exact (Hhzero y HyOut). }
		        claim HcylDef: product_cylinder J Xi h V0 =
		          {f0 :e product_space J Xi | h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun f0 h :e V0}.
		        { reflexivity. }
		        claim HFmapyCyl: apply_fun Fmap y :e product_cylinder J Xi h V0.
		        { exact HFmapyV. }
			        claim HFmapyCyl2: apply_fun Fmap y :e {f0 :e product_space J Xi | h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun f0 h :e V0}.
			        { rewrite <- HcylDef.
			          exact HFmapyCyl. }
		        claim HyProp: h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun (apply_fun Fmap y) h :e V0.
		        { exact (SepE2 (product_space J Xi)
		                       (fun f0:set => h :e J /\ V0 :e space_family_topology Xi h /\ apply_fun f0 h :e V0)
		                       (apply_fun Fmap y)
		                       HFmapyCyl2). }
		        claim HcoordIn: apply_fun (apply_fun Fmap y) h :e V0.
		        { exact (andER (h :e J /\ V0 :e space_family_topology Xi h)
		                       (apply_fun (apply_fun Fmap y) h :e V0)
		                       HyProp). }
		        claim HcoordEqy: apply_fun (apply_fun Fmap y) h = apply_fun h y.
		        { rewrite (diagonal_map_coord_apply X F J y h HyX HhJ).
		          claim HFdef: F = graph J (fun f0:set => f0).
		          { reflexivity. }
		          rewrite HFdef.
		          rewrite (apply_fun_graph J (fun f0:set => f0) h HhJ).
		          reflexivity. }
				        claim H0V0: 0 :e V0.
				        { rewrite <- Hhy0 at 1.
				          rewrite <- HcoordEqy at 1.
				          exact HcoordIn. }
		        claim H0open: 0 :e open_interval 0 2.
		        { exact (binintersectE1 (open_interval 0 2) unit_interval 0 H0V0). }
			        claim HdefOI: open_interval 0 2 = {t :e R|Rlt 0 t /\ Rlt t 2}.
			        { reflexivity. }
			        claim H0cond: Rlt 0 0 /\ Rlt 0 2.
			        { exact (SepE2 R (fun t:set => Rlt 0 t /\ Rlt t 2) 0 H0open). }
		        claim Hbad: Rlt 0 0.
		        { exact (andEL (Rlt 0 0) (Rlt 0 2) H0cond). }
		        exact ((not_Rlt_refl 0 real_0) Hbad).
		  }

  (** injectivity of the diagonal map **)
  claim Hinj:
    forall x y:set, x :e X -> y :e X -> apply_fun Fmap x = apply_fun Fmap y -> x = y.
  { let x y.
    assume HxX: x :e X.
    assume HyX: y :e X.
    assume Heq: apply_fun Fmap x = apply_fun Fmap y.
    apply (xm (x = y)).
    - assume Hxy: x = y.
      exact Hxy.
    - assume Hxyne: x <> y.
      set U := X :\: {y}.
      claim HyCl: closed_in X Tx {y}.
      { exact (andER (topology_on X Tx)
                     (forall z:set, z :e X -> closed_in X Tx {z})
                     HT1 y HyX). }
      claim HUopen: U :e Tx.
      { claim HUin: open_in X Tx U.
        { exact (open_of_closed_complement X Tx {y} HyCl). }
        exact (open_in_elem X Tx U HUin). }
      claim HxU: x :e U.
      { apply setminusI.
        - exact HxX.
        - assume HxY: x :e {y}.
          claim Hxy: x = y.
          { exact (SingE y x HxY). }
          exact (Hxyne Hxy). }
	      claim Hexh: exists h:set,
	        h :e function_space X unit_interval /\
	        continuous_map X Tx unit_interval unit_interval_topology h /\
	        apply_fun h x = 1 /\
	        forall z:set, z :e X :\: U -> apply_fun h z = 0.
	      { exact (completely_regular_space_open_separator_unit_interval_in_function_space X Tx x U Hcr HxX HUopen HxU). }
	      apply Hexh.
	      let h. assume Hhpack:
	        h :e function_space X unit_interval /\
	        continuous_map X Tx unit_interval unit_interval_topology h /\
	        apply_fun h x = 1 /\
	        forall z:set, z :e X :\: U -> apply_fun h z = 0.
	      claim Hhpair: (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1.
	      { exact (andEL ((h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1)
	                     (forall z:set, z :e X :\: U -> apply_fun h z = 0)
	                     Hhpack). }
	      claim Hhzero: forall z:set, z :e X :\: U -> apply_fun h z = 0.
	      { exact (andER ((h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h) /\ apply_fun h x = 1)
	                     (forall z:set, z :e X :\: U -> apply_fun h z = 0)
	                     Hhpack). }
	      claim Hhpair2: h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h.
	      { exact (andEL (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h)
	                     (apply_fun h x = 1)
	                     Hhpair). }
	      claim HhFS: h :e function_space X unit_interval.
	      { exact (andEL (h :e function_space X unit_interval)
	                     (continuous_map X Tx unit_interval unit_interval_topology h)
	                     Hhpair2). }
	      claim Hhcont: continuous_map X Tx unit_interval unit_interval_topology h.
	      { exact (andER (h :e function_space X unit_interval)
	                     (continuous_map X Tx unit_interval unit_interval_topology h)
	                     Hhpair2). }
	      claim Hhx1: apply_fun h x = 1.
	      { exact (andER (h :e function_space X unit_interval /\ continuous_map X Tx unit_interval unit_interval_topology h)
	                     (apply_fun h x = 1)
	                     Hhpair). }
	      claim HhJ: h :e J.
	      { exact (SepI (function_space X unit_interval)
	                    (fun f0:set => continuous_map X Tx unit_interval unit_interval_topology f0)
	                    h
	                    HhFS
	                    Hhcont). }
	      (** finish injection by evaluating the equal product points at coordinate h **)
	      apply FalseE.
	      prove False.
	      claim HyNotU: y /:e U.
	      { assume HyU: y :e U.
	        claim HyNotSing: y /:e {y}.
	        { exact (setminusE2 X {y} y HyU). }
	        exact (HyNotSing (SingI y)). }
	      claim HyOut: y :e X :\: U.
	      { exact (setminusI X U y HyX HyNotU). }
	      claim Hhy0: apply_fun h y = 0.
	      { exact (Hhzero y HyOut). }
	      claim HcoordEq: apply_fun (apply_fun Fmap x) h = apply_fun (apply_fun Fmap y) h.
	      { rewrite Heq.
	        reflexivity. }
	      claim HcoordEqx: apply_fun (apply_fun Fmap x) h = apply_fun h x.
	      { rewrite (diagonal_map_coord_apply X F J x h HxX HhJ).
	        claim HFdef: F = graph J (fun f0:set => f0).
	        { reflexivity. }
	        rewrite HFdef.
	        rewrite (apply_fun_graph J (fun f0:set => f0) h HhJ).
	        reflexivity. }
	      claim HcoordEqy: apply_fun (apply_fun Fmap y) h = apply_fun h y.
	      { rewrite (diagonal_map_coord_apply X F J y h HyX HhJ).
	        claim HFdef: F = graph J (fun f0:set => f0).
	        { reflexivity. }
	        rewrite HFdef.
	        rewrite (apply_fun_graph J (fun f0:set => f0) h HhJ).
	        reflexivity. }
	      claim HhEq: apply_fun h x = apply_fun h y.
	      { rewrite <- HcoordEqx.
	        rewrite <- HcoordEqy.
	        exact HcoordEq. }
	      claim H10: 1 = 0.
	      { rewrite <- Hhx1 at 1.
	        rewrite <- Hhy0.
	        exact HhEq. }
	      claim Hpos01: Rlt 0 1.
	      { exact (RltI 0 1 real_0 real_1 SNoLt_0_1). }
	      claim Hbad: Rlt 0 0.
	      { rewrite <- H10 at 2.
	        exact Hpos01. }
	      exact ((not_Rlt_refl 0 real_0) Hbad).
	  }

  exact (embedding_of_from_local_refinement X Tx (unit_interval_power J) (product_topology_full J Xi) Fmap
         HcontFmap Hloc Hinj).
- assume Hemb:
    exists J:set, exists Fmap:set,
      embedding_of X Tx (unit_interval_power J)
        (product_topology_full J (const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval))) Fmap.
  (** TODO: TeX §34.3 (←): subspaces of cubes are completely regular, and complete regularity transports along homeomorphisms. **)
  apply Hemb.
  let J. assume HJ.
  apply HJ.
  let Fmap. assume HFmap.
  prove completely_regular_space X Tx.
  set Y0 := unit_interval_power J.
  set Ty0 := product_topology_full J (const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval)).
  set Im := image_of Fmap X.
  set Tim := subspace_topology Y0 Ty0 Im.
  claim Hcont: continuous_map X Tx Y0 Ty0 Fmap.
  { exact (andEL (continuous_map X Tx Y0 Ty0 Fmap)
                 (homeomorphism X Tx Im Tim Fmap)
                 HFmap). }
  claim Hhom: homeomorphism X Tx Im Tim Fmap.
  { exact (andER (continuous_map X Tx Y0 Ty0 Fmap)
                 (homeomorphism X Tx Im Tim Fmap)
                 HFmap). }
  claim HTx: topology_on X Tx.
  { exact (continuous_map_topology_dom X Tx Y0 Ty0 Fmap Hcont). }
  claim Hfun: function_on Fmap X Y0.
  { exact (continuous_map_function_on X Tx Y0 Ty0 Fmap Hcont). }
  claim HImsubY0: Im c= Y0.
  { exact (image_of_sub_codomain Fmap X Y0 X Hfun (Subq_ref X)). }

  (** [0,1]^J is completely regular, since [0,1] is completely regular and products preserve complete regularity. **)
  claim HprodClause:
    forall I Xi:set, completely_regular_spaces_family I Xi ->
      completely_regular_space (product_space I Xi) (product_topology_full I Xi).
  { exact (andER (forall Z:set, Z c= X -> completely_regular_space X Tx -> completely_regular_space Z (subspace_topology X Tx Z))
                 (forall I Xi:set, completely_regular_spaces_family I Xi -> completely_regular_space (product_space I Xi) (product_topology_full I Xi))
                 (completely_regular_subspace_product X Tx HTx)). }
  set Xi := const_space_family J unit_interval (subspace_topology R R_standard_topology unit_interval).
  claim Hfam: completely_regular_spaces_family J Xi.
  { let i. assume HiJ: i :e J.
    prove completely_regular_space (product_component Xi i) (product_component_topology Xi i).
    rewrite (product_component_def Xi i).
    rewrite (product_component_topology_def Xi i).
    rewrite (const_space_family_apply J unit_interval (subspace_topology R R_standard_topology unit_interval) i HiJ).
    rewrite (tuple_2_0_eq unit_interval (subspace_topology R R_standard_topology unit_interval)).
    rewrite (tuple_2_1_eq unit_interval (subspace_topology R R_standard_topology unit_interval)).
    claim HUiEq: unit_interval_topology = subspace_topology R R_standard_topology unit_interval.
    { reflexivity. }
    rewrite <- HUiEq.
    exact unit_interval_completely_regular. }
  claim HcrY0: completely_regular_space Y0 Ty0.
  { claim HYeq: Y0 = product_space J Xi.
    { reflexivity. }
    rewrite HYeq.
    exact (HprodClause J Xi Hfam). }

  (** The image is a subspace of the cube, hence completely regular. **)
  claim HTy0: topology_on Y0 Ty0.
  { exact (completely_regular_space_topology_on Y0 Ty0 HcrY0). }
  claim HsubClause:
    forall Z:set, Z c= Y0 -> completely_regular_space Y0 Ty0 ->
      completely_regular_space Z (subspace_topology Y0 Ty0 Z).
  { exact (andEL (forall Z:set, Z c= Y0 -> completely_regular_space Y0 Ty0 -> completely_regular_space Z (subspace_topology Y0 Ty0 Z))
                 (forall I Xi0:set, completely_regular_spaces_family I Xi0 -> completely_regular_space (product_space I Xi0) (product_topology_full I Xi0))
                 (completely_regular_subspace_product Y0 Ty0 HTy0)). }
  claim HcrIm: completely_regular_space Im Tim.
  { exact (HsubClause Im HImsubY0 HcrY0). }
  exact (homeomorphism_preserves_completely_regular X Tx Im Tim Fmap Hhom HcrIm).
Qed.

(** helper moved earlier: metric Cauchy/completeness primitives are needed by uniform-limit infrastructure used in §35 **)
(** helper: Cauchy sequence in a metric space **)
(** LATEX VERSION: Cauchy sequence definition (metric). **)
(** FIXED: cauchy_sequence requires sequence_on seq X and uses N c= m and N c= n (eventuality) plus eps :e R and Rlt 0 eps; metric is applied as apply_fun d (seq(m), seq(n)). **)
Definition cauchy_sequence : set -> set -> set -> prop := fun X d seq =>
  metric_on X d /\ sequence_on seq X /\
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.

(** Helper: cauchy_sequence plus totality of the metric graph on X×X **)
(** from §43 Definition: Cauchy sequence in a metric space **)
(** LATEX VERSION: A sequence x_n is Cauchy if for every ε>0 there exists N such that d(x_m,x_n)<ε for m,n>N. **)
Definition cauchy_sequence_total : set -> set -> set -> prop := fun X d seq =>
  metric_on_total X d /\ sequence_on seq X /\
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.

Theorem cauchy_sequence_total_imp : forall X d seq:set,
  cauchy_sequence_total X d seq -> cauchy_sequence X d seq.
let X d seq. assume H.
claim Hleft: metric_on_total X d /\ sequence_on seq X.
{ exact (andEL (metric_on_total X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               H). }
claim Hmt: metric_on_total X d.
{ exact (andEL (metric_on_total X d) (sequence_on seq X) Hleft). }
claim Hseq: sequence_on seq X.
{ exact (andER (metric_on_total X d) (sequence_on seq X) Hleft). }
claim Htail: forall eps:set, eps :e R /\ Rlt 0 eps ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.
{ exact (andER (metric_on_total X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               H). }
prove metric_on X d /\ sequence_on seq X /\
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.
apply andI.
- apply andI.
  + exact (metric_on_total_imp_metric_on X d Hmt).
  + exact Hseq.
- exact Htail.
Qed.

(** from §43 Definition: complete metric space **)
(** LATEX VERSION: Completeness: every Cauchy sequence converges. **)
(** FIXED: complete_metric_space quantifies over seq with sequence_on seq X, matching cauchy_sequence. **)
Definition complete_metric_space : set -> set -> prop := fun X d =>
  metric_on X d /\
  forall seq:set, sequence_on seq X -> cauchy_sequence X d seq ->
    exists x:set, converges_to X (metric_topology X d) seq x.

(** Helper: complete_metric_space plus totality of the metric graph on X×X **)
(** from §43 Definition: complete metric space (total metric graph variant) **)
(** LATEX VERSION: A metric space is complete if every Cauchy sequence converges. **)
Definition complete_metric_space_total : set -> set -> prop := fun X d =>
  metric_on_total X d /\
  forall seq:set, sequence_on seq X -> cauchy_sequence_total X d seq ->
    exists x:set, converges_to X (metric_topology X d) seq x.

(** helper: continuity at a point into a topological space **)
(** LATEX VERSION: f is continuous at x if every neighborhood of f(x) contains the image of some neighborhood of x. **)
Definition continuous_at_map : set -> set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty f x =>
    function_on f X Y /\ x :e X /\
    forall V:set, V :e Ty -> apply_fun f x :e V ->
      exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V.

(** helper: pointwise convergence of a sequence of maps into a metric space **)
(** LATEX VERSION: f_n converges pointwise to f if for each x and each epsilon, eventually d(f_n(x),f(x))<epsilon. **)
Definition pointwise_limit_metric : set -> set -> set -> set -> set -> prop :=
  fun X Y d fn f =>
    forall x:set, x :e X ->
      forall eps:set, eps :e R -> Rlt 0 eps ->
        exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n ->
            Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps.

(** helper: uniform convergence of a sequence of maps into a metric space **)
(** LATEX VERSION: f_n converges uniformly to f if for each eps>0 there exists N such that d(f_n(x),f(x))<eps for all n>=N and all x in X. **)
Definition uniform_limit_metric : set -> set -> set -> set -> set -> prop :=
  fun X Y d fn f =>
    forall eps:set, eps :e R -> Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n ->
          forall x:set, x :e X ->
            Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps.

(** helper: uniform convergence implies pointwise convergence **)
(** LATEX VERSION: If f_n converges uniformly to f then f_n converges pointwise to f. **)
Theorem uniform_limit_metric_imp_pointwise_limit_metric : forall X Y d fn f:set,
  uniform_limit_metric X Y d fn f ->
  pointwise_limit_metric X Y d fn f.
let X Y d fn f.
assume Hunif: uniform_limit_metric X Y d fn f.
prove pointwise_limit_metric X Y d fn f.
let x. assume HxX: x :e X.
let eps. assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
apply (Hunif eps HepsR HepsPos).
let N. assume HNpair:
  N :e omega /\
  forall n:set, n :e omega -> N c= n ->
    forall x0:set, x0 :e X ->
      Rlt (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun f x0)) eps.
witness N.
apply andI.
- exact (andEL
    (N :e omega)
    (forall n:set, n :e omega -> N c= n ->
      forall x0:set, x0 :e X ->
        Rlt (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun f x0)) eps)
    HNpair).
- let n. assume HnO: n :e omega.
  assume HNn: N c= n.
  prove Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps.
  claim Htail:
    forall n0:set, n0 :e omega -> N c= n0 ->
      forall x0:set, x0 :e X ->
        Rlt (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun f x0)) eps.
  { exact (andER
      (N :e omega)
      (forall n0:set, n0 :e omega -> N c= n0 ->
        forall x0:set, x0 :e X ->
          Rlt (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun f x0)) eps)
      HNpair). }
  exact (Htail n HnO HNn x HxX).
Qed.

(** helper: a limit of a sequence in A lies in closure_of A **)
(** LATEX VERSION: If x_n converges to x and all x_n lie in A, then x lies in cl(A). **)
Theorem converges_to_imp_in_closure_of_terms : forall X Tx A seq x:set,
  converges_to X Tx seq x ->
  (forall n:set, n :e omega -> apply_fun seq n :e A) ->
  x :e closure_of X Tx A.
let X Tx A seq x.
assume Hxlim: converges_to X Tx seq x.
assume HseqA: forall n:set, n :e omega -> apply_fun seq n :e A.
prove x :e closure_of X Tx A.
claim HxX: x :e X.
{ exact (converges_to_point_in_X X Tx seq x Hxlim). }
claim Hnbhd: forall U:set, U :e Tx -> x :e U -> U :/\: A <> Empty.
{ let U. assume HU: U :e Tx.
  assume HxU: x :e U.
  claim HexN: exists N:set, N :e omega /\
    forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  { exact (converges_to_neighborhoods X Tx seq x Hxlim U HU HxU). }
  apply HexN.
  let N. assume HNpair: N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  claim HNO: N :e omega.
  { exact (andEL (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
  claim Htail: forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  { exact (andER (N :e omega) (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U) HNpair). }
  claim HNinU: apply_fun seq N :e U.
  { exact (Htail N HNO (Subq_ref N)). }
  claim HNinA: apply_fun seq N :e A.
  { exact (HseqA N HNO). }
  claim HNinUA: apply_fun seq N :e U :/\: A.
  { exact (binintersectI U A (apply_fun seq N) HNinU HNinA). }
  exact (elem_implies_nonempty (U :/\: A) (apply_fun seq N) HNinUA). }
exact (SepI X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: A <> Empty) x HxX Hnbhd).
Qed.

(** helper: closed sets contain limits of sequences **)
(** LATEX VERSION: If A is closed and x_n in A converges to x then x is in A. **)
Theorem converges_to_closed_in_contains_limit : forall X Tx A seq x:set,
  topology_on X Tx -> A c= X ->
  closed_in X Tx A ->
  converges_to X Tx seq x ->
  (forall n:set, n :e omega -> apply_fun seq n :e A) ->
  x :e A.
let X Tx A seq x.
assume HTx: topology_on X Tx.
assume HAsub: A c= X.
assume HAclosed: closed_in X Tx A.
assume Hxlim: converges_to X Tx seq x.
assume HseqA: forall n:set, n :e omega -> apply_fun seq n :e A.
prove x :e A.
claim Hxcl: x :e closure_of X Tx A.
{ exact (converges_to_imp_in_closure_of_terms X Tx A seq x Hxlim HseqA). }
claim HclEq: closure_of X Tx A = A.
{ exact (closed_closure_eq X Tx A HTx HAclosed). }
rewrite <- HclEq.
exact Hxcl.
Qed.

(** helper: uniform convergence gives metric convergence at each point **)
(** LATEX VERSION: If f_n converges uniformly to f, then for each x the sequence n |-> f_n(x) converges to f(x) in the metric sense. **)
Theorem uniform_limit_metric_imp_sequence_converges_metric_at_point : forall X Y d fn f x:set,
  metric_on Y d ->
  function_on fn omega (function_space X Y) ->
  function_on f X Y ->
  x :e X ->
  uniform_limit_metric X Y d fn f ->
  sequence_converges_metric Y d (graph omega (fun n:set => apply_fun (apply_fun fn n) x)) (apply_fun f x).
let X Y d fn f x.
assume Hd: metric_on Y d.
assume Hfn: function_on fn omega (function_space X Y).
assume Hf: function_on f X Y.
assume HxX: x :e X.
assume Hunif: uniform_limit_metric X Y d fn f.
set seqx := graph omega (fun n:set => apply_fun (apply_fun fn n) x).
prove sequence_converges_metric Y d seqx (apply_fun f x).
prove (((metric_on Y d /\ sequence_on seqx Y) /\ apply_fun f x :e Y) /\
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n ->
        Rlt (apply_fun d (apply_fun seqx n, apply_fun f x)) eps).
apply andI.
- apply andI.
  + apply andI.
    * exact Hd.
    * prove sequence_on seqx Y.
      let n. assume HnO: n :e omega.
      prove apply_fun seqx n :e Y.
      claim Hseqxdef: seqx = graph omega (fun n0:set => apply_fun (apply_fun fn n0) x).
      { reflexivity. }
      rewrite (apply_fun_of_graph_eq seqx omega (fun n0:set => apply_fun (apply_fun fn n0) x) n Hseqxdef HnO).
      claim HfnnFS: apply_fun fn n :e function_space X Y.
      { exact (Hfn n HnO). }
      claim Hfnn_on: function_on (apply_fun fn n) X Y.
      { exact (SepE2 (Power (setprod X Y)) (fun f0:set => function_on f0 X Y) (apply_fun fn n) HfnnFS). }
      exact (Hfnn_on x HxX).
  + exact (Hf x HxX).
- let eps. assume Heps: eps :e R /\ Rlt 0 eps.
  claim HepsR: eps :e R.
  { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
  claim HepsPos: Rlt 0 eps.
  { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
  apply (Hunif eps HepsR HepsPos).
  let N. assume HNpair: N :e omega /\
    forall n:set, n :e omega -> N c= n ->
      forall x0:set, x0 :e X ->
        Rlt (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun f x0)) eps.
  witness N.
  apply andI.
  * exact (andEL
      (N :e omega)
      (forall n:set, n :e omega -> N c= n ->
        forall x0:set, x0 :e X ->
          Rlt (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun f x0)) eps)
      HNpair).
  * let n. assume HnO: n :e omega.
    assume HNn: N c= n.
    prove Rlt (apply_fun d (apply_fun seqx n, apply_fun f x)) eps.
    claim Htail:
      forall n0:set, n0 :e omega -> N c= n0 ->
        forall x0:set, x0 :e X ->
          Rlt (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun f x0)) eps.
    { exact (andER
        (N :e omega)
        (forall n0:set, n0 :e omega -> N c= n0 ->
          forall x0:set, x0 :e X ->
            Rlt (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun f x0)) eps)
        HNpair). }
    claim Hseqxdef: seqx = graph omega (fun n0:set => apply_fun (apply_fun fn n0) x).
    { reflexivity. }
    rewrite (apply_fun_of_graph_eq seqx omega (fun n0:set => apply_fun (apply_fun fn n0) x) n Hseqxdef HnO).
    exact (Htail n HnO HNn x HxX).
Qed.

(** helper: metric topology neighborhoods contain a centered ball **)
(** LATEX VERSION: In a metric topology, every open neighborhood of x contains an open ball centered at x. **)
Theorem metric_topology_neighborhood_contains_ball : forall X d x U:set,
  metric_on X d ->
  x :e X ->
  U :e metric_topology X d ->
  x :e U ->
  exists r:set, r :e R /\ (Rlt 0 r /\ open_ball X d x r c= U).
let X d x U.
assume Hm: metric_on X d.
assume HxX: x :e X.
assume HU: U :e metric_topology X d.
assume HxU: x :e U.
set B0 := famunion X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r}).
claim Hdef: metric_topology X d = generated_topology X B0.
{ reflexivity. }
claim HUgen: U :e generated_topology X B0.
{ rewrite <- Hdef.
  exact HU. }
claim HUcond: forall y :e U, exists b0 :e B0, y :e b0 /\ b0 c= U.
{ exact (SepE2 (Power X)
               (fun U0:set => forall y:set, y :e U0 -> exists b0 :e B0, y :e b0 /\ b0 c= U0)
               U
               HUgen). }
claim Hexb0: exists b0 :e B0, x :e b0 /\ b0 c= U.
{ exact (HUcond x HxU). }
apply Hexb0.
let b0. assume Hb0pair.
claim Hb0B0: b0 :e B0.
{ exact (andEL (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair). }
claim Hxinb0: x :e b0.
{ exact (andEL (x :e b0) (b0 c= U) (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
claim Hb0sub: b0 c= U.
{ exact (andER (x :e b0) (b0 c= U) (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
apply (famunionE_impred X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r})
                        b0 Hb0B0
                        (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
let c. assume HcX: c :e X.
assume Hb0In: b0 :e {open_ball X d c r|r :e R, Rlt 0 r}.
apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0)
                        b0 Hb0In
                        (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
let r0. assume Hr0R: r0 :e R.
assume Hr0pos: Rlt 0 r0.
assume Hb0eq: b0 = open_ball X d c r0.
claim HxinBall: x :e open_ball X d c r0.
{ rewrite <- Hb0eq.
  exact Hxinb0. }
claim HballsubU: open_ball X d c r0 c= U.
{ prove open_ball X d c r0 c= U.
  rewrite <- Hb0eq.
  exact Hb0sub. }
claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r0.
{ exact (open_ball_refine_center X d c x r0 Hm HcX HxX Hr0R Hr0pos HxinBall). }
apply Hexs.
let s. assume Hs.
claim Hs12: s :e R /\ Rlt 0 s.
{ exact (andEL (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
claim HsR: s :e R.
{ exact (andEL (s :e R) (Rlt 0 s) Hs12). }
claim Hspos: Rlt 0 s.
{ exact (andER (s :e R) (Rlt 0 s) Hs12). }
claim HsubBall: open_ball X d x s c= open_ball X d c r0.
{ exact (andER (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
claim HsubU: open_ball X d x s c= U.
{ exact (Subq_tra (open_ball X d x s) (open_ball X d c r0) U HsubBall HballsubU). }
witness s.
apply andI.
- exact HsR.
- apply andI.
  + exact Hspos.
  + exact HsubU.
Qed.

(** helper: metric epsilon convergence implies topological convergence in metric topology **)
(** LATEX VERSION: If x_n converges to x in the metric sense, then it converges to x in the metric topology. **)
Theorem sequence_converges_metric_imp_converges_to_metric_topology : forall X d seq x:set,
  sequence_converges_metric X d seq x ->
  converges_to X (metric_topology X d) seq x.
let X d seq x.
assume Hconv: sequence_converges_metric X d seq x.
claim Hm: metric_on X d.
{ exact (sequence_converges_metric_metric_on X d seq x Hconv). }
claim Hseq: sequence_on seq X.
{ exact (sequence_converges_metric_sequence_on X d seq x Hconv). }
claim HxX: x :e X.
{ exact (sequence_converges_metric_point_in_X X d seq x Hconv). }
prove converges_to X (metric_topology X d) seq x.
prove topology_on X (metric_topology X d) /\ sequence_on seq X /\ x :e X /\
  forall U:set, U :e metric_topology X d -> x :e U ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
apply and4I.
- exact (metric_topology_is_topology X d Hm).
- exact Hseq.
- exact HxX.
- let U.
  assume HU: U :e metric_topology X d.
  assume HxU: x :e U.
  claim Hexr: exists r:set, r :e R /\ (Rlt 0 r /\ open_ball X d x r c= U).
  { exact (metric_topology_neighborhood_contains_ball X d x U Hm HxX HU HxU). }
  apply Hexr.
  let r. assume Hrpack.
  claim HrR: r :e R.
  { exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
  claim Hrrest: Rlt 0 r /\ open_ball X d x r c= U.
  { exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
  claim Hrpos: Rlt 0 r.
  { exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrrest). }
  claim Hballsub: open_ball X d x r c= U.
  { exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrrest). }
  claim HexN: exists N:set, N :e omega /\
    forall n:set, n :e omega -> N c= n ->
      Rlt (apply_fun d (apply_fun seq n, x)) r.
  { exact (sequence_converges_metric_eps X d seq x Hconv r (andI (r :e R) (Rlt 0 r) HrR Hrpos)). }
  apply HexN.
  let N. assume HNpack.
  witness N.
  apply andI.
  + exact (andEL (N :e omega)
                 (forall n:set, n :e omega -> N c= n -> Rlt (apply_fun d (apply_fun seq n, x)) r)
                 HNpack).
  + let n.
    assume HnO: n :e omega.
    assume HNn: N c= n.
    prove apply_fun seq n :e U.
    claim HseqnX: apply_fun seq n :e X.
    { exact (Hseq n HnO). }
    claim Hlt0: Rlt (apply_fun d (apply_fun seq n, x)) r.
    { exact (andER (N :e omega)
                   (forall n0:set, n0 :e omega -> N c= n0 -> Rlt (apply_fun d (apply_fun seq n0, x)) r)
                   HNpack
                   n
                   HnO
                   HNn). }
    claim Hsym: apply_fun d (x, apply_fun seq n) = apply_fun d (apply_fun seq n, x).
    { exact (metric_on_symmetric X d x (apply_fun seq n) Hm HxX HseqnX). }
    claim Hlt: Rlt (apply_fun d (x, apply_fun seq n)) r.
    { rewrite Hsym.
      exact Hlt0. }
    claim Hball: apply_fun seq n :e open_ball X d x r.
    { exact (open_ballI X d x r (apply_fun seq n) HseqnX Hlt). }
    exact (Hballsub (apply_fun seq n) Hball).
Qed.

(** helper: uniform convergence implies pointwise convergence in the metric topology **)
(** LATEX VERSION: If f_n converges uniformly to f then for each x the sequence f_n(x) converges to f(x) in the metric topology. **)
Theorem uniform_limit_metric_imp_converges_to_metric_topology_at_point : forall X Y d fn f x:set,
  metric_on Y d ->
  function_on fn omega (function_space X Y) ->
  function_on f X Y ->
  x :e X ->
  uniform_limit_metric X Y d fn f ->
  converges_to Y (metric_topology Y d)
    (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
    (apply_fun f x).
let X Y d fn f x.
assume Hd: metric_on Y d.
assume Hfn: function_on fn omega (function_space X Y).
assume Hf: function_on f X Y.
assume HxX: x :e X.
assume Hunif: uniform_limit_metric X Y d fn f.
claim Hseqconv: sequence_converges_metric Y d (graph omega (fun n:set => apply_fun (apply_fun fn n) x)) (apply_fun f x).
{ exact (uniform_limit_metric_imp_sequence_converges_metric_at_point
         X Y d fn f x
         Hd Hfn Hf HxX Hunif). }
exact (sequence_converges_metric_imp_converges_to_metric_topology
       Y d (graph omega (fun n:set => apply_fun (apply_fun fn n) x)) (apply_fun f x)
       Hseqconv).
Qed.

(** helper: uniform Cauchy property for a sequence of maps into a metric space **)
(** LATEX VERSION: (f_n) is uniformly Cauchy if for each eps>0 there exists N such that d(f_m(x),f_n(x))<eps for all m,n>=N and all x in X. **)
Definition uniform_cauchy_metric : set -> set -> set -> set -> prop :=
  fun X Y d fn =>
    forall eps:set, eps :e R -> Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
          forall x:set, x :e X ->
            Rlt (apply_fun d (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps.

(** helper: existence of a uniform limit in a complete metric space (stub) **)
(** LATEX VERSION: If (f_n) is uniformly Cauchy into a complete metric space, then there exists f with f_n converging uniformly to f. **)
Theorem uniform_cauchy_metric_complete_imp_uniform_limit_stub : forall X Y d fn:set,
  complete_metric_space Y d ->
  function_on fn omega (function_space X Y) ->
  uniform_cauchy_metric X Y d fn ->
  exists f:set, function_on f X Y /\ uniform_limit_metric X Y d fn f.
let X Y d fn.
assume Hcomp: complete_metric_space Y d.
assume Hfn: function_on fn omega (function_space X Y).
assume Huc: uniform_cauchy_metric X Y d fn.
claim HmY: metric_on Y d.
{ exact (andEL (metric_on Y d)
               (forall seq:set, sequence_on seq Y -> cauchy_sequence Y d seq ->
                 exists x:set, converges_to Y (metric_topology Y d) seq x)
               Hcomp). }
claim Hcomplete:
  forall seq:set, sequence_on seq Y -> cauchy_sequence Y d seq ->
    exists x:set, converges_to Y (metric_topology Y d) seq x.
{ exact (andER (metric_on Y d)
               (forall seq:set, sequence_on seq Y -> cauchy_sequence Y d seq ->
                 exists x:set, converges_to Y (metric_topology Y d) seq x)
               Hcomp). }
set f := graph X (fun x:set =>
  Eps_i (fun y:set =>
    converges_to Y (metric_topology Y d)
      (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
      y)).
witness f.
apply andI.
- prove function_on f X Y.
  let x. assume HxX: x :e X.
  prove apply_fun f x :e Y.
  claim Hfdef: f = graph X (fun x0:set =>
    Eps_i (fun y:set =>
      converges_to Y (metric_topology Y d)
        (graph omega (fun n:set => apply_fun (apply_fun fn n) x0))
        y)).
  { reflexivity. }
  rewrite (apply_fun_of_graph_eq f X
           (fun x0:set =>
             Eps_i (fun y:set =>
               converges_to Y (metric_topology Y d)
                 (graph omega (fun n:set => apply_fun (apply_fun fn n) x0))
                 y))
           x
           Hfdef
           HxX).
  set seqx := graph omega (fun n:set => apply_fun (apply_fun fn n) x).
  claim Hseqx: sequence_on seqx Y.
  { let n. assume HnO: n :e omega.
    prove apply_fun seqx n :e Y.
    claim Hseqxdef: seqx = graph omega (fun n0:set => apply_fun (apply_fun fn n0) x).
    { reflexivity. }
    rewrite (apply_fun_of_graph_eq seqx omega (fun n0:set => apply_fun (apply_fun fn n0) x) n Hseqxdef HnO).
    claim HfnnFS: apply_fun fn n :e function_space X Y.
    { exact (Hfn n HnO). }
    claim Hfnn_on: function_on (apply_fun fn n) X Y.
    { exact (SepE2 (Power (setprod X Y)) (fun f0:set => function_on f0 X Y) (apply_fun fn n) HfnnFS). }
    exact (Hfnn_on x HxX). }
  claim Hcaux: cauchy_sequence Y d seqx.
  { claim Hdef: cauchy_sequence Y d seqx =
      (metric_on Y d /\ sequence_on seqx Y /\
        forall eps:set, eps :e R /\ Rlt 0 eps ->
          exists N:set, N :e omega /\
            forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
              Rlt (apply_fun d (apply_fun seqx m, apply_fun seqx n)) eps).
    { reflexivity. }
    rewrite Hdef.
    apply andI.
    - apply andI.
      + exact HmY.
      + exact Hseqx.
    - let eps. assume Heps: eps :e R /\ Rlt 0 eps.
        claim HepsR: eps :e R.
        { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
        claim HepsPos: Rlt 0 eps.
        { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
        claim HNbig: exists N:set, N :e omega /\
          forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
            forall x0:set, x0 :e X ->
              Rlt (apply_fun d (apply_fun (apply_fun fn m) x0, apply_fun (apply_fun fn n) x0)) eps.
        { exact (Huc eps HepsR HepsPos). }
        apply HNbig.
        let N. assume HNpair.
        witness N.
        apply andI.
        - exact (andEL (N :e omega)
                       (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                         forall x0:set, x0 :e X ->
                           Rlt (apply_fun d (apply_fun (apply_fun fn m) x0, apply_fun (apply_fun fn n) x0)) eps)
                       HNpair).
        - let m n.
          assume HmO: m :e omega.
          assume HnO: n :e omega.
          assume HNm: N c= m.
          assume HNn: N c= n.
          prove Rlt (apply_fun d (apply_fun seqx m, apply_fun seqx n)) eps.
          claim Htail:
            forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
              forall x0:set, x0 :e X ->
                Rlt (apply_fun d (apply_fun (apply_fun fn m0) x0, apply_fun (apply_fun fn n0) x0)) eps.
          { exact (andER (N :e omega)
                         (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                           forall x0:set, x0 :e X ->
                             Rlt (apply_fun d (apply_fun (apply_fun fn m0) x0, apply_fun (apply_fun fn n0) x0)) eps)
                         HNpair). }
          claim Hseqm: apply_fun seqx m = apply_fun (apply_fun fn m) x.
          { claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
            { reflexivity. }
            rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) m Hseqxdef HmO).
            reflexivity. }
          claim Hseqn: apply_fun seqx n = apply_fun (apply_fun fn n) x.
          { claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
            { reflexivity. }
            rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) n Hseqxdef HnO).
            reflexivity. }
          rewrite Hseqm.
          rewrite Hseqn.
          exact (Htail m n HmO HnO HNm HNn x HxX). }
  claim Hexlim: exists y:set,
    converges_to Y (metric_topology Y d) seqx y.
  { apply (Hcomplete seqx Hseqx Hcaux). }
  claim HlimChosen:
    converges_to Y (metric_topology Y d) seqx
      (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)).
  { exact (Eps_i_ex (fun y:set => converges_to Y (metric_topology Y d) seqx y) Hexlim). }
  claim Hlim12:
    (topology_on Y (metric_topology Y d) /\ sequence_on seqx Y) /\
      (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y.
  { exact (andEL ((topology_on Y (metric_topology Y d) /\ sequence_on seqx Y) /\
                    (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y)
                 (forall U:set, U :e metric_topology Y d ->
                   (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e U ->
                     exists N:set, N :e omega /\
                       forall n:set, n :e omega -> N c= n -> apply_fun seqx n :e U)
                 HlimChosen). }
  exact (andER (topology_on Y (metric_topology Y d) /\ sequence_on seqx Y)
               ((Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y)
               Hlim12).
- prove uniform_limit_metric X Y d fn f.
  let eps. assume HepsR: eps :e R. assume HepsPos: Rlt 0 eps.
  apply (exists_eps_lt_pos_Euclid eps HepsR HepsPos).
  let Nsmall. assume HNsmall: Nsmall :e omega /\ eps_ Nsmall < eps.
  claim HNsmallO: Nsmall :e omega.
  { exact (andEL (Nsmall :e omega) (eps_ Nsmall < eps) HNsmall). }
  claim HepsNltS: eps_ Nsmall < eps.
  { exact (andER (Nsmall :e omega) (eps_ Nsmall < eps) HNsmall). }
  set delta := eps_ (ordsucc Nsmall).
	  claim HsuccO: ordsucc Nsmall :e omega.
	  { exact (omega_ordsucc Nsmall HNsmallO). }
	  claim HdeltaSNoS: delta :e SNoS_ omega.
	  { claim Hdef: delta = eps_ (ordsucc Nsmall).
	    { reflexivity. }
	    rewrite Hdef.
	    exact (SNo_eps_SNoS_omega (ordsucc Nsmall) HsuccO). }
	  claim HdeltaR: delta :e R.
	  { exact (SNoS_omega_real delta HdeltaSNoS). }
	  claim HdeltaPosS: 0 < delta.
	  { claim Hdef: delta = eps_ (ordsucc Nsmall).
	    { reflexivity. }
	    rewrite Hdef.
	    exact (SNo_eps_pos (ordsucc Nsmall) HsuccO). }
  claim HdeltaPos: Rlt 0 delta.
  { exact (RltI 0 delta real_0 HdeltaR HdeltaPosS). }
  apply (Huc delta HdeltaR HdeltaPos).
  let N0. assume HN0pair.
  claim HN0o: N0 :e omega.
  { exact (andEL (N0 :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                   forall x:set, x :e X ->
                     Rlt (apply_fun d (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) delta)
                 HN0pair). }
  claim Htail:
    forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
      forall x:set, x :e X ->
        Rlt (apply_fun d (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) delta.
  { exact (andER (N0 :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                   forall x:set, x :e X ->
                     Rlt (apply_fun d (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) delta)
                 HN0pair). }
  witness N0.
  apply andI.
  - exact HN0o.
  - let n. assume HnO: n :e omega. assume HN0n: N0 c= n.
    let x. assume HxX: x :e X.
    prove Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps.
    set seqx := graph omega (fun k:set => apply_fun (apply_fun fn k) x).
    claim Hfdef: f = graph X (fun x0:set =>
      Eps_i (fun y:set =>
        converges_to Y (metric_topology Y d)
          (graph omega (fun n0:set => apply_fun (apply_fun fn n0) x0))
          y)).
    { reflexivity. }
    claim HfxEq:
      apply_fun f x = Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y).
    { rewrite (apply_fun_of_graph_eq f X
             (fun x0:set =>
               Eps_i (fun y:set =>
                 converges_to Y (metric_topology Y d)
                   (graph omega (fun n0:set => apply_fun (apply_fun fn n0) x0))
                   y))
             x
             Hfdef
             HxX).
      reflexivity. }
    claim Hseqx: sequence_on seqx Y.
    { let k. assume HkO: k :e omega.
      prove apply_fun seqx k :e Y.
      claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
      { reflexivity. }
      rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) k Hseqxdef HkO).
      claim HfnkFS: apply_fun fn k :e function_space X Y.
      { exact (Hfn k HkO). }
      claim Hfnk_on: function_on (apply_fun fn k) X Y.
      { exact (SepE2 (Power (setprod X Y)) (fun f0:set => function_on f0 X Y) (apply_fun fn k) HfnkFS). }
      exact (Hfnk_on x HxX). }
    claim Hcaux: cauchy_sequence Y d seqx.
    { claim Hdef: cauchy_sequence Y d seqx =
        (metric_on Y d /\ sequence_on seqx Y /\
          forall e:set, e :e R /\ Rlt 0 e ->
            exists N:set, N :e omega /\
              forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                Rlt (apply_fun d (apply_fun seqx m, apply_fun seqx n)) e).
      { reflexivity. }
      rewrite Hdef.
      apply andI.
      - apply andI.
        + exact HmY.
        + exact Hseqx.
      - let e. assume He: e :e R /\ Rlt 0 e.
          claim HeR: e :e R.
          { exact (andEL (e :e R) (Rlt 0 e) He). }
          claim HePos: Rlt 0 e.
          { exact (andER (e :e R) (Rlt 0 e) He). }
          claim HNbig: exists N:set, N :e omega /\
            forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
              forall x0:set, x0 :e X ->
                Rlt (apply_fun d (apply_fun (apply_fun fn m) x0, apply_fun (apply_fun fn n) x0)) e.
          { exact (Huc e HeR HePos). }
          apply HNbig.
          let N. assume HNpair.
          witness N.
          apply andI.
          - exact (andEL (N :e omega)
                         (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                           forall x0:set, x0 :e X ->
                             Rlt (apply_fun d (apply_fun (apply_fun fn m) x0, apply_fun (apply_fun fn n) x0)) e)
                         HNpair).
          - let m n.
            assume HmO: m :e omega.
            assume HnO: n :e omega.
            assume HNm: N c= m.
            assume HNn: N c= n.
            prove Rlt (apply_fun d (apply_fun seqx m, apply_fun seqx n)) e.
            claim Htail:
              forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                forall x0:set, x0 :e X ->
                  Rlt (apply_fun d (apply_fun (apply_fun fn m0) x0, apply_fun (apply_fun fn n0) x0)) e.
            { exact (andER (N :e omega)
                           (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                             forall x0:set, x0 :e X ->
                               Rlt (apply_fun d (apply_fun (apply_fun fn m0) x0, apply_fun (apply_fun fn n0) x0)) e)
                           HNpair). }
            claim Hseqm: apply_fun seqx m = apply_fun (apply_fun fn m) x.
            { claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
              { reflexivity. }
              rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) m Hseqxdef HmO).
              reflexivity. }
            claim Hseqn: apply_fun seqx n = apply_fun (apply_fun fn n) x.
            { claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
              { reflexivity. }
              rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) n Hseqxdef HnO).
              reflexivity. }
            rewrite Hseqm.
            rewrite Hseqn.
            exact (Htail m n HmO HnO HNm HNn x HxX). }
    claim Hexlim: exists y:set, converges_to Y (metric_topology Y d) seqx y.
    { exact (Hcomplete seqx Hseqx Hcaux). }
    claim HlimChosen:
      converges_to Y (metric_topology Y d) seqx
        (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)).
    { exact (Eps_i_ex (fun y:set => converges_to Y (metric_topology Y d) seqx y) Hexlim). }
    claim Hlim34:
      (forall U:set, U :e metric_topology Y d ->
        (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e U ->
          exists N:set, N :e omega /\
            forall k:set, k :e omega -> N c= k -> apply_fun seqx k :e U).
    { exact (andER ((topology_on Y (metric_topology Y d) /\ sequence_on seqx Y) /\
                      (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y)
                   (forall U:set, U :e metric_topology Y d ->
                     (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e U ->
                       exists N:set, N :e omega /\
                         forall k:set, k :e omega -> N c= k -> apply_fun seqx k :e U)
                   HlimChosen). }
    set fx := apply_fun f x.
    claim HfxDef: fx = apply_fun f x.
    { reflexivity. }
    claim HfxEq2:
      fx = Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y).
    { rewrite HfxDef.
      rewrite HfxEq.
      reflexivity. }
    claim HfxY: fx :e Y.
    { rewrite HfxEq2.
      claim H12:
        (topology_on Y (metric_topology Y d) /\ sequence_on seqx Y) /\
          (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y.
      { exact (andEL ((topology_on Y (metric_topology Y d) /\ sequence_on seqx Y) /\
                        (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y)
                     (forall U:set, U :e metric_topology Y d ->
                       (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e U ->
                         exists N:set, N :e omega /\
                           forall k:set, k :e omega -> N c= k -> apply_fun seqx k :e U)
                     HlimChosen). }
      exact (andER (topology_on Y (metric_topology Y d) /\ sequence_on seqx Y)
                   ((Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Y)
                   H12). }
    set Uball := open_ball Y d fx delta.
    claim HUballIn: Uball :e metric_topology Y d.
    { exact (open_ball_in_metric_topology Y d fx delta HmY HfxY HdeltaPos). }
    claim HfxInBall: fx :e Uball.
    { exact (center_in_open_ball Y d fx delta HmY HfxY HdeltaPos). }
    claim HexMx: exists Mx:set, Mx :e omega /\
      forall k:set, k :e omega -> Mx c= k -> apply_fun seqx k :e Uball.
    { claim HfxInBall2:
        (Eps_i (fun y:set => converges_to Y (metric_topology Y d) seqx y)) :e Uball.
      { rewrite <- HfxEq2.
        exact HfxInBall. }
      exact (Hlim34 Uball HUballIn HfxInBall2). }
    apply HexMx.
    let Mx. assume HMxpair.
    claim HMxO: Mx :e omega.
    { exact (andEL (Mx :e omega)
                   (forall k:set, k :e omega -> Mx c= k -> apply_fun seqx k :e Uball)
                   HMxpair). }
    claim HtailMx: forall k:set, k :e omega -> Mx c= k -> apply_fun seqx k :e Uball.
    { exact (andER (Mx :e omega)
                   (forall k:set, k :e omega -> Mx c= k -> apply_fun seqx k :e Uball)
                   HMxpair). }
    set m := N0 :\/: Mx.
    claim HmO: m :e omega.
    { exact (omega_binunion N0 Mx HN0o HMxO). }
    claim HN0subm: N0 c= m.
    { let t. assume Ht: t :e N0.
      exact (binunionI1 N0 Mx t Ht). }
    claim HMxsubm: Mx c= m.
    { let t. assume Ht: t :e Mx.
      exact (binunionI2 N0 Mx t Ht). }
    claim Hdnm: Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) delta.
    { exact (Htail n m HnO HmO HN0n HN0subm x HxX). }
    claim HmInBall: apply_fun (apply_fun fn m) x :e Uball.
    { claim HseqmEq: apply_fun seqx m = apply_fun (apply_fun fn m) x.
      { claim Hseqxdef: seqx = graph omega (fun k0:set => apply_fun (apply_fun fn k0) x).
        { reflexivity. }
        rewrite (apply_fun_of_graph_eq seqx omega (fun k0:set => apply_fun (apply_fun fn k0) x) m Hseqxdef HmO).
        reflexivity. }
      rewrite <- HseqmEq.
      exact (HtailMx m HmO HMxsubm). }
    claim Hdmfx0: Rlt (apply_fun d (fx, apply_fun (apply_fun fn m) x)) delta.
    { exact (open_ballE2 Y d fx delta (apply_fun (apply_fun fn m) x) HmInBall). }
    claim HxY1: apply_fun (apply_fun fn n) x :e Y.
    { claim HfnnFS: apply_fun fn n :e function_space X Y.
      { exact (Hfn n HnO). }
      claim Hfnn_on: function_on (apply_fun fn n) X Y.
      { exact (SepE2 (Power (setprod X Y)) (fun f0:set => function_on f0 X Y) (apply_fun fn n) HfnnFS). }
      exact (Hfnn_on x HxX). }
    claim HxY2: apply_fun (apply_fun fn m) x :e Y.
    { claim HfnmFS: apply_fun fn m :e function_space X Y.
      { exact (Hfn m HmO). }
      claim Hfnm_on: function_on (apply_fun fn m) X Y.
      { exact (SepE2 (Power (setprod X Y)) (fun f0:set => function_on f0 X Y) (apply_fun fn m) HfnmFS). }
      exact (Hfnm_on x HxX). }
    claim Hdmfx: Rlt (apply_fun d (apply_fun (apply_fun fn m) x, fx)) delta.
    { rewrite <- (metric_on_symmetric Y d fx (apply_fun (apply_fun fn m) x) HmY HfxY HxY2).
      exact Hdmfx0. }
    claim Htri:
      Rle (apply_fun d (apply_fun (apply_fun fn n) x, fx))
          (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x))
                  (apply_fun d (apply_fun (apply_fun fn m) x, fx))).
    { exact (metric_triangle_Rle Y d (apply_fun (apply_fun fn n) x) (apply_fun (apply_fun fn m) x) fx
              HmY HxY1 HxY2 HfxY). }
    set a := apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x).
    set b := apply_fun d (apply_fun (apply_fun fn m) x, fx).
    set dn := apply_fun d (apply_fun (apply_fun fn n) x, fx).
    claim HaR: a :e R.
    { claim Hfun: function_on d (setprod Y Y) R.
      { exact (metric_on_function_on Y d HmY). }
      claim Hab: (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x) :e setprod Y Y.
      { exact (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun (apply_fun fn n) x) (apply_fun (apply_fun fn m) x) HxY1 HxY2). }
      exact (Hfun (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x) Hab). }
    claim HbR: b :e R.
    { claim Hfun: function_on d (setprod Y Y) R.
      { exact (metric_on_function_on Y d HmY). }
      claim Hab: (apply_fun (apply_fun fn m) x, fx) :e setprod Y Y.
      { exact (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun (apply_fun fn m) x) fx HxY2 HfxY). }
      exact (Hfun (apply_fun (apply_fun fn m) x, fx) Hab). }
    claim HdnR: dn :e R.
    { claim Hfun: function_on d (setprod Y Y) R.
      { exact (metric_on_function_on Y d HmY). }
      claim Hab: (apply_fun (apply_fun fn n) x, fx) :e setprod Y Y.
      { exact (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun (apply_fun fn n) x) fx HxY1 HfxY). }
      exact (Hfun (apply_fun (apply_fun fn n) x, fx) Hab). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim HdeltaS: SNo delta.
    { exact (real_SNo delta HdeltaR). }
    claim HltA: a < delta.
    { exact (RltE_lt a delta Hdnm). }
    claim HltB: b < delta.
    { exact (RltE_lt b delta Hdmfx). }
    claim Hsum1: add_SNo b a < add_SNo b delta.
    { exact (add_SNo_Lt2 b a delta HbS HaS HdeltaS HltA). }
    claim Hsum2: add_SNo b delta = add_SNo delta b.
    { exact (add_SNo_com b delta HbS HdeltaS). }
    claim Hsum3: add_SNo delta b < add_SNo delta delta.
    { exact (add_SNo_Lt2 delta b delta HdeltaS HbS HdeltaS HltB). }
    claim Hsum4: add_SNo b a < add_SNo delta delta.
    { claim Hsum3b: add_SNo b delta < add_SNo delta delta.
      { rewrite Hsum2.
        exact Hsum3. }
      exact (SNoLt_tra (add_SNo b a) (add_SNo b delta) (add_SNo delta delta)
             (SNo_add_SNo b a HbS HaS)
             (SNo_add_SNo b delta HbS HdeltaS)
             (SNo_add_SNo delta delta HdeltaS HdeltaS)
             Hsum1
             Hsum3b). }
    claim Hsum5: add_SNo a b = add_SNo b a.
    { exact (add_SNo_com a b HaS HbS). }
    claim Hsum6: add_SNo a b < add_SNo delta delta.
    { rewrite Hsum5.
      exact Hsum4. }
    claim HepsNR: eps_ Nsmall :e R.
    { exact (SNoS_omega_real (eps_ Nsmall) (SNo_eps_SNoS_omega Nsmall HNsmallO)). }
    claim HepsNS: SNo (eps_ Nsmall).
    { exact (real_SNo (eps_ Nsmall) HepsNR). }
    claim Hhalf: add_SNo delta delta = eps_ Nsmall.
    { claim Hnat: nat_p Nsmall.
      { exact (omega_nat_p Nsmall HNsmallO). }
      exact (eps_ordsucc_half_add Nsmall Hnat). }
    claim Hsum7: add_SNo a b < eps_ Nsmall.
    { rewrite <- Hhalf.
      exact Hsum6. }
    claim HepsS: SNo eps.
    { exact (real_SNo eps HepsR). }
    claim HepsNlt: eps_ Nsmall < eps.
    { exact HepsNltS. }
    claim Hsum8: add_SNo a b < eps.
    { exact (SNoLt_tra (add_SNo a b) (eps_ Nsmall) eps
             (SNo_add_SNo a b HaS HbS)
             HepsNS
             HepsS
             Hsum7
             HepsNlt). }
    claim HsumR: add_SNo a b :e R.
    { exact (real_add_SNo a HaR b HbR). }
    claim HsumLt: Rlt (add_SNo a b) eps.
    { exact (RltI (add_SNo a b) eps HsumR HepsR Hsum8). }
    claim HdnEq: dn = apply_fun d (apply_fun (apply_fun fn n) x, fx).
    { reflexivity. }
    rewrite HdnEq.
    exact (Rle_Rlt_tra dn (add_SNo a b) eps Htri HsumLt).
Qed.

(** helper: uniform limit of continuous maps into a metric space is continuous **)
(** LATEX VERSION: If f_n:X->Y are continuous and converge uniformly to f into metric Y, then f is continuous. **)
Theorem uniform_limit_of_continuous_to_metric_is_continuous : forall X Tx Y d fn f:set,
  topology_on X Tx ->
  metric_on Y d ->
  function_on fn omega (function_space X Y) ->
  function_on f X Y ->
  (forall n:set, n :e omega -> continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n)) ->
  uniform_limit_metric X Y d fn f ->
  continuous_map X Tx Y (metric_topology Y d) f.
let X Tx Y d fn f.
assume HTx: topology_on X Tx.
assume HmY: metric_on Y d.
assume Hfn: function_on fn omega (function_space X Y).
assume Hf: function_on f X Y.
assume Hcont: forall n:set, n :e omega -> continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n).
assume Hunif: uniform_limit_metric X Y d fn f.
prove continuous_map X Tx Y (metric_topology Y d) f.
set B := famunion Y (fun c:set => {open_ball Y d c r|r :e R, Rlt 0 r}).
claim HBasis: basis_on Y B.
{ exact (open_balls_form_basis Y d HmY). }
claim HpreB: forall b:set, b :e B -> preimage_of X f b :e Tx.
{ let b. assume HbB: b :e B.
  prove preimage_of X f b :e Tx.
  apply (famunionE_impred Y (fun c:set => {open_ball Y d c r|r :e R, Rlt 0 r}) b HbB
         (preimage_of X f b :e Tx)).
  let c. assume HcY: c :e Y.
  assume HbIn: b :e {open_ball Y d c r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball Y d c r0) b HbIn
         (preimage_of X f b :e Tx)).
  let r. assume HrR: r :e R.
  assume Hrpos: Rlt 0 r.
  assume Hbeq: b = open_ball Y d c r.
  rewrite Hbeq.
  set A0 := preimage_of X f (open_ball Y d c r).
  claim HA0subX: A0 c= X.
  { let x. assume Hx: x :e A0.
    exact (SepE1 X (fun u => apply_fun f u :e open_ball Y d c r) x Hx). }
	  (** local openness will be proved later using Hunif and continuity of fn n **)
	  claim Hlocal: forall x0:set, x0 :e A0 ->
	    exists U:set, U :e Tx /\ x0 :e U /\ U c= A0.
	  { let x0. assume Hx0A0: x0 :e A0.
	    prove exists U:set, U :e Tx /\ x0 :e U /\ U c= A0.
	    claim Hx0X: x0 :e X.
	    { exact (HA0subX x0 Hx0A0). }
	    claim Hfx0Ball: apply_fun f x0 :e open_ball Y d c r.
	    { exact (SepE2 X (fun u:set => apply_fun f u :e open_ball Y d c r) x0 Hx0A0). }
	    claim Hfx0Y: apply_fun f x0 :e Y.
	    { exact (Hf x0 Hx0X). }
	    claim Hexeps0: exists eps0:set, eps0 :e R /\ Rlt 0 eps0 /\
	      open_ball Y d (apply_fun f x0) eps0 c= open_ball Y d c r.
	    { exact (open_ball_refine_center Y d c (apply_fun f x0) r HmY HcY Hfx0Y HrR Hrpos Hfx0Ball). }
	    apply Hexeps0.
	    let eps0. assume Heps0.
	    claim Heps0_12: eps0 :e R /\ Rlt 0 eps0.
	    { exact (andEL (eps0 :e R /\ Rlt 0 eps0)
	                   (open_ball Y d (apply_fun f x0) eps0 c= open_ball Y d c r)
	                   Heps0). }
	    claim Heps0R: eps0 :e R.
	    { exact (andEL (eps0 :e R) (Rlt 0 eps0) Heps0_12). }
	    claim Heps0pos: Rlt 0 eps0.
	    { exact (andER (eps0 :e R) (Rlt 0 eps0) Heps0_12). }
	    claim Hballsub: open_ball Y d (apply_fun f x0) eps0 c= open_ball Y d c r.
	    { exact (andER (eps0 :e R /\ Rlt 0 eps0)
	                   (open_ball Y d (apply_fun f x0) eps0 c= open_ball Y d c r)
	                   Heps0). }
	    (** choose a small eta based on eps_ **)
	    claim HexN0: exists N0 :e omega, eps_ N0 < eps0.
	    { exact (exists_eps_lt_pos eps0 Heps0R Heps0pos). }
	    apply HexN0.
	    let N0. assume HN0pair.
	    claim HN0omega: N0 :e omega.
	    { exact (andEL (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
	    claim HepsN0lt: eps_ N0 < eps0.
	    { exact (andER (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
	    claim HN0nat: nat_p N0.
	    { exact (omega_nat_p N0 HN0omega). }
	    claim Hsucc0: ordsucc N0 :e omega.
	    { exact (omega_ordsucc N0 HN0omega). }
	    claim Hsucc1: ordsucc (ordsucc N0) :e omega.
	    { exact (omega_ordsucc (ordsucc N0) Hsucc0). }
	    set eta := eps_ (ordsucc (ordsucc N0)).
	    claim HetaR: eta :e R.
	    { exact (SNoS_omega_real eta (SNo_eps_SNoS_omega (ordsucc (ordsucc N0)) Hsucc1)). }
	    claim HetaS: SNo eta.
	    { exact (SNo_eps_ (ordsucc (ordsucc N0)) Hsucc1). }
	    claim H0lt_etaS: 0 < eta.
	    { exact (SNo_eps_pos (ordsucc (ordsucc N0)) Hsucc1). }
	    claim HetaPos: Rlt 0 eta.
	    { exact (RltI 0 eta real_0 HetaR H0lt_etaS). }
	    (** uniform convergence at eta gives a global Nu **)
	    claim HexNu: exists Nu:set, Nu :e omega /\
	      forall n:set, n :e omega -> Nu c= n ->
	        forall x:set, x :e X ->
	          Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eta.
	    { exact (Hunif eta HetaR HetaPos). }
	    apply HexNu.
	    let Nu. assume HNupair.
	    claim HNuomega: Nu :e omega.
	    { exact (andEL (Nu :e omega)
	                   (forall n:set, n :e omega -> Nu c= n ->
	                     forall x:set, x :e X ->
	                       Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eta)
	                   HNupair). }
	    claim HNuprop: forall n:set, n :e omega -> Nu c= n ->
	      forall x:set, x :e X ->
	        Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eta.
	    { exact (andER (Nu :e omega)
	                   (forall n:set, n :e omega -> Nu c= n ->
	                     forall x:set, x :e X ->
	                       Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eta)
	                   HNupair). }
	    set fn0 := apply_fun fn Nu.
	    claim Hfn0cont: continuous_map X Tx Y (metric_topology Y d) fn0.
	    { exact (Hcont Nu HNuomega). }
	    claim Hfn0: function_on fn0 X Y.
	    { exact (continuous_map_function_on X Tx Y (metric_topology Y d) fn0 Hfn0cont). }
	    claim Hfn0x0Y: apply_fun fn0 x0 :e Y.
	    { exact (Hfn0 x0 Hx0X). }
	    claim Hball0open: open_ball Y d (apply_fun fn0 x0) eta :e metric_topology Y d.
	    { exact (open_ball_in_metric_topology Y d (apply_fun fn0 x0) eta HmY Hfn0x0Y HetaPos). }
	    set U0 := preimage_of X fn0 (open_ball Y d (apply_fun fn0 x0) eta).
	    claim HU0Tx: U0 :e Tx.
	    { exact (continuous_map_preimage X Tx Y (metric_topology Y d) fn0 Hfn0cont
	                                     (open_ball Y d (apply_fun fn0 x0) eta) Hball0open). }
	    claim Hx0U0: x0 :e U0.
	    { claim HU0def: U0 = preimage_of X fn0 (open_ball Y d (apply_fun fn0 x0) eta).
	      { reflexivity. }
	      rewrite HU0def.
	      claim Hpredef: preimage_of X fn0 (open_ball Y d (apply_fun fn0 x0) eta) =
	        {u :e X | apply_fun fn0 u :e open_ball Y d (apply_fun fn0 x0) eta}.
	      { reflexivity. }
	      rewrite Hpredef.
	      apply (SepI X (fun u:set => apply_fun fn0 u :e open_ball Y d (apply_fun fn0 x0) eta) x0 Hx0X).
	      exact (center_in_open_ball Y d (apply_fun fn0 x0) eta HmY Hfn0x0Y HetaPos). }
	    claim HU0subA0: U0 c= A0.
	    { let x. assume HxU0: x :e U0.
		      prove x :e A0.
		      claim HU0def: U0 = preimage_of X fn0 (open_ball Y d (apply_fun fn0 x0) eta).
		      { reflexivity. }
		      claim HxU0': x :e preimage_of X fn0 (open_ball Y d (apply_fun fn0 x0) eta).
		      { rewrite <- HU0def.
		        exact HxU0. }
		      claim HxX: x :e X.
		      { exact (SepE1 X (fun u:set => apply_fun fn0 u :e open_ball Y d (apply_fun fn0 x0) eta) x HxU0'). }
		      claim Hfn0xBall: apply_fun fn0 x :e open_ball Y d (apply_fun fn0 x0) eta.
		      { exact (SepE2 X (fun u:set => apply_fun fn0 u :e open_ball Y d (apply_fun fn0 x0) eta) x HxU0'). }
	      claim HfxY: apply_fun f x :e Y.
	      { exact (Hf x HxX). }
	      claim Hdfnfx: Rlt (apply_fun d (apply_fun fn0 x, apply_fun f x)) eta.
	      { exact (HNuprop Nu HNuomega (Subq_ref Nu) x HxX). }
	      claim Hdfxfn: Rlt (apply_fun d (apply_fun f x, apply_fun fn0 x)) eta.
	      { claim Hsym: apply_fun d (apply_fun f x, apply_fun fn0 x) = apply_fun d (apply_fun fn0 x, apply_fun f x).
	        { exact (metric_on_symmetric Y d (apply_fun f x) (apply_fun fn0 x) HmY HfxY (Hfn0 x HxX)). }
	        rewrite Hsym.
	        exact Hdfnfx. }
	      claim Hdfn0x0: Rlt (apply_fun d (apply_fun fn0 x0, apply_fun f x0)) eta.
	      { exact (HNuprop Nu HNuomega (Subq_ref Nu) x0 Hx0X). }
	      claim Hdfx0fn0: Rlt (apply_fun d (apply_fun f x0, apply_fun fn0 x0)) eta.
	      { claim Hsym: apply_fun d (apply_fun f x0, apply_fun fn0 x0) = apply_fun d (apply_fun fn0 x0, apply_fun f x0).
	        { exact (metric_on_symmetric Y d (apply_fun f x0) (apply_fun fn0 x0) HmY Hfx0Y Hfn0x0Y). }
	        rewrite Hsym.
	        exact Hdfn0x0. }
	      claim Hdfn0ball0: Rlt (apply_fun d (apply_fun fn0 x0, apply_fun fn0 x)) eta.
	      { exact (SepE2 Y (fun y0:set => Rlt (apply_fun d (apply_fun fn0 x0, y0)) eta) (apply_fun fn0 x) Hfn0xBall). }
	      claim Hdfn0ball: Rlt (apply_fun d (apply_fun fn0 x, apply_fun fn0 x0)) eta.
	      { claim Hsym: apply_fun d (apply_fun fn0 x, apply_fun fn0 x0) = apply_fun d (apply_fun fn0 x0, apply_fun fn0 x).
	        { exact (metric_on_symmetric Y d (apply_fun fn0 x) (apply_fun fn0 x0) HmY (Hfn0 x HxX) Hfn0x0Y). }
	        rewrite Hsym.
	        exact Hdfn0ball0. }
	      (** notation for the three small distances **)
	      set p := apply_fun d (apply_fun f x, apply_fun fn0 x).
	      set q := apply_fun d (apply_fun fn0 x, apply_fun fn0 x0).
	      set r0 := apply_fun d (apply_fun fn0 x0, apply_fun f x0).
	      claim HpR: p :e R.
	      { exact ((metric_on_function_on Y d HmY) (apply_fun f x, apply_fun fn0 x)
	               (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun f x) (apply_fun fn0 x) HfxY (Hfn0 x HxX))). }
	      claim HqR: q :e R.
	      { exact ((metric_on_function_on Y d HmY) (apply_fun fn0 x, apply_fun fn0 x0)
	               (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn0 x) (apply_fun fn0 x0) (Hfn0 x HxX) Hfn0x0Y)). }
	      claim HrR: r0 :e R.
	      { exact ((metric_on_function_on Y d HmY) (apply_fun fn0 x0, apply_fun f x0)
	               (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn0 x0) (apply_fun f x0) Hfn0x0Y Hfx0Y)). }
	      claim HpS: SNo p.
	      { exact (real_SNo p HpR). }
	      claim HqS: SNo q.
	      { exact (real_SNo q HqR). }
	      claim HrS: SNo r0.
	      { exact (real_SNo r0 HrR). }
	      claim HpLt: p < eta.
	      { exact (RltE_lt p eta Hdfxfn). }
	      claim HqLt: q < eta.
	      { exact (RltE_lt q eta Hdfn0ball). }
	      claim HrLt: r0 < eta.
	      { exact (RltE_lt r0 eta Hdfn0x0). }
	      claim Hsum_pqr_lt: add_SNo p (add_SNo q r0) < add_SNo eta (add_SNo eta eta).
	      { exact (add_SNo_Lt4 p q r0 eta eta eta HpS HqS HrS HetaS HetaS HetaS HpLt HqLt HrLt). }
	      (** show eta+eta+eta < eps0 using eps_ N0 < eps0 **)
	      claim Heta3S: SNo (add_SNo eta (add_SNo eta eta)).
	      { exact (SNo_add_SNo_3 eta eta eta HetaS HetaS HetaS). }
	      claim Heta3S_left: SNo (add_SNo (add_SNo eta eta) eta).
	      { claim Heta2S: SNo (add_SNo eta eta).
	        { exact (SNo_add_SNo eta eta HetaS HetaS). }
	        exact (SNo_add_SNo (add_SNo eta eta) eta Heta2S HetaS). }
	      claim HepsN0S: SNo (eps_ N0).
	      { exact (real_SNo (eps_ N0) (SNoS_omega_real (eps_ N0) (SNo_eps_SNoS_omega N0 HN0omega))). }
	      claim Heta_lt_eta2: eta < add_SNo eta eta.
	      { claim H0S: SNo 0.
	        { exact SNo_0. }
	        claim Htmp: add_SNo eta 0 < add_SNo eta eta.
	        { exact (add_SNo_Lt2 eta 0 eta HetaS H0S HetaS H0lt_etaS). }
	        rewrite <- (add_SNo_0R eta HetaS) at 1.
	        exact Htmp. }
	      claim Heta3lt_4eta: add_SNo (add_SNo eta eta) eta < add_SNo (add_SNo eta eta) (add_SNo eta eta).
	      { exact (add_SNo_Lt2 (add_SNo eta eta) eta (add_SNo eta eta)
	                           (SNo_add_SNo eta eta HetaS HetaS) HetaS (SNo_add_SNo eta eta HetaS HetaS)
	                           Heta_lt_eta2). }
	      claim H4eta_eq_epsN0: add_SNo (add_SNo eta eta) (add_SNo eta eta) = eps_ N0.
	      { claim Heq1: add_SNo eta eta = eps_ (ordsucc N0).
	        { rewrite <- (eps_ordsucc_half_add (ordsucc N0) (omega_nat_p (ordsucc N0) Hsucc0)).
	          reflexivity. }
	        rewrite Heq1 at 1.
	        rewrite Heq1 at 1.
	        rewrite <- (eps_ordsucc_half_add N0 HN0nat).
	        reflexivity. }
	      claim Heta3lt_epsN0: add_SNo (add_SNo eta eta) eta < eps_ N0.
	      { rewrite <- H4eta_eq_epsN0.
	        exact Heta3lt_4eta. }
	      claim Heta3lt_eps0: add_SNo (add_SNo eta eta) eta < eps0.
	      { exact (SNoLt_tra (add_SNo (add_SNo eta eta) eta) (eps_ N0) eps0
	               Heta3S_left HepsN0S (real_SNo eps0 Heps0R) Heta3lt_epsN0 HepsN0lt). }
	      claim Hsumlt_eps0: add_SNo p (add_SNo q r0) < eps0.
	      { claim Hmid: add_SNo eta (add_SNo eta eta) < eps0.
	        { rewrite (add_SNo_assoc eta eta eta HetaS HetaS HetaS).
	          exact Heta3lt_eps0. }
	        exact (SNoLt_tra (add_SNo p (add_SNo q r0))
	                (add_SNo eta (add_SNo eta eta))
	                eps0
	                (SNo_add_SNo p (add_SNo q r0) HpS (SNo_add_SNo q r0 HqS HrS))
	                (SNo_add_SNo eta (add_SNo eta eta) HetaS (SNo_add_SNo eta eta HetaS HetaS))
	                (real_SNo eps0 Heps0R)
	                Hsum_pqr_lt Hmid). }
	      claim HsumR: add_SNo p (add_SNo q r0) :e R.
	      { exact (real_add_SNo p HpR (add_SNo q r0) (real_add_SNo q HqR r0 HrR)). }
	      claim HsumRlt: Rlt (add_SNo p (add_SNo q r0)) eps0.
	      { exact (RltI (add_SNo p (add_SNo q r0)) eps0 HsumR Heps0R Hsumlt_eps0). }
	      (** Rle bound for the metric distance **)
	      claim Htri1: Rle (apply_fun d (apply_fun f x, apply_fun f x0))
	                   (add_SNo p (apply_fun d (apply_fun fn0 x, apply_fun f x0))).
	      { exact (metric_triangle_Rle Y d (apply_fun f x) (apply_fun fn0 x) (apply_fun f x0)
	               HmY HfxY (Hfn0 x HxX) Hfx0Y). }
	      claim Htri2: Rle (apply_fun d (apply_fun fn0 x, apply_fun f x0))
	                   (add_SNo q r0).
	      { exact (metric_triangle_Rle Y d (apply_fun fn0 x) (apply_fun fn0 x0) (apply_fun f x0)
	               HmY (Hfn0 x HxX) Hfn0x0Y Hfx0Y). }
	      claim Hadd: Rle (add_SNo p (apply_fun d (apply_fun fn0 x, apply_fun f x0)))
	                    (add_SNo p (add_SNo q r0)).
	      { exact (Rle_add_SNo_2 p
	               (apply_fun d (apply_fun fn0 x, apply_fun f x0))
	               (add_SNo q r0)
	               HpR
	               ((metric_on_function_on Y d HmY) (apply_fun fn0 x, apply_fun f x0)
	                (tuple_2_setprod_by_pair_Sigma Y Y (apply_fun fn0 x) (apply_fun f x0) (Hfn0 x HxX) Hfx0Y))
	               (real_add_SNo q HqR r0 HrR)
	               Htri2). }
	      claim Htri3: Rle (apply_fun d (apply_fun f x, apply_fun f x0))
	                   (add_SNo p (add_SNo q r0)).
	      { exact (Rle_tra (apply_fun d (apply_fun f x, apply_fun f x0))
	               (add_SNo p (apply_fun d (apply_fun fn0 x, apply_fun f x0)))
	               (add_SNo p (add_SNo q r0))
	               Htri1 Hadd). }
	      claim Hdlt: Rlt (apply_fun d (apply_fun f x, apply_fun f x0)) eps0.
	      { exact (Rle_Rlt_tra (apply_fun d (apply_fun f x, apply_fun f x0))
	               (add_SNo p (add_SNo q r0))
	               eps0
	               Htri3 HsumRlt). }
	      claim Hsymd: apply_fun d (apply_fun f x0, apply_fun f x) = apply_fun d (apply_fun f x, apply_fun f x0).
	      { exact (metric_on_symmetric Y d (apply_fun f x0) (apply_fun f x) HmY Hfx0Y HfxY). }
	      claim Hdlt2: Rlt (apply_fun d (apply_fun f x0, apply_fun f x)) eps0.
	      { rewrite Hsymd.
	        exact Hdlt. }
	      claim Hfx_in_refined: apply_fun f x :e open_ball Y d (apply_fun f x0) eps0.
	      { claim HdefBall: open_ball Y d (apply_fun f x0) eps0 =
	          {y :e Y | Rlt (apply_fun d (apply_fun f x0, y)) eps0}.
	        { reflexivity. }
	        rewrite HdefBall.
	        apply (SepI Y (fun y0:set => Rlt (apply_fun d (apply_fun f x0, y0)) eps0) (apply_fun f x) HfxY).
	        exact Hdlt2. }
	      claim Hfx_in_ball: apply_fun f x :e open_ball Y d c r.
	      { exact (Hballsub (apply_fun f x) Hfx_in_refined). }
	      claim HA0def: A0 = preimage_of X f (open_ball Y d c r).
	      { reflexivity. }
	      rewrite HA0def.
	      claim HpredefA0: preimage_of X f (open_ball Y d c r) =
	        {u :e X | apply_fun f u :e open_ball Y d c r}.
	      { reflexivity. }
	      rewrite HpredefA0.
	      apply (SepI X (fun u:set => apply_fun f u :e open_ball Y d c r) x HxX).
	      exact Hfx_in_ball. }
	    witness U0.
	    apply andI.
	    - apply andI.
	      + exact HU0Tx.
	      + exact Hx0U0.
	    - exact HU0subA0. }
  claim HA0subInt: A0 c= interior_of X Tx A0.
  { let x0. assume Hx0A0: x0 :e A0.
    prove x0 :e interior_of X Tx A0.
    claim Hx0X: x0 :e X.
    { exact (HA0subX x0 Hx0A0). }
    claim HexU: exists U:set, U :e Tx /\ x0 :e U /\ U c= A0.
    { exact (Hlocal x0 Hx0A0). }
    apply HexU.
    let U. assume HUconj.
    claim HUand: U :e Tx /\ x0 :e U.
    { exact (andEL (U :e Tx /\ x0 :e U) (U c= A0) HUconj). }
    claim HUsub: U c= A0.
    { exact (andER (U :e Tx /\ x0 :e U) (U c= A0) HUconj). }
	    claim HU: U :e Tx.
	    { exact (andEL (U :e Tx) (x0 :e U) HUand). }
	    claim Hx0U: x0 :e U.
	    { exact (andER (U :e Tx) (x0 :e U) HUand). }
	    claim HdefInt: interior_of X Tx A0 =
	      {x :e X | exists V:set, V :e Tx /\ x :e V /\ V c= A0}.
	    { reflexivity. }
	    rewrite HdefInt.
	    apply (SepI X (fun x:set => exists V:set, V :e Tx /\ x :e V /\ V c= A0) x0 Hx0X).
	    witness U.
	    apply andI.
	    - apply andI.
	      + exact HU.
      + exact Hx0U.
    - exact HUsub. }
  claim HintSub: interior_of X Tx A0 c= A0.
  { exact (interior_subset X Tx A0 HTx). }
  claim HeqA0: A0 = interior_of X Tx A0.
  { apply set_ext.
    - exact HA0subInt.
    - exact HintSub. }
	  claim HintOpen: interior_of X Tx A0 :e Tx.
	  { exact (interior_is_open X Tx A0 HTx HA0subX). }
	  claim HA0def: preimage_of X f (open_ball Y d c r) = A0.
	  { reflexivity. }
	  rewrite HA0def.
	  rewrite HeqA0.
	  exact HintOpen. }
claim HeqTop: metric_topology Y d = generated_topology Y B.
{ reflexivity. }
rewrite HeqTop.
exact (continuous_map_to_generated_topology X Tx Y B f HTx HBasis Hf HpreB).
Qed.

(** helper: membership in bounded metric ball implies bounded distance inequality **)
(** LATEX VERSION: If 0<r<1 then y is in the bounded-metric ball B(x,r) iff y is real and dbar(x,y)<r. **)
Theorem open_ball_R_bounded_metric_abs_early : forall x r y:set,
  x :e R -> r :e R -> Rlt 0 r -> Rlt r 1 ->
  (y :e open_ball R R_bounded_metric x r <->
   (y :e R /\ Rlt (R_bounded_distance x y) r)).
let x r y.
assume Hx: x :e R.
assume Hr: r :e R.
assume Hrpos: Rlt 0 r.
assume Hrlt1: Rlt r 1.
apply iffI.
- assume HyB: y :e open_ball R R_bounded_metric x r.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric x r y HyB). }
  claim Hlt: Rlt (apply_fun R_bounded_metric (x,y)) r.
  { exact (open_ballE2 R R_bounded_metric x r y HyB). }
  apply andI.
  - exact HyR.
  - prove Rlt (R_bounded_distance x y) r.
    rewrite <- (R_bounded_metric_apply_early x y Hx HyR).
    exact Hlt.
- assume Hpair: y :e R /\ Rlt (R_bounded_distance x y) r.
  claim HyR: y :e R.
  { exact (andEL (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
  claim Hlt: Rlt (R_bounded_distance x y) r.
  { exact (andER (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
  apply (open_ballI R R_bounded_metric x r y HyR).
  rewrite (R_bounded_metric_apply_early x y Hx HyR).
  exact Hlt.
Qed.

(** helper: bounded-metric ball implies abs(x-y) < r **)
Theorem open_ball_R_bounded_metric_absdiff_lt : forall x r y:set,
  x :e R -> r :e R -> Rlt 0 r -> Rlt r 1 ->
  y :e open_ball R R_bounded_metric x r ->
  abs_SNo (add_SNo x (minus_SNo y)) < r.
let x r y.
assume HxR: x :e R.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
assume Hrlt1: Rlt r 1.
assume HyB: y :e open_ball R R_bounded_metric x r.
claim Hpair: y :e R /\ Rlt (R_bounded_distance x y) r.
{ exact (iffEL (y :e open_ball R R_bounded_metric x r) (y :e R /\ Rlt (R_bounded_distance x y) r)
         (open_ball_R_bounded_metric_abs_early x r y HxR HrR Hrpos Hrlt1) HyB). }
claim HyR: y :e R.
{ exact (andEL (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
claim Hbdlt: Rlt (R_bounded_distance x y) r.
{ exact (andER (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
exact (R_bounded_distance_lt_lt1_imp_abs_lt x y r HxR HyR HrR Hrlt1 Hbdlt).
Qed.

(** helper: bounded metric balls of radius greater than 1 are all of R (early) **)
(** LATEX VERSION: If 1<r then B(c,r)=R for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_eq_R_if_1_lt_early : forall c r:set,
  c :e R -> r :e R -> Rlt 1 r ->
  open_ball R R_bounded_metric c r = R.
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume Hrgt1: Rlt 1 r.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c r.
  prove y :e R.
  exact (open_ballE1 R R_bounded_metric c r y HyB).
- let y. assume HyR: y :e R.
  prove y :e open_ball R R_bounded_metric c r.
  apply (open_ballI R R_bounded_metric c r y HyR).
  rewrite (R_bounded_metric_apply_early c y HcR HyR).
  claim Hle: Rle (R_bounded_distance c y) 1.
  { exact (R_bounded_distance_le_1 c y HcR HyR). }
  exact (Rle_Rlt_tra (R_bounded_distance c y) 1 r Hle Hrgt1).
Qed.

(** helper: bounded metric balls with radius < 1 are open intervals (early) **)
(** LATEX VERSION: If 0<r<1 then B(c,r) = (c-r, c+r) for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_eq_open_interval_early : forall c r:set,
  c :e R -> r :e R -> Rlt 0 r -> Rlt r 1 ->
  open_ball R R_bounded_metric c r = open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume HrposR: Rlt 0 r.
assume Hrlt1R: Rlt r 1.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c r.
  prove y :e open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
  claim HdefI: open_interval (add_SNo c (minus_SNo r)) (add_SNo c r) =
    {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { reflexivity. }
  rewrite HdefI.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric c r y HyB). }
  claim Hdlt: Rlt (apply_fun R_bounded_metric (c,y)) r.
  { exact (open_ballE2 R R_bounded_metric c r y HyB). }
  claim Hbdlt: Rlt (R_bounded_distance c y) r.
  { rewrite <- (R_bounded_metric_apply_early c y HcR HyR).
    exact Hdlt. }
  claim Habslt: abs_SNo (add_SNo c (minus_SNo y)) < r.
  { exact (R_bounded_distance_lt_lt1_imp_abs_lt c y r HcR HyR HrR Hrlt1R Hbdlt). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim HrposS: 0 < r.
  { exact (RltE_lt 0 r HrposR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim Htlt: t < r.
  { exact (abs_SNo_lt_imp_lt t r HtS HrS HrposS Habslt). }
  claim Hmtlt: minus_SNo t < r.
  { exact (abs_SNo_lt_imp_neg_lt t r HtS HrS HrposS Habslt). }
  claim Hswap: add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
  { claim HmcS: SNo (minus_SNo c).
    { exact (SNo_minus_SNo c HcS). }
    claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
    { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
    claim Hinv : minus_SNo (minus_SNo y) = y.
    { exact (minus_SNo_invol y HyS). }
    claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
    { rewrite <- Hinv at 2.
      exact Hneg. }
    claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
    { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
    prove add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
    rewrite <- Hcom.
    rewrite <- Hneg2.
    reflexivity. }
  claim HycLt: add_SNo y (minus_SNo c) < r.
  { rewrite Hswap.
    exact Hmtlt. }
  claim HyLt: y < add_SNo c r.
  { claim Hlt1: y < add_SNo r c.
    { exact (add_SNo_minus_Lt1 y c r HyS HcS HrS HycLt). }
    claim Hcom: add_SNo r c = add_SNo c r.
    { exact (add_SNo_com r c HrS HcS). }
    rewrite <- Hcom.
    exact Hlt1. }
  claim HcmyLt: add_SNo c (minus_SNo r) < y.
  { claim Hlt1: c < add_SNo r y.
    { exact (add_SNo_minus_Lt1 c y r HcS HyS HrS Htlt). }
    claim Hcom1: add_SNo r y = add_SNo y r.
    { exact (add_SNo_com r y HrS HyS). }
    claim Hlt2: c < add_SNo y r.
    { rewrite <- Hcom1.
      exact Hlt1. }
    claim HmrS: SNo (minus_SNo r).
    { exact (SNo_minus_SNo r HrS). }
    claim HyrS: SNo (add_SNo y r).
    { exact (SNo_add_SNo y r HyS HrS). }
    exact (add_SNo_minus_Lt1b c r y HcS HrS HyS Hlt2). }
  claim HcrR: add_SNo c (minus_SNo r) :e R.
  { exact (real_add_SNo c HcR (minus_SNo r) (real_minus_SNo r HrR)). }
  claim HcprR: add_SNo c r :e R.
  { exact (real_add_SNo c HcR r HrR). }
  claim HleftRlt: Rlt (add_SNo c (minus_SNo r)) y.
  { exact (RltI (add_SNo c (minus_SNo r)) y HcrR HyR HcmyLt). }
  claim HrightRlt: Rlt y (add_SNo c r).
  { exact (RltI y (add_SNo c r) HyR HcprR HyLt). }
  exact (SepI R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r))
         y HyR (andI (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) HleftRlt HrightRlt)).
- let y. assume HyI: y :e open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
  prove y :e open_ball R R_bounded_metric c r.
  claim HdefI: open_interval (add_SNo c (minus_SNo r)) (add_SNo c r) =
    {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { reflexivity. }
  claim HyI': y :e {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { rewrite <- HdefI.
    exact HyI. }
  claim HyR: y :e R.
  { exact (SepE1 R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r)) y HyI'). }
  claim Hconj: Rlt (add_SNo c (minus_SNo r)) y /\ Rlt y (add_SNo c r).
  { exact (SepE2 R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r)) y HyI'). }
  claim Hleft: Rlt (add_SNo c (minus_SNo r)) y.
  { exact (andEL (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) Hconj). }
  claim Hright: Rlt y (add_SNo c r).
  { exact (andER (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) Hconj). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim HltY: y < add_SNo c r.
  { exact (RltE_lt y (add_SNo c r) Hright). }
  claim Hcylt: add_SNo c (minus_SNo r) < y.
  { exact (RltE_lt (add_SNo c (minus_SNo r)) y Hleft). }
  claim HycLt: add_SNo y (minus_SNo c) < r.
  { claim HcprS: SNo (add_SNo c r).
    { exact (SNo_add_SNo c r HcS HrS). }
    claim Hcom: add_SNo c r = add_SNo r c.
    { exact (add_SNo_com c r HcS HrS). }
    claim Hlt2: y < add_SNo r c.
    { rewrite <- Hcom.
      exact HltY. }
    exact (add_SNo_minus_Lt1b y c r HyS HcS HrS Hlt2). }
  claim HcyLt: add_SNo c (minus_SNo y) < r.
  { claim Hsum: add_SNo r (add_SNo c (minus_SNo r)) < add_SNo r y.
    { exact (add_SNo_Lt2 r (add_SNo c (minus_SNo r)) y HrS (SNo_add_SNo c (minus_SNo r) HcS (SNo_minus_SNo r HrS)) HyS Hcylt). }
    claim Hassoc1: add_SNo r (add_SNo c (minus_SNo r)) = add_SNo (add_SNo r c) (minus_SNo r).
    { exact (add_SNo_assoc r c (minus_SNo r) HrS HcS (SNo_minus_SNo r HrS)). }
    claim Hcom2: add_SNo r c = add_SNo c r.
    { exact (add_SNo_com r c HrS HcS). }
    claim Hassoc2: add_SNo (add_SNo r c) (minus_SNo r) = add_SNo c (add_SNo r (minus_SNo r)).
    { rewrite Hcom2.
      rewrite <- (add_SNo_assoc c r (minus_SNo r) HcS HrS (SNo_minus_SNo r HrS)).
      reflexivity. }
    claim Hrinv: add_SNo r (minus_SNo r) = 0.
    { exact (add_SNo_minus_SNo_rinv r HrS). }
    claim Heqleft: add_SNo r (add_SNo c (minus_SNo r)) = c.
    { rewrite Hassoc1.
      rewrite Hassoc2.
      rewrite Hrinv.
      rewrite (add_SNo_0R c HcS).
      reflexivity. }
    claim Hlt3: c < add_SNo r y.
    { rewrite <- Heqleft.
      exact Hsum. }
    exact (add_SNo_minus_Lt1b c y r HcS HyS HrS Hlt3). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim Hablt: abs_SNo t < r.
  { apply (xm (0 <= t)).
    - assume H0le: 0 <= t.
      rewrite (nonneg_abs_SNo t H0le).
      exact HcyLt.
    - assume Hn0le: ~(0 <= t).
      rewrite (not_nonneg_abs_SNo t Hn0le).
      claim Hswap: minus_SNo t = add_SNo y (minus_SNo c).
      { claim HmcS: SNo (minus_SNo c).
        { exact (SNo_minus_SNo c HcS). }
        claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
        { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
        claim Hinv : minus_SNo (minus_SNo y) = y.
        { exact (minus_SNo_invol y HyS). }
        claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
        { rewrite <- Hinv at 2.
          exact Hneg. }
        claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
        { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
        prove minus_SNo t = add_SNo y (minus_SNo c).
        claim Htdef: t = add_SNo c (minus_SNo y).
        { reflexivity. }
        rewrite Htdef.
        rewrite Hneg2.
        rewrite Hcom.
        reflexivity. }
      rewrite Hswap.
      exact HycLt. }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) r.
  { exact (RltI (abs_SNo t) r HabsR HrR Hablt). }
  claim HbdRlt: Rlt (R_bounded_distance c y) r.
  { set ab := abs_SNo t.
    claim Hablt1: Rlt ab 1.
    { exact (Rlt_tra ab r 1 HabRlt Hrlt1R). }
    claim Hbddef: R_bounded_distance c y = If_i (Rlt ab 1) ab 1.
    { reflexivity. }
    prove Rlt (R_bounded_distance c y) r.
    rewrite Hbddef.
    rewrite (If_i_1 (Rlt ab 1) ab 1 Hablt1).
    exact HabRlt. }
  apply (open_ballI R R_bounded_metric c r y HyR).
  rewrite (R_bounded_metric_apply_early c y HcR HyR).
  exact HbdRlt.
Qed.

(** helper: bounded metric ball of radius 1 is an open interval (early) **)
(** LATEX VERSION: B(c,1) = (c-1, c+1) for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_r1_eq_open_interval_early : forall c:set,
  c :e R ->
  open_ball R R_bounded_metric c 1 = open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
let c.
assume HcR: c :e R.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c 1.
  prove y :e open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  claim HdefI: open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1) =
    {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { reflexivity. }
  rewrite HdefI.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric c 1 y HyB). }
  claim Hdlt: Rlt (apply_fun R_bounded_metric (c,y)) 1.
  { exact (open_ballE2 R R_bounded_metric c 1 y HyB). }
  claim Hbdlt: Rlt (R_bounded_distance c y) 1.
  { rewrite <- (R_bounded_metric_apply_early c y HcR HyR).
    exact Hdlt. }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) 1.
  { claim Hbddef: R_bounded_distance c y = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
    { reflexivity. }
    claim HIfRlt: Rlt (If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1) 1.
    { rewrite <- Hbddef.
      exact Hbdlt. }
    apply (xm (Rlt (abs_SNo t) 1)).
    - assume Hablt1: Rlt (abs_SNo t) 1.
      rewrite <- (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hablt1).
      exact HIfRlt.
    - assume Hnablt1: ~(Rlt (abs_SNo t) 1).
      claim H1lt: Rlt 1 1.
      { rewrite <- (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnablt1) at 1.
        exact HIfRlt. }
      exact (FalseE ((not_Rlt_refl 1 real_1) H1lt) (Rlt (abs_SNo t) 1)). }
  claim Hablt: abs_SNo t < 1.
  { exact (RltE_lt (abs_SNo t) 1 HabRlt). }
  claim H1S: SNo 1.
  { exact SNo_1. }
  claim Htlt: t < 1.
  { exact (abs_SNo_lt_imp_lt t 1 HtS H1S SNoLt_0_1 Hablt). }
  claim Hmtlt: minus_SNo t < 1.
  { exact (abs_SNo_lt_imp_neg_lt t 1 HtS H1S SNoLt_0_1 Hablt). }
  claim Hswap: add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
  { claim HmcS: SNo (minus_SNo c).
    { exact (SNo_minus_SNo c HcS). }
    claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
    { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
    claim Hinv : minus_SNo (minus_SNo y) = y.
    { exact (minus_SNo_invol y HyS). }
    claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
    { rewrite <- Hinv at 2.
      exact Hneg. }
    claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
    { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
    prove add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
    rewrite <- Hcom.
    rewrite <- Hneg2.
    reflexivity. }
  claim HycLt: add_SNo y (minus_SNo c) < 1.
  { rewrite Hswap.
    exact Hmtlt. }
  claim HyLt: y < add_SNo c 1.
  { claim Hlt1: y < add_SNo 1 c.
    { exact (add_SNo_minus_Lt1 y c 1 HyS HcS SNo_1 HycLt). }
    claim Hcom: add_SNo 1 c = add_SNo c 1.
    { exact (add_SNo_com 1 c SNo_1 HcS). }
    rewrite <- Hcom.
    exact Hlt1. }
  claim HcmyLt: add_SNo c (minus_SNo 1) < y.
  { claim Hlt1: c < add_SNo 1 y.
    { exact (add_SNo_minus_Lt1 c y 1 HcS HyS SNo_1 Htlt). }
    claim Hcom1: add_SNo 1 y = add_SNo y 1.
    { exact (add_SNo_com 1 y SNo_1 HyS). }
    claim Hlt2: c < add_SNo y 1.
    { rewrite <- Hcom1.
      exact Hlt1. }
    exact (add_SNo_minus_Lt1b c 1 y HcS SNo_1 HyS Hlt2). }
  claim HclR: add_SNo c (minus_SNo 1) :e R.
  { exact (real_add_SNo c HcR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
  claim HcrR: add_SNo c 1 :e R.
  { exact (real_add_SNo c HcR 1 real_1). }
  claim HleftRlt: Rlt (add_SNo c (minus_SNo 1)) y.
  { exact (RltI (add_SNo c (minus_SNo 1)) y HclR HyR HcmyLt). }
  claim HrightRlt: Rlt y (add_SNo c 1).
  { exact (RltI y (add_SNo c 1) HyR HcrR HyLt). }
  exact (SepI R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1))
         y HyR (andI (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) HleftRlt HrightRlt)).
- let y. assume HyI: y :e open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  prove y :e open_ball R R_bounded_metric c 1.
  claim HdefI: open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1) =
    {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { reflexivity. }
  claim HyI': y :e {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { rewrite <- HdefI.
    exact HyI. }
  claim HyR: y :e R.
  { exact (SepE1 R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1)) y HyI'). }
  claim Hconj: Rlt (add_SNo c (minus_SNo 1)) y /\ Rlt y (add_SNo c 1).
  { exact (SepE2 R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1)) y HyI'). }
  claim Hleft: Rlt (add_SNo c (minus_SNo 1)) y.
  { exact (andEL (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) Hconj). }
  claim Hright: Rlt y (add_SNo c 1).
  { exact (andER (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) Hconj). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim HycLt: add_SNo y (minus_SNo c) < 1.
  { claim HltY: y < add_SNo c 1.
    { exact (RltE_lt y (add_SNo c 1) Hright). }
    claim Hcom: add_SNo c 1 = add_SNo 1 c.
    { exact (add_SNo_com c 1 HcS SNo_1). }
    claim Hlt2: y < add_SNo 1 c.
    { rewrite <- Hcom.
      exact HltY. }
    exact (add_SNo_minus_Lt1b y c 1 HyS HcS SNo_1 Hlt2). }
  claim HcyLt: add_SNo c (minus_SNo y) < 1.
  { claim Hcylt: add_SNo c (minus_SNo 1) < y.
    { exact (RltE_lt (add_SNo c (minus_SNo 1)) y Hleft). }
    claim Hsum: add_SNo 1 (add_SNo c (minus_SNo 1)) < add_SNo 1 y.
    { exact (add_SNo_Lt2 1 (add_SNo c (minus_SNo 1)) y SNo_1 (SNo_add_SNo c (minus_SNo 1) HcS (SNo_minus_SNo 1 SNo_1)) HyS Hcylt). }
    claim Heqleft: add_SNo 1 (add_SNo c (minus_SNo 1)) = c.
    { rewrite (add_SNo_assoc 1 c (minus_SNo 1) SNo_1 HcS (SNo_minus_SNo 1 SNo_1)).
      rewrite (add_SNo_com 1 c SNo_1 HcS).
      rewrite <- (add_SNo_assoc c 1 (minus_SNo 1) HcS SNo_1 (SNo_minus_SNo 1 SNo_1)).
      rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
      rewrite (add_SNo_0R c HcS).
      reflexivity. }
    claim Hlt3: c < add_SNo 1 y.
    { rewrite <- Heqleft.
      exact Hsum. }
    exact (add_SNo_minus_Lt1b c y 1 HcS HyS SNo_1 Hlt3). }
  claim Hablt: abs_SNo t < 1.
  { apply (xm (0 <= t)).
    - assume H0le: 0 <= t.
      rewrite (nonneg_abs_SNo t H0le).
      exact HcyLt.
    - assume Hn0le: ~(0 <= t).
      rewrite (not_nonneg_abs_SNo t Hn0le).
      claim Hswap: minus_SNo t = add_SNo y (minus_SNo c).
      { claim HmcS: SNo (minus_SNo c).
        { exact (SNo_minus_SNo c HcS). }
        claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
        { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
        claim Hinv : minus_SNo (minus_SNo y) = y.
        { exact (minus_SNo_invol y HyS). }
        claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
        { rewrite <- Hinv at 2.
          exact Hneg. }
        claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
        { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
        claim Htdef: t = add_SNo c (minus_SNo y).
        { reflexivity. }
        prove minus_SNo t = add_SNo y (minus_SNo c).
        rewrite Htdef.
        rewrite Hneg2.
        rewrite Hcom.
        reflexivity. }
      rewrite Hswap.
      exact HycLt. }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) 1.
  { exact (RltI (abs_SNo t) 1 HabsR real_1 Hablt). }
  claim HbdRlt: Rlt (R_bounded_distance c y) 1.
  { claim Hbddef: R_bounded_distance c y = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
    { reflexivity. }
    rewrite Hbddef.
    rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 HabRlt).
    exact HabRlt. }
  apply (open_ballI R R_bounded_metric c 1 y HyR).
  rewrite (R_bounded_metric_apply_early c y HcR HyR).
  exact HbdRlt.
Qed.

(** helper: bounded-metric open balls are standard-open in R (early) **)
(** LATEX VERSION: Each bounded-metric open ball is open in the standard topology on R. **)
Theorem open_ball_R_bounded_metric_in_R_standard_topology_early : forall c r:set,
  c :e R -> r :e R -> Rlt 0 r ->
  open_ball R R_bounded_metric c r :e R_standard_topology.
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HrposS: 0 < r.
{ exact (RltE_lt 0 r Hrpos). }
apply (SNoLt_trichotomy_or_impred r 1 HrS SNo_1 (open_ball R R_bounded_metric c r :e R_standard_topology)).
- assume Hrlt1S: r < 1.
  claim Hrlt1: Rlt r 1.
  { exact (RltI r 1 HrR real_1 Hrlt1S). }
  claim HmrcR: minus_SNo r :e R.
  { exact (real_minus_SNo r HrR). }
  claim HmrcS: SNo (minus_SNo r).
  { exact (real_SNo (minus_SNo r) HmrcR). }
  claim Hneglt0: minus_SNo r < 0.
  { rewrite <- minus_SNo_0.
    exact (minus_SNo_Lt_contra 0 r SNo_0 HrS HrposS). }
  claim Hneglt: minus_SNo r < r.
  { exact (SNoLt_tra (minus_SNo r) 0 r HmrcS SNo_0 HrS Hneglt0 HrposS). }
  claim HcprR: add_SNo c r :e R.
  { exact (real_add_SNo c HcR r HrR). }
  claim HcmrR: add_SNo c (minus_SNo r) :e R.
  { exact (real_add_SNo c HcR (minus_SNo r) HmrcR). }
  claim HcmrS: SNo (add_SNo c (minus_SNo r)).
  { exact (real_SNo (add_SNo c (minus_SNo r)) HcmrR). }
  claim HcprS: SNo (add_SNo c r).
  { exact (real_SNo (add_SNo c r) HcprR). }
  claim HltS: add_SNo c (minus_SNo r) < add_SNo c r.
  { exact (add_SNo_Lt2 c (minus_SNo r) r HcS HmrcS HrS Hneglt). }
  claim Hlt: Rlt (add_SNo c (minus_SNo r)) (add_SNo c r).
  { exact (RltI (add_SNo c (minus_SNo r)) (add_SNo c r) HcmrR HcprR HltS). }
  rewrite (open_ball_R_bounded_metric_eq_open_interval_early c r HcR HrR Hrpos Hrlt1).
  exact (open_interval_in_R_standard_topology (add_SNo c (minus_SNo r)) (add_SNo c r) Hlt).
- assume HrEq: r = 1.
  rewrite HrEq.
  rewrite (open_ball_R_bounded_metric_r1_eq_open_interval_early c HcR).
  claim Hm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (real_SNo (minus_SNo 1) Hm1R). }
  claim Hm1lt0: minus_SNo 1 < 0.
  { exact minus_1_lt_0. }
  claim Hm1lt1: minus_SNo 1 < 1.
  { exact (SNoLt_tra (minus_SNo 1) 0 1 Hm1S SNo_0 SNo_1 Hm1lt0 SNoLt_0_1). }
  claim HcprR: add_SNo c 1 :e R.
  { exact (real_add_SNo c HcR 1 real_1). }
  claim HcmrR: add_SNo c (minus_SNo 1) :e R.
  { exact (real_add_SNo c HcR (minus_SNo 1) Hm1R). }
  claim HcmrS: SNo (add_SNo c (minus_SNo 1)).
  { exact (real_SNo (add_SNo c (minus_SNo 1)) HcmrR). }
  claim HcprS: SNo (add_SNo c 1).
  { exact (real_SNo (add_SNo c 1) HcprR). }
  claim HltS: add_SNo c (minus_SNo 1) < add_SNo c 1.
  { exact (add_SNo_Lt2 c (minus_SNo 1) 1 HcS Hm1S SNo_1 Hm1lt1). }
  claim Hlt: Rlt (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  { exact (RltI (add_SNo c (minus_SNo 1)) (add_SNo c 1) HcmrR HcprR HltS). }
  exact (open_interval_in_R_standard_topology (add_SNo c (minus_SNo 1)) (add_SNo c 1) Hlt).
- assume H1ltrS: 1 < r.
  claim H1ltr: Rlt 1 r.
  { exact (RltI 1 r real_1 HrR H1ltrS). }
  rewrite (open_ball_R_bounded_metric_eq_R_if_1_lt_early c r HcR HrR H1ltr).
  exact (topology_has_X R R_standard_topology (R_standard_topology_is_topology_local)).
Qed.

(** moved below since it uses R_bounded_metric_is_metric_on_early **)

(** helper: bounded metric is a metric (early stub for §35) **)
(** LATEX VERSION: The bounded metric on R satisfies the metric axioms. **)
Theorem R_bounded_metric_is_metric_on_early : metric_on R R_bounded_metric.
prove metric_on R R_bounded_metric.
prove ((((function_on R_bounded_metric (setprod R R) R /\
         (forall x y:set, x :e R -> y :e R ->
            apply_fun R_bounded_metric (x,y) = apply_fun R_bounded_metric (y,x))) /\
        (forall x:set, x :e R -> apply_fun R_bounded_metric (x,x) = 0)) /\
       (forall x y:set, x :e R -> y :e R ->
          ~(Rlt (apply_fun R_bounded_metric (x,y)) 0)
          /\ (apply_fun R_bounded_metric (x,y) = 0 -> x = y))) /\
      (forall x y z:set, x :e R -> y :e R -> z :e R ->
         ~(Rlt (add_SNo (apply_fun R_bounded_metric (x,y)) (apply_fun R_bounded_metric (y,z)))
               (apply_fun R_bounded_metric (x,z))))).
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - let p. assume Hp: p :e setprod R R.
        prove apply_fun R_bounded_metric p :e R.
        claim Happ: apply_fun R_bounded_metric p =
          R_bounded_distance (p 0) (p 1).
        { exact (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 p
                                 Hp). }
        rewrite Happ.
        claim Hp0: p 0 :e R.
        { exact (ap0_Sigma R (fun _ : set => R) p Hp). }
        claim Hp1: p 1 :e R.
        { exact (ap1_Sigma R (fun _ : set => R) p Hp). }
        exact (R_bounded_distance_in_R (p 0) (p 1) Hp0 Hp1).
      - let x y.
        assume Hx: x :e R.
        assume Hy: y :e R.
        claim Hxyprod: (x,y) :e setprod R R.
        { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
        claim Hyxprod: (y,x) :e setprod R R.
        { exact (tuple_2_setprod_by_pair_Sigma R R y x Hy Hx). }
        rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (x,y)
                                 Hxyprod).
        rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (y,x)
                                 Hyxprod).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        rewrite (tuple_2_0_eq y x).
        rewrite (tuple_2_1_eq y x).
        exact (R_bounded_distance_sym x y Hx Hy).
    * let x. assume Hx: x :e R.
      claim Hxxprod: (x,x) :e setprod R R.
      { exact (tuple_2_setprod_by_pair_Sigma R R x x Hx Hx). }
      rewrite (apply_fun_graph (setprod R R)
                               (fun q:set => R_bounded_distance (q 0) (q 1))
                               (x,x)
                               Hxxprod).
      rewrite (tuple_2_0_eq x x).
      rewrite (tuple_2_1_eq x x).
      exact (R_bounded_distance_self_zero x Hx).
  + let x y.
    assume Hx: x :e R.
    assume Hy: y :e R.
    claim Hxyprod: (x,y) :e setprod R R.
    { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
    prove ~(Rlt (apply_fun R_bounded_metric (x,y)) 0)
         /\ (apply_fun R_bounded_metric (x,y) = 0 -> x = y).
    apply andI.
    * prove ~(Rlt (apply_fun R_bounded_metric (x,y)) 0).
      rewrite (apply_fun_graph (setprod R R)
                               (fun q:set => R_bounded_distance (q 0) (q 1))
                               (x,y)
                               Hxyprod).
      rewrite (tuple_2_0_eq x y).
      rewrite (tuple_2_1_eq x y).
      prove ~(Rlt (R_bounded_distance x y) 0).
      assume Hlt: Rlt (R_bounded_distance x y) 0.
      claim HdR: R_bounded_distance x y :e R.
      { exact (R_bounded_distance_in_R x y Hx Hy). }
      claim HdS: SNo (R_bounded_distance x y).
      { exact (real_SNo (R_bounded_distance x y) HdR). }
      claim H0S: SNo 0.
      { exact SNo_0. }
      claim Hnonneg: 0 <= R_bounded_distance x y.
      { exact (R_bounded_distance_nonneg x y Hx Hy). }
      claim Hcase: 0 < (R_bounded_distance x y) \/ 0 = (R_bounded_distance x y).
      { exact (SNoLeE 0 (R_bounded_distance x y) H0S HdS Hnonneg). }
      claim HltS: R_bounded_distance x y < 0.
      { exact (RltE_lt (R_bounded_distance x y) 0 Hlt). }
      apply (Hcase False).
      - assume H0ltd: 0 < (R_bounded_distance x y).
        claim H00: 0 < 0.
        { exact (SNoLt_tra 0 (R_bounded_distance x y) 0 H0S HdS H0S H0ltd HltS). }
        exact ((SNoLt_irref 0) H00).
      - assume H0eq: 0 = (R_bounded_distance x y).
        claim H00: 0 < 0.
        { rewrite H0eq at 1.
          exact HltS. }
        exact ((SNoLt_irref 0) H00).
    * assume H0: apply_fun R_bounded_metric (x,y) = 0.
      claim Happ: apply_fun R_bounded_metric (x,y) = R_bounded_distance x y.
      { rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (x,y)
                                 Hxyprod).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        reflexivity. }
      claim Hbd0: R_bounded_distance x y = 0.
      { rewrite <- Happ.
        exact H0. }
      exact (R_bounded_distance_eq0 x y Hx Hy Hbd0).
- let x y z.
  assume Hx: x :e R.
  assume Hy: y :e R.
  assume Hz: z :e R.
  claim Hxyprod: (x,y) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
  claim Hyzprod: (y,z) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R y z Hy Hz). }
  claim Hxzprod: (x,z) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R x z Hx Hz). }
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (x,y)
                           Hxyprod).
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (y,z)
                           Hyzprod).
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (x,z)
                           Hxzprod).
  rewrite (tuple_2_0_eq x y).
  rewrite (tuple_2_1_eq x y).
  rewrite (tuple_2_0_eq y z).
  rewrite (tuple_2_1_eq y z).
  rewrite (tuple_2_0_eq x z).
  rewrite (tuple_2_1_eq x z).
  claim Htri: R_bounded_distance x z <= add_SNo (R_bounded_distance x y) (R_bounded_distance y z).
  { exact (R_bounded_distance_triangle_Le x y z Hx Hy Hz). }
  prove ~(Rlt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
              (R_bounded_distance x z)).
  assume Hlt: Rlt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                  (R_bounded_distance x z).
  claim HxzR: R_bounded_distance x z :e R.
  { exact (R_bounded_distance_in_R x z Hx Hz). }
  claim HsumR: add_SNo (R_bounded_distance x y) (R_bounded_distance y z) :e R.
  { claim HxyR: R_bounded_distance x y :e R.
    { exact (R_bounded_distance_in_R x y Hx Hy). }
    claim HyzR: R_bounded_distance y z :e R.
    { exact (R_bounded_distance_in_R y z Hy Hz). }
    exact (real_add_SNo (R_bounded_distance x y) HxyR (R_bounded_distance y z) HyzR). }
  claim HxzS: SNo (R_bounded_distance x z).
  { exact (real_SNo (R_bounded_distance x z) HxzR). }
  claim HsumS: SNo (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
  { exact (real_SNo (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)) HsumR). }
  claim Hcase: (R_bounded_distance x z) < (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
               \/ (R_bounded_distance x z) = (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
  { exact (SNoLeE (R_bounded_distance x z)
                  (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                  HxzS HsumS Htri). }
  claim HltS: (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
              < (R_bounded_distance x z).
  { exact (RltE_lt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                   (R_bounded_distance x z)
                   Hlt). }
  apply (Hcase False).
  - assume Hxzlts: (R_bounded_distance x z) < (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
    claim Hbad: (R_bounded_distance x z) < (R_bounded_distance x z).
    { exact (SNoLt_tra (R_bounded_distance x z)
                      (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                      (R_bounded_distance x z)
                      HxzS HsumS HxzS
                      Hxzlts
                      HltS). }
    exact ((SNoLt_irref (R_bounded_distance x z)) Hbad).
  - assume Hxzeq: (R_bounded_distance x z) = (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
    claim Hbad: (R_bounded_distance x z) < (R_bounded_distance x z).
    { rewrite Hxzeq at 1.
      exact HltS. }
    exact ((SNoLt_irref (R_bounded_distance x z)) Hbad).
Qed.

(** helper: standard open intervals are open in the bounded metric topology (early) **)
(** LATEX VERSION: Every open interval (a,b) is open in the bounded-metric topology on R. **)
Theorem open_interval_in_metric_topology_R_bounded_metric_early : forall a b:set,
  a :e R -> b :e R ->
  open_interval a b :e metric_topology R R_bounded_metric.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
set B := famunion R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}).
prove open_interval a b :e generated_topology R B.
claim HdefGT: generated_topology R B =
  {U :e Power R|forall x :e U, exists b0 :e B, x :e b0 /\ b0 c= U}.
{ reflexivity. }
rewrite HdefGT.
apply SepI.
- apply PowerI.
  let x. assume Hx: x :e open_interval a b.
  exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx).
- let x. assume Hx: x :e open_interval a b.
  prove exists b0 :e B, x :e b0 /\ b0 c= open_interval a b.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hxab: Rlt a x /\ Rlt x b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hax: Rlt a x.
  { exact (andEL (Rlt a x) (Rlt x b) Hxab). }
  claim Hxb: Rlt x b.
  { exact (andER (Rlt a x) (Rlt x b) Hxab). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim HaxS: a < x.
  { exact (RltE_lt a x Hax). }
  claim HxbS: x < b.
  { exact (RltE_lt x b Hxb). }
  set dx := add_SNo x (minus_SNo a).
  set dy := add_SNo b (minus_SNo x).
  claim HmaR: minus_SNo a :e R.
  { exact (real_minus_SNo a HaR). }
  claim HmxR: minus_SNo x :e R.
  { exact (real_minus_SNo x HxR). }
  claim HdxR: dx :e R.
  { exact (real_add_SNo x HxR (minus_SNo a) HmaR). }
  claim HdyR: dy :e R.
  { exact (real_add_SNo b HbR (minus_SNo x) HmxR). }
  claim HdxS: SNo dx.
  { exact (real_SNo dx HdxR). }
  claim HdyS: SNo dy.
  { exact (real_SNo dy HdyR). }
  claim HdxPosS: 0 < dx.
  { claim H0aLt: add_SNo 0 a < x.
    { rewrite (add_SNo_0L a HaS).
      exact HaxS. }
    exact (add_SNo_minus_Lt2b x a 0 HxS HaS SNo_0 H0aLt). }
  claim HdyPosS: 0 < dy.
  { claim H0xLt: add_SNo 0 x < b.
    { rewrite (add_SNo_0L x HxS).
      exact HxbS. }
    exact (add_SNo_minus_Lt2b b x 0 HbS HxS SNo_0 H0xLt). }
  claim HdxPos: Rlt 0 dx.
  { exact (RltI 0 dx real_0 HdxR HdxPosS). }
  claim HdyPos: Rlt 0 dy.
  { exact (RltI 0 dy real_0 HdyR HdyPosS). }
  claim Hexr: exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 dx /\ Rlt r3 dy /\ Rlt r3 1 /\ Rlt r3 1.
  { exact (exists_eps_lt_four_pos_Euclid dx dy 1 1 HdxR HdyR real_1 real_1 HdxPos HdyPos Rlt_0_1 Rlt_0_1). }
  apply Hexr.
  let r3. assume Hr3: r3 :e R /\ Rlt 0 r3 /\ Rlt r3 dx /\ Rlt r3 dy /\ Rlt r3 1 /\ Rlt r3 1.
  claim Hr3_ABCDE: ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) /\ Rlt r3 1).
  { exact (andEL ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) /\ Rlt r3 1) (Rlt r3 1) Hr3). }
  claim Hr3_ABCD: (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy).
  { exact (andEL (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) (Rlt r3 1) Hr3_ABCDE). }
  claim Hr3_E: Rlt r3 1.
  { exact (andER (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) (Rlt r3 1) Hr3_ABCDE). }
  claim Hr3_ABC: ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx).
  { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) (Rlt r3 dy) Hr3_ABCD). }
  claim Hr3_D: Rlt r3 dy.
  { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) (Rlt r3 dy) Hr3_ABCD). }
  claim Hr3_AB: r3 :e R /\ Rlt 0 r3.
  { exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 dx) Hr3_ABC). }
  claim Hr3_C: Rlt r3 dx.
  { exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 dx) Hr3_ABC). }
  claim Hr3R: r3 :e R.
  { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3_AB). }
  claim Hr3pos: Rlt 0 r3.
  { exact (andER (r3 :e R) (Rlt 0 r3) Hr3_AB). }
  claim Hr3ltDx: Rlt r3 dx.
  { exact Hr3_C. }
  claim Hr3ltDy: Rlt r3 dy.
  { exact Hr3_D. }
  claim Hr3lt1: Rlt r3 1.
  { exact Hr3_E. }
  set ball := open_ball R R_bounded_metric x r3.
  witness ball.
  apply andI.
  - claim HballIn: ball :e {open_ball R R_bounded_metric x rr|rr :e R, Rlt 0 rr}.
    { exact (ReplSepI R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball R R_bounded_metric x rr) r3 Hr3R Hr3pos). }
    exact (famunionI R (fun x0:set => {open_ball R R_bounded_metric x0 rr|rr :e R, Rlt 0 rr}) x ball HxR HballIn).
  - apply andI.
    + exact (center_in_open_ball R R_bounded_metric x r3 R_bounded_metric_is_metric_on_early HxR Hr3pos).
    + rewrite (open_ball_R_bounded_metric_eq_open_interval_early x r3 HxR Hr3R Hr3pos Hr3lt1).
      let y. assume HyB: y :e open_interval (add_SNo x (minus_SNo r3)) (add_SNo x r3).
      prove y :e open_interval a b.
      claim HyR: y :e R.
      { exact (SepE1 R (fun y0:set => Rlt (add_SNo x (minus_SNo r3)) y0 /\ Rlt y0 (add_SNo x r3)) y HyB). }
      claim HyConj: Rlt (add_SNo x (minus_SNo r3)) y /\ Rlt y (add_SNo x r3).
      { exact (SepE2 R (fun y0:set => Rlt (add_SNo x (minus_SNo r3)) y0 /\ Rlt y0 (add_SNo x r3)) y HyB). }
      claim HyLeft: Rlt (add_SNo x (minus_SNo r3)) y.
      { exact (andEL (Rlt (add_SNo x (minus_SNo r3)) y) (Rlt y (add_SNo x r3)) HyConj). }
      claim HyRight: Rlt y (add_SNo x r3).
      { exact (andER (Rlt (add_SNo x (minus_SNo r3)) y) (Rlt y (add_SNo x r3)) HyConj). }
      claim Hxmr3R: add_SNo x (minus_SNo r3) :e R.
      { exact (real_add_SNo x HxR (minus_SNo r3) (real_minus_SNo r3 Hr3R)). }
      claim Hxpr3R: add_SNo x r3 :e R.
      { exact (real_add_SNo x HxR r3 Hr3R). }
      claim Haxmr3S: a < add_SNo x (minus_SNo r3).
      { claim Hr3dxS: r3 < dx.
        { exact (RltE_lt r3 dx Hr3ltDx). }
        claim Hr3plusA_lt_x: add_SNo r3 a < x.
        { exact (add_SNo_minus_Lt2 x a r3 HxS HaS (real_SNo r3 Hr3R) Hr3dxS). }
        claim Ha_plus_r3_lt_x: add_SNo a r3 < x.
        { rewrite <- (add_SNo_com r3 a (real_SNo r3 Hr3R) HaS).
          exact Hr3plusA_lt_x. }
        exact (add_SNo_minus_Lt2b x r3 a HxS (real_SNo r3 Hr3R) HaS Ha_plus_r3_lt_x). }
      claim Hxpr3ltbS: add_SNo x r3 < b.
      { claim Hr3dyS: r3 < dy.
        { exact (RltE_lt r3 dy Hr3ltDy). }
        claim Hr3plusX_lt_b: add_SNo r3 x < b.
        { exact (add_SNo_minus_Lt2 b x r3 HbS HxS (real_SNo r3 Hr3R) Hr3dyS). }
        rewrite <- (add_SNo_com r3 x (real_SNo r3 Hr3R) HxS) at 1.
        exact Hr3plusX_lt_b. }
      claim Haxmr3: Rlt a (add_SNo x (minus_SNo r3)).
      { exact (RltI a (add_SNo x (minus_SNo r3)) HaR Hxmr3R Haxmr3S). }
      claim Hxpr3ltb: Rlt (add_SNo x r3) b.
      { exact (RltI (add_SNo x r3) b Hxpr3R HbR Hxpr3ltbS). }
      claim Hay: Rlt a y.
      { exact (Rlt_tra a (add_SNo x (minus_SNo r3)) y Haxmr3 HyLeft). }
      claim Hyb: Rlt y b.
      { exact (Rlt_tra y (add_SNo x r3) b HyRight Hxpr3ltb). }
      exact (SepI R (fun y0:set => Rlt a y0 /\ Rlt y0 b) y HyR (andI (Rlt a y) (Rlt y b) Hay Hyb)).
Qed.

(** helper: bounded metric induces the standard topology on R (early stub for §35) **)
(** LATEX VERSION: The bounded metric on R induces the standard topology. **)
Theorem metric_topology_R_bounded_metric_eq_R_standard_topology_early :
  metric_topology R R_bounded_metric = R_standard_topology.
prove metric_topology R R_bounded_metric = R_standard_topology.
apply set_ext.
- let U. assume HU: U :e metric_topology R R_bounded_metric.
  prove U :e R_standard_topology.
  set B := famunion R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}).
  claim Htop: topology_on R R_standard_topology.
  { exact (R_standard_topology_is_topology_local). }
  claim HBsub: forall b0 :e B, b0 :e R_standard_topology.
  { let b0. assume Hb0: b0 :e B.
    apply (famunionE_impred R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}) b0 Hb0
           (b0 :e R_standard_topology)).
    let c0. assume Hc0R: c0 :e R.
    assume Hb0In: b0 :e {open_ball R R_bounded_metric c0 r0|r0 :e R, Rlt 0 r0}.
    apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball R R_bounded_metric c0 r0)
           b0 Hb0In (b0 :e R_standard_topology)).
    let r0. assume Hr0R: r0 :e R.
    assume Hr0pos: Rlt 0 r0.
    assume Hb0eq: b0 = open_ball R R_bounded_metric c0 r0.
    rewrite Hb0eq.
    exact (open_ball_R_bounded_metric_in_R_standard_topology_early c0 r0 Hc0R Hr0R Hr0pos). }
  claim Hsub: generated_topology R B c= R_standard_topology.
  { exact (generated_topology_finer_weak R B R_standard_topology Htop HBsub). }
  exact (Hsub U HU).
- let U. assume HU: U :e R_standard_topology.
  prove U :e metric_topology R R_bounded_metric.
  claim Htop: topology_on R (metric_topology R R_bounded_metric).
  { exact (metric_topology_is_topology R R_bounded_metric R_bounded_metric_is_metric_on_early). }
  claim HBsub: forall b0 :e R_standard_basis, b0 :e metric_topology R R_bounded_metric.
  { let b0. assume Hb0: b0 :e R_standard_basis.
    claim Hexa: exists a0 :e R, b0 :e {open_interval a0 bb|bb :e R}.
    { exact (famunionE R (fun a1:set => {open_interval a1 bb|bb :e R}) b0 Hb0). }
    apply Hexa.
    let a0. assume Hapair: a0 :e R /\ b0 :e {open_interval a0 bb|bb :e R}.
    claim Ha0R: a0 :e R.
    { exact (andEL (a0 :e R) (b0 :e {open_interval a0 bb|bb :e R}) Hapair). }
    claim Hb0Fam: b0 :e {open_interval a0 bb|bb :e R}.
    { exact (andER (a0 :e R) (b0 :e {open_interval a0 bb|bb :e R}) Hapair). }
    claim Hexb: exists bb :e R, b0 = open_interval a0 bb.
    { exact (ReplE R (fun bb0:set => open_interval a0 bb0) b0 Hb0Fam). }
    apply Hexb.
    let bb. assume Hbpair: bb :e R /\ b0 = open_interval a0 bb.
    claim HbbR: bb :e R.
    { exact (andEL (bb :e R) (b0 = open_interval a0 bb) Hbpair). }
    claim Hb0eq: b0 = open_interval a0 bb.
    { exact (andER (bb :e R) (b0 = open_interval a0 bb) Hbpair). }
    rewrite Hb0eq.
    exact (open_interval_in_metric_topology_R_bounded_metric_early a0 bb Ha0R HbbR). }
  claim Hsub: generated_topology R R_standard_basis c= metric_topology R R_bounded_metric.
  { exact (generated_topology_finer_weak R R_standard_basis (metric_topology R R_bounded_metric) Htop HBsub). }
  claim HUgen: U :e generated_topology R R_standard_basis.
  { rewrite <- (R_standard_topology_def_eq).
    exact HU. }
  exact (Hsub U HUgen).
Qed.

(** helper: bounded-metric Cauchy gives abs-tail estimates for eps<1 (early) **)
(** LATEX VERSION: If seq is Cauchy in dbar and 0<eps<1 then eventually |seq m-seq n| < eps. **)
Theorem cauchy_R_bounded_metric_abs_tail_early : forall seq eps:set,
  cauchy_sequence R R_bounded_metric seq ->
  eps :e R -> Rlt 0 eps -> Rlt eps 1 ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
let seq eps.
assume Hc: cauchy_sequence R R_bounded_metric seq.
assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
assume HepsLt1: Rlt eps 1.
claim Hleft: metric_on R R_bounded_metric /\ sequence_on seq R.
{ exact (andEL (metric_on R R_bounded_metric /\ sequence_on seq R)
               (forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0)
               Hc). }
claim Hseq: sequence_on seq R.
{ exact (andER (metric_on R R_bounded_metric) (sequence_on seq R) Hleft). }
claim Htail: forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0.
{ exact (andER (metric_on R R_bounded_metric /\ sequence_on seq R)
               (forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0)
               Hc). }
claim HepsPair: eps :e R /\ Rlt 0 eps.
{ apply andI.
  - exact HepsR.
  - exact HepsPos. }
apply (Htail eps HepsPair).
let N. assume HNpair.
witness N.
apply andI.
- exact (andEL (N :e omega)
               (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                 Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps)
               HNpair).
- let m n.
  assume HmO: m :e omega.
  assume HnO: n :e omega.
  assume HNm: N c= m.
  assume HNn: N c= n.
  prove abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
  claim HmR: apply_fun seq m :e R.
  { exact (Hseq m HmO). }
  claim HnR: apply_fun seq n :e R.
  { exact (Hseq n HnO). }
  claim Hlt: Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps.
  { exact (andER (N :e omega)
                 (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                   Rlt (apply_fun R_bounded_metric (apply_fun seq m0, apply_fun seq n0)) eps)
                 HNpair m n HmO HnO HNm HNn). }
  claim Hlt2: Rlt (R_bounded_distance (apply_fun seq m) (apply_fun seq n)) eps.
  { rewrite <- (R_bounded_metric_apply_early (apply_fun seq m) (apply_fun seq n) HmR HnR).
    exact Hlt. }
  exact (R_bounded_distance_lt_lt1_imp_abs_lt (apply_fun seq m) (apply_fun seq n) eps HmR HnR HepsR HepsLt1 Hlt2).
Qed.

(** helper: abs-Cauchy sequences on R converge in the standard topology (early) **)
(** LATEX VERSION: Every Cauchy sequence in R with respect to |x-y| converges in the standard topology. **)
Theorem abs_Cauchy_sequence_converges_R_standard_topology_early : forall seq:set,
  sequence_on seq R ->
  (forall eps:set, eps :e R /\ Rlt 0 eps ->
     exists N:set, N :e omega /\
       forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
         abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps) ->
  exists x:set, converges_to R R_standard_topology seq x.
let seq.
assume Hseq: sequence_on seq R.
assume HabC: forall eps:set, eps :e R /\ Rlt 0 eps ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
claim H1pair: 1 :e R /\ Rlt 0 1.
{ apply andI.
  - exact real_1.
  - exact Rlt_0_1. }
apply (HabC 1 H1pair).
let N0. assume HN0pair.
claim HN0omega: N0 :e omega.
{ exact (andEL (N0 :e omega)
               (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                 abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1)
               HN0pair). }
claim Htail1: forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
  abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1.
{ exact (andER (N0 :e omega)
               (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                 abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1)
               HN0pair). }
claim Hx0R: apply_fun seq N0 :e R.
{ exact (Hseq N0 HN0omega). }
set u := add_SNo 1 (apply_fun seq N0).
claim HuR: u :e R.
{ exact (real_add_SNo 1 real_1 (apply_fun seq N0) Hx0R). }
set A := {x :e R |
  exists N:set, N :e omega /\
    forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n)}.
claim HAinR: forall x:set, x :e A -> x :e R.
{ let x. assume HxA: x :e A.
  exact (SepE1 R
               (fun x0 : set => exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
               x
               HxA). }
claim HAnen: exists a0:set, a0 :e A.
{ set a0 := add_SNo (minus_SNo 1) (apply_fun seq N0).
  claim Ha0R: a0 :e R.
  { exact (real_add_SNo (minus_SNo 1) (real_minus_SNo 1 real_1) (apply_fun seq N0) Hx0R). }
  witness a0.
  apply (SepI R
               (fun x0 : set => exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
               a0
               Ha0R).
  witness N0.
  apply andI.
  - exact HN0omega.
  - let n. assume HnO: n :e omega.
    assume HN0subn: N0 c= n.
    claim Habslt1: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0))) < 1.
    { exact (Htail1 n N0 HnO HN0omega HN0subn (Subq_ref N0)). }
    claim HnR: apply_fun seq n :e R.
    { exact (Hseq n HnO). }
    claim HnS: SNo (apply_fun seq n).
    { exact (real_SNo (apply_fun seq n) HnR). }
    claim Hx0S: SNo (apply_fun seq N0).
    { exact (real_SNo (apply_fun seq N0) Hx0R). }
    claim HmS: SNo (minus_SNo (apply_fun seq N0)).
    { exact (SNo_minus_SNo (apply_fun seq N0) Hx0S). }
    set t := add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)).
    claim HtS: SNo t.
    { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)) HnS HmS). }
    claim Hneglt1: minus_SNo t < 1.
    { exact (abs_SNo_lt_imp_neg_lt t 1 HtS SNo_1 SNoLt_0_1 Habslt1). }
    claim Hm1lt: minus_SNo 1 < t.
    { claim HmtS: SNo (minus_SNo t).
      { exact (SNo_minus_SNo t HtS). }
      claim HmmtS: SNo (minus_SNo (minus_SNo t)).
      { exact (SNo_minus_SNo (minus_SNo t) HmtS). }
      claim Hinv1: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = 0.
      { exact (add_SNo_minus_SNo_linv (minus_SNo t) HmtS). }
      claim Hinv2: add_SNo t (minus_SNo t) = 0.
      { exact (add_SNo_minus_SNo_rinv t HtS). }
      claim Hnegneg: minus_SNo (minus_SNo t) = t.
      { claim Heq: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = add_SNo t (minus_SNo t).
        { rewrite Hinv1. rewrite Hinv2. reflexivity. }
        exact (add_SNo_cancel_R (minus_SNo (minus_SNo t)) (minus_SNo t) t HmmtS HmtS HtS Heq). }
      claim Hm1lt2: minus_SNo 1 < minus_SNo (minus_SNo t).
      { exact (minus_SNo_Lt_contra (minus_SNo t) 1 HmtS SNo_1 Hneglt1). }
      rewrite <- Hnegneg.
      exact Hm1lt2. }
    claim Hm1S: SNo (minus_SNo 1).
    { exact (SNo_minus_SNo 1 SNo_1). }
    claim Htlt: add_SNo (minus_SNo 1) (apply_fun seq N0) < apply_fun seq n.
    { exact (add_SNo_minus_Lt2 (apply_fun seq n) (apply_fun seq N0) (minus_SNo 1) HnS Hx0S Hm1S Hm1lt). }
    exact (Rlt_implies_Rle a0 (apply_fun seq n)
                           (RltI a0 (apply_fun seq n) Ha0R HnR Htlt)). }
(** tail upper bound by u = seq N0 + 1 **)
claim HtailLeU: forall n:set, n :e omega -> N0 c= n -> Rle (apply_fun seq n) u.
{ let n. assume HnO: n :e omega. assume HN0subn: N0 c= n.
  claim Habslt1: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0))) < 1.
  { exact (Htail1 n N0 HnO HN0omega HN0subn (Subq_ref N0)). }
  claim HnR: apply_fun seq n :e R.
  { exact (Hseq n HnO). }
  claim HnS: SNo (apply_fun seq n).
  { exact (real_SNo (apply_fun seq n) HnR). }
  claim Hx0S: SNo (apply_fun seq N0).
  { exact (real_SNo (apply_fun seq N0) Hx0R). }
  claim HmS: SNo (minus_SNo (apply_fun seq N0)).
  { exact (SNo_minus_SNo (apply_fun seq N0) Hx0S). }
  set t := add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)).
  claim HtS: SNo t.
  { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)) HnS HmS). }
  claim Htlt1: t < 1.
  { exact (abs_SNo_lt_imp_lt t 1 HtS SNo_1 SNoLt_0_1 Habslt1). }
  claim Htltu: apply_fun seq n < u.
  { exact (add_SNo_minus_Lt1 (apply_fun seq n) (apply_fun seq N0) 1 HnS Hx0S SNo_1 Htlt1). }
  claim HxRlt: Rlt (apply_fun seq n) u.
  { exact (RltI (apply_fun seq n) u HnR HuR Htltu). }
  exact (Rlt_implies_Rle (apply_fun seq n) u HxRlt). }
(** show A is bounded above by u **)
claim HubExists: exists u0:set, u0 :e R /\ forall x:set, x :e A -> x :e R -> Rle x u0.
{ witness u.
  apply andI.
  - exact HuR.
  - let x. assume HxA: x :e A. assume HxR: x :e R.
    claim Hxprop: exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n).
    { exact (SepE2 R
                 (fun x0 : set => exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
                 x
                 HxA). }
    apply Hxprop.
    let N. assume HNpair2.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega)
                   (forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n))
                   HNpair2). }
    claim HNtail: forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n).
    { exact (andER (N :e omega)
                   (forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n))
                   HNpair2). }
    set n0 := ordsucc (N :\/: N0).
    claim HmaxO: N :\/: N0 :e omega.
    { exact (omega_binunion N N0 HNomega HN0omega). }
    claim Hn0O: n0 :e omega.
    { exact (omega_ordsucc (N :\/: N0) HmaxO). }
    claim HNsubn0: N c= n0.
    { let t. assume Ht: t :e N.
      claim Htmax: t :e (N :\/: N0).
      { exact (binunionI1 N N0 t Ht). }
      exact (ordsuccI1 (N :\/: N0) t Htmax). }
    claim HN0subn0: N0 c= n0.
    { let t. assume Ht: t :e N0.
      claim Htmax: t :e (N :\/: N0).
      { exact (binunionI2 N N0 t Ht). }
      exact (ordsuccI1 (N :\/: N0) t Htmax). }
    claim Hxlen0: Rle x (apply_fun seq n0).
    { exact (HNtail n0 Hn0O HNsubn0). }
    claim Hn0leu: Rle (apply_fun seq n0) u.
    { exact (HtailLeU n0 Hn0O HN0subn0). }
    exact (Rle_tra x (apply_fun seq n0) u Hxlen0 Hn0leu). }
apply (R_lub_exists A HAnen HAinR HubExists).
let l. assume Hlub: R_lub A l.
witness l.
claim HlR: l :e R.
{ exact (R_lub_in_R A l Hlub). }
prove converges_to R R_standard_topology seq l.
prove topology_on R R_standard_topology /\ sequence_on seq R /\ l :e R /\
  forall U:set, U :e R_standard_topology -> l :e U ->
    exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
apply andI.
- apply andI.
  + apply andI.
    - exact R_standard_topology_is_topology_local.
    - exact Hseq.
  + exact HlR.
- let U. assume HU: U :e R_standard_topology.
  assume HlU: l :e U.
  claim HUprop: forall x :e U, exists b :e R_standard_basis, x :e b /\ b c= U.
  { exact (SepE2 (Power R)
               (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
               U
               HU). }
  apply (HUprop l HlU).
  let b. assume Hbpair.
  claim HbB: b :e R_standard_basis.
  { exact (andEL (b :e R_standard_basis) (l :e b /\ b c= U) Hbpair). }
  claim Hlbsub: l :e b /\ b c= U.
  { exact (andER (b :e R_standard_basis) (l :e b /\ b c= U) Hbpair). }
  claim Hlb: l :e b.
  { exact (andEL (l :e b) (b c= U) Hlbsub). }
  claim HbsubU: b c= U.
  { exact (andER (l :e b) (b c= U) Hlbsub). }
  claim Hexa: exists a :e R, b :e {open_interval a c|c :e R}.
  { exact (famunionE R (fun a0 : set => {open_interval a0 c|c :e R}) b HbB). }
  apply Hexa.
  let a. assume Hapair.
  claim HaR: a :e R.
  { exact (andEL (a :e R) (b :e {open_interval a c|c :e R}) Hapair). }
  claim Hbfam: b :e {open_interval a c|c :e R}.
  { exact (andER (a :e R) (b :e {open_interval a c|c :e R}) Hapair). }
  claim Hexc: exists c :e R, b = open_interval a c.
  { exact (ReplE R (fun c0 : set => open_interval a c0) b Hbfam). }
  apply Hexc.
  let c. assume Hcpair.
  claim HcR: c :e R.
  { exact (andEL (c :e R) (b = open_interval a c) Hcpair). }
  claim Hbeq: b = open_interval a c.
  { exact (andER (c :e R) (b = open_interval a c) Hcpair). }
  claim HlInt: l :e open_interval a c.
  { rewrite <- Hbeq at 1.
    exact Hlb. }
  claim Hltac: Rlt a l /\ Rlt l c.
  { exact (SepE2 R (fun x0 : set => Rlt a x0 /\ Rlt x0 c) l HlInt). }
  claim Hlta: Rlt a l.
  { exact (andEL (Rlt a l) (Rlt l c) Hltac). }
  claim Hltlc: Rlt l c.
  { exact (andER (Rlt a l) (Rlt l c) Hltac). }
  claim Hlubcore: l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
  { exact (andEL (l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l)
                 (forall u0:set, u0 :e R ->
                   (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u0) ->
                   Rle l u0)
                 Hlub). }
  claim HubA: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
  { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
  claim HexLower: exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> Rlt a (apply_fun seq n).
  { claim HaR2: a :e R.
    { exact HaR. }
    claim HlR2: l :e R.
    { exact HlR. }
    claim HaS: SNo a.
    { exact (real_SNo a HaR2). }
    claim HlS: SNo l.
    { exact (real_SNo l HlR2). }
    claim HaltlS: a < l.
    { exact (RltE_lt a l Hlta). }
    claim HmaS: SNo (minus_SNo a).
    { exact (SNo_minus_SNo a HaS). }
    claim HdiffR: add_SNo l (minus_SNo a) :e R.
    { exact (real_add_SNo l HlR2 (minus_SNo a) (real_minus_SNo a HaR2)). }
    claim H0ltdS: 0 < add_SNo (minus_SNo a) l.
    { claim H0lt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) l.
      { exact (add_SNo_Lt2 (minus_SNo a) a l HmaS HaS HlS HaltlS). }
      rewrite <- (add_SNo_minus_SNo_linv a HaS) at 1.
      exact H0lt. }
    claim H0ltdS2: 0 < add_SNo l (minus_SNo a).
    { claim Hcom: add_SNo (minus_SNo a) l = add_SNo l (minus_SNo a).
      { exact (add_SNo_com (minus_SNo a) l HmaS HlS). }
      rewrite <- Hcom.
      exact H0ltdS. }
    claim Hdpos: Rlt 0 (add_SNo l (minus_SNo a)).
    { exact (RltI 0 (add_SNo l (minus_SNo a)) real_0 HdiffR H0ltdS2). }
    claim Hexeps: exists Neps :e omega, eps_ Neps < add_SNo l (minus_SNo a).
    { exact (exists_eps_lt_pos_Euclid (add_SNo l (minus_SNo a)) HdiffR Hdpos). }
    apply Hexeps.
    let Neps. assume HNepspair.
    claim HNepsO: Neps :e omega.
    { exact (andEL (Neps :e omega) (eps_ Neps < add_SNo l (minus_SNo a)) HNepspair). }
    claim Hepslt: eps_ Neps < add_SNo l (minus_SNo a).
    { exact (andER (Neps :e omega) (eps_ Neps < add_SNo l (minus_SNo a)) HNepspair). }
    claim HepsR: eps_ Neps :e R.
    { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
    claim HepsposS: 0 < eps_ Neps.
    { exact (SNo_eps_pos Neps HNepsO). }
    claim HepsposR: Rlt 0 (eps_ Neps).
    { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }
    claim HepsS: SNo (eps_ Neps).
    { exact (real_SNo (eps_ Neps) HepsR). }
    claim Hu0R: add_SNo l (minus_SNo (eps_ Neps)) :e R.
    { exact (real_add_SNo l HlR2 (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
    claim Hsumlt1: add_SNo (eps_ Neps) a < l.
    { exact (add_SNo_minus_Lt2 l a (eps_ Neps) HlS HaS HepsS Hepslt). }
    claim Hsumlt2: add_SNo a (eps_ Neps) < l.
    { rewrite (add_SNo_com a (eps_ Neps) HaS HepsS).
      exact Hsumlt1. }
    claim Haltu0S: a < add_SNo l (minus_SNo (eps_ Neps)).
    { exact (add_SNo_minus_Lt2b l (eps_ Neps) a HlS HepsS HaS Hsumlt2). }
    claim Haltu0R: Rlt a (add_SNo l (minus_SNo (eps_ Neps))).
    { exact (RltI a (add_SNo l (minus_SNo (eps_ Neps))) HaR2 Hu0R Haltu0S). }
    claim HexAbove: exists x0:set, x0 :e A /\ x0 :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0.
    { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR HepsposR). }
    apply HexAbove.
    let x0. assume Hx0pack.
    claim Hx0pair: x0 :e A /\ x0 :e R.
    { exact (andEL (x0 :e A /\ x0 :e R)
                   (Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0)
                   Hx0pack). }
    claim Hltu0x0: Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0.
    { exact (andER (x0 :e A /\ x0 :e R)
                   (Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0)
                   Hx0pack). }
    claim Hx0A: x0 :e A.
    { exact (andEL (x0 :e A) (x0 :e R) Hx0pair). }
    claim Hx0R: x0 :e R.
    { exact (andER (x0 :e A) (x0 :e R) Hx0pair). }
    claim Haltax0: Rlt a x0.
    { exact (Rlt_tra a (add_SNo l (minus_SNo (eps_ Neps))) x0 Haltu0R Hltu0x0). }
    claim Hx0prop: exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n).
    { exact (SepE2 R
                 (fun x1 : set => exists N:set, N :e omega /\
                   forall n:set, n :e omega -> N c= n -> Rle x1 (apply_fun seq n))
                 x0
                 Hx0A). }
    apply Hx0prop.
    let N. assume HNpair3.
    witness N.
    apply andI.
    - exact (andEL (N :e omega)
                   (forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
                   HNpair3).
    - let n. assume HnO: n :e omega. assume HNsubn: N c= n.
      claim Hx0len: Rle x0 (apply_fun seq n).
      { exact (andER (N :e omega)
                     (forall n0:set, n0 :e omega -> N c= n0 -> Rle x0 (apply_fun seq n0))
                     HNpair3 n HnO HNsubn). }
      exact (Rlt_Rle_tra a x0 (apply_fun seq n) Haltax0 Hx0len). }
  claim HexUpper: exists Nhi:set, Nhi :e omega /\ forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c.
  { claim HlR2: l :e R.
    { exact HlR. }
    claim HcR2: c :e R.
    { exact HcR. }
    claim HlS: SNo l.
    { exact (real_SNo l HlR2). }
    claim HcS: SNo c.
    { exact (real_SNo c HcR2). }
    set gap := add_SNo c (minus_SNo l).
    claim HgapR: gap :e R.
    { exact (real_add_SNo c HcR2 (minus_SNo l) (real_minus_SNo l HlR2)). }
    claim HmlS: SNo (minus_SNo l).
    { exact (SNo_minus_SNo l HlS). }
    claim H0lt_gapS: 0 < add_SNo (minus_SNo l) c.
    { claim HltS: l < c.
      { exact (RltE_lt l c Hltlc). }
      claim H0lt: add_SNo (minus_SNo l) l < add_SNo (minus_SNo l) c.
      { exact (add_SNo_Lt2 (minus_SNo l) l c HmlS HlS HcS HltS). }
      rewrite <- (add_SNo_minus_SNo_linv l HlS) at 1.
      exact H0lt. }
    claim H0lt_gapS2: 0 < gap.
    { rewrite <- (add_SNo_com (minus_SNo l) c HmlS HcS) at 1.
      exact H0lt_gapS. }
    claim HgapPos: Rlt 0 gap.
    { exact (RltI 0 gap real_0 HgapR H0lt_gapS2). }
    claim Hexd: exists Nd :e omega, eps_ Nd < gap.
    { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
    apply Hexd.
    let Nd. assume HNdPair.
    claim HNdO: Nd :e omega.
    { exact (andEL (Nd :e omega) (eps_ Nd < gap) HNdPair). }
    claim HdltGapS: eps_ Nd < gap.
    { exact (andER (Nd :e omega) (eps_ Nd < gap) HNdPair). }
    set d := eps_ Nd.
    claim HdR: d :e R.
    { exact (SNoS_omega_real d (SNo_eps_SNoS_omega Nd HNdO)). }
    claim HdposS: 0 < d.
    { exact (SNo_eps_pos Nd HNdO). }
    claim Hdpos: Rlt 0 d.
    { exact (RltI 0 d real_0 HdR HdposS). }
    claim HdS: SNo d.
    { exact (real_SNo d HdR). }
    claim HmdR: minus_SNo d :e R.
    { exact (real_minus_SNo d HdR). }
    claim HmdS: SNo (minus_SNo d).
    { exact (SNo_minus_SNo d HdS). }
    claim HcdR: add_SNo c (minus_SNo d) :e R.
    { exact (real_add_SNo c HcR2 (minus_SNo d) HmdR). }
    claim HdltGapR: Rlt d gap.
    { exact (RltI d gap HdR HgapR HdltGapS). }
    claim HdltGapS2: d < gap.
    { exact (RltE_lt d gap HdltGapR). }
    claim Hdl_lt_c: add_SNo d l < c.
    { exact (add_SNo_minus_Lt2 c l d HcS HlS HdS HdltGapS2). }
    claim Hld_lt_c: add_SNo l d < c.
    { rewrite <- (add_SNo_com d l HdS HlS) at 1.
      exact Hdl_lt_c. }
    claim Hlt_l_cdS: l < add_SNo c (minus_SNo d).
    { exact (add_SNo_minus_Lt2b c d l HcS HdS HlS Hld_lt_c). }
    claim Hlt_l_cd: Rlt l (add_SNo c (minus_SNo d)).
    { exact (RltI l (add_SNo c (minus_SNo d)) HlR2 HcdR Hlt_l_cdS). }
    claim HexN0: exists N0:set, N0 :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
    { exact (HabC d (andI (d :e R) (Rlt 0 d) HdR Hdpos)). }
    apply HexN0.
    let N0. assume HN0pair.
    claim HN0omega2: N0 :e omega.
    { exact (andEL (N0 :e omega)
                   (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
                   HN0pair). }
    claim HN0tail: forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
    { exact (andER (N0 :e omega)
                   (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
                   HN0pair). }
    claim Hx0R2: apply_fun seq N0 :e R.
    { exact (Hseq N0 HN0omega2). }
    witness N0.
    apply andI.
    - exact (andEL (N0 :e omega)
                   (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
                   HN0pair).
    - let n. assume HnO: n :e omega. assume HN0subn: N0 c= n.
      prove Rlt (apply_fun seq n) c.
      claim HnR: apply_fun seq n :e R.
      { exact (Hseq n HnO). }
      apply xm (Rlt (apply_fun seq n) c).
      - assume Hlt: Rlt (apply_fun seq n) c.
        exact Hlt.
      - assume Hnlt: ~(Rlt (apply_fun seq n) c).
        claim HcLeN: Rle c (apply_fun seq n).
        { exact (RleI c (apply_fun seq n) HcR2 HnR Hnlt). }
        claim HcdA: add_SNo c (minus_SNo d) :e A.
        { apply (SepI R
                     (fun x0 : set => exists N:set, N :e omega /\
                       forall n0:set, n0 :e omega -> N c= n0 -> Rle x0 (apply_fun seq n0))
                     (add_SNo c (minus_SNo d))
                     HcdR).
          witness N0.
          apply andI.
          - exact HN0omega2.
          - let m. assume HmO: m :e omega. assume HN0subm: N0 c= m.
            claim Habmn: abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
            { exact (HN0tail m n HmO HnO HN0subm HN0subn). }
            claim HmR: apply_fun seq m :e R.
            { exact (Hseq m HmO). }
            claim HmS: SNo (apply_fun seq m).
            { exact (real_SNo (apply_fun seq m) HmR). }
            claim HnS: SNo (apply_fun seq n).
            { exact (real_SNo (apply_fun seq n) HnR). }
            claim HabsSwap: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) =
              abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))).
            { exact (abs_SNo_dist_swap (apply_fun seq n) (apply_fun seq m) HnS HmS). }
            claim Habnm: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) < d.
            { rewrite HabsSwap.
              exact Habmn. }
            claim HtS: SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))).
            { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m)) HnS
                      (SNo_minus_SNo (apply_fun seq m) HmS)). }
            claim Hnm_lt_d: add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m)) < d.
            { exact (abs_SNo_lt_imp_lt (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) d
                      HtS HdS HdposS Habnm). }
            claim Hn_lt_dm: apply_fun seq n < add_SNo d (apply_fun seq m).
            { exact (add_SNo_minus_Lt1 (apply_fun seq n) (apply_fun seq m) d HnS HmS HdS Hnm_lt_d). }
            claim Hn_lt_md: apply_fun seq n < add_SNo (apply_fun seq m) d.
            { rewrite <- (add_SNo_com d (apply_fun seq m) HdS HmS) at 1.
              exact Hn_lt_dm. }
            claim Hnmd_lt_m: add_SNo (apply_fun seq n) (minus_SNo d) < apply_fun seq m.
            { exact (add_SNo_minus_Lt1b (apply_fun seq n) d (apply_fun seq m) HnS HdS HmS Hn_lt_md). }
            claim HnmdR: add_SNo (apply_fun seq n) (minus_SNo d) :e R.
            { exact (real_add_SNo (apply_fun seq n) HnR (minus_SNo d) HmdR). }
            claim Hnmd_lt_mR: Rlt (add_SNo (apply_fun seq n) (minus_SNo d)) (apply_fun seq m).
            { exact (RltI (add_SNo (apply_fun seq n) (minus_SNo d)) (apply_fun seq m) HnmdR HmR Hnmd_lt_m). }
            claim HcdLeNmd: Rle (add_SNo c (minus_SNo d)) (add_SNo (apply_fun seq n) (minus_SNo d)).
            { claim Hleft: Rle (add_SNo (minus_SNo d) c) (add_SNo (minus_SNo d) (apply_fun seq n)).
              { exact (Rle_add_SNo_2 (minus_SNo d) c (apply_fun seq n) HmdR HcR2 HnR HcLeN). }
              rewrite <- (add_SNo_com (minus_SNo d) c HmdS HcS) at 1.
              rewrite <- (add_SNo_com (minus_SNo d) (apply_fun seq n) HmdS HnS) at 1.
              exact Hleft. }
            claim Hcdltm: Rlt (add_SNo c (minus_SNo d)) (apply_fun seq m).
            { exact (Rle_Rlt_tra (add_SNo c (minus_SNo d))
                                 (add_SNo (apply_fun seq n) (minus_SNo d))
                                 (apply_fun seq m)
                                 HcdLeNmd
                                 Hnmd_lt_mR). }
            exact (Rlt_implies_Rle (add_SNo c (minus_SNo d)) (apply_fun seq m) Hcdltm). }
        claim HcdLeL: Rle (add_SNo c (minus_SNo d)) l.
        { exact (HubA (add_SNo c (minus_SNo d)) HcdA HcdR). }
        claim Hnlt2: ~(Rlt l (add_SNo c (minus_SNo d))).
        { exact (RleE_nlt (add_SNo c (minus_SNo d)) l HcdLeL). }
        exact (FalseE (Hnlt2 Hlt_l_cd) (Rlt (apply_fun seq n) c)). }
  apply HexLower.
  let Nlow. assume HNlowpair.
  apply HexUpper.
  let Nhi. assume HNhipair.
  set N := ordsucc (Nlow :\/: Nhi).
  witness N.
  apply andI.
  - claim Hmax: Nlow :\/: Nhi :e omega.
    { exact (omega_binunion Nlow Nhi
                           (andEL (Nlow :e omega) (forall n:set, n :e omega -> Nlow c= n -> Rlt a (apply_fun seq n)) HNlowpair)
                           (andEL (Nhi :e omega) (forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c) HNhipair)). }
    exact (omega_ordsucc (Nlow :\/: Nhi) Hmax).
  - let n. assume HnO: n :e omega. assume HNsub: N c= n.
    prove apply_fun seq n :e U.
    claim HNlowSubn: Nlow c= n.
    { let t. assume Ht: t :e Nlow.
      claim HtN: t :e N.
      { claim Htmax: t :e (Nlow :\/: Nhi).
        { exact (binunionI1 Nlow Nhi t Ht). }
        exact (ordsuccI1 (Nlow :\/: Nhi) t Htmax). }
      exact (HNsub t HtN). }
    claim HNhiSubn: Nhi c= n.
    { let t. assume Ht: t :e Nhi.
      claim HtN: t :e N.
      { claim Htmax: t :e (Nlow :\/: Nhi).
        { exact (binunionI2 Nlow Nhi t Ht). }
        exact (ordsuccI1 (Nlow :\/: Nhi) t Htmax). }
      exact (HNsub t HtN). }
    claim HltA: Rlt a (apply_fun seq n).
    { exact ((andER (Nlow :e omega)
                   (forall n0:set, n0 :e omega -> Nlow c= n0 -> Rlt a (apply_fun seq n0))
                   HNlowpair) n HnO HNlowSubn). }
    claim HltC: Rlt (apply_fun seq n) c.
    { exact ((andER (Nhi :e omega)
                   (forall n0:set, n0 :e omega -> Nhi c= n0 -> Rlt (apply_fun seq n0) c)
                   HNhipair) n HnO HNhiSubn). }
    claim HnR: apply_fun seq n :e R.
    { exact (Hseq n HnO). }
    claim Hnb: apply_fun seq n :e open_interval a c.
    { claim HdefInt: open_interval a c = {x :e R|Rlt a x /\ Rlt x c}.
      { reflexivity. }
      rewrite HdefInt.
      apply (SepI R (fun x0 : set => Rlt a x0 /\ Rlt x0 c) (apply_fun seq n) HnR).
      apply andI.
      - exact HltA.
      - exact HltC. }
    claim Hnb2: apply_fun seq n :e b.
    { rewrite Hbeq.
      exact Hnb. }
    exact (HbsubU (apply_fun seq n) Hnb2).
Qed.

(** helper: bounded metric on R is complete (early stub for §35) **)
(** LATEX VERSION: The real line with the bounded metric is complete. **)
Theorem R_bounded_metric_complete_early : complete_metric_space R R_bounded_metric.
prove metric_on R R_bounded_metric /\
  forall seq:set, sequence_on seq R -> cauchy_sequence R R_bounded_metric seq ->
    exists x:set, converges_to R (metric_topology R R_bounded_metric) seq x.
apply andI.
- exact R_bounded_metric_is_metric_on_early.
- let seq.
  assume Hseq: sequence_on seq R.
  assume Hc: cauchy_sequence R R_bounded_metric seq.
  claim HabsTail: forall eps0:set, eps0 :e R -> Rlt 0 eps0 -> Rlt eps0 1 ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
  { let eps0.
    assume Heps0R: eps0 :e R.
    assume Heps0Pos: Rlt 0 eps0.
    assume Heps0Lt1: Rlt eps0 1.
    exact (cauchy_R_bounded_metric_abs_tail_early seq eps0 Hc Heps0R Heps0Pos Heps0Lt1). }
  claim HabC: forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
  { let eps0.
    assume Heps0: eps0 :e R /\ Rlt 0 eps0.
    claim Heps0R: eps0 :e R.
    { exact (andEL (eps0 :e R) (Rlt 0 eps0) Heps0). }
    claim Heps0Pos: Rlt 0 eps0.
    { exact (andER (eps0 :e R) (Rlt 0 eps0) Heps0). }
    claim Hexd: exists d:set, d :e R /\ Rlt 0 d /\ Rlt d eps0 /\ Rlt d 1 /\ Rlt d 1 /\ Rlt d 1.
    { exact (exists_eps_lt_four_pos_Euclid eps0 1 1 1 Heps0R real_1 real_1 real_1 Heps0Pos Rlt_0_1 Rlt_0_1 Rlt_0_1). }
    apply Hexd.
    let d. assume Hd: d :e R /\ Rlt 0 d /\ Rlt d eps0 /\ Rlt d 1 /\ Rlt d 1 /\ Rlt d 1.
    claim HdABCDE: ((((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) /\ Rlt d 1).
    { exact (andEL ((((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) /\ Rlt d 1) (Rlt d 1) Hd). }
    claim HdABCD: (((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1).
    { exact (andEL (((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) (Rlt d 1) HdABCDE). }
    claim HdABC: ((d :e R /\ Rlt 0 d) /\ Rlt d eps0).
    { exact (andEL ((d :e R /\ Rlt 0 d) /\ Rlt d eps0) (Rlt d 1) HdABCD). }
    claim HdD: Rlt d 1.
    { exact (andER ((d :e R /\ Rlt 0 d) /\ Rlt d eps0) (Rlt d 1) HdABCD). }
    claim HdAB: d :e R /\ Rlt 0 d.
    { exact (andEL (d :e R /\ Rlt 0 d) (Rlt d eps0) HdABC). }
    claim Hdeps0: Rlt d eps0.
    { exact (andER (d :e R /\ Rlt 0 d) (Rlt d eps0) HdABC). }
    claim HdR: d :e R.
    { exact (andEL (d :e R) (Rlt 0 d) HdAB). }
    claim HdPos: Rlt 0 d.
    { exact (andER (d :e R) (Rlt 0 d) HdAB). }
    claim Hdlt1: Rlt d 1.
    { exact HdD. }
    claim HexN: exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
    { exact (HabsTail d HdR HdPos Hdlt1). }
    apply HexN.
    let N. assume HNpair.
    witness N.
    apply andI.
    - exact (andEL (N :e omega)
                   (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
                   HNpair).
    - let m n.
      assume HmO: m :e omega.
      assume HnO: n :e omega.
      assume HNm: N c= m.
      assume HNn: N c= n.
      prove abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
      claim Habd: abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
      { exact (andER (N :e omega)
                     (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                       abs_SNo (add_SNo (apply_fun seq m0) (minus_SNo (apply_fun seq n0))) < d)
                     HNpair m n HmO HnO HNm HNn). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      claim Heps0S: SNo eps0.
      { exact (real_SNo eps0 Heps0R). }
      claim Hdeps0S: d < eps0.
      { exact (RltE_lt d eps0 Hdeps0). }
      claim HmR: apply_fun seq m :e R.
      { exact (Hseq m HmO). }
      claim HnR: apply_fun seq n :e R.
      { exact (Hseq n HnO). }
      claim HmnR: add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n)) :e R.
      { exact (real_add_SNo (apply_fun seq m) HmR
                            (minus_SNo (apply_fun seq n))
                            (real_minus_SNo (apply_fun seq n) HnR)). }
      claim HabsR: abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) :e R.
      { exact (abs_SNo_in_R (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) HmnR). }
      claim HabsS: SNo (abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n)))).
      { exact (real_SNo (abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n)))) HabsR). }
      exact (SNoLt_tra (abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))))
                       d
                       eps0
                       HabsS
                       HdS
                       Heps0S
                       Habd
                       Hdeps0S). }
  claim HexStd: exists x:set, converges_to R R_standard_topology seq x.
  { exact (abs_Cauchy_sequence_converges_R_standard_topology_early seq Hseq HabC). }
  apply HexStd.
  let x. assume HxStd: converges_to R R_standard_topology seq x.
  witness x.
  prove converges_to R (metric_topology R R_bounded_metric) seq x.
  rewrite metric_topology_R_bounded_metric_eq_R_standard_topology_early.
  exact HxStd.
Qed.

(** helper: uniform limit of continuous maps to R is continuous in the standard topology **)
(** LATEX VERSION: If f_n:X->R are continuous (usual topology) and converge uniformly in the bounded metric, then the limit is continuous. **)
Theorem uniform_limit_of_continuous_to_R_standard_topology : forall X Tx fn f:set,
  topology_on X Tx ->
  function_on fn omega (function_space X R) ->
  function_on f X R ->
  (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)) ->
  uniform_limit_metric X R R_bounded_metric fn f ->
  continuous_map X Tx R R_standard_topology f.
let X Tx fn f.
assume HTx: topology_on X Tx.
assume Hfn: function_on fn omega (function_space X R).
assume Hf: function_on f X R.
assume Hcont: forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n).
assume Hunif: uniform_limit_metric X R R_bounded_metric fn f.
prove continuous_map X Tx R R_standard_topology f.
rewrite <- metric_topology_R_bounded_metric_eq_R_standard_topology_early.
claim Hcont2: forall n:set, n :e omega ->
  continuous_map X Tx R (metric_topology R R_bounded_metric) (apply_fun fn n).
{ let n. assume HnO: n :e omega.
  prove continuous_map X Tx R (metric_topology R R_bounded_metric) (apply_fun fn n).
  rewrite metric_topology_R_bounded_metric_eq_R_standard_topology_early.
  exact (Hcont n HnO). }
exact (uniform_limit_of_continuous_to_metric_is_continuous
         X Tx R R_bounded_metric fn f
         HTx
         R_bounded_metric_is_metric_on_early
         Hfn
         Hf
         Hcont2
         Hunif).
Qed.

(** helper: uniformly Cauchy continuous maps to R have a continuous uniform limit **)
(** LATEX VERSION: In a complete metric codomain, a uniformly Cauchy sequence of continuous functions has a continuous uniform limit. **)
Theorem uniform_cauchy_continuous_to_R_has_continuous_limit : forall X Tx fn:set,
  topology_on X Tx ->
  function_on fn omega (function_space X R) ->
  (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)) ->
  uniform_cauchy_metric X R R_bounded_metric fn ->
  exists f:set,
    function_on f X R /\
    uniform_limit_metric X R R_bounded_metric fn f /\
    continuous_map X Tx R R_standard_topology f.
let X Tx fn.
assume HTx: topology_on X Tx.
assume Hfn: function_on fn omega (function_space X R).
assume Hcont: forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n).
assume Huc: uniform_cauchy_metric X R R_bounded_metric fn.
claim Hexlim: exists f:set, function_on f X R /\ uniform_limit_metric X R R_bounded_metric fn f.
{ exact (uniform_cauchy_metric_complete_imp_uniform_limit_stub
           X R R_bounded_metric fn
           R_bounded_metric_complete_early
           Hfn
           Huc). }
apply Hexlim.
let f. assume Hfpack: function_on f X R /\ uniform_limit_metric X R R_bounded_metric fn f.
witness f.
apply andI.
- exact Hfpack.
- exact (uniform_limit_of_continuous_to_R_standard_topology
           X Tx fn f
           HTx
           Hfn
           (andEL (function_on f X R) (uniform_limit_metric X R R_bounded_metric fn f) Hfpack)
           Hcont
           (andER (function_on f X R) (uniform_limit_metric X R R_bounded_metric fn f) Hfpack)).
Qed.

(** from §35 Theorem 35.1: Tietze extension theorem **)
(** LATEX VERSION: Tietze extension theorem for normal spaces and intervals. **)
(** helper for §35: 1/3 and 2/3 in R **)
Definition one_third : set := inv_nat 3.
Definition two_thirds : set := add_SNo one_third one_third.

Theorem one_third_in_R : one_third :e R.
prove one_third :e R.
claim H3nat: nat_p 3.
{ exact (nat_ordsucc 2 nat_2). }
claim H3omega: 3 :e omega.
{ exact (nat_p_omega 3 H3nat). }
claim Hdef: one_third = inv_nat 3.
{ reflexivity. }
rewrite Hdef.
exact (inv_nat_real 3 H3omega).
Qed.

	Theorem two_thirds_in_R : two_thirds :e R.
	prove two_thirds :e R.
	claim Hdef: two_thirds = add_SNo one_third one_third.
	{ reflexivity. }
	rewrite Hdef.
	claim H13R: one_third :e R.
	{ exact one_third_in_R. }
	exact (real_add_SNo one_third H13R one_third H13R).
	Qed.
	
	(** helper for §35: positivity of one_third and two_thirds **)
	Theorem one_third_pos : 0 < one_third.
	prove 0 < one_third.
	claim H3nat: nat_p 3.
	{ exact (nat_ordsucc 2 nat_2). }
	claim H3omega: 3 :e omega.
	{ exact (nat_p_omega 3 H3nat). }
	claim H3non0: 3 /:e {0}.
	{ assume H3in: 3 :e {0}.
	  claim H30: 3 = 0.
	  { exact (SingE 0 3 H3in). }
	  claim H3ne0: 3 <> 0.
	  { claim H3def: 3 = ordsucc 2.
	    { reflexivity. }
	    rewrite H3def.
	    exact (neq_ordsucc_0 2). }
	  exact (H3ne0 H30). }
	claim H3in: 3 :e omega :\: {0}.
	{ exact (setminusI omega {0} 3 H3omega H3non0). }
		claim Hdef: one_third = inv_nat 3.
		{ reflexivity. }
		rewrite Hdef.
		claim H0ltR: Rlt 0 (inv_nat 3).
		{ exact (inv_nat_pos 3 H3in). }
		exact (RltE_lt 0 (inv_nat 3) H0ltR).
		Qed.
	
	Theorem two_thirds_pos : 0 < two_thirds.
	prove 0 < two_thirds.
	claim H13R: one_third :e R.
	{ exact one_third_in_R. }
	claim H13S: SNo one_third.
	{ exact (real_SNo one_third H13R). }
	claim H23R: two_thirds :e R.
	{ exact two_thirds_in_R. }
	claim H23S: SNo two_thirds.
	{ exact (real_SNo two_thirds H23R). }
	claim Hlt13: 0 < one_third.
	{ exact one_third_pos. }
	claim H1lt2: one_third < two_thirds.
	{ claim Hdef: two_thirds = add_SNo one_third one_third.
	  { reflexivity. }
	  rewrite Hdef.
	  rewrite <- (add_SNo_0R one_third H13S) at 1.
	  exact (add_SNo_Lt2 one_third 0 one_third H13S SNo_0 H13S Hlt13). }
	exact (SNoLt_tra 0 one_third two_thirds SNo_0 H13S H23S Hlt13 H1lt2).
	Qed.
	
		Theorem two_thirds_ne0 : two_thirds <> 0.
		assume H20: two_thirds = 0.
		claim H0lt0: 0 < 0.
		{ rewrite <- H20 at 2.
		  exact two_thirds_pos. }
			exact ((SNoLt_irref 0) H0lt0).
			Qed.
		
		(** helper for §35: division by a positive constant is continuous on R **)
		Definition div_const_fun : set -> set := fun c =>
		  graph R (fun t:set => div_SNo t c).
	
		Theorem div_const_fun_apply : forall c t:set,
		  c :e R -> t :e R ->
		  apply_fun (div_const_fun c) t = div_SNo t c.
		let c t.
		assume HcR: c :e R.
		assume HtR: t :e R.
		claim Hdef: div_const_fun c = graph R (fun t0:set => div_SNo t0 c).
		{ reflexivity. }
		rewrite Hdef.
		exact (apply_fun_graph R (fun t0:set => div_SNo t0 c) t HtR).
		Qed.

		(** helper for §35: apply_fun of compose_fun with div_const_fun **)
		Theorem compose_div_const_fun_apply : forall A f c x:set,
		  x :e A -> c :e R -> apply_fun f x :e R ->
		  apply_fun (compose_fun A f (div_const_fun c)) x = div_SNo (apply_fun f x) c.
		let A f c x.
		assume HxA: x :e A.
		assume HcR: c :e R.
		assume HfxR: apply_fun f x :e R.
		rewrite (compose_fun_apply A f (div_const_fun c) x HxA).
		rewrite (div_const_fun_apply c (apply_fun f x) HcR HfxR).
		reflexivity.
		Qed.

		(** helper: div_const_fun c is an element of function_space R R **)
		(** LATEX VERSION: For fixed c∈ℝ, the map t↦t/c is a function ℝ→ℝ. **)
		Theorem div_const_fun_in_function_space : forall c:set,
		  c :e R -> div_const_fun c :e function_space R R.
	let c.
	assume HcR: c :e R.
	set g := (fun t:set => div_SNo t c).
	claim Hg: forall t:set, t :e R -> g t :e R.
	{ let t. assume HtR: t :e R.
	  prove g t :e R.
	  exact (real_div_SNo t HtR c HcR). }
	claim Hdef: div_const_fun c = graph R g.
	{ reflexivity. }
	rewrite Hdef.
	exact (graph_in_function_space R R g Hg).
	Qed.
	
	Theorem div_const_fun_value_in_R : forall c t:set,
	  c :e R -> t :e R ->
	  apply_fun (div_const_fun c) t :e R.
	let c t.
	assume HcR: c :e R.
	assume HtR: t :e R.
	rewrite (div_const_fun_apply c t HcR HtR).
	exact (real_div_SNo t HtR c HcR).
	Qed.
	
	(** preimage of an upper ray under division by positive c **)
	Theorem preimage_div_const_open_ray_upper : forall c a:set,
	  c :e R -> 0 < c -> a :e R ->
	  preimage_of R (div_const_fun c) (open_ray_upper R a) = open_ray_upper R (mul_SNo a c).
	let c a.
	assume HcR: c :e R.
	assume Hcpos: 0 < c.
	assume HaR: a :e R.
	prove preimage_of R (div_const_fun c) (open_ray_upper R a) = open_ray_upper R (mul_SNo a c).
	apply set_ext.
	- let t. assume HtPre: t :e preimage_of R (div_const_fun c) (open_ray_upper R a).
	  prove t :e open_ray_upper R (mul_SNo a c).
	  claim HtR: t :e R.
	  { exact (SepE1 R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_upper R a) t HtPre). }
	  claim Himg: apply_fun (div_const_fun c) t :e open_ray_upper R a.
	  { exact (SepE2 R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_upper R a) t HtPre). }
	  claim Hrel: order_rel R a (apply_fun (div_const_fun c) t).
	  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun (div_const_fun c) t) Himg). }
	  claim Hrlt: Rlt a (apply_fun (div_const_fun c) t).
	  { exact (order_rel_R_implies_Rlt a (apply_fun (div_const_fun c) t) Hrel). }
	  claim HdivEq: apply_fun (div_const_fun c) t = div_SNo t c.
	  { exact (div_const_fun_apply c t HcR HtR). }
	  claim HtS: SNo t.
	  { exact (real_SNo t HtR). }
	  claim HcS: SNo c.
	  { exact (real_SNo c HcR). }
	  claim HaS: SNo a.
	  { exact (real_SNo a HaR). }
	  claim HacR: mul_SNo a c :e R.
	  { exact (real_mul_SNo a HaR c HcR). }
	  claim HacS: SNo (mul_SNo a c).
	  { exact (real_SNo (mul_SNo a c) HacR). }
		  claim Halt: a < div_SNo t c.
		  { rewrite <- HdivEq.
		    exact (RltE_lt a (apply_fun (div_const_fun c) t) Hrlt). }
	  claim HmulLt: mul_SNo a c < t.
	  { exact (div_SNo_pos_LtR' t c a HtS HcS HaS Hcpos Halt). }
	  claim Hray: order_rel R (mul_SNo a c) t.
	  { exact (Rlt_implies_order_rel_R (mul_SNo a c) t (RltI (mul_SNo a c) t HacR HtR HmulLt)). }
	  exact (SepI R (fun x0:set => order_rel R (mul_SNo a c) x0) t HtR Hray).
	- let t. assume HtRay: t :e open_ray_upper R (mul_SNo a c).
	  prove t :e preimage_of R (div_const_fun c) (open_ray_upper R a).
	  claim HtR: t :e R.
	  { exact (SepE1 R (fun x0:set => order_rel R (mul_SNo a c) x0) t HtRay). }
	  claim Hrel: order_rel R (mul_SNo a c) t.
	  { exact (SepE2 R (fun x0:set => order_rel R (mul_SNo a c) x0) t HtRay). }
	  claim Hrlt: Rlt (mul_SNo a c) t.
	  { exact (order_rel_R_implies_Rlt (mul_SNo a c) t Hrel). }
	  claim HtS: SNo t.
	  { exact (real_SNo t HtR). }
	  claim HcS: SNo c.
	  { exact (real_SNo c HcR). }
	  claim HaS: SNo a.
	  { exact (real_SNo a HaR). }
	  claim HacR: mul_SNo a c :e R.
	  { exact (real_mul_SNo a HaR c HcR). }
	  claim HacS: SNo (mul_SNo a c).
	  { exact (real_SNo (mul_SNo a c) HacR). }
	  claim HmulLt: mul_SNo a c < t.
	  { exact (RltE_lt (mul_SNo a c) t Hrlt). }
	  claim Halt: a < div_SNo t c.
	  { exact (div_SNo_pos_LtR t c a HtS HcS HaS Hcpos HmulLt). }
	  claim Hray: order_rel R a (div_SNo t c).
	  { exact (Rlt_implies_order_rel_R a (div_SNo t c) (RltI a (div_SNo t c) HaR (real_div_SNo t HtR c HcR) Halt)). }
	  claim Himg: div_SNo t c :e open_ray_upper R a.
	  { exact (SepI R (fun x0:set => order_rel R a x0) (div_SNo t c) (real_div_SNo t HtR c HcR) Hray). }
	  claim Hpredef: preimage_of R (div_const_fun c) (open_ray_upper R a) =
	    {x0 :e R | apply_fun (div_const_fun c) x0 :e open_ray_upper R a}.
	  { reflexivity. }
	  rewrite Hpredef.
	  apply (SepI R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_upper R a) t HtR).
	  rewrite (div_const_fun_apply c t HcR HtR).
	  exact Himg.
	Qed.
	
	(** preimage of a lower ray under division by positive c **)
	Theorem preimage_div_const_open_ray_lower : forall c b:set,
	  c :e R -> 0 < c -> b :e R ->
	  preimage_of R (div_const_fun c) (open_ray_lower R b) = open_ray_lower R (mul_SNo b c).
	let c b.
	assume HcR: c :e R.
	assume Hcpos: 0 < c.
	assume HbR: b :e R.
	prove preimage_of R (div_const_fun c) (open_ray_lower R b) = open_ray_lower R (mul_SNo b c).
	apply set_ext.
	- let t. assume HtPre: t :e preimage_of R (div_const_fun c) (open_ray_lower R b).
	  prove t :e open_ray_lower R (mul_SNo b c).
	  claim HtR: t :e R.
	  { exact (SepE1 R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_lower R b) t HtPre). }
	  claim Himg: apply_fun (div_const_fun c) t :e open_ray_lower R b.
	  { exact (SepE2 R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_lower R b) t HtPre). }
	  claim Hrel: order_rel R (apply_fun (div_const_fun c) t) b.
	  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun (div_const_fun c) t) Himg). }
	  claim Hrlt: Rlt (apply_fun (div_const_fun c) t) b.
	  { exact (order_rel_R_implies_Rlt (apply_fun (div_const_fun c) t) b Hrel). }
	  claim HdivEq: apply_fun (div_const_fun c) t = div_SNo t c.
	  { exact (div_const_fun_apply c t HcR HtR). }
	  claim HtS: SNo t.
	  { exact (real_SNo t HtR). }
	  claim HcS: SNo c.
	  { exact (real_SNo c HcR). }
	  claim HbS: SNo b.
	  { exact (real_SNo b HbR). }
	  claim HbcR: mul_SNo b c :e R.
	  { exact (real_mul_SNo b HbR c HcR). }
	  claim HbcS: SNo (mul_SNo b c).
	  { exact (real_SNo (mul_SNo b c) HbcR). }
		  claim Hdivlt: div_SNo t c < b.
		  { rewrite <- HdivEq.
		    exact (RltE_lt (apply_fun (div_const_fun c) t) b Hrlt). }
	  claim HmulLt: t < mul_SNo b c.
	  { exact (div_SNo_pos_LtL' t c b HtS HcS HbS Hcpos Hdivlt). }
	  claim Hray: order_rel R t (mul_SNo b c).
	  { exact (Rlt_implies_order_rel_R t (mul_SNo b c) (RltI t (mul_SNo b c) HtR HbcR HmulLt)). }
	  exact (SepI R (fun x0:set => order_rel R x0 (mul_SNo b c)) t HtR Hray).
	- let t. assume HtRay: t :e open_ray_lower R (mul_SNo b c).
	  prove t :e preimage_of R (div_const_fun c) (open_ray_lower R b).
	  claim HtR: t :e R.
	  { exact (SepE1 R (fun x0:set => order_rel R x0 (mul_SNo b c)) t HtRay). }
	  claim Hrel: order_rel R t (mul_SNo b c).
	  { exact (SepE2 R (fun x0:set => order_rel R x0 (mul_SNo b c)) t HtRay). }
	  claim Hrlt: Rlt t (mul_SNo b c).
	  { exact (order_rel_R_implies_Rlt t (mul_SNo b c) Hrel). }
	  claim HtS: SNo t.
	  { exact (real_SNo t HtR). }
	  claim HcS: SNo c.
	  { exact (real_SNo c HcR). }
	  claim HbS: SNo b.
	  { exact (real_SNo b HbR). }
	  claim HbcR: mul_SNo b c :e R.
	  { exact (real_mul_SNo b HbR c HcR). }
	  claim HbcS: SNo (mul_SNo b c).
	  { exact (real_SNo (mul_SNo b c) HbcR). }
	  claim HmulLt: t < mul_SNo b c.
	  { exact (RltE_lt t (mul_SNo b c) Hrlt). }
	  claim Hdivlt: div_SNo t c < b.
	  { exact (div_SNo_pos_LtL t c b HtS HcS HbS Hcpos HmulLt). }
	  claim Hray: order_rel R (div_SNo t c) b.
	  { exact (Rlt_implies_order_rel_R (div_SNo t c) b (RltI (div_SNo t c) b (real_div_SNo t HtR c HcR) HbR Hdivlt)). }
	  claim Himg: div_SNo t c :e open_ray_lower R b.
	  { exact (SepI R (fun x0:set => order_rel R x0 b) (div_SNo t c) (real_div_SNo t HtR c HcR) Hray). }
	  claim Hpredef: preimage_of R (div_const_fun c) (open_ray_lower R b) =
	    {x0 :e R | apply_fun (div_const_fun c) x0 :e open_ray_lower R b}.
	  { reflexivity. }
	  rewrite Hpredef.
	  apply (SepI R (fun x0:set => apply_fun (div_const_fun c) x0 :e open_ray_lower R b) t HtR).
	  rewrite (div_const_fun_apply c t HcR HtR).
	  exact Himg.
	Qed.
	
Theorem div_const_fun_continuous_pos : forall c:set,
  c :e R -> 0 < c ->
  continuous_map R R_standard_topology R R_standard_topology (div_const_fun c).
	let c.
	assume HcR: c :e R.
	assume Hcpos: 0 < c.
	prove continuous_map R R_standard_topology R R_standard_topology (div_const_fun c).
	set Tx := R_standard_topology.
	set S := open_rays_subbasis R.
	claim HTx: topology_on R Tx.
	{ exact R_standard_topology_is_topology. }
	claim Hfun: function_on (div_const_fun c) R R.
	{ let t. assume HtR: t :e R.
	  exact (div_const_fun_value_in_R c t HcR HtR). }
	claim HS: subbasis_on R S.
	{ exact (open_rays_subbasis_is_subbasis R). }
	claim Hgen: generated_topology_from_subbasis R S = Tx.
	{ rewrite open_rays_subbasis_for_order_topology_R.
	  rewrite standard_topology_is_order_topology.
	  reflexivity. }
	rewrite <- Hgen at 2.
	apply (continuous_map_from_subbasis R Tx R S (div_const_fun c) HTx Hfun HS).
	let s. assume HsS: s :e S.
	prove preimage_of R (div_const_fun c) s :e Tx.
	claim HSdef: S =
	  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
	    :\/:
	    {I :e Power R | exists b :e R, I = open_ray_lower R b})
	   :\/:
	   {R}).
	{ reflexivity. }
	claim HsS': s :e
	  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
	    :\/:
	    {I :e Power R | exists b :e R, I = open_ray_lower R b})
	   :\/:
	   {R}).
	{ rewrite <- HSdef.
	  exact HsS. }
	apply (binunionE'
	  ({I :e Power R | exists a :e R, I = open_ray_upper R a}
	   :\/:
	   {I :e Power R | exists b :e R, I = open_ray_lower R b})
	  {R}
	  s
	  (preimage_of R (div_const_fun c) s :e Tx)).
	- assume HsAB: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
	                     :\/:
	                     {I :e Power R | exists b :e R, I = open_ray_lower R b}).
	  apply (binunionE'
	    {I :e Power R | exists a :e R, I = open_ray_upper R a}
	    {I :e Power R | exists b :e R, I = open_ray_lower R b}
	    s
	    (preimage_of R (div_const_fun c) s :e Tx)).
	  + assume HsUpper: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
	    claim Hex: exists a :e R, s = open_ray_upper R a.
	    { exact (SepE2 (Power R) (fun I0:set => exists a :e R, I0 = open_ray_upper R a) s HsUpper). }
	    apply Hex.
	    let a. assume Hacore.
	    apply Hacore.
	    assume HaR: a :e R.
	    assume Hseq: s = open_ray_upper R a.
	    rewrite Hseq.
	    rewrite (preimage_div_const_open_ray_upper c a HcR Hcpos HaR).
	    rewrite <- standard_topology_is_order_topology.
	    claim Hray: open_ray_upper R (mul_SNo a c) :e open_rays_subbasis R.
	    { claim HacR: mul_SNo a c :e R.
	      { exact (real_mul_SNo a HaR c HcR). }
	      exact (open_ray_upper_in_open_rays_subbasis R (mul_SNo a c) HacR). }
	    exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R (mul_SNo a c)) Hray).
	  + assume HsLower: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
	    claim Hex: exists b :e R, s = open_ray_lower R b.
	    { exact (SepE2 (Power R) (fun I0:set => exists b :e R, I0 = open_ray_lower R b) s HsLower). }
	    apply Hex.
	    let b. assume Hbcore.
	    apply Hbcore.
	    assume HbR: b :e R.
	    assume Hseq: s = open_ray_lower R b.
	    rewrite Hseq.
	    rewrite (preimage_div_const_open_ray_lower c b HcR Hcpos HbR).
	    rewrite <- standard_topology_is_order_topology.
	    claim Hray: open_ray_lower R (mul_SNo b c) :e open_rays_subbasis R.
	    { claim HbcR: mul_SNo b c :e R.
	      { exact (real_mul_SNo b HbR c HcR). }
	      exact (open_ray_lower_in_open_rays_subbasis R (mul_SNo b c) HbcR). }
	    exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R (mul_SNo b c)) Hray).
	  + exact HsAB.
		- assume HsR: s :e {R}.
		  claim Hseq: s = R.
		  { exact (SingE R s HsR). }
		  rewrite Hseq.
		  rewrite (preimage_of_whole R R (div_const_fun c) Hfun).
		  exact (topology_has_X R Tx HTx).
		- exact HsS'.
		Qed.

(** helper for §35: multiplication by a fixed constant on R **)
Definition mul_const_fun : set -> set := fun c =>
  graph R (fun t:set => mul_SNo t c).

Theorem mul_const_fun_apply : forall c t:set,
  c :e R -> t :e R ->
  apply_fun (mul_const_fun c) t = mul_SNo t c.
let c t.
assume HcR: c :e R.
assume HtR: t :e R.
claim Hdef: mul_const_fun c = graph R (fun t0:set => mul_SNo t0 c).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph R (fun t0:set => mul_SNo t0 c) t HtR).
Qed.

(** helper for §35 Step II: scaling from [-den,den] to [-1,1] for den>0 **)
Theorem div_SNo_closed_interval_scale : forall den y:set,
  den :e R -> 0 < den ->
  y :e closed_interval (minus_SNo den) den ->
  div_SNo y den :e closed_interval (minus_SNo 1) 1.
let den y.
assume HdenR: den :e R.
assume HdenPos: 0 < den.
assume HyI2: y :e closed_interval (minus_SNo den) den.
prove div_SNo y den :e closed_interval (minus_SNo 1) 1.
claim Hm1R: (minus_SNo 1) :e R.
{ exact (real_minus_SNo 1 real_1). }
claim HmdenR: (minus_SNo den) :e R.
{ exact (real_minus_SNo den HdenR). }
claim HyR: y :e R.
{ exact (closed_interval_sub_R (minus_SNo den) den y HyI2). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HdenS: SNo den.
{ exact (real_SNo den HdenR). }
claim Hdenne0: den <> 0.
{ exact (SNo_pos_ne0 den HdenS HdenPos). }
claim Hbounds: Rle (minus_SNo den) y /\ Rle y den.
{ exact (closed_interval_bounds (minus_SNo den) den y HmdenR HdenR HyI2). }
claim Hlo: Rle (minus_SNo den) y.
{ exact (andEL (Rle (minus_SNo den) y) (Rle y den) Hbounds). }
claim Hhi: Rle y den.
{ exact (andER (Rle (minus_SNo den) y) (Rle y den) Hbounds). }
claim Hnlt_hi: ~(Rlt den y).
{ exact (RleE_nlt y den Hhi). }
claim Hnlt_lo: ~(Rlt y (minus_SNo den)).
{ exact (RleE_nlt (minus_SNo den) y Hlo). }
claim HyDivR: div_SNo y den :e R.
{ exact (real_div_SNo y HyR den HdenR). }
claim HyDivS: SNo (div_SNo y den).
{ exact (real_SNo (div_SNo y den) HyDivR). }
claim Hy_le_1: Rle (div_SNo y den) 1.
{ apply (RleI (div_SNo y den) 1 HyDivR real_1).
  prove ~(Rlt 1 (div_SNo y den)).
  assume H1lt: Rlt 1 (div_SNo y den).
  claim H1lty: 1 < div_SNo y den.
  { exact (RltE_lt 1 (div_SNo y den) H1lt). }
  claim HmulLt: mul_SNo 1 den < mul_SNo (div_SNo y den) den.
  { exact (pos_mul_SNo_Lt' 1 (div_SNo y den) den SNo_1 HyDivS HdenS HdenPos H1lty). }
  claim HmulLt': den < mul_SNo (div_SNo y den) den.
  { rewrite <- (mul_SNo_oneL den HdenS) at 1.
    exact HmulLt. }
  claim HmulEq: mul_SNo (div_SNo y den) den = y.
  { exact (mul_div_SNo_invL y den HyS HdenS Hdenne0). }
  claim Hden_lt_y: den < y.
  { rewrite <- HmulEq.
    exact HmulLt'. }
  claim Hbad: Rlt den y.
  { exact (RltI den y HdenR HyR Hden_lt_y). }
  exact (Hnlt_hi Hbad). }
claim Hm1_le_y: Rle (minus_SNo 1) (div_SNo y den).
{ apply (RleI (minus_SNo 1) (div_SNo y den) Hm1R HyDivR).
  prove ~(Rlt (div_SNo y den) (minus_SNo 1)).
  assume Hylt: Rlt (div_SNo y den) (minus_SNo 1).
  claim Hylts: div_SNo y den < minus_SNo 1.
  { exact (RltE_lt (div_SNo y den) (minus_SNo 1) Hylt). }
  claim HmulLt: mul_SNo (div_SNo y den) den < mul_SNo (minus_SNo 1) den.
  { exact (pos_mul_SNo_Lt' (div_SNo y den) (minus_SNo 1) den HyDivS (SNo_minus_SNo 1 SNo_1) HdenS HdenPos Hylts). }
  claim HmulEq: mul_SNo (div_SNo y den) den = y.
  { exact (mul_div_SNo_invL y den HyS HdenS Hdenne0). }
  claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
  { rewrite (mul_SNo_minus_distrL 1 den SNo_1 HdenS) at 1.
    rewrite (mul_SNo_oneL den HdenS) at 1.
    reflexivity. }
  claim Hy_lt_mden: y < minus_SNo den.
  { rewrite <- HmulEq.
    rewrite <- HrhsEq.
    exact HmulLt. }
  claim Hbad: Rlt y (minus_SNo den).
  { exact (RltI y (minus_SNo den) HyR HmdenR Hy_lt_mden). }
  exact (Hnlt_lo Hbad). }
exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (div_SNo y den) Hm1R real_1 HyDivR Hm1_le_y Hy_le_1).
Qed.

(** helper: mul_const_fun c is an element of function_space R R **)
(** LATEX VERSION: For fixed c∈ℝ, the map t↦t·c is a function ℝ→ℝ. **)
Theorem mul_const_fun_in_function_space : forall c:set,
  c :e R -> mul_const_fun c :e function_space R R.
let c.
assume HcR: c :e R.
set g := (fun t:set => mul_SNo t c).
claim Hg: forall t:set, t :e R -> g t :e R.
{ let t. assume HtR: t :e R.
  prove g t :e R.
  exact (real_mul_SNo t HtR c HcR). }
claim Hdef: mul_const_fun c = graph R g.
{ reflexivity. }
rewrite Hdef.
exact (graph_in_function_space R R g Hg).
Qed.

Theorem mul_const_fun_value_in_R : forall c t:set,
  c :e R -> t :e R ->
  apply_fun (mul_const_fun c) t :e R.
let c t.
assume HcR: c :e R.
assume HtR: t :e R.
rewrite (mul_const_fun_apply c t HcR HtR).
exact (real_mul_SNo t HtR c HcR).
Qed.

(** preimage of an upper ray under multiplication by positive c **)
Theorem preimage_mul_const_open_ray_upper : forall c a:set,
  c :e R -> 0 < c -> a :e R ->
  preimage_of R (mul_const_fun c) (open_ray_upper R a) = open_ray_upper R (div_SNo a c).
let c a.
assume HcR: c :e R.
assume Hcpos: 0 < c.
assume HaR: a :e R.
prove preimage_of R (mul_const_fun c) (open_ray_upper R a) = open_ray_upper R (div_SNo a c).
apply set_ext.
- let t. assume HtPre: t :e preimage_of R (mul_const_fun c) (open_ray_upper R a).
  prove t :e open_ray_upper R (div_SNo a c).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_upper R a) t HtPre). }
  claim Himg: apply_fun (mul_const_fun c) t :e open_ray_upper R a.
  { exact (SepE2 R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_upper R a) t HtPre). }
  claim Hrel: order_rel R a (apply_fun (mul_const_fun c) t).
  { exact (SepE2 R (fun y0:set => order_rel R a y0) (apply_fun (mul_const_fun c) t) Himg). }
  claim Halt: Rlt a (apply_fun (mul_const_fun c) t).
  { exact (order_rel_R_implies_Rlt a (apply_fun (mul_const_fun c) t) Hrel). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HmulEq: apply_fun (mul_const_fun c) t = mul_SNo t c.
  { rewrite (mul_const_fun_apply c t HcR HtR).
    reflexivity. }
  claim HaltS: a < mul_SNo t c.
  { rewrite <- HmulEq at 1.
    exact (RltE_lt a (apply_fun (mul_const_fun c) t) Halt). }
  claim HdivLtS: div_SNo a c < t.
  { exact (div_SNo_pos_LtL a c t HaS HcS HtS Hcpos HaltS). }
  claim HdivR: div_SNo a c :e R.
  { exact (real_div_SNo a HaR c HcR). }
  claim Hray: order_rel R (div_SNo a c) t.
  { exact (Rlt_implies_order_rel_R (div_SNo a c) t (RltI (div_SNo a c) t HdivR HtR HdivLtS)). }
  exact (SepI R (fun x0:set => order_rel R (div_SNo a c) x0) t HtR Hray).
- let t. assume HtRay: t :e open_ray_upper R (div_SNo a c).
  prove t :e preimage_of R (mul_const_fun c) (open_ray_upper R a).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R (div_SNo a c) x0) t HtRay). }
  claim Hrel: order_rel R (div_SNo a c) t.
  { exact (SepE2 R (fun x0:set => order_rel R (div_SNo a c) x0) t HtRay). }
  claim HdivLt: Rlt (div_SNo a c) t.
  { exact (order_rel_R_implies_Rlt (div_SNo a c) t Hrel). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HdivLtS: div_SNo a c < t.
  { exact (RltE_lt (div_SNo a c) t HdivLt). }
  claim HaltS: a < mul_SNo t c.
  { exact (div_SNo_pos_LtL' a c t HaS HcS HtS Hcpos HdivLtS). }
  claim HmulR: mul_SNo t c :e R.
  { exact (real_mul_SNo t HtR c HcR). }
  claim HaltR: Rlt a (mul_SNo t c).
  { exact (RltI a (mul_SNo t c) HaR HmulR HaltS). }
  claim Hrel2: order_rel R a (mul_SNo t c).
  { exact (Rlt_implies_order_rel_R a (mul_SNo t c) HaltR). }
  claim Himg: mul_SNo t c :e open_ray_upper R a.
  { exact (SepI R (fun y0:set => order_rel R a y0) (mul_SNo t c) HmulR Hrel2). }
  claim Hpredef: preimage_of R (mul_const_fun c) (open_ray_upper R a) =
    {x0 :e R | apply_fun (mul_const_fun c) x0 :e open_ray_upper R a}.
  { reflexivity. }
  rewrite Hpredef.
  apply (SepI R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_upper R a) t HtR).
  rewrite (mul_const_fun_apply c t HcR HtR).
  exact Himg.
Qed.

(** preimage of a lower ray under multiplication by positive c **)
Theorem preimage_mul_const_open_ray_lower : forall c b:set,
  c :e R -> 0 < c -> b :e R ->
  preimage_of R (mul_const_fun c) (open_ray_lower R b) = open_ray_lower R (div_SNo b c).
let c b.
assume HcR: c :e R.
assume Hcpos: 0 < c.
assume HbR: b :e R.
prove preimage_of R (mul_const_fun c) (open_ray_lower R b) = open_ray_lower R (div_SNo b c).
apply set_ext.
- let t. assume HtPre: t :e preimage_of R (mul_const_fun c) (open_ray_lower R b).
  prove t :e open_ray_lower R (div_SNo b c).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_lower R b) t HtPre). }
  claim Himg: apply_fun (mul_const_fun c) t :e open_ray_lower R b.
  { exact (SepE2 R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_lower R b) t HtPre). }
  claim Hrel: order_rel R (apply_fun (mul_const_fun c) t) b.
  { exact (SepE2 R (fun y0:set => order_rel R y0 b) (apply_fun (mul_const_fun c) t) Himg). }
  claim Hlt: Rlt (apply_fun (mul_const_fun c) t) b.
  { exact (order_rel_R_implies_Rlt (apply_fun (mul_const_fun c) t) b Hrel). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HmulEq: apply_fun (mul_const_fun c) t = mul_SNo t c.
  { rewrite (mul_const_fun_apply c t HcR HtR).
    reflexivity. }
  claim HltS: mul_SNo t c < b.
  { rewrite <- HmulEq at 1.
    exact (RltE_lt (apply_fun (mul_const_fun c) t) b Hlt). }
  claim HtLtS: t < div_SNo b c.
  { exact (div_SNo_pos_LtR b c t HbS HcS HtS Hcpos HltS). }
  claim HdivR: div_SNo b c :e R.
  { exact (real_div_SNo b HbR c HcR). }
  claim HtLt: Rlt t (div_SNo b c).
  { exact (RltI t (div_SNo b c) HtR HdivR HtLtS). }
  claim Hray: order_rel R t (div_SNo b c).
  { exact (Rlt_implies_order_rel_R t (div_SNo b c) HtLt). }
  exact (SepI R (fun x0:set => order_rel R x0 (div_SNo b c)) t HtR Hray).
- let t. assume HtRay: t :e open_ray_lower R (div_SNo b c).
  prove t :e preimage_of R (mul_const_fun c) (open_ray_lower R b).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R x0 (div_SNo b c)) t HtRay). }
  claim Hrel: order_rel R t (div_SNo b c).
  { exact (SepE2 R (fun x0:set => order_rel R x0 (div_SNo b c)) t HtRay). }
  claim HtLt: Rlt t (div_SNo b c).
  { exact (order_rel_R_implies_Rlt t (div_SNo b c) Hrel). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HtLtS: t < div_SNo b c.
  { exact (RltE_lt t (div_SNo b c) HtLt). }
  claim HmulLtS: mul_SNo t c < b.
  { exact (div_SNo_pos_LtR' b c t HbS HcS HtS Hcpos HtLtS). }
  claim HmulR: mul_SNo t c :e R.
  { exact (real_mul_SNo t HtR c HcR). }
  claim HmulLt: Rlt (mul_SNo t c) b.
  { exact (RltI (mul_SNo t c) b HmulR HbR HmulLtS). }
  claim Hray: order_rel R (mul_SNo t c) b.
  { exact (Rlt_implies_order_rel_R (mul_SNo t c) b HmulLt). }
  claim Himg: mul_SNo t c :e open_ray_lower R b.
  { exact (SepI R (fun y0:set => order_rel R y0 b) (mul_SNo t c) HmulR Hray). }
  claim Hpredef: preimage_of R (mul_const_fun c) (open_ray_lower R b) =
    {x0 :e R | apply_fun (mul_const_fun c) x0 :e open_ray_lower R b}.
  { reflexivity. }
  rewrite Hpredef.
  apply (SepI R (fun x0:set => apply_fun (mul_const_fun c) x0 :e open_ray_lower R b) t HtR).
  rewrite (mul_const_fun_apply c t HcR HtR).
  exact Himg.
Qed.

Theorem mul_const_fun_continuous_pos : forall c:set,
  c :e R -> 0 < c ->
  continuous_map R R_standard_topology R R_standard_topology (mul_const_fun c).
let c.
assume HcR: c :e R.
assume Hcpos: 0 < c.
prove continuous_map R R_standard_topology R R_standard_topology (mul_const_fun c).
set Tx := R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on R Tx.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on (mul_const_fun c) R R.
{ let t. assume HtR: t :e R.
  exact (mul_const_fun_value_in_R c t HcR HtR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = Tx.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- Hgen at 2.
apply (continuous_map_from_subbasis R Tx R S (mul_const_fun c) HTx Hfun HS).
let s. assume HsS: s :e S.
prove preimage_of R (mul_const_fun c) s :e Tx.
claim HSdef: S =
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ reflexivity. }
claim HsS': s :e
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ rewrite <- HSdef.
  exact HsS. }
apply (binunionE'
  ({I :e Power R | exists a :e R, I = open_ray_upper R a}
   :\/:
   {I :e Power R | exists b :e R, I = open_ray_lower R b})
  {R}
  s
  (preimage_of R (mul_const_fun c) s :e Tx)).
- assume HsAB: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b}).
  apply (binunionE'
    {I :e Power R | exists a :e R, I = open_ray_upper R a}
    {I :e Power R | exists b :e R, I = open_ray_lower R b}
    s
    (preimage_of R (mul_const_fun c) s :e Tx)).
  + assume HsUpper: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
    claim Hex: exists a :e R, s = open_ray_upper R a.
    { exact (SepE2 (Power R) (fun I0:set => exists a :e R, I0 = open_ray_upper R a) s HsUpper). }
    apply Hex.
    let a. assume Hacore.
    apply Hacore.
    assume HaR: a :e R.
    assume Hseq: s = open_ray_upper R a.
    rewrite Hseq.
    rewrite (preimage_mul_const_open_ray_upper c a HcR Hcpos HaR).
    rewrite <- standard_topology_is_order_topology.
    claim HdivR: div_SNo a c :e R.
    { exact (real_div_SNo a HaR c HcR). }
    claim Hray: open_ray_upper R (div_SNo a c) :e open_rays_subbasis R.
    { exact (open_ray_upper_in_open_rays_subbasis R (div_SNo a c) HdivR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R (div_SNo a c)) Hray).
  + assume HsLower: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
    claim Hex: exists b :e R, s = open_ray_lower R b.
    { exact (SepE2 (Power R) (fun I0:set => exists b :e R, I0 = open_ray_lower R b) s HsLower). }
    apply Hex.
    let b. assume Hbcore.
    apply Hbcore.
    assume HbR: b :e R.
    assume Hseq: s = open_ray_lower R b.
    rewrite Hseq.
    rewrite (preimage_mul_const_open_ray_lower c b HcR Hcpos HbR).
    rewrite <- standard_topology_is_order_topology.
    claim HdivR: div_SNo b c :e R.
    { exact (real_div_SNo b HbR c HcR). }
    claim Hray: open_ray_lower R (div_SNo b c) :e open_rays_subbasis R.
    { exact (open_ray_lower_in_open_rays_subbasis R (div_SNo b c) HdivR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R (div_SNo b c)) Hray).
  + exact HsAB.
- assume HsR: s :e {R}.
  claim Hseq: s = R.
  { exact (SingE R s HsR). }
  rewrite Hseq.
  rewrite (preimage_of_whole R R (mul_const_fun c) Hfun).
  exact (topology_has_X R Tx HTx).
- exact HsS'.
Qed.

(** helper for §35: scaling a continuous map by a positive constant is continuous **)
Theorem scale_continuous_mul_const_pos : forall X Tx g c:set,
  topology_on X Tx ->
  continuous_map X Tx R R_standard_topology g ->
  c :e R -> 0 < c ->
  continuous_map X Tx R R_standard_topology (compose_fun X g (mul_const_fun c)).
let X Tx g c.
assume HTx: topology_on X Tx.
assume Hg: continuous_map X Tx R R_standard_topology g.
assume HcR: c :e R.
assume Hcpos: 0 < c.
prove continuous_map X Tx R R_standard_topology (compose_fun X g (mul_const_fun c)).
claim Hmulcont: continuous_map R R_standard_topology R R_standard_topology (mul_const_fun c).
{ exact (mul_const_fun_continuous_pos c HcR Hcpos). }
exact (composition_continuous X Tx R R_standard_topology R R_standard_topology
         g (mul_const_fun c) Hg Hmulcont).
Qed.

(** helper for §35: adding two continuous R-valued maps is continuous **)
Theorem add_two_continuous_R : forall X Tx g h:set,
  topology_on X Tx ->
  continuous_map X Tx R R_standard_topology g ->
  continuous_map X Tx R R_standard_topology h ->
  continuous_map X Tx R R_standard_topology (compose_fun X (pair_map X g h) add_fun_R).
let X Tx g h.
assume HTx: topology_on X Tx.
assume Hg: continuous_map X Tx R R_standard_topology g.
assume Hh: continuous_map X Tx R R_standard_topology h.
prove continuous_map X Tx R R_standard_topology (compose_fun X (pair_map X g h) add_fun_R).
set p := pair_map X g h.
claim Hpcont:
  continuous_map X Tx (setprod R R)
    (product_topology R R_standard_topology R R_standard_topology) p.
{ exact (maps_into_products_axiom X Tx R R_standard_topology R R_standard_topology
         g h Hg Hh). }
claim Haddcont:
  continuous_map (setprod R R)
    (product_topology R R_standard_topology R R_standard_topology)
    R R_standard_topology add_fun_R.
{ exact add_fun_R_continuous. }
exact (composition_continuous X Tx (setprod R R)
         (product_topology R R_standard_topology R R_standard_topology)
         R R_standard_topology
         p add_fun_R Hpcont Haddcont).
Qed.

(** helper for §35: multiplication map on R×R **)
(** LATEX VERSION: The multiplication map R×R→R is continuous in the standard topology. **)
Definition mul_fun_R : set :=
  graph (setprod R R) (fun p:set => mul_SNo (p 0) (p 1)).

(** helper for §35: multiplication map values lie in R **)
Theorem mul_fun_R_value_in_R : forall p:set, p :e setprod R R -> apply_fun mul_fun_R p :e R.
let p.
assume Hp: p :e setprod R R.
prove apply_fun mul_fun_R p :e R.
rewrite (apply_fun_graph (setprod R R) (fun p0:set => mul_SNo (p0 0) (p0 1)) p Hp).
claim Hp0R: p 0 :e R.
{ exact (ap0_Sigma R (fun _ : set => R) p Hp). }
claim Hp1R: p 1 :e R.
{ exact (ap1_Sigma R (fun _ : set => R) p Hp). }
exact (real_mul_SNo (p 0) Hp0R (p 1) Hp1R).
Qed.

(** helper for §35: multiplication map application **)
Theorem mul_fun_R_apply : forall p:set,
  p :e setprod R R -> apply_fun mul_fun_R p = mul_SNo (p 0) (p 1).
let p.
assume HpRR: p :e setprod R R.
prove apply_fun mul_fun_R p = mul_SNo (p 0) (p 1).
claim Hdef: mul_fun_R = graph (setprod R R) (fun p0:set => mul_SNo (p0 0) (p0 1)).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph (setprod R R) (fun p0:set => mul_SNo (p0 0) (p0 1)) p HpRR).
reflexivity.
Qed.

(** helper for section 35 abs and multiplication **)
Theorem abs_SNo_mul_nonneg_left : forall x y:set,
  SNo x -> SNo y -> 0 <= x ->
  abs_SNo (mul_SNo x y) = mul_SNo x (abs_SNo y).
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0lex: 0 <= x.
apply (xm (0 <= y)).
- assume H0ley: 0 <= y.
  rewrite (nonneg_abs_SNo y H0ley).
  claim H0lexy: 0 <= mul_SNo x y.
  { exact (mul_SNo_nonneg_nonneg x y HxS HyS H0lex H0ley). }
  rewrite (nonneg_abs_SNo (mul_SNo x y) H0lexy).
  reflexivity.
- assume Hn0ley: ~(0 <= y).
  rewrite (not_nonneg_abs_SNo y Hn0ley).
  apply (xm (x = 0)).
  + assume Hx0: x = 0.
    rewrite Hx0.
    rewrite (mul_SNo_zeroL y HyS).
    rewrite (mul_SNo_zeroL (minus_SNo y) (SNo_minus_SNo y HyS)).
    rewrite (nonneg_abs_SNo 0 (SNoLe_ref 0)).
    reflexivity.
  + assume Hxne0: x <> 0.
    claim H0ltx: 0 < x.
    { claim H0or: 0 < x \/ 0 = x.
      { exact (SNoLeE 0 x SNo_0 HxS H0lex). }
      apply H0or.
      - assume H: 0 < x. exact H.
      - assume H0x: 0 = x.
        claim Hx0: x = 0.
        { rewrite <- H0x. reflexivity. }
        exact (FalseE (Hxne0 Hx0) (0 < x)). }
    claim Hylt0: y < 0.
    { apply (SNoLt_trichotomy_or_impred y 0 HyS SNo_0 (y < 0)).
      - assume H: y < 0. exact H.
      - assume Hy0: y = 0.
        claim H0ley: 0 <= y.
        { rewrite Hy0. exact (SNoLe_ref 0). }
        exact (FalseE (Hn0ley H0ley) (y < 0)).
      - assume H0lty: 0 < y.
        claim H0ley: 0 <= y.
        { exact (SNoLtLe 0 y H0lty). }
        exact (FalseE (Hn0ley H0ley) (y < 0)). }
    claim Hxylt0: mul_SNo x y < 0.
    { rewrite <- (mul_SNo_zeroR x HxS).
      exact (pos_mul_SNo_Lt x y 0 HxS H0ltx HyS SNo_0 Hylt0). }
    claim Hn0lexy: ~(0 <= mul_SNo x y).
    { assume H0le: 0 <= mul_SNo x y.
      claim HxyS: SNo (mul_SNo x y).
      { exact (SNo_mul_SNo x y HxS HyS). }
      claim Hbad: mul_SNo x y < mul_SNo x y.
      { exact (SNoLtLe_tra (mul_SNo x y) 0 (mul_SNo x y) HxyS SNo_0 HxyS Hxylt0 H0le). }
      exact (FalseE ((SNoLt_irref (mul_SNo x y)) Hbad) False). }
    rewrite (not_nonneg_abs_SNo (mul_SNo x y) Hn0lexy).
    rewrite (mul_SNo_minus_distrR x y HxS HyS).
    reflexivity.
Qed.

Theorem abs_SNo_mul_eq : forall x y:set,
  SNo x -> SNo y ->
  abs_SNo (mul_SNo x y) = mul_SNo (abs_SNo x) (abs_SNo y).
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
apply (xm (0 <= x)).
- assume H0lex: 0 <= x.
  rewrite (nonneg_abs_SNo x H0lex).
  exact (abs_SNo_mul_nonneg_left x y HxS HyS H0lex).
- assume Hn0lex: ~(0 <= x).
  rewrite (not_nonneg_abs_SNo x Hn0lex).
  claim Hxlt0: x < 0.
  { apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (x < 0)).
    - assume H: x < 0. exact H.
    - assume Hx0: x = 0.
      claim H0lex: 0 <= x.
      { rewrite Hx0. exact (SNoLe_ref 0). }
      exact (FalseE (Hn0lex H0lex) (x < 0)).
    - assume H0ltx: 0 < x.
      claim H0lex: 0 <= x.
      { exact (SNoLtLe 0 x H0ltx). }
      exact (FalseE (Hn0lex H0lex) (x < 0)). }
  claim H0ltmx: 0 < minus_SNo x.
  { rewrite <- minus_SNo_0 at 1.
    exact (minus_SNo_Lt_contra x 0 HxS SNo_0 Hxlt0). }
  claim H0lemx: 0 <= minus_SNo x.
  { exact (SNoLtLe 0 (minus_SNo x) H0ltmx). }
  claim HxyS: SNo (mul_SNo x y).
  { exact (SNo_mul_SNo x y HxS HyS). }
  rewrite <- (abs_SNo_minus (mul_SNo x y) HxyS).
  rewrite <- (mul_SNo_minus_distrL x y HxS HyS).
  rewrite (abs_SNo_mul_nonneg_left (minus_SNo x) y (SNo_minus_SNo x HxS) HyS H0lemx).
  reflexivity.
Qed.

(** helper for §35: preimage of upper ray under multiplication on R **)
Theorem preimage_mul_fun_R_open_ray_upper_in_product_topology : forall a:set,
  a :e R ->
  preimage_of (setprod R R) mul_fun_R (open_ray_upper R a) :e
    (product_topology R R_standard_topology R R_standard_topology).
let a.
assume HaR: a :e R.
prove preimage_of (setprod R R) mul_fun_R (open_ray_upper R a) :e
  (product_topology R R_standard_topology R R_standard_topology).
set Tx := product_topology R R_standard_topology R R_standard_topology.
set B := product_subbasis R R_standard_topology R R_standard_topology.
set W := preimage_of (setprod R R) mul_fun_R (open_ray_upper R a).
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim HdefT: Tx = generated_topology (setprod R R) B.
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod R R) B =
  {U :e Power (setprod R R) | forall p :e U, exists b :e B, p :e b /\ b c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod R R))
  (fun U:set => forall p :e U, exists b :e B, p :e b /\ b c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_upper R a) p Hp).
- let p. assume Hp: p :e W.
  prove exists b :e B, p :e b /\ b c= W.
  claim HpDom: p :e setprod R R.
  { exact (SepE1 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_upper R a) p Hp). }
  claim Hp0R: p 0 :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpDom). }
  claim Hp1R: p 1 :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpDom). }
  claim Himg: apply_fun mul_fun_R p :e open_ray_upper R a.
  { exact (SepE2 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_upper R a) p Hp). }
  claim Hrel: order_rel R a (apply_fun mul_fun_R p).
  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun mul_fun_R p) Himg). }
  claim Halt: Rlt a (apply_fun mul_fun_R p).
  { exact (order_rel_R_implies_Rlt a (apply_fun mul_fun_R p) Hrel). }
  claim HexUV:
    exists U :e R_standard_topology, exists V :e R_standard_topology,
      p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { set x0 := p 0.
    set y0 := p 1.
    set s0 := apply_fun mul_fun_R p.
    claim Hs0R: s0 :e R.
    { exact (mul_fun_R_value_in_R p HpDom). }
    set diff := add_SNo s0 (minus_SNo a).
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim Hs0S: SNo s0.
    { exact (real_SNo s0 Hs0R). }
    claim HdiffR: diff :e R.
    { exact (real_add_SNo s0 Hs0R (minus_SNo a) (real_minus_SNo a HaR)). }
    claim HdiffPos: Rlt 0 diff.
    { exact (Rlt_0_diff_of_lt a s0 Halt). }
    claim HdiffS: SNo diff.
    { exact (real_SNo diff HdiffR). }
    claim HdiffPosS: 0 < diff.
    { exact (RltE_lt 0 diff HdiffPos). }
    set absx0 := abs_SNo x0.
    set absy0 := abs_SNo y0.
    claim Habsx0R: absx0 :e R.
    { exact (abs_SNo_in_R x0 Hp0R). }
    claim Habsy0R: absy0 :e R.
    { exact (abs_SNo_in_R y0 Hp1R). }
    claim Habsx0S: SNo absx0.
    { exact (real_SNo absx0 Habsx0R). }
    claim Habsy0S: SNo absy0.
    { exact (real_SNo absy0 Habsy0R). }
    set sumabs := add_SNo absx0 absy0.
    claim HsumabsR: sumabs :e R.
    { exact (real_add_SNo absx0 Habsx0R absy0 Habsy0R). }
    claim HsumabsS: SNo sumabs.
    { exact (real_SNo sumabs HsumabsR). }
    set denom := add_SNo 1 sumabs.
    claim HdenR: denom :e R.
    { exact (real_add_SNo 1 real_1 sumabs HsumabsR). }
    claim HdenS: SNo denom.
    { exact (SNo_add_SNo 1 sumabs SNo_1 HsumabsS). }
    claim H0le_absx0: 0 <= absx0.
    { exact (abs_SNo_nonneg x0 (real_SNo x0 Hp0R)). }
    claim H0le_absy0: 0 <= absy0.
    { exact (abs_SNo_nonneg y0 (real_SNo y0 Hp1R)). }
    claim H0le_sumabs: 0 <= sumabs.
    { claim Htmp: add_SNo 0 0 <= sumabs.
      { exact (add_SNo_Le3 0 0 absx0 absy0 SNo_0 SNo_0 Habsx0S Habsy0S H0le_absx0 H0le_absy0). }
      rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact Htmp. }
    claim HdenPos0: add_SNo 0 0 < denom.
    { exact (add_SNo_Lt3a 0 0 1 sumabs SNo_0 SNo_0 SNo_1 HsumabsS SNoLt_0_1 H0le_sumabs). }
    claim HdenPos: 0 < denom.
    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact HdenPos0. }
    set r := div_SNo diff denom.
    claim HrR: r :e R.
    { exact (real_div_SNo diff HdiffR denom HdenR). }
    claim HrS: SNo r.
    { exact (real_SNo r HrR). }
    claim HrposS: 0 < r.
    { exact (div_SNo_pos_pos diff denom HdiffS HdenS HdiffPosS HdenPos). }
    claim Hrpos: Rlt 0 r.
    { exact (RltI 0 r real_0 HrR HrposS). }
    claim HexN: exists N :e omega, eps_ N < r.
    { exact (exists_eps_lt_pos_Euclid r HrR Hrpos). }
    apply HexN.
    let N. assume HNpair.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega) (eps_ N < r) HNpair). }
    claim HepsLt: eps_ N < r.
    { exact (andER (N :e omega) (eps_ N < r) HNpair). }
	    claim HNnat: nat_p N.
	    { exact (omega_nat_p N HNomega). }
	    claim HsuccOmega: ordsucc N :e omega.
	    { exact (omega_ordsucc N HNomega). }
	    claim Hsucc2Omega: ordsucc (ordsucc N) :e omega.
	    { exact (omega_ordsucc (ordsucc N) HsuccOmega). }
	    set delta := eps_ (ordsucc (ordsucc N)).
	    claim HdeltaSNoS: delta :e SNoS_ omega.
	    { exact (SNo_eps_SNoS_omega (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaR: delta :e R.
	    { exact (SNoS_omega_real delta HdeltaSNoS). }
	    claim HdeltaPosS: 0 < delta.
	    { exact (SNo_eps_pos (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaPos: Rlt 0 delta.
	    { exact (RltI 0 delta real_0 HdeltaR HdeltaPosS). }
	    claim HdeltaS: SNo delta.
	    { exact (SNo_eps_ (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaLt1S: delta < 1.
	    { claim HN1nat: nat_p (ordsucc N).
	      { exact (nat_ordsucc N HNnat). }
	      claim H0In: 0 :e ordsucc (ordsucc N).
	      { exact (nat_0_in_ordsucc (ordsucc N) HN1nat). }
	      claim Hlt0: delta < eps_ 0.
	      { exact (SNo_eps_decr (ordsucc (ordsucc N)) Hsucc2Omega 0 H0In). }
	      rewrite <- (eps_0_1).
	      exact Hlt0. }
	    claim HdeltaLt1: Rlt delta 1.
	    { exact (RltI delta 1 HdeltaR real_1 HdeltaLt1S). }
	    claim HepsSuccS: SNo (eps_ (ordsucc N)).
	    { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
	    claim HepsNS: SNo (eps_ N).
	    { exact (SNo_eps_ N HNomega). }
	    claim HmIn: ordsucc N :e ordsucc (ordsucc N).
	    { exact (ordsuccI2 (ordsucc N)). }
	    claim HdeltaLtEpsSucc: delta < eps_ (ordsucc N).
	    { exact (SNo_eps_decr (ordsucc (ordsucc N)) Hsucc2Omega (ordsucc N) HmIn). }
	    claim HNIn: N :e ordsucc N.
	    { exact (ordsuccI2 N). }
	    claim HepsSuccLtEpsN: eps_ (ordsucc N) < eps_ N.
	    { exact (SNo_eps_decr (ordsucc N) HsuccOmega N HNIn). }
	    claim HdeltaLtEpsN: delta < eps_ N.
	    { exact (SNoLt_tra delta (eps_ (ordsucc N)) (eps_ N) HdeltaS HepsSuccS HepsNS HdeltaLtEpsSucc HepsSuccLtEpsN). }
	    claim HdeltaLtR: delta < r.
	    { exact (SNoLt_tra delta (eps_ N) r HdeltaS HepsNS HrS HdeltaLtEpsN HepsLt). }
	    set U0 := open_ball R R_bounded_metric x0 delta.
	    set V0 := open_ball R R_bounded_metric y0 delta.
    witness U0.
    apply andI.
    - prove U0 :e R_standard_topology.
      exact (open_ball_R_bounded_metric_in_R_standard_topology_early x0 delta Hp0R HdeltaR HdeltaPos).
    - witness V0.
      apply andI.
      + prove V0 :e R_standard_topology.
        exact (open_ball_R_bounded_metric_in_R_standard_topology_early y0 delta Hp1R HdeltaR HdeltaPos).
      + prove x0 :e U0 /\ y0 :e V0 /\ rectangle_set U0 V0 c= W.
        apply andI.
        * prove x0 :e U0 /\ y0 :e V0.
          apply andI.
          - prove x0 :e U0.
            exact (center_in_open_ball R R_bounded_metric x0 delta
                   R_bounded_metric_is_metric_on_early Hp0R HdeltaPos).
          - prove y0 :e V0.
            exact (center_in_open_ball R R_bounded_metric y0 delta
                   R_bounded_metric_is_metric_on_early Hp1R HdeltaPos).
	        * prove rectangle_set U0 V0 c= W.
	          let q. assume Hq: q :e rectangle_set U0 V0.
	          prove q :e W.
	          claim HqUV: q :e setprod U0 V0.
	          { rewrite <- (rectangle_set_def U0 V0) at 1.
	            exact Hq. }
	          claim Hq0U0: q 0 :e U0.
	          { exact (ap0_Sigma U0 (fun _ : set => V0) q HqUV). }
	          claim Hq1V0: q 1 :e V0.
	          { exact (ap1_Sigma U0 (fun _ : set => V0) q HqUV). }
		          claim HqRR: q :e setprod R R.
		          { claim HU0subR: U0 c= R.
		            { exact (open_ball_subset_X R R_bounded_metric x0 delta). }
		            claim HV0subR: V0 c= R.
		            { exact (open_ball_subset_X R R_bounded_metric y0 delta). }
		            exact ((setprod_Subq U0 V0 R R HU0subR HV0subR) q HqUV). }
		          claim HWdef: W = {q0 :e setprod R R | apply_fun mul_fun_R q0 :e open_ray_upper R a}.
		          { reflexivity. }
		          rewrite HWdef at 1.
		          apply (SepI (setprod R R) (fun q0:set => apply_fun mul_fun_R q0 :e open_ray_upper R a) q HqRR).
		          prove apply_fun mul_fun_R q :e open_ray_upper R a.
	          set v := apply_fun mul_fun_R q.
		          claim HvR: v :e R.
		          { exact (mul_fun_R_value_in_R q HqRR). }
		          claim Hltv: Rlt a v.
		          { claim HvS: SNo v.
		            { exact (real_SNo v HvR). }
		            claim HaS: SNo a.
		            { exact (real_SNo a HaR). }
		            claim Hs0S: SNo s0.
		            { exact (real_SNo s0 Hs0R). }
		            claim HdiffS: SNo diff.
		            { exact (real_SNo diff HdiffR). }
		            claim HdiffPosS: 0 < diff.
		            { exact (RltE_lt 0 diff HdiffPos). }
		            claim Hdiffdef: diff = add_SNo s0 (minus_SNo a).
		            { reflexivity. }
		            claim Hmdiffdef: minus_SNo diff = minus_SNo (add_SNo s0 (minus_SNo a)).
		            { rewrite Hdiffdef.
		              reflexivity. }
		            set t := add_SNo (minus_SNo v) s0.
		            claim HtS: SNo t.
		            { exact (SNo_add_SNo (minus_SNo v) s0 (SNo_minus_SNo v HvS) Hs0S). }
		            claim Htdef: t = add_SNo (minus_SNo v) s0.
		            { reflexivity. }
		            claim Habs: abs_SNo t < diff.
		            { set q0 := q 0.
		              set q1 := q 1.
		              claim Hq0R: q0 :e R.
		              { exact (open_ballE1 R R_bounded_metric x0 delta q0 Hq0U0). }
		              claim Hq1R: q1 :e R.
		              { exact (open_ballE1 R R_bounded_metric y0 delta q1 Hq1V0). }
		              claim Habsx: abs_SNo (add_SNo x0 (minus_SNo q0)) < delta.
		              { exact (open_ball_R_bounded_metric_absdiff_lt x0 delta q0 Hp0R HdeltaR HdeltaPos HdeltaLt1 Hq0U0). }
		              claim Habsy: abs_SNo (add_SNo y0 (minus_SNo q1)) < delta.
		              { exact (open_ball_R_bounded_metric_absdiff_lt y0 delta q1 Hp1R HdeltaR HdeltaPos HdeltaLt1 Hq1V0). }
		              claim Hvdef: v = apply_fun mul_fun_R q.
		              { reflexivity. }
		              claim HvEq: v = mul_SNo (q 0) (q 1).
		              { rewrite Hvdef.
		                exact (mul_fun_R_apply q HqRR). }
		              claim Hs0def: s0 = apply_fun mul_fun_R p.
		              { reflexivity. }
		              claim Hs0Eq: s0 = mul_SNo x0 y0.
		              { rewrite Hs0def.
		                rewrite (mul_fun_R_apply p HpDom).
		                reflexivity. }
		              claim Hmain: abs_SNo (add_SNo (minus_SNo v) s0) < diff.
		              { claim Hq0S: SNo q0.
		                { exact (real_SNo q0 Hq0R). }
		                claim Hq1S: SNo q1.
		                { exact (real_SNo q1 Hq1R). }
		                claim Hx0S: SNo x0.
		                { exact (real_SNo x0 Hp0R). }
		                claim Hy0S: SNo y0.
		                { exact (real_SNo y0 Hp1R). }
		                claim Habsy0S: SNo absy0.
		                { exact (real_SNo absy0 Habsy0R). }
		                claim Habsx0S: SNo absx0.
		                { exact (real_SNo absx0 Habsx0R). }
		                set mid := mul_SNo q0 y0.
		                claim HmidS: SNo mid.
		                { exact (SNo_mul_SNo q0 y0 Hq0S Hy0S). }
		                claim Htri:
		                  abs_SNo (add_SNo s0 (minus_SNo v))
		                  <= add_SNo (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                             (abs_SNo (add_SNo mid (minus_SNo v))).
		                { exact (abs_SNo_triangle s0 mid v Hs0S HmidS HvS). }
		                set dx := add_SNo x0 (minus_SNo q0).
		                claim HdxS: SNo dx.
		                { exact (SNo_add_SNo x0 (minus_SNo q0) Hx0S (SNo_minus_SNo q0 Hq0S)). }
		                set dy := add_SNo y0 (minus_SNo q1).
		                claim HdyS: SNo dy.
		                { exact (SNo_add_SNo y0 (minus_SNo q1) Hy0S (SNo_minus_SNo q1 Hq1S)). }
		                claim Habsdx: abs_SNo dx < delta.
		                { exact Habsx. }
		                claim Habsdy: abs_SNo dy < delta.
		                { exact Habsy. }
		                claim HabsdxLe: abs_SNo dx <= delta.
		                { exact (SNoLtLe (abs_SNo dx) delta Habsdx). }
		                claim HabsdyLe: abs_SNo dy <= delta.
		                { exact (SNoLtLe (abs_SNo dy) delta Habsdy). }
		                claim H0le_absy0: 0 <= absy0.
		                { exact (abs_SNo_nonneg y0 Hy0S). }
		                claim H0le_absx0: 0 <= absx0.
		                { exact (abs_SNo_nonneg x0 Hx0S). }
		                claim H0le_delta: 0 <= delta.
		                { exact (SNoLtLe 0 delta HdeltaPosS). }
		                claim HsbEq: add_SNo s0 (minus_SNo mid) = mul_SNo dx y0.
		                { claim Hmiddef: mid = mul_SNo q0 y0.
		                  { reflexivity. }
		                  claim Hdxdef: dx = add_SNo x0 (minus_SNo q0).
		                  { reflexivity. }
		                  rewrite Hs0Eq at 1.
		                  rewrite Hmiddef at 1.
		                  rewrite Hdxdef.
		                  rewrite (mul_SNo_distrR x0 (minus_SNo q0) y0
		                            Hx0S (SNo_minus_SNo q0 Hq0S) Hy0S).
		                  claim Hneg2: mul_SNo (minus_SNo q0) y0 = minus_SNo (mul_SNo q0 y0).
		                  { rewrite (mul_SNo_com (minus_SNo q0) y0 (SNo_minus_SNo q0 Hq0S) Hy0S).
		                    rewrite (mul_SNo_minus_distrR y0 q0 Hy0S Hq0S).
		                    rewrite (mul_SNo_com y0 q0 Hy0S Hq0S).
		                    reflexivity. }
		                  rewrite Hneg2.
		                  reflexivity. }
		                claim HbvEq: add_SNo mid (minus_SNo v) = mul_SNo q0 dy.
		                { claim Hmiddef: mid = mul_SNo q0 y0.
		                  { reflexivity. }
		                  claim Hdydef: dy = add_SNo y0 (minus_SNo q1).
		                  { reflexivity. }
		                  rewrite Hmiddef at 1.
		                  rewrite HvEq at 1.
		                  rewrite Hdydef.
		                  rewrite (mul_SNo_distrL q0 y0 (minus_SNo q1) Hq0S Hy0S (SNo_minus_SNo q1 Hq1S)).
		                  claim Hneg: mul_SNo q0 (minus_SNo q1) = minus_SNo (mul_SNo q0 q1).
		                  { rewrite (mul_SNo_minus_distrR q0 q1 Hq0S Hq1S).
		                    reflexivity. }
		                  rewrite Hneg.
		                  reflexivity. }
		                claim Habs1:
		                  abs_SNo (add_SNo s0 (minus_SNo mid)) <= mul_SNo absy0 delta.
		                { rewrite HsbEq.
		                  rewrite (abs_SNo_mul_eq dx y0 HdxS Hy0S) at 1.
		                  rewrite (mul_SNo_com absy0 delta Habsy0S HdeltaS).
		                  claim HmulLe: mul_SNo (abs_SNo dx) absy0 <= mul_SNo delta absy0.
		                  { exact (nonneg_mul_SNo_Le' (abs_SNo dx) delta absy0
		                           (SNo_abs_SNo dx HdxS) HdeltaS Habsy0S H0le_absy0 HabsdxLe). }
		                  exact HmulLe. }
		                claim Habs_q0_le:
		                  abs_SNo q0 <= add_SNo absx0 delta.
		                { set dq := add_SNo q0 (minus_SNo x0).
		                  claim HdqS: SNo dq.
		                  { exact (SNo_add_SNo q0 (minus_SNo x0) Hq0S (SNo_minus_SNo x0 Hx0S)). }
		                  claim HdqEq: abs_SNo dq = abs_SNo dx.
		                  { rewrite <- (abs_SNo_dist_swap x0 q0 Hx0S Hq0S).
		                    reflexivity. }
		                  claim Hq0Eq: q0 = add_SNo dq x0.
		                  { claim Hdqdef: dq = add_SNo q0 (minus_SNo x0).
		                    { reflexivity. }
		                    rewrite Hdqdef.
		                    rewrite <- (add_SNo_assoc q0 (minus_SNo x0) x0 Hq0S (SNo_minus_SNo x0 Hx0S) Hx0S).
		                    rewrite (add_SNo_minus_SNo_linv x0 Hx0S).
		                    rewrite (add_SNo_0R q0 Hq0S).
		                    reflexivity. }
		                  claim Habsub: abs_SNo q0 <= add_SNo (abs_SNo dq) (abs_SNo x0).
		                  { rewrite Hq0Eq at 1.
		                    exact (abs_SNo_subadd dq x0 HdqS Hx0S). }
		                  claim Habsub_dx: abs_SNo q0 <= add_SNo (abs_SNo dx) (abs_SNo x0).
		                  { claim HsumEq: add_SNo (abs_SNo dq) (abs_SNo x0) = add_SNo (abs_SNo dx) (abs_SNo x0).
		                    { rewrite HdqEq at 1.
		                      reflexivity. }
		                    rewrite <- HsumEq.
		                    exact Habsub. }
		                  claim Habsy: abs_SNo x0 = absx0.
		                  { reflexivity. }
		                  claim Habsub_dx2: abs_SNo q0 <= add_SNo (abs_SNo dx) absx0.
		                  { rewrite <- Habsy.
		                    exact Habsub_dx. }
		                  claim Habsub2: add_SNo (abs_SNo dx) absx0 <= add_SNo delta absx0.
		                  { exact (add_SNo_Le3 (abs_SNo dx) absx0 delta absx0
		                           (SNo_abs_SNo dx HdxS) Habsx0S HdeltaS Habsx0S
		                           HabsdxLe (SNoLe_ref absx0)). }
		                  rewrite (add_SNo_com absx0 delta Habsx0S HdeltaS) at 1.
		                  exact (SNoLe_tra (abs_SNo q0)
		                                   (add_SNo (abs_SNo dx) absx0)
		                                   (add_SNo delta absx0)
		                                   (SNo_abs_SNo q0 Hq0S)
		                                   (SNo_add_SNo (abs_SNo dx) absx0 (SNo_abs_SNo dx HdxS) Habsx0S)
		                                   (SNo_add_SNo delta absx0 HdeltaS Habsx0S)
		                                   Habsub_dx2 Habsub2). }
		                claim Habs2:
		                  abs_SNo (add_SNo mid (minus_SNo v)) <= add_SNo (mul_SNo absx0 delta) delta.
		                { rewrite HbvEq.
		                  rewrite (abs_SNo_mul_eq q0 dy Hq0S HdyS) at 1.
		                  claim HmulDy: mul_SNo (abs_SNo q0) (abs_SNo dy) <= mul_SNo (abs_SNo q0) delta.
		                  { exact (nonneg_mul_SNo_Le (abs_SNo q0) (abs_SNo dy) delta
		                           (SNo_abs_SNo q0 Hq0S) (abs_SNo_nonneg q0 Hq0S)
		                           (SNo_abs_SNo dy HdyS) HdeltaS HabsdyLe). }
		                  claim HmulQ0: mul_SNo (abs_SNo q0) delta <= mul_SNo (add_SNo absx0 delta) delta.
		                  { exact (nonneg_mul_SNo_Le' (abs_SNo q0) (add_SNo absx0 delta) delta
		                           (SNo_abs_SNo q0 Hq0S)
		                           (SNo_add_SNo absx0 delta Habsx0S HdeltaS)
		                           HdeltaS H0le_delta Habs_q0_le). }
		                  claim HmulLe: mul_SNo (abs_SNo q0) (abs_SNo dy) <= mul_SNo (add_SNo absx0 delta) delta.
		                  { exact (SNoLe_tra (mul_SNo (abs_SNo q0) (abs_SNo dy))
		                                     (mul_SNo (abs_SNo q0) delta)
		                                     (mul_SNo (add_SNo absx0 delta) delta)
		                                     (SNo_mul_SNo (abs_SNo q0) (abs_SNo dy) (SNo_abs_SNo q0 Hq0S) (SNo_abs_SNo dy HdyS))
		                                     (SNo_mul_SNo (abs_SNo q0) delta (SNo_abs_SNo q0 Hq0S) HdeltaS)
		                                     (SNo_mul_SNo (add_SNo absx0 delta) delta (SNo_add_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                     HmulDy HmulQ0). }
		                  claim HdeltaLe1: delta <= 1.
		                  { exact (SNoLtLe delta 1 HdeltaLt1S). }
		                  claim Hdelta2Le: mul_SNo delta delta <= delta.
		                  { exact (mul_SNo_Le1_nonneg_Le delta delta HdeltaS HdeltaS HdeltaLe1 H0le_delta). }
		                  claim HexpLe:
		                    mul_SNo (add_SNo absx0 delta) delta <= add_SNo (mul_SNo absx0 delta) delta.
		                  { rewrite (mul_SNo_distrR absx0 delta delta Habsx0S HdeltaS HdeltaS) at 1.
		                    exact (add_SNo_Le3 (mul_SNo absx0 delta) (mul_SNo delta delta)
		                             (mul_SNo absx0 delta) delta
		                             (SNo_mul_SNo absx0 delta Habsx0S HdeltaS)
		                             (SNo_mul_SNo delta delta HdeltaS HdeltaS)
		                             (SNo_mul_SNo absx0 delta Habsx0S HdeltaS)
		                             HdeltaS
		                             (SNoLe_ref (mul_SNo absx0 delta)) Hdelta2Le). }
		                  exact (SNoLe_tra (mul_SNo (abs_SNo q0) (abs_SNo dy))
		                                   (mul_SNo (add_SNo absx0 delta) delta)
		                                   (add_SNo (mul_SNo absx0 delta) delta)
		                                   (SNo_mul_SNo (abs_SNo q0) (abs_SNo dy) (SNo_abs_SNo q0 Hq0S) (SNo_abs_SNo dy HdyS))
		                                   (SNo_mul_SNo (add_SNo absx0 delta) delta (SNo_add_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                   (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                   HmulLe
		                                   HexpLe). }
		                claim HabsBound:
		                  abs_SNo (add_SNo s0 (minus_SNo v)) <= mul_SNo denom delta.
		                { claim Hstep1:
		                    abs_SNo (add_SNo s0 (minus_SNo v))
		                    <= add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta).
		                  { exact (SNoLe_tra
		                           (abs_SNo (add_SNo s0 (minus_SNo v)))
		                           (add_SNo (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                                    (abs_SNo (add_SNo mid (minus_SNo v))))
		                           (add_SNo (mul_SNo absy0 delta)
		                                    (add_SNo (mul_SNo absx0 delta) delta))
		                           (SNo_abs_SNo (add_SNo s0 (minus_SNo v))
		                             (SNo_add_SNo s0 (minus_SNo v) Hs0S (SNo_minus_SNo v HvS)))
		                           (SNo_add_SNo
		                             (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                             (abs_SNo (add_SNo mid (minus_SNo v)))
		                             (SNo_abs_SNo (add_SNo s0 (minus_SNo mid))
		                               (SNo_add_SNo s0 (minus_SNo mid) Hs0S (SNo_minus_SNo mid HmidS)))
		                             (SNo_abs_SNo (add_SNo mid (minus_SNo v))
		                               (SNo_add_SNo mid (minus_SNo v) HmidS (SNo_minus_SNo v HvS))))
		                           (SNo_add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta)
		                             (SNo_mul_SNo absy0 delta Habsy0S HdeltaS)
		                             (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS))
		                           Htri
		                           (add_SNo_Le3
		                             (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                             (abs_SNo (add_SNo mid (minus_SNo v)))
		                             (mul_SNo absy0 delta)
		                             (add_SNo (mul_SNo absx0 delta) delta)
		                             (SNo_abs_SNo (add_SNo s0 (minus_SNo mid))
		                               (SNo_add_SNo s0 (minus_SNo mid) Hs0S (SNo_minus_SNo mid HmidS)))
		                             (SNo_abs_SNo (add_SNo mid (minus_SNo v))
		                               (SNo_add_SNo mid (minus_SNo v) HmidS (SNo_minus_SNo v HvS)))
		                             (SNo_mul_SNo absy0 delta Habsy0S HdeltaS)
		                             (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                             Habs1 Habs2)). }
		                  claim HdenExp:
		                    mul_SNo denom delta = add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta).
		                  { rewrite (mul_SNo_distrR 1 sumabs delta SNo_1 HsumabsS HdeltaS) at 1.
		                    rewrite (mul_SNo_com 1 delta SNo_1 HdeltaS) at 1.
		                    rewrite (mul_SNo_oneR delta HdeltaS) at 1.
		                    rewrite (mul_SNo_distrR absx0 absy0 delta Habsx0S Habsy0S HdeltaS) at 1.
		                    set A := mul_SNo absx0 delta.
		                    set B := mul_SNo absy0 delta.
		                    claim HAS: SNo A.
		                    { exact (SNo_mul_SNo absx0 delta Habsx0S HdeltaS). }
		                    claim HBS: SNo B.
		                    { exact (SNo_mul_SNo absy0 delta Habsy0S HdeltaS). }
		                    rewrite (add_SNo_assoc delta A B HdeltaS HAS HBS) at 1.
		                    rewrite (add_SNo_com (add_SNo delta A) B
		                                         (SNo_add_SNo delta A HdeltaS HAS) HBS) at 1.
		                    rewrite (add_SNo_com delta A HdeltaS HAS) at 1.
		                    reflexivity. }
		                  rewrite HdenExp.
		                  exact Hstep1. }
		                claim HmulDenLt: mul_SNo denom delta < diff.
		                { rewrite (mul_SNo_com denom delta HdenS HdeltaS).
		                  exact (div_SNo_pos_LtR' diff denom delta HdiffS HdenS HdeltaS HdenPos HdeltaLtR). }
		                claim HabsLt:
		                  abs_SNo (add_SNo s0 (minus_SNo v)) < diff.
		                { exact (SNoLeLt_tra (abs_SNo (add_SNo s0 (minus_SNo v)))
		                                     (mul_SNo denom delta)
		                                     diff
		                                     (SNo_abs_SNo (add_SNo s0 (minus_SNo v))
		                                       (SNo_add_SNo s0 (minus_SNo v) Hs0S (SNo_minus_SNo v HvS)))
		                                     (SNo_mul_SNo denom delta HdenS HdeltaS)
		                                     HdiffS
		                                     HabsBound
		                                     HmulDenLt). }
		                rewrite (add_SNo_com (minus_SNo v) s0 (SNo_minus_SNo v HvS) Hs0S) at 1.
		                exact HabsLt. }
		              rewrite Htdef.
		              exact Hmain. }
		            claim Htlt: t < diff.
		            { exact (abs_SNo_lt_imp_lt t diff HtS HdiffS HdiffPosS Habs). }
		            claim Hvtlt: add_SNo v t < add_SNo v diff.
		            { exact (add_SNo_Lt2 v t diff HvS HtS HdiffS Htlt). }
		            claim Hvtsimpl: add_SNo v t = s0.
		            { rewrite Htdef.
		              rewrite (add_SNo_assoc v (minus_SNo v) s0 HvS (SNo_minus_SNo v HvS) Hs0S).
		              rewrite (add_SNo_minus_SNo_rinv v HvS).
		              rewrite (add_SNo_0L s0 Hs0S).
		              reflexivity. }
		            claim Hs0lt: s0 < add_SNo v diff.
		            { rewrite <- Hvtsimpl at 1.
		              exact Hvtlt. }
		            claim HminusDiffS: SNo (minus_SNo diff).
		            { exact (SNo_minus_SNo diff HdiffS). }
		            claim Hs0mDiffS: SNo (add_SNo (minus_SNo diff) s0).
		            { exact (SNo_add_SNo (minus_SNo diff) s0 HminusDiffS Hs0S). }
		            claim HvDiffS: SNo (add_SNo v diff).
		            { exact (SNo_add_SNo v diff HvS HdiffS). }
		            claim Hlhslt: add_SNo (minus_SNo diff) s0 < add_SNo (minus_SNo diff) (add_SNo v diff).
		            { exact (add_SNo_Lt2 (minus_SNo diff) s0 (add_SNo v diff) HminusDiffS Hs0S HvDiffS Hs0lt). }
		            claim Hrss: add_SNo (minus_SNo diff) (add_SNo v diff) = v.
		            { rewrite (add_SNo_com (minus_SNo diff) (add_SNo v diff) HminusDiffS HvDiffS) at 1.
		              rewrite <- (add_SNo_assoc v diff (minus_SNo diff) HvS HdiffS HminusDiffS) at 1.
		              rewrite (add_SNo_minus_SNo_rinv diff HdiffS).
		              rewrite (add_SNo_0R v HvS).
		              reflexivity. }
		            claim Hlss: add_SNo (minus_SNo diff) s0 = a.
		            { rewrite Hmdiffdef at 1.
		              rewrite (minus_add_SNo_distr s0 (minus_SNo a) Hs0S (SNo_minus_SNo a HaS)) at 1.
		              rewrite (minus_SNo_minus_SNo_R a HaR) at 1.
		              rewrite (add_SNo_com (minus_SNo s0) a (SNo_minus_SNo s0 Hs0S) HaS) at 1.
		              rewrite <- (add_SNo_assoc a (minus_SNo s0) s0 HaS (SNo_minus_SNo s0 Hs0S) Hs0S) at 1.
		              rewrite (add_SNo_minus_SNo_linv s0 Hs0S).
		              rewrite (add_SNo_0R a HaS).
		              reflexivity. }
		            claim Hs0mdlt: a < v.
		            { rewrite <- Hlss.
		              rewrite <- Hrss.
		              exact Hlhslt. }
		            exact (RltI a v HaR HvR Hs0mdlt). }
		          claim Hord: order_rel R a v.
		          { exact (Rlt_implies_order_rel_R a v Hltv). }
		          exact (SepI R (fun x1:set => order_rel R a x1) v HvR Hord). }
  apply HexUV.
  let U. assume HUpair.
  claim HUopen: U :e R_standard_topology.
  { exact (andEL (U :e R_standard_topology)
                 (exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HUpair). }
  claim HexV: exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { exact (andER (U :e R_standard_topology)
                 (exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HUpair). }
  apply HexV.
  let V. assume HVpair.
  claim HVopen: V :e R_standard_topology.
  { exact (andEL (V :e R_standard_topology)
                 (p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HVpair). }
  claim Hcore: p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { exact (andER (V :e R_standard_topology)
                 (p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HVpair). }
  claim Hp01: p 0 :e U /\ p 1 :e V.
  { exact (andEL (p 0 :e U /\ p 1 :e V) (rectangle_set U V c= W) Hcore). }
  claim Hbsub: rectangle_set U V c= W.
  { exact (andER (p 0 :e U /\ p 1 :e V) (rectangle_set U V c= W) Hcore). }
  claim Hp0U: p 0 :e U.
  { exact (andEL (p 0 :e U) (p 1 :e V) Hp01). }
  claim Hp1V: p 1 :e V.
  { exact (andER (p 0 :e U) (p 1 :e V) Hp01). }
  set b := rectangle_set U V.
  witness b.
  apply andI.
  - prove b :e B.
    claim HbV: b :e {rectangle_set U V0|V0 :e R_standard_topology}.
    { rewrite rectangle_set_def.
      exact (ReplI R_standard_topology (fun V0:set => rectangle_set U V0) V HVopen). }
    exact (famunionI R_standard_topology
           (fun U0:set => {rectangle_set U0 V0|V0 :e R_standard_topology})
           U b HUopen HbV).
  - apply andI.
    + prove p :e b.
      rewrite rectangle_set_def.
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta R R p HpDom). }
      rewrite HpEta at 1.
      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1V).
    + prove b c= W.
      rewrite rectangle_set_def.
      exact Hbsub.
Qed.

(** helper for §35: preimage of lower ray under multiplication on R **)
Theorem preimage_mul_fun_R_open_ray_lower_in_product_topology : forall b:set,
  b :e R ->
  preimage_of (setprod R R) mul_fun_R (open_ray_lower R b) :e
    (product_topology R R_standard_topology R R_standard_topology).
let b.
assume HbR: b :e R.
prove preimage_of (setprod R R) mul_fun_R (open_ray_lower R b) :e
  (product_topology R R_standard_topology R R_standard_topology).
set Tx := product_topology R R_standard_topology R R_standard_topology.
set B := product_subbasis R R_standard_topology R R_standard_topology.
set W := preimage_of (setprod R R) mul_fun_R (open_ray_lower R b).
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim HdefT: Tx = generated_topology (setprod R R) B.
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod R R) B =
  {U :e Power (setprod R R) | forall p :e U, exists b0 :e B, p :e b0 /\ b0 c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod R R))
  (fun U:set => forall p :e U, exists b0 :e B, p :e b0 /\ b0 c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_lower R b) p Hp).
- let p. assume Hp: p :e W.
  prove exists b0 :e B, p :e b0 /\ b0 c= W.
  claim HpDom: p :e setprod R R.
  { exact (SepE1 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_lower R b) p Hp). }
  claim Hp0R: p 0 :e R.
  { exact (ap0_Sigma R (fun _ : set => R) p HpDom). }
  claim Hp1R: p 1 :e R.
  { exact (ap1_Sigma R (fun _ : set => R) p HpDom). }
  claim Himg: apply_fun mul_fun_R p :e open_ray_lower R b.
  { exact (SepE2 (setprod R R) (fun q:set => apply_fun mul_fun_R q :e open_ray_lower R b) p Hp). }
  claim Hrel: order_rel R (apply_fun mul_fun_R p) b.
  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun mul_fun_R p) Himg). }
  claim Halt: Rlt (apply_fun mul_fun_R p) b.
  { exact (order_rel_R_implies_Rlt (apply_fun mul_fun_R p) b Hrel). }
  claim HexUV:
    exists U :e R_standard_topology, exists V :e R_standard_topology,
      p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { set x0 := p 0.
    set y0 := p 1.
    set s0 := apply_fun mul_fun_R p.
    claim Hs0R: s0 :e R.
    { exact (mul_fun_R_value_in_R p HpDom). }
    set diff := add_SNo b (minus_SNo s0).
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim Hs0S: SNo s0.
    { exact (real_SNo s0 Hs0R). }
    claim HdiffR: diff :e R.
    { exact (real_add_SNo b HbR (minus_SNo s0) (real_minus_SNo s0 Hs0R)). }
    claim HdiffPos: Rlt 0 diff.
    { exact (Rlt_0_diff_of_lt s0 b Halt). }
    claim HdiffS: SNo diff.
    { exact (real_SNo diff HdiffR). }
    claim HdiffPosS: 0 < diff.
    { exact (RltE_lt 0 diff HdiffPos). }
    set absx0 := abs_SNo x0.
    set absy0 := abs_SNo y0.
    claim Habsx0R: absx0 :e R.
    { exact (abs_SNo_in_R x0 Hp0R). }
    claim Habsy0R: absy0 :e R.
    { exact (abs_SNo_in_R y0 Hp1R). }
    claim Habsx0S: SNo absx0.
    { exact (real_SNo absx0 Habsx0R). }
    claim Habsy0S: SNo absy0.
    { exact (real_SNo absy0 Habsy0R). }
    set sumabs := add_SNo absx0 absy0.
    claim HsumabsR: sumabs :e R.
    { exact (real_add_SNo absx0 Habsx0R absy0 Habsy0R). }
    claim HsumabsS: SNo sumabs.
    { exact (real_SNo sumabs HsumabsR). }
    set denom := add_SNo 1 sumabs.
    claim HdenR: denom :e R.
    { exact (real_add_SNo 1 real_1 sumabs HsumabsR). }
    claim HdenS: SNo denom.
    { exact (SNo_add_SNo 1 sumabs SNo_1 HsumabsS). }
    claim H0le_absx0: 0 <= absx0.
    { exact (abs_SNo_nonneg x0 (real_SNo x0 Hp0R)). }
    claim H0le_absy0: 0 <= absy0.
    { exact (abs_SNo_nonneg y0 (real_SNo y0 Hp1R)). }
    claim H0le_sumabs: 0 <= sumabs.
    { claim Htmp: add_SNo 0 0 <= sumabs.
      { exact (add_SNo_Le3 0 0 absx0 absy0 SNo_0 SNo_0 Habsx0S Habsy0S H0le_absx0 H0le_absy0). }
      rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact Htmp. }
    claim HdenPos0: add_SNo 0 0 < denom.
    { exact (add_SNo_Lt3a 0 0 1 sumabs SNo_0 SNo_0 SNo_1 HsumabsS SNoLt_0_1 H0le_sumabs). }
    claim HdenPos: 0 < denom.
    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact HdenPos0. }
    set r := div_SNo diff denom.
    claim HrR: r :e R.
    { exact (real_div_SNo diff HdiffR denom HdenR). }
    claim HrS: SNo r.
    { exact (real_SNo r HrR). }
    claim HrposS: 0 < r.
    { exact (div_SNo_pos_pos diff denom HdiffS HdenS HdiffPosS HdenPos). }
    claim Hrpos: Rlt 0 r.
    { exact (RltI 0 r real_0 HrR HrposS). }
    claim HexN: exists N :e omega, eps_ N < r.
    { exact (exists_eps_lt_pos_Euclid r HrR Hrpos). }
	    apply HexN.
	    let N. assume HNpair.
	    claim HNomega: N :e omega.
	    { exact (andEL (N :e omega) (eps_ N < r) HNpair). }
	    claim HepsLt: eps_ N < r.
	    { exact (andER (N :e omega) (eps_ N < r) HNpair). }
	    claim HNnat: nat_p N.
	    { exact (omega_nat_p N HNomega). }
	    claim HsuccOmega: ordsucc N :e omega.
	    { exact (omega_ordsucc N HNomega). }
	    claim Hsucc2Omega: ordsucc (ordsucc N) :e omega.
	    { exact (omega_ordsucc (ordsucc N) HsuccOmega). }
	    set delta := eps_ (ordsucc (ordsucc N)).
	    claim HdeltaSNoS: delta :e SNoS_ omega.
	    { exact (SNo_eps_SNoS_omega (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaR: delta :e R.
	    { exact (SNoS_omega_real delta HdeltaSNoS). }
	    claim HdeltaPosS: 0 < delta.
	    { exact (SNo_eps_pos (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaPos: Rlt 0 delta.
	    { exact (RltI 0 delta real_0 HdeltaR HdeltaPosS). }
	    claim HdeltaS: SNo delta.
	    { exact (SNo_eps_ (ordsucc (ordsucc N)) Hsucc2Omega). }
	    claim HdeltaLt1S: delta < 1.
	    { claim HN1nat: nat_p (ordsucc N).
	      { exact (nat_ordsucc N HNnat). }
	      claim H0In: 0 :e ordsucc (ordsucc N).
	      { exact (nat_0_in_ordsucc (ordsucc N) HN1nat). }
	      claim Hlt0: delta < eps_ 0.
	      { exact (SNo_eps_decr (ordsucc (ordsucc N)) Hsucc2Omega 0 H0In). }
	      rewrite <- (eps_0_1).
	      exact Hlt0. }
	    claim HdeltaLt1: Rlt delta 1.
	    { exact (RltI delta 1 HdeltaR real_1 HdeltaLt1S). }
	    claim HepsSuccS: SNo (eps_ (ordsucc N)).
	    { exact (SNo_eps_ (ordsucc N) HsuccOmega). }
	    claim HepsNS: SNo (eps_ N).
	    { exact (SNo_eps_ N HNomega). }
	    claim HmIn: ordsucc N :e ordsucc (ordsucc N).
	    { exact (ordsuccI2 (ordsucc N)). }
	    claim HdeltaLtEpsSucc: delta < eps_ (ordsucc N).
	    { exact (SNo_eps_decr (ordsucc (ordsucc N)) Hsucc2Omega (ordsucc N) HmIn). }
	    claim HNIn: N :e ordsucc N.
	    { exact (ordsuccI2 N). }
	    claim HepsSuccLtEpsN: eps_ (ordsucc N) < eps_ N.
	    { exact (SNo_eps_decr (ordsucc N) HsuccOmega N HNIn). }
	    claim HdeltaLtEpsN: delta < eps_ N.
	    { exact (SNoLt_tra delta (eps_ (ordsucc N)) (eps_ N) HdeltaS HepsSuccS HepsNS HdeltaLtEpsSucc HepsSuccLtEpsN). }
	    claim HdeltaLtR: delta < r.
	    { exact (SNoLt_tra delta (eps_ N) r HdeltaS HepsNS HrS HdeltaLtEpsN HepsLt). }
	    set U0 := open_ball R R_bounded_metric x0 delta.
	    set V0 := open_ball R R_bounded_metric y0 delta.
    witness U0.
    apply andI.
    - prove U0 :e R_standard_topology.
      exact (open_ball_R_bounded_metric_in_R_standard_topology_early x0 delta Hp0R HdeltaR HdeltaPos).
    - witness V0.
      apply andI.
      + prove V0 :e R_standard_topology.
        exact (open_ball_R_bounded_metric_in_R_standard_topology_early y0 delta Hp1R HdeltaR HdeltaPos).
      + prove x0 :e U0 /\ y0 :e V0 /\ rectangle_set U0 V0 c= W.
        apply andI.
        * prove x0 :e U0 /\ y0 :e V0.
          apply andI.
          - prove x0 :e U0.
            exact (center_in_open_ball R R_bounded_metric x0 delta
                   R_bounded_metric_is_metric_on_early Hp0R HdeltaPos).
          - prove y0 :e V0.
            exact (center_in_open_ball R R_bounded_metric y0 delta
                   R_bounded_metric_is_metric_on_early Hp1R HdeltaPos).
	        * prove rectangle_set U0 V0 c= W.
	          let q. assume Hq: q :e rectangle_set U0 V0.
	          prove q :e W.
	          claim HqUV: q :e setprod U0 V0.
	          { rewrite <- (rectangle_set_def U0 V0) at 1.
	            exact Hq. }
	          claim Hq0U0: q 0 :e U0.
	          { exact (ap0_Sigma U0 (fun _ : set => V0) q HqUV). }
	          claim Hq1V0: q 1 :e V0.
	          { exact (ap1_Sigma U0 (fun _ : set => V0) q HqUV). }
	          claim HqRR: q :e setprod R R.
	          { claim HU0subR: U0 c= R.
	            { exact (open_ball_subset_X R R_bounded_metric x0 delta). }
	            claim HV0subR: V0 c= R.
	            { exact (open_ball_subset_X R R_bounded_metric y0 delta). }
	            exact ((setprod_Subq U0 V0 R R HU0subR HV0subR) q HqUV). }
	          claim HWdef: W = {q0 :e setprod R R | apply_fun mul_fun_R q0 :e open_ray_lower R b}.
	          { reflexivity. }
	          rewrite HWdef at 1.
	          apply (SepI (setprod R R) (fun q0:set => apply_fun mul_fun_R q0 :e open_ray_lower R b) q HqRR).
	          prove apply_fun mul_fun_R q :e open_ray_lower R b.
		          set v := apply_fun mul_fun_R q.
		          claim HvR: v :e R.
		          { exact (mul_fun_R_value_in_R q HqRR). }
		          claim Hltv: Rlt v b.
		          { claim HvS: SNo v.
		            { exact (real_SNo v HvR). }
		            claim HbS: SNo b.
		            { exact (real_SNo b HbR). }
		            claim Hs0S: SNo s0.
		            { exact (real_SNo s0 Hs0R). }
		            claim HdiffS: SNo diff.
		            { exact (real_SNo diff HdiffR). }
		            claim HdiffPosS: 0 < diff.
		            { exact (RltE_lt 0 diff HdiffPos). }
		            claim Hdiffdef: diff = add_SNo b (minus_SNo s0).
		            { reflexivity. }
		            set t := add_SNo v (minus_SNo s0).
		            claim HtS: SNo t.
		            { exact (SNo_add_SNo v (minus_SNo s0) HvS (SNo_minus_SNo s0 Hs0S)). }
		            claim Habs: abs_SNo t < diff.
		            { set q0 := q 0.
		              set q1 := q 1.
		              claim Hq0R: q0 :e R.
		              { exact (open_ballE1 R R_bounded_metric x0 delta q0 Hq0U0). }
		              claim Hq1R: q1 :e R.
		              { exact (open_ballE1 R R_bounded_metric y0 delta q1 Hq1V0). }
		              claim Habsx: abs_SNo (add_SNo x0 (minus_SNo q0)) < delta.
		              { exact (open_ball_R_bounded_metric_absdiff_lt x0 delta q0 Hp0R HdeltaR HdeltaPos HdeltaLt1 Hq0U0). }
		              claim Habsy: abs_SNo (add_SNo y0 (minus_SNo q1)) < delta.
		              { exact (open_ball_R_bounded_metric_absdiff_lt y0 delta q1 Hp1R HdeltaR HdeltaPos HdeltaLt1 Hq1V0). }
		              claim Hq0S: SNo q0.
		              { exact (real_SNo q0 Hq0R). }
		              claim Hq1S: SNo q1.
		              { exact (real_SNo q1 Hq1R). }
		              claim Hx0S: SNo x0.
		              { exact (real_SNo x0 Hp0R). }
		              claim Hy0S: SNo y0.
		              { exact (real_SNo y0 Hp1R). }
		              claim Habsy0S: SNo absy0.
		              { exact (real_SNo absy0 Habsy0R). }
		              claim Habsx0S: SNo absx0.
		              { exact (real_SNo absx0 Habsx0R). }
		              claim HvEq: v = mul_SNo q0 q1.
		              { rewrite (mul_fun_R_apply q HqRR).
		                reflexivity. }
		              claim Hs0Eq: s0 = mul_SNo x0 y0.
		              { rewrite (mul_fun_R_apply p HpDom).
		                reflexivity. }
		              set mid := mul_SNo q0 y0.
		              claim HmidS: SNo mid.
		              { exact (SNo_mul_SNo q0 y0 Hq0S Hy0S). }
		              claim Htri:
		                abs_SNo (add_SNo s0 (minus_SNo v))
		                <= add_SNo (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                           (abs_SNo (add_SNo mid (minus_SNo v))).
		              { exact (abs_SNo_triangle s0 mid v Hs0S HmidS HvS). }
		              set dx := add_SNo x0 (minus_SNo q0).
		              claim HdxS: SNo dx.
		              { exact (SNo_add_SNo x0 (minus_SNo q0) Hx0S (SNo_minus_SNo q0 Hq0S)). }
		              set dy := add_SNo y0 (minus_SNo q1).
		              claim HdyS: SNo dy.
		              { exact (SNo_add_SNo y0 (minus_SNo q1) Hy0S (SNo_minus_SNo q1 Hq1S)). }
		              claim HabsdxLe: abs_SNo dx <= delta.
		              { exact (SNoLtLe (abs_SNo dx) delta Habsx). }
		              claim HabsdyLe: abs_SNo dy <= delta.
		              { exact (SNoLtLe (abs_SNo dy) delta Habsy). }
		              claim H0le_absy0: 0 <= absy0.
		              { exact (abs_SNo_nonneg y0 Hy0S). }
		              claim H0le_delta: 0 <= delta.
		              { exact (SNoLtLe 0 delta HdeltaPosS). }
		              claim HswapAbs: abs_SNo t = abs_SNo (add_SNo s0 (minus_SNo v)).
		              { rewrite <- (abs_SNo_dist_swap s0 v Hs0S HvS).
		                rewrite (add_SNo_com s0 (minus_SNo v) Hs0S (SNo_minus_SNo v HvS)).
		                reflexivity. }
		              claim HsbEq: add_SNo s0 (minus_SNo mid) = mul_SNo dx y0.
		              { claim Hmiddef: mid = mul_SNo q0 y0.
		                { reflexivity. }
		                claim Hdxdef: dx = add_SNo x0 (minus_SNo q0).
		                { reflexivity. }
		                rewrite Hs0Eq at 1.
		                rewrite Hmiddef at 1.
		                rewrite Hdxdef.
		                rewrite (mul_SNo_distrR x0 (minus_SNo q0) y0
		                          Hx0S (SNo_minus_SNo q0 Hq0S) Hy0S).
		                claim Hneg2: mul_SNo (minus_SNo q0) y0 = minus_SNo (mul_SNo q0 y0).
		                { rewrite (mul_SNo_com (minus_SNo q0) y0 (SNo_minus_SNo q0 Hq0S) Hy0S).
		                  rewrite (mul_SNo_minus_distrR y0 q0 Hy0S Hq0S).
		                  rewrite (mul_SNo_com y0 q0 Hy0S Hq0S).
		                  reflexivity. }
		                rewrite Hneg2.
		                reflexivity. }
		              claim HbvEq: add_SNo mid (minus_SNo v) = mul_SNo q0 dy.
		              { claim Hmiddef: mid = mul_SNo q0 y0.
		                { reflexivity. }
		                claim Hdydef: dy = add_SNo y0 (minus_SNo q1).
		                { reflexivity. }
		                rewrite Hmiddef at 1.
		                rewrite HvEq at 1.
		                rewrite Hdydef.
		                rewrite (mul_SNo_distrL q0 y0 (minus_SNo q1) Hq0S Hy0S (SNo_minus_SNo q1 Hq1S)).
		                claim Hneg: mul_SNo q0 (minus_SNo q1) = minus_SNo (mul_SNo q0 q1).
		                { rewrite (mul_SNo_minus_distrR q0 q1 Hq0S Hq1S).
		                  reflexivity. }
		                rewrite Hneg.
		                reflexivity. }
		              claim Habs1:
		                abs_SNo (add_SNo s0 (minus_SNo mid)) <= mul_SNo absy0 delta.
		              { rewrite HsbEq.
		                rewrite (abs_SNo_mul_eq dx y0 HdxS Hy0S) at 1.
		                rewrite (mul_SNo_com absy0 delta Habsy0S HdeltaS).
		                claim HmulLe: mul_SNo (abs_SNo dx) absy0 <= mul_SNo delta absy0.
		                { exact (nonneg_mul_SNo_Le' (abs_SNo dx) delta absy0
		                         (SNo_abs_SNo dx HdxS) HdeltaS Habsy0S H0le_absy0 HabsdxLe). }
		                exact HmulLe. }
		              claim Habs_q0_le:
		                abs_SNo q0 <= add_SNo absx0 delta.
		              { set dq := add_SNo q0 (minus_SNo x0).
		                claim HdqS: SNo dq.
		                { exact (SNo_add_SNo q0 (minus_SNo x0) Hq0S (SNo_minus_SNo x0 Hx0S)). }
		                claim HdqEq: abs_SNo dq = abs_SNo dx.
		                { rewrite <- (abs_SNo_dist_swap x0 q0 Hx0S Hq0S).
		                  reflexivity. }
		                claim Hq0Eq: q0 = add_SNo dq x0.
		                { claim Hdqdef: dq = add_SNo q0 (minus_SNo x0).
		                  { reflexivity. }
		                  rewrite Hdqdef.
		                  rewrite <- (add_SNo_assoc q0 (minus_SNo x0) x0 Hq0S (SNo_minus_SNo x0 Hx0S) Hx0S).
		                  rewrite (add_SNo_minus_SNo_linv x0 Hx0S).
		                  rewrite (add_SNo_0R q0 Hq0S).
		                  reflexivity. }
		                claim Habsub: abs_SNo q0 <= add_SNo (abs_SNo dq) (abs_SNo x0).
		                { rewrite Hq0Eq at 1.
		                  exact (abs_SNo_subadd dq x0 HdqS Hx0S). }
		                claim Habsub_dx: abs_SNo q0 <= add_SNo (abs_SNo dx) (abs_SNo x0).
		                { claim HsumEq: add_SNo (abs_SNo dq) (abs_SNo x0) = add_SNo (abs_SNo dx) (abs_SNo x0).
		                  { rewrite HdqEq at 1.
		                    reflexivity. }
		                  rewrite <- HsumEq.
		                  exact Habsub. }
		                claim Habsy: abs_SNo x0 = absx0.
		                { reflexivity. }
		                claim Habsub_dx2: abs_SNo q0 <= add_SNo (abs_SNo dx) absx0.
		                { rewrite <- Habsy.
		                  exact Habsub_dx. }
		                claim HabsdxLe: abs_SNo dx <= delta.
		                { exact (SNoLtLe (abs_SNo dx) delta Habsx). }
		                claim Habsub2: add_SNo (abs_SNo dx) absx0 <= add_SNo delta absx0.
		                { exact (add_SNo_Le3 (abs_SNo dx) absx0 delta absx0
		                         (SNo_abs_SNo dx HdxS) Habsx0S HdeltaS Habsx0S
		                         HabsdxLe (SNoLe_ref absx0)). }
		                claim Habsub_dx3: abs_SNo q0 <= add_SNo delta absx0.
		                { exact (SNoLe_tra (abs_SNo q0)
		                                   (add_SNo (abs_SNo dx) absx0)
		                                   (add_SNo delta absx0)
		                                   (SNo_abs_SNo q0 Hq0S)
		                                   (SNo_add_SNo (abs_SNo dx) absx0 (SNo_abs_SNo dx HdxS) Habsx0S)
		                                   (SNo_add_SNo delta absx0 HdeltaS Habsx0S)
		                                   Habsub_dx2 Habsub2). }
		                rewrite (add_SNo_com absx0 delta Habsx0S HdeltaS) at 1.
		                exact Habsub_dx3. }
		              claim Habs2:
		                abs_SNo (add_SNo mid (minus_SNo v)) <= add_SNo (mul_SNo absx0 delta) delta.
		              { rewrite HbvEq.
		                rewrite (abs_SNo_mul_eq q0 dy Hq0S HdyS) at 1.
		                claim HmulDy: mul_SNo (abs_SNo q0) (abs_SNo dy) <= mul_SNo (abs_SNo q0) delta.
		                { exact (nonneg_mul_SNo_Le (abs_SNo q0) (abs_SNo dy) delta
		                         (SNo_abs_SNo q0 Hq0S) (abs_SNo_nonneg q0 Hq0S)
		                         (SNo_abs_SNo dy HdyS) HdeltaS HabsdyLe). }
		                claim HmulQ0: mul_SNo (abs_SNo q0) delta <= mul_SNo (add_SNo absx0 delta) delta.
		                { exact (nonneg_mul_SNo_Le' (abs_SNo q0) (add_SNo absx0 delta) delta
		                         (SNo_abs_SNo q0 Hq0S)
		                         (SNo_add_SNo absx0 delta Habsx0S HdeltaS)
		                         HdeltaS H0le_delta Habs_q0_le). }
		                claim HmulLe: mul_SNo (abs_SNo q0) (abs_SNo dy) <= mul_SNo (add_SNo absx0 delta) delta.
		                { exact (SNoLe_tra (mul_SNo (abs_SNo q0) (abs_SNo dy))
		                                   (mul_SNo (abs_SNo q0) delta)
		                                   (mul_SNo (add_SNo absx0 delta) delta)
		                                   (SNo_mul_SNo (abs_SNo q0) (abs_SNo dy) (SNo_abs_SNo q0 Hq0S) (SNo_abs_SNo dy HdyS))
		                                   (SNo_mul_SNo (abs_SNo q0) delta (SNo_abs_SNo q0 Hq0S) HdeltaS)
		                                   (SNo_mul_SNo (add_SNo absx0 delta) delta (SNo_add_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                   HmulDy HmulQ0). }
		                claim HdeltaLe1: delta <= 1.
		                { exact (SNoLtLe delta 1 HdeltaLt1S). }
		                claim Hdelta2Le: mul_SNo delta delta <= delta.
		                { exact (mul_SNo_Le1_nonneg_Le delta delta HdeltaS HdeltaS HdeltaLe1 H0le_delta). }
		                claim HexpLe:
		                  mul_SNo (add_SNo absx0 delta) delta <= add_SNo (mul_SNo absx0 delta) delta.
		                { rewrite (mul_SNo_distrR absx0 delta delta Habsx0S HdeltaS HdeltaS) at 1.
		                  exact (add_SNo_Le3 (mul_SNo absx0 delta) (mul_SNo delta delta)
		                           (mul_SNo absx0 delta) delta
		                           (SNo_mul_SNo absx0 delta Habsx0S HdeltaS)
		                           (SNo_mul_SNo delta delta HdeltaS HdeltaS)
		                           (SNo_mul_SNo absx0 delta Habsx0S HdeltaS)
		                           HdeltaS
		                           (SNoLe_ref (mul_SNo absx0 delta)) Hdelta2Le). }
		                exact (SNoLe_tra (mul_SNo (abs_SNo q0) (abs_SNo dy))
		                                 (mul_SNo (add_SNo absx0 delta) delta)
		                                 (add_SNo (mul_SNo absx0 delta) delta)
		                                 (SNo_mul_SNo (abs_SNo q0) (abs_SNo dy) (SNo_abs_SNo q0 Hq0S) (SNo_abs_SNo dy HdyS))
		                                 (SNo_mul_SNo (add_SNo absx0 delta) delta (SNo_add_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                 (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                                 HmulLe
		                                 HexpLe). }
		              claim HabsBound:
		                abs_SNo (add_SNo s0 (minus_SNo v)) <= mul_SNo denom delta.
		              { claim Hstep1:
		                  abs_SNo (add_SNo s0 (minus_SNo v))
		                  <= add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta).
		                { exact (SNoLe_tra
		                         (abs_SNo (add_SNo s0 (minus_SNo v)))
		                         (add_SNo (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                                  (abs_SNo (add_SNo mid (minus_SNo v))))
		                         (add_SNo (mul_SNo absy0 delta)
		                                  (add_SNo (mul_SNo absx0 delta) delta))
		                         (SNo_abs_SNo (add_SNo s0 (minus_SNo v))
		                           (SNo_add_SNo s0 (minus_SNo v) Hs0S (SNo_minus_SNo v HvS)))
		                         (SNo_add_SNo
		                           (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                           (abs_SNo (add_SNo mid (minus_SNo v)))
		                           (SNo_abs_SNo (add_SNo s0 (minus_SNo mid))
		                             (SNo_add_SNo s0 (minus_SNo mid) Hs0S (SNo_minus_SNo mid HmidS)))
		                           (SNo_abs_SNo (add_SNo mid (minus_SNo v))
		                             (SNo_add_SNo mid (minus_SNo v) HmidS (SNo_minus_SNo v HvS))))
		                         (SNo_add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta)
		                           (SNo_mul_SNo absy0 delta Habsy0S HdeltaS)
		                           (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS))
		                         Htri
		                         (add_SNo_Le3
		                           (abs_SNo (add_SNo s0 (minus_SNo mid)))
		                           (abs_SNo (add_SNo mid (minus_SNo v)))
		                           (mul_SNo absy0 delta)
		                           (add_SNo (mul_SNo absx0 delta) delta)
		                           (SNo_abs_SNo (add_SNo s0 (minus_SNo mid))
		                             (SNo_add_SNo s0 (minus_SNo mid) Hs0S (SNo_minus_SNo mid HmidS)))
		                           (SNo_abs_SNo (add_SNo mid (minus_SNo v))
		                             (SNo_add_SNo mid (minus_SNo v) HmidS (SNo_minus_SNo v HvS)))
		                           (SNo_mul_SNo absy0 delta Habsy0S HdeltaS)
		                           (SNo_add_SNo (mul_SNo absx0 delta) delta (SNo_mul_SNo absx0 delta Habsx0S HdeltaS) HdeltaS)
		                           Habs1 Habs2)). }
		                claim HdenExp:
		                  mul_SNo denom delta = add_SNo (mul_SNo absy0 delta) (add_SNo (mul_SNo absx0 delta) delta).
		                { rewrite (mul_SNo_distrR 1 sumabs delta SNo_1 HsumabsS HdeltaS) at 1.
		                  rewrite (mul_SNo_com 1 delta SNo_1 HdeltaS) at 1.
		                  rewrite (mul_SNo_oneR delta HdeltaS) at 1.
		                  rewrite (mul_SNo_distrR absx0 absy0 delta Habsx0S Habsy0S HdeltaS) at 1.
		                  set A := mul_SNo absx0 delta.
		                  set B := mul_SNo absy0 delta.
		                  claim HAS: SNo A.
		                  { exact (SNo_mul_SNo absx0 delta Habsx0S HdeltaS). }
		                  claim HBS: SNo B.
		                  { exact (SNo_mul_SNo absy0 delta Habsy0S HdeltaS). }
		                  rewrite (add_SNo_assoc delta A B HdeltaS HAS HBS) at 1.
		                  rewrite (add_SNo_com (add_SNo delta A) B
		                                       (SNo_add_SNo delta A HdeltaS HAS) HBS) at 1.
		                  rewrite (add_SNo_com delta A HdeltaS HAS) at 1.
		                  reflexivity. }
		                rewrite HdenExp.
		                exact Hstep1. }
		              claim HmulDenLt: mul_SNo denom delta < diff.
		              { rewrite (mul_SNo_com denom delta HdenS HdeltaS).
		                exact (div_SNo_pos_LtR' diff denom delta HdiffS HdenS HdeltaS HdenPos HdeltaLtR). }
		              claim HabsLt:
		                abs_SNo (add_SNo s0 (minus_SNo v)) < diff.
		              { exact (SNoLeLt_tra (abs_SNo (add_SNo s0 (minus_SNo v)))
		                                   (mul_SNo denom delta)
		                                   diff
		                                   (SNo_abs_SNo (add_SNo s0 (minus_SNo v))
		                                     (SNo_add_SNo s0 (minus_SNo v) Hs0S (SNo_minus_SNo v HvS)))
		                                   (SNo_mul_SNo denom delta HdenS HdeltaS)
		                                   HdiffS
		                                   HabsBound
		                                   HmulDenLt). }
		              rewrite HswapAbs.
		              exact HabsLt. }
		            claim Htlt: t < diff.
		            { exact (abs_SNo_lt_imp_lt t diff HtS HdiffS HdiffPosS Habs). }
		            claim Hs0tlt: add_SNo s0 t < add_SNo s0 diff.
		            { exact (add_SNo_Lt2 s0 t diff Hs0S HtS HdiffS Htlt). }
		            claim Hs0tEq: add_SNo s0 t = v.
		            { rewrite (add_SNo_assoc s0 v (minus_SNo s0) Hs0S HvS (SNo_minus_SNo s0 Hs0S)) at 1.
		              rewrite (add_SNo_com s0 v Hs0S HvS) at 1.
		              rewrite <- (add_SNo_assoc v s0 (minus_SNo s0) HvS Hs0S (SNo_minus_SNo s0 Hs0S)) at 1.
		              rewrite (add_SNo_minus_SNo_rinv s0 Hs0S).
		              rewrite (add_SNo_0R v HvS).
		              reflexivity. }
		            claim Hs0dEq: add_SNo s0 diff = b.
		            { rewrite Hdiffdef.
		              rewrite (add_SNo_assoc s0 b (minus_SNo s0) Hs0S HbS (SNo_minus_SNo s0 Hs0S)) at 1.
		              rewrite (add_SNo_com s0 b Hs0S HbS) at 1.
		              rewrite <- (add_SNo_assoc b s0 (minus_SNo s0) HbS Hs0S (SNo_minus_SNo s0 Hs0S)) at 1.
		              rewrite (add_SNo_minus_SNo_rinv s0 Hs0S).
		              rewrite (add_SNo_0R b HbS).
		              reflexivity. }
		            claim HvltS: v < b.
		            { rewrite <- Hs0tEq.
		              rewrite <- Hs0dEq.
		              exact Hs0tlt. }
		            exact (RltI v b HvR HbR HvltS). }
		          claim Hord: order_rel R v b.
		          { exact (Rlt_implies_order_rel_R v b Hltv). }
		          exact (SepI R (fun x1:set => order_rel R x1 b) v HvR Hord). }
  apply HexUV.
  let U. assume HUpair.
  claim HUopen: U :e R_standard_topology.
  { exact (andEL (U :e R_standard_topology)
                 (exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HUpair). }
  claim HexV: exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { exact (andER (U :e R_standard_topology)
                 (exists V :e R_standard_topology, p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HUpair). }
  apply HexV.
  let V. assume HVpair.
  claim HVopen: V :e R_standard_topology.
  { exact (andEL (V :e R_standard_topology)
                 (p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HVpair). }
  claim Hcore: p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W.
  { exact (andER (V :e R_standard_topology)
                 (p 0 :e U /\ p 1 :e V /\ rectangle_set U V c= W)
                 HVpair). }
  claim Hp01: p 0 :e U /\ p 1 :e V.
  { exact (andEL (p 0 :e U /\ p 1 :e V) (rectangle_set U V c= W) Hcore). }
  claim Hbsub: rectangle_set U V c= W.
  { exact (andER (p 0 :e U /\ p 1 :e V) (rectangle_set U V c= W) Hcore). }
  claim Hp0U: p 0 :e U.
  { exact (andEL (p 0 :e U) (p 1 :e V) Hp01). }
  claim Hp1V: p 1 :e V.
  { exact (andER (p 0 :e U) (p 1 :e V) Hp01). }
  set b0 := rectangle_set U V.
  witness b0.
  apply andI.
  - prove b0 :e B.
    claim HbV: b0 :e {rectangle_set U V0|V0 :e R_standard_topology}.
    { rewrite rectangle_set_def.
      exact (ReplI R_standard_topology (fun V0:set => rectangle_set U V0) V HVopen). }
    exact (famunionI R_standard_topology
           (fun U0:set => {rectangle_set U0 V0|V0 :e R_standard_topology})
           U b0 HUopen HbV).
  - apply andI.
    + prove p :e b0.
      rewrite rectangle_set_def.
      claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta R R p HpDom). }
      rewrite HpEta at 1.
      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0U Hp1V).
    + prove b0 c= W.
      rewrite rectangle_set_def.
      exact Hbsub.
Qed.

(** helper for §35: continuity of multiplication on R×R **)
Theorem mul_fun_R_continuous :
  continuous_map (setprod R R) (product_topology R R_standard_topology R R_standard_topology)
    R R_standard_topology mul_fun_R.
prove continuous_map (setprod R R) (product_topology R R_standard_topology R R_standard_topology)
  R R_standard_topology mul_fun_R.
set Tx := product_topology R R_standard_topology R R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on (setprod R R) Tx.
{ exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology_local
         R_standard_topology_is_topology_local). }
claim Hfun: function_on mul_fun_R (setprod R R) R.
{ let p. assume HpRR: p :e setprod R R.
  exact (mul_fun_R_value_in_R p HpRR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = R_standard_topology.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }

claim HpreS: forall s:set, s :e S -> preimage_of (setprod R R) mul_fun_R s :e Tx.
{ let s. assume HsS: s :e S.
  prove preimage_of (setprod R R) mul_fun_R s :e Tx.
  apply (binunionE' ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b})
                    {R}
                    s
                    (preimage_of (setprod R R) mul_fun_R s :e Tx)).
  - assume Hs0: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                      :\/:
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}).
    apply (binunionE' {I :e Power R | exists a :e R, I = open_ray_upper R a}
                      {I :e Power R | exists b :e R, I = open_ray_lower R b}
                      s
                      (preimage_of (setprod R R) mul_fun_R s :e Tx)).
    + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
      claim Hex: exists a :e R, s = open_ray_upper R a.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists a :e R, I0 = open_ray_upper R a)
                    s
                    Hsu). }
      apply Hex.
      let a. assume Hacore.
      apply Hacore.
      assume HaR: a :e R.
      assume Hseq: s = open_ray_upper R a.
      rewrite Hseq.
      exact (preimage_mul_fun_R_open_ray_upper_in_product_topology a HaR).
    + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
      claim Hex: exists b :e R, s = open_ray_lower R b.
      { exact (SepE2 (Power R)
                    (fun I0 : set => exists b :e R, I0 = open_ray_lower R b)
                    s
                    Hsl). }
      apply Hex.
      let b. assume Hbcore.
      apply Hbcore.
      assume HbR: b :e R.
      assume Hseq: s = open_ray_lower R b.
      rewrite Hseq.
      exact (preimage_mul_fun_R_open_ray_lower_in_product_topology b HbR).
    + exact Hs0.
  - assume HsR: s :e {R}.
    claim Hseq: s = R.
    { exact (SingE R s HsR). }
    rewrite Hseq.
    claim Heq: preimage_of (setprod R R) mul_fun_R R = setprod R R.
    { exact (preimage_of_whole (setprod R R) R mul_fun_R Hfun). }
    rewrite Heq.
    exact (topology_has_X (setprod R R) Tx HTx).
  - exact HsS. }

claim Hcont0:
  continuous_map (setprod R R) Tx R (generated_topology_from_subbasis R S) mul_fun_R.
{ exact (continuous_map_from_subbasis (setprod R R) Tx R S mul_fun_R HTx Hfun HS HpreS). }
claim Hsub: R_standard_topology c= generated_topology_from_subbasis R S.
{ rewrite <- Hgen.
  let U. assume HU: U :e generated_topology_from_subbasis R S.
  exact HU. }
exact (continuous_map_codomain_coarser (setprod R R) Tx R
        (generated_topology_from_subbasis R S) R_standard_topology
        mul_fun_R
        Hcont0
        R_standard_topology_is_topology_local
        Hsub).
Qed.

(** helper for §35: pointwise product of two continuous R-valued maps is continuous **)
Theorem mul_two_continuous_R : forall X Tx g h:set,
  topology_on X Tx ->
  continuous_map X Tx R R_standard_topology g ->
  continuous_map X Tx R R_standard_topology h ->
  continuous_map X Tx R R_standard_topology (compose_fun X (pair_map X g h) mul_fun_R).
let X Tx g h.
assume HTx: topology_on X Tx.
assume Hg: continuous_map X Tx R R_standard_topology g.
assume Hh: continuous_map X Tx R R_standard_topology h.
prove continuous_map X Tx R R_standard_topology (compose_fun X (pair_map X g h) mul_fun_R).
set p := pair_map X g h.
claim Hpcont:
  continuous_map X Tx (setprod R R)
    (product_topology R R_standard_topology R R_standard_topology) p.
{ exact (maps_into_products_axiom X Tx R R_standard_topology R R_standard_topology g h Hg Hh). }
claim Hmulcont:
  continuous_map (setprod R R)
    (product_topology R R_standard_topology R R_standard_topology)
    R R_standard_topology mul_fun_R.
{ exact mul_fun_R_continuous. }
exact (composition_continuous X Tx (setprod R R)
         (product_topology R R_standard_topology R R_standard_topology)
         R R_standard_topology
         p mul_fun_R Hpcont Hmulcont).
Qed.


(** helper for §35: -2/3 expressed as -1/3 + -1/3 **)
Theorem minus_two_thirds_eq : minus_SNo two_thirds = add_SNo (minus_SNo one_third) (minus_SNo one_third).
prove minus_SNo two_thirds = add_SNo (minus_SNo one_third) (minus_SNo one_third).
claim Hdef: two_thirds = add_SNo one_third one_third.
{ reflexivity. }
rewrite Hdef at 1.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
exact (minus_add_SNo_distr one_third one_third H13S H13S).
Qed.

(** helper for §35: one_third and two_thirds as divisions by 3 **)
Theorem one_third_eq_div_1_3 : one_third = div_SNo 1 3.
prove one_third = div_SNo 1 3.
claim H3S: SNo 3.
{ exact (real_SNo 3 real_3). }
claim Hdiv: div_SNo 1 3 = inv_nat 3.
{ exact (div_SNo_1_eq_inv_nat 3 H3S). }
claim Hdef: one_third = inv_nat 3.
{ reflexivity. }
rewrite Hdef.
rewrite <- Hdiv.
reflexivity.
Qed.

Theorem two_thirds_eq_div_2_3 : two_thirds = div_SNo 2 3.
prove two_thirds = div_SNo 2 3.
claim H3S: SNo 3.
{ exact (real_SNo 3 real_3). }
claim HrS: SNo (recip_SNo 3).
{ exact (SNo_recip_SNo 3 H3S). }
claim Hdiv1: div_SNo 1 3 = mul_SNo 1 (recip_SNo 3).
{ reflexivity. }
claim Hdiv2: div_SNo 2 3 = mul_SNo 2 (recip_SNo 3).
{ reflexivity. }
claim Hdef23: two_thirds = add_SNo one_third one_third.
{ reflexivity. }
rewrite Hdef23.
rewrite one_third_eq_div_1_3.
rewrite Hdiv1.
rewrite Hdiv2.
rewrite (mul_SNo_oneL (recip_SNo 3) HrS).
claim H2mul: mul_SNo (add_SNo 1 1) (recip_SNo 3) = mul_SNo 2 (recip_SNo 3).
{ rewrite add_SNo_1_1_2.
  reflexivity. }
rewrite <- H2mul at 1.
rewrite (mul_SNo_distrR 1 1 (recip_SNo 3) SNo_1 SNo_1 HrS) at 1.
rewrite (mul_SNo_oneL (recip_SNo 3) HrS).
reflexivity.
Qed.

(** helper for §35: 1 divided by 2 equals eps_ 1 **)
Theorem div_SNo_1_2_eq_eps_1 : div_SNo 1 2 = eps_ 1.
prove div_SNo 1 2 = eps_ 1.
claim Hpos2: 0 < 2.
{ exact SNoLt_0_2. }
claim HdivDef: div_SNo 1 2 = mul_SNo 1 (recip_SNo 2).
{ reflexivity. }
rewrite HdivDef.
rewrite (recip_SNo_poscase 2 Hpos2).
rewrite recip_SNo_pos_2.
exact (mul_SNo_oneL (eps_ 1) SNo_eps_1).
Qed.

(** helper: add_nat 4 4 equals 8 **)
Theorem add_nat_4_4_eq_8 : add_nat 4 4 = 8.
prove add_nat 4 4 = 8.
claim H0nat: nat_p 0.
{ exact nat_0. }
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H2nat: nat_p 2.
{ exact nat_2. }
claim H3nat: nat_p 3.
{ exact (nat_ordsucc 2 nat_2). }
claim H4eq: 4 = ordsucc 3.
{ reflexivity. }
rewrite H4eq at 1.
rewrite (add_nat_SR 4 3 H3nat) at 1.
rewrite H4eq at 1.
rewrite (add_nat_SR 4 2 H2nat) at 1.
rewrite (add_nat_SR 4 1 H1nat) at 1.
rewrite (add_nat_SR 4 0 H0nat) at 1.
rewrite (add_nat_0R 4) at 1.
reflexivity.
Qed.

(** helper: mul_nat 4 2 equals 8 **)
Theorem mul_nat_4_2_eq_8 : mul_nat 4 2 = 8.
prove mul_nat 4 2 = 8.
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H2eq: 2 = ordsucc 1.
{ reflexivity. }
rewrite H2eq at 1.
rewrite (mul_nat_SR 4 1 H1nat) at 1.
rewrite (mul_nat_1R 4) at 1.
rewrite add_nat_4_4_eq_8.
reflexivity.
Qed.

(** helper: 4 times 2 is strictly below 9 in SNo order **)
Theorem mul_SNo_4_2_lt_9 : mul_SNo 4 2 < 9.
prove mul_SNo 4 2 < 9.
claim H3nat: nat_p 3.
{ exact (nat_ordsucc 2 nat_2). }
claim H4nat: nat_p 4.
{ exact (nat_ordsucc 3 H3nat). }
claim H5nat: nat_p 5.
{ exact (nat_ordsucc 4 H4nat). }
claim H6nat: nat_p 6.
{ exact (nat_ordsucc 5 H5nat). }
claim H7nat: nat_p 7.
{ exact (nat_ordsucc 6 H6nat). }
claim H8nat: nat_p 8.
{ exact (nat_ordsucc 7 H7nat). }
claim H9nat: nat_p 9.
{ exact (nat_ordsucc 8 H8nat). }
claim H4O: 4 :e omega.
{ exact (nat_p_omega 4 H4nat). }
claim H2O: 2 :e omega.
{ exact (nat_p_omega 2 nat_2). }
claim HmulNatEq: mul_nat 4 2 = mul_SNo 4 2.
{ exact (mul_nat_mul_SNo 4 H4O 2 H2O). }
rewrite <- HmulNatEq at 1.
rewrite mul_nat_4_2_eq_8.
claim Hord9: ordinal 9.
{ exact (nat_p_ordinal 9 H9nat). }
claim H9eq: ordsucc 8 = 9.
{ reflexivity. }
claim H8in9: 8 :e 9.
{ rewrite <- H9eq.
  exact (ordsuccI2 8). }
exact (ordinal_In_SNoLt 9 Hord9 8 H8in9).
Qed.

(** helper: add_nat 3 3 equals 6 **)
Theorem add_nat_3_3_eq_6 : add_nat 3 3 = 6.
prove add_nat 3 3 = 6.
claim H0nat: nat_p 0.
{ exact nat_0. }
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H2nat: nat_p 2.
{ exact nat_2. }
claim H3eq: 3 = ordsucc 2.
{ reflexivity. }
rewrite H3eq at 1.
rewrite (add_nat_SR 3 2 H2nat) at 1.
rewrite (add_nat_SR 3 1 H1nat) at 1.
rewrite (add_nat_SR 3 0 H0nat) at 1.
rewrite (add_nat_0R 3) at 1.
reflexivity.
Qed.

(** helper: add_nat 3 6 equals 9 **)
Theorem add_nat_3_6_eq_9 : add_nat 3 6 = 9.
prove add_nat 3 6 = 9.
claim H0nat: nat_p 0.
{ exact nat_0. }
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H2nat: nat_p 2.
{ exact nat_2. }
claim H3nat: nat_p 3.
{ exact (nat_ordsucc 2 nat_2). }
claim H4nat: nat_p 4.
{ exact (nat_ordsucc 3 H3nat). }
claim H5nat: nat_p 5.
{ exact (nat_ordsucc 4 H4nat). }
claim H6eq: 6 = ordsucc 5.
{ reflexivity. }
rewrite H6eq at 1.
rewrite (add_nat_SR 3 5 H5nat) at 1.
rewrite (add_nat_SR 3 4 H4nat) at 1.
rewrite (add_nat_SR 3 3 H3nat) at 1.
rewrite (add_nat_SR 3 2 H2nat) at 1.
rewrite (add_nat_SR 3 1 H1nat) at 1.
rewrite (add_nat_SR 3 0 H0nat) at 1.
rewrite (add_nat_0R 3) at 1.
reflexivity.
Qed.

(** helper: mul_nat 2 2 equals 4 **)
Theorem mul_nat_2_2_eq_4 : mul_nat 2 2 = 4.
prove mul_nat 2 2 = 4.
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H2eq: 2 = ordsucc 1.
{ reflexivity. }
rewrite H2eq at 1.
rewrite (mul_nat_SR 2 1 H1nat) at 1.
rewrite (mul_nat_1R 2) at 1.
rewrite H2eq at 2.
rewrite (add_nat_SR 2 1 H1nat) at 1.
claim H1eq: 1 = ordsucc 0.
{ reflexivity. }
rewrite H1eq at 1.
rewrite (add_nat_SR 2 0 nat_0) at 1.
rewrite (add_nat_0R 2) at 1.
reflexivity.
Qed.

(** helper: mul_nat 3 3 equals 9 **)
Theorem mul_nat_3_3_eq_9 : mul_nat 3 3 = 9.
prove mul_nat 3 3 = 9.
claim H2nat: nat_p 2.
{ exact nat_2. }
claim H1nat: nat_p 1.
{ exact nat_1. }
claim H3eq: 3 = ordsucc 2.
{ reflexivity. }
rewrite H3eq at 1.
rewrite (mul_nat_SR 3 2 H2nat) at 1.
rewrite H3eq at 1.
rewrite (mul_nat_SR 3 1 H1nat) at 1.
rewrite (mul_nat_1R 3) at 1.
rewrite add_nat_3_3_eq_6 at 1.
rewrite add_nat_3_6_eq_9 at 1.
reflexivity.
Qed.

(** helper: mul_SNo 2 2 equals 4 **)
Theorem mul_SNo_2_2_eq_4 : mul_SNo 2 2 = 4.
prove mul_SNo 2 2 = 4.
claim H2O: 2 :e omega.
{ exact (nat_p_omega 2 nat_2). }
claim HmulEq: mul_nat 2 2 = mul_SNo 2 2.
{ exact (mul_nat_mul_SNo 2 H2O 2 H2O). }
rewrite <- HmulEq.
rewrite mul_nat_2_2_eq_4.
reflexivity.
Qed.

(** helper: mul_SNo 3 3 equals 9 **)
Theorem mul_SNo_3_3_eq_9 : mul_SNo 3 3 = 9.
prove mul_SNo 3 3 = 9.
claim H3nat: nat_p 3.
{ exact (nat_ordsucc 2 nat_2). }
claim H3O: 3 :e omega.
{ exact (nat_p_omega 3 H3nat). }
claim HmulEq: mul_nat 3 3 = mul_SNo 3 3.
{ exact (mul_nat_mul_SNo 3 H3O 3 H3O). }
rewrite <- HmulEq.
rewrite mul_nat_3_3_eq_9.
reflexivity.
Qed.

(** helper for §35: square of two_thirds is below eps_ 1 **)
Theorem two_thirds_sq_lt_eps_1 : mul_SNo two_thirds two_thirds < eps_ 1.
prove mul_SNo two_thirds two_thirds < eps_ 1.
rewrite two_thirds_eq_div_2_3 at 1.
rewrite two_thirds_eq_div_2_3 at 1.
claim H3S: SNo 3.
{ exact (real_SNo 3 real_3). }
rewrite (mul_div_SNo_both 2 3 2 3 SNo_2 H3S SNo_2 H3S) at 1.
rewrite mul_SNo_2_2_eq_4 at 1.
rewrite mul_SNo_3_3_eq_9 at 1.
rewrite <- div_SNo_1_2_eq_eps_1.
claim H4S: SNo 4.
{ rewrite <- mul_SNo_2_2_eq_4.
  exact (SNo_mul_SNo 2 2 SNo_2 SNo_2). }
claim H9S: SNo 9.
{ rewrite <- mul_SNo_3_3_eq_9.
  exact (SNo_mul_SNo 3 3 H3S H3S). }
claim HdivS: SNo (div_SNo 1 2).
{ exact (SNo_div_SNo 1 2 SNo_1 SNo_2). }
claim H8nat: nat_p 8.
{ claim H3nat: nat_p 3.
  { exact (nat_ordsucc 2 nat_2). }
  claim H4nat: nat_p 4.
  { exact (nat_ordsucc 3 H3nat). }
  claim H5nat: nat_p 5.
  { exact (nat_ordsucc 4 H4nat). }
  claim H6nat: nat_p 6.
  { exact (nat_ordsucc 5 H5nat). }
  claim H7nat: nat_p 7.
  { exact (nat_ordsucc 6 H6nat). }
  exact (nat_ordsucc 7 H7nat). }
claim H9eq: 9 = ordsucc 8.
{ reflexivity. }
claim H0in9: 0 :e 9.
{ rewrite H9eq.
  exact (nat_0_in_ordsucc 8 H8nat). }
claim Hord9: ordinal 9.
{ claim H9nat: nat_p 9.
  { exact (nat_ordsucc 8 H8nat). }
  exact (nat_p_ordinal 9 H9nat). }
claim H0lt9: 0 < 9.
{ exact (ordinal_In_SNoLt 9 Hord9 0 H0in9). }
apply (div_SNo_pos_LtL 4 9 (div_SNo 1 2) H4S H9S HdivS H0lt9).
prove 4 < mul_SNo (div_SNo 1 2) 9.
claim HmulEq: mul_SNo (div_SNo 1 2) 9 = div_SNo (mul_SNo 1 9) 2.
{ exact (mul_div_SNo_R 1 2 9 SNo_1 SNo_2 H9S). }
rewrite HmulEq.
rewrite (mul_SNo_oneL 9 H9S) at 1.
apply (div_SNo_pos_LtR 9 2 4 H9S SNo_2 H4S SNoLt_0_2).
exact mul_SNo_4_2_lt_9.
Qed.

Theorem add_one_third_two_thirds_eq_1 : add_SNo one_third two_thirds = 1.
prove add_SNo one_third two_thirds = 1.
claim H3S: SNo 3.
{ exact (real_SNo 3 real_3). }
claim HrS: SNo (recip_SNo 3).
{ exact (SNo_recip_SNo 3 H3S). }
claim Hdiv1: div_SNo 1 3 = mul_SNo 1 (recip_SNo 3).
{ reflexivity. }
claim Hdiv2: div_SNo 2 3 = mul_SNo 2 (recip_SNo 3).
{ reflexivity. }
rewrite one_third_eq_div_1_3 at 1.
rewrite two_thirds_eq_div_2_3 at 1.
rewrite Hdiv1 at 1.
rewrite Hdiv2 at 1.
rewrite <- (mul_SNo_distrR 1 2 (recip_SNo 3) SNo_1 SNo_2 HrS) at 1.
claim H12eq: add_SNo 1 2 = 3.
{ rewrite (add_SNo_com 1 2 SNo_1 SNo_2).
  rewrite <- add_SNo_2_1_eq_3.
  reflexivity. }
rewrite H12eq at 1.
claim H3ne0: 3 <> 0.
{ claim H3def: 3 = ordsucc 2.
  { reflexivity. }
  rewrite H3def.
  exact (neq_ordsucc_0 2). }
exact (recip_SNo_invR 3 H3S H3ne0).
Qed.

(** helper for §35: 2/3 < 1 **)
Theorem Rlt_two_thirds_1 : Rlt two_thirds 1.
prove Rlt two_thirds 1.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim H0lt13: 0 < one_third.
{ exact one_third_pos. }
claim Hlt: two_thirds < add_SNo two_thirds one_third.
{ rewrite <- (add_SNo_0R two_thirds H23S) at 1.
  exact (add_SNo_Lt2 two_thirds 0 one_third H23S SNo_0 H13S H0lt13). }
claim Heq: add_SNo two_thirds one_third = 1.
{ rewrite (add_SNo_com two_thirds one_third H23S H13S) at 1.
  exact add_one_third_two_thirds_eq_1. }
claim Hlt': two_thirds < 1.
{ rewrite <- Heq at 1.
  exact Hlt. }
exact (RltI two_thirds 1 H23R real_1 Hlt').
Qed.

(** helper for §35: 1/3 < 2/3 **)
Theorem one_third_lt_two_thirds : one_third < two_thirds.
prove one_third < two_thirds.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hlt13: 0 < one_third.
{ exact one_third_pos. }
claim Hdef: two_thirds = add_SNo one_third one_third.
{ reflexivity. }
rewrite Hdef.
rewrite <- (add_SNo_0R one_third H13S) at 1.
exact (add_SNo_Lt2 one_third 0 one_third H13S SNo_0 H13S Hlt13).
Qed.

(** helper for §35: 1/3 < 1 **)
Theorem one_third_lt_1_SNo : one_third < 1.
prove one_third < 1.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim H23lt1: two_thirds < 1.
{ exact (RltE_lt two_thirds 1 Rlt_two_thirds_1). }
exact (SNoLt_tra one_third two_thirds 1 H13S H23S SNo_1 one_third_lt_two_thirds H23lt1).
Qed.

(** helper for §35: Rlt one_third 1 **)
Theorem Rlt_one_third_1 : Rlt one_third 1.
prove Rlt one_third 1.
exact (RltI one_third 1 one_third_in_R real_1 one_third_lt_1_SNo).
Qed.

(** helper for §35: -1 < -1/3 **)
Theorem minus_1_lt_minus_one_third_SNo : (minus_SNo 1) < (minus_SNo one_third).
prove (minus_SNo 1) < (minus_SNo one_third).
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
exact (minus_SNo_Lt_contra one_third 1 H13S SNo_1 one_third_lt_1_SNo).
Qed.

(** helper for §35: Rlt (minus 1) (minus one_third) **)
Theorem Rlt_minus1_minus_one_third : Rlt (minus_SNo 1) (minus_SNo one_third).
prove Rlt (minus_SNo 1) (minus_SNo one_third).
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim Hm13R: minus_SNo one_third :e R.
{ exact (real_minus_SNo one_third H13R). }
exact (RltI (minus_SNo 1) (minus_SNo one_third) Hm1R Hm13R minus_1_lt_minus_one_third_SNo).
Qed.

(** helper for §35: I0 subset I **)
Theorem closed_interval_minus_one_third_one_third_sub_closed_interval_minus1_1 :
  closed_interval (minus_SNo one_third) one_third c= closed_interval (minus_SNo 1) 1.
let x. assume HxI0: x :e closed_interval (minus_SNo one_third) one_third.
prove x :e closed_interval (minus_SNo 1) 1.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim Hm13R: minus_SNo one_third :e R.
{ exact (real_minus_SNo one_third H13R). }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim HxR: x :e R.
{ exact ((closed_interval_sub_R (minus_SNo one_third) one_third) x HxI0). }
claim Hbnds0: Rle (minus_SNo one_third) x /\ Rle x one_third.
{ exact (closed_interval_bounds (minus_SNo one_third) one_third x Hm13R H13R HxI0). }
claim Hm13lex: Rle (minus_SNo one_third) x.
{ exact (andEL (Rle (minus_SNo one_third) x) (Rle x one_third) Hbnds0). }
claim Hxle13: Rle x one_third.
{ exact (andER (Rle (minus_SNo one_third) x) (Rle x one_third) Hbnds0). }
claim Hm1le_m13: Rle (minus_SNo 1) (minus_SNo one_third).
{ exact (Rlt_implies_Rle (minus_SNo 1) (minus_SNo one_third) Rlt_minus1_minus_one_third). }
claim H13le1: Rle one_third 1.
{ exact (Rlt_implies_Rle one_third 1 Rlt_one_third_1). }
claim Hm1lex: Rle (minus_SNo 1) x.
{ exact (Rle_tra (minus_SNo 1) (minus_SNo one_third) x Hm1le_m13 Hm13lex). }
claim Hxle1: Rle x 1.
{ exact (Rle_tra x one_third 1 Hxle13 H13le1). }
exact (closed_intervalI_of_Rle (minus_SNo 1) 1 x Hm1R real_1 HxR Hm1lex Hxle1).
Qed.

Theorem two_thirds_eq_1_minus_one_third : two_thirds = add_SNo 1 (minus_SNo one_third).
prove two_thirds = add_SNo 1 (minus_SNo one_third).
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim Heq: add_SNo two_thirds one_third = 1.
{ rewrite (add_SNo_com two_thirds one_third H23S H13S).
  exact add_one_third_two_thirds_eq_1. }
rewrite <- (add_SNo_minus_R2 two_thirds one_third H23S H13S) at 1.
rewrite Heq at 1.
reflexivity.
Qed.

Theorem minus_two_thirds_eq_minus1_plus_one_third : minus_SNo two_thirds = add_SNo (minus_SNo 1) one_third.
prove minus_SNo two_thirds = add_SNo (minus_SNo 1) one_third.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hm13S: SNo (minus_SNo one_third).
{ exact (SNo_minus_SNo one_third H13S). }
claim Heq: two_thirds = add_SNo 1 (minus_SNo one_third).
{ exact two_thirds_eq_1_minus_one_third. }
rewrite Heq at 1.
rewrite (minus_add_SNo_distr 1 (minus_SNo one_third) SNo_1 Hm13S) at 1.
rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
reflexivity.
Qed.

Theorem add_minus1_two_thirds_eq_minus_one_third : add_SNo (minus_SNo 1) two_thirds = minus_SNo one_third.
prove add_SNo (minus_SNo 1) two_thirds = minus_SNo one_third.
claim H23eq: two_thirds = add_SNo 1 (minus_SNo one_third).
{ exact two_thirds_eq_1_minus_one_third. }
rewrite H23eq.
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hm13S: SNo (minus_SNo one_third).
{ exact (SNo_minus_SNo one_third H13S). }
claim Hassoc:
  add_SNo (minus_SNo 1) (add_SNo 1 (minus_SNo one_third)) =
    add_SNo (add_SNo (minus_SNo 1) 1) (minus_SNo one_third).
{ exact (add_SNo_assoc (minus_SNo 1) 1 (minus_SNo one_third) Hm1S SNo_1 Hm13S). }
rewrite Hassoc.
claim Hinv: add_SNo (minus_SNo 1) 1 = 0.
{ exact (add_SNo_minus_SNo_linv 1 SNo_1). }
rewrite Hinv.
exact (add_SNo_0L (minus_SNo one_third) Hm13S).
Qed.

Theorem add_1_minus_two_thirds_eq_one_third : add_SNo 1 (minus_SNo two_thirds) = one_third.
prove add_SNo 1 (minus_SNo two_thirds) = one_third.
claim Hm23eq: minus_SNo two_thirds = add_SNo (minus_SNo 1) one_third.
{ exact minus_two_thirds_eq_minus1_plus_one_third. }
rewrite Hm23eq.
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hassoc:
  add_SNo 1 (add_SNo (minus_SNo 1) one_third) =
    add_SNo (add_SNo 1 (minus_SNo 1)) one_third.
{ exact (add_SNo_assoc 1 (minus_SNo 1) one_third SNo_1 Hm1S H13S). }
rewrite Hassoc.
claim Hinv: add_SNo 1 (minus_SNo 1) = 0.
{ exact (add_SNo_minus_SNo_rinv 1 SNo_1). }
rewrite Hinv.
exact (add_SNo_0L one_third H13S).
Qed.

Theorem Rle_0_two_thirds : Rle 0 two_thirds.
prove Rle 0 two_thirds.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H0lt13: Rlt 0 one_third.
{ claim H3nat: nat_p 3.
  { exact (nat_ordsucc 2 nat_2). }
  claim H3omega: 3 :e omega.
  { exact (nat_p_omega 3 H3nat). }
  claim H3non0: 3 /:e {0}.
  { assume H3in: 3 :e {0}.
    claim H30: 3 = 0.
    { exact (SingE 0 3 H3in). }
    claim H3ne0: 3 <> 0.
    { claim H3def: 3 = ordsucc 2.
      { reflexivity. }
      rewrite H3def.
      exact (neq_ordsucc_0 2). }
    exact (H3ne0 H30). }
  claim H3in: 3 :e omega :\: {0}.
  { exact (setminusI omega {0} 3 H3omega H3non0). }
  claim Hdef: one_third = inv_nat 3.
  { reflexivity. }
  rewrite Hdef.
  exact (inv_nat_pos 3 H3in). }
claim Hlt13: 0 < one_third.
{ exact (RltE_lt 0 one_third H0lt13). }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim H12S: SNo (add_SNo one_third 0).
{ exact (SNo_add_SNo one_third 0 H13S SNo_0). }
claim Hlt1: one_third < add_SNo one_third one_third.
{ rewrite <- (add_SNo_0R one_third H13S) at 1.
  exact (add_SNo_Lt2 one_third 0 one_third H13S SNo_0 H13S Hlt13). }
claim Hlt2: one_third < two_thirds.
{ claim Hdef: two_thirds = add_SNo one_third one_third.
  { reflexivity. }
  rewrite Hdef.
  exact Hlt1. }
claim H0S: SNo 0.
{ exact SNo_0. }
claim H13pos: 0 < two_thirds.
{ exact (SNoLt_tra 0 one_third two_thirds H0S H13S H23S Hlt13 Hlt2). }
exact (Rlt_implies_Rle 0 two_thirds (RltI 0 two_thirds real_0 H23R H13pos)).
Qed.

Theorem Rle_minus_two_thirds_0 : Rle (minus_SNo two_thirds) 0.
prove Rle (minus_SNo two_thirds) 0.
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H0lt13: Rlt 0 one_third.
{ claim H3nat: nat_p 3.
  { exact (nat_ordsucc 2 nat_2). }
  claim H3omega: 3 :e omega.
  { exact (nat_p_omega 3 H3nat). }
  claim H3non0: 3 /:e {0}.
  { assume H3in: 3 :e {0}.
    claim H30: 3 = 0.
    { exact (SingE 0 3 H3in). }
    claim H3ne0: 3 <> 0.
    { claim H3def: 3 = ordsucc 2.
      { reflexivity. }
      rewrite H3def.
      exact (neq_ordsucc_0 2). }
    exact (H3ne0 H30). }
  claim H3in: 3 :e omega :\: {0}.
  { exact (setminusI omega {0} 3 H3omega H3non0). }
  claim Hdef: one_third = inv_nat 3.
  { reflexivity. }
  rewrite Hdef.
  exact (inv_nat_pos 3 H3in). }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hlt13: 0 < one_third.
{ exact (RltE_lt 0 one_third H0lt13). }
claim Hlt2: one_third < two_thirds.
{ claim Hdef: two_thirds = add_SNo one_third one_third.
  { reflexivity. }
  rewrite Hdef.
  rewrite <- (add_SNo_0R one_third H13S) at 1.
  exact (add_SNo_Lt2 one_third 0 one_third H13S SNo_0 H13S Hlt13). }
claim Hpos: 0 < two_thirds.
{ exact (SNoLt_tra 0 one_third two_thirds SNo_0 H13S H23S Hlt13 Hlt2). }
claim Hm23lt0: (minus_SNo two_thirds) < 0.
{ rewrite <- minus_SNo_0 at 1.
  exact (minus_SNo_Lt_contra 0 two_thirds SNo_0 H23S Hpos). }
claim Hm23R: minus_SNo two_thirds :e R.
{ exact (real_minus_SNo two_thirds H23R). }
exact (Rlt_implies_Rle (minus_SNo two_thirds) 0 (RltI (minus_SNo two_thirds) 0 Hm23R real_0 Hm23lt0)).
Qed.

(** helper for §35: order relation -one_third <= one_third **)
Theorem Rlt_minus_one_third_one_third : Rlt (minus_SNo one_third) one_third.
prove Rlt (minus_SNo one_third) one_third.
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H0lt13: Rlt 0 one_third.
{ claim H3nat: nat_p 3.
  { exact (nat_ordsucc 2 nat_2). }
  claim H3omega: 3 :e omega.
  { exact (nat_p_omega 3 H3nat). }
  claim H3non0: 3 /:e {0}.
  { assume H3in: 3 :e {0}.
    claim H30: 3 = 0.
    { exact (SingE 0 3 H3in). }
    claim H3ne0: 3 <> 0.
    { claim H3def: 3 = ordsucc 2.
      { reflexivity. }
      rewrite H3def.
      exact (neq_ordsucc_0 2). }
    exact (H3ne0 H30). }
  claim H3in: 3 :e omega :\: {0}.
  { exact (setminusI omega {0} 3 H3omega H3non0). }
  claim Hdef: one_third = inv_nat 3.
  { reflexivity. }
  rewrite Hdef.
  exact (inv_nat_pos 3 H3in). }
claim Hlt13: 0 < one_third.
{ exact (RltE_lt 0 one_third H0lt13). }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim Hm13R: minus_SNo one_third :e R.
{ exact (real_minus_SNo one_third H13R). }
claim Hm13S: SNo (minus_SNo one_third).
{ exact (real_SNo (minus_SNo one_third) Hm13R). }
claim Hm13lt0: (minus_SNo one_third) < 0.
{ prove (minus_SNo one_third) < 0.
  rewrite <- minus_SNo_0 at 1.
  exact (minus_SNo_Lt_contra 0 one_third SNo_0 H13S Hlt13). }
claim Hm13lt13: (minus_SNo one_third) < one_third.
{ exact (SNoLt_tra (minus_SNo one_third) 0 one_third Hm13S SNo_0 H13S Hm13lt0 Hlt13). }
exact (RltI (minus_SNo one_third) one_third Hm13R H13R Hm13lt13).
Qed.

Theorem Rle_minus_one_third_one_third : Rle (minus_SNo one_third) one_third.
prove Rle (minus_SNo one_third) one_third.
exact (Rlt_implies_Rle (minus_SNo one_third) one_third (Rlt_minus_one_third_one_third)).
Qed.

(** helper: monotonicity of add_SNo in Rle form (left argument) **)
Theorem Rle_add_SNo_1 : forall x y z:set,
  x :e R -> y :e R -> z :e R ->
  Rle x y -> Rle (add_SNo x z) (add_SNo y z).
let x y z.
assume HxR: x :e R.
assume HyR: y :e R.
assume HzR: z :e R.
assume Hxy: Rle x y.
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HzS: SNo z.
{ exact (real_SNo z HzR). }
claim HxzR: add_SNo x z :e R.
{ exact (real_add_SNo x HxR z HzR). }
claim HyzR: add_SNo y z :e R.
{ exact (real_add_SNo y HyR z HzR). }
claim Hcomm_xz: add_SNo x z = add_SNo z x.
{ exact (add_SNo_com x z HxS HzS). }
claim Hcomm_yz: add_SNo y z = add_SNo z y.
{ exact (add_SNo_com y z HyS HzS). }
rewrite Hcomm_xz.
rewrite Hcomm_yz.
exact (Rle_add_SNo_2 z x y HzR HxR HyR Hxy).
Qed.

(** helper for §35 Step II: interval expansion by a 1/3-sized correction term **)
(** LATEX VERSION: If y is in [-1+c, 1-c] and z is in [-c/3, c/3] with c>0, then y+z lies in [-1+(2/3)c, 1-(2/3)c]. **)
Theorem add_SNo_interval_expand_by_third_stub : forall c y z:set,
  c :e R -> 0 < c ->
  y :e closed_interval (add_SNo (minus_SNo 1) c) (add_SNo 1 (minus_SNo c)) ->
  z :e closed_interval (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third) ->
  add_SNo y z :e closed_interval (add_SNo (minus_SNo 1) (mul_SNo c two_thirds))
                                (add_SNo 1 (minus_SNo (mul_SNo c two_thirds))).
let c y z.
assume HcR: c :e R.
assume Hcpos: 0 < c.
assume HyI: y :e closed_interval (add_SNo (minus_SNo 1) c) (add_SNo 1 (minus_SNo c)).
assume HzI: z :e closed_interval (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third).
prove add_SNo y z :e closed_interval (add_SNo (minus_SNo 1) (mul_SNo c two_thirds))
                              (add_SNo 1 (minus_SNo (mul_SNo c two_thirds))).
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13S: SNo one_third.
{ exact (real_SNo one_third H13R). }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
claim HyR: y :e R.
{ exact (closed_interval_sub_R (add_SNo (minus_SNo 1) c) (add_SNo 1 (minus_SNo c)) y HyI). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HzR: z :e R.
{ exact (closed_interval_sub_R (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third) z HzI). }
claim HzS: SNo z.
{ exact (real_SNo z HzR). }
claim Hc13R: mul_SNo c one_third :e R.
{ exact (real_mul_SNo c HcR one_third H13R). }
claim Hc13S: SNo (mul_SNo c one_third).
{ exact (real_SNo (mul_SNo c one_third) Hc13R). }
claim Hm_c13R: minus_SNo (mul_SNo c one_third) :e R.
{ exact (real_minus_SNo (mul_SNo c one_third) Hc13R). }
claim Hm_c13S: SNo (minus_SNo (mul_SNo c one_third)).
{ exact (SNo_minus_SNo (mul_SNo c one_third) Hc13S). }
claim HmcR: minus_SNo c :e R.
{ exact (real_minus_SNo c HcR). }
claim HmcS: SNo (minus_SNo c).
{ exact (SNo_minus_SNo c HcS). }
claim Hc23R: mul_SNo c two_thirds :e R.
{ exact (real_mul_SNo c HcR two_thirds H23R). }
claim Hc23S: SNo (mul_SNo c two_thirds).
{ exact (real_SNo (mul_SNo c two_thirds) Hc23R). }
claim HyB: Rle (add_SNo (minus_SNo 1) c) y /\ Rle y (add_SNo 1 (minus_SNo c)).
{ exact (closed_interval_bounds (add_SNo (minus_SNo 1) c) (add_SNo 1 (minus_SNo c)) y
         (real_add_SNo (minus_SNo 1) Hm1R c HcR)
         (real_add_SNo 1 real_1 (minus_SNo c) HmcR)
         HyI). }
claim HyLo: Rle (add_SNo (minus_SNo 1) c) y.
{ exact (andEL (Rle (add_SNo (minus_SNo 1) c) y) (Rle y (add_SNo 1 (minus_SNo c))) HyB). }
claim HyHi: Rle y (add_SNo 1 (minus_SNo c)).
{ exact (andER (Rle (add_SNo (minus_SNo 1) c) y) (Rle y (add_SNo 1 (minus_SNo c))) HyB). }
claim HzB: Rle (minus_SNo (mul_SNo c one_third)) z /\ Rle z (mul_SNo c one_third).
{ exact (closed_interval_bounds (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third) z
         Hm_c13R Hc13R HzI). }
claim HzLo: Rle (minus_SNo (mul_SNo c one_third)) z.
{ exact (andEL (Rle (minus_SNo (mul_SNo c one_third)) z) (Rle z (mul_SNo c one_third)) HzB). }
claim HzHi: Rle z (mul_SNo c one_third).
{ exact (andER (Rle (minus_SNo (mul_SNo c one_third)) z) (Rle z (mul_SNo c one_third)) HzB). }
claim HsumR: add_SNo y z :e R.
{ exact (real_add_SNo y HyR z HzR). }
claim HsumS: SNo (add_SNo y z).
{ exact (real_SNo (add_SNo y z) HsumR). }

(** lower bound **)
set ylo := add_SNo (minus_SNo 1) c.
set zlo := minus_SNo (mul_SNo c one_third).
claim HyloR: ylo :e R.
{ exact (real_add_SNo (minus_SNo 1) Hm1R c HcR). }
claim HyloS: SNo ylo.
{ exact (real_SNo ylo HyloR). }
claim HzloR: zlo :e R.
{ exact Hm_c13R. }
claim HzloS: SNo zlo.
{ exact Hm_c13S. }
claim Hylzlo: Rle (add_SNo ylo zlo) (add_SNo ylo z).
{ exact (Rle_add_SNo_2 ylo zlo z HyloR HzloR HzR HzLo). }
claim Hylz: Rle (add_SNo ylo z) (add_SNo y z).
{ exact (Rle_add_SNo_1 ylo y z HyloR HyR HzR HyLo). }
claim Hylzlo2: Rle (add_SNo ylo zlo) (add_SNo y z).
{ exact (Rle_tra (add_SNo ylo zlo) (add_SNo ylo z) (add_SNo y z) Hylzlo Hylz). }
claim Hylo_zlo_eq:
  add_SNo ylo zlo = add_SNo (minus_SNo 1) (mul_SNo c two_thirds).
{ claim HyloDef: ylo = add_SNo (minus_SNo 1) c.
  { reflexivity. }
  claim HzloDef: zlo = minus_SNo (mul_SNo c one_third).
  { reflexivity. }
  rewrite HyloDef.
  rewrite HzloDef.
  claim HcmulEq: add_SNo c (minus_SNo (mul_SNo c one_third)) = mul_SNo c two_thirds.
  { claim H23eq: two_thirds = add_SNo 1 (minus_SNo one_third).
    { exact two_thirds_eq_1_minus_one_third. }
    rewrite H23eq.
    claim Hm13R: minus_SNo one_third :e R.
    { exact (real_minus_SNo one_third H13R). }
    claim Hm13S: SNo (minus_SNo one_third).
    { exact (SNo_minus_SNo one_third H13S). }
    rewrite (mul_SNo_distrL c 1 (minus_SNo one_third) HcS SNo_1 Hm13S).
    rewrite (mul_SNo_oneR c HcS) at 1.
    rewrite (mul_SNo_minus_distrR c one_third HcS H13S) at 1.
    reflexivity. }
  claim HyloS0: SNo (add_SNo (minus_SNo 1) c).
  { exact (SNo_add_SNo (minus_SNo 1) c Hm1S HcS). }
  claim HcmulS: SNo (add_SNo c (minus_SNo (mul_SNo c one_third))).
  { exact (SNo_add_SNo c (minus_SNo (mul_SNo c one_third)) HcS Hm_c13S). }
  rewrite <- (add_SNo_assoc (minus_SNo 1) c (minus_SNo (mul_SNo c one_third)) Hm1S HcS Hm_c13S) at 1.
  rewrite <- HcmulEq.
  reflexivity. }
claim HlowRle: Rle (add_SNo (minus_SNo 1) (mul_SNo c two_thirds)) (add_SNo y z).
{ rewrite <- Hylo_zlo_eq at 1.
  exact Hylzlo2. }

(** upper bound **)
set yhi := add_SNo 1 (minus_SNo c).
set zhi := mul_SNo c one_third.
claim HyhiR: yhi :e R.
{ exact (real_add_SNo 1 real_1 (minus_SNo c) HmcR). }
claim HyhiS: SNo yhi.
{ exact (real_SNo yhi HyhiR). }
claim HzhiR: zhi :e R.
{ exact Hc13R. }
claim HzhiS: SNo zhi.
{ exact Hc13S. }
claim Hyzhi: Rle (add_SNo y z) (add_SNo yhi z).
{ exact (Rle_add_SNo_1 y yhi z HyR HyhiR HzR HyHi). }
claim Hupper2: Rle (add_SNo yhi z) (add_SNo yhi zhi).
{ exact (Rle_add_SNo_2 yhi z zhi HyhiR HzR HzhiR HzHi). }
claim Hupper: Rle (add_SNo y z) (add_SNo yhi zhi).
{ exact (Rle_tra (add_SNo y z) (add_SNo yhi z) (add_SNo yhi zhi) Hyzhi Hupper2). }
claim Hyhi_zhi_eq:
  add_SNo yhi zhi = add_SNo 1 (minus_SNo (mul_SNo c two_thirds)).
{ claim HyhiDef: yhi = add_SNo 1 (minus_SNo c).
  { reflexivity. }
  claim HzhiDef: zhi = mul_SNo c one_third.
  { reflexivity. }
  rewrite HyhiDef.
  rewrite HzhiDef.
  claim HcmulEq: add_SNo c (minus_SNo (mul_SNo c one_third)) = mul_SNo c two_thirds.
  { claim H23eq: two_thirds = add_SNo 1 (minus_SNo one_third).
    { exact two_thirds_eq_1_minus_one_third. }
    rewrite H23eq.
    claim Hm13R: minus_SNo one_third :e R.
    { exact (real_minus_SNo one_third H13R). }
    claim Hm13S: SNo (minus_SNo one_third).
    { exact (SNo_minus_SNo one_third H13S). }
    rewrite (mul_SNo_distrL c 1 (minus_SNo one_third) HcS SNo_1 Hm13S).
    rewrite (mul_SNo_oneR c HcS) at 1.
    rewrite (mul_SNo_minus_distrR c one_third HcS H13S) at 1.
    reflexivity. }
  claim HcmulNegEq: minus_SNo (mul_SNo c two_thirds) = add_SNo (minus_SNo c) (mul_SNo c one_third).
  { rewrite <- HcmulEq at 1.
    claim HcmulS: SNo (add_SNo c (minus_SNo (mul_SNo c one_third))).
    { exact (SNo_add_SNo c (minus_SNo (mul_SNo c one_third)) HcS Hm_c13S). }
    claim HnegD: minus_SNo (add_SNo c (minus_SNo (mul_SNo c one_third))) =
      add_SNo (minus_SNo c) (minus_SNo (minus_SNo (mul_SNo c one_third))).
    { exact (minus_add_SNo_distr c (minus_SNo (mul_SNo c one_third)) HcS Hm_c13S). }
    rewrite HnegD.
    rewrite (minus_SNo_invol (mul_SNo c one_third) Hc13S) at 1.
    reflexivity. }
  rewrite <- (add_SNo_assoc 1 (minus_SNo c) (mul_SNo c one_third) SNo_1 HmcS Hc13S) at 1.
  rewrite <- HcmulNegEq at 1.
  reflexivity. }
claim HhiRle: Rle (add_SNo y z) (add_SNo 1 (minus_SNo (mul_SNo c two_thirds))).
{ rewrite <- Hyhi_zhi_eq at 1.
  exact Hupper. }

exact (closed_intervalI_of_Rle
  (add_SNo (minus_SNo 1) (mul_SNo c two_thirds))
  (add_SNo 1 (minus_SNo (mul_SNo c two_thirds)))
  (add_SNo y z)
  (real_add_SNo (minus_SNo 1) Hm1R (mul_SNo c two_thirds) Hc23R)
  (real_add_SNo 1 real_1 (minus_SNo (mul_SNo c two_thirds)) (real_minus_SNo (mul_SNo c two_thirds) Hc23R))
  HsumR
  HlowRle
  HhiRle).
Qed.

(** helper: negation reverses Rle **)
Theorem Rle_minus_contra : forall x y:set,
  Rle x y -> Rle (minus_SNo y) (minus_SNo x).
let x y.
assume Hxy: Rle x y.
prove Rle (minus_SNo y) (minus_SNo x).
claim HxR: x :e R.
{ exact (RleE_left x y Hxy). }
claim HyR: y :e R.
{ exact (RleE_right x y Hxy). }
claim Hnxlt: ~(Rlt y x).
{ exact (RleE_nlt x y Hxy). }
claim HmxR: minus_SNo x :e R.
{ exact (real_minus_SNo x HxR). }
claim HmyR: minus_SNo y :e R.
{ exact (real_minus_SNo y HyR). }
apply (RleI (minus_SNo y) (minus_SNo x) HmyR HmxR).
assume Hlt: Rlt (minus_SNo x) (minus_SNo y).
claim HltS: (minus_SNo x) < (minus_SNo y).
{ exact (RltE_lt (minus_SNo x) (minus_SNo y) Hlt). }
claim HxS: SNo x.
{ exact (real_SNo x HxR). }
claim HyS: SNo y.
{ exact (real_SNo y HyR). }
claim HmxS: SNo (minus_SNo x).
{ exact (SNo_minus_SNo x HxS). }
claim HmyS: SNo (minus_SNo y).
{ exact (SNo_minus_SNo y HyS). }
apply (SNoLt_trichotomy_or_impred x y HxS HyS False).
- assume Hxly: x < y.
  claim Hmyltmx: (minus_SNo y) < (minus_SNo x).
  { exact (minus_SNo_Lt_contra x y HxS HyS Hxly). }
  claim Hmxltmx: (minus_SNo x) < (minus_SNo x).
  { exact (SNoLt_tra (minus_SNo x) (minus_SNo y) (minus_SNo x) HmxS HmyS HmxS HltS Hmyltmx). }
  exact ((SNoLt_irref (minus_SNo x)) Hmxltmx).
- assume HxyEq: x = y.
  claim HnegEq: minus_SNo y = minus_SNo x.
  { rewrite HxyEq. reflexivity. }
  claim Hmxltmx: (minus_SNo x) < (minus_SNo x).
  { prove (minus_SNo x) < (minus_SNo x).
    rewrite <- HnegEq at 2.
    exact HltS. }
  exact ((SNoLt_irref (minus_SNo x)) Hmxltmx).
- assume Hyxlt: y < x.
  claim HyxRlt: Rlt y x.
  { exact (RltI y x HyR HxR Hyxlt). }
  exact (Hnxlt HyxRlt).
Qed.

(** helper for §35: -1 < -2/3 **)
Theorem Rlt_minus1_minus_two_thirds : Rlt (minus_SNo 1) (minus_SNo two_thirds).
prove Rlt (minus_SNo 1) (minus_SNo two_thirds).
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm23R: minus_SNo two_thirds :e R.
{ exact (real_minus_SNo two_thirds H23R). }
claim Hle23: Rle two_thirds 1.
{ exact (Rlt_implies_Rle two_thirds 1 Rlt_two_thirds_1). }
claim Hle: Rle (minus_SNo 1) (minus_SNo two_thirds).
{ exact (Rle_minus_contra two_thirds 1 Hle23). }
claim Hneq: ~(minus_SNo 1 = minus_SNo two_thirds).
{ assume Heq: minus_SNo 1 = minus_SNo two_thirds.
  claim Heq1: 1 = two_thirds.
  { claim Htmp: minus_SNo (minus_SNo 1) = minus_SNo (minus_SNo two_thirds).
    { rewrite Heq.
      reflexivity. }
    rewrite <- (minus_SNo_minus_SNo_real 1 real_1) at 1.
    rewrite <- (minus_SNo_minus_SNo_real two_thirds H23R).
    exact Htmp. }
  claim H11: Rlt 1 1.
  { rewrite Heq1 at 1.
    exact Rlt_two_thirds_1. }
  exact ((not_Rlt_sym 1 1 H11) H11). }
exact (Rle_neq_implies_Rlt (minus_SNo 1) (minus_SNo two_thirds) Hle Hneq).
Qed.

(** helper for §35: [-2/3,2/3] is contained in (-1,1) **)
Theorem closed_interval_minus_two_thirds_two_thirds_Subq_open_interval_minus1_1 :
  closed_interval (minus_SNo two_thirds) two_thirds c= open_interval (minus_SNo 1) 1.
let x. assume Hx: x :e closed_interval (minus_SNo two_thirds) two_thirds.
prove x :e open_interval (minus_SNo 1) 1.
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim Hm23R: minus_SNo two_thirds :e R.
{ exact (real_minus_SNo two_thirds H23R). }
claim HxR: x :e R.
{ exact (closed_interval_sub_R (minus_SNo two_thirds) two_thirds x Hx). }
claim Hbounds: Rle (minus_SNo two_thirds) x /\ Rle x two_thirds.
{ exact (closed_interval_bounds (minus_SNo two_thirds) two_thirds x Hm23R H23R Hx). }
claim Hm23_le_x: Rle (minus_SNo two_thirds) x.
{ exact (andEL (Rle (minus_SNo two_thirds) x) (Rle x two_thirds) Hbounds). }
claim Hx_le_23: Rle x two_thirds.
{ exact (andER (Rle (minus_SNo two_thirds) x) (Rle x two_thirds) Hbounds). }
claim Hlt1: Rlt (minus_SNo 1) x.
{ exact (Rlt_Rle_tra (minus_SNo 1) (minus_SNo two_thirds) x
                      Rlt_minus1_minus_two_thirds Hm23_le_x). }
claim Hlt2: Rlt x 1.
{ exact (Rle_Rlt_tra x two_thirds 1 Hx_le_23 Rlt_two_thirds_1). }
claim Hdef: open_interval (minus_SNo 1) 1 = {z :e R|Rlt (minus_SNo 1) z /\ Rlt z 1}.
{ reflexivity. }
rewrite Hdef.
apply (SepI R (fun z:set => Rlt (minus_SNo 1) z /\ Rlt z 1) x HxR).
exact (andI (Rlt (minus_SNo 1) x) (Rlt x 1) Hlt1 Hlt2).
Qed.

(** helper for §35: scaling [-1,1] by two_thirds lands in [-2/3,2/3] **)
Theorem mul_two_thirds_closed_interval_minus1_1 : forall t:set,
  t :e closed_interval (minus_SNo 1) 1 ->
  mul_SNo t two_thirds :e closed_interval (minus_SNo two_thirds) two_thirds.
let t. assume HtI: t :e closed_interval (minus_SNo 1) 1.
prove mul_SNo t two_thirds :e closed_interval (minus_SNo two_thirds) two_thirds.
claim Hm1R: (minus_SNo 1) :e R.
{ exact (real_minus_SNo 1 real_1). }
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim Hm23R: (minus_SNo two_thirds) :e R.
{ exact (real_minus_SNo two_thirds H23R). }
claim HtR: t :e R.
{ exact (closed_interval_sub_R (minus_SNo 1) 1 t HtI). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
claim Hbounds: Rle (minus_SNo 1) t /\ Rle t 1.
{ exact (closed_interval_bounds (minus_SNo 1) 1 t Hm1R real_1 HtI). }
claim HloRle: Rle (minus_SNo 1) t.
{ exact (andEL (Rle (minus_SNo 1) t) (Rle t 1) Hbounds). }
claim HhiRle: Rle t 1.
{ exact (andER (Rle (minus_SNo 1) t) (Rle t 1) Hbounds). }
claim Hnot_lt_lo: ~(t < (minus_SNo 1)).
{ assume Hlt: t < (minus_SNo 1).
  claim Hrlt: Rlt t (minus_SNo 1).
  { exact (RltI t (minus_SNo 1) HtR Hm1R Hlt). }
  exact ((RleE_nlt (minus_SNo 1) t HloRle) Hrlt). }
claim Hnot_lt_hi: ~(1 < t).
{ assume Hlt: 1 < t.
  claim Hrlt: Rlt 1 t.
  { exact (RltI 1 t real_1 HtR Hlt). }
  exact ((RleE_nlt t 1 HhiRle) Hrlt). }
claim Hm1_le_t: (minus_SNo 1) <= t.
{ apply (SNoLtLe_or t (minus_SNo 1) HtS Hm1S).
  - assume Hlt: t < (minus_SNo 1).
    exact (FalseE (Hnot_lt_lo Hlt) ((minus_SNo 1) <= t)).
  - assume Hle: (minus_SNo 1) <= t.
    exact Hle. }
claim Ht_le_1: t <= 1.
{ apply (SNoLtLe_or 1 t SNo_1 HtS).
  - assume Hlt: 1 < t.
    exact (FalseE (Hnot_lt_hi Hlt) (t <= 1)).
  - assume Hle: t <= 1.
    exact Hle. }
claim H23pos: 0 < two_thirds.
{ exact two_thirds_pos. }
claim H0le_23: 0 <= two_thirds.
{ exact (SNoLtLe 0 two_thirds H23pos). }
claim HmulR: mul_SNo t two_thirds :e R.
{ exact (real_mul_SNo t HtR two_thirds H23R). }
claim HmulS: SNo (mul_SNo t two_thirds).
{ exact (real_SNo (mul_SNo t two_thirds) HmulR). }
claim HloLe: mul_SNo (minus_SNo 1) two_thirds <= mul_SNo t two_thirds.
{ exact (nonneg_mul_SNo_Le' (minus_SNo 1) t two_thirds Hm1S HtS H23S H0le_23 Hm1_le_t). }
claim HhiLe: mul_SNo t two_thirds <= mul_SNo 1 two_thirds.
{ exact (nonneg_mul_SNo_Le' t 1 two_thirds HtS SNo_1 H23S H0le_23 Ht_le_1). }
claim HloR: mul_SNo (minus_SNo 1) two_thirds :e R.
{ exact (real_mul_SNo (minus_SNo 1) Hm1R two_thirds H23R). }
claim HhiR: mul_SNo 1 two_thirds :e R.
{ exact (real_mul_SNo 1 real_1 two_thirds H23R). }
claim HloRle': Rle (mul_SNo (minus_SNo 1) two_thirds) (mul_SNo t two_thirds).
{ exact (Rle_of_SNoLe (mul_SNo (minus_SNo 1) two_thirds) (mul_SNo t two_thirds) HloR HmulR HloLe). }
claim HhiRle': Rle (mul_SNo t two_thirds) (mul_SNo 1 two_thirds).
{ exact (Rle_of_SNoLe (mul_SNo t two_thirds) (mul_SNo 1 two_thirds) HmulR HhiR HhiLe). }
claim HloEq: mul_SNo (minus_SNo 1) two_thirds = (minus_SNo two_thirds).
{ rewrite (mul_SNo_minus_distrL 1 two_thirds SNo_1 H23S) at 1.
  rewrite (mul_SNo_oneL two_thirds H23S) at 1.
  reflexivity. }
claim HhiEq: mul_SNo 1 two_thirds = two_thirds.
{ exact (mul_SNo_oneL two_thirds H23S). }
claim Hm23le: Rle (minus_SNo two_thirds) (mul_SNo t two_thirds).
{ rewrite <- HloEq at 1.
  exact HloRle'. }
claim Hle23: Rle (mul_SNo t two_thirds) two_thirds.
{ rewrite <- HhiEq at 2.
  exact HhiRle'. }
exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds (mul_SNo t two_thirds)
       Hm23R H23R HmulR
       Hm23le Hle23).
Qed.

(** helper for §35: scaling [-1,1] by a nonnegative real c lands in [-c,c] **)
(** LATEX VERSION: If t ∈ [-1,1] and c ≥ 0, then c·t ∈ [-c,c]. **)
Theorem mul_nonneg_closed_interval_minus1_1 : forall t c:set,
  t :e closed_interval (minus_SNo 1) 1 ->
  c :e R ->
  0 <= c ->
  mul_SNo t c :e closed_interval (minus_SNo c) c.
let t c.
assume HtI: t :e closed_interval (minus_SNo 1) 1.
assume HcR: c :e R.
assume H0leC: 0 <= c.
prove mul_SNo t c :e closed_interval (minus_SNo c) c.
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim HmcR: minus_SNo c :e R.
{ exact (real_minus_SNo c HcR). }
claim HtR: t :e R.
{ exact (closed_interval_sub_R (minus_SNo 1) 1 t HtI). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim Hm1S: SNo (minus_SNo 1).
{ exact (SNo_minus_SNo 1 SNo_1). }
claim Hbounds: Rle (minus_SNo 1) t /\ Rle t 1.
{ exact (closed_interval_bounds (minus_SNo 1) 1 t Hm1R real_1 HtI). }
claim HloRle: Rle (minus_SNo 1) t.
{ exact (andEL (Rle (minus_SNo 1) t) (Rle t 1) Hbounds). }
claim HhiRle: Rle t 1.
{ exact (andER (Rle (minus_SNo 1) t) (Rle t 1) Hbounds). }
claim Hnot_lt_lo: ~(t < (minus_SNo 1)).
{ assume Hlt: t < (minus_SNo 1).
  claim Hrlt: Rlt t (minus_SNo 1).
  { exact (RltI t (minus_SNo 1) HtR Hm1R Hlt). }
  exact ((RleE_nlt (minus_SNo 1) t HloRle) Hrlt). }
claim Hnot_lt_hi: ~(1 < t).
{ assume Hlt: 1 < t.
  claim Hrlt: Rlt 1 t.
  { exact (RltI 1 t real_1 HtR Hlt). }
  exact ((RleE_nlt t 1 HhiRle) Hrlt). }
claim Hm1_le_t: (minus_SNo 1) <= t.
{ apply (SNoLtLe_or t (minus_SNo 1) HtS Hm1S).
  - assume Hlt: t < (minus_SNo 1).
    exact (FalseE (Hnot_lt_lo Hlt) ((minus_SNo 1) <= t)).
  - assume Hle: (minus_SNo 1) <= t.
    exact Hle. }
claim Ht_le_1: t <= 1.
{ apply (SNoLtLe_or 1 t SNo_1 HtS).
  - assume Hlt: 1 < t.
    exact (FalseE (Hnot_lt_hi Hlt) (t <= 1)).
  - assume Hle: t <= 1.
    exact Hle. }
claim HmulR: mul_SNo t c :e R.
{ exact (real_mul_SNo t HtR c HcR). }
claim HmulS: SNo (mul_SNo t c).
{ exact (real_SNo (mul_SNo t c) HmulR). }
claim HloLe: mul_SNo (minus_SNo 1) c <= mul_SNo t c.
{ exact (nonneg_mul_SNo_Le' (minus_SNo 1) t c Hm1S HtS HcS H0leC Hm1_le_t). }
claim HhiLe: mul_SNo t c <= mul_SNo 1 c.
{ exact (nonneg_mul_SNo_Le' t 1 c HtS SNo_1 HcS H0leC Ht_le_1). }
claim HloR: mul_SNo (minus_SNo 1) c :e R.
{ exact (real_mul_SNo (minus_SNo 1) Hm1R c HcR). }
claim HhiR: mul_SNo 1 c :e R.
{ exact (real_mul_SNo 1 real_1 c HcR). }
claim HloRle': Rle (mul_SNo (minus_SNo 1) c) (mul_SNo t c).
{ exact (Rle_of_SNoLe (mul_SNo (minus_SNo 1) c) (mul_SNo t c) HloR HmulR HloLe). }
claim HhiRle': Rle (mul_SNo t c) (mul_SNo 1 c).
{ exact (Rle_of_SNoLe (mul_SNo t c) (mul_SNo 1 c) HmulR HhiR HhiLe). }
claim HloEq: mul_SNo (minus_SNo 1) c = minus_SNo c.
{ rewrite (mul_SNo_minus_distrL 1 c SNo_1 HcS) at 1.
  rewrite (mul_SNo_oneL c HcS) at 1.
  reflexivity. }
claim HhiEq: mul_SNo 1 c = c.
{ exact (mul_SNo_oneL c HcS). }
claim Hmc_le: Rle (minus_SNo c) (mul_SNo t c).
{ rewrite <- HloEq at 1.
  exact HloRle'. }
claim Hle_c: Rle (mul_SNo t c) c.
{ rewrite <- HhiEq at 2.
  exact HhiRle'. }
exact (closed_intervalI_of_Rle (minus_SNo c) c (mul_SNo t c) HmcR HcR HmulR Hmc_le Hle_c).
Qed.

(** helper for §35: dividing [-2/3,2/3] by two_thirds lands in [-1,1] **)
Theorem div_two_thirds_closed_interval_minus_two_thirds_two_thirds : forall t:set,
  t :e closed_interval (minus_SNo two_thirds) two_thirds ->
  div_SNo t two_thirds :e closed_interval (minus_SNo 1) 1.
let t. assume HtI: t :e closed_interval (minus_SNo two_thirds) two_thirds.
prove div_SNo t two_thirds :e closed_interval (minus_SNo 1) 1.
claim H23R: two_thirds :e R.
{ exact two_thirds_in_R. }
claim H23S: SNo two_thirds.
{ exact (real_SNo two_thirds H23R). }
claim H23pos: 0 < two_thirds.
{ exact two_thirds_pos. }
claim HtR: t :e R.
{ exact (closed_interval_sub_R (minus_SNo two_thirds) two_thirds t HtI). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
set u := div_SNo t two_thirds.
claim HuS: SNo u.
{ claim HuEq: u = div_SNo t two_thirds.
  { reflexivity. }
  rewrite HuEq.
  exact (SNo_div_SNo t two_thirds HtS H23S). }
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim HuR: u :e R.
{ exact (real_div_SNo t HtR two_thirds H23R). }
claim HcasesCI: u :e closed_interval (minus_SNo 1) 1 \/ ~(u :e closed_interval (minus_SNo 1) 1).
{ exact (xm (u :e closed_interval (minus_SNo 1) 1)). }
apply HcasesCI.
- assume HuCI: u :e closed_interval (minus_SNo 1) 1.
  exact HuCI.
- assume Hnot: ~(u :e closed_interval (minus_SNo 1) 1).
  apply FalseE.
  claim Hcases: Rlt u (minus_SNo 1) \/ Rlt 1 u.
  { exact (closed_interval_not_mem_cases (minus_SNo 1) 1 u Hm1R real_1 HuR Hnot). }
  apply Hcases.
  - assume Hltm1: Rlt u (minus_SNo 1).
    claim Hltm1S: u < (minus_SNo 1).
    { exact (RltE_lt u (minus_SNo 1) Hltm1). }
    claim Hm1S: SNo (minus_SNo 1).
    { exact (SNo_minus_SNo 1 SNo_1). }
    claim HmulLtS: mul_SNo u two_thirds < mul_SNo (minus_SNo 1) two_thirds.
    { exact (pos_mul_SNo_Lt' u (minus_SNo 1) two_thirds HuS Hm1S H23S H23pos Hltm1S). }
    claim HmulLtS2: mul_SNo two_thirds u < mul_SNo (minus_SNo 1) two_thirds.
    { rewrite <- (mul_SNo_com u two_thirds HuS H23S) at 1.
      exact HmulLtS. }
    claim H23ne0: two_thirds <> 0.
    { exact two_thirds_ne0. }
    claim HmulEq: mul_SNo two_thirds u = t.
    { claim HtuEq: u = div_SNo t two_thirds.
      { reflexivity. }
      rewrite HtuEq.
      exact (mul_div_SNo_invR t two_thirds HtS H23S H23ne0). }
    claim Hm1mulEq: mul_SNo (minus_SNo 1) two_thirds = minus_SNo two_thirds.
    { rewrite (mul_SNo_minus_distrL 1 two_thirds SNo_1 H23S).
      rewrite (mul_SNo_oneL two_thirds H23S).
      reflexivity. }
    claim HtLtS: t < minus_SNo two_thirds.
    { rewrite <- HmulEq at 1.
      rewrite <- Hm1mulEq.
      exact HmulLtS2. }
    claim HtLt: Rlt t (minus_SNo two_thirds).
    { exact (RltI t (minus_SNo two_thirds) HtR (real_minus_SNo two_thirds H23R) HtLtS). }
    claim Hbounds: Rle (minus_SNo two_thirds) t /\ Rle t two_thirds.
    { exact (closed_interval_bounds (minus_SNo two_thirds) two_thirds t
             (real_minus_SNo two_thirds H23R) H23R HtI). }
    claim Hm23le_t: Rle (minus_SNo two_thirds) t.
    { exact (andEL (Rle (minus_SNo two_thirds) t) (Rle t two_thirds) Hbounds). }
    exact ((RleE_nlt (minus_SNo two_thirds) t Hm23le_t) HtLt).
  - assume Hu1lt: Rlt 1 u.
    claim Hu1ltS: 1 < u.
    { exact (RltE_lt 1 u Hu1lt). }
    claim H1S: SNo 1.
    { exact SNo_1. }
    claim HmulLtS: mul_SNo 1 two_thirds < mul_SNo u two_thirds.
    { exact (pos_mul_SNo_Lt' 1 u two_thirds H1S HuS H23S H23pos Hu1ltS). }
    claim H23ne0: two_thirds <> 0.
    { exact two_thirds_ne0. }
    claim HmulEq: mul_SNo two_thirds u = t.
    { claim HtuEq: u = div_SNo t two_thirds.
      { reflexivity. }
      rewrite HtuEq.
      exact (mul_div_SNo_invR t two_thirds HtS H23S H23ne0). }
    claim H1mulEq: mul_SNo 1 two_thirds = two_thirds.
    { exact (mul_SNo_oneL two_thirds H23S). }
    claim HmulLtS2: mul_SNo 1 two_thirds < mul_SNo two_thirds u.
    { rewrite <- (mul_SNo_com u two_thirds HuS H23S).
      exact HmulLtS. }
    claim HtGtS: two_thirds < t.
    { rewrite <- H1mulEq at 1.
      rewrite <- HmulEq.
      exact HmulLtS2. }
    claim HtGt: Rlt two_thirds t.
    { exact (RltI two_thirds t H23R HtR HtGtS). }
    claim Hbounds: Rle (minus_SNo two_thirds) t /\ Rle t two_thirds.
    { exact (closed_interval_bounds (minus_SNo two_thirds) two_thirds t
             (real_minus_SNo two_thirds H23R) H23R HtI). }
    claim Ht_le_23: Rle t two_thirds.
    { exact (andER (Rle (minus_SNo two_thirds) t) (Rle t two_thirds) Hbounds). }
    exact ((RleE_nlt t two_thirds Ht_le_23) HtGt).
Qed.

(** helper for §35 Step I: the subinterval pieces are closed in [-1,1] (as a subspace) **)
Theorem Tietze_I1_closed_in_I : 
  closed_in (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
    ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)).
prove closed_in (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
  ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)).
claim HdefR: R = real.
{ reflexivity. }
claim Hm1real: (minus_SNo 1) :e real.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1R: (minus_SNo 1) :e R.
{ rewrite HdefR at 1.
  exact Hm1real. }
claim H1R: 1 :e R.
{ rewrite HdefR at 1.
  exact real_1. }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
claim H13real: one_third :e real.
{ rewrite <- HdefR at 1.
  exact H13R. }
claim Hm13real: (minus_SNo one_third) :e real.
{ exact (real_minus_SNo one_third H13real). }
claim Hm13R: (minus_SNo one_third) :e R.
{ rewrite HdefR at 1.
  exact Hm13real. }
exact (closed_interval_closed_in_closed_interval_topology (minus_SNo 1) 1 (minus_SNo 1) (minus_SNo one_third)
         Hm1R H1R Hm1R Hm13R).
Qed.

Theorem Tietze_I3_closed_in_I :
  closed_in (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
    ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)).
prove closed_in (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
  ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)).
claim HdefR: R = real.
{ reflexivity. }
claim Hm1real: (minus_SNo 1) :e real.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1R: (minus_SNo 1) :e R.
{ rewrite HdefR at 1.
  exact Hm1real. }
claim H1R: 1 :e R.
{ rewrite HdefR at 1.
  exact real_1. }
claim H13R: one_third :e R.
{ exact one_third_in_R. }
exact (closed_interval_closed_in_closed_interval_topology (minus_SNo 1) 1 one_third 1
         Hm1R H1R H13R H1R).
Qed.

(** helper for §35 Step I: preimages of the subinterval pieces are closed in X **)
Theorem Tietze_stepI_BC_closed_in_X : forall X Tx A f:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f ->
  closed_in X Tx (preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)))
  /\
  closed_in X Tx (preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HAcl: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f.
prove closed_in X Tx (preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)))
  /\ closed_in X Tx (preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))).
set I := closed_interval (minus_SNo 1) 1.
set Ti := closed_interval_topology (minus_SNo 1) 1.
set I1 := (closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I.
set I3 := (closed_interval one_third 1) :/\: I.
claim HI1closed: closed_in I Ti I1.
{ exact Tietze_I1_closed_in_I. }
claim HI3closed: closed_in I Ti I3.
{ exact Tietze_I3_closed_in_I. }
claim HBclosedA: closed_in A (subspace_topology X Tx A) (preimage_of A f I1).
{ exact (continuous_preserves_closed A (subspace_topology X Tx A) I Ti f Hf I1 HI1closed). }
claim HCclosedA: closed_in A (subspace_topology X Tx A) (preimage_of A f I3).
{ exact (continuous_preserves_closed A (subspace_topology X Tx A) I Ti f Hf I3 HI3closed). }
apply andI.
- exact (ex17_2_closed_in_closed_subspace X Tx A (preimage_of A f I1) HAcl HBclosedA).
- exact (ex17_2_closed_in_closed_subspace X Tx A (preimage_of A f I3) HAcl HCclosedA).
Qed.

(** helper for §35 Step I: the two Step I subinterval pieces are disjoint **)
Theorem Tietze_I1_I3_disjoint :
  ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
    :/\:
  ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))
    = Empty.
prove
  ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
    :/\:
  ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))
    = Empty.
apply set_ext.
- let x.
  assume Hx:
    x :e
      ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
        :/\:
      ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)).
  prove x :e Empty.
  claim HxI1:
    x :e (closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1).
  { exact (binintersectE1
      ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
      ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))
      x Hx). }
  claim HxI3:
    x :e (closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1).
  { exact (binintersectE2
      ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
      ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))
      x Hx). }
  claim HxLo: x :e closed_interval (minus_SNo 1) (minus_SNo one_third).
  { exact (binintersectE1
      (closed_interval (minus_SNo 1) (minus_SNo one_third))
      (closed_interval (minus_SNo 1) 1)
      x HxI1). }
  claim HxHi: x :e closed_interval one_third 1.
  { exact (binintersectE1
      (closed_interval one_third 1)
      (closed_interval (minus_SNo 1) 1)
      x HxI3). }

  claim HLo_def:
    closed_interval (minus_SNo 1) (minus_SNo one_third) =
      {t :e R | ~(Rlt t (minus_SNo 1)) /\ ~(Rlt (minus_SNo one_third) t)}.
  { reflexivity. }
  claim HxLo': x :e {t :e R | ~(Rlt t (minus_SNo 1)) /\ ~(Rlt (minus_SNo one_third) t)}.
  { rewrite <- HLo_def. exact HxLo. }
  claim HxR: x :e R.
  { exact (SepE1 R (fun t:set => ~(Rlt t (minus_SNo 1)) /\ ~(Rlt (minus_SNo one_third) t)) x HxLo'). }
  claim HxLoConj: ~(Rlt x (minus_SNo 1)) /\ ~(Rlt (minus_SNo one_third) x).
  { exact (SepE2 R (fun t:set => ~(Rlt t (minus_SNo 1)) /\ ~(Rlt (minus_SNo one_third) t)) x HxLo'). }
  claim Hnlt_m13_x: ~(Rlt (minus_SNo one_third) x).
  { exact (andER (~(Rlt x (minus_SNo 1))) (~(Rlt (minus_SNo one_third) x)) HxLoConj). }

  claim HHi_def:
    closed_interval one_third 1 =
      {t :e R | ~(Rlt t one_third) /\ ~(Rlt 1 t)}.
  { reflexivity. }
  claim HxHi': x :e {t :e R | ~(Rlt t one_third) /\ ~(Rlt 1 t)}.
  { rewrite <- HHi_def. exact HxHi. }
  claim HxHiConj: ~(Rlt x one_third) /\ ~(Rlt 1 x).
  { exact (SepE2 R (fun t:set => ~(Rlt t one_third) /\ ~(Rlt 1 t)) x HxHi'). }
  claim Hnlt_x_13: ~(Rlt x one_third).
  { exact (andEL (~(Rlt x one_third)) (~(Rlt 1 x)) HxHiConj). }

  claim H13R: one_third :e R.
  { exact one_third_in_R. }
  claim Hm13R: (minus_SNo one_third) :e R.
  { exact (real_minus_SNo one_third H13R). }
  claim H13lex: Rle one_third x.
  { exact (RleI one_third x H13R HxR Hnlt_x_13). }
  claim Hxlem13: Rle x (minus_SNo one_third).
  { exact (RleI x (minus_SNo one_third) HxR Hm13R Hnlt_m13_x). }
  claim H13lem13: Rle one_third (minus_SNo one_third).
  { exact (Rle_tra one_third x (minus_SNo one_third) H13lex Hxlem13). }
  apply FalseE.
  exact ((RleE_nlt one_third (minus_SNo one_third) H13lem13) (Rlt_minus_one_third_one_third)).
- let x. assume Hx: x :e Empty.
  prove x :e
    ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
      :/\:
    ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)).
  apply FalseE.
  exact ((EmptyE x) Hx).
Qed.

(** helper for §35 Step I: apply Urysohn lemma to the B,C preimages **)
Theorem Tietze_stepI_g_exists : forall X Tx A f:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f ->
  exists g:set,
    continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g /\
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g x = minus_SNo one_third) /\
    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g x = one_third).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HAcl: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f.
prove exists g:set,
  continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g /\
  (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g x = minus_SNo one_third) /\
  (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g x = one_third).
set B := preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)).
set C := preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)).
claim HBCclosed: closed_in X Tx B /\ closed_in X Tx C.
{ exact (Tietze_stepI_BC_closed_in_X X Tx A f Hnorm HAcl Hf). }
claim HBcl: closed_in X Tx B.
{ exact (andEL (closed_in X Tx B) (closed_in X Tx C) HBCclosed). }
claim HCcl: closed_in X Tx C.
{ exact (andER (closed_in X Tx B) (closed_in X Tx C) HBCclosed). }
claim Hdisj: B :/\: C = Empty.
{ rewrite <- (preimage_of_binintersect A f
    ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1))
    ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1))).
  rewrite Tietze_I1_I3_disjoint.
  exact (preimage_of_Empty A f). }
claim Hm13le13: Rle (minus_SNo one_third) one_third.
{ exact Rle_minus_one_third_one_third. }
exact (Urysohn_lemma X Tx B C (minus_SNo one_third) one_third Hm13le13 Hnorm HBcl HCcl Hdisj).
Qed.

(** helper for §35 Step II: add_fun_R after pair_map evaluates pointwise **)
Theorem add_of_pair_map_apply : forall A f g a:set,
  a :e A ->
  apply_fun f a :e R ->
  apply_fun g a :e R ->
  apply_fun (compose_fun A (pair_map A f g) add_fun_R) a = add_SNo (apply_fun f a) (apply_fun g a).
let A f g a.
assume Ha: a :e A.
assume HfaR: apply_fun f a :e R.
assume HgaR: apply_fun g a :e R.
prove apply_fun (compose_fun A (pair_map A f g) add_fun_R) a = add_SNo (apply_fun f a) (apply_fun g a).
rewrite (compose_fun_apply A (pair_map A f g) add_fun_R a Ha).
rewrite (pair_map_apply A R R f g a Ha) at 1.
claim HpRR: (apply_fun f a, apply_fun g a) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun f a) (apply_fun g a) HfaR HgaR). }
rewrite (add_fun_R_apply (apply_fun f a, apply_fun g a) HpRR).
rewrite (tuple_2_0_eq (apply_fun f a) (apply_fun g a)) at 1.
	rewrite (tuple_2_1_eq (apply_fun f a) (apply_fun g a)) at 1.
	reflexivity.
	Qed.

	(** helper for §35 Step II: add_fun_R after pair_map with negated second component **)
		Theorem add_of_pair_map_neg_apply : forall A f g a:set,
		  a :e A ->
		  apply_fun f a :e R ->
		  apply_fun g a :e R ->
		  apply_fun (compose_fun A (pair_map A f (compose_fun A g neg_fun)) add_fun_R) a =
		    add_SNo (apply_fun f a) (minus_SNo (apply_fun g a)).
	let A f g a.
	assume Ha: a :e A.
	assume HfaR: apply_fun f a :e R.
	assume HgaR: apply_fun g a :e R.
	prove apply_fun (compose_fun A (pair_map A f (compose_fun A g neg_fun)) add_fun_R) a =
	  add_SNo (apply_fun f a) (minus_SNo (apply_fun g a)).
	claim HgnegR: apply_fun (compose_fun A g neg_fun) a :e R.
	{ rewrite (compose_fun_apply A g neg_fun a Ha).
	  rewrite (neg_fun_apply (apply_fun g a) HgaR).
	  exact (real_minus_SNo (apply_fun g a) HgaR). }
	rewrite (add_of_pair_map_apply A f (compose_fun A g neg_fun) a Ha HfaR HgnegR).
	rewrite (compose_fun_apply A g neg_fun a Ha) at 1.
		rewrite (neg_fun_apply (apply_fun g a) HgaR) at 1.
		reflexivity.
		Qed.

		(** helper for §35 Step II: algebraic cancellation identity **)
		Theorem Tietze_stepII_algebra_tail : forall gx rx ux c:set,
		  SNo gx -> SNo rx -> SNo ux -> SNo c ->
		  add_SNo (add_SNo gx (mul_SNo ux c))
		    (mul_SNo (add_SNo rx (minus_SNo ux)) c)
		  = add_SNo gx (mul_SNo rx c).
		let gx rx ux c.
		assume HgxS: SNo gx.
		assume HrxS: SNo rx.
		assume HuxS: SNo ux.
		assume HcS: SNo c.
		prove add_SNo (add_SNo gx (mul_SNo ux c))
		  (mul_SNo (add_SNo rx (minus_SNo ux)) c)
		  = add_SNo gx (mul_SNo rx c).
		set uxc := mul_SNo ux c.
		set rxc := mul_SNo rx c.
		claim HuxcS: SNo uxc.
		{ exact (SNo_mul_SNo ux c HuxS HcS). }
		claim HrxcS: SNo rxc.
		{ exact (SNo_mul_SNo rx c HrxS HcS). }
		claim HmUxS: SNo (minus_SNo ux).
		{ exact (SNo_minus_SNo ux HuxS). }
		claim Hdistr: mul_SNo (add_SNo rx (minus_SNo ux)) c = add_SNo rxc (mul_SNo (minus_SNo ux) c).
		{ claim Hdistr0: mul_SNo (add_SNo rx (minus_SNo ux)) c =
		    add_SNo (mul_SNo rx c) (mul_SNo (minus_SNo ux) c).
		  { exact (mul_SNo_distrR rx (minus_SNo ux) c HrxS HmUxS HcS). }
		  claim HrxcDef: rxc = mul_SNo rx c.
		  { reflexivity. }
		  rewrite HrxcDef.
		  exact Hdistr0. }
		rewrite Hdistr.
		claim HmUxC: mul_SNo (minus_SNo ux) c = minus_SNo uxc.
		{ claim HmUxC0: mul_SNo (minus_SNo ux) c = minus_SNo (mul_SNo ux c).
		  { exact (mul_SNo_minus_distrL ux c HuxS HcS). }
		  rewrite HmUxC0.
		  claim HuxcDef: uxc = mul_SNo ux c.
		  { reflexivity. }
		  rewrite <- HuxcDef.
		  reflexivity. }
		rewrite HmUxC.
		claim HmUxcS: SNo (minus_SNo uxc).
		{ exact (SNo_minus_SNo uxc HuxcS). }
		claim Ht2S: SNo (add_SNo rxc (minus_SNo uxc)).
		{ exact (SNo_add_SNo rxc (minus_SNo uxc) HrxcS HmUxcS). }
		rewrite <- (add_SNo_assoc gx uxc (add_SNo rxc (minus_SNo uxc)) HgxS HuxcS Ht2S).
		rewrite (add_SNo_assoc uxc rxc (minus_SNo uxc) HuxcS HrxcS HmUxcS).
		rewrite (add_SNo_com uxc rxc HuxcS HrxcS) at 1.
		rewrite (add_SNo_minus_R2 rxc uxc HrxcS HuxcS) at 1.
		reflexivity.
		Qed.
	
		(** helper for §35: -1 < 0 in R **)
		Theorem Rlt_minus1_0 : Rlt (minus_SNo 1) 0.
		prove Rlt (minus_SNo 1) 0.
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0).
Qed.

(** helper for §35: 0 is in [-1,1] **)
Theorem zero_in_closed_interval_minus1_1 : 0 :e closed_interval (minus_SNo 1) 1.
prove 0 :e closed_interval (minus_SNo 1) 1.
claim Hm1R: (minus_SNo 1) :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm1le0: Rle (minus_SNo 1) 0.
{ exact (Rlt_implies_Rle (minus_SNo 1) 0 Rlt_minus1_0). }
claim H0le1: Rle 0 1.
{ exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
exact (closed_intervalI_of_Rle (minus_SNo 1) 1 0 Hm1R real_1 real_0 Hm1le0 H0le1).
Qed.

(** helper for §35 Step II: real-valued extension with range in [-1,1] **)
(** LATEX VERSION: Step 2 (core): extend f:A→(-1,1) by an infinite series of Urysohn functions; here packaged as existence of a continuous gR:X→R agreeing with f on A and mapping X into [-1,1]. **)
(** helper for §35 Step II: nonempty closed subset case, real-valued extension **)
(** LATEX VERSION: Step II (nonempty A): construct a real-valued continuous extension gR:X->R agreeing with f on A and bounded in [-1,1]. **)
Theorem Tietze_stepII_real_extension_nonempty : forall X Tx A f:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  A <> Empty ->
  continuous_map A (subspace_topology X Tx A)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f ->
  exists gR:set,
    continuous_map X Tx R R_standard_topology gR /\
    (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
    (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume HAnemp: A <> Empty.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f.
prove exists gR:set,
  continuous_map X Tx R R_standard_topology gR /\
  (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
  (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1).
(** TeX Step II series construction remains to be formalized. **)
set I := closed_interval (minus_SNo 1) 1.
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A HA). }
claim Hf_fun: function_on f A I.
{ exact (continuous_map_function_on A (subspace_topology X Tx A)
          I (closed_interval_topology (minus_SNo 1) 1) f Hf). }
claim Hf_R: function_on f A R.
{ let x. assume HxA: x :e A.
  claim HfxI: apply_fun f x :e I.
  { exact (Hf_fun x HxA). }
  exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun f x) HfxI). }

(** TeX Step II outline: obtain g0 by Step I, then iterate on residuals and take a uniformly convergent series. **)
set I0 := closed_interval (minus_SNo one_third) one_third.
set T0 := closed_interval_topology (minus_SNo one_third) one_third.
claim Hexg0:
  exists g0:set,
    continuous_map X Tx I0 T0 g0 /\
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
      apply_fun g0 x = minus_SNo one_third) /\
    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
      apply_fun g0 x = one_third).
{ exact (Tietze_stepI_g_exists X Tx A f Hnorm HA Hf). }
apply Hexg0.
let g0. assume Hg0.
claim Hg0contI0: continuous_map X Tx I0 T0 g0.
{ claim Hleft:
    continuous_map X Tx I0 T0 g0 /\
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
      apply_fun g0 x = minus_SNo one_third).
  { exact (andEL
      (continuous_map X Tx I0 T0 g0 /\
       (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
         apply_fun g0 x = minus_SNo one_third))
      (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
        apply_fun g0 x = one_third)
      Hg0). }
  exact (andEL
      (continuous_map X Tx I0 T0 g0)
      (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
        apply_fun g0 x = minus_SNo one_third)
      Hleft). }
claim Hg0contR: continuous_map X Tx R R_standard_topology g0.
{ claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
  { reflexivity. }
  exact (continuous_map_range_expand X Tx I0 T0 R R_standard_topology g0
    Hg0contI0
    (closed_interval_sub_R (minus_SNo one_third) one_third)
    R_standard_topology_is_topology_local
    HT0eq). }
(** Residual on A: f1 = f - g0|A. **)
set f1 := graph A (fun x:set => add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
claim Hfung0: function_on g0 X I0.
{ exact (continuous_map_function_on X Tx I0 T0 g0 Hg0contI0). }
	claim Hf1_total: total_function_on f1 A R.
	{ apply (total_function_on_graph A R (fun x:set => add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))).
	  let x. assume HxA: x :e A.
	  prove add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)) :e R.
	  claim HfxR: apply_fun f x :e R.
	  { exact (Hf_R x HxA). }
	  claim HgxI0: apply_fun g0 x :e I0.
	  { exact (Hfung0 x (HAsubX x HxA)). }
	  claim HgxR: apply_fun g0 x :e R.
	  { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) HgxI0). }
	  claim HmgxR: minus_SNo (apply_fun g0 x) :e R.
	  { exact (real_minus_SNo (apply_fun g0 x) HgxR). }
	  exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo (apply_fun g0 x)) HmgxR). }
	claim Hg0pair:
	  (continuous_map X Tx I0 T0 g0 /\
	   (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	     apply_fun g0 x = minus_SNo one_third))
	  /\
	  (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
	    apply_fun g0 x = one_third).
	{ exact Hg0. }
	claim Hg0_on_B:
	  forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	    apply_fun g0 x = minus_SNo one_third.
	{ claim Hleft:
	    continuous_map X Tx I0 T0 g0 /\
	    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	      apply_fun g0 x = minus_SNo one_third).
	  { exact (andEL
	      (continuous_map X Tx I0 T0 g0 /\
	       (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	         apply_fun g0 x = minus_SNo one_third))
	      (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
	        apply_fun g0 x = one_third)
	      Hg0pair). }
	  exact (andER
	      (continuous_map X Tx I0 T0 g0)
	      (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	        apply_fun g0 x = minus_SNo one_third)
	      Hleft). }
	claim Hg0_on_C:
	  forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
	    apply_fun g0 x = one_third.
	{ exact (andER
	    (continuous_map X Tx I0 T0 g0 /\
	     (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
	       apply_fun g0 x = minus_SNo one_third))
	    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: I) ->
	      apply_fun g0 x = one_third)
	    Hg0pair). }

	claim Hf1_apply: forall x:set, x :e A ->
	  apply_fun f1 x = add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)).
	{ let x. assume HxA: x :e A.
	  rewrite (apply_fun_graph A (fun x0:set => add_SNo (apply_fun f x0) (minus_SNo (apply_fun g0 x0))) x HxA).
	  reflexivity. }

	set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
	set I3 := closed_interval one_third 1.
	set I2 := closed_interval (minus_SNo two_thirds) two_thirds.
	set B := preimage_of A f (I1 :/\: I).
	set C := preimage_of A f (I3 :/\: I).

	claim Hf1_range: forall x:set, x :e A -> apply_fun f1 x :e I2.
	{ let x. assume HxA: x :e A.
	  claim HfxI: apply_fun f x :e I.
	  { exact (Hf_fun x HxA). }
	  claim HxX: x :e X.
	  { exact (HAsubX x HxA). }
	  apply (xm (x :e B)).
	  - assume HxB: x :e B.
	    claim Hg0eq: apply_fun g0 x = minus_SNo one_third.
	    { exact (Hg0_on_B x HxB). }
	    claim Hf1eq: apply_fun f1 x = add_SNo (apply_fun f x) one_third.
	    { rewrite (Hf1_apply x HxA).
	      rewrite Hg0eq at 1.
	      claim H13R: one_third :e R.
	      { exact one_third_in_R. }
	      rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
	      reflexivity. }
	    rewrite Hf1eq.
	    claim HfxI1I: apply_fun f x :e I1 :/\: I.
	    { exact (SepE2 A (fun x0:set => apply_fun f x0 :e I1 :/\: I) x HxB). }
	    claim HfxI1: apply_fun f x :e I1.
	    { exact (binintersectE1 I1 I (apply_fun f x) HfxI1I). }
	    claim H13R: one_third :e R.
	    { exact one_third_in_R. }
	    claim H23R: two_thirds :e R.
	    { exact two_thirds_in_R. }
	    claim Hm23R: minus_SNo two_thirds :e R.
	    { exact (real_minus_SNo two_thirds H23R). }
	    claim Hm1R: minus_SNo 1 :e R.
	    { exact (real_minus_SNo 1 real_1). }
	    claim Hm13R: minus_SNo one_third :e R.
	    { exact (real_minus_SNo one_third H13R). }
	    claim HfxR: apply_fun f x :e R.
	    { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun f x) HfxI1). }
	    claim Hfx_bounds: Rle (minus_SNo 1) (apply_fun f x) /\ Rle (apply_fun f x) (minus_SNo one_third).
	    { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun f x)
	                                   Hm1R Hm13R HfxI1). }
	    claim Hm1lefx: Rle (minus_SNo 1) (apply_fun f x).
	    { exact (andEL (Rle (minus_SNo 1) (apply_fun f x))
	                   (Rle (apply_fun f x) (minus_SNo one_third)) Hfx_bounds). }
	    claim Hfxlem13: Rle (apply_fun f x) (minus_SNo one_third).
	    { exact (andER (Rle (minus_SNo 1) (apply_fun f x))
	                   (Rle (apply_fun f x) (minus_SNo one_third)) Hfx_bounds). }
	    claim Hf1R: add_SNo (apply_fun f x) one_third :e R.
	    { exact (real_add_SNo (apply_fun f x) HfxR one_third H13R). }
	    claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun f x) one_third).
	    { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun f x) one_third Hm1R HfxR H13R Hm1lefx). }
	    claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) one_third).
	    { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
	      exact Hlow_tmp. }
	    claim Hup0_tmp: Rle (add_SNo (apply_fun f x) one_third) (add_SNo (minus_SNo one_third) one_third).
	    { exact (Rle_add_SNo_1 (apply_fun f x) (minus_SNo one_third) one_third HfxR Hm13R H13R Hfxlem13). }
	    claim H13S: SNo one_third.
	    { exact (real_SNo one_third H13R). }
	    claim Hup0: Rle (add_SNo (apply_fun f x) one_third) 0.
	    { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
	      exact Hup0_tmp. }
	    claim H0le23: Rle 0 two_thirds.
	    { exact Rle_0_two_thirds. }
	    claim Hup: Rle (add_SNo (apply_fun f x) one_third) two_thirds.
	    { exact (Rle_tra (add_SNo (apply_fun f x) one_third) 0 two_thirds Hup0 H0le23). }
	    exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds (add_SNo (apply_fun f x) one_third)
	                                  Hm23R H23R Hf1R Hlow Hup).
	  - assume HxnotB: ~(x :e B).
	    apply (xm (x :e C)).
	    + assume HxC: x :e C.
	      claim Hg0eq: apply_fun g0 x = one_third.
	      { exact (Hg0_on_C x HxC). }
	      claim Hf1eq: apply_fun f1 x = add_SNo (apply_fun f x) (minus_SNo one_third).
	      { rewrite (Hf1_apply x HxA).
	        rewrite Hg0eq at 1.
	        reflexivity. }
	      rewrite Hf1eq.
	      claim HfxI3I: apply_fun f x :e I3 :/\: I.
	      { exact (SepE2 A (fun x0:set => apply_fun f x0 :e I3 :/\: I) x HxC). }
	      claim HfxI3: apply_fun f x :e I3.
	      { exact (binintersectE1 I3 I (apply_fun f x) HfxI3I). }
	      claim H13R: one_third :e R.
	      { exact one_third_in_R. }
	      claim H23R: two_thirds :e R.
	      { exact two_thirds_in_R. }
	      claim Hm23R: minus_SNo two_thirds :e R.
	      { exact (real_minus_SNo two_thirds H23R). }
	      claim Hm13R: minus_SNo one_third :e R.
	      { exact (real_minus_SNo one_third H13R). }
	      claim HfxR: apply_fun f x :e R.
	      { exact (closed_interval_sub_R one_third 1 (apply_fun f x) HfxI3). }
	      claim Hfx_bounds: Rle one_third (apply_fun f x) /\ Rle (apply_fun f x) 1.
	      { exact (closed_interval_bounds one_third 1 (apply_fun f x) H13R real_1 HfxI3). }
	      claim H13lefx: Rle one_third (apply_fun f x).
	      { exact (andEL (Rle one_third (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds). }
	      claim Hfxle1: Rle (apply_fun f x) 1.
	      { exact (andER (Rle one_third (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds). }
	      claim Hf1R: add_SNo (apply_fun f x) (minus_SNo one_third) :e R.
	      { exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo one_third) Hm13R). }
	      claim H0le_f1_tmp: Rle (add_SNo one_third (minus_SNo one_third))
	                             (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 one_third (apply_fun f x) (minus_SNo one_third) H13R HfxR Hm13R H13lefx). }
	      claim H13S: SNo one_third.
	      { exact (real_SNo one_third H13R). }
	      claim H0le_f1: Rle 0 (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
	        exact H0le_f1_tmp. }
	      claim Hm23le0: Rle (minus_SNo two_thirds) 0.
	      { exact Rle_minus_two_thirds_0. }
	      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_tra (minus_SNo two_thirds) 0 (add_SNo (apply_fun f x) (minus_SNo one_third)) Hm23le0 H0le_f1). }
	      claim Hup_tmp: Rle (add_SNo (apply_fun f x) (minus_SNo one_third))
	                           (add_SNo 1 (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 (apply_fun f x) 1 (minus_SNo one_third) HfxR real_1 Hm13R Hfxle1). }
	      claim Hup: Rle (add_SNo (apply_fun f x) (minus_SNo one_third)) two_thirds.
	      { rewrite two_thirds_eq_1_minus_one_third at 1.
	        exact Hup_tmp. }
	      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
	                                     (add_SNo (apply_fun f x) (minus_SNo one_third))
	                                     Hm23R H23R Hf1R Hlow Hup).
	    + assume HxnotC: ~(x :e C).
	      claim HnotI1: ~(apply_fun f x :e I1).
	      { assume HfxI1: apply_fun f x :e I1.
	        claim HfxI1I: apply_fun f x :e I1 :/\: I.
	        { exact (binintersectI I1 I (apply_fun f x) HfxI1 HfxI). }
	        claim HxB': x :e B.
	        { exact (SepI A (fun x0:set => apply_fun f x0 :e I1 :/\: I) x HxA HfxI1I). }
	        apply FalseE.
	        exact (HxnotB HxB'). }
	      claim HnotI3: ~(apply_fun f x :e I3).
	      { assume HfxI3: apply_fun f x :e I3.
	        claim HfxI3I: apply_fun f x :e I3 :/\: I.
	        { exact (binintersectI I3 I (apply_fun f x) HfxI3 HfxI). }
	        claim HxC': x :e C.
	        { exact (SepI A (fun x0:set => apply_fun f x0 :e I3 :/\: I) x HxA HfxI3I). }
	        apply FalseE.
	        exact (HxnotC HxC'). }
	      claim HfxR: apply_fun f x :e R.
	      { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun f x) HfxI). }
	      claim Hm1R: (minus_SNo 1) :e R.
	      { exact (real_minus_SNo 1 real_1). }
	      claim H13R: one_third :e R.
	      { exact one_third_in_R. }
	      claim Hm13R: (minus_SNo one_third) :e R.
	      { exact (real_minus_SNo one_third H13R). }
	      claim Hfx_bounds: Rle (minus_SNo 1) (apply_fun f x) /\ Rle (apply_fun f x) 1.
	      { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun f x) Hm1R real_1 HfxI). }
	      claim Hnlt_fx_m1: ~(Rlt (apply_fun f x) (minus_SNo 1)).
	      { exact (RleE_nlt (minus_SNo 1) (apply_fun f x)
	                        (andEL (Rle (minus_SNo 1) (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds)). }
	      claim Hnlt_1_fx: ~(Rlt 1 (apply_fun f x)).
	      { exact (RleE_nlt (apply_fun f x) 1
	                        (andER (Rle (minus_SNo 1) (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds)). }
	      claim HnotI1_cases: Rlt (apply_fun f x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun f x).
	      { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun f x)
	                                            Hm1R Hm13R HfxR HnotI1). }
	      claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun f x).
	      { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun f x))).
	        - assume Hbad: Rlt (apply_fun f x) (minus_SNo 1).
	          apply FalseE.
	          exact (Hnlt_fx_m1 Hbad).
	        - assume Hok: Rlt (minus_SNo one_third) (apply_fun f x).
	          exact Hok. }
	      claim Hnot_fx_lt_m13: ~(Rlt (apply_fun f x) (minus_SNo one_third)).
	      { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun f x) Hm13lt_fx). }
	      claim HnotI3_cases: Rlt (apply_fun f x) one_third \/ Rlt 1 (apply_fun f x).
	      { exact (closed_interval_not_mem_cases one_third 1 (apply_fun f x)
	                                            H13R real_1 HfxR HnotI3). }
	      claim Hfx_lt_13: Rlt (apply_fun f x) one_third.
	      { apply (HnotI3_cases (Rlt (apply_fun f x) one_third)).
	        - assume Hok: Rlt (apply_fun f x) one_third.
	          exact Hok.
	        - assume Hbad: Rlt 1 (apply_fun f x).
	          apply FalseE.
	          exact (Hnlt_1_fx Hbad). }
	      claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun f x)).
	      { exact (not_Rlt_sym (apply_fun f x) one_third Hfx_lt_13). }
	      claim HfxI0: apply_fun f x :e I0.
	      { claim HI0_def:
	          I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
	        { reflexivity. }
	        claim HxSep: apply_fun f x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
	        { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
	                      (apply_fun f x) HfxR (andI (~(Rlt (apply_fun f x) (minus_SNo one_third)))
	                                                 (~(Rlt one_third (apply_fun f x)))
	                                                 Hnot_fx_lt_m13
	                                                 Hnot_13_lt_fx)). }
	        rewrite HI0_def.
	        exact HxSep. }
	      rewrite (Hf1_apply x HxA).
	      claim Hg0xI0: apply_fun g0 x :e I0.
	      { exact (Hfung0 x HxX). }
	      claim Hg0xR: apply_fun g0 x :e R.
	      { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0xI0). }
	      claim Hm_g0x_R: minus_SNo (apply_fun g0 x) :e R.
	      { exact (real_minus_SNo (apply_fun g0 x) Hg0xR). }
	      claim Hf1xR: add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)) :e R.
	      { exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo (apply_fun g0 x)) Hm_g0x_R). }
	      claim Hm13R: (minus_SNo one_third) :e R.
	      { exact (real_minus_SNo one_third H13R). }
	      claim H23R: two_thirds :e R.
	      { exact two_thirds_in_R. }
	      claim Hm23R: (minus_SNo two_thirds) :e R.
	      { exact (real_minus_SNo two_thirds H23R). }
	      claim Hfx0_bounds: Rle (minus_SNo one_third) (apply_fun f x) /\ Rle (apply_fun f x) one_third.
	      { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun f x) Hm13R H13R HfxI0). }
	      claim Hg0x_bounds: Rle (minus_SNo one_third) (apply_fun g0 x) /\ Rle (apply_fun g0 x) one_third.
	      { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun g0 x) Hm13R H13R Hg0xI0). }
	      claim Hm13_le_fx: Rle (minus_SNo one_third) (apply_fun f x).
	      { exact (andEL (Rle (minus_SNo one_third) (apply_fun f x)) (Rle (apply_fun f x) one_third) Hfx0_bounds). }
	      claim Hfx_le_13: Rle (apply_fun f x) one_third.
	      { exact (andER (Rle (minus_SNo one_third) (apply_fun f x)) (Rle (apply_fun f x) one_third) Hfx0_bounds). }
	      claim Hm13_le_g0x: Rle (minus_SNo one_third) (apply_fun g0 x).
	      { exact (andEL (Rle (minus_SNo one_third) (apply_fun g0 x)) (Rle (apply_fun g0 x) one_third) Hg0x_bounds). }
	      claim Hg0x_le_13: Rle (apply_fun g0 x) one_third.
	      { exact (andER (Rle (minus_SNo one_third) (apply_fun g0 x)) (Rle (apply_fun g0 x) one_third) Hg0x_bounds). }
	      claim Hm13_le_mg0x: Rle (minus_SNo one_third) (minus_SNo (apply_fun g0 x)).
	      { exact (Rle_minus_contra (apply_fun g0 x) one_third Hg0x_le_13). }
	      claim Hmg0x_le_13: Rle (minus_SNo (apply_fun g0 x)) one_third.
	      { claim Htmp: Rle (minus_SNo (apply_fun g0 x)) (minus_SNo (minus_SNo one_third)).
	        { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun g0 x) Hm13_le_g0x). }
	        claim H13R: one_third :e R.
	        { exact one_third_in_R. }
	        rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
	        exact Htmp. }
	      claim Hlo1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
	                     (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun f x) (minus_SNo one_third)
	                             Hm13R HfxR Hm13R Hm13_le_fx). }
	      claim Hlo2: Rle (add_SNo (apply_fun f x) (minus_SNo one_third))
	                     (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
	      { exact (Rle_add_SNo_2 (apply_fun f x) (minus_SNo one_third) (minus_SNo (apply_fun g0 x))
	                             HfxR Hm13R Hm_g0x_R Hm13_le_mg0x). }
	      claim Hlo': Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
	                     (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
	      { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
	                       (add_SNo (apply_fun f x) (minus_SNo one_third))
	                       (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                       Hlo1 Hlo2). }
	      claim Hlo: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
	      { rewrite (minus_two_thirds_eq) at 1.
	        exact Hlo'. }
	      claim Hhi1: Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third (minus_SNo (apply_fun g0 x))).
	      { exact (Rle_add_SNo_1 (apply_fun f x) one_third (minus_SNo (apply_fun g0 x))
	                             HfxR H13R Hm_g0x_R Hfx_le_13). }
	      claim Hhi2: Rle (add_SNo one_third (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third one_third).
	      { exact (Rle_add_SNo_2 one_third (minus_SNo (apply_fun g0 x)) one_third
	                             H13R Hm_g0x_R H13R Hmg0x_le_13). }
	      claim Hhi': Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third one_third).
	      { exact (Rle_tra (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                       (add_SNo one_third (minus_SNo (apply_fun g0 x)))
	                       (add_SNo one_third one_third)
	                       Hhi1 Hhi2). }
	      claim Hhi: Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))) two_thirds.
	      { claim Hdef23: two_thirds = add_SNo one_third one_third.
	        { reflexivity. }
	        rewrite Hdef23.
	        exact Hhi'. }
	      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
	                                     (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                                     Hm23R H23R Hf1xR Hlo Hhi). }
		(** Further iteration and summation still pending. **)
		claim Hseries:
		  exists gR:set,
		    continuous_map X Tx R R_standard_topology gR /\
		    (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
		    (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1).
		{ (** TeX Step II: geometric series of successive Step I corrections. **)
		  set I := closed_interval (minus_SNo 1) 1.
		  set Ti := closed_interval_topology (minus_SNo 1) 1.
		  claim H23R: two_thirds :e R.
		  { exact two_thirds_in_R. }
		  claim H23S: SNo two_thirds.
		  { exact (real_SNo two_thirds H23R). }
		  claim H23pos: 0 < two_thirds.
		  { exact two_thirds_pos. }
			  claim H23ne0: two_thirds <> 0.
			  { exact two_thirds_ne0. }
			
			  (** define scaled residual on A: f1s = f1 / (2/3), so f1s maps into [-1,1] **)
			  set den := two_thirds.
			  set f1s := compose_fun A f1 (div_const_fun den).
			  claim Hdivfun: function_on (div_const_fun den) R R.
			  { let t. assume HtR: t :e R.
			    exact (div_const_fun_value_in_R den t H23R HtR). }
			  claim Hf1fun0: function_on f1 A R.
			  { exact (andEL (function_on f1 A R)
			                 (forall a:set, a :e A -> exists y:set, y :e R /\ (a,y) :e f1)
			                 Hf1_total). }
			  claim Hf1s_total: total_function_on f1s A R.
			  { exact (total_function_on_compose_fun A R R f1 (div_const_fun den) Hf1fun0 Hdivfun). }
			  claim Hf1s_fun: function_on f1s A R.
			  { exact (andEL (function_on f1s A R)
			                 (forall x:set, x :e A -> exists y:set, y :e R /\ (x,y) :e f1s)
			                 Hf1s_total). }
			  claim Hf1s_apply: forall x:set, x :e A ->
			    apply_fun f1s x = div_SNo (apply_fun f1 x) den.
			  { let x. assume HxA: x :e A.
			    claim HxR: apply_fun f1 x :e R.
			    { exact (Hf1fun0 x HxA). }
			    rewrite (compose_fun_apply A f1 (div_const_fun den) x HxA).
			    rewrite (div_const_fun_apply den (apply_fun f1 x) H23R HxR).
			    reflexivity. }
			
			  (** pending: prove f1s is continuous as a map A -> I with the interval topology **)
			  claim Hf1s_I: forall x:set, x :e A -> apply_fun f1s x :e I.
			  { let x. assume HxA: x :e A.
			    prove apply_fun f1s x :e I.
			    claim Hm1R: (minus_SNo 1) :e R.
			    { exact (real_minus_SNo 1 real_1). }
			    
			    claim Hf1xI2: apply_fun f1 x :e I2.
			    { exact (Hf1_range x HxA). }
			    claim Hm23R: (minus_SNo den) :e R.
			    { exact (real_minus_SNo den H23R). }
			    claim Hf1xR: apply_fun f1 x :e R.
			    { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun f1 x) Hf1xI2). }
			    claim Hf1xS: SNo (apply_fun f1 x).
			    { exact (real_SNo (apply_fun f1 x) Hf1xR). }
		    
			    claim Hbounds: Rle (minus_SNo den) (apply_fun f1 x) /\ Rle (apply_fun f1 x) den.
			    { exact (closed_interval_bounds (minus_SNo den) den (apply_fun f1 x) Hm23R H23R Hf1xI2). }
		    claim Hlo: Rle (minus_SNo den) (apply_fun f1 x).
		    { exact (andEL (Rle (minus_SNo den) (apply_fun f1 x))
		                   (Rle (apply_fun f1 x) den)
		                   Hbounds). }
		    claim Hhi: Rle (apply_fun f1 x) den.
		    { exact (andER (Rle (minus_SNo den) (apply_fun f1 x))
		                   (Rle (apply_fun f1 x) den)
		                   Hbounds). }
		    claim Hnlt_hi: ~(Rlt den (apply_fun f1 x)).
		    { exact (RleE_nlt (apply_fun f1 x) den Hhi). }
		    claim Hnlt_lo: ~(Rlt (apply_fun f1 x) (minus_SNo den)).
		    { exact (RleE_nlt (minus_SNo den) (apply_fun f1 x) Hlo). }
		    
			    claim HyEq: apply_fun f1s x = div_SNo (apply_fun f1 x) den.
			    { exact (Hf1s_apply x HxA). }
			    claim HyR: apply_fun f1s x :e R.
			    { rewrite HyEq.
			      exact (real_div_SNo (apply_fun f1 x) Hf1xR den H23R). }
			    claim HyS: SNo (apply_fun f1s x).
			    { exact (real_SNo (apply_fun f1s x) HyR). }
		    
		    claim Hy_le_1: Rle (apply_fun f1s x) 1.
		    { apply (RleI (apply_fun f1s x) 1 HyR real_1).
		      prove ~(Rlt 1 (apply_fun f1s x)).
		      assume H1lt: Rlt 1 (apply_fun f1s x).
		      claim H1lty: 1 < apply_fun f1s x.
		      { exact (RltE_lt 1 (apply_fun f1s x) H1lt). }
			      claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun f1s x) den.
			      { exact (pos_mul_SNo_Lt' 1 (apply_fun f1s x) den SNo_1 HyS H23S H23pos H1lty). }
		      claim HmulLt': den < mul_SNo (apply_fun f1s x) den.
			      { rewrite <- (mul_SNo_oneL den H23S) at 1.
			        exact HmulLt. }
			      claim HmulEq: mul_SNo (apply_fun f1s x) den = apply_fun f1 x.
			      { rewrite HyEq at 1.
			        exact (mul_div_SNo_invL (apply_fun f1 x) den Hf1xS H23S H23ne0). }
			      claim Hden_lt_f1x: den < apply_fun f1 x.
			      { rewrite <- HmulEq.
			        exact HmulLt'. }
			      claim Hbad: Rlt den (apply_fun f1 x).
			      { exact (RltI den (apply_fun f1 x) H23R Hf1xR Hden_lt_f1x). }
			      exact (Hnlt_hi Hbad). }
		    
		    claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun f1s x).
		    { apply (RleI (minus_SNo 1) (apply_fun f1s x) Hm1R HyR).
		      prove ~(Rlt (apply_fun f1s x) (minus_SNo 1)).
		      assume Hylt: Rlt (apply_fun f1s x) (minus_SNo 1).
		      claim Hylts: apply_fun f1s x < minus_SNo 1.
		      { exact (RltE_lt (apply_fun f1s x) (minus_SNo 1) Hylt). }
		      claim HmulLt: mul_SNo (apply_fun f1s x) den < mul_SNo (minus_SNo 1) den.
			      { exact (pos_mul_SNo_Lt' (apply_fun f1s x) (minus_SNo 1) den HyS
		                               (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
			      claim HmulEq: mul_SNo (apply_fun f1s x) den = apply_fun f1 x.
			      { rewrite HyEq at 1.
			        exact (mul_div_SNo_invL (apply_fun f1 x) den Hf1xS H23S H23ne0). }
		      claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
			      { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
			        rewrite (mul_SNo_oneL den H23S) at 1.
			        reflexivity. }
			      claim Hf1x_lt_mden: apply_fun f1 x < minus_SNo den.
			      { rewrite <- HmulEq.
			        rewrite <- HrhsEq.
			        exact HmulLt. }
		      claim Hbad: Rlt (apply_fun f1 x) (minus_SNo den).
		      { exact (RltI (apply_fun f1 x) (minus_SNo den) Hf1xR Hm23R Hf1x_lt_mden). }
		      exact (Hnlt_lo Hbad). }
		    
			    exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun f1s x) Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
			  claim Hf1s_cont: continuous_map A (subspace_topology X Tx A) I Ti f1s.
			  { (** reduce to continuity into R and range restriction to I **)
			    claim HRtop: topology_on R R_standard_topology.
			    { exact R_standard_topology_is_topology. }
				    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
				    { exact (div_const_fun_continuous_pos den H23R H23pos). }
				    claim Hf1cont: continuous_map A (subspace_topology X Tx A) R R_standard_topology f1.
				    { (** f1 is composition of pair_map with add_fun_R **)
				      set Ta := subspace_topology X Tx A.
				      claim HTa: topology_on A Ta.
				      { exact (subspace_topology_is_topology X Tx A HTx HAsubX). }
				      claim HIcR: I c= R.
				      { exact (closed_interval_sub_R (minus_SNo 1) 1). }
				      claim HTiEq: (closed_interval_topology (minus_SNo 1) 1) =
				        subspace_topology R R_standard_topology I.
				      { reflexivity. }
				      claim HfcontR: continuous_map A Ta R R_standard_topology f.
				      { exact (continuous_map_range_expand A Ta I (closed_interval_topology (minus_SNo 1) 1)
				               R R_standard_topology f
				               Hf
				               HIcR
				               R_standard_topology_is_topology_local
				               HTiEq). }
				      claim Hg0contA: continuous_map A Ta R R_standard_topology g0.
				      { exact (continuous_on_subspace X Tx R R_standard_topology g0 A HTx HAsubX Hg0contR). }
				      claim Hnegcont: continuous_map R R_standard_topology R R_standard_topology neg_fun.
				      { exact neg_fun_continuous. }
				      set g0neg := compose_fun A g0 neg_fun.
				      claim Hg0negcont: continuous_map A Ta R R_standard_topology g0neg.
				      { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
				               g0 neg_fun Hg0contA Hnegcont). }
				      set h := pair_map A f g0neg.
				      claim Hhcont:
				        continuous_map A Ta (setprod R R)
				          (product_topology R R_standard_topology R R_standard_topology) h.
				      { exact (maps_into_products_axiom A Ta R R_standard_topology R R_standard_topology
				               f g0neg HfcontR Hg0negcont). }
				      claim Haddcont:
				        continuous_map (setprod R R)
				          (product_topology R R_standard_topology R R_standard_topology)
				          R R_standard_topology add_fun_R.
				      { exact add_fun_R_continuous. }
				      set f1c := compose_fun A h add_fun_R.
				      claim Hf1c_cont: continuous_map A Ta R R_standard_topology f1c.
				      { exact (composition_continuous A Ta (setprod R R)
				               (product_topology R R_standard_topology R R_standard_topology)
				               R R_standard_topology
				               h add_fun_R Hhcont Haddcont). }
				      claim Heq: f1 = f1c.
				      { apply set_ext.
				        - let p. assume Hp: p :e f1.
				          prove p :e f1c.
				          apply (ReplE_impred A
				            (fun x0:set => (x0, add_SNo (apply_fun f x0) (minus_SNo (apply_fun g0 x0))))
				            p
				            Hp
				            (p :e f1c)).
				          let x. assume HxA: x :e A.
				          assume Hpeq: p = (x, add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
				          rewrite Hpeq.
				          claim Hhx: apply_fun h x = (apply_fun f x, apply_fun g0neg x).
				          { exact (pair_map_apply A R R f g0neg x HxA). }
				          claim Hg0negx: apply_fun g0neg x = minus_SNo (apply_fun g0 x).
				          { claim HxTa: x :e A.
				            { exact HxA. }
				            claim HxX: x :e X.
				            { exact (HAsubX x HxA). }
				            claim Hg0xR: apply_fun g0 x :e R.
				            { exact (continuous_map_function_on X Tx R R_standard_topology g0 Hg0contR x HxX). }
				            rewrite (compose_fun_apply A g0 neg_fun x HxA) at 1.
				            rewrite (neg_fun_apply (apply_fun g0 x) Hg0xR) at 1.
				            reflexivity. }
				          claim Hhimg: apply_fun h x :e setprod R R.
				          { exact (continuous_map_function_on A Ta (setprod R R)
				                    (product_topology R R_standard_topology R R_standard_topology) h Hhcont x HxA). }
				          claim Happ: apply_fun f1c x = apply_fun add_fun_R (apply_fun h x).
				          { exact (compose_fun_apply A h add_fun_R x HxA). }
						          claim Hadd: apply_fun add_fun_R (apply_fun h x) =
						            add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)).
						          { rewrite (add_fun_R_apply (apply_fun h x) Hhimg) at 1.
						            rewrite Hhx.
						            rewrite (tuple_2_0_eq (apply_fun f x) (apply_fun g0neg x)).
						            rewrite (tuple_2_1_eq (apply_fun f x) (apply_fun g0neg x)).
						            rewrite Hg0negx at 1.
						            reflexivity. }
					          rewrite <- Hadd.
					          exact (ReplI A (fun x0:set => (x0, apply_fun add_fun_R (apply_fun h x0))) x HxA).
				        - let p. assume Hp: p :e f1c.
				          prove p :e f1.
				          apply (ReplE_impred A (fun x0:set => (x0, apply_fun add_fun_R (apply_fun h x0))) p Hp (p :e f1)).
				          let x. assume HxA: x :e A.
				          assume Hpeq: p = (x, apply_fun add_fun_R (apply_fun h x)).
				          rewrite Hpeq.
				          claim Hhx: apply_fun h x = (apply_fun f x, apply_fun g0neg x).
				          { exact (pair_map_apply A R R f g0neg x HxA). }
				          claim Hg0xR: apply_fun g0 x :e R.
				          { claim HxX: x :e X.
				            { exact (HAsubX x HxA). }
				            exact (continuous_map_function_on X Tx R R_standard_topology g0 Hg0contR x HxX). }
				          claim Hg0negx: apply_fun g0neg x = minus_SNo (apply_fun g0 x).
				          { rewrite (compose_fun_apply A g0 neg_fun x HxA) at 1.
				            rewrite (neg_fun_apply (apply_fun g0 x) Hg0xR) at 1.
				            reflexivity. }
					          claim Hadd: apply_fun add_fun_R (apply_fun h x) =
					            add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)).
					          { claim Hhimg: apply_fun h x :e setprod R R.
					            { exact (continuous_map_function_on A Ta (setprod R R)
					                      (product_topology R R_standard_topology R R_standard_topology) h Hhcont x HxA). }
					            rewrite (add_fun_R_apply (apply_fun h x) Hhimg) at 1.
					            rewrite Hhx.
					            rewrite (tuple_2_0_eq (apply_fun f x) (apply_fun g0neg x)).
					            rewrite (tuple_2_1_eq (apply_fun f x) (apply_fun g0neg x)).
					            rewrite Hg0negx at 1.
					            reflexivity. }
				          rewrite Hadd.
				          exact (ReplI A
				                  (fun x0:set => (x0, add_SNo (apply_fun f x0) (minus_SNo (apply_fun g0 x0))))
				                  x
				                  HxA). }
				      rewrite Heq.
				      exact Hf1c_cont. }
				    claim Hf1s_cont_R: continuous_map A (subspace_topology X Tx A) R R_standard_topology f1s.
				    { exact (composition_continuous A (subspace_topology X Tx A) R R_standard_topology R R_standard_topology
				             f1 (div_const_fun den) Hf1cont Hdivcont). }
			    claim HISubR: I c= R.
			    { exact (closed_interval_sub_R (minus_SNo 1) 1). }
			    claim HTiEq: Ti = subspace_topology R R_standard_topology I.
			    { reflexivity. }
			    rewrite HTiEq.
			    exact (continuous_map_range_restrict A (subspace_topology X Tx A) R R_standard_topology f1s I
			             Hf1s_cont_R HISubR Hf1s_I). }
		
			  (** apply Step I to f1s to obtain the next correction u1:X -> [-1/3,1/3] **)
			  claim Hex_u1: exists u1:set,
			    continuous_map X Tx (closed_interval (minus_SNo one_third) one_third)
			      (closed_interval_topology (minus_SNo one_third) one_third) u1 /\
			    (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
			      apply_fun u1 x = minus_SNo one_third) /\
			    (forall x:set, x :e preimage_of A f1s ((closed_interval one_third 1) :/\: I) ->
			      apply_fun u1 x = one_third).
			  { exact (Tietze_stepI_g_exists X Tx A f1s Hnorm HA Hf1s_cont). }
			  apply Hex_u1.
			  let u1. assume Hu1.
			  set I0 := closed_interval (minus_SNo one_third) one_third.
			  set T0 := closed_interval_topology (minus_SNo one_third) one_third.
			  claim Hu1AB:
			    continuous_map X Tx I0 T0 u1 /\
			    (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
			      apply_fun u1 x = minus_SNo one_third).
			  { exact (andEL
			      (continuous_map X Tx I0 T0 u1 /\
			       (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
			         apply_fun u1 x = minus_SNo one_third))
			      (forall x:set, x :e preimage_of A f1s ((closed_interval one_third 1) :/\: I) ->
			        apply_fun u1 x = one_third)
			      Hu1). }
			  claim Hu1contI0: continuous_map X Tx I0 T0 u1.
			  { exact (andEL
			      (continuous_map X Tx I0 T0 u1)
			      (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
			        apply_fun u1 x = minus_SNo one_third)
			      Hu1AB). }
			  claim Hu1contR: continuous_map X Tx R R_standard_topology u1.
			  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
			    { reflexivity. }
			    claim HI0subR: I0 c= R.
			    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
			    exact (continuous_map_range_expand
			             X Tx I0 T0
			             R R_standard_topology
			             u1
			             Hu1contI0
			             HI0subR
			             R_standard_topology_is_topology_local
			             HT0eq). }
			  (** a first partial sum g1 = g0 + (2/3) u1 is continuous **)
			  set den := two_thirds.
			  set u1s := compose_fun X u1 (mul_const_fun den).
			  claim HdenR: den :e R.
			  { exact two_thirds_in_R. }
			  claim HdenPos: 0 < den.
			  { exact two_thirds_pos. }
			  claim HmulCont: continuous_map R R_standard_topology R R_standard_topology (mul_const_fun den).
			  { exact (mul_const_fun_continuous_pos den HdenR HdenPos). }
			  claim Hu1s_cont: continuous_map X Tx R R_standard_topology u1s.
			  { exact (composition_continuous X Tx R R_standard_topology R R_standard_topology
			           u1 (mul_const_fun den) Hu1contR HmulCont). }
			  set h1 := pair_map X g0 u1s.
			  claim Hh1cont:
			    continuous_map X Tx (setprod R R)
			      (product_topology R R_standard_topology R R_standard_topology) h1.
			  { exact (maps_into_products_axiom X Tx R R_standard_topology R R_standard_topology
			           g0 u1s Hg0contR Hu1s_cont). }
			  claim Haddcont:
			    continuous_map (setprod R R)
			      (product_topology R R_standard_topology R R_standard_topology)
			      R R_standard_topology add_fun_R.
			  { exact add_fun_R_continuous. }
			  set g1 := compose_fun X h1 add_fun_R.
				  claim Hg1cont: continuous_map X Tx R R_standard_topology g1.
				  { exact (composition_continuous X Tx (setprod R R)
				           (product_topology R R_standard_topology R R_standard_topology)
				           R R_standard_topology
				           h1 add_fun_R Hh1cont Haddcont). }
				
				  (** second correction step: build the next residual on A and a second partial sum **)
				  set Ta := subspace_topology X Tx A.
				  claim HTa: topology_on A Ta.
				  { exact (subspace_topology_is_topology X Tx A HTx HAsubX). }
				  claim HIcR: I c= R.
				  { exact (closed_interval_sub_R (minus_SNo 1) 1). }
				  claim HTiEq: Ti = subspace_topology R R_standard_topology I.
				  { reflexivity. }
				  claim Hf1s_contR: continuous_map A Ta R R_standard_topology f1s.
				  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology
				           f1s Hf1s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
				  claim Hu1contA: continuous_map A Ta R R_standard_topology u1.
				  { exact (continuous_on_subspace X Tx R R_standard_topology u1 A HTx HAsubX Hu1contR). }
				  claim Hnegcont: continuous_map R R_standard_topology R R_standard_topology neg_fun.
				  { exact neg_fun_continuous. }
				  set u1neg := compose_fun A u1 neg_fun.
				  claim Hu1neg_cont: continuous_map A Ta R R_standard_topology u1neg.
				  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
				           u1 neg_fun Hu1contA Hnegcont). }
				  set r1 := compose_fun A (pair_map A f1s u1neg) add_fun_R.
				  claim Hr1_cont: continuous_map A Ta R R_standard_topology r1.
				  { exact (add_two_continuous_R A Ta f1s u1neg HTa Hf1s_contR Hu1neg_cont). }
				  claim Hr1_apply: forall x:set, x :e A ->
				    apply_fun r1 x = add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)).
				  { let x. assume HxA: x :e A.
				    claim Hpimg: apply_fun (pair_map A f1s u1neg) x :e setprod R R.
				    { rewrite (pair_map_apply A R R f1s u1neg x HxA).
				      claim Hf1sRx: apply_fun f1s x :e R.
				      { exact (continuous_map_function_on A Ta R R_standard_topology f1s Hf1s_contR x HxA). }
				      claim Hu1negRx: apply_fun u1neg x :e R.
				      { exact (continuous_map_function_on A Ta R R_standard_topology u1neg Hu1neg_cont x HxA). }
				      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun f1s x) (apply_fun u1neg x) Hf1sRx Hu1negRx). }
				    rewrite (compose_fun_apply A (pair_map A f1s u1neg) add_fun_R x HxA).
				    rewrite (add_fun_R_apply (apply_fun (pair_map A f1s u1neg) x) Hpimg) at 1.
				    rewrite (pair_map_apply A R R f1s u1neg x HxA).
				    rewrite (tuple_2_0_eq (apply_fun f1s x) (apply_fun u1neg x)).
				    rewrite (tuple_2_1_eq (apply_fun f1s x) (apply_fun u1neg x)).
				    rewrite (compose_fun_apply A u1 neg_fun x HxA) at 1.
				    claim Hu1Rx: apply_fun u1 x :e R.
				    { exact (continuous_map_function_on A Ta R R_standard_topology u1 Hu1contA x HxA). }
				    rewrite (neg_fun_apply (apply_fun u1 x) Hu1Rx) at 1.
				    reflexivity. }
				
				  (** show the next residual stays within [-2/3,2/3] on A **)
				  claim Hu1_on_B1:
				    forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				      apply_fun u1 x = minus_SNo one_third.
				  { exact (andER
				      (continuous_map X Tx I0 T0 u1)
				      (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				        apply_fun u1 x = minus_SNo one_third)
				      Hu1AB). }
				  claim Hu1_on_C1:
				    forall x:set, x :e preimage_of A f1s ((closed_interval one_third 1) :/\: I) ->
				      apply_fun u1 x = one_third.
				  { exact (andER
				      (continuous_map X Tx I0 T0 u1 /\
				       (forall x:set, x :e preimage_of A f1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				         apply_fun u1 x = minus_SNo one_third))
				      (forall x:set, x :e preimage_of A f1s ((closed_interval one_third 1) :/\: I) ->
				        apply_fun u1 x = one_third)
				      Hu1). }
				  claim Hr1_range: forall x:set, x :e A -> apply_fun r1 x :e I2.
				  { let x. assume HxA: x :e A.
				    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
				    set I3 := closed_interval one_third 1.
				    set B1 := preimage_of A f1s (I1 :/\: I).
				    set C1 := preimage_of A f1s (I3 :/\: I).
				    claim Hf1sIx: apply_fun f1s x :e I.
				    { exact (Hf1s_I x HxA). }
				    claim HB1_cases: x :e B1 \/ ~(x :e B1).
				    { exact (xm (x :e B1)). }
				    apply (HB1_cases (apply_fun r1 x :e I2)).
				    - assume HxB1: x :e B1.
				      claim Hu1eq: apply_fun u1 x = minus_SNo one_third.
				      { exact (Hu1_on_B1 x HxB1). }
				      claim Hr1eq: apply_fun r1 x = add_SNo (apply_fun f1s x) one_third.
				      { rewrite (Hr1_apply x HxA).
				        rewrite Hu1eq at 1.
				        claim H13R: one_third :e R.
				        { exact one_third_in_R. }
				        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
				        reflexivity. }
				      rewrite Hr1eq.
				      claim Hf1sI1I: apply_fun f1s x :e I1 :/\: I.
				      { exact (SepE2 A (fun x0:set => apply_fun f1s x0 :e I1 :/\: I) x HxB1). }
				      claim Hf1sI1: apply_fun f1s x :e I1.
				      { exact (binintersectE1 I1 I (apply_fun f1s x) Hf1sI1I). }
				      claim H13R: one_third :e R.
				      { exact one_third_in_R. }
				      claim H23R: two_thirds :e R.
				      { exact two_thirds_in_R. }
				      claim Hm23R: minus_SNo two_thirds :e R.
				      { exact (real_minus_SNo two_thirds H23R). }
				      claim Hm1R: minus_SNo 1 :e R.
				      { exact (real_minus_SNo 1 real_1). }
				      claim Hm13R: minus_SNo one_third :e R.
				      { exact (real_minus_SNo one_third H13R). }
				      claim Hf1sRx: apply_fun f1s x :e R.
				      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun f1s x) Hf1sI1). }
				      claim Hf1s_bounds: Rle (minus_SNo 1) (apply_fun f1s x) /\ Rle (apply_fun f1s x) (minus_SNo one_third).
				      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun f1s x)
				                                     Hm1R Hm13R Hf1sI1). }
				      claim Hm1le: Rle (minus_SNo 1) (apply_fun f1s x).
				      { exact (andEL (Rle (minus_SNo 1) (apply_fun f1s x))
				                     (Rle (apply_fun f1s x) (minus_SNo one_third)) Hf1s_bounds). }
				      claim HhiI1: Rle (apply_fun f1s x) (minus_SNo one_third).
				      { exact (andER (Rle (minus_SNo 1) (apply_fun f1s x))
				                     (Rle (apply_fun f1s x) (minus_SNo one_third)) Hf1s_bounds). }
				      claim Hr1Rx: add_SNo (apply_fun f1s x) one_third :e R.
				      { exact (real_add_SNo (apply_fun f1s x) Hf1sRx one_third H13R). }
				      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun f1s x) one_third).
				      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun f1s x) one_third Hm1R Hf1sRx H13R Hm1le). }
				      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f1s x) one_third).
				      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
				        exact Hlow_tmp. }
				      claim Hup0_tmp: Rle (add_SNo (apply_fun f1s x) one_third) (add_SNo (minus_SNo one_third) one_third).
				      { exact (Rle_add_SNo_1 (apply_fun f1s x) (minus_SNo one_third) one_third Hf1sRx Hm13R H13R HhiI1). }
				      claim H13S: SNo one_third.
				      { exact (real_SNo one_third H13R). }
				      claim Hup0: Rle (add_SNo (apply_fun f1s x) one_third) 0.
				      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
				        exact Hup0_tmp. }
				      claim H0le23: Rle 0 two_thirds.
				      { exact Rle_0_two_thirds. }
				      claim Hup: Rle (add_SNo (apply_fun f1s x) one_third) two_thirds.
				      { exact (Rle_tra (add_SNo (apply_fun f1s x) one_third) 0 two_thirds Hup0 H0le23). }
				      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
				                                     (add_SNo (apply_fun f1s x) one_third)
				                                     Hm23R H23R Hr1Rx Hlow Hup).
				    - assume HxnotB1: ~(x :e B1).
				      claim HC1_cases: x :e C1 \/ ~(x :e C1).
				      { exact (xm (x :e C1)). }
				      apply (HC1_cases (apply_fun r1 x :e I2)).
				      + assume HxC1: x :e C1.
				        claim Hu1eq: apply_fun u1 x = one_third.
				        { exact (Hu1_on_C1 x HxC1). }
				        claim Hr1eq: apply_fun r1 x = add_SNo (apply_fun f1s x) (minus_SNo one_third).
				        { rewrite (Hr1_apply x HxA).
				          rewrite Hu1eq at 1.
				          reflexivity. }
				        rewrite Hr1eq.
				        claim Hf1sI3I: apply_fun f1s x :e I3 :/\: I.
				        { exact (SepE2 A (fun x0:set => apply_fun f1s x0 :e I3 :/\: I) x HxC1). }
				        claim Hf1sI3: apply_fun f1s x :e I3.
				        { exact (binintersectE1 I3 I (apply_fun f1s x) Hf1sI3I). }
				        claim H13R: one_third :e R.
				        { exact one_third_in_R. }
				        claim H23R: two_thirds :e R.
				        { exact two_thirds_in_R. }
				        claim Hm23R: minus_SNo two_thirds :e R.
				        { exact (real_minus_SNo two_thirds H23R). }
				        claim Hm13R: minus_SNo one_third :e R.
				        { exact (real_minus_SNo one_third H13R). }
				        claim Hf1sRx: apply_fun f1s x :e R.
				        { exact (closed_interval_sub_R one_third 1 (apply_fun f1s x) Hf1sI3). }
				        claim Hf1s_bounds: Rle one_third (apply_fun f1s x) /\ Rle (apply_fun f1s x) 1.
				        { exact (closed_interval_bounds one_third 1 (apply_fun f1s x) H13R real_1 Hf1sI3). }
				        claim HloI3: Rle one_third (apply_fun f1s x).
				        { exact (andEL (Rle one_third (apply_fun f1s x)) (Rle (apply_fun f1s x) 1) Hf1s_bounds). }
				        claim HhiI3: Rle (apply_fun f1s x) 1.
				        { exact (andER (Rle one_third (apply_fun f1s x)) (Rle (apply_fun f1s x) 1) Hf1s_bounds). }
				        claim Hr1Rx: add_SNo (apply_fun f1s x) (minus_SNo one_third) :e R.
				        { exact (real_add_SNo (apply_fun f1s x) Hf1sRx (minus_SNo one_third) Hm13R). }
				        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
				                          (add_SNo (apply_fun f1s x) (minus_SNo one_third)).
				        { exact (Rle_add_SNo_1 one_third (apply_fun f1s x) (minus_SNo one_third)
				                               H13R Hf1sRx Hm13R HloI3). }
				        claim H13S: SNo one_third.
				        { exact (real_SNo one_third H13R). }
				        claim H0le: Rle 0 (add_SNo (apply_fun f1s x) (minus_SNo one_third)).
				        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
				          exact H0le_tmp. }
				        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
				        { exact Rle_minus_two_thirds_0. }
				        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f1s x) (minus_SNo one_third)).
				        { exact (Rle_tra (minus_SNo two_thirds) 0
				                         (add_SNo (apply_fun f1s x) (minus_SNo one_third))
				                         Hm23le0 H0le). }
				        claim Hup_tmp: Rle (add_SNo (apply_fun f1s x) (minus_SNo one_third))
				                         (add_SNo 1 (minus_SNo one_third)).
				        { exact (Rle_add_SNo_1 (apply_fun f1s x) 1 (minus_SNo one_third)
				                               Hf1sRx real_1 Hm13R HhiI3). }
				        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
				        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
				          exact (Rle_refl two_thirds H23R). }
				        claim Hup: Rle (add_SNo (apply_fun f1s x) (minus_SNo one_third)) two_thirds.
				        { exact (Rle_tra (add_SNo (apply_fun f1s x) (minus_SNo one_third))
				                         (add_SNo 1 (minus_SNo one_third))
				                         two_thirds
				                         Hup_tmp Hup1). }
				        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
				                                       (add_SNo (apply_fun f1s x) (minus_SNo one_third))
				                                       Hm23R H23R Hr1Rx Hlow Hup).
				      + assume HxnotC1: ~(x :e C1).
				        claim HxX: x :e X.
				        { exact (HAsubX x HxA). }
				        claim HnotI1: ~(apply_fun f1s x :e I1).
				        { assume Hf1sI1': apply_fun f1s x :e I1.
				          claim Hf1sI1I: apply_fun f1s x :e I1 :/\: I.
				          { exact (binintersectI I1 I (apply_fun f1s x) Hf1sI1' Hf1sIx). }
				          claim HxB1': x :e B1.
				          { exact (SepI A (fun x0:set => apply_fun f1s x0 :e I1 :/\: I) x HxA Hf1sI1I). }
				          apply FalseE.
				          exact (HxnotB1 HxB1'). }
				        claim HnotI3: ~(apply_fun f1s x :e I3).
				        { assume Hf1sI3': apply_fun f1s x :e I3.
				          claim Hf1sI3I: apply_fun f1s x :e I3 :/\: I.
				          { exact (binintersectI I3 I (apply_fun f1s x) Hf1sI3' Hf1sIx). }
				          claim HxC1': x :e C1.
				          { exact (SepI A (fun x0:set => apply_fun f1s x0 :e I3 :/\: I) x HxA Hf1sI3I). }
				          apply FalseE.
				          exact (HxnotC1 HxC1'). }
				        claim Hf1sRx: apply_fun f1s x :e R.
				        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun f1s x) Hf1sIx). }
				        claim Hm1R: minus_SNo 1 :e R.
				        { exact (real_minus_SNo 1 real_1). }
				        claim H13R: one_third :e R.
				        { exact one_third_in_R. }
				        claim Hm13R: minus_SNo one_third :e R.
				        { exact (real_minus_SNo one_third H13R). }
				        claim Hf1s_boundsI: Rle (minus_SNo 1) (apply_fun f1s x) /\ Rle (apply_fun f1s x) 1.
				        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun f1s x) Hm1R real_1 Hf1sIx). }
				        claim Hnlt_fx_m1: ~(Rlt (apply_fun f1s x) (minus_SNo 1)).
				        { exact (RleE_nlt (minus_SNo 1) (apply_fun f1s x)
				                          (andEL (Rle (minus_SNo 1) (apply_fun f1s x)) (Rle (apply_fun f1s x) 1) Hf1s_boundsI)). }
				        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun f1s x)).
				        { exact (RleE_nlt (apply_fun f1s x) 1
				                          (andER (Rle (minus_SNo 1) (apply_fun f1s x)) (Rle (apply_fun f1s x) 1) Hf1s_boundsI)). }
				        claim HnotI1_cases: Rlt (apply_fun f1s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun f1s x).
				        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun f1s x)
				                                              Hm1R Hm13R Hf1sRx HnotI1). }
				        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun f1s x).
				        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun f1s x))).
				          - assume Hbad: Rlt (apply_fun f1s x) (minus_SNo 1).
				            apply FalseE.
				            exact (Hnlt_fx_m1 Hbad).
				          - assume Hok: Rlt (minus_SNo one_third) (apply_fun f1s x).
				            exact Hok. }
				        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun f1s x) (minus_SNo one_third)).
				        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun f1s x) Hm13lt_fx). }
				        claim HnotI3_cases: Rlt (apply_fun f1s x) one_third \/ Rlt 1 (apply_fun f1s x).
				        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun f1s x)
				                                              H13R real_1 Hf1sRx HnotI3). }
				        claim Hfx_lt_13: Rlt (apply_fun f1s x) one_third.
				        { apply (HnotI3_cases (Rlt (apply_fun f1s x) one_third)).
				          - assume Hok: Rlt (apply_fun f1s x) one_third.
				            exact Hok.
				          - assume Hbad: Rlt 1 (apply_fun f1s x).
				            apply FalseE.
				            exact (Hnlt_1_fx Hbad). }
				        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun f1s x)).
				        { exact (not_Rlt_sym (apply_fun f1s x) one_third Hfx_lt_13). }
				        claim Hf1sI0: apply_fun f1s x :e I0.
				        { claim HI0_def:
				            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
				          { reflexivity. }
				          claim HxSep: apply_fun f1s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
				          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
				                        (apply_fun f1s x) Hf1sRx (andI (~(Rlt (apply_fun f1s x) (minus_SNo one_third)))
				                                                       (~(Rlt one_third (apply_fun f1s x)))
				                                                       Hnot_fx_lt_m13
				                                                       Hnot_13_lt_fx)). }
				          rewrite HI0_def.
				          exact HxSep. }
				        claim Hu1funI0: function_on u1 X I0.
				        { exact (continuous_map_function_on X Tx I0 T0 u1 Hu1contI0). }
				        claim Hu1xI0: apply_fun u1 x :e I0.
				        { exact (Hu1funI0 x HxX). }
				        claim Hu1xR: apply_fun u1 x :e R.
				        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u1 x) Hu1xI0). }
				        claim Hm_u1x_R: minus_SNo (apply_fun u1 x) :e R.
				        { exact (real_minus_SNo (apply_fun u1 x) Hu1xR). }
				        rewrite (Hr1_apply x HxA).
				        claim Hr1xR: add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)) :e R.
				        { exact (real_add_SNo (apply_fun f1s x)
				                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun f1s x) Hf1sI0)
				                              (minus_SNo (apply_fun u1 x)) Hm_u1x_R). }
				        claim H23R: two_thirds :e R.
				        { exact two_thirds_in_R. }
				        claim Hm23R: minus_SNo two_thirds :e R.
				        { exact (real_minus_SNo two_thirds H23R). }
				        claim Hf1s_bounds0: Rle (minus_SNo one_third) (apply_fun f1s x) /\ Rle (apply_fun f1s x) one_third.
				        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun f1s x) Hm13R H13R Hf1sI0). }
				        claim Hu1_bounds0: Rle (minus_SNo one_third) (apply_fun u1 x) /\ Rle (apply_fun u1 x) one_third.
				        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u1 x) Hm13R H13R Hu1xI0). }
				        claim Hm13_le_f1s: Rle (minus_SNo one_third) (apply_fun f1s x).
				        { exact (andEL (Rle (minus_SNo one_third) (apply_fun f1s x)) (Rle (apply_fun f1s x) one_third) Hf1s_bounds0). }
				        claim Hf1s_le_13: Rle (apply_fun f1s x) one_third.
				        { exact (andER (Rle (minus_SNo one_third) (apply_fun f1s x)) (Rle (apply_fun f1s x) one_third) Hf1s_bounds0). }
				        claim Hm13_le_u1x: Rle (minus_SNo one_third) (apply_fun u1 x).
				        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u1 x)) (Rle (apply_fun u1 x) one_third) Hu1_bounds0). }
				        claim Hu1x_le_13: Rle (apply_fun u1 x) one_third.
				        { exact (andER (Rle (minus_SNo one_third) (apply_fun u1 x)) (Rle (apply_fun u1 x) one_third) Hu1_bounds0). }
				        claim Hm13_le_mu1: Rle (minus_SNo one_third) (minus_SNo (apply_fun u1 x)).
				        { exact (Rle_minus_contra (apply_fun u1 x) one_third Hu1x_le_13). }
				        claim Hmu1_le_13: Rle (minus_SNo (apply_fun u1 x)) one_third.
				        { claim Htmp: Rle (minus_SNo (apply_fun u1 x)) (minus_SNo (minus_SNo one_third)).
				          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u1 x) Hm13_le_u1x). }
				          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
				          exact Htmp. }
				        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
				                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u1 x))).
				        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u1 x))
				                               Hm13R Hm13R Hm_u1x_R Hm13_le_mu1). }
				        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u1 x)))
				                      (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x))).
				        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun f1s x) (minus_SNo (apply_fun u1 x))
				                               Hm13R
				                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun f1s x) Hf1sI0)
				                               Hm_u1x_R
				                               Hm13_le_f1s). }
				        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
				                        (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x))).
				        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
				                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u1 x)))
				                         (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)))
				                         Hlow1 Hlow2). }
				        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x))).
				        { rewrite minus_two_thirds_eq at 1.
				          exact Hlow_tmp. }
				        claim Hup1: Rle (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)))
				                      (add_SNo (apply_fun f1s x) one_third).
				        { exact (Rle_add_SNo_2 (apply_fun f1s x) (minus_SNo (apply_fun u1 x)) one_third
				                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun f1s x) Hf1sI0)
				                               Hm_u1x_R H13R Hmu1_le_13). }
				        claim Hup2: Rle (add_SNo (apply_fun f1s x) one_third) (add_SNo one_third one_third).
				        { exact (Rle_add_SNo_1 (apply_fun f1s x) one_third one_third
				                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun f1s x) Hf1sI0)
				                               H13R H13R Hf1s_le_13). }
				        claim Hup_tmp: Rle (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)))
				                        (add_SNo one_third one_third).
				        { exact (Rle_tra (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)))
				                         (add_SNo (apply_fun f1s x) one_third)
				                         (add_SNo one_third one_third)
				                         Hup1 Hup2). }
				        claim Hdef23: two_thirds = add_SNo one_third one_third.
				        { reflexivity. }
				        claim Hup: Rle (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x))) two_thirds.
				        { rewrite Hdef23 at 1.
				          exact Hup_tmp. }
				        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
				                                       (add_SNo (apply_fun f1s x) (minus_SNo (apply_fun u1 x)))
				                                       Hm23R H23R Hr1xR Hlow Hup). }
				
				  (** second-step scaled residual and second correction u2 **)
				  set r1s := compose_fun A r1 (div_const_fun den).
				  claim Hr1s_cont: continuous_map A Ta I Ti r1s.
				  { (** prove continuity into R, then restrict the range to I **)
				    claim HRtop: topology_on R R_standard_topology.
				    { exact R_standard_topology_is_topology. }
				    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
				    { exact (div_const_fun_continuous_pos den H23R H23pos). }
				    claim Hr1s_contR: continuous_map A Ta R R_standard_topology r1s.
				    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
				             r1 (div_const_fun den) Hr1_cont Hdivcont). }
				    claim Hr1s_I: forall x:set, x :e A -> apply_fun r1s x :e I.
				    { let x. assume HxA: x :e A.
				      claim Hr1xI2: apply_fun r1 x :e I2.
				      { exact (Hr1_range x HxA). }
				      claim Hm1R: (minus_SNo 1) :e R.
				      { exact (real_minus_SNo 1 real_1). }
				      claim HmdenR: (minus_SNo den) :e R.
				      { exact (real_minus_SNo den H23R). }
				      claim Hr1xR: apply_fun r1 x :e R.
				      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r1 x) Hr1xI2). }
				      claim Hr1xS: SNo (apply_fun r1 x).
				      { exact (real_SNo (apply_fun r1 x) Hr1xR). }
				      claim Hbounds: Rle (minus_SNo den) (apply_fun r1 x) /\ Rle (apply_fun r1 x) den.
				      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r1 x) HmdenR H23R Hr1xI2). }
				      claim Hlo: Rle (minus_SNo den) (apply_fun r1 x).
				      { exact (andEL (Rle (minus_SNo den) (apply_fun r1 x))
				                     (Rle (apply_fun r1 x) den)
				                     Hbounds). }
				      claim Hhi: Rle (apply_fun r1 x) den.
				      { exact (andER (Rle (minus_SNo den) (apply_fun r1 x))
				                     (Rle (apply_fun r1 x) den)
				                     Hbounds). }
				      claim Hnlt_hi: ~(Rlt den (apply_fun r1 x)).
				      { exact (RleE_nlt (apply_fun r1 x) den Hhi). }
				      claim Hnlt_lo: ~(Rlt (apply_fun r1 x) (minus_SNo den)).
				      { exact (RleE_nlt (minus_SNo den) (apply_fun r1 x) Hlo). }
				      claim HyEq: apply_fun r1s x = div_SNo (apply_fun r1 x) den.
				      { rewrite (compose_fun_apply A r1 (div_const_fun den) x HxA).
				        rewrite (div_const_fun_apply den (apply_fun r1 x) H23R Hr1xR).
				        reflexivity. }
				      claim HyR: apply_fun r1s x :e R.
				      { rewrite HyEq.
				        exact (real_div_SNo (apply_fun r1 x) Hr1xR den H23R). }
				      claim HyS: SNo (apply_fun r1s x).
				      { exact (real_SNo (apply_fun r1s x) HyR). }
				      claim Hy_le_1: Rle (apply_fun r1s x) 1.
				      { apply (RleI (apply_fun r1s x) 1 HyR real_1).
				        prove ~(Rlt 1 (apply_fun r1s x)).
				        assume H1lt: Rlt 1 (apply_fun r1s x).
				        claim H1lty: 1 < apply_fun r1s x.
				        { exact (RltE_lt 1 (apply_fun r1s x) H1lt). }
				        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r1s x) den.
				        { exact (pos_mul_SNo_Lt' 1 (apply_fun r1s x) den SNo_1 HyS H23S H23pos H1lty). }
				        claim HmulLt': den < mul_SNo (apply_fun r1s x) den.
				        { rewrite <- (mul_SNo_oneL den H23S) at 1.
				          exact HmulLt. }
				        claim HmulEq: mul_SNo (apply_fun r1s x) den = apply_fun r1 x.
				        { rewrite HyEq at 1.
				          exact (mul_div_SNo_invL (apply_fun r1 x) den Hr1xS H23S H23ne0). }
				        claim Hden_lt_r1x: den < apply_fun r1 x.
				        { rewrite <- HmulEq.
				          exact HmulLt'. }
				        claim Hbad: Rlt den (apply_fun r1 x).
				        { exact (RltI den (apply_fun r1 x) H23R Hr1xR Hden_lt_r1x). }
				        exact (Hnlt_hi Hbad). }
				      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r1s x).
				      { apply (RleI (minus_SNo 1) (apply_fun r1s x) Hm1R HyR).
				        prove ~(Rlt (apply_fun r1s x) (minus_SNo 1)).
				        assume Hylt: Rlt (apply_fun r1s x) (minus_SNo 1).
				        claim Hylts: apply_fun r1s x < minus_SNo 1.
				        { exact (RltE_lt (apply_fun r1s x) (minus_SNo 1) Hylt). }
				        claim HmulLt: mul_SNo (apply_fun r1s x) den < mul_SNo (minus_SNo 1) den.
				        { exact (pos_mul_SNo_Lt' (apply_fun r1s x) (minus_SNo 1) den HyS
				                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
				        claim HmulEq: mul_SNo (apply_fun r1s x) den = apply_fun r1 x.
				        { rewrite HyEq at 1.
				          exact (mul_div_SNo_invL (apply_fun r1 x) den Hr1xS H23S H23ne0). }
				        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
				        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
				          rewrite (mul_SNo_oneL den H23S) at 1.
				          reflexivity. }
				        claim Hr1x_lt_mden: apply_fun r1 x < minus_SNo den.
				        { rewrite <- HmulEq.
				          rewrite <- HrhsEq.
				          exact HmulLt. }
				        claim Hbad: Rlt (apply_fun r1 x) (minus_SNo den).
				        { exact (RltI (apply_fun r1 x) (minus_SNo den) Hr1xR HmdenR Hr1x_lt_mden). }
				        exact (Hnlt_lo Hbad). }
				      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r1s x) Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
				    prove continuous_map A Ta I Ti r1s.
				    rewrite HTiEq.
				    exact (continuous_map_range_restrict A Ta R R_standard_topology r1s I Hr1s_contR HIcR Hr1s_I). }
				  claim Hex_u2:
				    exists u2:set,
				      continuous_map X Tx I0 T0 u2 /\
				      (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				        apply_fun u2 x = minus_SNo one_third) /\
				      (forall x:set, x :e preimage_of A r1s ((closed_interval one_third 1) :/\: I) ->
				        apply_fun u2 x = one_third).
				  { exact (Tietze_stepI_g_exists X Tx A r1s Hnorm HA Hr1s_cont). }
				  apply Hex_u2.
				  let u2. assume Hu2.
				  claim Hu2AB:
				    continuous_map X Tx I0 T0 u2 /\
				    (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				      apply_fun u2 x = minus_SNo one_third).
				  { exact (andEL
				      (continuous_map X Tx I0 T0 u2 /\
				       (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				         apply_fun u2 x = minus_SNo one_third))
				      (forall x:set, x :e preimage_of A r1s ((closed_interval one_third 1) :/\: I) ->
				        apply_fun u2 x = one_third)
				      Hu2). }
				  claim Hu2contI0: continuous_map X Tx I0 T0 u2.
				  { exact (andEL
				      (continuous_map X Tx I0 T0 u2)
				      (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				        apply_fun u2 x = minus_SNo one_third)
				      Hu2AB). }
				  claim Hu2contR: continuous_map X Tx R R_standard_topology u2.
				  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
				    { reflexivity. }
				    claim HI0subR: I0 c= R.
				    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
				    exact (continuous_map_range_expand
				             X Tx I0 T0
				             R R_standard_topology
				             u2
				             Hu2contI0
				             HI0subR
				             R_standard_topology_is_topology_local
				             HT0eq). }
				
				  (** a second partial sum g2 = g1 + (2/3)^2 u2 is continuous **)
				  set den2 := mul_SNo den den.
				  claim Hden2R: den2 :e R.
				  { exact (real_mul_SNo den HdenR den HdenR). }
				  claim Hden2pos: 0 < den2.
				  { exact (mul_SNo_pos_pos den den H23S H23S HdenPos HdenPos). }
				  set u2s := compose_fun X u2 (mul_const_fun den2).
				  claim Hu2s_cont: continuous_map X Tx R R_standard_topology u2s.
				  { exact (scale_continuous_mul_const_pos X Tx u2 den2 HTx Hu2contR Hden2R Hden2pos). }
				  set g2 := compose_fun X (pair_map X g1 u2s) add_fun_R.
				  claim Hg2cont: continuous_map X Tx R R_standard_topology g2.
				  { exact (add_two_continuous_R X Tx g1 u2s HTx Hg1cont Hu2s_cont). }

				  (** third correction step scaffold: residual r2 on A, scaling r2s, and u3 **)
				  claim Hu2contA: continuous_map A Ta R R_standard_topology u2.
				  { exact (continuous_on_subspace X Tx R R_standard_topology u2 A HTx HAsubX Hu2contR). }
				  set u2neg := compose_fun A u2 neg_fun.
				  claim Hu2neg_cont: continuous_map A Ta R R_standard_topology u2neg.
				  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
				           u2 neg_fun Hu2contA Hnegcont). }
				  claim Hr1s_contR: continuous_map A Ta R R_standard_topology r1s.
				  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r1s
				           Hr1s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
				  set r2 := compose_fun A (pair_map A r1s u2neg) add_fun_R.
				  claim Hr2_cont: continuous_map A Ta R R_standard_topology r2.
				  { exact (add_two_continuous_R A Ta r1s u2neg HTa Hr1s_contR Hu2neg_cont). }
				  claim Hr2_apply: forall x:set, x :e A ->
				    apply_fun r2 x = add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)).
				  { let x. assume HxA: x :e A.
				    claim Hpimg: apply_fun (pair_map A r1s u2neg) x :e setprod R R.
				    { rewrite (pair_map_apply A R R r1s u2neg x HxA).
				      claim Hr1sRx: apply_fun r1s x :e R.
				      { exact (continuous_map_function_on A Ta R R_standard_topology r1s Hr1s_contR x HxA). }
				      claim Hu2negRx: apply_fun u2neg x :e R.
				      { exact (continuous_map_function_on A Ta R R_standard_topology u2neg Hu2neg_cont x HxA). }
				      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r1s x) (apply_fun u2neg x) Hr1sRx Hu2negRx). }
				    rewrite (compose_fun_apply A (pair_map A r1s u2neg) add_fun_R x HxA).
				    rewrite (add_fun_R_apply (apply_fun (pair_map A r1s u2neg) x) Hpimg) at 1.
				    rewrite (pair_map_apply A R R r1s u2neg x HxA).
				    rewrite (tuple_2_0_eq (apply_fun r1s x) (apply_fun u2neg x)).
				    rewrite (tuple_2_1_eq (apply_fun r1s x) (apply_fun u2neg x)).
				    rewrite (compose_fun_apply A u2 neg_fun x HxA) at 1.
				    claim Hu2Rx: apply_fun u2 x :e R.
				    { exact (continuous_map_function_on A Ta R R_standard_topology u2 Hu2contA x HxA). }
				    rewrite (neg_fun_apply (apply_fun u2 x) Hu2Rx) at 1.
				    reflexivity. }
					  claim Hr2_range: forall x:set, x :e A -> apply_fun r2 x :e I2.
					  { (** show the next residual stays within [-2/3,2/3] on A **)
					    claim Hu2_on_B2:
					      forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					        apply_fun u2 x = minus_SNo one_third.
					    { exact (andER
					        (continuous_map X Tx I0 T0 u2)
					        (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					          apply_fun u2 x = minus_SNo one_third)
					        Hu2AB). }
					    claim Hu2_on_C2:
					      forall x:set, x :e preimage_of A r1s ((closed_interval one_third 1) :/\: I) ->
					        apply_fun u2 x = one_third.
					    { exact (andER
					        (continuous_map X Tx I0 T0 u2 /\
					         (forall x:set, x :e preimage_of A r1s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					           apply_fun u2 x = minus_SNo one_third))
					        (forall x:set, x :e preimage_of A r1s ((closed_interval one_third 1) :/\: I) ->
					          apply_fun u2 x = one_third)
					        Hu2). }
					    let x. assume HxA: x :e A.
					    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
					    set I3 := closed_interval one_third 1.
					    set B2 := preimage_of A r1s (I1 :/\: I).
					    set C2 := preimage_of A r1s (I3 :/\: I).
					    claim Hr1sIx: apply_fun r1s x :e I.
					    { exact (continuous_map_function_on A Ta I Ti r1s Hr1s_cont x HxA). }
					    claim HB2_cases: x :e B2 \/ ~(x :e B2).
					    { exact (xm (x :e B2)). }
					    apply (HB2_cases (apply_fun r2 x :e I2)).
					    - assume HxB2: x :e B2.
					      claim Hu2eq: apply_fun u2 x = minus_SNo one_third.
					      { exact (Hu2_on_B2 x HxB2). }
					      claim Hr2eq: apply_fun r2 x = add_SNo (apply_fun r1s x) one_third.
					      { rewrite (Hr2_apply x HxA).
					        rewrite Hu2eq at 1.
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
					        reflexivity. }
					      rewrite Hr2eq.
					      claim Hr1sI1I: apply_fun r1s x :e I1 :/\: I.
					      { exact (SepE2 A (fun x0:set => apply_fun r1s x0 :e I1 :/\: I) x HxB2). }
					      claim Hr1sI1: apply_fun r1s x :e I1.
					      { exact (binintersectE1 I1 I (apply_fun r1s x) Hr1sI1I). }
					      claim H13R: one_third :e R.
					      { exact one_third_in_R. }
					      claim H23R: two_thirds :e R.
					      { exact two_thirds_in_R. }
					      claim Hm23R: minus_SNo two_thirds :e R.
					      { exact (real_minus_SNo two_thirds H23R). }
					      claim Hm1R: minus_SNo 1 :e R.
					      { exact (real_minus_SNo 1 real_1). }
					      claim Hm13R: minus_SNo one_third :e R.
					      { exact (real_minus_SNo one_third H13R). }
					      claim Hr1sRx: apply_fun r1s x :e R.
					      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r1s x) Hr1sI1). }
					      claim Hr1s_bounds: Rle (minus_SNo 1) (apply_fun r1s x) /\ Rle (apply_fun r1s x) (minus_SNo one_third).
					      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r1s x)
					                                     Hm1R Hm13R Hr1sI1). }
					      claim Hm1le: Rle (minus_SNo 1) (apply_fun r1s x).
					      { exact (andEL (Rle (minus_SNo 1) (apply_fun r1s x))
					                     (Rle (apply_fun r1s x) (minus_SNo one_third)) Hr1s_bounds). }
					      claim HhiI1: Rle (apply_fun r1s x) (minus_SNo one_third).
					      { exact (andER (Rle (minus_SNo 1) (apply_fun r1s x))
					                     (Rle (apply_fun r1s x) (minus_SNo one_third)) Hr1s_bounds). }
					      claim Hr2Rx: add_SNo (apply_fun r1s x) one_third :e R.
					      { exact (real_add_SNo (apply_fun r1s x) Hr1sRx one_third H13R). }
					      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r1s x) one_third).
					      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r1s x) one_third Hm1R Hr1sRx H13R Hm1le). }
					      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r1s x) one_third).
					      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
					        exact Hlow_tmp. }
					      claim Hup0_tmp: Rle (add_SNo (apply_fun r1s x) one_third) (add_SNo (minus_SNo one_third) one_third).
					      { exact (Rle_add_SNo_1 (apply_fun r1s x) (minus_SNo one_third) one_third Hr1sRx Hm13R H13R HhiI1). }
					      claim H13S: SNo one_third.
					      { exact (real_SNo one_third H13R). }
					      claim Hup0: Rle (add_SNo (apply_fun r1s x) one_third) 0.
					      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
					        exact Hup0_tmp. }
					      claim H0le23: Rle 0 two_thirds.
					      { exact Rle_0_two_thirds. }
					      claim Hup: Rle (add_SNo (apply_fun r1s x) one_third) two_thirds.
					      { exact (Rle_tra (add_SNo (apply_fun r1s x) one_third) 0 two_thirds Hup0 H0le23). }
					      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                     (add_SNo (apply_fun r1s x) one_third)
					                                     Hm23R H23R Hr2Rx Hlow Hup).
					    - assume HxnotB2: ~(x :e B2).
					      claim HC2_cases: x :e C2 \/ ~(x :e C2).
					      { exact (xm (x :e C2)). }
					      apply (HC2_cases (apply_fun r2 x :e I2)).
					      + assume HxC2: x :e C2.
					        claim Hu2eq: apply_fun u2 x = one_third.
					        { exact (Hu2_on_C2 x HxC2). }
					        claim Hr2eq: apply_fun r2 x = add_SNo (apply_fun r1s x) (minus_SNo one_third).
					        { rewrite (Hr2_apply x HxA).
					          rewrite Hu2eq at 1.
					          reflexivity. }
					        rewrite Hr2eq.
					        claim Hr1sI3I: apply_fun r1s x :e I3 :/\: I.
					        { exact (SepE2 A (fun x0:set => apply_fun r1s x0 :e I3 :/\: I) x HxC2). }
					        claim Hr1sI3: apply_fun r1s x :e I3.
					        { exact (binintersectE1 I3 I (apply_fun r1s x) Hr1sI3I). }
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        claim H23R: two_thirds :e R.
					        { exact two_thirds_in_R. }
					        claim Hm23R: minus_SNo two_thirds :e R.
					        { exact (real_minus_SNo two_thirds H23R). }
					        claim Hm13R: minus_SNo one_third :e R.
					        { exact (real_minus_SNo one_third H13R). }
					        claim Hr1sRx: apply_fun r1s x :e R.
					        { exact (closed_interval_sub_R one_third 1 (apply_fun r1s x) Hr1sI3). }
					        claim Hr1s_bounds: Rle one_third (apply_fun r1s x) /\ Rle (apply_fun r1s x) 1.
					        { exact (closed_interval_bounds one_third 1 (apply_fun r1s x) H13R real_1 Hr1sI3). }
					        claim HloI3: Rle one_third (apply_fun r1s x).
					        { exact (andEL (Rle one_third (apply_fun r1s x)) (Rle (apply_fun r1s x) 1) Hr1s_bounds). }
					        claim HhiI3: Rle (apply_fun r1s x) 1.
					        { exact (andER (Rle one_third (apply_fun r1s x)) (Rle (apply_fun r1s x) 1) Hr1s_bounds). }
					        claim Hr2Rx: add_SNo (apply_fun r1s x) (minus_SNo one_third) :e R.
					        { exact (real_add_SNo (apply_fun r1s x) Hr1sRx (minus_SNo one_third) Hm13R). }
					        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
					                          (add_SNo (apply_fun r1s x) (minus_SNo one_third)).
					        { exact (Rle_add_SNo_1 one_third (apply_fun r1s x) (minus_SNo one_third)
					                               H13R Hr1sRx Hm13R HloI3). }
					        claim H13S: SNo one_third.
					        { exact (real_SNo one_third H13R). }
					        claim H0le: Rle 0 (add_SNo (apply_fun r1s x) (minus_SNo one_third)).
					        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
					          exact H0le_tmp. }
					        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
					        { exact Rle_minus_two_thirds_0. }
					        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r1s x) (minus_SNo one_third)).
					        { exact (Rle_tra (minus_SNo two_thirds) 0
					                         (add_SNo (apply_fun r1s x) (minus_SNo one_third))
					                         Hm23le0 H0le). }
					        claim Hup_tmp: Rle (add_SNo (apply_fun r1s x) (minus_SNo one_third))
					                         (add_SNo 1 (minus_SNo one_third)).
					        { exact (Rle_add_SNo_1 (apply_fun r1s x) 1 (minus_SNo one_third)
					                               Hr1sRx real_1 Hm13R HhiI3). }
					        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
					        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
					          exact (Rle_refl two_thirds H23R). }
					        claim Hup: Rle (add_SNo (apply_fun r1s x) (minus_SNo one_third)) two_thirds.
					        { exact (Rle_tra (add_SNo (apply_fun r1s x) (minus_SNo one_third))
					                         (add_SNo 1 (minus_SNo one_third))
					                         two_thirds
					                         Hup_tmp Hup1). }
					        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                       (add_SNo (apply_fun r1s x) (minus_SNo one_third))
					                                       Hm23R H23R Hr2Rx Hlow Hup).
					      + assume HxnotC2: ~(x :e C2).
					        claim HxX: x :e X.
					        { exact (HAsubX x HxA). }
					        claim HnotI1: ~(apply_fun r1s x :e I1).
					        { assume Hr1sI1': apply_fun r1s x :e I1.
					          claim Hr1sI1I: apply_fun r1s x :e I1 :/\: I.
					          { exact (binintersectI I1 I (apply_fun r1s x) Hr1sI1' Hr1sIx). }
					          claim HxB2': x :e B2.
					          { exact (SepI A (fun x0:set => apply_fun r1s x0 :e I1 :/\: I) x HxA Hr1sI1I). }
					          apply FalseE.
					          exact (HxnotB2 HxB2'). }
					        claim HnotI3: ~(apply_fun r1s x :e I3).
					        { assume Hr1sI3': apply_fun r1s x :e I3.
					          claim Hr1sI3I: apply_fun r1s x :e I3 :/\: I.
					          { exact (binintersectI I3 I (apply_fun r1s x) Hr1sI3' Hr1sIx). }
					          claim HxC2': x :e C2.
					          { exact (SepI A (fun x0:set => apply_fun r1s x0 :e I3 :/\: I) x HxA Hr1sI3I). }
					          apply FalseE.
					          exact (HxnotC2 HxC2'). }
					        claim Hr1sRx: apply_fun r1s x :e R.
					        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r1s x) Hr1sIx). }
					        claim Hm1R: minus_SNo 1 :e R.
					        { exact (real_minus_SNo 1 real_1). }
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        claim Hm13R: minus_SNo one_third :e R.
					        { exact (real_minus_SNo one_third H13R). }
					        claim Hr1s_boundsI: Rle (minus_SNo 1) (apply_fun r1s x) /\ Rle (apply_fun r1s x) 1.
					        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r1s x) Hm1R real_1 Hr1sIx). }
					        claim Hnlt_fx_m1: ~(Rlt (apply_fun r1s x) (minus_SNo 1)).
					        { exact (RleE_nlt (minus_SNo 1) (apply_fun r1s x)
					                          (andEL (Rle (minus_SNo 1) (apply_fun r1s x)) (Rle (apply_fun r1s x) 1) Hr1s_boundsI)). }
					        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r1s x)).
					        { exact (RleE_nlt (apply_fun r1s x) 1
					                          (andER (Rle (minus_SNo 1) (apply_fun r1s x)) (Rle (apply_fun r1s x) 1) Hr1s_boundsI)). }
					        claim HnotI1_cases: Rlt (apply_fun r1s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r1s x).
					        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r1s x)
					                                              Hm1R Hm13R Hr1sRx HnotI1). }
					        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r1s x).
					        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r1s x))).
					          - assume Hbad: Rlt (apply_fun r1s x) (minus_SNo 1).
					            apply FalseE.
					            exact (Hnlt_fx_m1 Hbad).
					          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r1s x).
					            exact Hok. }
					        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r1s x) (minus_SNo one_third)).
					        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r1s x) Hm13lt_fx). }
					        claim HnotI3_cases: Rlt (apply_fun r1s x) one_third \/ Rlt 1 (apply_fun r1s x).
					        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r1s x)
					                                              H13R real_1 Hr1sRx HnotI3). }
					        claim Hfx_lt_13: Rlt (apply_fun r1s x) one_third.
					        { apply (HnotI3_cases (Rlt (apply_fun r1s x) one_third)).
					          - assume Hok: Rlt (apply_fun r1s x) one_third.
					            exact Hok.
					          - assume Hbad: Rlt 1 (apply_fun r1s x).
					            apply FalseE.
					            exact (Hnlt_1_fx Hbad). }
					        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r1s x)).
					        { exact (not_Rlt_sym (apply_fun r1s x) one_third Hfx_lt_13). }
					        claim Hr1sI0: apply_fun r1s x :e I0.
					        { claim HI0_def:
					            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
					          { reflexivity. }
					          claim HxSep: apply_fun r1s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
					          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
					                        (apply_fun r1s x) Hr1sRx (andI (~(Rlt (apply_fun r1s x) (minus_SNo one_third)))
					                                                      (~(Rlt one_third (apply_fun r1s x)))
					                                                      Hnot_fx_lt_m13
					                                                      Hnot_13_lt_fx)). }
					          rewrite HI0_def.
					          exact HxSep. }
					        claim Hu2funI0: function_on u2 X I0.
					        { exact (continuous_map_function_on X Tx I0 T0 u2 Hu2contI0). }
					        claim Hu2xI0: apply_fun u2 x :e I0.
					        { exact (Hu2funI0 x HxX). }
					        claim Hu2xR: apply_fun u2 x :e R.
					        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u2 x) Hu2xI0). }
					        claim Hm_u2x_R: minus_SNo (apply_fun u2 x) :e R.
					        { exact (real_minus_SNo (apply_fun u2 x) Hu2xR). }
					        rewrite (Hr2_apply x HxA).
					        claim Hr2xR: add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)) :e R.
					        { exact (real_add_SNo (apply_fun r1s x)
					                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r1s x) Hr1sI0)
					                              (minus_SNo (apply_fun u2 x)) Hm_u2x_R). }
					        claim H23R: two_thirds :e R.
					        { exact two_thirds_in_R. }
					        claim Hm23R: minus_SNo two_thirds :e R.
					        { exact (real_minus_SNo two_thirds H23R). }
					        claim Hr1s_bounds0: Rle (minus_SNo one_third) (apply_fun r1s x) /\ Rle (apply_fun r1s x) one_third.
					        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r1s x) Hm13R H13R Hr1sI0). }
					        claim Hu2_bounds0: Rle (minus_SNo one_third) (apply_fun u2 x) /\ Rle (apply_fun u2 x) one_third.
					        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u2 x) Hm13R H13R Hu2xI0). }
					        claim Hm13_le_r1s: Rle (minus_SNo one_third) (apply_fun r1s x).
					        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r1s x)) (Rle (apply_fun r1s x) one_third) Hr1s_bounds0). }
					        claim Hr1s_le_13: Rle (apply_fun r1s x) one_third.
					        { exact (andER (Rle (minus_SNo one_third) (apply_fun r1s x)) (Rle (apply_fun r1s x) one_third) Hr1s_bounds0). }
					        claim Hm13_le_u2x: Rle (minus_SNo one_third) (apply_fun u2 x).
					        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u2 x)) (Rle (apply_fun u2 x) one_third) Hu2_bounds0). }
					        claim Hu2x_le_13: Rle (apply_fun u2 x) one_third.
					        { exact (andER (Rle (minus_SNo one_third) (apply_fun u2 x)) (Rle (apply_fun u2 x) one_third) Hu2_bounds0). }
					        claim Hm13_le_mu2: Rle (minus_SNo one_third) (minus_SNo (apply_fun u2 x)).
					        { exact (Rle_minus_contra (apply_fun u2 x) one_third Hu2x_le_13). }
					        claim Hmu2_le_13: Rle (minus_SNo (apply_fun u2 x)) one_third.
					        { claim Htmp: Rle (minus_SNo (apply_fun u2 x)) (minus_SNo (minus_SNo one_third)).
					          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u2 x) Hm13_le_u2x). }
					          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
					          exact Htmp. }
					        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u2 x))).
					        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u2 x))
					                               Hm13R Hm13R Hm_u2x_R Hm13_le_mu2). }
					        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u2 x)))
					                      (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x))).
					        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r1s x) (minus_SNo (apply_fun u2 x))
					                               Hm13R
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r1s x) Hr1sI0)
					                               Hm_u2x_R
					                               Hm13_le_r1s). }
					        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                        (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x))).
					        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u2 x)))
					                         (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)))
					                         Hlow1 Hlow2). }
					        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x))).
					        { rewrite minus_two_thirds_eq at 1.
					          exact Hlow_tmp. }
					        claim Hup1: Rle (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)))
					                      (add_SNo (apply_fun r1s x) one_third).
					        { exact (Rle_add_SNo_2 (apply_fun r1s x) (minus_SNo (apply_fun u2 x)) one_third
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r1s x) Hr1sI0)
					                               Hm_u2x_R H13R Hmu2_le_13). }
					        claim Hup2: Rle (add_SNo (apply_fun r1s x) one_third)
					                      (add_SNo one_third one_third).
					        { exact (Rle_add_SNo_1 (apply_fun r1s x) one_third one_third
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r1s x) Hr1sI0)
					                               H13R H13R Hr1s_le_13). }
					        claim Hup_tmp: Rle (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)))
					                         (add_SNo one_third one_third).
					        { exact (Rle_tra (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)))
					                         (add_SNo (apply_fun r1s x) one_third)
					                         (add_SNo one_third one_third)
					                         Hup1 Hup2). }
					        claim Hup: Rle (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x))) two_thirds.
					        { claim Hdef23: two_thirds = add_SNo one_third one_third.
					          { reflexivity. }
					          rewrite Hdef23.
					          exact Hup_tmp. }
					        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                       (add_SNo (apply_fun r1s x) (minus_SNo (apply_fun u2 x)))
					                                       Hm23R H23R Hr2xR Hlow Hup). }
					  set r2s := compose_fun A r2 (div_const_fun den).
					  claim Hr2s_cont: continuous_map A Ta I Ti r2s.
					  { claim HRtop: topology_on R R_standard_topology.
					    { exact R_standard_topology_is_topology. }
					    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
					    { exact (div_const_fun_continuous_pos den H23R H23pos). }
					    claim Hr2s_contR: continuous_map A Ta R R_standard_topology r2s.
					    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
					             r2 (div_const_fun den) Hr2_cont Hdivcont). }
					    claim Hr2s_I: forall x:set, x :e A -> apply_fun r2s x :e I.
					    { let x. assume HxA: x :e A.
					      claim Hr2xI2: apply_fun r2 x :e I2.
					      { exact (Hr2_range x HxA). }
					      claim Hm1R: (minus_SNo 1) :e R.
					      { exact (real_minus_SNo 1 real_1). }
					      claim HmdenR: (minus_SNo den) :e R.
					      { exact (real_minus_SNo den H23R). }
					      claim Hr2xR: apply_fun r2 x :e R.
					      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r2 x) Hr2xI2). }
					      claim Hr2xS: SNo (apply_fun r2 x).
					      { exact (real_SNo (apply_fun r2 x) Hr2xR). }
					      claim Hbounds: Rle (minus_SNo den) (apply_fun r2 x) /\ Rle (apply_fun r2 x) den.
					      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r2 x) HmdenR H23R Hr2xI2). }
					      claim Hlo: Rle (minus_SNo den) (apply_fun r2 x).
					      { exact (andEL (Rle (minus_SNo den) (apply_fun r2 x))
					                     (Rle (apply_fun r2 x) den)
					                     Hbounds). }
					      claim Hhi: Rle (apply_fun r2 x) den.
					      { exact (andER (Rle (minus_SNo den) (apply_fun r2 x))
					                     (Rle (apply_fun r2 x) den)
					                     Hbounds). }
					      claim Hnlt_hi: ~(Rlt den (apply_fun r2 x)).
					      { exact (RleE_nlt (apply_fun r2 x) den Hhi). }
					      claim Hnlt_lo: ~(Rlt (apply_fun r2 x) (minus_SNo den)).
					      { exact (RleE_nlt (minus_SNo den) (apply_fun r2 x) Hlo). }
					      claim HyEq: apply_fun r2s x = div_SNo (apply_fun r2 x) den.
					      { rewrite (compose_fun_apply A r2 (div_const_fun den) x HxA).
					        rewrite (div_const_fun_apply den (apply_fun r2 x) H23R Hr2xR).
					        reflexivity. }
					      claim HyR: apply_fun r2s x :e R.
					      { rewrite HyEq.
					        exact (real_div_SNo (apply_fun r2 x) Hr2xR den H23R). }
					      claim HyS: SNo (apply_fun r2s x).
					      { exact (real_SNo (apply_fun r2s x) HyR). }
					      claim Hy_le_1: Rle (apply_fun r2s x) 1.
					      { apply (RleI (apply_fun r2s x) 1 HyR real_1).
					        prove ~(Rlt 1 (apply_fun r2s x)).
					        assume H1lt: Rlt 1 (apply_fun r2s x).
					        claim H1lty: 1 < apply_fun r2s x.
					        { exact (RltE_lt 1 (apply_fun r2s x) H1lt). }
					        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r2s x) den.
					        { exact (pos_mul_SNo_Lt' 1 (apply_fun r2s x) den SNo_1 HyS H23S H23pos H1lty). }
					        claim HmulLt': den < mul_SNo (apply_fun r2s x) den.
					        { rewrite <- (mul_SNo_oneL den H23S) at 1.
					          exact HmulLt. }
					        claim HmulEq: mul_SNo (apply_fun r2s x) den = apply_fun r2 x.
					        { rewrite HyEq at 1.
					          exact (mul_div_SNo_invL (apply_fun r2 x) den Hr2xS H23S H23ne0). }
					        claim Hden_lt_r2x: den < apply_fun r2 x.
					        { rewrite <- HmulEq.
					          exact HmulLt'. }
					        claim Hbad: Rlt den (apply_fun r2 x).
					        { exact (RltI den (apply_fun r2 x) H23R Hr2xR Hden_lt_r2x). }
					        exact (Hnlt_hi Hbad). }
					      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r2s x).
					      { apply (RleI (minus_SNo 1) (apply_fun r2s x) Hm1R HyR).
					        prove ~(Rlt (apply_fun r2s x) (minus_SNo 1)).
					        assume Hylt: Rlt (apply_fun r2s x) (minus_SNo 1).
					        claim Hylts: apply_fun r2s x < minus_SNo 1.
					        { exact (RltE_lt (apply_fun r2s x) (minus_SNo 1) Hylt). }
					        claim HmulLt: mul_SNo (apply_fun r2s x) den < mul_SNo (minus_SNo 1) den.
					        { exact (pos_mul_SNo_Lt' (apply_fun r2s x) (minus_SNo 1) den HyS
					                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
					        claim HmulEq: mul_SNo (apply_fun r2s x) den = apply_fun r2 x.
					        { rewrite HyEq at 1.
					          exact (mul_div_SNo_invL (apply_fun r2 x) den Hr2xS H23S H23ne0). }
					        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
					        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
					          rewrite (mul_SNo_oneL den H23S) at 1.
					          reflexivity. }
						        claim Hr2x_lt_mden: apply_fun r2 x < minus_SNo den.
						        { rewrite <- HmulEq.
						          rewrite <- HrhsEq.
						          exact HmulLt. }
					        claim Hbad: Rlt (apply_fun r2 x) (minus_SNo den).
					        { exact (RltI (apply_fun r2 x) (minus_SNo den) Hr2xR HmdenR Hr2x_lt_mden). }
					        exact (Hnlt_lo Hbad). }
					      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r2s x)
					                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
					    exact (continuous_map_range_restrict A Ta R R_standard_topology r2s I Hr2s_contR HIcR Hr2s_I). }
				  claim Hex_u3:
				    exists u3:set,
				      continuous_map X Tx I0 T0 u3 /\
				      (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
				        apply_fun u3 x = minus_SNo one_third) /\
				      (forall x:set, x :e preimage_of A r2s ((closed_interval one_third 1) :/\: I) ->
				        apply_fun u3 x = one_third).
				  { exact (Tietze_stepI_g_exists X Tx A r2s Hnorm HA Hr2s_cont). }
					  apply Hex_u3.
					  let u3. assume Hu3.
					  claim Hu3contI0: continuous_map X Tx I0 T0 u3.
					  { claim Hu3AB:
					      continuous_map X Tx I0 T0 u3 /\
					      (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					        apply_fun u3 x = minus_SNo one_third).
					    { exact (andEL
					        (continuous_map X Tx I0 T0 u3 /\
					         (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					           apply_fun u3 x = minus_SNo one_third))
					        (forall x:set, x :e preimage_of A r2s ((closed_interval one_third 1) :/\: I) ->
					          apply_fun u3 x = one_third)
					        Hu3). }
					    exact (andEL
					        (continuous_map X Tx I0 T0 u3)
					        (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					          apply_fun u3 x = minus_SNo one_third)
					        Hu3AB). }
					  claim Hu3contR: continuous_map X Tx R R_standard_topology u3.
					  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
					    { reflexivity. }
					    claim HI0subR: I0 c= R.
					    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
					    exact (continuous_map_range_expand
					             X Tx I0 T0
					             R R_standard_topology
					             u3
					             Hu3contI0
					             HI0subR
					             R_standard_topology_is_topology_local
					             HT0eq). }
					  set den3 := mul_SNo den2 den.
					  claim Hden3R: den3 :e R.
					  { exact (real_mul_SNo den2 Hden2R den HdenR). }
					  claim Hden3pos: 0 < den3.
					  { claim Hden2S: SNo den2.
					    { exact (real_SNo den2 Hden2R). }
					    exact (mul_SNo_pos_pos den2 den Hden2S H23S Hden2pos HdenPos). }
					  set u3s := compose_fun X u3 (mul_const_fun den3).
					  claim Hu3s_cont: continuous_map X Tx R R_standard_topology u3s.
					  { exact (scale_continuous_mul_const_pos X Tx u3 den3 HTx Hu3contR Hden3R Hden3pos). }
					  set g3 := compose_fun X (pair_map X g2 u3s) add_fun_R.
					  claim Hg3cont: continuous_map X Tx R R_standard_topology g3.
					  { exact (add_two_continuous_R X Tx g2 u3s HTx Hg2cont Hu3s_cont). }

					  (** fourth correction step scaffold: residual r3 on A, scaling r3s, and u4 **)
					  claim Hu3contA: continuous_map A Ta R R_standard_topology u3.
					  { exact (continuous_on_subspace X Tx R R_standard_topology u3 A HTx HAsubX Hu3contR). }
					  set u3neg := compose_fun A u3 neg_fun.
					  claim Hu3neg_cont: continuous_map A Ta R R_standard_topology u3neg.
					  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
					           u3 neg_fun Hu3contA Hnegcont). }
					  claim Hr2s_contR: continuous_map A Ta R R_standard_topology r2s.
					  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r2s
					           Hr2s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
					  set r3 := compose_fun A (pair_map A r2s u3neg) add_fun_R.
					  claim Hr3_cont: continuous_map A Ta R R_standard_topology r3.
					  { exact (add_two_continuous_R A Ta r2s u3neg HTa Hr2s_contR Hu3neg_cont). }
					  claim Hr3_apply: forall x:set, x :e A ->
					    apply_fun r3 x = add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)).
					  { let x. assume HxA: x :e A.
					    claim Hpimg: apply_fun (pair_map A r2s u3neg) x :e setprod R R.
					    { rewrite (pair_map_apply A R R r2s u3neg x HxA).
					      claim Hr2sRx: apply_fun r2s x :e R.
					      { exact (continuous_map_function_on A Ta R R_standard_topology r2s Hr2s_contR x HxA). }
					      claim Hu3negRx: apply_fun u3neg x :e R.
					      { exact (continuous_map_function_on A Ta R R_standard_topology u3neg Hu3neg_cont x HxA). }
					      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r2s x) (apply_fun u3neg x) Hr2sRx Hu3negRx). }
					    rewrite (compose_fun_apply A (pair_map A r2s u3neg) add_fun_R x HxA).
					    rewrite (add_fun_R_apply (apply_fun (pair_map A r2s u3neg) x) Hpimg) at 1.
					    rewrite (pair_map_apply A R R r2s u3neg x HxA).
					    rewrite (tuple_2_0_eq (apply_fun r2s x) (apply_fun u3neg x)).
					    rewrite (tuple_2_1_eq (apply_fun r2s x) (apply_fun u3neg x)).
					    rewrite (compose_fun_apply A u3 neg_fun x HxA) at 1.
					    claim Hu3Rx: apply_fun u3 x :e R.
					    { exact (continuous_map_function_on A Ta R R_standard_topology u3 Hu3contA x HxA). }
					    rewrite (neg_fun_apply (apply_fun u3 x) Hu3Rx) at 1.
					    reflexivity. }
					  claim Hr3_range: forall x:set, x :e A -> apply_fun r3 x :e I2.
					  { (** show the next residual stays within [-2/3,2/3] on A **)
					    claim Hu3AB:
					      continuous_map X Tx I0 T0 u3 /\
					      (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					        apply_fun u3 x = minus_SNo one_third).
					    { exact (andEL
					        (continuous_map X Tx I0 T0 u3 /\
					         (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					           apply_fun u3 x = minus_SNo one_third))
					        (forall x:set, x :e preimage_of A r2s ((closed_interval one_third 1) :/\: I) ->
					          apply_fun u3 x = one_third)
					        Hu3). }
					    claim Hu3_on_B3:
					      forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					        apply_fun u3 x = minus_SNo one_third.
					    { exact (andER
					        (continuous_map X Tx I0 T0 u3)
					        (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					          apply_fun u3 x = minus_SNo one_third)
					        Hu3AB). }
					    claim Hu3_on_C3:
					      forall x:set, x :e preimage_of A r2s ((closed_interval one_third 1) :/\: I) ->
					        apply_fun u3 x = one_third.
					    { exact (andER
					        (continuous_map X Tx I0 T0 u3 /\
					         (forall x:set, x :e preimage_of A r2s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
					           apply_fun u3 x = minus_SNo one_third))
					        (forall x:set, x :e preimage_of A r2s ((closed_interval one_third 1) :/\: I) ->
					          apply_fun u3 x = one_third)
					        Hu3). }
					    let x. assume HxA: x :e A.
					    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
					    set I3 := closed_interval one_third 1.
					    set B3 := preimage_of A r2s (I1 :/\: I).
					    set C3 := preimage_of A r2s (I3 :/\: I).
					    claim Hr2sIx: apply_fun r2s x :e I.
					    { exact (continuous_map_function_on A Ta I Ti r2s Hr2s_cont x HxA). }
					    claim HB3_cases: x :e B3 \/ ~(x :e B3).
					    { exact (xm (x :e B3)). }
					    apply (HB3_cases (apply_fun r3 x :e I2)).
					    - assume HxB3: x :e B3.
					      claim Hu3eq: apply_fun u3 x = minus_SNo one_third.
					      { exact (Hu3_on_B3 x HxB3). }
					      claim Hr3eq: apply_fun r3 x = add_SNo (apply_fun r2s x) one_third.
					      { rewrite (Hr3_apply x HxA).
					        rewrite Hu3eq at 1.
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
					        reflexivity. }
					      rewrite Hr3eq.
					      claim Hr2sI1I: apply_fun r2s x :e I1 :/\: I.
					      { exact (SepE2 A (fun x0:set => apply_fun r2s x0 :e I1 :/\: I) x HxB3). }
					      claim Hr2sI1: apply_fun r2s x :e I1.
					      { exact (binintersectE1 I1 I (apply_fun r2s x) Hr2sI1I). }
					      claim H13R: one_third :e R.
					      { exact one_third_in_R. }
					      claim H23R: two_thirds :e R.
					      { exact two_thirds_in_R. }
					      claim Hm23R: minus_SNo two_thirds :e R.
					      { exact (real_minus_SNo two_thirds H23R). }
					      claim Hm1R: minus_SNo 1 :e R.
					      { exact (real_minus_SNo 1 real_1). }
					      claim Hm13R: minus_SNo one_third :e R.
					      { exact (real_minus_SNo one_third H13R). }
					      claim Hr2sRx: apply_fun r2s x :e R.
					      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r2s x) Hr2sI1). }
					      claim Hr2s_bounds: Rle (minus_SNo 1) (apply_fun r2s x) /\ Rle (apply_fun r2s x) (minus_SNo one_third).
					      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r2s x)
					                                     Hm1R Hm13R Hr2sI1). }
					      claim Hm1le: Rle (minus_SNo 1) (apply_fun r2s x).
					      { exact (andEL (Rle (minus_SNo 1) (apply_fun r2s x))
					                     (Rle (apply_fun r2s x) (minus_SNo one_third)) Hr2s_bounds). }
					      claim HhiI1: Rle (apply_fun r2s x) (minus_SNo one_third).
					      { exact (andER (Rle (minus_SNo 1) (apply_fun r2s x))
					                     (Rle (apply_fun r2s x) (minus_SNo one_third)) Hr2s_bounds). }
					      claim Hr3Rx: add_SNo (apply_fun r2s x) one_third :e R.
					      { exact (real_add_SNo (apply_fun r2s x) Hr2sRx one_third H13R). }
					      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r2s x) one_third).
					      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r2s x) one_third Hm1R Hr2sRx H13R Hm1le). }
					      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r2s x) one_third).
					      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
					        exact Hlow_tmp. }
					      claim Hup0_tmp: Rle (add_SNo (apply_fun r2s x) one_third) (add_SNo (minus_SNo one_third) one_third).
					      { exact (Rle_add_SNo_1 (apply_fun r2s x) (minus_SNo one_third) one_third Hr2sRx Hm13R H13R HhiI1). }
					      claim H13S: SNo one_third.
					      { exact (real_SNo one_third H13R). }
					      claim Hup0: Rle (add_SNo (apply_fun r2s x) one_third) 0.
					      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
					        exact Hup0_tmp. }
					      claim H0le23: Rle 0 two_thirds.
					      { exact Rle_0_two_thirds. }
					      claim Hup: Rle (add_SNo (apply_fun r2s x) one_third) two_thirds.
					      { exact (Rle_tra (add_SNo (apply_fun r2s x) one_third) 0 two_thirds Hup0 H0le23). }
					      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                     (add_SNo (apply_fun r2s x) one_third)
					                                     Hm23R H23R Hr3Rx Hlow Hup).
					    - assume HxnotB3: ~(x :e B3).
					      claim HC3_cases: x :e C3 \/ ~(x :e C3).
					      { exact (xm (x :e C3)). }
					      apply (HC3_cases (apply_fun r3 x :e I2)).
					      + assume HxC3: x :e C3.
					        claim Hu3eq: apply_fun u3 x = one_third.
					        { exact (Hu3_on_C3 x HxC3). }
					        claim Hr3eq: apply_fun r3 x = add_SNo (apply_fun r2s x) (minus_SNo one_third).
					        { rewrite (Hr3_apply x HxA).
					          rewrite Hu3eq at 1.
					          reflexivity. }
					        rewrite Hr3eq.
					        claim Hr2sI3I: apply_fun r2s x :e I3 :/\: I.
					        { exact (SepE2 A (fun x0:set => apply_fun r2s x0 :e I3 :/\: I) x HxC3). }
					        claim Hr2sI3: apply_fun r2s x :e I3.
					        { exact (binintersectE1 I3 I (apply_fun r2s x) Hr2sI3I). }
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        claim H23R: two_thirds :e R.
					        { exact two_thirds_in_R. }
					        claim Hm23R: minus_SNo two_thirds :e R.
					        { exact (real_minus_SNo two_thirds H23R). }
					        claim Hm13R: minus_SNo one_third :e R.
					        { exact (real_minus_SNo one_third H13R). }
					        claim Hr2sRx: apply_fun r2s x :e R.
					        { exact (closed_interval_sub_R one_third 1 (apply_fun r2s x) Hr2sI3). }
					        claim Hr2s_bounds: Rle one_third (apply_fun r2s x) /\ Rle (apply_fun r2s x) 1.
					        { exact (closed_interval_bounds one_third 1 (apply_fun r2s x) H13R real_1 Hr2sI3). }
					        claim HloI3: Rle one_third (apply_fun r2s x).
					        { exact (andEL (Rle one_third (apply_fun r2s x)) (Rle (apply_fun r2s x) 1) Hr2s_bounds). }
					        claim HhiI3: Rle (apply_fun r2s x) 1.
					        { exact (andER (Rle one_third (apply_fun r2s x)) (Rle (apply_fun r2s x) 1) Hr2s_bounds). }
					        claim Hr3Rx: add_SNo (apply_fun r2s x) (minus_SNo one_third) :e R.
					        { exact (real_add_SNo (apply_fun r2s x) Hr2sRx (minus_SNo one_third) Hm13R). }
					        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
					                          (add_SNo (apply_fun r2s x) (minus_SNo one_third)).
					        { exact (Rle_add_SNo_1 one_third (apply_fun r2s x) (minus_SNo one_third)
					                               H13R Hr2sRx Hm13R HloI3). }
					        claim H13S: SNo one_third.
					        { exact (real_SNo one_third H13R). }
					        claim H0le: Rle 0 (add_SNo (apply_fun r2s x) (minus_SNo one_third)).
					        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
					          exact H0le_tmp. }
					        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
					        { exact Rle_minus_two_thirds_0. }
					        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r2s x) (minus_SNo one_third)).
					        { exact (Rle_tra (minus_SNo two_thirds) 0
					                         (add_SNo (apply_fun r2s x) (minus_SNo one_third))
					                         Hm23le0 H0le). }
					        claim Hup_tmp: Rle (add_SNo (apply_fun r2s x) (minus_SNo one_third))
					                         (add_SNo 1 (minus_SNo one_third)).
					        { exact (Rle_add_SNo_1 (apply_fun r2s x) 1 (minus_SNo one_third)
					                               Hr2sRx real_1 Hm13R HhiI3). }
					        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
					        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
					          exact (Rle_refl two_thirds H23R). }
					        claim Hup: Rle (add_SNo (apply_fun r2s x) (minus_SNo one_third)) two_thirds.
					        { exact (Rle_tra (add_SNo (apply_fun r2s x) (minus_SNo one_third))
					                         (add_SNo 1 (minus_SNo one_third))
					                         two_thirds
					                         Hup_tmp Hup1). }
					        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                       (add_SNo (apply_fun r2s x) (minus_SNo one_third))
					                                       Hm23R H23R Hr3Rx Hlow Hup).
					      + assume HxnotC3: ~(x :e C3).
					        claim HxX: x :e X.
					        { exact (HAsubX x HxA). }
					        claim HnotI1: ~(apply_fun r2s x :e I1).
					        { assume Hr2sI1': apply_fun r2s x :e I1.
					          claim Hr2sI1I: apply_fun r2s x :e I1 :/\: I.
					          { exact (binintersectI I1 I (apply_fun r2s x) Hr2sI1' Hr2sIx). }
					          claim HxB3': x :e B3.
					          { exact (SepI A (fun x0:set => apply_fun r2s x0 :e I1 :/\: I) x HxA Hr2sI1I). }
					          apply FalseE.
					          exact (HxnotB3 HxB3'). }
					        claim HnotI3: ~(apply_fun r2s x :e I3).
					        { assume Hr2sI3': apply_fun r2s x :e I3.
					          claim Hr2sI3I: apply_fun r2s x :e I3 :/\: I.
					          { exact (binintersectI I3 I (apply_fun r2s x) Hr2sI3' Hr2sIx). }
					          claim HxC3': x :e C3.
					          { exact (SepI A (fun x0:set => apply_fun r2s x0 :e I3 :/\: I) x HxA Hr2sI3I). }
					          apply FalseE.
					          exact (HxnotC3 HxC3'). }
					        claim Hr2sRx: apply_fun r2s x :e R.
					        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r2s x) Hr2sIx). }
					        claim Hm1R: minus_SNo 1 :e R.
					        { exact (real_minus_SNo 1 real_1). }
					        claim H13R: one_third :e R.
					        { exact one_third_in_R. }
					        claim Hm13R: minus_SNo one_third :e R.
					        { exact (real_minus_SNo one_third H13R). }
					        claim Hr2s_boundsI: Rle (minus_SNo 1) (apply_fun r2s x) /\ Rle (apply_fun r2s x) 1.
					        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r2s x) Hm1R real_1 Hr2sIx). }
					        claim Hnlt_fx_m1: ~(Rlt (apply_fun r2s x) (minus_SNo 1)).
					        { exact (RleE_nlt (minus_SNo 1) (apply_fun r2s x)
					                          (andEL (Rle (minus_SNo 1) (apply_fun r2s x)) (Rle (apply_fun r2s x) 1) Hr2s_boundsI)). }
					        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r2s x)).
					        { exact (RleE_nlt (apply_fun r2s x) 1
					                          (andER (Rle (minus_SNo 1) (apply_fun r2s x)) (Rle (apply_fun r2s x) 1) Hr2s_boundsI)). }
					        claim HnotI1_cases: Rlt (apply_fun r2s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r2s x).
					        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r2s x)
					                                              Hm1R Hm13R Hr2sRx HnotI1). }
					        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r2s x).
					        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r2s x))).
					          - assume Hbad: Rlt (apply_fun r2s x) (minus_SNo 1).
					            apply FalseE.
					            exact (Hnlt_fx_m1 Hbad).
					          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r2s x).
					            exact Hok. }
					        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r2s x) (minus_SNo one_third)).
					        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r2s x) Hm13lt_fx). }
					        claim HnotI3_cases: Rlt (apply_fun r2s x) one_third \/ Rlt 1 (apply_fun r2s x).
					        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r2s x)
					                                              H13R real_1 Hr2sRx HnotI3). }
					        claim Hfx_lt_13: Rlt (apply_fun r2s x) one_third.
					        { apply (HnotI3_cases (Rlt (apply_fun r2s x) one_third)).
					          - assume Hok: Rlt (apply_fun r2s x) one_third.
					            exact Hok.
					          - assume Hbad: Rlt 1 (apply_fun r2s x).
					            apply FalseE.
					            exact (Hnlt_1_fx Hbad). }
					        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r2s x)).
					        { exact (not_Rlt_sym (apply_fun r2s x) one_third Hfx_lt_13). }
					        claim Hr2sI0: apply_fun r2s x :e I0.
					        { claim HI0_def:
					            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
					          { reflexivity. }
					          claim HxSep: apply_fun r2s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
					          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
					                        (apply_fun r2s x) Hr2sRx (andI (~(Rlt (apply_fun r2s x) (minus_SNo one_third)))
					                                                      (~(Rlt one_third (apply_fun r2s x)))
					                                                      Hnot_fx_lt_m13
					                                                      Hnot_13_lt_fx)). }
					          rewrite HI0_def.
					          exact HxSep. }
					        claim Hu3funI0: function_on u3 X I0.
					        { exact (continuous_map_function_on X Tx I0 T0 u3 Hu3contI0). }
					        claim Hu3xI0: apply_fun u3 x :e I0.
					        { exact (Hu3funI0 x HxX). }
					        claim Hu3xR: apply_fun u3 x :e R.
					        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u3 x) Hu3xI0). }
					        claim Hm_u3x_R: minus_SNo (apply_fun u3 x) :e R.
					        { exact (real_minus_SNo (apply_fun u3 x) Hu3xR). }
					        rewrite (Hr3_apply x HxA).
					        claim Hr3xR: add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)) :e R.
					        { exact (real_add_SNo (apply_fun r2s x)
					                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r2s x) Hr2sI0)
					                              (minus_SNo (apply_fun u3 x)) Hm_u3x_R). }
					        claim H23R: two_thirds :e R.
					        { exact two_thirds_in_R. }
					        claim Hm23R: minus_SNo two_thirds :e R.
					        { exact (real_minus_SNo two_thirds H23R). }
					        claim Hr2s_bounds0: Rle (minus_SNo one_third) (apply_fun r2s x) /\ Rle (apply_fun r2s x) one_third.
					        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r2s x) Hm13R H13R Hr2sI0). }
					        claim Hu3_bounds0: Rle (minus_SNo one_third) (apply_fun u3 x) /\ Rle (apply_fun u3 x) one_third.
					        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u3 x) Hm13R H13R Hu3xI0). }
					        claim Hm13_le_r2s: Rle (minus_SNo one_third) (apply_fun r2s x).
					        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r2s x)) (Rle (apply_fun r2s x) one_third) Hr2s_bounds0). }
					        claim Hr2s_le_13: Rle (apply_fun r2s x) one_third.
					        { exact (andER (Rle (minus_SNo one_third) (apply_fun r2s x)) (Rle (apply_fun r2s x) one_third) Hr2s_bounds0). }
					        claim Hm13_le_u3x: Rle (minus_SNo one_third) (apply_fun u3 x).
					        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u3 x)) (Rle (apply_fun u3 x) one_third) Hu3_bounds0). }
					        claim Hu3x_le_13: Rle (apply_fun u3 x) one_third.
					        { exact (andER (Rle (minus_SNo one_third) (apply_fun u3 x)) (Rle (apply_fun u3 x) one_third) Hu3_bounds0). }
					        claim Hm13_le_mu3: Rle (minus_SNo one_third) (minus_SNo (apply_fun u3 x)).
					        { exact (Rle_minus_contra (apply_fun u3 x) one_third Hu3x_le_13). }
					        claim Hmu3_le_13: Rle (minus_SNo (apply_fun u3 x)) one_third.
					        { claim Htmp: Rle (minus_SNo (apply_fun u3 x)) (minus_SNo (minus_SNo one_third)).
					          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u3 x) Hm13_le_u3x). }
					          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
					          exact Htmp. }
					        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u3 x))).
					        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u3 x))
					                               Hm13R Hm13R Hm_u3x_R Hm13_le_mu3). }
					        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u3 x)))
					                      (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x))).
					        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r2s x) (minus_SNo (apply_fun u3 x))
					                               Hm13R
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r2s x) Hr2sI0)
					                               Hm_u3x_R
					                               Hm13_le_r2s). }
					        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                        (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x))).
					        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
					                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u3 x)))
					                         (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)))
					                         Hlow1 Hlow2). }
					        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x))).
					        { rewrite minus_two_thirds_eq at 1.
					          exact Hlow_tmp. }
					        claim Hup1: Rle (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)))
					                      (add_SNo (apply_fun r2s x) one_third).
					        { exact (Rle_add_SNo_2 (apply_fun r2s x) (minus_SNo (apply_fun u3 x)) one_third
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r2s x) Hr2sI0)
					                               Hm_u3x_R H13R Hmu3_le_13). }
					        claim Hup2: Rle (add_SNo (apply_fun r2s x) one_third)
					                      (add_SNo one_third one_third).
					        { exact (Rle_add_SNo_1 (apply_fun r2s x) one_third one_third
					                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r2s x) Hr2sI0)
					                               H13R H13R Hr2s_le_13). }
					        claim Hup_tmp: Rle (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)))
					                         (add_SNo one_third one_third).
					        { exact (Rle_tra (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)))
					                         (add_SNo (apply_fun r2s x) one_third)
					                         (add_SNo one_third one_third)
					                         Hup1 Hup2). }
					        claim Hdef23: two_thirds = add_SNo one_third one_third.
					        { reflexivity. }
					        claim Hup: Rle (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x))) two_thirds.
					        { rewrite Hdef23 at 1.
					          exact Hup_tmp. }
					        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
					                                       (add_SNo (apply_fun r2s x) (minus_SNo (apply_fun u3 x)))
					                                       Hm23R H23R Hr3xR Hlow Hup). }
						  set r3s := compose_fun A r3 (div_const_fun den).
						  claim Hr3s_cont: continuous_map A Ta I Ti r3s.
					  { claim HRtop: topology_on R R_standard_topology.
					    { exact R_standard_topology_is_topology. }
					    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
					    { exact (div_const_fun_continuous_pos den H23R H23pos). }
					    claim Hr3s_contR: continuous_map A Ta R R_standard_topology r3s.
					    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
					             r3 (div_const_fun den) Hr3_cont Hdivcont). }
					    claim Hr3s_I: forall x:set, x :e A -> apply_fun r3s x :e I.
					    { let x. assume HxA: x :e A.
					      claim Hr3xI2: apply_fun r3 x :e I2.
					      { exact (Hr3_range x HxA). }
					      claim Hm1R: (minus_SNo 1) :e R.
					      { exact (real_minus_SNo 1 real_1). }
					      claim HmdenR: (minus_SNo den) :e R.
					      { exact (real_minus_SNo den H23R). }
					      claim Hr3xR: apply_fun r3 x :e R.
					      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r3 x) Hr3xI2). }
					      claim Hr3xS: SNo (apply_fun r3 x).
					      { exact (real_SNo (apply_fun r3 x) Hr3xR). }
					      claim Hbounds: Rle (minus_SNo den) (apply_fun r3 x) /\ Rle (apply_fun r3 x) den.
					      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r3 x) HmdenR H23R Hr3xI2). }
					      claim Hlo: Rle (minus_SNo den) (apply_fun r3 x).
					      { exact (andEL (Rle (minus_SNo den) (apply_fun r3 x))
					                     (Rle (apply_fun r3 x) den)
					                     Hbounds). }
					      claim Hhi: Rle (apply_fun r3 x) den.
					      { exact (andER (Rle (minus_SNo den) (apply_fun r3 x))
					                     (Rle (apply_fun r3 x) den)
					                     Hbounds). }
					      claim Hnlt_hi: ~(Rlt den (apply_fun r3 x)).
					      { exact (RleE_nlt (apply_fun r3 x) den Hhi). }
					      claim Hnlt_lo: ~(Rlt (apply_fun r3 x) (minus_SNo den)).
					      { exact (RleE_nlt (minus_SNo den) (apply_fun r3 x) Hlo). }
					      claim HyEq: apply_fun r3s x = div_SNo (apply_fun r3 x) den.
					      { rewrite (compose_fun_apply A r3 (div_const_fun den) x HxA).
					        rewrite (div_const_fun_apply den (apply_fun r3 x) H23R Hr3xR).
					        reflexivity. }
					      claim HyR: apply_fun r3s x :e R.
					      { rewrite HyEq.
					        exact (real_div_SNo (apply_fun r3 x) Hr3xR den H23R). }
					      claim HyS: SNo (apply_fun r3s x).
					      { exact (real_SNo (apply_fun r3s x) HyR). }
					      claim Hy_le_1: Rle (apply_fun r3s x) 1.
					      { apply (RleI (apply_fun r3s x) 1 HyR real_1).
					        prove ~(Rlt 1 (apply_fun r3s x)).
					        assume H1lt: Rlt 1 (apply_fun r3s x).
					        claim H1lty: 1 < apply_fun r3s x.
					        { exact (RltE_lt 1 (apply_fun r3s x) H1lt). }
					        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r3s x) den.
					        { exact (pos_mul_SNo_Lt' 1 (apply_fun r3s x) den SNo_1 HyS H23S H23pos H1lty). }
					        claim HmulLt': den < mul_SNo (apply_fun r3s x) den.
					        { rewrite <- (mul_SNo_oneL den H23S) at 1.
					          exact HmulLt. }
					        claim HmulEq: mul_SNo (apply_fun r3s x) den = apply_fun r3 x.
					        { rewrite HyEq at 1.
					          exact (mul_div_SNo_invL (apply_fun r3 x) den Hr3xS H23S H23ne0). }
					        claim Hden_lt_r3x: den < apply_fun r3 x.
					        { rewrite <- HmulEq.
					          exact HmulLt'. }
					        claim Hbad: Rlt den (apply_fun r3 x).
					        { exact (RltI den (apply_fun r3 x) H23R Hr3xR Hden_lt_r3x). }
					        exact (Hnlt_hi Hbad). }
					      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r3s x).
					      { apply (RleI (minus_SNo 1) (apply_fun r3s x) Hm1R HyR).
					        prove ~(Rlt (apply_fun r3s x) (minus_SNo 1)).
					        assume Hylt: Rlt (apply_fun r3s x) (minus_SNo 1).
					        claim Hylts: apply_fun r3s x < minus_SNo 1.
					        { exact (RltE_lt (apply_fun r3s x) (minus_SNo 1) Hylt). }
					        claim HmulLt: mul_SNo (apply_fun r3s x) den < mul_SNo (minus_SNo 1) den.
					        { exact (pos_mul_SNo_Lt' (apply_fun r3s x) (minus_SNo 1) den HyS
					                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
					        claim HmulEq: mul_SNo (apply_fun r3s x) den = apply_fun r3 x.
					        { rewrite HyEq at 1.
					          exact (mul_div_SNo_invL (apply_fun r3 x) den Hr3xS H23S H23ne0). }
					        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
					        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
					          rewrite (mul_SNo_oneL den H23S) at 1.
					          reflexivity. }
					        claim Hr3x_lt_mden: apply_fun r3 x < minus_SNo den.
					        { rewrite <- HmulEq.
					          rewrite <- HrhsEq.
					          exact HmulLt. }
					        claim Hbad: Rlt (apply_fun r3 x) (minus_SNo den).
					        { exact (RltI (apply_fun r3 x) (minus_SNo den) Hr3xR HmdenR Hr3x_lt_mden). }
					        exact (Hnlt_lo Hbad). }
					      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r3s x)
					                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
						    exact (continuous_map_range_restrict A Ta R R_standard_topology r3s I Hr3s_contR HIcR Hr3s_I). }
	
						  (** fifth correction step scaffold: build u4 and g4 from residual r3s **)
						  claim Hex_u4:
						    exists u4:set,
						      continuous_map X Tx I0 T0 u4 /\
						      (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u4 x = minus_SNo one_third) /\
						      (forall x:set, x :e preimage_of A r3s ((closed_interval one_third 1) :/\: I) ->
						        apply_fun u4 x = one_third).
						  { exact (Tietze_stepI_g_exists X Tx A r3s Hnorm HA Hr3s_cont). }
						  apply Hex_u4.
						  let u4. assume Hu4.
						  claim Hu4contI0: continuous_map X Tx I0 T0 u4.
						  { claim Hu4AB:
						      continuous_map X Tx I0 T0 u4 /\
						      (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u4 x = minus_SNo one_third).
						    { exact (andEL
						        (continuous_map X Tx I0 T0 u4 /\
						         (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						           apply_fun u4 x = minus_SNo one_third))
						        (forall x:set, x :e preimage_of A r3s ((closed_interval one_third 1) :/\: I) ->
						          apply_fun u4 x = one_third)
						        Hu4). }
						    exact (andEL
						        (continuous_map X Tx I0 T0 u4)
						        (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						          apply_fun u4 x = minus_SNo one_third)
						        Hu4AB). }
						  claim Hu4contR: continuous_map X Tx R R_standard_topology u4.
						  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
						    { reflexivity. }
						    claim HI0subR: I0 c= R.
						    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
						    exact (continuous_map_range_expand
						             X Tx I0 T0
						             R R_standard_topology
						             u4
						             Hu4contI0
						             HI0subR
						             R_standard_topology_is_topology_local
						             HT0eq). }
						  set den4 := mul_SNo den3 den.
						  claim Hden4R: den4 :e R.
						  { exact (real_mul_SNo den3 Hden3R den H23R). }
						  claim Hden4pos: 0 < den4.
						  { claim Hden3S: SNo den3.
						    { exact (real_SNo den3 Hden3R). }
						    exact (mul_SNo_pos_pos den3 den Hden3S H23S Hden3pos HdenPos). }
						  set u4s := compose_fun X u4 (mul_const_fun den4).
						  claim Hu4s_cont: continuous_map X Tx R R_standard_topology u4s.
						  { exact (scale_continuous_mul_const_pos X Tx u4 den4 HTx Hu4contR Hden4R Hden4pos). }
						  set g4 := compose_fun X (pair_map X g3 u4s) add_fun_R.
						  claim Hg4cont: continuous_map X Tx R R_standard_topology g4.
						  { exact (add_two_continuous_R X Tx g3 u4s HTx Hg3cont Hu4s_cont). }

						  (** sixth correction step scaffold: residual r4 on A and scaling r4s **)
						  claim Hu4contA: continuous_map A Ta R R_standard_topology u4.
						  { exact (continuous_on_subspace X Tx R R_standard_topology u4 A HTx HAsubX Hu4contR). }
						  set u4neg := compose_fun A u4 neg_fun.
						  claim Hu4neg_cont: continuous_map A Ta R R_standard_topology u4neg.
						  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
						           u4 neg_fun Hu4contA Hnegcont). }
						  claim Hr3s_contR: continuous_map A Ta R R_standard_topology r3s.
						  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r3s
						           Hr3s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
						  set r4 := compose_fun A (pair_map A r3s u4neg) add_fun_R.
						  claim Hr4_cont: continuous_map A Ta R R_standard_topology r4.
						  { exact (add_two_continuous_R A Ta r3s u4neg HTa Hr3s_contR Hu4neg_cont). }
						  claim Hr4_apply: forall x:set, x :e A ->
						    apply_fun r4 x = add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)).
						  { let x. assume HxA: x :e A.
						    claim Hpimg: apply_fun (pair_map A r3s u4neg) x :e setprod R R.
						    { rewrite (pair_map_apply A R R r3s u4neg x HxA).
						      claim Hr3sxI: apply_fun r3s x :e I.
						      { exact (continuous_map_function_on A Ta I Ti r3s Hr3s_cont x HxA). }
						      claim Hr3sxR: apply_fun r3s x :e R.
						      { exact (HIcR (apply_fun r3s x) Hr3sxI). }
						      claim Hu4negRx: apply_fun u4neg x :e R.
						      { exact (continuous_map_function_on A Ta R R_standard_topology u4neg Hu4neg_cont x HxA). }
						      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r3s x) (apply_fun u4neg x) Hr3sxR Hu4negRx). }
						    rewrite (compose_fun_apply A (pair_map A r3s u4neg) add_fun_R x HxA).
						    rewrite (add_fun_R_apply (apply_fun (pair_map A r3s u4neg) x) Hpimg) at 1.
						    rewrite (pair_map_apply A R R r3s u4neg x HxA).
						    rewrite (tuple_2_0_eq (apply_fun r3s x) (apply_fun u4neg x)).
						    rewrite (tuple_2_1_eq (apply_fun r3s x) (apply_fun u4neg x)).
						    rewrite (compose_fun_apply A u4 neg_fun x HxA) at 1.
						    claim Hu4Rx: apply_fun u4 x :e R.
						    { exact (continuous_map_function_on A Ta R R_standard_topology u4 Hu4contA x HxA). }
						    rewrite (neg_fun_apply (apply_fun u4 x) Hu4Rx) at 1.
						    reflexivity. }
						  claim Hr4_range: forall x:set, x :e A -> apply_fun r4 x :e I2.
						  { (** show the next residual stays within [-2/3,2/3] on A **)
						    claim Hu4AB:
						      continuous_map X Tx I0 T0 u4 /\
						      (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u4 x = minus_SNo one_third).
						    { exact (andEL
						        (continuous_map X Tx I0 T0 u4 /\
						         (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						           apply_fun u4 x = minus_SNo one_third))
						        (forall x:set, x :e preimage_of A r3s ((closed_interval one_third 1) :/\: I) ->
						          apply_fun u4 x = one_third)
						        Hu4). }
						    claim Hu4_on_B4:
						      forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u4 x = minus_SNo one_third.
						    { exact (andER
						        (continuous_map X Tx I0 T0 u4)
						        (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						          apply_fun u4 x = minus_SNo one_third)
						        Hu4AB). }
						    claim Hu4_on_C4:
						      forall x:set, x :e preimage_of A r3s ((closed_interval one_third 1) :/\: I) ->
						        apply_fun u4 x = one_third.
						    { exact (andER
						        (continuous_map X Tx I0 T0 u4 /\
						         (forall x:set, x :e preimage_of A r3s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						           apply_fun u4 x = minus_SNo one_third))
						        (forall x:set, x :e preimage_of A r3s ((closed_interval one_third 1) :/\: I) ->
						          apply_fun u4 x = one_third)
						        Hu4). }
						    let x. assume HxA: x :e A.
						    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
						    set I3 := closed_interval one_third 1.
						    set B4 := preimage_of A r3s (I1 :/\: I).
						    set C4 := preimage_of A r3s (I3 :/\: I).
						    claim Hr3sIx: apply_fun r3s x :e I.
						    { exact (continuous_map_function_on A Ta I Ti r3s Hr3s_cont x HxA). }
						    claim HB4_cases: x :e B4 \/ ~(x :e B4).
						    { exact (xm (x :e B4)). }
						    apply (HB4_cases (apply_fun r4 x :e I2)).
						    - assume HxB4: x :e B4.
						      claim Hu4eq: apply_fun u4 x = minus_SNo one_third.
						      { exact (Hu4_on_B4 x HxB4). }
						      claim Hr4eq: apply_fun r4 x = add_SNo (apply_fun r3s x) one_third.
						      { rewrite (Hr4_apply x HxA).
						        rewrite Hu4eq at 1.
						        claim H13R: one_third :e R.
						        { exact one_third_in_R. }
						        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
						        reflexivity. }
						      rewrite Hr4eq.
						      claim Hr3sI1I: apply_fun r3s x :e I1 :/\: I.
						      { exact (SepE2 A (fun x0:set => apply_fun r3s x0 :e I1 :/\: I) x HxB4). }
						      claim Hr3sI1: apply_fun r3s x :e I1.
						      { exact (binintersectE1 I1 I (apply_fun r3s x) Hr3sI1I). }
						      claim H13R: one_third :e R.
						      { exact one_third_in_R. }
						      claim H23R: two_thirds :e R.
						      { exact two_thirds_in_R. }
						      claim Hm23R: minus_SNo two_thirds :e R.
						      { exact (real_minus_SNo two_thirds H23R). }
						      claim Hm1R: minus_SNo 1 :e R.
						      { exact (real_minus_SNo 1 real_1). }
						      claim Hm13R: minus_SNo one_third :e R.
						      { exact (real_minus_SNo one_third H13R). }
						      claim Hr3sRx: apply_fun r3s x :e R.
						      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r3s x) Hr3sI1). }
						      claim Hr3s_bounds: Rle (minus_SNo 1) (apply_fun r3s x) /\ Rle (apply_fun r3s x) (minus_SNo one_third).
						      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r3s x)
						                                     Hm1R Hm13R Hr3sI1). }
						      claim Hm1le: Rle (minus_SNo 1) (apply_fun r3s x).
						      { exact (andEL (Rle (minus_SNo 1) (apply_fun r3s x))
						                     (Rle (apply_fun r3s x) (minus_SNo one_third)) Hr3s_bounds). }
						      claim HhiI1: Rle (apply_fun r3s x) (minus_SNo one_third).
						      { exact (andER (Rle (minus_SNo 1) (apply_fun r3s x))
						                     (Rle (apply_fun r3s x) (minus_SNo one_third)) Hr3s_bounds). }
						      claim Hr4Rx: add_SNo (apply_fun r3s x) one_third :e R.
						      { exact (real_add_SNo (apply_fun r3s x) Hr3sRx one_third H13R). }
						      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r3s x) one_third).
						      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r3s x) one_third Hm1R Hr3sRx H13R Hm1le). }
						      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r3s x) one_third).
						      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
						        exact Hlow_tmp. }
						      claim Hup0_tmp: Rle (add_SNo (apply_fun r3s x) one_third) (add_SNo (minus_SNo one_third) one_third).
						      { exact (Rle_add_SNo_1 (apply_fun r3s x) (minus_SNo one_third) one_third Hr3sRx Hm13R H13R HhiI1). }
						      claim H13S: SNo one_third.
						      { exact (real_SNo one_third H13R). }
						      claim Hup0: Rle (add_SNo (apply_fun r3s x) one_third) 0.
						      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
						        exact Hup0_tmp. }
						      claim H0le23: Rle 0 two_thirds.
						      { exact Rle_0_two_thirds. }
						      claim Hup: Rle (add_SNo (apply_fun r3s x) one_third) two_thirds.
						      { exact (Rle_tra (add_SNo (apply_fun r3s x) one_third) 0 two_thirds Hup0 H0le23). }
						      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
						                                     (add_SNo (apply_fun r3s x) one_third)
						                                     Hm23R H23R Hr4Rx Hlow Hup).
						    - assume HxnotB4: ~(x :e B4).
						      claim HC4_cases: x :e C4 \/ ~(x :e C4).
						      { exact (xm (x :e C4)). }
						      apply (HC4_cases (apply_fun r4 x :e I2)).
						      + assume HxC4: x :e C4.
						        claim Hu4eq: apply_fun u4 x = one_third.
						        { exact (Hu4_on_C4 x HxC4). }
						        claim Hr4eq: apply_fun r4 x = add_SNo (apply_fun r3s x) (minus_SNo one_third).
						        { rewrite (Hr4_apply x HxA).
						          rewrite Hu4eq at 1.
						          reflexivity. }
						        rewrite Hr4eq.
						        claim Hr3sI3I: apply_fun r3s x :e I3 :/\: I.
						        { exact (SepE2 A (fun x0:set => apply_fun r3s x0 :e I3 :/\: I) x HxC4). }
						        claim Hr3sI3: apply_fun r3s x :e I3.
						        { exact (binintersectE1 I3 I (apply_fun r3s x) Hr3sI3I). }
						        claim H13R: one_third :e R.
						        { exact one_third_in_R. }
						        claim H23R: two_thirds :e R.
						        { exact two_thirds_in_R. }
						        claim Hm23R: minus_SNo two_thirds :e R.
						        { exact (real_minus_SNo two_thirds H23R). }
						        claim Hm13R: minus_SNo one_third :e R.
						        { exact (real_minus_SNo one_third H13R). }
						        claim Hr3sRx: apply_fun r3s x :e R.
						        { exact (closed_interval_sub_R one_third 1 (apply_fun r3s x) Hr3sI3). }
						        claim Hr3s_bounds: Rle one_third (apply_fun r3s x) /\ Rle (apply_fun r3s x) 1.
						        { exact (closed_interval_bounds one_third 1 (apply_fun r3s x) H13R real_1 Hr3sI3). }
						        claim HloI3: Rle one_third (apply_fun r3s x).
						        { exact (andEL (Rle one_third (apply_fun r3s x)) (Rle (apply_fun r3s x) 1) Hr3s_bounds). }
						        claim HhiI3: Rle (apply_fun r3s x) 1.
						        { exact (andER (Rle one_third (apply_fun r3s x)) (Rle (apply_fun r3s x) 1) Hr3s_bounds). }
						        claim Hr4Rx: add_SNo (apply_fun r3s x) (minus_SNo one_third) :e R.
						        { exact (real_add_SNo (apply_fun r3s x) Hr3sRx (minus_SNo one_third) Hm13R). }
						        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
						                          (add_SNo (apply_fun r3s x) (minus_SNo one_third)).
						        { exact (Rle_add_SNo_1 one_third (apply_fun r3s x) (minus_SNo one_third)
						                               H13R Hr3sRx Hm13R HloI3). }
						        claim H13S: SNo one_third.
						        { exact (real_SNo one_third H13R). }
						        claim H0le: Rle 0 (add_SNo (apply_fun r3s x) (minus_SNo one_third)).
						        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
						          exact H0le_tmp. }
						        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
						        { exact Rle_minus_two_thirds_0. }
						        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r3s x) (minus_SNo one_third)).
						        { exact (Rle_tra (minus_SNo two_thirds) 0
						                         (add_SNo (apply_fun r3s x) (minus_SNo one_third))
						                         Hm23le0 H0le). }
						        claim Hup_tmp: Rle (add_SNo (apply_fun r3s x) (minus_SNo one_third))
						                         (add_SNo 1 (minus_SNo one_third)).
						        { exact (Rle_add_SNo_1 (apply_fun r3s x) 1 (minus_SNo one_third)
						                               Hr3sRx real_1 Hm13R HhiI3). }
						        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
						        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
						          exact (Rle_refl two_thirds H23R). }
						        claim Hup: Rle (add_SNo (apply_fun r3s x) (minus_SNo one_third)) two_thirds.
						        { exact (Rle_tra (add_SNo (apply_fun r3s x) (minus_SNo one_third))
						                         (add_SNo 1 (minus_SNo one_third))
						                         two_thirds
						                         Hup_tmp Hup1). }
						        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
						                                       (add_SNo (apply_fun r3s x) (minus_SNo one_third))
						                                       Hm23R H23R Hr4Rx Hlow Hup).
						      + assume HxnotC4: ~(x :e C4).
						        claim HxX: x :e X.
						        { exact (HAsubX x HxA). }
						        claim HnotI1: ~(apply_fun r3s x :e I1).
						        { assume Hr3sI1': apply_fun r3s x :e I1.
						          claim Hr3sI1I: apply_fun r3s x :e I1 :/\: I.
						          { exact (binintersectI I1 I (apply_fun r3s x) Hr3sI1' Hr3sIx). }
						          claim HxB4': x :e B4.
						          { exact (SepI A (fun x0:set => apply_fun r3s x0 :e I1 :/\: I) x HxA Hr3sI1I). }
						          apply FalseE.
						          exact (HxnotB4 HxB4'). }
						        claim HnotI3: ~(apply_fun r3s x :e I3).
						        { assume Hr3sI3': apply_fun r3s x :e I3.
						          claim Hr3sI3I: apply_fun r3s x :e I3 :/\: I.
						          { exact (binintersectI I3 I (apply_fun r3s x) Hr3sI3' Hr3sIx). }
						          claim HxC4': x :e C4.
						          { exact (SepI A (fun x0:set => apply_fun r3s x0 :e I3 :/\: I) x HxA Hr3sI3I). }
						          apply FalseE.
						          exact (HxnotC4 HxC4'). }
						        claim Hr3sRx: apply_fun r3s x :e R.
						        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r3s x) Hr3sIx). }
						        claim Hm1R: minus_SNo 1 :e R.
						        { exact (real_minus_SNo 1 real_1). }
						        claim H13R: one_third :e R.
						        { exact one_third_in_R. }
						        claim Hm13R: minus_SNo one_third :e R.
						        { exact (real_minus_SNo one_third H13R). }
						        claim Hr3s_boundsI: Rle (minus_SNo 1) (apply_fun r3s x) /\ Rle (apply_fun r3s x) 1.
						        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r3s x) Hm1R real_1 Hr3sIx). }
						        claim Hnlt_fx_m1: ~(Rlt (apply_fun r3s x) (minus_SNo 1)).
						        { exact (RleE_nlt (minus_SNo 1) (apply_fun r3s x)
						                          (andEL (Rle (minus_SNo 1) (apply_fun r3s x)) (Rle (apply_fun r3s x) 1) Hr3s_boundsI)). }
						        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r3s x)).
						        { exact (RleE_nlt (apply_fun r3s x) 1
						                          (andER (Rle (minus_SNo 1) (apply_fun r3s x)) (Rle (apply_fun r3s x) 1) Hr3s_boundsI)). }
						        claim HnotI1_cases: Rlt (apply_fun r3s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r3s x).
						        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r3s x)
						                                              Hm1R Hm13R Hr3sRx HnotI1). }
						        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r3s x).
						        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r3s x))).
						          - assume Hbad: Rlt (apply_fun r3s x) (minus_SNo 1).
						            apply FalseE.
						            exact (Hnlt_fx_m1 Hbad).
						          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r3s x).
						            exact Hok. }
						        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r3s x) (minus_SNo one_third)).
						        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r3s x) Hm13lt_fx). }
						        claim HnotI3_cases: Rlt (apply_fun r3s x) one_third \/ Rlt 1 (apply_fun r3s x).
						        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r3s x)
						                                              H13R real_1 Hr3sRx HnotI3). }
						        claim Hfx_lt_13: Rlt (apply_fun r3s x) one_third.
						        { apply (HnotI3_cases (Rlt (apply_fun r3s x) one_third)).
						          - assume Hok: Rlt (apply_fun r3s x) one_third.
						            exact Hok.
						          - assume Hbad: Rlt 1 (apply_fun r3s x).
						            apply FalseE.
						            exact (Hnlt_1_fx Hbad). }
						        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r3s x)).
						        { exact (not_Rlt_sym (apply_fun r3s x) one_third Hfx_lt_13). }
						        claim Hr3sI0: apply_fun r3s x :e I0.
						        { claim HI0_def:
						            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
						          { reflexivity. }
						          claim HxSep: apply_fun r3s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
						          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
						                        (apply_fun r3s x) Hr3sRx (andI (~(Rlt (apply_fun r3s x) (minus_SNo one_third)))
						                                                      (~(Rlt one_third (apply_fun r3s x)))
						                                                      Hnot_fx_lt_m13
						                                                      Hnot_13_lt_fx)). }
						          rewrite HI0_def.
						          exact HxSep. }
						        claim Hu4funI0: function_on u4 X I0.
						        { exact (continuous_map_function_on X Tx I0 T0 u4 Hu4contI0). }
						        claim Hu4xI0: apply_fun u4 x :e I0.
						        { exact (Hu4funI0 x HxX). }
						        claim Hu4xR: apply_fun u4 x :e R.
						        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u4 x) Hu4xI0). }
						        claim Hm_u4x_R: minus_SNo (apply_fun u4 x) :e R.
						        { exact (real_minus_SNo (apply_fun u4 x) Hu4xR). }
						        rewrite (Hr4_apply x HxA).
						        claim Hr4xR: add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)) :e R.
						        { exact (real_add_SNo (apply_fun r3s x)
						                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r3s x) Hr3sI0)
						                              (minus_SNo (apply_fun u4 x)) Hm_u4x_R). }
						        claim H23R: two_thirds :e R.
						        { exact two_thirds_in_R. }
						        claim Hm23R: minus_SNo two_thirds :e R.
						        { exact (real_minus_SNo two_thirds H23R). }
						        claim Hr3s_bounds0: Rle (minus_SNo one_third) (apply_fun r3s x) /\ Rle (apply_fun r3s x) one_third.
						        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r3s x) Hm13R H13R Hr3sI0). }
						        claim Hu4_bounds0: Rle (minus_SNo one_third) (apply_fun u4 x) /\ Rle (apply_fun u4 x) one_third.
						        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u4 x) Hm13R H13R Hu4xI0). }
						        claim Hm13_le_r3s: Rle (minus_SNo one_third) (apply_fun r3s x).
						        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r3s x)) (Rle (apply_fun r3s x) one_third) Hr3s_bounds0). }
						        claim Hr3s_le_13: Rle (apply_fun r3s x) one_third.
						        { exact (andER (Rle (minus_SNo one_third) (apply_fun r3s x)) (Rle (apply_fun r3s x) one_third) Hr3s_bounds0). }
						        claim Hm13_le_u4x: Rle (minus_SNo one_third) (apply_fun u4 x).
						        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u4 x)) (Rle (apply_fun u4 x) one_third) Hu4_bounds0). }
						        claim Hu4x_le_13: Rle (apply_fun u4 x) one_third.
						        { exact (andER (Rle (minus_SNo one_third) (apply_fun u4 x)) (Rle (apply_fun u4 x) one_third) Hu4_bounds0). }
						        claim Hm13_le_mu4: Rle (minus_SNo one_third) (minus_SNo (apply_fun u4 x)).
						        { exact (Rle_minus_contra (apply_fun u4 x) one_third Hu4x_le_13). }
						        claim Hmu4_le_13: Rle (minus_SNo (apply_fun u4 x)) one_third.
						        { claim Htmp: Rle (minus_SNo (apply_fun u4 x)) (minus_SNo (minus_SNo one_third)).
						          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u4 x) Hm13_le_u4x). }
						          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
						          exact Htmp. }
						        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
						                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u4 x))).
						        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u4 x))
						                               Hm13R Hm13R Hm_u4x_R Hm13_le_mu4). }
						        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u4 x)))
						                      (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x))).
						        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r3s x) (minus_SNo (apply_fun u4 x))
						                               Hm13R
						                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r3s x) Hr3sI0)
						                               Hm_u4x_R
						                               Hm13_le_r3s). }
						        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
						                        (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x))).
						        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
						                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u4 x)))
						                         (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)))
						                         Hlow1 Hlow2). }
						        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x))).
						        { rewrite minus_two_thirds_eq at 1.
						          exact Hlow_tmp. }
						        claim Hup1: Rle (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)))
						                      (add_SNo (apply_fun r3s x) one_third).
						        { exact (Rle_add_SNo_2 (apply_fun r3s x) (minus_SNo (apply_fun u4 x)) one_third
						                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r3s x) Hr3sI0)
						                               Hm_u4x_R H13R Hmu4_le_13). }
						        claim Hup2: Rle (add_SNo (apply_fun r3s x) one_third)
						                      (add_SNo one_third one_third).
						        { exact (Rle_add_SNo_1 (apply_fun r3s x) one_third one_third
						                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r3s x) Hr3sI0)
						                               H13R H13R Hr3s_le_13). }
						        claim Hup_tmp: Rle (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)))
						                         (add_SNo one_third one_third).
						        { exact (Rle_tra (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)))
						                         (add_SNo (apply_fun r3s x) one_third)
						                         (add_SNo one_third one_third)
						                         Hup1 Hup2). }
						        claim Hdef23: two_thirds = add_SNo one_third one_third.
						        { reflexivity. }
						        claim Hup: Rle (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x))) two_thirds.
						        { rewrite Hdef23 at 1.
						          exact Hup_tmp. }
						        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
						                                       (add_SNo (apply_fun r3s x) (minus_SNo (apply_fun u4 x)))
						                                       Hm23R H23R Hr4xR Hlow Hup). }
							  set r4s := compose_fun A r4 (div_const_fun den).
							  claim Hr4s_cont: continuous_map A Ta I Ti r4s.
						  { claim HRtop: topology_on R R_standard_topology.
						    { exact R_standard_topology_is_topology. }
						    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
						    { exact (div_const_fun_continuous_pos den H23R H23pos). }
						    claim Hr4s_contR: continuous_map A Ta R R_standard_topology r4s.
						    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
						             r4 (div_const_fun den) Hr4_cont Hdivcont). }
						    claim Hr4s_I: forall x:set, x :e A -> apply_fun r4s x :e I.
						    { let x. assume HxA: x :e A.
						      claim Hr4xI2: apply_fun r4 x :e I2.
						      { exact (Hr4_range x HxA). }
						      claim Hm1R: (minus_SNo 1) :e R.
						      { exact (real_minus_SNo 1 real_1). }
						      claim HmdenR: (minus_SNo den) :e R.
						      { exact (real_minus_SNo den H23R). }
						      claim Hr4xR: apply_fun r4 x :e R.
						      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r4 x) Hr4xI2). }
						      claim Hr4xS: SNo (apply_fun r4 x).
						      { exact (real_SNo (apply_fun r4 x) Hr4xR). }
						      claim Hbounds: Rle (minus_SNo den) (apply_fun r4 x) /\ Rle (apply_fun r4 x) den.
						      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r4 x) HmdenR H23R Hr4xI2). }
						      claim Hlo: Rle (minus_SNo den) (apply_fun r4 x).
						      { exact (andEL (Rle (minus_SNo den) (apply_fun r4 x))
						                     (Rle (apply_fun r4 x) den)
						                     Hbounds). }
						      claim Hhi: Rle (apply_fun r4 x) den.
						      { exact (andER (Rle (minus_SNo den) (apply_fun r4 x))
						                     (Rle (apply_fun r4 x) den)
						                     Hbounds). }
						      claim Hnlt_hi: ~(Rlt den (apply_fun r4 x)).
						      { exact (RleE_nlt (apply_fun r4 x) den Hhi). }
						      claim Hnlt_lo: ~(Rlt (apply_fun r4 x) (minus_SNo den)).
						      { exact (RleE_nlt (minus_SNo den) (apply_fun r4 x) Hlo). }
						      claim HyEq: apply_fun r4s x = div_SNo (apply_fun r4 x) den.
						      { rewrite (compose_fun_apply A r4 (div_const_fun den) x HxA).
						        rewrite (div_const_fun_apply den (apply_fun r4 x) H23R Hr4xR).
						        reflexivity. }
						      claim HyR: apply_fun r4s x :e R.
						      { rewrite HyEq.
						        exact (real_div_SNo (apply_fun r4 x) Hr4xR den H23R). }
						      claim HyS: SNo (apply_fun r4s x).
						      { exact (real_SNo (apply_fun r4s x) HyR). }
						      claim Hy_le_1: Rle (apply_fun r4s x) 1.
						      { apply (RleI (apply_fun r4s x) 1 HyR real_1).
						        prove ~(Rlt 1 (apply_fun r4s x)).
						        assume H1lt: Rlt 1 (apply_fun r4s x).
						        claim H1lty: 1 < apply_fun r4s x.
						        { exact (RltE_lt 1 (apply_fun r4s x) H1lt). }
						        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r4s x) den.
						        { exact (pos_mul_SNo_Lt' 1 (apply_fun r4s x) den SNo_1 HyS H23S H23pos H1lty). }
						        claim HmulLt': den < mul_SNo (apply_fun r4s x) den.
						        { rewrite <- (mul_SNo_oneL den H23S) at 1.
						          exact HmulLt. }
						        claim HmulEq: mul_SNo (apply_fun r4s x) den = apply_fun r4 x.
						        { rewrite HyEq at 1.
						          exact (mul_div_SNo_invL (apply_fun r4 x) den Hr4xS H23S H23ne0). }
						        claim Hden_lt_r4x: den < apply_fun r4 x.
						        { rewrite <- HmulEq.
						          exact HmulLt'. }
						        claim Hbad: Rlt den (apply_fun r4 x).
						        { exact (RltI den (apply_fun r4 x) H23R Hr4xR Hden_lt_r4x). }
						        exact (Hnlt_hi Hbad). }
						      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r4s x).
						      { apply (RleI (minus_SNo 1) (apply_fun r4s x) Hm1R HyR).
						        prove ~(Rlt (apply_fun r4s x) (minus_SNo 1)).
						        assume Hylt: Rlt (apply_fun r4s x) (minus_SNo 1).
						        claim Hylts: apply_fun r4s x < minus_SNo 1.
						        { exact (RltE_lt (apply_fun r4s x) (minus_SNo 1) Hylt). }
						        claim HmulLt: mul_SNo (apply_fun r4s x) den < mul_SNo (minus_SNo 1) den.
						        { exact (pos_mul_SNo_Lt' (apply_fun r4s x) (minus_SNo 1) den HyS
						                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
						        claim HmulEq: mul_SNo (apply_fun r4s x) den = apply_fun r4 x.
						        { rewrite HyEq at 1.
						          exact (mul_div_SNo_invL (apply_fun r4 x) den Hr4xS H23S H23ne0). }
						        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
						        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
						          rewrite (mul_SNo_oneL den H23S) at 1.
						          reflexivity. }
						        claim Hr4x_lt_mden: apply_fun r4 x < minus_SNo den.
						        { rewrite <- HmulEq.
						          rewrite <- HrhsEq.
						          exact HmulLt. }
						        claim Hbad: Rlt (apply_fun r4 x) (minus_SNo den).
						        { exact (RltI (apply_fun r4 x) (minus_SNo den) Hr4xR HmdenR Hr4x_lt_mden). }
						        exact (Hnlt_lo Hbad). }
						      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r4s x)
						                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
						    exact (continuous_map_range_restrict A Ta R R_standard_topology r4s I Hr4s_contR HIcR Hr4s_I). }

						  (** seventh correction step scaffold: build u5 and g5 from residual r4s **)
						  claim Hex_u5:
						    exists u5:set,
						      continuous_map X Tx I0 T0 u5 /\
						      (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u5 x = minus_SNo one_third) /\
						      (forall x:set, x :e preimage_of A r4s ((closed_interval one_third 1) :/\: I) ->
						        apply_fun u5 x = one_third).
						  { exact (Tietze_stepI_g_exists X Tx A r4s Hnorm HA Hr4s_cont). }
						  apply Hex_u5.
						  let u5. assume Hu5.
						  claim Hu5contI0: continuous_map X Tx I0 T0 u5.
						  { claim Hu5AB:
						      continuous_map X Tx I0 T0 u5 /\
						      (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						        apply_fun u5 x = minus_SNo one_third).
						    { exact (andEL
						        (continuous_map X Tx I0 T0 u5 /\
						         (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						           apply_fun u5 x = minus_SNo one_third))
						        (forall x:set, x :e preimage_of A r4s ((closed_interval one_third 1) :/\: I) ->
						          apply_fun u5 x = one_third)
						        Hu5). }
						    exact (andEL
						        (continuous_map X Tx I0 T0 u5)
						        (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
						          apply_fun u5 x = minus_SNo one_third)
						        Hu5AB). }
						  claim Hu5contR: continuous_map X Tx R R_standard_topology u5.
						  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
						    { reflexivity. }
						    claim HI0subR: I0 c= R.
						    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
						    exact (continuous_map_range_expand
						             X Tx I0 T0
						             R R_standard_topology
						             u5
						             Hu5contI0
						             HI0subR
						             R_standard_topology_is_topology_local
						             HT0eq). }
						  set den5 := mul_SNo den4 den.
						  claim Hden5R: den5 :e R.
						  { exact (real_mul_SNo den4 Hden4R den H23R). }
						  claim Hden5pos: 0 < den5.
						  { claim Hden4S: SNo den4.
						    { exact (real_SNo den4 Hden4R). }
						    exact (mul_SNo_pos_pos den4 den Hden4S H23S Hden4pos HdenPos). }
						  set u5s := compose_fun X u5 (mul_const_fun den5).
						  claim Hu5s_cont: continuous_map X Tx R R_standard_topology u5s.
						  { exact (scale_continuous_mul_const_pos X Tx u5 den5 HTx Hu5contR Hden5R Hden5pos). }
						  set g5 := compose_fun X (pair_map X g4 u5s) add_fun_R.
						  claim Hg5cont: continuous_map X Tx R R_standard_topology g5.
						  { exact (add_two_continuous_R X Tx g4 u5s HTx Hg4cont Hu5s_cont). }

						  (** eighth correction step scaffold: residual r5 on A and scaling r5s **)
						  claim Hu5contA: continuous_map A Ta R R_standard_topology u5.
						  { exact (continuous_on_subspace X Tx R R_standard_topology u5 A HTx HAsubX Hu5contR). }
						  set u5neg := compose_fun A u5 neg_fun.
						  claim Hu5neg_cont: continuous_map A Ta R R_standard_topology u5neg.
						  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
						           u5 neg_fun Hu5contA Hnegcont). }
						  claim Hr4s_contR: continuous_map A Ta R R_standard_topology r4s.
						  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r4s
						           Hr4s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
						  set r5 := compose_fun A (pair_map A r4s u5neg) add_fun_R.
						  claim Hr5_cont: continuous_map A Ta R R_standard_topology r5.
						  { exact (add_two_continuous_R A Ta r4s u5neg HTa Hr4s_contR Hu5neg_cont). }
							  claim Hr5_apply: forall x:set, x :e A ->
							    apply_fun r5 x = add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)).
							  { let x. assume HxA: x :e A.
							    claim Hpimg: apply_fun (pair_map A r4s u5neg) x :e setprod R R.
							    { rewrite (pair_map_apply A R R r4s u5neg x HxA).
							      claim Hr4sxI: apply_fun r4s x :e I.
							      { exact (continuous_map_function_on A Ta I Ti r4s Hr4s_cont x HxA). }
							      claim Hr4sxR: apply_fun r4s x :e R.
							      { exact (HIcR (apply_fun r4s x) Hr4sxI). }
							      claim Hu5negRx: apply_fun u5neg x :e R.
							      { exact (continuous_map_function_on A Ta R R_standard_topology u5neg Hu5neg_cont x HxA). }
							      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r4s x) (apply_fun u5neg x) Hr4sxR Hu5negRx). }
							    rewrite (compose_fun_apply A (pair_map A r4s u5neg) add_fun_R x HxA).
							    rewrite (add_fun_R_apply (apply_fun (pair_map A r4s u5neg) x) Hpimg) at 1.
							    rewrite (pair_map_apply A R R r4s u5neg x HxA).
							    rewrite (tuple_2_0_eq (apply_fun r4s x) (apply_fun u5neg x)).
							    rewrite (tuple_2_1_eq (apply_fun r4s x) (apply_fun u5neg x)).
							    rewrite (compose_fun_apply A u5 neg_fun x HxA) at 1.
							    claim Hu5Rx: apply_fun u5 x :e R.
							    { exact (continuous_map_function_on A Ta R R_standard_topology u5 Hu5contA x HxA). }
							    rewrite (neg_fun_apply (apply_fun u5 x) Hu5Rx) at 1.
							    reflexivity. }
							  claim Hr5_range: forall x:set, x :e A -> apply_fun r5 x :e I2.
							  { (** show the next residual stays within [-2/3,2/3] on A **)
							    claim Hu5AB:
							      continuous_map X Tx I0 T0 u5 /\
							      (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
							        apply_fun u5 x = minus_SNo one_third).
							    { exact (andEL
							        (continuous_map X Tx I0 T0 u5 /\
							         (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
							           apply_fun u5 x = minus_SNo one_third))
							        (forall x:set, x :e preimage_of A r4s ((closed_interval one_third 1) :/\: I) ->
							          apply_fun u5 x = one_third)
							        Hu5). }
							    claim Hu5_on_B5:
							      forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
							        apply_fun u5 x = minus_SNo one_third.
							    { exact (andER
							        (continuous_map X Tx I0 T0 u5)
							        (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
							          apply_fun u5 x = minus_SNo one_third)
							        Hu5AB). }
							    claim Hu5_on_C5:
							      forall x:set, x :e preimage_of A r4s ((closed_interval one_third 1) :/\: I) ->
							        apply_fun u5 x = one_third.
							    { exact (andER
							        (continuous_map X Tx I0 T0 u5 /\
							         (forall x:set, x :e preimage_of A r4s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
							           apply_fun u5 x = minus_SNo one_third))
							        (forall x:set, x :e preimage_of A r4s ((closed_interval one_third 1) :/\: I) ->
							          apply_fun u5 x = one_third)
							        Hu5). }
							    let x. assume HxA: x :e A.
							    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
							    set I3 := closed_interval one_third 1.
							    set B5 := preimage_of A r4s (I1 :/\: I).
							    set C5 := preimage_of A r4s (I3 :/\: I).
							    claim Hr4sIx: apply_fun r4s x :e I.
							    { exact (continuous_map_function_on A Ta I Ti r4s Hr4s_cont x HxA). }
							    claim HB5_cases: x :e B5 \/ ~(x :e B5).
							    { exact (xm (x :e B5)). }
							    apply (HB5_cases (apply_fun r5 x :e I2)).
							    - assume HxB5: x :e B5.
							      claim Hu5eq: apply_fun u5 x = minus_SNo one_third.
							      { exact (Hu5_on_B5 x HxB5). }
							      claim Hr5eq: apply_fun r5 x = add_SNo (apply_fun r4s x) one_third.
							      { rewrite (Hr5_apply x HxA).
							        rewrite Hu5eq at 1.
							        claim H13R: one_third :e R.
							        { exact one_third_in_R. }
							        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
							        reflexivity. }
							      rewrite Hr5eq.
							      claim Hr4sI1I: apply_fun r4s x :e I1 :/\: I.
							      { exact (SepE2 A (fun x0:set => apply_fun r4s x0 :e I1 :/\: I) x HxB5). }
							      claim Hr4sI1: apply_fun r4s x :e I1.
							      { exact (binintersectE1 I1 I (apply_fun r4s x) Hr4sI1I). }
							      claim H13R: one_third :e R.
							      { exact one_third_in_R. }
							      claim H23R: two_thirds :e R.
							      { exact two_thirds_in_R. }
							      claim Hm23R: minus_SNo two_thirds :e R.
							      { exact (real_minus_SNo two_thirds H23R). }
							      claim Hm1R: minus_SNo 1 :e R.
							      { exact (real_minus_SNo 1 real_1). }
							      claim Hm13R: minus_SNo one_third :e R.
							      { exact (real_minus_SNo one_third H13R). }
							      claim Hr4sRx: apply_fun r4s x :e R.
							      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r4s x) Hr4sI1). }
							      claim Hr4s_bounds: Rle (minus_SNo 1) (apply_fun r4s x) /\ Rle (apply_fun r4s x) (minus_SNo one_third).
							      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r4s x)
							                                     Hm1R Hm13R Hr4sI1). }
							      claim Hm1le: Rle (minus_SNo 1) (apply_fun r4s x).
							      { exact (andEL (Rle (minus_SNo 1) (apply_fun r4s x))
							                     (Rle (apply_fun r4s x) (minus_SNo one_third)) Hr4s_bounds). }
							      claim HhiI1: Rle (apply_fun r4s x) (minus_SNo one_third).
							      { exact (andER (Rle (minus_SNo 1) (apply_fun r4s x))
							                     (Rle (apply_fun r4s x) (minus_SNo one_third)) Hr4s_bounds). }
							      claim Hr5Rx: add_SNo (apply_fun r4s x) one_third :e R.
							      { exact (real_add_SNo (apply_fun r4s x) Hr4sRx one_third H13R). }
							      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r4s x) one_third).
							      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r4s x) one_third Hm1R Hr4sRx H13R Hm1le). }
							      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r4s x) one_third).
							      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
							        exact Hlow_tmp. }
							      claim Hup0_tmp: Rle (add_SNo (apply_fun r4s x) one_third) (add_SNo (minus_SNo one_third) one_third).
							      { exact (Rle_add_SNo_1 (apply_fun r4s x) (minus_SNo one_third) one_third Hr4sRx Hm13R H13R HhiI1). }
							      claim H13S: SNo one_third.
							      { exact (real_SNo one_third H13R). }
							      claim Hup0: Rle (add_SNo (apply_fun r4s x) one_third) 0.
							      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
							        exact Hup0_tmp. }
							      claim H0le23: Rle 0 two_thirds.
							      { exact Rle_0_two_thirds. }
							      claim Hup: Rle (add_SNo (apply_fun r4s x) one_third) two_thirds.
							      { exact (Rle_tra (add_SNo (apply_fun r4s x) one_third) 0 two_thirds Hup0 H0le23). }
							      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
							                                     (add_SNo (apply_fun r4s x) one_third)
							                                     Hm23R H23R Hr5Rx Hlow Hup).
							    - assume HxnotB5: ~(x :e B5).
							      claim HC5_cases: x :e C5 \/ ~(x :e C5).
							      { exact (xm (x :e C5)). }
							      apply (HC5_cases (apply_fun r5 x :e I2)).
							      + assume HxC5: x :e C5.
							        claim Hu5eq: apply_fun u5 x = one_third.
							        { exact (Hu5_on_C5 x HxC5). }
							        claim Hr5eq: apply_fun r5 x = add_SNo (apply_fun r4s x) (minus_SNo one_third).
							        { rewrite (Hr5_apply x HxA).
							          rewrite Hu5eq at 1.
							          reflexivity. }
							        rewrite Hr5eq.
							        claim Hr4sI3I: apply_fun r4s x :e I3 :/\: I.
							        { exact (SepE2 A (fun x0:set => apply_fun r4s x0 :e I3 :/\: I) x HxC5). }
							        claim Hr4sI3: apply_fun r4s x :e I3.
							        { exact (binintersectE1 I3 I (apply_fun r4s x) Hr4sI3I). }
							        claim H13R: one_third :e R.
							        { exact one_third_in_R. }
							        claim H23R: two_thirds :e R.
							        { exact two_thirds_in_R. }
							        claim Hm23R: minus_SNo two_thirds :e R.
							        { exact (real_minus_SNo two_thirds H23R). }
							        claim Hm13R: minus_SNo one_third :e R.
							        { exact (real_minus_SNo one_third H13R). }
							        claim Hr4sRx: apply_fun r4s x :e R.
							        { exact (closed_interval_sub_R one_third 1 (apply_fun r4s x) Hr4sI3). }
							        claim Hr4s_bounds: Rle one_third (apply_fun r4s x) /\ Rle (apply_fun r4s x) 1.
							        { exact (closed_interval_bounds one_third 1 (apply_fun r4s x) H13R real_1 Hr4sI3). }
							        claim HloI3: Rle one_third (apply_fun r4s x).
							        { exact (andEL (Rle one_third (apply_fun r4s x)) (Rle (apply_fun r4s x) 1) Hr4s_bounds). }
							        claim HhiI3: Rle (apply_fun r4s x) 1.
							        { exact (andER (Rle one_third (apply_fun r4s x)) (Rle (apply_fun r4s x) 1) Hr4s_bounds). }
							        claim Hr5Rx: add_SNo (apply_fun r4s x) (minus_SNo one_third) :e R.
							        { exact (real_add_SNo (apply_fun r4s x) Hr4sRx (minus_SNo one_third) Hm13R). }
							        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
							                          (add_SNo (apply_fun r4s x) (minus_SNo one_third)).
							        { exact (Rle_add_SNo_1 one_third (apply_fun r4s x) (minus_SNo one_third)
							                               H13R Hr4sRx Hm13R HloI3). }
							        claim H13S: SNo one_third.
							        { exact (real_SNo one_third H13R). }
							        claim H0le: Rle 0 (add_SNo (apply_fun r4s x) (minus_SNo one_third)).
							        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
							          exact H0le_tmp. }
							        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
							        { exact Rle_minus_two_thirds_0. }
							        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r4s x) (minus_SNo one_third)).
							        { exact (Rle_tra (minus_SNo two_thirds) 0
							                         (add_SNo (apply_fun r4s x) (minus_SNo one_third))
							                         Hm23le0 H0le). }
							        claim Hup_tmp: Rle (add_SNo (apply_fun r4s x) (minus_SNo one_third))
							                         (add_SNo 1 (minus_SNo one_third)).
							        { exact (Rle_add_SNo_1 (apply_fun r4s x) 1 (minus_SNo one_third)
							                               Hr4sRx real_1 Hm13R HhiI3). }
							        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
							        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
							          exact (Rle_refl two_thirds H23R). }
							        claim Hup: Rle (add_SNo (apply_fun r4s x) (minus_SNo one_third)) two_thirds.
							        { exact (Rle_tra (add_SNo (apply_fun r4s x) (minus_SNo one_third))
							                         (add_SNo 1 (minus_SNo one_third))
							                         two_thirds
							                         Hup_tmp Hup1). }
							        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
							                                       (add_SNo (apply_fun r4s x) (minus_SNo one_third))
							                                       Hm23R H23R Hr5Rx Hlow Hup).
							      + assume HxnotC5: ~(x :e C5).
							        claim HxX: x :e X.
							        { exact (HAsubX x HxA). }
							        claim HnotI1: ~(apply_fun r4s x :e I1).
							        { assume Hr4sI1': apply_fun r4s x :e I1.
							          claim Hr4sI1I: apply_fun r4s x :e I1 :/\: I.
							          { exact (binintersectI I1 I (apply_fun r4s x) Hr4sI1' Hr4sIx). }
							          claim HxB5': x :e B5.
							          { exact (SepI A (fun x0:set => apply_fun r4s x0 :e I1 :/\: I) x HxA Hr4sI1I). }
							          apply FalseE.
							          exact (HxnotB5 HxB5'). }
							        claim HnotI3: ~(apply_fun r4s x :e I3).
							        { assume Hr4sI3': apply_fun r4s x :e I3.
							          claim Hr4sI3I: apply_fun r4s x :e I3 :/\: I.
							          { exact (binintersectI I3 I (apply_fun r4s x) Hr4sI3' Hr4sIx). }
							          claim HxC5': x :e C5.
							          { exact (SepI A (fun x0:set => apply_fun r4s x0 :e I3 :/\: I) x HxA Hr4sI3I). }
							          apply FalseE.
							          exact (HxnotC5 HxC5'). }
							        claim Hr4sRx: apply_fun r4s x :e R.
							        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r4s x) Hr4sIx). }
							        claim Hm1R: minus_SNo 1 :e R.
							        { exact (real_minus_SNo 1 real_1). }
							        claim H13R: one_third :e R.
							        { exact one_third_in_R. }
							        claim Hm13R: minus_SNo one_third :e R.
							        { exact (real_minus_SNo one_third H13R). }
							        claim Hr4s_boundsI: Rle (minus_SNo 1) (apply_fun r4s x) /\ Rle (apply_fun r4s x) 1.
							        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r4s x) Hm1R real_1 Hr4sIx). }
							        claim Hnlt_fx_m1: ~(Rlt (apply_fun r4s x) (minus_SNo 1)).
							        { exact (RleE_nlt (minus_SNo 1) (apply_fun r4s x)
							                          (andEL (Rle (minus_SNo 1) (apply_fun r4s x)) (Rle (apply_fun r4s x) 1) Hr4s_boundsI)). }
							        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r4s x)).
							        { exact (RleE_nlt (apply_fun r4s x) 1
							                          (andER (Rle (minus_SNo 1) (apply_fun r4s x)) (Rle (apply_fun r4s x) 1) Hr4s_boundsI)). }
							        claim HnotI1_cases: Rlt (apply_fun r4s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r4s x).
							        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r4s x)
							                                              Hm1R Hm13R Hr4sRx HnotI1). }
							        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r4s x).
							        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r4s x))).
							          - assume Hbad: Rlt (apply_fun r4s x) (minus_SNo 1).
							            apply FalseE.
							            exact (Hnlt_fx_m1 Hbad).
							          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r4s x).
							            exact Hok. }
							        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r4s x) (minus_SNo one_third)).
							        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r4s x) Hm13lt_fx). }
							        claim HnotI3_cases: Rlt (apply_fun r4s x) one_third \/ Rlt 1 (apply_fun r4s x).
							        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r4s x)
							                                              H13R real_1 Hr4sRx HnotI3). }
							        claim Hfx_lt_13: Rlt (apply_fun r4s x) one_third.
							        { apply (HnotI3_cases (Rlt (apply_fun r4s x) one_third)).
							          - assume Hok: Rlt (apply_fun r4s x) one_third.
							            exact Hok.
							          - assume Hbad: Rlt 1 (apply_fun r4s x).
							            apply FalseE.
							            exact (Hnlt_1_fx Hbad). }
							        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r4s x)).
							        { exact (not_Rlt_sym (apply_fun r4s x) one_third Hfx_lt_13). }
							        claim Hr4sI0: apply_fun r4s x :e I0.
							        { claim HI0_def:
							            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
							          { reflexivity. }
							          claim HxSep: apply_fun r4s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
							          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
							                        (apply_fun r4s x) Hr4sRx (andI (~(Rlt (apply_fun r4s x) (minus_SNo one_third)))
							                                                      (~(Rlt one_third (apply_fun r4s x)))
							                                                      Hnot_fx_lt_m13
							                                                      Hnot_13_lt_fx)). }
							          rewrite HI0_def.
							          exact HxSep. }
							        claim Hu5funI0: function_on u5 X I0.
							        { exact (continuous_map_function_on X Tx I0 T0 u5 Hu5contI0). }
							        claim Hu5xI0: apply_fun u5 x :e I0.
							        { exact (Hu5funI0 x HxX). }
							        claim Hu5xR: apply_fun u5 x :e R.
							        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u5 x) Hu5xI0). }
							        claim Hm_u5x_R: minus_SNo (apply_fun u5 x) :e R.
							        { exact (real_minus_SNo (apply_fun u5 x) Hu5xR). }
							        rewrite (Hr5_apply x HxA).
							        claim Hr5xR: add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)) :e R.
							        { exact (real_add_SNo (apply_fun r4s x)
							                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r4s x) Hr4sI0)
							                              (minus_SNo (apply_fun u5 x)) Hm_u5x_R). }
							        claim H23R: two_thirds :e R.
							        { exact two_thirds_in_R. }
							        claim Hm23R: minus_SNo two_thirds :e R.
							        { exact (real_minus_SNo two_thirds H23R). }
							        claim Hr4s_bounds0: Rle (minus_SNo one_third) (apply_fun r4s x) /\ Rle (apply_fun r4s x) one_third.
							        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r4s x) Hm13R H13R Hr4sI0). }
							        claim Hu5_bounds0: Rle (minus_SNo one_third) (apply_fun u5 x) /\ Rle (apply_fun u5 x) one_third.
							        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u5 x) Hm13R H13R Hu5xI0). }
							        claim Hm13_le_r4s: Rle (minus_SNo one_third) (apply_fun r4s x).
							        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r4s x)) (Rle (apply_fun r4s x) one_third) Hr4s_bounds0). }
							        claim Hr4s_le_13: Rle (apply_fun r4s x) one_third.
							        { exact (andER (Rle (minus_SNo one_third) (apply_fun r4s x)) (Rle (apply_fun r4s x) one_third) Hr4s_bounds0). }
							        claim Hm13_le_u5x: Rle (minus_SNo one_third) (apply_fun u5 x).
							        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u5 x)) (Rle (apply_fun u5 x) one_third) Hu5_bounds0). }
							        claim Hu5x_le_13: Rle (apply_fun u5 x) one_third.
							        { exact (andER (Rle (minus_SNo one_third) (apply_fun u5 x)) (Rle (apply_fun u5 x) one_third) Hu5_bounds0). }
							        claim Hm13_le_mu5: Rle (minus_SNo one_third) (minus_SNo (apply_fun u5 x)).
							        { exact (Rle_minus_contra (apply_fun u5 x) one_third Hu5x_le_13). }
							        claim Hmu5_le_13: Rle (minus_SNo (apply_fun u5 x)) one_third.
							        { claim Htmp: Rle (minus_SNo (apply_fun u5 x)) (minus_SNo (minus_SNo one_third)).
							          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u5 x) Hm13_le_u5x). }
							          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
							          exact Htmp. }
							        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
							                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u5 x))).
							        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u5 x))
							                               Hm13R Hm13R Hm_u5x_R Hm13_le_mu5). }
							        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u5 x)))
							                      (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x))).
							        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r4s x) (minus_SNo (apply_fun u5 x))
							                               Hm13R
							                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r4s x) Hr4sI0)
							                               Hm_u5x_R
							                               Hm13_le_r4s). }
							        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
							                        (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x))).
							        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
							                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u5 x)))
							                         (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)))
							                         Hlow1 Hlow2). }
							        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x))).
							        { rewrite minus_two_thirds_eq at 1.
							          exact Hlow_tmp. }
							        claim Hup1: Rle (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)))
							                      (add_SNo (apply_fun r4s x) one_third).
							        { exact (Rle_add_SNo_2 (apply_fun r4s x) (minus_SNo (apply_fun u5 x)) one_third
							                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r4s x) Hr4sI0)
							                               Hm_u5x_R H13R Hmu5_le_13). }
							        claim Hup2: Rle (add_SNo (apply_fun r4s x) one_third)
							                      (add_SNo one_third one_third).
							        { exact (Rle_add_SNo_1 (apply_fun r4s x) one_third one_third
							                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r4s x) Hr4sI0)
							                               H13R H13R Hr4s_le_13). }
							        claim Hup_tmp: Rle (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)))
							                         (add_SNo one_third one_third).
							        { exact (Rle_tra (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)))
							                         (add_SNo (apply_fun r4s x) one_third)
							                         (add_SNo one_third one_third)
							                         Hup1 Hup2). }
							        claim Hdef23: two_thirds = add_SNo one_third one_third.
							        { reflexivity. }
							        claim Hup: Rle (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x))) two_thirds.
							        { rewrite Hdef23 at 1.
							          exact Hup_tmp. }
							        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
							                                       (add_SNo (apply_fun r4s x) (minus_SNo (apply_fun u5 x)))
							                                       Hm23R H23R Hr5xR Hlow Hup). }
								  set r5s := compose_fun A r5 (div_const_fun den).
								  claim Hr5s_cont: continuous_map A Ta I Ti r5s.
								  { claim HRtop: topology_on R R_standard_topology.
								    { exact R_standard_topology_is_topology. }
								    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
								    { exact (div_const_fun_continuous_pos den H23R H23pos). }
								    claim Hr5s_contR: continuous_map A Ta R R_standard_topology r5s.
								    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
								             r5 (div_const_fun den) Hr5_cont Hdivcont). }
								    claim Hr5s_I: forall x:set, x :e A -> apply_fun r5s x :e I.
								    { let x. assume HxA: x :e A.
								      claim Hr5xI2: apply_fun r5 x :e I2.
								      { exact (Hr5_range x HxA). }
								      claim Hm1R: (minus_SNo 1) :e R.
								      { exact (real_minus_SNo 1 real_1). }
								      claim HmdenR: (minus_SNo den) :e R.
								      { exact (real_minus_SNo den H23R). }
								      claim Hr5xR: apply_fun r5 x :e R.
								      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r5 x) Hr5xI2). }
								      claim Hr5xS: SNo (apply_fun r5 x).
								      { exact (real_SNo (apply_fun r5 x) Hr5xR). }
								      claim Hbounds: Rle (minus_SNo den) (apply_fun r5 x) /\ Rle (apply_fun r5 x) den.
								      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r5 x) HmdenR H23R Hr5xI2). }
								      claim Hlo: Rle (minus_SNo den) (apply_fun r5 x).
								      { exact (andEL (Rle (minus_SNo den) (apply_fun r5 x))
								                     (Rle (apply_fun r5 x) den)
								                     Hbounds). }
								      claim Hhi: Rle (apply_fun r5 x) den.
								      { exact (andER (Rle (minus_SNo den) (apply_fun r5 x))
								                     (Rle (apply_fun r5 x) den)
								                     Hbounds). }
								      claim Hnlt_hi: ~(Rlt den (apply_fun r5 x)).
								      { exact (RleE_nlt (apply_fun r5 x) den Hhi). }
								      claim Hnlt_lo: ~(Rlt (apply_fun r5 x) (minus_SNo den)).
								      { exact (RleE_nlt (minus_SNo den) (apply_fun r5 x) Hlo). }
								      claim HyEq: apply_fun r5s x = div_SNo (apply_fun r5 x) den.
								      { rewrite (compose_fun_apply A r5 (div_const_fun den) x HxA).
								        rewrite (div_const_fun_apply den (apply_fun r5 x) H23R Hr5xR).
								        reflexivity. }
								      claim HyR: apply_fun r5s x :e R.
								      { rewrite HyEq.
								        exact (real_div_SNo (apply_fun r5 x) Hr5xR den H23R). }
								      claim HyS: SNo (apply_fun r5s x).
								      { exact (real_SNo (apply_fun r5s x) HyR). }
								      claim Hy_le_1: Rle (apply_fun r5s x) 1.
								      { apply (RleI (apply_fun r5s x) 1 HyR real_1).
								        prove ~(Rlt 1 (apply_fun r5s x)).
								        assume H1lt: Rlt 1 (apply_fun r5s x).
								        claim H1lty: 1 < apply_fun r5s x.
								        { exact (RltE_lt 1 (apply_fun r5s x) H1lt). }
								        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r5s x) den.
								        { exact (pos_mul_SNo_Lt' 1 (apply_fun r5s x) den SNo_1 HyS H23S H23pos H1lty). }
								        claim HmulLt': den < mul_SNo (apply_fun r5s x) den.
								        { rewrite <- (mul_SNo_oneL den H23S) at 1.
								          exact HmulLt. }
								        claim HmulEq: mul_SNo (apply_fun r5s x) den = apply_fun r5 x.
								        { rewrite HyEq at 1.
								          exact (mul_div_SNo_invL (apply_fun r5 x) den Hr5xS H23S H23ne0). }
								        claim Hden_lt_r5x: den < apply_fun r5 x.
								        { rewrite <- HmulEq.
								          exact HmulLt'. }
								        claim Hbad: Rlt den (apply_fun r5 x).
								        { exact (RltI den (apply_fun r5 x) H23R Hr5xR Hden_lt_r5x). }
								        exact (Hnlt_hi Hbad). }
								      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r5s x).
								      { apply (RleI (minus_SNo 1) (apply_fun r5s x) Hm1R HyR).
								        prove ~(Rlt (apply_fun r5s x) (minus_SNo 1)).
								        assume Hylt: Rlt (apply_fun r5s x) (minus_SNo 1).
								        claim Hylts: apply_fun r5s x < minus_SNo 1.
								        { exact (RltE_lt (apply_fun r5s x) (minus_SNo 1) Hylt). }
								        claim HmulLt: mul_SNo (apply_fun r5s x) den < mul_SNo (minus_SNo 1) den.
								        { exact (pos_mul_SNo_Lt' (apply_fun r5s x) (minus_SNo 1) den HyS
								                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
								        claim HmulEq: mul_SNo (apply_fun r5s x) den = apply_fun r5 x.
								        { rewrite HyEq at 1.
								          exact (mul_div_SNo_invL (apply_fun r5 x) den Hr5xS H23S H23ne0). }
								        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
								        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
								          rewrite (mul_SNo_oneL den H23S) at 1.
								          reflexivity. }
								        claim Hr5x_lt_mden: apply_fun r5 x < minus_SNo den.
								        { rewrite <- HmulEq.
								          rewrite <- HrhsEq.
								          exact HmulLt. }
								        claim Hbad: Rlt (apply_fun r5 x) (minus_SNo den).
								        { exact (RltI (apply_fun r5 x) (minus_SNo den) Hr5xR HmdenR Hr5x_lt_mden). }
								        exact (Hnlt_lo Hbad). }
								      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r5s x)
								                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
								    exact (continuous_map_range_restrict A Ta R R_standard_topology r5s I Hr5s_contR HIcR Hr5s_I). }

								  (** ninth correction step scaffold: build u6 and g6 from residual r5s **)
								  claim Hex_u6:
								    exists u6:set,
								      continuous_map X Tx I0 T0 u6 /\
								      (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								        apply_fun u6 x = minus_SNo one_third) /\
								      (forall x:set, x :e preimage_of A r5s ((closed_interval one_third 1) :/\: I) ->
								        apply_fun u6 x = one_third).
								  { exact (Tietze_stepI_g_exists X Tx A r5s Hnorm HA Hr5s_cont). }
								  apply Hex_u6.
								  let u6. assume Hu6.
								  claim Hu6contI0: continuous_map X Tx I0 T0 u6.
								  { claim Hu6AB:
								      continuous_map X Tx I0 T0 u6 /\
								      (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								        apply_fun u6 x = minus_SNo one_third).
								    { exact (andEL
								        (continuous_map X Tx I0 T0 u6 /\
								         (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								           apply_fun u6 x = minus_SNo one_third))
								        (forall x:set, x :e preimage_of A r5s ((closed_interval one_third 1) :/\: I) ->
								          apply_fun u6 x = one_third)
								        Hu6). }
								    exact (andEL
								        (continuous_map X Tx I0 T0 u6)
								        (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								          apply_fun u6 x = minus_SNo one_third)
								        Hu6AB). }
								  claim Hu6contR: continuous_map X Tx R R_standard_topology u6.
								  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
								    { reflexivity. }
								    claim HI0subR: I0 c= R.
								    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
								    exact (continuous_map_range_expand
								             X Tx I0 T0
								             R R_standard_topology
								             u6
								             Hu6contI0
								             HI0subR
								             R_standard_topology_is_topology_local
								             HT0eq). }
								  set den6 := mul_SNo den5 den.
								  claim Hden6R: den6 :e R.
								  { exact (real_mul_SNo den5 Hden5R den H23R). }
								  claim Hden6pos: 0 < den6.
								  { claim Hden5S: SNo den5.
								    { exact (real_SNo den5 Hden5R). }
								    exact (mul_SNo_pos_pos den5 den Hden5S H23S Hden5pos HdenPos). }
								  set u6s := compose_fun X u6 (mul_const_fun den6).
								  claim Hu6s_cont: continuous_map X Tx R R_standard_topology u6s.
								  { exact (scale_continuous_mul_const_pos X Tx u6 den6 HTx Hu6contR Hden6R Hden6pos). }
								  set g6 := compose_fun X (pair_map X g5 u6s) add_fun_R.
								  claim Hg6cont: continuous_map X Tx R R_standard_topology g6.
								  { exact (add_two_continuous_R X Tx g5 u6s HTx Hg5cont Hu6s_cont). }

								  (** tenth correction step scaffold: residual r6 on A and scaling r6s **)
								  claim Hu6contA: continuous_map A Ta R R_standard_topology u6.
								  { exact (continuous_on_subspace X Tx R R_standard_topology u6 A HTx HAsubX Hu6contR). }
								  set u6neg := compose_fun A u6 neg_fun.
								  claim Hu6neg_cont: continuous_map A Ta R R_standard_topology u6neg.
								  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
								           u6 neg_fun Hu6contA Hnegcont). }
								  claim Hr5s_contR: continuous_map A Ta R R_standard_topology r5s.
								  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r5s
								           Hr5s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
								  set r6 := compose_fun A (pair_map A r5s u6neg) add_fun_R.
								  claim Hr6_cont: continuous_map A Ta R R_standard_topology r6.
								  { exact (add_two_continuous_R A Ta r5s u6neg HTa Hr5s_contR Hu6neg_cont). }
								  claim Hr6_apply: forall x:set, x :e A ->
								    apply_fun r6 x = add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)).
								  { let x. assume HxA: x :e A.
								    claim Hpimg: apply_fun (pair_map A r5s u6neg) x :e setprod R R.
								    { rewrite (pair_map_apply A R R r5s u6neg x HxA).
								      claim Hr5sxI: apply_fun r5s x :e I.
								      { exact (continuous_map_function_on A Ta I Ti r5s Hr5s_cont x HxA). }
								      claim Hr5sxR: apply_fun r5s x :e R.
								      { exact (HIcR (apply_fun r5s x) Hr5sxI). }
								      claim Hu6negRx: apply_fun u6neg x :e R.
								      { exact (continuous_map_function_on A Ta R R_standard_topology u6neg Hu6neg_cont x HxA). }
								      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r5s x) (apply_fun u6neg x) Hr5sxR Hu6negRx). }
								    rewrite (compose_fun_apply A (pair_map A r5s u6neg) add_fun_R x HxA).
								    rewrite (add_fun_R_apply (apply_fun (pair_map A r5s u6neg) x) Hpimg) at 1.
								    rewrite (pair_map_apply A R R r5s u6neg x HxA).
								    rewrite (tuple_2_0_eq (apply_fun r5s x) (apply_fun u6neg x)).
								    rewrite (tuple_2_1_eq (apply_fun r5s x) (apply_fun u6neg x)).
								    rewrite (compose_fun_apply A u6 neg_fun x HxA) at 1.
								    claim Hu6Rx: apply_fun u6 x :e R.
								    { exact (continuous_map_function_on A Ta R R_standard_topology u6 Hu6contA x HxA). }
								    rewrite (neg_fun_apply (apply_fun u6 x) Hu6Rx) at 1.
								    reflexivity. }
								  claim Hr6_range: forall x:set, x :e A -> apply_fun r6 x :e I2.
								  { (** show the next residual stays within [-2/3,2/3] on A **)
								    claim Hu6AB:
								      continuous_map X Tx I0 T0 u6 /\
								      (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								        apply_fun u6 x = minus_SNo one_third).
								    { exact (andEL
								        (continuous_map X Tx I0 T0 u6 /\
								         (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								           apply_fun u6 x = minus_SNo one_third))
								        (forall x:set, x :e preimage_of A r5s ((closed_interval one_third 1) :/\: I) ->
								          apply_fun u6 x = one_third)
								        Hu6). }
								    claim Hu6_on_B6:
								      forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								        apply_fun u6 x = minus_SNo one_third.
								    { exact (andER
								        (continuous_map X Tx I0 T0 u6)
								        (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								          apply_fun u6 x = minus_SNo one_third)
								        Hu6AB). }
								    claim Hu6_on_C6:
								      forall x:set, x :e preimage_of A r5s ((closed_interval one_third 1) :/\: I) ->
								        apply_fun u6 x = one_third.
								    { exact (andER
								        (continuous_map X Tx I0 T0 u6 /\
								         (forall x:set, x :e preimage_of A r5s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
								           apply_fun u6 x = minus_SNo one_third))
								        (forall x:set, x :e preimage_of A r5s ((closed_interval one_third 1) :/\: I) ->
								          apply_fun u6 x = one_third)
								        Hu6). }
								    let x. assume HxA: x :e A.
								    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
								    set I3 := closed_interval one_third 1.
								    set B6 := preimage_of A r5s (I1 :/\: I).
								    set C6 := preimage_of A r5s (I3 :/\: I).
								    claim Hr5sIx: apply_fun r5s x :e I.
								    { exact (continuous_map_function_on A Ta I Ti r5s Hr5s_cont x HxA). }
								    claim HB6_cases: x :e B6 \/ ~(x :e B6).
								    { exact (xm (x :e B6)). }
								    apply (HB6_cases (apply_fun r6 x :e I2)).
								    - assume HxB6: x :e B6.
								      claim Hu6eq: apply_fun u6 x = minus_SNo one_third.
								      { exact (Hu6_on_B6 x HxB6). }
								      claim Hr6eq: apply_fun r6 x = add_SNo (apply_fun r5s x) one_third.
								      { rewrite (Hr6_apply x HxA).
								        rewrite Hu6eq at 1.
								        claim H13R: one_third :e R.
								        { exact one_third_in_R. }
								        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
								        reflexivity. }
								      rewrite Hr6eq.
								      claim Hr5sI1I: apply_fun r5s x :e I1 :/\: I.
								      { exact (SepE2 A (fun x0:set => apply_fun r5s x0 :e I1 :/\: I) x HxB6). }
								      claim Hr5sI1: apply_fun r5s x :e I1.
								      { exact (binintersectE1 I1 I (apply_fun r5s x) Hr5sI1I). }
								      claim H13R: one_third :e R.
								      { exact one_third_in_R. }
								      claim H23R: two_thirds :e R.
								      { exact two_thirds_in_R. }
								      claim Hm23R: minus_SNo two_thirds :e R.
								      { exact (real_minus_SNo two_thirds H23R). }
								      claim Hm1R: minus_SNo 1 :e R.
								      { exact (real_minus_SNo 1 real_1). }
								      claim Hm13R: minus_SNo one_third :e R.
								      { exact (real_minus_SNo one_third H13R). }
								      claim Hr5sRx: apply_fun r5s x :e R.
								      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r5s x) Hr5sI1). }
								      claim Hr5s_bounds: Rle (minus_SNo 1) (apply_fun r5s x) /\ Rle (apply_fun r5s x) (minus_SNo one_third).
								      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r5s x)
								                                     Hm1R Hm13R Hr5sI1). }
								      claim Hm1le: Rle (minus_SNo 1) (apply_fun r5s x).
								      { exact (andEL (Rle (minus_SNo 1) (apply_fun r5s x))
								                     (Rle (apply_fun r5s x) (minus_SNo one_third)) Hr5s_bounds). }
								      claim HhiI1: Rle (apply_fun r5s x) (minus_SNo one_third).
								      { exact (andER (Rle (minus_SNo 1) (apply_fun r5s x))
								                     (Rle (apply_fun r5s x) (minus_SNo one_third)) Hr5s_bounds). }
								      claim Hr6Rx: add_SNo (apply_fun r5s x) one_third :e R.
								      { exact (real_add_SNo (apply_fun r5s x) Hr5sRx one_third H13R). }
								      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r5s x) one_third).
								      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r5s x) one_third Hm1R Hr5sRx H13R Hm1le). }
								      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r5s x) one_third).
								      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
								        exact Hlow_tmp. }
								      claim Hup0_tmp: Rle (add_SNo (apply_fun r5s x) one_third) (add_SNo (minus_SNo one_third) one_third).
								      { exact (Rle_add_SNo_1 (apply_fun r5s x) (minus_SNo one_third) one_third Hr5sRx Hm13R H13R HhiI1). }
								      claim H13S: SNo one_third.
								      { exact (real_SNo one_third H13R). }
								      claim Hup0: Rle (add_SNo (apply_fun r5s x) one_third) 0.
								      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
								        exact Hup0_tmp. }
								      claim H0le23: Rle 0 two_thirds.
								      { exact Rle_0_two_thirds. }
								      claim Hup: Rle (add_SNo (apply_fun r5s x) one_third) two_thirds.
								      { exact (Rle_tra (add_SNo (apply_fun r5s x) one_third) 0 two_thirds Hup0 H0le23). }
								      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
								                                     (add_SNo (apply_fun r5s x) one_third)
								                                     Hm23R H23R Hr6Rx Hlow Hup).
								    - assume HxnotB6: ~(x :e B6).
								      claim HC6_cases: x :e C6 \/ ~(x :e C6).
								      { exact (xm (x :e C6)). }
								      apply (HC6_cases (apply_fun r6 x :e I2)).
								      + assume HxC6: x :e C6.
								        claim Hu6eq: apply_fun u6 x = one_third.
								        { exact (Hu6_on_C6 x HxC6). }
								        claim Hr6eq: apply_fun r6 x = add_SNo (apply_fun r5s x) (minus_SNo one_third).
								        { rewrite (Hr6_apply x HxA).
								          rewrite Hu6eq at 1.
								          reflexivity. }
								        rewrite Hr6eq.
								        claim Hr5sI3I: apply_fun r5s x :e I3 :/\: I.
								        { exact (SepE2 A (fun x0:set => apply_fun r5s x0 :e I3 :/\: I) x HxC6). }
								        claim Hr5sI3: apply_fun r5s x :e I3.
								        { exact (binintersectE1 I3 I (apply_fun r5s x) Hr5sI3I). }
								        claim H13R: one_third :e R.
								        { exact one_third_in_R. }
								        claim H23R: two_thirds :e R.
								        { exact two_thirds_in_R. }
								        claim Hm23R: minus_SNo two_thirds :e R.
								        { exact (real_minus_SNo two_thirds H23R). }
								        claim Hm13R: minus_SNo one_third :e R.
								        { exact (real_minus_SNo one_third H13R). }
								        claim Hr5sRx: apply_fun r5s x :e R.
								        { exact (closed_interval_sub_R one_third 1 (apply_fun r5s x) Hr5sI3). }
								        claim Hr5s_bounds: Rle one_third (apply_fun r5s x) /\ Rle (apply_fun r5s x) 1.
								        { exact (closed_interval_bounds one_third 1 (apply_fun r5s x) H13R real_1 Hr5sI3). }
								        claim HloI3: Rle one_third (apply_fun r5s x).
								        { exact (andEL (Rle one_third (apply_fun r5s x)) (Rle (apply_fun r5s x) 1) Hr5s_bounds). }
								        claim HhiI3: Rle (apply_fun r5s x) 1.
								        { exact (andER (Rle one_third (apply_fun r5s x)) (Rle (apply_fun r5s x) 1) Hr5s_bounds). }
								        claim Hr6Rx: add_SNo (apply_fun r5s x) (minus_SNo one_third) :e R.
								        { exact (real_add_SNo (apply_fun r5s x) Hr5sRx (minus_SNo one_third) Hm13R). }
								        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
								                          (add_SNo (apply_fun r5s x) (minus_SNo one_third)).
								        { exact (Rle_add_SNo_1 one_third (apply_fun r5s x) (minus_SNo one_third)
								                               H13R Hr5sRx Hm13R HloI3). }
								        claim H13S: SNo one_third.
								        { exact (real_SNo one_third H13R). }
								        claim H0le: Rle 0 (add_SNo (apply_fun r5s x) (minus_SNo one_third)).
								        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
								          exact H0le_tmp. }
								        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
								        { exact Rle_minus_two_thirds_0. }
								        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r5s x) (minus_SNo one_third)).
								        { exact (Rle_tra (minus_SNo two_thirds) 0
								                         (add_SNo (apply_fun r5s x) (minus_SNo one_third))
								                         Hm23le0 H0le). }
								        claim Hup_tmp: Rle (add_SNo (apply_fun r5s x) (minus_SNo one_third))
								                         (add_SNo 1 (minus_SNo one_third)).
								        { exact (Rle_add_SNo_1 (apply_fun r5s x) 1 (minus_SNo one_third)
								                               Hr5sRx real_1 Hm13R HhiI3). }
								        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
								        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
								          exact (Rle_refl two_thirds H23R). }
								        claim Hup: Rle (add_SNo (apply_fun r5s x) (minus_SNo one_third)) two_thirds.
								        { exact (Rle_tra (add_SNo (apply_fun r5s x) (minus_SNo one_third))
								                         (add_SNo 1 (minus_SNo one_third))
								                         two_thirds
								                         Hup_tmp Hup1). }
								        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
								                                       (add_SNo (apply_fun r5s x) (minus_SNo one_third))
								                                       Hm23R H23R Hr6Rx Hlow Hup).
								      + assume HxnotC6: ~(x :e C6).
								        claim HxX: x :e X.
								        { exact (HAsubX x HxA). }
								        claim HnotI1: ~(apply_fun r5s x :e I1).
								        { assume Hr5sI1': apply_fun r5s x :e I1.
								          claim Hr5sI1I: apply_fun r5s x :e I1 :/\: I.
								          { exact (binintersectI I1 I (apply_fun r5s x) Hr5sI1' Hr5sIx). }
								          claim HxB6': x :e B6.
								          { exact (SepI A (fun x0:set => apply_fun r5s x0 :e I1 :/\: I) x HxA Hr5sI1I). }
								          apply FalseE.
								          exact (HxnotB6 HxB6'). }
								        claim HnotI3: ~(apply_fun r5s x :e I3).
								        { assume Hr5sI3': apply_fun r5s x :e I3.
								          claim Hr5sI3I: apply_fun r5s x :e I3 :/\: I.
								          { exact (binintersectI I3 I (apply_fun r5s x) Hr5sI3' Hr5sIx). }
								          claim HxC6': x :e C6.
								          { exact (SepI A (fun x0:set => apply_fun r5s x0 :e I3 :/\: I) x HxA Hr5sI3I). }
								          apply FalseE.
								          exact (HxnotC6 HxC6'). }
								        claim Hr5sRx: apply_fun r5s x :e R.
								        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r5s x) Hr5sIx). }
								        claim Hm1R: minus_SNo 1 :e R.
								        { exact (real_minus_SNo 1 real_1). }
								        claim H13R: one_third :e R.
								        { exact one_third_in_R. }
								        claim Hm13R: minus_SNo one_third :e R.
								        { exact (real_minus_SNo one_third H13R). }
								        claim Hr5s_boundsI: Rle (minus_SNo 1) (apply_fun r5s x) /\ Rle (apply_fun r5s x) 1.
								        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r5s x) Hm1R real_1 Hr5sIx). }
								        claim Hnlt_fx_m1: ~(Rlt (apply_fun r5s x) (minus_SNo 1)).
								        { exact (RleE_nlt (minus_SNo 1) (apply_fun r5s x)
								                          (andEL (Rle (minus_SNo 1) (apply_fun r5s x)) (Rle (apply_fun r5s x) 1) Hr5s_boundsI)). }
								        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r5s x)).
								        { exact (RleE_nlt (apply_fun r5s x) 1
								                          (andER (Rle (minus_SNo 1) (apply_fun r5s x)) (Rle (apply_fun r5s x) 1) Hr5s_boundsI)). }
								        claim HnotI1_cases: Rlt (apply_fun r5s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r5s x).
								        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r5s x)
								                                              Hm1R Hm13R Hr5sRx HnotI1). }
								        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r5s x).
								        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r5s x))).
								          - assume Hbad: Rlt (apply_fun r5s x) (minus_SNo 1).
								            apply FalseE.
								            exact (Hnlt_fx_m1 Hbad).
								          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r5s x).
								            exact Hok. }
								        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r5s x) (minus_SNo one_third)).
								        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r5s x) Hm13lt_fx). }
								        claim HnotI3_cases: Rlt (apply_fun r5s x) one_third \/ Rlt 1 (apply_fun r5s x).
								        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r5s x)
								                                              H13R real_1 Hr5sRx HnotI3). }
								        claim Hfx_lt_13: Rlt (apply_fun r5s x) one_third.
								        { apply (HnotI3_cases (Rlt (apply_fun r5s x) one_third)).
								          - assume Hok: Rlt (apply_fun r5s x) one_third.
								            exact Hok.
								          - assume Hbad: Rlt 1 (apply_fun r5s x).
								            apply FalseE.
								            exact (Hnlt_1_fx Hbad). }
								        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r5s x)).
								        { exact (not_Rlt_sym (apply_fun r5s x) one_third Hfx_lt_13). }
								        claim Hr5sI0: apply_fun r5s x :e I0.
								        { claim HI0_def:
								            I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
								          { reflexivity. }
								          claim HxSep: apply_fun r5s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
								          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
								                        (apply_fun r5s x) Hr5sRx (andI (~(Rlt (apply_fun r5s x) (minus_SNo one_third)))
								                                                      (~(Rlt one_third (apply_fun r5s x)))
								                                                      Hnot_fx_lt_m13
								                                                      Hnot_13_lt_fx)). }
								          rewrite HI0_def.
								          exact HxSep. }
								        claim Hu6funI0: function_on u6 X I0.
								        { exact (continuous_map_function_on X Tx I0 T0 u6 Hu6contI0). }
								        claim Hu6xI0: apply_fun u6 x :e I0.
								        { exact (Hu6funI0 x HxX). }
								        claim Hu6xR: apply_fun u6 x :e R.
								        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u6 x) Hu6xI0). }
								        claim Hm_u6x_R: minus_SNo (apply_fun u6 x) :e R.
								        { exact (real_minus_SNo (apply_fun u6 x) Hu6xR). }
								        rewrite (Hr6_apply x HxA).
								        claim Hr6xR: add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)) :e R.
								        { exact (real_add_SNo (apply_fun r5s x)
								                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r5s x) Hr5sI0)
								                              (minus_SNo (apply_fun u6 x)) Hm_u6x_R). }
								        claim H23R: two_thirds :e R.
								        { exact two_thirds_in_R. }
								        claim Hm23R: minus_SNo two_thirds :e R.
								        { exact (real_minus_SNo two_thirds H23R). }
								        claim Hr5s_bounds0: Rle (minus_SNo one_third) (apply_fun r5s x) /\ Rle (apply_fun r5s x) one_third.
								        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r5s x) Hm13R H13R Hr5sI0). }
								        claim Hu6_bounds0: Rle (minus_SNo one_third) (apply_fun u6 x) /\ Rle (apply_fun u6 x) one_third.
								        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u6 x) Hm13R H13R Hu6xI0). }
								        claim Hm13_le_r5s: Rle (minus_SNo one_third) (apply_fun r5s x).
								        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r5s x)) (Rle (apply_fun r5s x) one_third) Hr5s_bounds0). }
								        claim Hr5s_le_13: Rle (apply_fun r5s x) one_third.
								        { exact (andER (Rle (minus_SNo one_third) (apply_fun r5s x)) (Rle (apply_fun r5s x) one_third) Hr5s_bounds0). }
								        claim Hm13_le_u6x: Rle (minus_SNo one_third) (apply_fun u6 x).
								        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u6 x)) (Rle (apply_fun u6 x) one_third) Hu6_bounds0). }
								        claim Hu6x_le_13: Rle (apply_fun u6 x) one_third.
								        { exact (andER (Rle (minus_SNo one_third) (apply_fun u6 x)) (Rle (apply_fun u6 x) one_third) Hu6_bounds0). }
								        claim Hm13_le_mu6: Rle (minus_SNo one_third) (minus_SNo (apply_fun u6 x)).
								        { exact (Rle_minus_contra (apply_fun u6 x) one_third Hu6x_le_13). }
								        claim Hmu6_le_13: Rle (minus_SNo (apply_fun u6 x)) one_third.
								        { claim Htmp: Rle (minus_SNo (apply_fun u6 x)) (minus_SNo (minus_SNo one_third)).
								          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u6 x) Hm13_le_u6x). }
								          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
								          exact Htmp. }
								        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
								                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u6 x))).
								        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u6 x))
								                               Hm13R Hm13R Hm_u6x_R Hm13_le_mu6). }
								        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u6 x)))
								                      (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x))).
								        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r5s x) (minus_SNo (apply_fun u6 x))
								                               Hm13R
								                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r5s x) Hr5sI0)
								                               Hm_u6x_R
								                               Hm13_le_r5s). }
								        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
								                        (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x))).
								        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
								                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u6 x)))
								                         (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)))
								                         Hlow1 Hlow2). }
								        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x))).
								        { rewrite minus_two_thirds_eq at 1.
								          exact Hlow_tmp. }
								        claim Hup1: Rle (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)))
								                      (add_SNo (apply_fun r5s x) one_third).
								        { exact (Rle_add_SNo_2 (apply_fun r5s x) (minus_SNo (apply_fun u6 x)) one_third
								                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r5s x) Hr5sI0)
								                               Hm_u6x_R H13R Hmu6_le_13). }
								        claim Hup2: Rle (add_SNo (apply_fun r5s x) one_third)
								                      (add_SNo one_third one_third).
								        { exact (Rle_add_SNo_1 (apply_fun r5s x) one_third one_third
								                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r5s x) Hr5sI0)
								                               H13R H13R Hr5s_le_13). }
								        claim Hup_tmp: Rle (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)))
								                         (add_SNo one_third one_third).
								        { exact (Rle_tra (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)))
								                         (add_SNo (apply_fun r5s x) one_third)
								                         (add_SNo one_third one_third)
								                         Hup1 Hup2). }
								        claim Hdef23: two_thirds = add_SNo one_third one_third.
								        { reflexivity. }
								        claim Hup: Rle (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x))) two_thirds.
								        { rewrite Hdef23 at 1.
								          exact Hup_tmp. }
								        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
								                                       (add_SNo (apply_fun r5s x) (minus_SNo (apply_fun u6 x)))
								                                       Hm23R H23R Hr6xR Hlow Hup). }
									  set r6s := compose_fun A r6 (div_const_fun den).
									  claim Hr6s_cont: continuous_map A Ta I Ti r6s.
								  { claim HRtop: topology_on R R_standard_topology.
								    { exact R_standard_topology_is_topology. }
								    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
								    { exact (div_const_fun_continuous_pos den H23R H23pos). }
								    claim Hr6s_contR: continuous_map A Ta R R_standard_topology r6s.
								    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
								             r6 (div_const_fun den) Hr6_cont Hdivcont). }
								    claim Hr6s_I: forall x:set, x :e A -> apply_fun r6s x :e I.
								    { let x. assume HxA: x :e A.
								      claim Hr6xI2: apply_fun r6 x :e I2.
								      { exact (Hr6_range x HxA). }
								      claim Hm1R: (minus_SNo 1) :e R.
								      { exact (real_minus_SNo 1 real_1). }
								      claim HmdenR: (minus_SNo den) :e R.
								      { exact (real_minus_SNo den H23R). }
								      claim Hr6xR: apply_fun r6 x :e R.
								      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r6 x) Hr6xI2). }
								      claim Hr6xS: SNo (apply_fun r6 x).
								      { exact (real_SNo (apply_fun r6 x) Hr6xR). }
								      claim Hbounds: Rle (minus_SNo den) (apply_fun r6 x) /\ Rle (apply_fun r6 x) den.
								      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r6 x) HmdenR H23R Hr6xI2). }
								      claim Hlo: Rle (minus_SNo den) (apply_fun r6 x).
								      { exact (andEL (Rle (minus_SNo den) (apply_fun r6 x))
								                     (Rle (apply_fun r6 x) den)
								                     Hbounds). }
								      claim Hhi: Rle (apply_fun r6 x) den.
								      { exact (andER (Rle (minus_SNo den) (apply_fun r6 x))
								                     (Rle (apply_fun r6 x) den)
								                     Hbounds). }
								      claim Hnlt_hi: ~(Rlt den (apply_fun r6 x)).
								      { exact (RleE_nlt (apply_fun r6 x) den Hhi). }
								      claim Hnlt_lo: ~(Rlt (apply_fun r6 x) (minus_SNo den)).
								      { exact (RleE_nlt (minus_SNo den) (apply_fun r6 x) Hlo). }
								      claim HyEq: apply_fun r6s x = div_SNo (apply_fun r6 x) den.
								      { rewrite (compose_fun_apply A r6 (div_const_fun den) x HxA).
								        rewrite (div_const_fun_apply den (apply_fun r6 x) H23R Hr6xR).
								        reflexivity. }
								      claim HyR: apply_fun r6s x :e R.
								      { rewrite HyEq.
								        exact (real_div_SNo (apply_fun r6 x) Hr6xR den H23R). }
								      claim HyS: SNo (apply_fun r6s x).
								      { exact (real_SNo (apply_fun r6s x) HyR). }
								      claim Hy_le_1: Rle (apply_fun r6s x) 1.
								      { apply (RleI (apply_fun r6s x) 1 HyR real_1).
								        prove ~(Rlt 1 (apply_fun r6s x)).
								        assume H1lt: Rlt 1 (apply_fun r6s x).
								        claim H1lty: 1 < apply_fun r6s x.
								        { exact (RltE_lt 1 (apply_fun r6s x) H1lt). }
								        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r6s x) den.
								        { exact (pos_mul_SNo_Lt' 1 (apply_fun r6s x) den SNo_1 HyS H23S H23pos H1lty). }
								        claim HmulLt': den < mul_SNo (apply_fun r6s x) den.
								        { rewrite <- (mul_SNo_oneL den H23S) at 1.
								          exact HmulLt. }
								        claim HmulEq: mul_SNo (apply_fun r6s x) den = apply_fun r6 x.
								        { rewrite HyEq at 1.
								          exact (mul_div_SNo_invL (apply_fun r6 x) den Hr6xS H23S H23ne0). }
								        claim Hden_lt_r6x: den < apply_fun r6 x.
								        { rewrite <- HmulEq.
								          exact HmulLt'. }
								        claim Hbad: Rlt den (apply_fun r6 x).
								        { exact (RltI den (apply_fun r6 x) H23R Hr6xR Hden_lt_r6x). }
								        exact (Hnlt_hi Hbad). }
								      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r6s x).
								      { apply (RleI (minus_SNo 1) (apply_fun r6s x) Hm1R HyR).
								        prove ~(Rlt (apply_fun r6s x) (minus_SNo 1)).
								        assume Hylt: Rlt (apply_fun r6s x) (minus_SNo 1).
								        claim Hylts: apply_fun r6s x < minus_SNo 1.
								        { exact (RltE_lt (apply_fun r6s x) (minus_SNo 1) Hylt). }
								        claim HmulLt: mul_SNo (apply_fun r6s x) den < mul_SNo (minus_SNo 1) den.
								        { exact (pos_mul_SNo_Lt' (apply_fun r6s x) (minus_SNo 1) den HyS
								                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
								        claim HmulEq: mul_SNo (apply_fun r6s x) den = apply_fun r6 x.
								        { rewrite HyEq at 1.
								          exact (mul_div_SNo_invL (apply_fun r6 x) den Hr6xS H23S H23ne0). }
								        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
								        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
								          rewrite (mul_SNo_oneL den H23S) at 1.
								          reflexivity. }
								        claim Hr6x_lt_mden: apply_fun r6 x < minus_SNo den.
								        { rewrite <- HmulEq.
								          rewrite <- HrhsEq.
								          exact HmulLt. }
								        claim Hbad: Rlt (apply_fun r6 x) (minus_SNo den).
								        { exact (RltI (apply_fun r6 x) (minus_SNo den) Hr6xR HmdenR Hr6x_lt_mden). }
								        exact (Hnlt_lo Hbad). }
								      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r6s x)
								                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
									    exact (continuous_map_range_restrict A Ta R R_standard_topology r6s I Hr6s_contR HIcR Hr6s_I). }
		
									  (** eleventh correction step scaffold: build u7 and g7 from residual r6s **)
									  claim Hex_u7:
									    exists u7:set,
									      continuous_map X Tx I0 T0 u7 /\
									      (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
									        apply_fun u7 x = minus_SNo one_third) /\
									      (forall x:set, x :e preimage_of A r6s ((closed_interval one_third 1) :/\: I) ->
									        apply_fun u7 x = one_third).
									  { exact (Tietze_stepI_g_exists X Tx A r6s Hnorm HA Hr6s_cont). }
									  apply Hex_u7.
									  let u7. assume Hu7.
									  claim Hu7contI0: continuous_map X Tx I0 T0 u7.
									  { claim Hu7AB:
									      continuous_map X Tx I0 T0 u7 /\
									      (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
									        apply_fun u7 x = minus_SNo one_third).
									    { exact (andEL
									        (continuous_map X Tx I0 T0 u7 /\
									         (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
									           apply_fun u7 x = minus_SNo one_third))
									        (forall x:set, x :e preimage_of A r6s ((closed_interval one_third 1) :/\: I) ->
									          apply_fun u7 x = one_third)
									        Hu7). }
									    exact (andEL
									        (continuous_map X Tx I0 T0 u7)
									        (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
									          apply_fun u7 x = minus_SNo one_third)
									        Hu7AB). }
									  claim Hu7contR: continuous_map X Tx R R_standard_topology u7.
									  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
									    { reflexivity. }
									    claim HI0subR: I0 c= R.
									    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
									    exact (continuous_map_range_expand
									             X Tx I0 T0
									             R R_standard_topology
									             u7
									             Hu7contI0
									             HI0subR
									             R_standard_topology_is_topology_local
									             HT0eq). }
									  set den7 := mul_SNo den6 den.
									  claim Hden7R: den7 :e R.
									  { exact (real_mul_SNo den6 Hden6R den H23R). }
									  claim Hden7pos: 0 < den7.
									  { claim Hden6S: SNo den6.
									    { exact (real_SNo den6 Hden6R). }
									    exact (mul_SNo_pos_pos den6 den Hden6S H23S Hden6pos HdenPos). }
									  set u7s := compose_fun X u7 (mul_const_fun den7).
									  claim Hu7s_cont: continuous_map X Tx R R_standard_topology u7s.
									  { exact (scale_continuous_mul_const_pos X Tx u7 den7 HTx Hu7contR Hden7R Hden7pos). }
									  set g7 := compose_fun X (pair_map X g6 u7s) add_fun_R.
									  claim Hg7cont: continuous_map X Tx R R_standard_topology g7.
									  { exact (add_two_continuous_R X Tx g6 u7s HTx Hg6cont Hu7s_cont). }

									  (** twelfth correction step scaffold: residual r7 on A and scaling r7s **)
									  claim Hu7contA: continuous_map A Ta R R_standard_topology u7.
									  { exact (continuous_on_subspace X Tx R R_standard_topology u7 A HTx HAsubX Hu7contR). }
									  set u7neg := compose_fun A u7 neg_fun.
									  claim Hu7neg_cont: continuous_map A Ta R R_standard_topology u7neg.
									  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
									           u7 neg_fun Hu7contA Hnegcont). }
									  claim Hr6s_contR: continuous_map A Ta R R_standard_topology r6s.
									  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r6s
									           Hr6s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
									  set r7 := compose_fun A (pair_map A r6s u7neg) add_fun_R.
									  claim Hr7_cont: continuous_map A Ta R R_standard_topology r7.
									  { exact (add_two_continuous_R A Ta r6s u7neg HTa Hr6s_contR Hu7neg_cont). }
									  claim Hr7_apply: forall x:set, x :e A ->
									    apply_fun r7 x = add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)).
									  { let x. assume HxA: x :e A.
									    claim Hpimg: apply_fun (pair_map A r6s u7neg) x :e setprod R R.
									    { rewrite (pair_map_apply A R R r6s u7neg x HxA).
									      claim Hr6sxI: apply_fun r6s x :e I.
									      { exact (continuous_map_function_on A Ta I Ti r6s Hr6s_cont x HxA). }
									      claim Hr6sxR: apply_fun r6s x :e R.
									      { exact (HIcR (apply_fun r6s x) Hr6sxI). }
									      claim Hu7negRx: apply_fun u7neg x :e R.
									      { exact (continuous_map_function_on A Ta R R_standard_topology u7neg Hu7neg_cont x HxA). }
									      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r6s x) (apply_fun u7neg x) Hr6sxR Hu7negRx). }
									    rewrite (compose_fun_apply A (pair_map A r6s u7neg) add_fun_R x HxA).
									    rewrite (add_fun_R_apply (apply_fun (pair_map A r6s u7neg) x) Hpimg) at 1.
									    rewrite (pair_map_apply A R R r6s u7neg x HxA).
									    rewrite (tuple_2_0_eq (apply_fun r6s x) (apply_fun u7neg x)).
									    rewrite (tuple_2_1_eq (apply_fun r6s x) (apply_fun u7neg x)).
									    rewrite (compose_fun_apply A u7 neg_fun x HxA) at 1.
									    claim Hu7Rx: apply_fun u7 x :e R.
									    { exact (continuous_map_function_on A Ta R R_standard_topology u7 Hu7contA x HxA). }
										    rewrite (neg_fun_apply (apply_fun u7 x) Hu7Rx) at 1.
										    reflexivity. }
										  claim Hr7_range: forall x:set, x :e A -> apply_fun r7 x :e I2.
										  { claim Hu7AB:
										      continuous_map X Tx I0 T0 u7 /\
										      (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										        apply_fun u7 x = minus_SNo one_third).
										    { exact (andEL
										        (continuous_map X Tx I0 T0 u7 /\
										         (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										           apply_fun u7 x = minus_SNo one_third))
										        (forall x:set, x :e preimage_of A r6s ((closed_interval one_third 1) :/\: I) ->
										          apply_fun u7 x = one_third)
										        Hu7). }
										    claim Hu7_on_B7:
										      forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										        apply_fun u7 x = minus_SNo one_third.
										    { exact (andER
										        (continuous_map X Tx I0 T0 u7)
										        (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										          apply_fun u7 x = minus_SNo one_third)
										        Hu7AB). }
										    claim Hu7_on_C7:
										      forall x:set, x :e preimage_of A r6s ((closed_interval one_third 1) :/\: I) ->
										        apply_fun u7 x = one_third.
										    { exact (andER
										        (continuous_map X Tx I0 T0 u7 /\
										         (forall x:set, x :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										           apply_fun u7 x = minus_SNo one_third))
										        (forall x:set, x :e preimage_of A r6s ((closed_interval one_third 1) :/\: I) ->
										          apply_fun u7 x = one_third)
										        Hu7). }
										    let x. assume HxA: x :e A.
										    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
										    set I3 := closed_interval one_third 1.
										    set B7 := preimage_of A r6s (I1 :/\: I).
										    set C7 := preimage_of A r6s (I3 :/\: I).
										    claim Hr6sIx: apply_fun r6s x :e I.
										    { exact (continuous_map_function_on A Ta I Ti r6s Hr6s_cont x HxA). }
										    claim HB7_cases: x :e B7 \/ ~(x :e B7).
										    { exact (xm (x :e B7)). }
										    apply (HB7_cases (apply_fun r7 x :e I2)).
										    - assume HxB7: x :e B7.
										      claim Hu7eq: apply_fun u7 x = minus_SNo one_third.
										      { exact (Hu7_on_B7 x HxB7). }
										      claim Hr7eq: apply_fun r7 x = add_SNo (apply_fun r6s x) one_third.
										      { rewrite (Hr7_apply x HxA).
										        rewrite Hu7eq at 1.
										        claim H13R: one_third :e R.
										        { exact one_third_in_R. }
										        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
										        reflexivity. }
										      rewrite Hr7eq.
										      claim Hr6sI1I: apply_fun r6s x :e I1 :/\: I.
										      { exact (SepE2 A (fun x0:set => apply_fun r6s x0 :e I1 :/\: I) x HxB7). }
										      claim Hr6sI1: apply_fun r6s x :e I1.
										      { exact (binintersectE1 I1 I (apply_fun r6s x) Hr6sI1I). }
										      claim H13R: one_third :e R.
										      { exact one_third_in_R. }
										      claim H23R: two_thirds :e R.
										      { exact two_thirds_in_R. }
										      claim Hm23R: minus_SNo two_thirds :e R.
										      { exact (real_minus_SNo two_thirds H23R). }
										      claim Hm1R: minus_SNo 1 :e R.
										      { exact (real_minus_SNo 1 real_1). }
										      claim Hm13R: minus_SNo one_third :e R.
										      { exact (real_minus_SNo one_third H13R). }
										      claim Hr6sRx: apply_fun r6s x :e R.
										      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r6s x) Hr6sI1). }
										      claim Hr6s_bounds: Rle (minus_SNo 1) (apply_fun r6s x) /\ Rle (apply_fun r6s x) (minus_SNo one_third).
										      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r6s x)
										                                     Hm1R Hm13R Hr6sI1). }
										      claim Hm1le: Rle (minus_SNo 1) (apply_fun r6s x).
										      { exact (andEL (Rle (minus_SNo 1) (apply_fun r6s x))
										                     (Rle (apply_fun r6s x) (minus_SNo one_third)) Hr6s_bounds). }
										      claim HhiI1: Rle (apply_fun r6s x) (minus_SNo one_third).
										      { exact (andER (Rle (minus_SNo 1) (apply_fun r6s x))
										                     (Rle (apply_fun r6s x) (minus_SNo one_third)) Hr6s_bounds). }
										      claim Hr7Rx: add_SNo (apply_fun r6s x) one_third :e R.
										      { exact (real_add_SNo (apply_fun r6s x) Hr6sRx one_third H13R). }
										      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r6s x) one_third).
										      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r6s x) one_third Hm1R Hr6sRx H13R Hm1le). }
										      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r6s x) one_third).
										      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
										        exact Hlow_tmp. }
										      claim Hup0_tmp: Rle (add_SNo (apply_fun r6s x) one_third) (add_SNo (minus_SNo one_third) one_third).
										      { exact (Rle_add_SNo_1 (apply_fun r6s x) (minus_SNo one_third) one_third Hr6sRx Hm13R H13R HhiI1). }
										      claim H13S: SNo one_third.
										      { exact (real_SNo one_third H13R). }
										      claim Hup0: Rle (add_SNo (apply_fun r6s x) one_third) 0.
										      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
										        exact Hup0_tmp. }
										      claim H0le23: Rle 0 two_thirds.
										      { exact Rle_0_two_thirds. }
										      claim Hup: Rle (add_SNo (apply_fun r6s x) one_third) two_thirds.
										      { exact (Rle_tra (add_SNo (apply_fun r6s x) one_third) 0 two_thirds Hup0 H0le23). }
										      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
										                                     (add_SNo (apply_fun r6s x) one_third)
										                                     Hm23R H23R Hr7Rx Hlow Hup).
										    - assume HxnotB7: ~(x :e B7).
										      claim HC7_cases: x :e C7 \/ ~(x :e C7).
										      { exact (xm (x :e C7)). }
										      apply (HC7_cases (apply_fun r7 x :e I2)).
										      + assume HxC7: x :e C7.
										        claim Hu7eq: apply_fun u7 x = one_third.
										        { exact (Hu7_on_C7 x HxC7). }
										        claim Hr7eq: apply_fun r7 x = add_SNo (apply_fun r6s x) (minus_SNo one_third).
										        { rewrite (Hr7_apply x HxA).
										          rewrite Hu7eq at 1.
										          reflexivity. }
										        rewrite Hr7eq.
										        claim Hr6sI3I: apply_fun r6s x :e I3 :/\: I.
										        { exact (SepE2 A (fun x0:set => apply_fun r6s x0 :e I3 :/\: I) x HxC7). }
										        claim Hr6sI3: apply_fun r6s x :e I3.
										        { exact (binintersectE1 I3 I (apply_fun r6s x) Hr6sI3I). }
										        claim H13R: one_third :e R.
										        { exact one_third_in_R. }
										        claim H23R: two_thirds :e R.
										        { exact two_thirds_in_R. }
										        claim Hm23R: minus_SNo two_thirds :e R.
										        { exact (real_minus_SNo two_thirds H23R). }
										        claim Hm13R: minus_SNo one_third :e R.
										        { exact (real_minus_SNo one_third H13R). }
										        claim Hr6sRx: apply_fun r6s x :e R.
										        { exact (closed_interval_sub_R one_third 1 (apply_fun r6s x) Hr6sI3). }
										        claim Hr6s_bounds: Rle one_third (apply_fun r6s x) /\ Rle (apply_fun r6s x) 1.
										        { exact (closed_interval_bounds one_third 1 (apply_fun r6s x) H13R real_1 Hr6sI3). }
										        claim HloI3: Rle one_third (apply_fun r6s x).
										        { exact (andEL (Rle one_third (apply_fun r6s x)) (Rle (apply_fun r6s x) 1) Hr6s_bounds). }
										        claim HhiI3: Rle (apply_fun r6s x) 1.
										        { exact (andER (Rle one_third (apply_fun r6s x)) (Rle (apply_fun r6s x) 1) Hr6s_bounds). }
										        claim Hr7Rx: add_SNo (apply_fun r6s x) (minus_SNo one_third) :e R.
										        { exact (real_add_SNo (apply_fun r6s x) Hr6sRx (minus_SNo one_third) Hm13R). }
										        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
										                          (add_SNo (apply_fun r6s x) (minus_SNo one_third)).
										        { exact (Rle_add_SNo_1 one_third (apply_fun r6s x) (minus_SNo one_third)
										                               H13R Hr6sRx Hm13R HloI3). }
										        claim H13S: SNo one_third.
										        { exact (real_SNo one_third H13R). }
										        claim H0le: Rle 0 (add_SNo (apply_fun r6s x) (minus_SNo one_third)).
										        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
										          exact H0le_tmp. }
										        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
										        { exact Rle_minus_two_thirds_0. }
										        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r6s x) (minus_SNo one_third)).
										        { exact (Rle_tra (minus_SNo two_thirds) 0
										                         (add_SNo (apply_fun r6s x) (minus_SNo one_third))
										                         Hm23le0 H0le). }
										        claim Hup_tmp: Rle (add_SNo (apply_fun r6s x) (minus_SNo one_third))
										                         (add_SNo 1 (minus_SNo one_third)).
										        { exact (Rle_add_SNo_1 (apply_fun r6s x) 1 (minus_SNo one_third)
										                               Hr6sRx real_1 Hm13R HhiI3). }
										        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
										        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
										          exact (Rle_refl two_thirds H23R). }
										        claim Hup: Rle (add_SNo (apply_fun r6s x) (minus_SNo one_third)) two_thirds.
										        { exact (Rle_tra (add_SNo (apply_fun r6s x) (minus_SNo one_third))
										                         (add_SNo 1 (minus_SNo one_third))
										                         two_thirds
										                         Hup_tmp Hup1). }
										        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
										                                       (add_SNo (apply_fun r6s x) (minus_SNo one_third))
										                                       Hm23R H23R Hr7Rx Hlow Hup).
										      + assume HxnotC7: ~(x :e C7).
										        claim HxX: x :e X.
										        { exact (HAsubX x HxA). }
										        claim HnotI1: ~(apply_fun r6s x :e I1).
										        { assume Hr6sI1': apply_fun r6s x :e I1.
										          claim Hr6sI1I: apply_fun r6s x :e I1 :/\: I.
										          { exact (binintersectI I1 I (apply_fun r6s x) Hr6sI1' Hr6sIx). }
										          claim HxB7': x :e B7.
										          { exact (SepI A (fun x0:set => apply_fun r6s x0 :e I1 :/\: I) x HxA Hr6sI1I). }
										          apply FalseE.
										          exact (HxnotB7 HxB7'). }
										        claim HnotI3: ~(apply_fun r6s x :e I3).
										        { assume Hr6sI3': apply_fun r6s x :e I3.
										          claim Hr6sI3I: apply_fun r6s x :e I3 :/\: I.
										          { exact (binintersectI I3 I (apply_fun r6s x) Hr6sI3' Hr6sIx). }
										          claim HxC7': x :e C7.
										          { exact (SepI A (fun x0:set => apply_fun r6s x0 :e I3 :/\: I) x HxA Hr6sI3I). }
										          apply FalseE.
										          exact (HxnotC7 HxC7'). }
										        claim Hr6sRx: apply_fun r6s x :e R.
										        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r6s x) Hr6sIx). }
										        claim Hm1R: minus_SNo 1 :e R.
										        { exact (real_minus_SNo 1 real_1). }
										        claim H13R: one_third :e R.
										        { exact one_third_in_R. }
										        claim Hm13R: minus_SNo one_third :e R.
										        { exact (real_minus_SNo one_third H13R). }
										        claim Hr6s_boundsI: Rle (minus_SNo 1) (apply_fun r6s x) /\ Rle (apply_fun r6s x) 1.
										        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r6s x) Hm1R real_1 Hr6sIx). }
										        claim Hnlt_fx_m1: ~(Rlt (apply_fun r6s x) (minus_SNo 1)).
										        { exact (RleE_nlt (minus_SNo 1) (apply_fun r6s x)
										                          (andEL (Rle (minus_SNo 1) (apply_fun r6s x)) (Rle (apply_fun r6s x) 1) Hr6s_boundsI)). }
										        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r6s x)).
										        { exact (RleE_nlt (apply_fun r6s x) 1
										                          (andER (Rle (minus_SNo 1) (apply_fun r6s x)) (Rle (apply_fun r6s x) 1) Hr6s_boundsI)). }
										        claim HnotI1_cases: Rlt (apply_fun r6s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r6s x).
										        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r6s x)
										                                              Hm1R Hm13R Hr6sRx HnotI1). }
										        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r6s x).
										        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r6s x))).
										          - assume Hbad: Rlt (apply_fun r6s x) (minus_SNo 1).
										            apply FalseE.
										            exact (Hnlt_fx_m1 Hbad).
										          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r6s x).
										            exact Hok. }
										        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r6s x) (minus_SNo one_third)).
										        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r6s x) Hm13lt_fx). }
										        claim HnotI3_cases: Rlt (apply_fun r6s x) one_third \/ Rlt 1 (apply_fun r6s x).
										        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r6s x)
										                                              H13R real_1 Hr6sRx HnotI3). }
										        claim Hfx_lt_13: Rlt (apply_fun r6s x) one_third.
										        { apply (HnotI3_cases (Rlt (apply_fun r6s x) one_third)).
										          - assume Hok: Rlt (apply_fun r6s x) one_third.
										            exact Hok.
										          - assume Hbad: Rlt 1 (apply_fun r6s x).
										            apply FalseE.
										            exact (Hnlt_1_fx Hbad). }
										        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r6s x)).
										        { exact (not_Rlt_sym (apply_fun r6s x) one_third Hfx_lt_13). }
										        claim Hr6sI0: apply_fun r6s x :e I0.
										        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
										          { reflexivity. }
										          claim HxSep: apply_fun r6s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
										          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
										                        (apply_fun r6s x) Hr6sRx (andI (~(Rlt (apply_fun r6s x) (minus_SNo one_third)))
										                                                      (~(Rlt one_third (apply_fun r6s x)))
										                                                      Hnot_fx_lt_m13
										                                                      Hnot_13_lt_fx)). }
										          rewrite HI0_def.
										          exact HxSep. }
										        claim Hu7contI0: continuous_map X Tx I0 T0 u7.
										        { exact (andEL
										            (continuous_map X Tx I0 T0 u7)
										            (forall x0:set, x0 :e preimage_of A r6s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
										              apply_fun u7 x0 = minus_SNo one_third)
										            Hu7AB). }
										        claim Hu7funI0: function_on u7 X I0.
										        { exact (continuous_map_function_on X Tx I0 T0 u7 Hu7contI0). }
										        claim Hu7xI0: apply_fun u7 x :e I0.
										        { exact (Hu7funI0 x HxX). }
										        claim Hu7xR: apply_fun u7 x :e R.
										        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u7 x) Hu7xI0). }
										        claim Hm_u7x_R: minus_SNo (apply_fun u7 x) :e R.
										        { exact (real_minus_SNo (apply_fun u7 x) Hu7xR). }
										        rewrite (Hr7_apply x HxA).
										        claim Hr7xR: add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)) :e R.
										        { exact (real_add_SNo (apply_fun r6s x)
										                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r6s x) Hr6sI0)
										                              (minus_SNo (apply_fun u7 x)) Hm_u7x_R). }
										        claim H23R: two_thirds :e R.
										        { exact two_thirds_in_R. }
										        claim Hm23R: minus_SNo two_thirds :e R.
										        { exact (real_minus_SNo two_thirds H23R). }
										        claim Hr6s_bounds0: Rle (minus_SNo one_third) (apply_fun r6s x) /\ Rle (apply_fun r6s x) one_third.
										        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r6s x) Hm13R H13R Hr6sI0). }
										        claim Hu7_bounds0: Rle (minus_SNo one_third) (apply_fun u7 x) /\ Rle (apply_fun u7 x) one_third.
										        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u7 x) Hm13R H13R Hu7xI0). }
										        claim Hm13_le_r6s: Rle (minus_SNo one_third) (apply_fun r6s x).
										        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r6s x)) (Rle (apply_fun r6s x) one_third) Hr6s_bounds0). }
										        claim Hr6s_le_13: Rle (apply_fun r6s x) one_third.
										        { exact (andER (Rle (minus_SNo one_third) (apply_fun r6s x)) (Rle (apply_fun r6s x) one_third) Hr6s_bounds0). }
										        claim Hm13_le_u7x: Rle (minus_SNo one_third) (apply_fun u7 x).
										        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u7 x)) (Rle (apply_fun u7 x) one_third) Hu7_bounds0). }
										        claim Hu7x_le_13: Rle (apply_fun u7 x) one_third.
										        { exact (andER (Rle (minus_SNo one_third) (apply_fun u7 x)) (Rle (apply_fun u7 x) one_third) Hu7_bounds0). }
										        claim Hm13_le_mu7: Rle (minus_SNo one_third) (minus_SNo (apply_fun u7 x)).
										        { exact (Rle_minus_contra (apply_fun u7 x) one_third Hu7x_le_13). }
										        claim Hmu7_le_13: Rle (minus_SNo (apply_fun u7 x)) one_third.
										        { claim Htmp: Rle (minus_SNo (apply_fun u7 x)) (minus_SNo (minus_SNo one_third)).
										          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u7 x) Hm13_le_u7x). }
										          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
										          exact Htmp. }
										        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
										                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u7 x))).
										        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u7 x))
										                               Hm13R Hm13R Hm_u7x_R Hm13_le_mu7). }
										        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u7 x)))
										                      (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x))).
										        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r6s x) (minus_SNo (apply_fun u7 x))
										                               Hm13R
										                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r6s x) Hr6sI0)
										                               Hm_u7x_R
										                               Hm13_le_r6s). }
										        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
										                        (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x))).
										        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
										                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u7 x)))
										                         (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)))
										                         Hlow1 Hlow2). }
										        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x))).
										        { rewrite minus_two_thirds_eq at 1.
										          exact Hlow_tmp. }
										        claim Hup1: Rle (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)))
										                      (add_SNo (apply_fun r6s x) one_third).
										        { exact (Rle_add_SNo_2 (apply_fun r6s x) (minus_SNo (apply_fun u7 x)) one_third
										                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r6s x) Hr6sI0)
										                               Hm_u7x_R H13R Hmu7_le_13). }
										        claim Hup2: Rle (add_SNo (apply_fun r6s x) one_third)
										                      (add_SNo one_third one_third).
										        { exact (Rle_add_SNo_1 (apply_fun r6s x) one_third one_third
										                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r6s x) Hr6sI0)
										                               H13R H13R Hr6s_le_13). }
										        claim Hup_tmp: Rle (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)))
										                         (add_SNo one_third one_third).
										        { exact (Rle_tra (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)))
										                         (add_SNo (apply_fun r6s x) one_third)
										                         (add_SNo one_third one_third)
										                         Hup1 Hup2). }
										        claim Hdef23: two_thirds = add_SNo one_third one_third.
										        { reflexivity. }
										        claim Hup: Rle (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x))) two_thirds.
										        { rewrite Hdef23 at 1.
										          exact Hup_tmp. }
										        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
										                                       (add_SNo (apply_fun r6s x) (minus_SNo (apply_fun u7 x)))
										                                       Hm23R H23R Hr7xR Hlow Hup). }
 										  set r7s := compose_fun A r7 (div_const_fun den).
										  claim Hr7s_cont: continuous_map A Ta I Ti r7s.
										  { claim HRtop: topology_on R R_standard_topology.
										    { exact R_standard_topology_is_topology. }
										    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
										    { exact (div_const_fun_continuous_pos den H23R H23pos). }
										    claim Hr7s_contR: continuous_map A Ta R R_standard_topology r7s.
										    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
										             r7 (div_const_fun den) Hr7_cont Hdivcont). }
										    claim Hr7s_I: forall x:set, x :e A -> apply_fun r7s x :e I.
										    { let x. assume HxA: x :e A.
										      claim Hr7xI2: apply_fun r7 x :e I2.
										      { exact (Hr7_range x HxA). }
										      claim Hm1R: (minus_SNo 1) :e R.
										      { exact (real_minus_SNo 1 real_1). }
										      claim HmdenR: (minus_SNo den) :e R.
										      { exact (real_minus_SNo den H23R). }
										      claim Hr7xR: apply_fun r7 x :e R.
										      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r7 x) Hr7xI2). }
										      claim Hr7xS: SNo (apply_fun r7 x).
										      { exact (real_SNo (apply_fun r7 x) Hr7xR). }
										      claim Hbounds: Rle (minus_SNo den) (apply_fun r7 x) /\ Rle (apply_fun r7 x) den.
										      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r7 x) HmdenR H23R Hr7xI2). }
										      claim Hlo: Rle (minus_SNo den) (apply_fun r7 x).
										      { exact (andEL (Rle (minus_SNo den) (apply_fun r7 x))
										                     (Rle (apply_fun r7 x) den)
										                     Hbounds). }
										      claim Hhi: Rle (apply_fun r7 x) den.
										      { exact (andER (Rle (minus_SNo den) (apply_fun r7 x))
										                     (Rle (apply_fun r7 x) den)
										                     Hbounds). }
										      claim Hnlt_hi: ~(Rlt den (apply_fun r7 x)).
										      { exact (RleE_nlt (apply_fun r7 x) den Hhi). }
										      claim Hnlt_lo: ~(Rlt (apply_fun r7 x) (minus_SNo den)).
										      { exact (RleE_nlt (minus_SNo den) (apply_fun r7 x) Hlo). }
										      claim HyEq: apply_fun r7s x = div_SNo (apply_fun r7 x) den.
										      { rewrite (compose_fun_apply A r7 (div_const_fun den) x HxA).
										        rewrite (div_const_fun_apply den (apply_fun r7 x) H23R Hr7xR).
										        reflexivity. }
										      claim HyR: apply_fun r7s x :e R.
										      { rewrite HyEq.
										        exact (real_div_SNo (apply_fun r7 x) Hr7xR den H23R). }
										      claim HyS: SNo (apply_fun r7s x).
										      { exact (real_SNo (apply_fun r7s x) HyR). }
										      claim Hy_le_1: Rle (apply_fun r7s x) 1.
										      { apply (RleI (apply_fun r7s x) 1 HyR real_1).
										        prove ~(Rlt 1 (apply_fun r7s x)).
										        assume H1lt: Rlt 1 (apply_fun r7s x).
										        claim H1lty: 1 < apply_fun r7s x.
										        { exact (RltE_lt 1 (apply_fun r7s x) H1lt). }
										        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r7s x) den.
										        { exact (pos_mul_SNo_Lt' 1 (apply_fun r7s x) den SNo_1 HyS H23S H23pos H1lty). }
										        claim HmulLt': den < mul_SNo (apply_fun r7s x) den.
										        { rewrite <- (mul_SNo_oneL den H23S) at 1.
										          exact HmulLt. }
										        claim HmulEq: mul_SNo (apply_fun r7s x) den = apply_fun r7 x.
										        { rewrite HyEq at 1.
										          exact (mul_div_SNo_invL (apply_fun r7 x) den Hr7xS H23S H23ne0). }
										        claim Hden_lt_r7x: den < apply_fun r7 x.
										        { rewrite <- HmulEq.
										          exact HmulLt'. }
										        claim Hbad: Rlt den (apply_fun r7 x).
										        { exact (RltI den (apply_fun r7 x) H23R Hr7xR Hden_lt_r7x). }
										        exact (Hnlt_hi Hbad). }
										      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r7s x).
										      { apply (RleI (minus_SNo 1) (apply_fun r7s x) Hm1R HyR).
										        prove ~(Rlt (apply_fun r7s x) (minus_SNo 1)).
										        assume Hylt: Rlt (apply_fun r7s x) (minus_SNo 1).
										        claim Hylts: apply_fun r7s x < minus_SNo 1.
										        { exact (RltE_lt (apply_fun r7s x) (minus_SNo 1) Hylt). }
										        claim HmulLt: mul_SNo (apply_fun r7s x) den < mul_SNo (minus_SNo 1) den.
										        { exact (pos_mul_SNo_Lt' (apply_fun r7s x) (minus_SNo 1) den HyS
										                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
										        claim HmulEq: mul_SNo (apply_fun r7s x) den = apply_fun r7 x.
										        { rewrite HyEq at 1.
										          exact (mul_div_SNo_invL (apply_fun r7 x) den Hr7xS H23S H23ne0). }
										        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
										        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
										          rewrite (mul_SNo_oneL den H23S) at 1.
										          reflexivity. }
										        claim Hr7x_lt_mden: apply_fun r7 x < minus_SNo den.
										        { rewrite <- HmulEq.
										          rewrite <- HrhsEq.
										          exact HmulLt. }
										        claim Hbad: Rlt (apply_fun r7 x) (minus_SNo den).
										        { exact (RltI (apply_fun r7 x) (minus_SNo den) Hr7xR HmdenR Hr7x_lt_mden). }
										        exact (Hnlt_lo Hbad). }
											      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r7s x)
											                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
											    exact (continuous_map_range_restrict A Ta R R_standard_topology r7s I Hr7s_contR HIcR Hr7s_I). }

											  (** thirteenth correction step scaffold: build u8 and g8 from residual r7s **)
											  claim Hex_u8:
											    exists u8:set,
											      continuous_map X Tx I0 T0 u8 /\
											      (forall x:set, x :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
											        apply_fun u8 x = minus_SNo one_third) /\
											      (forall x:set, x :e preimage_of A r7s ((closed_interval one_third 1) :/\: I) ->
											        apply_fun u8 x = one_third).
											  { exact (Tietze_stepI_g_exists X Tx A r7s Hnorm HA Hr7s_cont). }
											  apply Hex_u8.
											  let u8. assume Hu8.
											  claim Hu8contI0: continuous_map X Tx I0 T0 u8.
											  { claim Hu8AB:
											      continuous_map X Tx I0 T0 u8 /\
											      (forall x:set, x :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
											        apply_fun u8 x = minus_SNo one_third).
											    { exact (andEL
											        (continuous_map X Tx I0 T0 u8 /\
											         (forall x:set, x :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
											           apply_fun u8 x = minus_SNo one_third))
											        (forall x:set, x :e preimage_of A r7s ((closed_interval one_third 1) :/\: I) ->
											          apply_fun u8 x = one_third)
											        Hu8). }
											    exact (andEL
											        (continuous_map X Tx I0 T0 u8)
											        (forall x:set, x :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
											          apply_fun u8 x = minus_SNo one_third)
											        Hu8AB). }
											  claim Hu8contR: continuous_map X Tx R R_standard_topology u8.
											  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
											    { reflexivity. }
											    claim HI0subR: I0 c= R.
											    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
											    exact (continuous_map_range_expand
											             X Tx I0 T0
											             R R_standard_topology
											             u8
											             Hu8contI0
											             HI0subR
											             R_standard_topology_is_topology_local
											             HT0eq). }
											  set den8 := mul_SNo den7 den.
											  claim Hden8R: den8 :e R.
											  { exact (real_mul_SNo den7 Hden7R den H23R). }
											  claim Hden8pos: 0 < den8.
											  { claim Hden7S: SNo den7.
											    { exact (real_SNo den7 Hden7R). }
											    exact (mul_SNo_pos_pos den7 den Hden7S H23S Hden7pos HdenPos). }
											  set u8s := compose_fun X u8 (mul_const_fun den8).
											  claim Hu8s_cont: continuous_map X Tx R R_standard_topology u8s.
											  { exact (scale_continuous_mul_const_pos X Tx u8 den8 HTx Hu8contR Hden8R Hden8pos). }
											  set g8 := compose_fun X (pair_map X g7 u8s) add_fun_R.
											  claim Hg8cont: continuous_map X Tx R R_standard_topology g8.
											  { exact (add_two_continuous_R X Tx g7 u8s HTx Hg7cont Hu8s_cont). }

											  (** fourteenth correction step scaffold: residual r8 on A and scaling r8s **)
											  claim Hu8contA: continuous_map A Ta R R_standard_topology u8.
											  { exact (continuous_on_subspace X Tx R R_standard_topology u8 A HTx HAsubX Hu8contR). }
											  set u8neg := compose_fun A u8 neg_fun.
											  claim Hu8neg_cont: continuous_map A Ta R R_standard_topology u8neg.
											  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
											           u8 neg_fun Hu8contA Hnegcont). }
											  claim Hr7s_contR: continuous_map A Ta R R_standard_topology r7s.
											  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r7s
											           Hr7s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
											  set r8 := compose_fun A (pair_map A r7s u8neg) add_fun_R.
											  claim Hr8_cont: continuous_map A Ta R R_standard_topology r8.
											  { exact (add_two_continuous_R A Ta r7s u8neg HTa Hr7s_contR Hu8neg_cont). }
											  claim Hr8_apply: forall x:set, x :e A ->
											    apply_fun r8 x = add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)).
											  { let x. assume HxA: x :e A.
											    claim Hpimg: apply_fun (pair_map A r7s u8neg) x :e setprod R R.
											    { rewrite (pair_map_apply A R R r7s u8neg x HxA).
											      claim Hr7sxI: apply_fun r7s x :e I.
											      { exact (continuous_map_function_on A Ta I Ti r7s Hr7s_cont x HxA). }
											      claim Hr7sxR: apply_fun r7s x :e R.
											      { exact (HIcR (apply_fun r7s x) Hr7sxI). }
											      claim Hu8negRx: apply_fun u8neg x :e R.
											      { exact (continuous_map_function_on A Ta R R_standard_topology u8neg Hu8neg_cont x HxA). }
											      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r7s x) (apply_fun u8neg x) Hr7sxR Hu8negRx). }
											    rewrite (compose_fun_apply A (pair_map A r7s u8neg) add_fun_R x HxA).
											    rewrite (add_fun_R_apply (apply_fun (pair_map A r7s u8neg) x) Hpimg) at 1.
											    rewrite (pair_map_apply A R R r7s u8neg x HxA).
											    rewrite (tuple_2_0_eq (apply_fun r7s x) (apply_fun u8neg x)).
											    rewrite (tuple_2_1_eq (apply_fun r7s x) (apply_fun u8neg x)).
											    rewrite (compose_fun_apply A u8 neg_fun x HxA) at 1.
											    claim Hu8Rx: apply_fun u8 x :e R.
											    { exact (continuous_map_function_on A Ta R R_standard_topology u8 Hu8contA x HxA). }
												    rewrite (neg_fun_apply (apply_fun u8 x) Hu8Rx) at 1.
												    reflexivity. }
												  claim Hr8_range: forall x:set, x :e A -> apply_fun r8 x :e I2.
												  { claim Hu8AB:
												      continuous_map X Tx I0 T0 u8 /\
												      (forall x0:set, x0 :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u8 x0 = minus_SNo one_third).
												    { exact (andEL
												        (continuous_map X Tx I0 T0 u8 /\
												         (forall x0:set, x0 :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												           apply_fun u8 x0 = minus_SNo one_third))
												        (forall x0:set, x0 :e preimage_of A r7s ((closed_interval one_third 1) :/\: I) ->
												          apply_fun u8 x0 = one_third)
												        Hu8). }
												    claim Hu8_on_B8:
												      forall x0:set, x0 :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u8 x0 = minus_SNo one_third.
												    { exact (andER
												        (continuous_map X Tx I0 T0 u8)
												        (forall x0:set, x0 :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												          apply_fun u8 x0 = minus_SNo one_third)
												        Hu8AB). }
												    claim Hu8_on_C8:
												      forall x0:set, x0 :e preimage_of A r7s ((closed_interval one_third 1) :/\: I) ->
												        apply_fun u8 x0 = one_third.
												    { exact (andER
												        (continuous_map X Tx I0 T0 u8 /\
												         (forall x0:set, x0 :e preimage_of A r7s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												           apply_fun u8 x0 = minus_SNo one_third))
												        (forall x0:set, x0 :e preimage_of A r7s ((closed_interval one_third 1) :/\: I) ->
												          apply_fun u8 x0 = one_third)
												        Hu8). }
												    let x. assume HxA: x :e A.
												    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
												    set I3 := closed_interval one_third 1.
												    set B8 := preimage_of A r7s (I1 :/\: I).
												    set C8 := preimage_of A r7s (I3 :/\: I).
												    claim Hr7sIx: apply_fun r7s x :e I.
												    { exact (continuous_map_function_on A Ta I Ti r7s Hr7s_cont x HxA). }
												    claim HB8_cases: x :e B8 \/ ~(x :e B8).
												    { exact (xm (x :e B8)). }
												    apply (HB8_cases (apply_fun r8 x :e I2)).
												    - assume HxB8: x :e B8.
												      claim Hu8eq: apply_fun u8 x = minus_SNo one_third.
												      { exact (Hu8_on_B8 x HxB8). }
												      claim Hr8eq: apply_fun r8 x = add_SNo (apply_fun r7s x) one_third.
												      { rewrite (Hr8_apply x HxA).
												        rewrite Hu8eq at 1.
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
												        reflexivity. }
												      rewrite Hr8eq.
												      claim Hr7sI1I: apply_fun r7s x :e I1 :/\: I.
												      { exact (SepE2 A (fun x0:set => apply_fun r7s x0 :e I1 :/\: I) x HxB8). }
												      claim Hr7sI1: apply_fun r7s x :e I1.
												      { exact (binintersectE1 I1 I (apply_fun r7s x) Hr7sI1I). }
												      claim H13R: one_third :e R.
												      { exact one_third_in_R. }
												      claim H23R: two_thirds :e R.
												      { exact two_thirds_in_R. }
												      claim Hm23R: minus_SNo two_thirds :e R.
												      { exact (real_minus_SNo two_thirds H23R). }
												      claim Hm1R: minus_SNo 1 :e R.
												      { exact (real_minus_SNo 1 real_1). }
												      claim Hm13R: minus_SNo one_third :e R.
												      { exact (real_minus_SNo one_third H13R). }
												      claim Hr7sRx: apply_fun r7s x :e R.
												      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r7s x) Hr7sI1). }
												      claim Hr7s_bounds: Rle (minus_SNo 1) (apply_fun r7s x) /\ Rle (apply_fun r7s x) (minus_SNo one_third).
												      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r7s x)
												                                     Hm1R Hm13R Hr7sI1). }
												      claim Hm1le: Rle (minus_SNo 1) (apply_fun r7s x).
												      { exact (andEL (Rle (minus_SNo 1) (apply_fun r7s x))
												                     (Rle (apply_fun r7s x) (minus_SNo one_third)) Hr7s_bounds). }
												      claim HhiI1: Rle (apply_fun r7s x) (minus_SNo one_third).
												      { exact (andER (Rle (minus_SNo 1) (apply_fun r7s x))
												                     (Rle (apply_fun r7s x) (minus_SNo one_third)) Hr7s_bounds). }
												      claim Hr8xR: add_SNo (apply_fun r7s x) one_third :e R.
												      { exact (real_add_SNo (apply_fun r7s x) Hr7sRx one_third H13R). }
												      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r7s x) one_third).
												      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r7s x) one_third Hm1R Hr7sRx H13R Hm1le). }
												      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r7s x) one_third).
												      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
												        exact Hlow_tmp. }
												      claim Hup0_tmp: Rle (add_SNo (apply_fun r7s x) one_third) (add_SNo (minus_SNo one_third) one_third).
												      { exact (Rle_add_SNo_1 (apply_fun r7s x) (minus_SNo one_third) one_third Hr7sRx Hm13R H13R HhiI1). }
												      claim H13S: SNo one_third.
												      { exact (real_SNo one_third H13R). }
												      claim Hup0: Rle (add_SNo (apply_fun r7s x) one_third) 0.
												      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
												        exact Hup0_tmp. }
												      claim H0le23: Rle 0 two_thirds.
												      { exact Rle_0_two_thirds. }
												      claim Hup: Rle (add_SNo (apply_fun r7s x) one_third) two_thirds.
												      { exact (Rle_tra (add_SNo (apply_fun r7s x) one_third) 0 two_thirds Hup0 H0le23). }
												      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                     (add_SNo (apply_fun r7s x) one_third)
												                                     Hm23R H23R Hr8xR Hlow Hup).
												    - assume HxnotB8: ~(x :e B8).
												      claim HC8_cases: x :e C8 \/ ~(x :e C8).
												      { exact (xm (x :e C8)). }
												      apply (HC8_cases (apply_fun r8 x :e I2)).
												      + assume HxC8: x :e C8.
												        claim Hu8eq: apply_fun u8 x = one_third.
												        { exact (Hu8_on_C8 x HxC8). }
												        claim Hr8eq: apply_fun r8 x = add_SNo (apply_fun r7s x) (minus_SNo one_third).
												        { rewrite (Hr8_apply x HxA).
												          rewrite Hu8eq at 1.
												          reflexivity. }
												        rewrite Hr8eq.
												        claim Hr7sI3I: apply_fun r7s x :e I3 :/\: I.
												        { exact (SepE2 A (fun x0:set => apply_fun r7s x0 :e I3 :/\: I) x HxC8). }
												        claim Hr7sI3: apply_fun r7s x :e I3.
												        { exact (binintersectE1 I3 I (apply_fun r7s x) Hr7sI3I). }
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        claim H23R: two_thirds :e R.
												        { exact two_thirds_in_R. }
												        claim Hm23R: minus_SNo two_thirds :e R.
												        { exact (real_minus_SNo two_thirds H23R). }
												        claim Hm13R: minus_SNo one_third :e R.
												        { exact (real_minus_SNo one_third H13R). }
												        claim Hr7sRx: apply_fun r7s x :e R.
												        { exact (closed_interval_sub_R one_third 1 (apply_fun r7s x) Hr7sI3). }
												        claim Hr7s_bounds: Rle one_third (apply_fun r7s x) /\ Rle (apply_fun r7s x) 1.
												        { exact (closed_interval_bounds one_third 1 (apply_fun r7s x) H13R real_1 Hr7sI3). }
												        claim HloI3: Rle one_third (apply_fun r7s x).
												        { exact (andEL (Rle one_third (apply_fun r7s x)) (Rle (apply_fun r7s x) 1) Hr7s_bounds). }
												        claim HhiI3: Rle (apply_fun r7s x) 1.
												        { exact (andER (Rle one_third (apply_fun r7s x)) (Rle (apply_fun r7s x) 1) Hr7s_bounds). }
												        claim Hr8xR: add_SNo (apply_fun r7s x) (minus_SNo one_third) :e R.
												        { exact (real_add_SNo (apply_fun r7s x) Hr7sRx (minus_SNo one_third) Hm13R). }
												        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
												                          (add_SNo (apply_fun r7s x) (minus_SNo one_third)).
												        { exact (Rle_add_SNo_1 one_third (apply_fun r7s x) (minus_SNo one_third)
												                               H13R Hr7sRx Hm13R HloI3). }
												        claim H13S: SNo one_third.
												        { exact (real_SNo one_third H13R). }
												        claim H0le: Rle 0 (add_SNo (apply_fun r7s x) (minus_SNo one_third)).
												        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
												          exact H0le_tmp. }
												        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
												        { exact Rle_minus_two_thirds_0. }
												        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r7s x) (minus_SNo one_third)).
												        { exact (Rle_tra (minus_SNo two_thirds) 0
												                         (add_SNo (apply_fun r7s x) (minus_SNo one_third))
												                         Hm23le0 H0le). }
												        claim Hup_tmp: Rle (add_SNo (apply_fun r7s x) (minus_SNo one_third))
												                         (add_SNo 1 (minus_SNo one_third)).
												        { exact (Rle_add_SNo_1 (apply_fun r7s x) 1 (minus_SNo one_third)
												                               Hr7sRx real_1 Hm13R HhiI3). }
												        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
												        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
												          exact (Rle_refl two_thirds H23R). }
												        claim Hup: Rle (add_SNo (apply_fun r7s x) (minus_SNo one_third)) two_thirds.
												        { exact (Rle_tra (add_SNo (apply_fun r7s x) (minus_SNo one_third))
												                         (add_SNo 1 (minus_SNo one_third))
												                         two_thirds
												                         Hup_tmp Hup1). }
												        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                       (add_SNo (apply_fun r7s x) (minus_SNo one_third))
												                                       Hm23R H23R Hr8xR Hlow Hup).
												      + assume HxnotC8: ~(x :e C8).
												        claim HxX: x :e X.
												        { exact (HAsubX x HxA). }
												        claim HnotI1: ~(apply_fun r7s x :e I1).
												        { assume Hr7sI1': apply_fun r7s x :e I1.
												          claim Hr7sI1I: apply_fun r7s x :e I1 :/\: I.
												          { exact (binintersectI I1 I (apply_fun r7s x) Hr7sI1' Hr7sIx). }
												          claim HxB8': x :e B8.
												          { exact (SepI A (fun x0:set => apply_fun r7s x0 :e I1 :/\: I) x HxA Hr7sI1I). }
												          apply FalseE.
												          exact (HxnotB8 HxB8'). }
												        claim HnotI3: ~(apply_fun r7s x :e I3).
												        { assume Hr7sI3': apply_fun r7s x :e I3.
												          claim Hr7sI3I: apply_fun r7s x :e I3 :/\: I.
												          { exact (binintersectI I3 I (apply_fun r7s x) Hr7sI3' Hr7sIx). }
												          claim HxC8': x :e C8.
												          { exact (SepI A (fun x0:set => apply_fun r7s x0 :e I3 :/\: I) x HxA Hr7sI3I). }
												          apply FalseE.
												          exact (HxnotC8 HxC8'). }
												        claim Hr7sRx: apply_fun r7s x :e R.
												        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r7s x) Hr7sIx). }
												        claim Hm1R: minus_SNo 1 :e R.
												        { exact (real_minus_SNo 1 real_1). }
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        claim Hm13R: minus_SNo one_third :e R.
												        { exact (real_minus_SNo one_third H13R). }
												        claim Hr7s_boundsI: Rle (minus_SNo 1) (apply_fun r7s x) /\ Rle (apply_fun r7s x) 1.
												        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r7s x) Hm1R real_1 Hr7sIx). }
												        claim Hnlt_fx_m1: ~(Rlt (apply_fun r7s x) (minus_SNo 1)).
												        { exact (RleE_nlt (minus_SNo 1) (apply_fun r7s x)
												                          (andEL (Rle (minus_SNo 1) (apply_fun r7s x)) (Rle (apply_fun r7s x) 1) Hr7s_boundsI)). }
												        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r7s x)).
												        { exact (RleE_nlt (apply_fun r7s x) 1
												                          (andER (Rle (minus_SNo 1) (apply_fun r7s x)) (Rle (apply_fun r7s x) 1) Hr7s_boundsI)). }
												        claim HnotI1_cases: Rlt (apply_fun r7s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r7s x).
												        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r7s x)
												                                              Hm1R Hm13R Hr7sRx HnotI1). }
												        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r7s x).
												        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r7s x))).
												          - assume Hbad: Rlt (apply_fun r7s x) (minus_SNo 1).
												            apply FalseE.
												            exact (Hnlt_fx_m1 Hbad).
												          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r7s x).
												            exact Hok. }
												        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r7s x) (minus_SNo one_third)).
												        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r7s x) Hm13lt_fx). }
												        claim HnotI3_cases: Rlt (apply_fun r7s x) one_third \/ Rlt 1 (apply_fun r7s x).
												        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r7s x)
												                                              H13R real_1 Hr7sRx HnotI3). }
												        claim Hfx_lt_13: Rlt (apply_fun r7s x) one_third.
												        { apply (HnotI3_cases (Rlt (apply_fun r7s x) one_third)).
												          - assume Hok: Rlt (apply_fun r7s x) one_third.
												            exact Hok.
												          - assume Hbad: Rlt 1 (apply_fun r7s x).
												            apply FalseE.
												            exact (Hnlt_1_fx Hbad). }
												        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r7s x)).
												        { exact (not_Rlt_sym (apply_fun r7s x) one_third Hfx_lt_13). }
												        claim Hr7sI0: apply_fun r7s x :e I0.
												        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
												          { reflexivity. }
												          claim HxSep: apply_fun r7s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
												          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
												                        (apply_fun r7s x) Hr7sRx (andI (~(Rlt (apply_fun r7s x) (minus_SNo one_third)))
												                                                      (~(Rlt one_third (apply_fun r7s x)))
												                                                      Hnot_fx_lt_m13
												                                                      Hnot_13_lt_fx)). }
												          rewrite HI0_def.
												          exact HxSep. }
												        claim Hu8funI0: function_on u8 X I0.
												        { exact (continuous_map_function_on X Tx I0 T0 u8 Hu8contI0). }
												        claim Hu8xI0: apply_fun u8 x :e I0.
												        { exact (Hu8funI0 x HxX). }
												        claim Hu8xR: apply_fun u8 x :e R.
												        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u8 x) Hu8xI0). }
												        claim Hm_u8x_R: minus_SNo (apply_fun u8 x) :e R.
												        { exact (real_minus_SNo (apply_fun u8 x) Hu8xR). }
												        rewrite (Hr8_apply x HxA).
												        claim Hr8xR: add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)) :e R.
												        { exact (real_add_SNo (apply_fun r7s x)
												                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r7s x) Hr7sI0)
												                              (minus_SNo (apply_fun u8 x)) Hm_u8x_R). }
												        claim H23R: two_thirds :e R.
												        { exact two_thirds_in_R. }
												        claim Hm23R: minus_SNo two_thirds :e R.
												        { exact (real_minus_SNo two_thirds H23R). }
												        claim Hr7s_bounds0: Rle (minus_SNo one_third) (apply_fun r7s x) /\ Rle (apply_fun r7s x) one_third.
												        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r7s x) Hm13R H13R Hr7sI0). }
												        claim Hu8_bounds0: Rle (minus_SNo one_third) (apply_fun u8 x) /\ Rle (apply_fun u8 x) one_third.
												        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u8 x) Hm13R H13R Hu8xI0). }
												        claim Hm13_le_r7s: Rle (minus_SNo one_third) (apply_fun r7s x).
												        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r7s x)) (Rle (apply_fun r7s x) one_third) Hr7s_bounds0). }
												        claim Hr7s_le_13: Rle (apply_fun r7s x) one_third.
												        { exact (andER (Rle (minus_SNo one_third) (apply_fun r7s x)) (Rle (apply_fun r7s x) one_third) Hr7s_bounds0). }
												        claim Hm13_le_u8x: Rle (minus_SNo one_third) (apply_fun u8 x).
												        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u8 x)) (Rle (apply_fun u8 x) one_third) Hu8_bounds0). }
												        claim Hu8x_le_13: Rle (apply_fun u8 x) one_third.
												        { exact (andER (Rle (minus_SNo one_third) (apply_fun u8 x)) (Rle (apply_fun u8 x) one_third) Hu8_bounds0). }
												        claim Hm13_le_mu8: Rle (minus_SNo one_third) (minus_SNo (apply_fun u8 x)).
												        { exact (Rle_minus_contra (apply_fun u8 x) one_third Hu8x_le_13). }
												        claim Hmu8_le_13: Rle (minus_SNo (apply_fun u8 x)) one_third.
												        { claim Htmp: Rle (minus_SNo (apply_fun u8 x)) (minus_SNo (minus_SNo one_third)).
												          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u8 x) Hm13_le_u8x). }
												          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
												          exact Htmp. }
												        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u8 x))).
												        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u8 x))
												                               Hm13R Hm13R Hm_u8x_R Hm13_le_mu8). }
												        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u8 x)))
												                      (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x))).
												        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r7s x) (minus_SNo (apply_fun u8 x))
												                               Hm13R
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r7s x) Hr7sI0)
												                               Hm_u8x_R
												                               Hm13_le_r7s). }
												        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                        (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x))).
												        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u8 x)))
												                         (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)))
												                         Hlow1 Hlow2). }
												        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x))).
												        { rewrite minus_two_thirds_eq at 1.
												          exact Hlow_tmp. }
												        claim Hup1: Rle (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)))
												                      (add_SNo (apply_fun r7s x) one_third).
												        { exact (Rle_add_SNo_2 (apply_fun r7s x) (minus_SNo (apply_fun u8 x)) one_third
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r7s x) Hr7sI0)
												                               Hm_u8x_R H13R Hmu8_le_13). }
												        claim Hup2: Rle (add_SNo (apply_fun r7s x) one_third)
												                      (add_SNo one_third one_third).
												        { exact (Rle_add_SNo_1 (apply_fun r7s x) one_third one_third
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r7s x) Hr7sI0)
												                               H13R H13R Hr7s_le_13). }
												        claim Hup_tmp: Rle (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)))
												                         (add_SNo one_third one_third).
												        { exact (Rle_tra (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)))
												                         (add_SNo (apply_fun r7s x) one_third)
												                         (add_SNo one_third one_third)
												                         Hup1 Hup2). }
												        claim Hdef23: two_thirds = add_SNo one_third one_third.
												        { reflexivity. }
												        claim Hup: Rle (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x))) two_thirds.
												        { rewrite Hdef23 at 1.
												          exact Hup_tmp. }
												        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                       (add_SNo (apply_fun r7s x) (minus_SNo (apply_fun u8 x)))
												                                       Hm23R H23R Hr8xR Hlow Hup). }
												  set r8s := compose_fun A r8 (div_const_fun den).
												  claim Hr8s_cont: continuous_map A Ta I Ti r8s.
												  { claim HRtop: topology_on R R_standard_topology.
												    { exact R_standard_topology_is_topology. }
												    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
												    { exact (div_const_fun_continuous_pos den H23R H23pos). }
												    claim Hr8s_contR: continuous_map A Ta R R_standard_topology r8s.
												    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
												             r8 (div_const_fun den) Hr8_cont Hdivcont). }
												    claim Hr8s_I: forall x:set, x :e A -> apply_fun r8s x :e I.
												    { let x. assume HxA: x :e A.
												      claim Hr8xI2: apply_fun r8 x :e I2.
												      { exact (Hr8_range x HxA). }
												      claim Hm1R: (minus_SNo 1) :e R.
												      { exact (real_minus_SNo 1 real_1). }
												      claim HmdenR: (minus_SNo den) :e R.
												      { exact (real_minus_SNo den H23R). }
												      claim Hr8xR: apply_fun r8 x :e R.
												      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r8 x) Hr8xI2). }
												      claim Hr8xS: SNo (apply_fun r8 x).
												      { exact (real_SNo (apply_fun r8 x) Hr8xR). }
												      claim Hbounds: Rle (minus_SNo den) (apply_fun r8 x) /\ Rle (apply_fun r8 x) den.
												      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r8 x) HmdenR H23R Hr8xI2). }
												      claim Hlo: Rle (minus_SNo den) (apply_fun r8 x).
												      { exact (andEL (Rle (minus_SNo den) (apply_fun r8 x))
												                     (Rle (apply_fun r8 x) den)
												                     Hbounds). }
												      claim Hhi: Rle (apply_fun r8 x) den.
												      { exact (andER (Rle (minus_SNo den) (apply_fun r8 x))
												                     (Rle (apply_fun r8 x) den)
												                     Hbounds). }
												      claim Hnlt_hi: ~(Rlt den (apply_fun r8 x)).
												      { exact (RleE_nlt (apply_fun r8 x) den Hhi). }
												      claim Hnlt_lo: ~(Rlt (apply_fun r8 x) (minus_SNo den)).
												      { exact (RleE_nlt (minus_SNo den) (apply_fun r8 x) Hlo). }
												      claim HyEq: apply_fun r8s x = div_SNo (apply_fun r8 x) den.
												      { rewrite (compose_fun_apply A r8 (div_const_fun den) x HxA).
												        rewrite (div_const_fun_apply den (apply_fun r8 x) H23R Hr8xR).
												        reflexivity. }
												      claim HyR: apply_fun r8s x :e R.
												      { rewrite HyEq.
												        exact (real_div_SNo (apply_fun r8 x) Hr8xR den H23R). }
												      claim HyS: SNo (apply_fun r8s x).
												      { exact (real_SNo (apply_fun r8s x) HyR). }
												      claim Hy_le_1: Rle (apply_fun r8s x) 1.
												      { apply (RleI (apply_fun r8s x) 1 HyR real_1).
												        prove ~(Rlt 1 (apply_fun r8s x)).
												        assume H1lt: Rlt 1 (apply_fun r8s x).
												        claim H1lty: 1 < apply_fun r8s x.
												        { exact (RltE_lt 1 (apply_fun r8s x) H1lt). }
												        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r8s x) den.
												        { exact (pos_mul_SNo_Lt' 1 (apply_fun r8s x) den SNo_1 HyS H23S H23pos H1lty). }
												        claim HmulLt': den < mul_SNo (apply_fun r8s x) den.
												        { rewrite <- (mul_SNo_oneL den H23S) at 1.
												          exact HmulLt. }
												        claim HmulEq: mul_SNo (apply_fun r8s x) den = apply_fun r8 x.
												        { rewrite HyEq at 1.
												          exact (mul_div_SNo_invL (apply_fun r8 x) den Hr8xS H23S H23ne0). }
												        claim Hden_lt_r8x: den < apply_fun r8 x.
												        { rewrite <- HmulEq.
												          exact HmulLt'. }
												        claim Hbad: Rlt den (apply_fun r8 x).
												        { exact (RltI den (apply_fun r8 x) H23R Hr8xR Hden_lt_r8x). }
												        exact (Hnlt_hi Hbad). }
												      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r8s x).
												      { apply (RleI (minus_SNo 1) (apply_fun r8s x) Hm1R HyR).
												        prove ~(Rlt (apply_fun r8s x) (minus_SNo 1)).
												        assume Hylt: Rlt (apply_fun r8s x) (minus_SNo 1).
												        claim Hylts: apply_fun r8s x < minus_SNo 1.
												        { exact (RltE_lt (apply_fun r8s x) (minus_SNo 1) Hylt). }
												        claim HmulLt: mul_SNo (apply_fun r8s x) den < mul_SNo (minus_SNo 1) den.
												        { exact (pos_mul_SNo_Lt' (apply_fun r8s x) (minus_SNo 1) den HyS
												                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
												        claim HmulEq: mul_SNo (apply_fun r8s x) den = apply_fun r8 x.
												        { rewrite HyEq at 1.
												          exact (mul_div_SNo_invL (apply_fun r8 x) den Hr8xS H23S H23ne0). }
												        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
												        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
												          rewrite (mul_SNo_oneL den H23S) at 1.
												          reflexivity. }
												        claim Hr8x_lt_mden: apply_fun r8 x < minus_SNo den.
												        { rewrite <- HmulEq.
												          rewrite <- HrhsEq.
												          exact HmulLt. }
												        claim Hbad: Rlt (apply_fun r8 x) (minus_SNo den).
												        { exact (RltI (apply_fun r8 x) (minus_SNo den) Hr8xR HmdenR Hr8x_lt_mden). }
												        exact (Hnlt_lo Hbad). }
												      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r8s x)
												                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
												    exact (continuous_map_range_restrict A Ta R R_standard_topology r8s I Hr8s_contR HIcR Hr8s_I). }

												  (** fifteenth correction step scaffold: build u9 and g9 from residual r8s **)
												  claim Hex_u9:
												    exists u9:set,
												      continuous_map X Tx I0 T0 u9 /\
												      (forall x:set, x :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u9 x = minus_SNo one_third) /\
												      (forall x:set, x :e preimage_of A r8s ((closed_interval one_third 1) :/\: I) ->
												        apply_fun u9 x = one_third).
												  { exact (Tietze_stepI_g_exists X Tx A r8s Hnorm HA Hr8s_cont). }
												  apply Hex_u9.
												  let u9. assume Hu9.
												  claim Hu9contI0: continuous_map X Tx I0 T0 u9.
												  { claim Hu9AB:
												      continuous_map X Tx I0 T0 u9 /\
												      (forall x:set, x :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u9 x = minus_SNo one_third).
												    { exact (andEL
												        (continuous_map X Tx I0 T0 u9 /\
												         (forall x:set, x :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												           apply_fun u9 x = minus_SNo one_third))
												        (forall x:set, x :e preimage_of A r8s ((closed_interval one_third 1) :/\: I) ->
												          apply_fun u9 x = one_third)
												        Hu9). }
												    exact (andEL
												        (continuous_map X Tx I0 T0 u9)
												        (forall x:set, x :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												          apply_fun u9 x = minus_SNo one_third)
												        Hu9AB). }
												  claim Hu9contR: continuous_map X Tx R R_standard_topology u9.
												  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
												    { reflexivity. }
												    claim HI0subR: I0 c= R.
												    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
												    exact (continuous_map_range_expand
												             X Tx I0 T0
												             R R_standard_topology
												             u9
												             Hu9contI0
												             HI0subR
												             R_standard_topology_is_topology_local
												             HT0eq). }
												  set den9 := mul_SNo den8 den.
												  claim Hden9R: den9 :e R.
												  { exact (real_mul_SNo den8 Hden8R den H23R). }
												  claim Hden9pos: 0 < den9.
												  { claim Hden8S: SNo den8.
												    { exact (real_SNo den8 Hden8R). }
												    exact (mul_SNo_pos_pos den8 den Hden8S H23S Hden8pos HdenPos). }
												  set u9s := compose_fun X u9 (mul_const_fun den9).
												  claim Hu9s_cont: continuous_map X Tx R R_standard_topology u9s.
												  { exact (scale_continuous_mul_const_pos X Tx u9 den9 HTx Hu9contR Hden9R Hden9pos). }
												  set g9 := compose_fun X (pair_map X g8 u9s) add_fun_R.
												  claim Hg9cont: continuous_map X Tx R R_standard_topology g9.
												  { exact (add_two_continuous_R X Tx g8 u9s HTx Hg8cont Hu9s_cont). }

												  (** fifteenth correction step scaffold: residual r9 on A and scaling r9s **)
												  claim Hu9contA: continuous_map A Ta R R_standard_topology u9.
												  { exact (continuous_on_subspace X Tx R R_standard_topology u9 A HTx HAsubX Hu9contR). }
												  set u9neg := compose_fun A u9 neg_fun.
												  claim Hu9neg_cont: continuous_map A Ta R R_standard_topology u9neg.
												  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
												           u9 neg_fun Hu9contA Hnegcont). }
												  claim Hr8s_contR: continuous_map A Ta R R_standard_topology r8s.
												  { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r8s
												           Hr8s_cont HIcR R_standard_topology_is_topology_local HTiEq). }
												  set r9 := compose_fun A (pair_map A r8s u9neg) add_fun_R.
												  claim Hr9_cont: continuous_map A Ta R R_standard_topology r9.
												  { exact (add_two_continuous_R A Ta r8s u9neg HTa Hr8s_contR Hu9neg_cont). }
												  claim Hr9_apply: forall x:set, x :e A ->
												    apply_fun r9 x = add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)).
												  { let x. assume HxA: x :e A.
												    claim Hpimg: apply_fun (pair_map A r8s u9neg) x :e setprod R R.
												    { rewrite (pair_map_apply A R R r8s u9neg x HxA).
												      claim Hr8sxI: apply_fun r8s x :e I.
												      { exact (continuous_map_function_on A Ta I Ti r8s Hr8s_cont x HxA). }
												      claim Hr8sxR: apply_fun r8s x :e R.
												      { exact (HIcR (apply_fun r8s x) Hr8sxI). }
												      claim Hu9negRx: apply_fun u9neg x :e R.
												      { exact (continuous_map_function_on A Ta R R_standard_topology u9neg Hu9neg_cont x HxA). }
												      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r8s x) (apply_fun u9neg x) Hr8sxR Hu9negRx). }
												    rewrite (compose_fun_apply A (pair_map A r8s u9neg) add_fun_R x HxA).
												    rewrite (add_fun_R_apply (apply_fun (pair_map A r8s u9neg) x) Hpimg) at 1.
												    rewrite (pair_map_apply A R R r8s u9neg x HxA).
												    rewrite (tuple_2_0_eq (apply_fun r8s x) (apply_fun u9neg x)).
												    rewrite (tuple_2_1_eq (apply_fun r8s x) (apply_fun u9neg x)).
												    rewrite (compose_fun_apply A u9 neg_fun x HxA) at 1.
												    claim Hu9Rx: apply_fun u9 x :e R.
												    { exact (continuous_map_function_on A Ta R R_standard_topology u9 Hu9contA x HxA). }
												    rewrite (neg_fun_apply (apply_fun u9 x) Hu9Rx) at 1.
												    reflexivity. }
												  claim Hr9_range: forall x:set, x :e A -> apply_fun r9 x :e I2.
												  { claim Hu9AB:
												      continuous_map X Tx I0 T0 u9 /\
												      (forall x0:set, x0 :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u9 x0 = minus_SNo one_third).
												    { exact (andEL
												        (continuous_map X Tx I0 T0 u9 /\
												         (forall x0:set, x0 :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												           apply_fun u9 x0 = minus_SNo one_third))
												        (forall x0:set, x0 :e preimage_of A r8s ((closed_interval one_third 1) :/\: I) ->
												          apply_fun u9 x0 = one_third)
												        Hu9). }
												    claim Hu9_on_B9:
												      forall x0:set, x0 :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												        apply_fun u9 x0 = minus_SNo one_third.
												    { exact (andER
												        (continuous_map X Tx I0 T0 u9)
												        (forall x0:set, x0 :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												          apply_fun u9 x0 = minus_SNo one_third)
												        Hu9AB). }
												    claim Hu9_on_C9:
												      forall x0:set, x0 :e preimage_of A r8s ((closed_interval one_third 1) :/\: I) ->
												        apply_fun u9 x0 = one_third.
												    { exact (andER
												        (continuous_map X Tx I0 T0 u9 /\
												         (forall x0:set, x0 :e preimage_of A r8s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
												           apply_fun u9 x0 = minus_SNo one_third))
												        (forall x0:set, x0 :e preimage_of A r8s ((closed_interval one_third 1) :/\: I) ->
												          apply_fun u9 x0 = one_third)
												        Hu9). }
												    let x. assume HxA: x :e A.
												    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
												    set I3 := closed_interval one_third 1.
												    set B9 := preimage_of A r8s (I1 :/\: I).
												    set C9 := preimage_of A r8s (I3 :/\: I).
												    claim Hr8sIx: apply_fun r8s x :e I.
												    { exact (continuous_map_function_on A Ta I Ti r8s Hr8s_cont x HxA). }
												    claim HB9_cases: x :e B9 \/ ~(x :e B9).
												    { exact (xm (x :e B9)). }
												    apply (HB9_cases (apply_fun r9 x :e I2)).
												    - assume HxB9: x :e B9.
												      claim Hu9eq: apply_fun u9 x = minus_SNo one_third.
												      { exact (Hu9_on_B9 x HxB9). }
												      claim Hr9eq: apply_fun r9 x = add_SNo (apply_fun r8s x) one_third.
												      { rewrite (Hr9_apply x HxA).
												        rewrite Hu9eq at 1.
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
												        reflexivity. }
												      rewrite Hr9eq.
												      claim Hr8sI1I: apply_fun r8s x :e I1 :/\: I.
												      { exact (SepE2 A (fun x0:set => apply_fun r8s x0 :e I1 :/\: I) x HxB9). }
												      claim Hr8sI1: apply_fun r8s x :e I1.
												      { exact (binintersectE1 I1 I (apply_fun r8s x) Hr8sI1I). }
												      claim H13R: one_third :e R.
												      { exact one_third_in_R. }
												      claim H23R: two_thirds :e R.
												      { exact two_thirds_in_R. }
												      claim Hm23R: minus_SNo two_thirds :e R.
												      { exact (real_minus_SNo two_thirds H23R). }
												      claim Hm1R: minus_SNo 1 :e R.
												      { exact (real_minus_SNo 1 real_1). }
												      claim Hm13R: minus_SNo one_third :e R.
												      { exact (real_minus_SNo one_third H13R). }
												      claim Hr8sRx: apply_fun r8s x :e R.
												      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r8s x) Hr8sI1). }
												      claim Hr8s_bounds: Rle (minus_SNo 1) (apply_fun r8s x) /\ Rle (apply_fun r8s x) (minus_SNo one_third).
												      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r8s x)
												                                     Hm1R Hm13R Hr8sI1). }
												      claim Hm1le: Rle (minus_SNo 1) (apply_fun r8s x).
												      { exact (andEL (Rle (minus_SNo 1) (apply_fun r8s x))
												                     (Rle (apply_fun r8s x) (minus_SNo one_third)) Hr8s_bounds). }
												      claim HhiI1: Rle (apply_fun r8s x) (minus_SNo one_third).
												      { exact (andER (Rle (minus_SNo 1) (apply_fun r8s x))
												                     (Rle (apply_fun r8s x) (minus_SNo one_third)) Hr8s_bounds). }
												      claim Hr9xR: add_SNo (apply_fun r8s x) one_third :e R.
												      { exact (real_add_SNo (apply_fun r8s x) Hr8sRx one_third H13R). }
												      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r8s x) one_third).
												      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r8s x) one_third Hm1R Hr8sRx H13R Hm1le). }
												      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r8s x) one_third).
												      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
												        exact Hlow_tmp. }
												      claim Hup0_tmp: Rle (add_SNo (apply_fun r8s x) one_third) (add_SNo (minus_SNo one_third) one_third).
												      { exact (Rle_add_SNo_1 (apply_fun r8s x) (minus_SNo one_third) one_third Hr8sRx Hm13R H13R HhiI1). }
												      claim H13S: SNo one_third.
												      { exact (real_SNo one_third H13R). }
												      claim Hup0: Rle (add_SNo (apply_fun r8s x) one_third) 0.
												      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
												        exact Hup0_tmp. }
												      claim H0le23: Rle 0 two_thirds.
												      { exact Rle_0_two_thirds. }
												      claim Hup: Rle (add_SNo (apply_fun r8s x) one_third) two_thirds.
												      { exact (Rle_tra (add_SNo (apply_fun r8s x) one_third) 0 two_thirds Hup0 H0le23). }
												      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                     (add_SNo (apply_fun r8s x) one_third)
												                                     Hm23R H23R Hr9xR Hlow Hup).
												    - assume HxnotB9: ~(x :e B9).
												      claim HC9_cases: x :e C9 \/ ~(x :e C9).
												      { exact (xm (x :e C9)). }
												      apply (HC9_cases (apply_fun r9 x :e I2)).
												      + assume HxC9: x :e C9.
												        claim Hu9eq: apply_fun u9 x = one_third.
												        { exact (Hu9_on_C9 x HxC9). }
												        claim Hr9eq: apply_fun r9 x = add_SNo (apply_fun r8s x) (minus_SNo one_third).
												        { rewrite (Hr9_apply x HxA).
												          rewrite Hu9eq at 1.
												          reflexivity. }
												        rewrite Hr9eq.
												        claim Hr8sI3I: apply_fun r8s x :e I3 :/\: I.
												        { exact (SepE2 A (fun x0:set => apply_fun r8s x0 :e I3 :/\: I) x HxC9). }
												        claim Hr8sI3: apply_fun r8s x :e I3.
												        { exact (binintersectE1 I3 I (apply_fun r8s x) Hr8sI3I). }
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        claim H23R: two_thirds :e R.
												        { exact two_thirds_in_R. }
												        claim Hm23R: minus_SNo two_thirds :e R.
												        { exact (real_minus_SNo two_thirds H23R). }
												        claim Hm13R: minus_SNo one_third :e R.
												        { exact (real_minus_SNo one_third H13R). }
												        claim Hr8sRx: apply_fun r8s x :e R.
												        { exact (closed_interval_sub_R one_third 1 (apply_fun r8s x) Hr8sI3). }
												        claim Hr8s_bounds: Rle one_third (apply_fun r8s x) /\ Rle (apply_fun r8s x) 1.
												        { exact (closed_interval_bounds one_third 1 (apply_fun r8s x) H13R real_1 Hr8sI3). }
												        claim HloI3: Rle one_third (apply_fun r8s x).
												        { exact (andEL (Rle one_third (apply_fun r8s x)) (Rle (apply_fun r8s x) 1) Hr8s_bounds). }
												        claim HhiI3: Rle (apply_fun r8s x) 1.
												        { exact (andER (Rle one_third (apply_fun r8s x)) (Rle (apply_fun r8s x) 1) Hr8s_bounds). }
												        claim Hr9xR: add_SNo (apply_fun r8s x) (minus_SNo one_third) :e R.
												        { exact (real_add_SNo (apply_fun r8s x) Hr8sRx (minus_SNo one_third) Hm13R). }
												        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
												                          (add_SNo (apply_fun r8s x) (minus_SNo one_third)).
												        { exact (Rle_add_SNo_1 one_third (apply_fun r8s x) (minus_SNo one_third)
												                               H13R Hr8sRx Hm13R HloI3). }
												        claim H13S: SNo one_third.
												        { exact (real_SNo one_third H13R). }
												        claim H0le: Rle 0 (add_SNo (apply_fun r8s x) (minus_SNo one_third)).
												        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
												          exact H0le_tmp. }
												        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
												        { exact Rle_minus_two_thirds_0. }
												        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r8s x) (minus_SNo one_third)).
												        { exact (Rle_tra (minus_SNo two_thirds) 0
												                         (add_SNo (apply_fun r8s x) (minus_SNo one_third))
												                         Hm23le0 H0le). }
												        claim Hup_tmp: Rle (add_SNo (apply_fun r8s x) (minus_SNo one_third))
												                         (add_SNo 1 (minus_SNo one_third)).
												        { exact (Rle_add_SNo_1 (apply_fun r8s x) 1 (minus_SNo one_third)
												                               Hr8sRx real_1 Hm13R HhiI3). }
												        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
												        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
												          exact (Rle_refl two_thirds H23R). }
												        claim Hup: Rle (add_SNo (apply_fun r8s x) (minus_SNo one_third)) two_thirds.
												        { exact (Rle_tra (add_SNo (apply_fun r8s x) (minus_SNo one_third))
												                         (add_SNo 1 (minus_SNo one_third))
												                         two_thirds
												                         Hup_tmp Hup1). }
												        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                       (add_SNo (apply_fun r8s x) (minus_SNo one_third))
												                                       Hm23R H23R Hr9xR Hlow Hup).
												      + assume HxnotC9: ~(x :e C9).
												        claim HxX: x :e X.
												        { exact (HAsubX x HxA). }
												        claim HnotI1: ~(apply_fun r8s x :e I1).
												        { assume Hr8sI1': apply_fun r8s x :e I1.
												          claim Hr8sI1I: apply_fun r8s x :e I1 :/\: I.
												          { exact (binintersectI I1 I (apply_fun r8s x) Hr8sI1' Hr8sIx). }
												          claim HxB9': x :e B9.
												          { exact (SepI A (fun x0:set => apply_fun r8s x0 :e I1 :/\: I) x HxA Hr8sI1I). }
												          apply FalseE.
												          exact (HxnotB9 HxB9'). }
												        claim HnotI3: ~(apply_fun r8s x :e I3).
												        { assume Hr8sI3': apply_fun r8s x :e I3.
												          claim Hr8sI3I: apply_fun r8s x :e I3 :/\: I.
												          { exact (binintersectI I3 I (apply_fun r8s x) Hr8sI3' Hr8sIx). }
												          claim HxC9': x :e C9.
												          { exact (SepI A (fun x0:set => apply_fun r8s x0 :e I3 :/\: I) x HxA Hr8sI3I). }
												          apply FalseE.
												          exact (HxnotC9 HxC9'). }
												        claim Hr8sRx: apply_fun r8s x :e R.
												        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r8s x) Hr8sIx). }
												        claim Hm1R: minus_SNo 1 :e R.
												        { exact (real_minus_SNo 1 real_1). }
												        claim H13R: one_third :e R.
												        { exact one_third_in_R. }
												        claim Hm13R: minus_SNo one_third :e R.
												        { exact (real_minus_SNo one_third H13R). }
												        claim Hr8s_boundsI: Rle (minus_SNo 1) (apply_fun r8s x) /\ Rle (apply_fun r8s x) 1.
												        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r8s x) Hm1R real_1 Hr8sIx). }
												        claim Hnlt_fx_m1: ~(Rlt (apply_fun r8s x) (minus_SNo 1)).
												        { exact (RleE_nlt (minus_SNo 1) (apply_fun r8s x)
												                          (andEL (Rle (minus_SNo 1) (apply_fun r8s x)) (Rle (apply_fun r8s x) 1) Hr8s_boundsI)). }
												        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r8s x)).
												        { exact (RleE_nlt (apply_fun r8s x) 1
												                          (andER (Rle (minus_SNo 1) (apply_fun r8s x)) (Rle (apply_fun r8s x) 1) Hr8s_boundsI)). }
												        claim HnotI1_cases: Rlt (apply_fun r8s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r8s x).
												        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r8s x)
												                                              Hm1R Hm13R Hr8sRx HnotI1). }
												        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r8s x).
												        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r8s x))).
												          - assume Hbad: Rlt (apply_fun r8s x) (minus_SNo 1).
												            apply FalseE.
												            exact (Hnlt_fx_m1 Hbad).
												          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r8s x).
												            exact Hok. }
												        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r8s x) (minus_SNo one_third)).
												        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r8s x) Hm13lt_fx). }
												        claim HnotI3_cases: Rlt (apply_fun r8s x) one_third \/ Rlt 1 (apply_fun r8s x).
												        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r8s x)
												                                              H13R real_1 Hr8sRx HnotI3). }
												        claim Hfx_lt_13: Rlt (apply_fun r8s x) one_third.
												        { apply (HnotI3_cases (Rlt (apply_fun r8s x) one_third)).
												          - assume Hok: Rlt (apply_fun r8s x) one_third.
												            exact Hok.
												          - assume Hbad: Rlt 1 (apply_fun r8s x).
												            apply FalseE.
												            exact (Hnlt_1_fx Hbad). }
												        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r8s x)).
												        { exact (not_Rlt_sym (apply_fun r8s x) one_third Hfx_lt_13). }
												        claim Hr8sI0: apply_fun r8s x :e I0.
												        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
												          { reflexivity. }
												          claim HxSep: apply_fun r8s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
												          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
												                        (apply_fun r8s x) Hr8sRx (andI (~(Rlt (apply_fun r8s x) (minus_SNo one_third)))
												                                                      (~(Rlt one_third (apply_fun r8s x)))
												                                                      Hnot_fx_lt_m13
												                                                      Hnot_13_lt_fx)). }
												          rewrite HI0_def.
												          exact HxSep. }
												        claim Hu9funI0: function_on u9 X I0.
												        { exact (continuous_map_function_on X Tx I0 T0 u9 Hu9contI0). }
												        claim Hu9xI0: apply_fun u9 x :e I0.
												        { exact (Hu9funI0 x HxX). }
												        claim Hu9xR: apply_fun u9 x :e R.
												        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u9 x) Hu9xI0). }
												        claim Hm_u9x_R: minus_SNo (apply_fun u9 x) :e R.
												        { exact (real_minus_SNo (apply_fun u9 x) Hu9xR). }
												        rewrite (Hr9_apply x HxA).
												        claim Hr9xR: add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)) :e R.
												        { exact (real_add_SNo (apply_fun r8s x)
												                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r8s x) Hr8sI0)
												                              (minus_SNo (apply_fun u9 x)) Hm_u9x_R). }
												        claim H23R: two_thirds :e R.
												        { exact two_thirds_in_R. }
												        claim Hm23R: minus_SNo two_thirds :e R.
												        { exact (real_minus_SNo two_thirds H23R). }
												        claim Hr8s_bounds0: Rle (minus_SNo one_third) (apply_fun r8s x) /\ Rle (apply_fun r8s x) one_third.
												        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r8s x) Hm13R H13R Hr8sI0). }
												        claim Hu9_bounds0: Rle (minus_SNo one_third) (apply_fun u9 x) /\ Rle (apply_fun u9 x) one_third.
												        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u9 x) Hm13R H13R Hu9xI0). }
												        claim Hm13_le_r8s: Rle (minus_SNo one_third) (apply_fun r8s x).
												        { exact (andEL (Rle (minus_SNo one_third) (apply_fun r8s x)) (Rle (apply_fun r8s x) one_third) Hr8s_bounds0). }
												        claim Hr8s_le_13: Rle (apply_fun r8s x) one_third.
												        { exact (andER (Rle (minus_SNo one_third) (apply_fun r8s x)) (Rle (apply_fun r8s x) one_third) Hr8s_bounds0). }
												        claim Hm13_le_u9x: Rle (minus_SNo one_third) (apply_fun u9 x).
												        { exact (andEL (Rle (minus_SNo one_third) (apply_fun u9 x)) (Rle (apply_fun u9 x) one_third) Hu9_bounds0). }
												        claim Hu9x_le_13: Rle (apply_fun u9 x) one_third.
												        { exact (andER (Rle (minus_SNo one_third) (apply_fun u9 x)) (Rle (apply_fun u9 x) one_third) Hu9_bounds0). }
												        claim Hm13_le_mu9: Rle (minus_SNo one_third) (minus_SNo (apply_fun u9 x)).
												        { exact (Rle_minus_contra (apply_fun u9 x) one_third Hu9x_le_13). }
												        claim Hmu9_le_13: Rle (minus_SNo (apply_fun u9 x)) one_third.
												        { claim Htmp: Rle (minus_SNo (apply_fun u9 x)) (minus_SNo (minus_SNo one_third)).
												          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u9 x) Hm13_le_u9x). }
												          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
												          exact Htmp. }
												        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                      (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u9 x))).
												        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u9 x))
												                               Hm13R Hm13R Hm_u9x_R Hm13_le_mu9). }
												        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u9 x)))
												                      (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x))).
												        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r8s x) (minus_SNo (apply_fun u9 x))
												                               Hm13R
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r8s x) Hr8sI0)
												                               Hm_u9x_R
												                               Hm13_le_r8s). }
												        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                        (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x))).
												        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
												                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u9 x)))
												                         (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)))
												                         Hlow1 Hlow2). }
												        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x))).
												        { rewrite minus_two_thirds_eq at 1.
												          exact Hlow_tmp. }
												        claim Hup1: Rle (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)))
												                      (add_SNo (apply_fun r8s x) one_third).
												        { exact (Rle_add_SNo_2 (apply_fun r8s x) (minus_SNo (apply_fun u9 x)) one_third
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r8s x) Hr8sI0)
												                               Hm_u9x_R H13R Hmu9_le_13). }
												        claim Hup2: Rle (add_SNo (apply_fun r8s x) one_third)
												                      (add_SNo one_third one_third).
												        { exact (Rle_add_SNo_1 (apply_fun r8s x) one_third one_third
												                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r8s x) Hr8sI0)
												                               H13R H13R Hr8s_le_13). }
												        claim Hup_tmp: Rle (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)))
												                         (add_SNo one_third one_third).
												        { exact (Rle_tra (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)))
												                         (add_SNo (apply_fun r8s x) one_third)
												                         (add_SNo one_third one_third)
												                         Hup1 Hup2). }
												        claim Hdef23: two_thirds = add_SNo one_third one_third.
												        { reflexivity. }
												        claim Hup: Rle (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x))) two_thirds.
												        { rewrite Hdef23 at 1.
												          exact Hup_tmp. }
												        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
												                                       (add_SNo (apply_fun r8s x) (minus_SNo (apply_fun u9 x)))
												                                       Hm23R H23R Hr9xR Hlow Hup). }
												  set r9s := compose_fun A r9 (div_const_fun den).
												  claim Hr9s_cont: continuous_map A Ta I Ti r9s.
												  { claim HRtop: topology_on R R_standard_topology.
												    { exact R_standard_topology_is_topology. }
												    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
												    { exact (div_const_fun_continuous_pos den H23R H23pos). }
												    claim Hr9s_contR: continuous_map A Ta R R_standard_topology r9s.
												    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
												             r9 (div_const_fun den) Hr9_cont Hdivcont). }
												    claim Hr9s_I: forall x:set, x :e A -> apply_fun r9s x :e I.
												    { let x. assume HxA: x :e A.
												      claim Hr9xI2: apply_fun r9 x :e I2.
												      { exact (Hr9_range x HxA). }
												      claim Hm1R: (minus_SNo 1) :e R.
												      { exact (real_minus_SNo 1 real_1). }
												      claim HmdenR: (minus_SNo den) :e R.
												      { exact (real_minus_SNo den H23R). }
												      claim Hr9xR: apply_fun r9 x :e R.
												      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r9 x) Hr9xI2). }
												      claim Hr9xS: SNo (apply_fun r9 x).
												      { exact (real_SNo (apply_fun r9 x) Hr9xR). }
												      claim Hbounds: Rle (minus_SNo den) (apply_fun r9 x) /\ Rle (apply_fun r9 x) den.
												      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r9 x) HmdenR H23R Hr9xI2). }
												      claim Hlo: Rle (minus_SNo den) (apply_fun r9 x).
												      { exact (andEL (Rle (minus_SNo den) (apply_fun r9 x))
												                     (Rle (apply_fun r9 x) den)
												                     Hbounds). }
												      claim Hhi: Rle (apply_fun r9 x) den.
												      { exact (andER (Rle (minus_SNo den) (apply_fun r9 x))
												                     (Rle (apply_fun r9 x) den)
												                     Hbounds). }
												      claim Hnlt_hi: ~(Rlt den (apply_fun r9 x)).
												      { exact (RleE_nlt (apply_fun r9 x) den Hhi). }
												      claim Hnlt_lo: ~(Rlt (apply_fun r9 x) (minus_SNo den)).
												      { exact (RleE_nlt (minus_SNo den) (apply_fun r9 x) Hlo). }
												      claim HyEq: apply_fun r9s x = div_SNo (apply_fun r9 x) den.
												      { rewrite (compose_fun_apply A r9 (div_const_fun den) x HxA).
												        rewrite (div_const_fun_apply den (apply_fun r9 x) H23R Hr9xR).
												        reflexivity. }
												      claim HyR: apply_fun r9s x :e R.
												      { rewrite HyEq.
												        exact (real_div_SNo (apply_fun r9 x) Hr9xR den H23R). }
												      claim HyS: SNo (apply_fun r9s x).
												      { exact (real_SNo (apply_fun r9s x) HyR). }
												      claim Hy_le_1: Rle (apply_fun r9s x) 1.
												      { apply (RleI (apply_fun r9s x) 1 HyR real_1).
												        prove ~(Rlt 1 (apply_fun r9s x)).
												        assume H1lt: Rlt 1 (apply_fun r9s x).
												        claim H1lty: 1 < apply_fun r9s x.
												        { exact (RltE_lt 1 (apply_fun r9s x) H1lt). }
												        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r9s x) den.
												        { exact (pos_mul_SNo_Lt' 1 (apply_fun r9s x) den SNo_1 HyS H23S H23pos H1lty). }
												        claim HmulLt': den < mul_SNo (apply_fun r9s x) den.
												        { rewrite <- (mul_SNo_oneL den H23S) at 1.
												          exact HmulLt. }
												        claim HmulEq: mul_SNo (apply_fun r9s x) den = apply_fun r9 x.
												        { rewrite HyEq at 1.
												          exact (mul_div_SNo_invL (apply_fun r9 x) den Hr9xS H23S H23ne0). }
												        claim Hden_lt_r9x: den < apply_fun r9 x.
												        { rewrite <- HmulEq.
												          exact HmulLt'. }
												        claim Hbad: Rlt den (apply_fun r9 x).
												        { exact (RltI den (apply_fun r9 x) H23R Hr9xR Hden_lt_r9x). }
												        exact (Hnlt_hi Hbad). }
												      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r9s x).
												      { apply (RleI (minus_SNo 1) (apply_fun r9s x) Hm1R HyR).
												        prove ~(Rlt (apply_fun r9s x) (minus_SNo 1)).
												        assume Hylt: Rlt (apply_fun r9s x) (minus_SNo 1).
												        claim Hylts: apply_fun r9s x < minus_SNo 1.
												        { exact (RltE_lt (apply_fun r9s x) (minus_SNo 1) Hylt). }
												        claim HmulLt: mul_SNo (apply_fun r9s x) den < mul_SNo (minus_SNo 1) den.
												        { exact (pos_mul_SNo_Lt' (apply_fun r9s x) (minus_SNo 1) den HyS
												                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
												        claim HmulEq: mul_SNo (apply_fun r9s x) den = apply_fun r9 x.
												        { rewrite HyEq at 1.
												          exact (mul_div_SNo_invL (apply_fun r9 x) den Hr9xS H23S H23ne0). }
												        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
												        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
												          rewrite (mul_SNo_oneL den H23S) at 1.
												          reflexivity. }
												        claim Hr9x_lt_mden: apply_fun r9 x < minus_SNo den.
												        { rewrite <- HmulEq.
												          rewrite <- HrhsEq.
												          exact HmulLt. }
												        claim Hbad: Rlt (apply_fun r9 x) (minus_SNo den).
												        { exact (RltI (apply_fun r9 x) (minus_SNo den) Hr9xR HmdenR Hr9x_lt_mden). }
												        exact (Hnlt_lo Hbad). }
												      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r9s x)
												                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
												    exact (continuous_map_range_restrict A Ta R R_standard_topology r9s I Hr9s_contR HIcR Hr9s_I). }

													  (** further iteration scaffold: build u10 and g10 from residual r9s **)
													  claim Hex_u10:
													    exists u10:set,
													      continuous_map X Tx I0 T0 u10 /\
													      (forall x:set, x :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
													        apply_fun u10 x = minus_SNo one_third) /\
													      (forall x:set, x :e preimage_of A r9s ((closed_interval one_third 1) :/\: I) ->
													        apply_fun u10 x = one_third).
													  { exact (Tietze_stepI_g_exists X Tx A r9s Hnorm HA Hr9s_cont). }
													  apply Hex_u10.
													  let u10. assume Hu10.
													  claim Hu10contI0: continuous_map X Tx I0 T0 u10.
													  { claim Hu10AB:
													      continuous_map X Tx I0 T0 u10 /\
													      (forall x:set, x :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
													        apply_fun u10 x = minus_SNo one_third).
													    { exact (andEL
													        (continuous_map X Tx I0 T0 u10 /\
													         (forall x:set, x :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
													           apply_fun u10 x = minus_SNo one_third))
													        (forall x:set, x :e preimage_of A r9s ((closed_interval one_third 1) :/\: I) ->
													          apply_fun u10 x = one_third)
													        Hu10). }
													    exact (andEL
													        (continuous_map X Tx I0 T0 u10)
													        (forall x:set, x :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
													          apply_fun u10 x = minus_SNo one_third)
													        Hu10AB). }
													  claim Hu10contR: continuous_map X Tx R R_standard_topology u10.
													  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
													    { reflexivity. }
													    claim HI0subR: I0 c= R.
													    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
													    exact (continuous_map_range_expand
													             X Tx I0 T0
													             R R_standard_topology
													             u10
													             Hu10contI0
													             HI0subR
													             R_standard_topology_is_topology_local
													             HT0eq). }
													  set den10 := mul_SNo den9 den.
													  claim Hden10R: den10 :e R.
													  { exact (real_mul_SNo den9 Hden9R den H23R). }
													  claim Hden10pos: 0 < den10.
													  { claim Hden9S: SNo den9.
													    { exact (real_SNo den9 Hden9R). }
													    exact (mul_SNo_pos_pos den9 den Hden9S H23S Hden9pos HdenPos). }
													  set u10s := compose_fun X u10 (mul_const_fun den10).
													  claim Hu10s_cont: continuous_map X Tx R R_standard_topology u10s.
													  { exact (scale_continuous_mul_const_pos X Tx u10 den10 HTx Hu10contR Hden10R Hden10pos). }
													  set g10 := compose_fun X (pair_map X g9 u10s) add_fun_R.
													  claim Hg10cont: continuous_map X Tx R R_standard_topology g10.
													  { exact (add_two_continuous_R X Tx g9 u10s HTx Hg9cont Hu10s_cont). }

													  (** further iteration scaffold: residual r10 on A and scaling r10s **)
													  claim Hu10contA: continuous_map A Ta R R_standard_topology u10.
													  { exact (continuous_on_subspace X Tx R R_standard_topology u10 A HTx HAsubX Hu10contR). }
													  set u10neg := compose_fun A u10 neg_fun.
													  claim Hu10neg_cont: continuous_map A Ta R R_standard_topology u10neg.
													  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
													           u10 neg_fun Hu10contA Hnegcont). }
													  claim Hr9s_contR: continuous_map A Ta R R_standard_topology r9s.
													  { claim HTiEq': Ti = subspace_topology R R_standard_topology I.
													    { exact HTiEq. }
													    exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r9s
													             Hr9s_cont HIcR R_standard_topology_is_topology_local HTiEq'). }
													  set r10 := compose_fun A (pair_map A r9s u10neg) add_fun_R.
													  claim Hr10_cont: continuous_map A Ta R R_standard_topology r10.
													  { exact (add_two_continuous_R A Ta r9s u10neg HTa Hr9s_contR Hu10neg_cont). }
														  claim Hr10_apply: forall x:set, x :e A ->
														    apply_fun r10 x = add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)).
														  { let x. assume HxA: x :e A.
														    claim Hpimg: apply_fun (pair_map A r9s u10neg) x :e setprod R R.
														    { rewrite (pair_map_apply A R R r9s u10neg x HxA).
														      claim Hr9sxI: apply_fun r9s x :e I.
														      { exact (continuous_map_function_on A Ta I Ti r9s Hr9s_cont x HxA). }
														      claim Hr9sxR: apply_fun r9s x :e R.
														      { exact (HIcR (apply_fun r9s x) Hr9sxI). }
														      claim Hu10negRx: apply_fun u10neg x :e R.
														      { exact (continuous_map_function_on A Ta R R_standard_topology u10neg Hu10neg_cont x HxA). }
														      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r9s x) (apply_fun u10neg x) Hr9sxR Hu10negRx). }
														    rewrite (compose_fun_apply A (pair_map A r9s u10neg) add_fun_R x HxA).
														    rewrite (add_fun_R_apply (apply_fun (pair_map A r9s u10neg) x) Hpimg) at 1.
														    rewrite (pair_map_apply A R R r9s u10neg x HxA).
														    rewrite (tuple_2_0_eq (apply_fun r9s x) (apply_fun u10neg x)).
														    rewrite (tuple_2_1_eq (apply_fun r9s x) (apply_fun u10neg x)).
														    rewrite (compose_fun_apply A u10 neg_fun x HxA).
														    claim Hu10Rx: apply_fun u10 x :e R.
														    { exact (continuous_map_function_on A Ta R R_standard_topology u10 Hu10contA x HxA). }
														    rewrite (neg_fun_apply (apply_fun u10 x) Hu10Rx).
														    reflexivity. }
														  claim Hr10_range: forall x:set, x :e A -> apply_fun r10 x :e I2.
														  { claim Hu10AB:
														      continuous_map X Tx I0 T0 u10 /\
														      (forall x0:set, x0 :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u10 x0 = minus_SNo one_third).
														    { exact (andEL
														        (continuous_map X Tx I0 T0 u10 /\
														         (forall x0:set, x0 :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u10 x0 = minus_SNo one_third))
														        (forall x0:set, x0 :e preimage_of A r9s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u10 x0 = one_third)
														        Hu10). }
														    claim Hu10_on_B10:
														      forall x0:set, x0 :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u10 x0 = minus_SNo one_third.
														    { exact (andER
														        (continuous_map X Tx I0 T0 u10)
														        (forall x0:set, x0 :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														          apply_fun u10 x0 = minus_SNo one_third)
														        Hu10AB). }
														    claim Hu10_on_C10:
														      forall x0:set, x0 :e preimage_of A r9s ((closed_interval one_third 1) :/\: I) ->
														        apply_fun u10 x0 = one_third.
														    { exact (andER
														        (continuous_map X Tx I0 T0 u10 /\
														         (forall x0:set, x0 :e preimage_of A r9s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u10 x0 = minus_SNo one_third))
														        (forall x0:set, x0 :e preimage_of A r9s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u10 x0 = one_third)
														        Hu10). }
														    let x. assume HxA: x :e A.
														    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
														    set I3 := closed_interval one_third 1.
														    set B10 := preimage_of A r9s (I1 :/\: I).
														    set C10 := preimage_of A r9s (I3 :/\: I).
														    claim Hr9sIx: apply_fun r9s x :e I.
														    { exact (continuous_map_function_on A Ta I Ti r9s Hr9s_cont x HxA). }
														    claim HB10_cases: x :e B10 \/ ~(x :e B10).
														    { exact (xm (x :e B10)). }
														    apply (HB10_cases (apply_fun r10 x :e I2)).
														    - assume HxB10: x :e B10.
														      claim Hu10eq: apply_fun u10 x = minus_SNo one_third.
														      { exact (Hu10_on_B10 x HxB10). }
														      claim Hr10eq: apply_fun r10 x = add_SNo (apply_fun r9s x) one_third.
														      { rewrite (Hr10_apply x HxA).
														        rewrite Hu10eq at 1.
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
														        reflexivity. }
														      rewrite Hr10eq.
														      claim Hr9sI1I: apply_fun r9s x :e I1 :/\: I.
														      { exact (SepE2 A (fun x0:set => apply_fun r9s x0 :e I1 :/\: I) x HxB10). }
														      claim Hr9sI1: apply_fun r9s x :e I1.
														      { exact (binintersectE1 I1 I (apply_fun r9s x) Hr9sI1I). }
														      claim H13R: one_third :e R.
														      { exact one_third_in_R. }
														      claim H23R: two_thirds :e R.
														      { exact two_thirds_in_R. }
														      claim Hm23R: minus_SNo two_thirds :e R.
														      { exact (real_minus_SNo two_thirds H23R). }
														      claim Hm1R: minus_SNo 1 :e R.
														      { exact (real_minus_SNo 1 real_1). }
														      claim Hm13R: minus_SNo one_third :e R.
														      { exact (real_minus_SNo one_third H13R). }
														      claim Hr9sRx: apply_fun r9s x :e R.
														      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r9s x) Hr9sI1). }
														      claim Hr9s_bounds: Rle (minus_SNo 1) (apply_fun r9s x) /\ Rle (apply_fun r9s x) (minus_SNo one_third).
														      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r9s x)
														                                     Hm1R Hm13R Hr9sI1). }
														      claim Hm1le: Rle (minus_SNo 1) (apply_fun r9s x).
														      { exact (andEL (Rle (minus_SNo 1) (apply_fun r9s x))
														                     (Rle (apply_fun r9s x) (minus_SNo one_third)) Hr9s_bounds). }
														      claim HhiI1: Rle (apply_fun r9s x) (minus_SNo one_third).
														      { exact (andER (Rle (minus_SNo 1) (apply_fun r9s x))
														                     (Rle (apply_fun r9s x) (minus_SNo one_third)) Hr9s_bounds). }
														      claim Hr10xR: add_SNo (apply_fun r9s x) one_third :e R.
														      { exact (real_add_SNo (apply_fun r9s x) Hr9sRx one_third H13R). }
														      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r9s x) one_third).
														      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r9s x) one_third Hm1R Hr9sRx H13R Hm1le). }
														      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r9s x) one_third).
														      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
														        exact Hlow_tmp. }
														      claim Hup0_tmp: Rle (add_SNo (apply_fun r9s x) one_third) (add_SNo (minus_SNo one_third) one_third).
														      { exact (Rle_add_SNo_1 (apply_fun r9s x) (minus_SNo one_third) one_third Hr9sRx Hm13R H13R HhiI1). }
														      claim H13S: SNo one_third.
														      { exact (real_SNo one_third H13R). }
														      claim Hup0: Rle (add_SNo (apply_fun r9s x) one_third) 0.
														      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
														        exact Hup0_tmp. }
														      claim H0le23: Rle 0 two_thirds.
														      { exact Rle_0_two_thirds. }
														      claim Hup: Rle (add_SNo (apply_fun r9s x) one_third) two_thirds.
														      { exact (Rle_tra (add_SNo (apply_fun r9s x) one_third) 0 two_thirds Hup0 H0le23). }
														      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                     (add_SNo (apply_fun r9s x) one_third)
														                                     Hm23R H23R Hr10xR Hlow Hup).
														    - assume HxnotB10: ~(x :e B10).
														      claim HC10_cases: x :e C10 \/ ~(x :e C10).
														      { exact (xm (x :e C10)). }
														      apply (HC10_cases (apply_fun r10 x :e I2)).
														      + assume HxC10: x :e C10.
														        claim Hu10eq: apply_fun u10 x = one_third.
														        { exact (Hu10_on_C10 x HxC10). }
														        claim Hr10eq: apply_fun r10 x = add_SNo (apply_fun r9s x) (minus_SNo one_third).
														        { rewrite (Hr10_apply x HxA).
														          rewrite Hu10eq at 1.
														          reflexivity. }
														        rewrite Hr10eq.
														        claim Hr9sI3I: apply_fun r9s x :e I3 :/\: I.
														        { exact (SepE2 A (fun x0:set => apply_fun r9s x0 :e I3 :/\: I) x HxC10). }
														        claim Hr9sI3: apply_fun r9s x :e I3.
														        { exact (binintersectE1 I3 I (apply_fun r9s x) Hr9sI3I). }
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        claim H23R: two_thirds :e R.
														        { exact two_thirds_in_R. }
														        claim Hm23R: minus_SNo two_thirds :e R.
														        { exact (real_minus_SNo two_thirds H23R). }
														        claim Hm13R: minus_SNo one_third :e R.
														        { exact (real_minus_SNo one_third H13R). }
														        claim Hr9sRx: apply_fun r9s x :e R.
														        { exact (closed_interval_sub_R one_third 1 (apply_fun r9s x) Hr9sI3). }
														        claim Hr9s_bounds: Rle one_third (apply_fun r9s x) /\ Rle (apply_fun r9s x) 1.
														        { exact (closed_interval_bounds one_third 1 (apply_fun r9s x) H13R real_1 Hr9sI3). }
														        claim HloI3: Rle one_third (apply_fun r9s x).
														        { exact (andEL (Rle one_third (apply_fun r9s x)) (Rle (apply_fun r9s x) 1) Hr9s_bounds). }
														        claim HhiI3: Rle (apply_fun r9s x) 1.
														        { exact (andER (Rle one_third (apply_fun r9s x)) (Rle (apply_fun r9s x) 1) Hr9s_bounds). }
														        claim Hr10xR: add_SNo (apply_fun r9s x) (minus_SNo one_third) :e R.
														        { exact (real_add_SNo (apply_fun r9s x) Hr9sRx (minus_SNo one_third) Hm13R). }
														        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
														                          (add_SNo (apply_fun r9s x) (minus_SNo one_third)).
														        { exact (Rle_add_SNo_1 one_third (apply_fun r9s x) (minus_SNo one_third)
														                               H13R Hr9sRx Hm13R HloI3). }
														        claim H13S: SNo one_third.
														        { exact (real_SNo one_third H13R). }
														        claim H0le: Rle 0 (add_SNo (apply_fun r9s x) (minus_SNo one_third)).
														        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
														          exact H0le_tmp. }
														        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
														        { exact Rle_minus_two_thirds_0. }
														        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r9s x) (minus_SNo one_third)).
														        { exact (Rle_tra (minus_SNo two_thirds) 0
														                         (add_SNo (apply_fun r9s x) (minus_SNo one_third))
														                         Hm23le0 H0le). }
														        claim Hup_tmp: Rle (add_SNo (apply_fun r9s x) (minus_SNo one_third))
														                         (add_SNo 1 (minus_SNo one_third)).
														        { exact (Rle_add_SNo_1 (apply_fun r9s x) 1 (minus_SNo one_third)
														                               Hr9sRx real_1 Hm13R HhiI3). }
														        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
														        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
														          exact (Rle_refl two_thirds H23R). }
														        claim Hup: Rle (add_SNo (apply_fun r9s x) (minus_SNo one_third)) two_thirds.
														        { exact (Rle_tra (add_SNo (apply_fun r9s x) (minus_SNo one_third))
														                         (add_SNo 1 (minus_SNo one_third))
														                         two_thirds
														                         Hup_tmp Hup1). }
														        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                       (add_SNo (apply_fun r9s x) (minus_SNo one_third))
														                                       Hm23R H23R Hr10xR Hlow Hup).
														      + assume HxnotC10: ~(x :e C10).
														        claim HxX: x :e X.
														        { exact (HAsubX x HxA). }
														        claim HnotI1: ~(apply_fun r9s x :e I1).
														        { assume Hr9sI1': apply_fun r9s x :e I1.
														          claim Hr9sI1I: apply_fun r9s x :e I1 :/\: I.
														          { exact (binintersectI I1 I (apply_fun r9s x) Hr9sI1' Hr9sIx). }
														          claim HxB10': x :e B10.
														          { exact (SepI A (fun x0:set => apply_fun r9s x0 :e I1 :/\: I) x HxA Hr9sI1I). }
														          apply FalseE.
														          exact (HxnotB10 HxB10'). }
														        claim HnotI3: ~(apply_fun r9s x :e I3).
														        { assume Hr9sI3': apply_fun r9s x :e I3.
														          claim Hr9sI3I: apply_fun r9s x :e I3 :/\: I.
														          { exact (binintersectI I3 I (apply_fun r9s x) Hr9sI3' Hr9sIx). }
														          claim HxC10': x :e C10.
														          { exact (SepI A (fun x0:set => apply_fun r9s x0 :e I3 :/\: I) x HxA Hr9sI3I). }
														          apply FalseE.
														          exact (HxnotC10 HxC10'). }
														        claim Hr9sRx: apply_fun r9s x :e R.
														        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r9s x) Hr9sIx). }
														        claim Hm1R: minus_SNo 1 :e R.
														        { exact (real_minus_SNo 1 real_1). }
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        claim Hm13R: minus_SNo one_third :e R.
														        { exact (real_minus_SNo one_third H13R). }
														        claim Hr9s_boundsI: Rle (minus_SNo 1) (apply_fun r9s x) /\ Rle (apply_fun r9s x) 1.
														        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r9s x) Hm1R real_1 Hr9sIx). }
														        claim Hnlt_fx_m1: ~(Rlt (apply_fun r9s x) (minus_SNo 1)).
														        { exact (RleE_nlt (minus_SNo 1) (apply_fun r9s x)
														                          (andEL (Rle (minus_SNo 1) (apply_fun r9s x)) (Rle (apply_fun r9s x) 1) Hr9s_boundsI)). }
														        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r9s x)).
														        { exact (RleE_nlt (apply_fun r9s x) 1
														                          (andER (Rle (minus_SNo 1) (apply_fun r9s x)) (Rle (apply_fun r9s x) 1) Hr9s_boundsI)). }
														        claim HnotI1_cases: Rlt (apply_fun r9s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r9s x).
														        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r9s x)
														                                              Hm1R Hm13R Hr9sRx HnotI1). }
														        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r9s x).
														        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r9s x))).
														          - assume Hbad: Rlt (apply_fun r9s x) (minus_SNo 1).
														            apply FalseE.
														            exact (Hnlt_fx_m1 Hbad).
														          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r9s x).
														            exact Hok. }
														        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r9s x) (minus_SNo one_third)).
														        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r9s x) Hm13lt_fx). }
														        claim HnotI3_cases: Rlt (apply_fun r9s x) one_third \/ Rlt 1 (apply_fun r9s x).
														        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r9s x)
														                                              H13R real_1 Hr9sRx HnotI3). }
														        claim Hfx_lt_13: Rlt (apply_fun r9s x) one_third.
														        { apply (HnotI3_cases (Rlt (apply_fun r9s x) one_third)).
														          - assume Hok: Rlt (apply_fun r9s x) one_third.
														            exact Hok.
														          - assume Hbad: Rlt 1 (apply_fun r9s x).
														            apply FalseE.
														            exact (Hnlt_1_fx Hbad). }
														        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r9s x)).
														        { exact (not_Rlt_sym (apply_fun r9s x) one_third Hfx_lt_13). }
														        claim Hr9sI0: apply_fun r9s x :e I0.
														        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
														          { reflexivity. }
														          claim HxSep: apply_fun r9s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
														          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
														                        (apply_fun r9s x) Hr9sRx (andI (~(Rlt (apply_fun r9s x) (minus_SNo one_third)))
														                                                      (~(Rlt one_third (apply_fun r9s x)))
														                                                      Hnot_fx_lt_m13
														                                                      Hnot_13_lt_fx)). }
														          rewrite HI0_def.
														          exact HxSep. }
														        claim Hu10funI0: function_on u10 X I0.
														        { exact (continuous_map_function_on X Tx I0 T0 u10 Hu10contI0). }
														        claim Hu10xI0: apply_fun u10 x :e I0.
														        { exact (Hu10funI0 x HxX). }
														        claim Hu10xR: apply_fun u10 x :e R.
														        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u10 x) Hu10xI0). }
														        claim Hm_u10x_R: minus_SNo (apply_fun u10 x) :e R.
														        { exact (real_minus_SNo (apply_fun u10 x) Hu10xR). }
														        rewrite (Hr10_apply x HxA).
														        claim Hr10xR: add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)) :e R.
														        { exact (real_add_SNo (apply_fun r9s x)
														                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r9s x) Hr9sI0)
														                              (minus_SNo (apply_fun u10 x)) Hm_u10x_R). }
														        claim H23R: two_thirds :e R.
														        { exact two_thirds_in_R. }
														        claim Hm23R: minus_SNo two_thirds :e R.
														        { exact (real_minus_SNo two_thirds H23R). }
														        claim Hr9s_bounds0: Rle (minus_SNo one_third) (apply_fun r9s x) /\ Rle (apply_fun r9s x) one_third.
														        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r9s x) Hm13R H13R Hr9sI0). }
														        claim Hu10_bounds0: Rle (minus_SNo one_third) (apply_fun u10 x) /\ Rle (apply_fun u10 x) one_third.
														        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u10 x) Hm13R H13R Hu10xI0). }
														        claim Hr9s_le_13: Rle (apply_fun r9s x) one_third.
														        { exact (andER
														            (Rle (minus_SNo one_third) (apply_fun r9s x))
														            (Rle (apply_fun r9s x) one_third)
														            Hr9s_bounds0). }
														        claim Hr9s_ge_m13: Rle (minus_SNo one_third) (apply_fun r9s x).
														        { exact (andEL
														            (Rle (minus_SNo one_third) (apply_fun r9s x))
														            (Rle (apply_fun r9s x) one_third)
														            Hr9s_bounds0). }
														        claim Hu10_le_13: Rle (apply_fun u10 x) one_third.
														        { exact (andER
														            (Rle (minus_SNo one_third) (apply_fun u10 x))
														            (Rle (apply_fun u10 x) one_third)
														            Hu10_bounds0). }
														        claim Hu10_ge_m13: Rle (minus_SNo one_third) (apply_fun u10 x).
														        { exact (andEL
														            (Rle (minus_SNo one_third) (apply_fun u10 x))
														            (Rle (apply_fun u10 x) one_third)
														            Hu10_bounds0). }
														        claim Hm13_le_mu10: Rle (minus_SNo one_third) (minus_SNo (apply_fun u10 x)).
														        { exact (Rle_minus_contra (apply_fun u10 x) one_third Hu10_le_13). }
														        claim Hmu10_le_13: Rle (minus_SNo (apply_fun u10 x)) one_third.
														        { claim Htmp: Rle (minus_SNo (apply_fun u10 x)) (minus_SNo (minus_SNo one_third)).
														          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u10 x) Hu10_ge_m13). }
														          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
														          exact Htmp. }
														        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                        (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u10 x))).
														        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u10 x))
														                               Hm13R Hm13R Hm_u10x_R Hm13_le_mu10). }
														        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u10 x)))
														                        (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x))).
														        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r9s x) (minus_SNo (apply_fun u10 x))
														                               Hm13R
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r9s x) Hr9sI0)
														                               Hm_u10x_R Hr9s_ge_m13). }
														        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                        (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x))).
														        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u10 x)))
														                         (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)))
														                         Hlow1 Hlow2). }
														        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x))).
														        { rewrite minus_two_thirds_eq at 1.
														          exact Hlow_tmp. }
														        claim Hup1: Rle (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)))
														                      (add_SNo (apply_fun r9s x) one_third).
														        { exact (Rle_add_SNo_2 (apply_fun r9s x) (minus_SNo (apply_fun u10 x)) one_third
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r9s x) Hr9sI0)
														                               Hm_u10x_R H13R Hmu10_le_13). }
														        claim Hup2: Rle (add_SNo (apply_fun r9s x) one_third)
														                      (add_SNo one_third one_third).
														        { exact (Rle_add_SNo_1 (apply_fun r9s x) one_third one_third
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r9s x) Hr9sI0)
														                               H13R H13R Hr9s_le_13). }
														        claim Hup_tmp: Rle (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)))
														                         (add_SNo one_third one_third).
														        { exact (Rle_tra (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)))
														                         (add_SNo (apply_fun r9s x) one_third)
														                         (add_SNo one_third one_third)
														                         Hup1 Hup2). }
														        claim Hdef23: two_thirds = add_SNo one_third one_third.
														        { reflexivity. }
														        claim Hup: Rle (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x))) two_thirds.
														        { rewrite Hdef23 at 1.
														          exact Hup_tmp. }
														        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                       (add_SNo (apply_fun r9s x) (minus_SNo (apply_fun u10 x)))
														                                       Hm23R H23R Hr10xR Hlow Hup). }
														  set r10s := compose_fun A r10 (div_const_fun den).
															  claim Hr10s_cont: continuous_map A Ta I Ti r10s.
															  { (** structured: prove continuity into R, then restrict range to I **)
															    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
															    { exact (div_const_fun_continuous_pos den H23R H23pos). }
															    claim Hr10s_contR: continuous_map A Ta R R_standard_topology r10s.
															    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
															             r10 (div_const_fun den) Hr10_cont Hdivcont). }
															    claim Hr10s_I: forall x:set, x :e A -> apply_fun r10s x :e I.
															    { let x. assume HxA: x :e A.
															      claim Hr10xI2: apply_fun r10 x :e I2.
															      { exact (Hr10_range x HxA). }
															      claim Hm1R: (minus_SNo 1) :e R.
															      { exact (real_minus_SNo 1 real_1). }
															      claim HmdenR: (minus_SNo den) :e R.
															      { exact (real_minus_SNo den H23R). }
															      claim Hr10xR: apply_fun r10 x :e R.
															      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r10 x) Hr10xI2). }
															      claim Hr10xS: SNo (apply_fun r10 x).
															      { exact (real_SNo (apply_fun r10 x) Hr10xR). }
															      claim Hbounds: Rle (minus_SNo den) (apply_fun r10 x) /\ Rle (apply_fun r10 x) den.
															      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r10 x) HmdenR H23R Hr10xI2). }
															      claim Hlo: Rle (minus_SNo den) (apply_fun r10 x).
															      { exact (andEL (Rle (minus_SNo den) (apply_fun r10 x))
															                     (Rle (apply_fun r10 x) den)
															                     Hbounds). }
															      claim Hhi: Rle (apply_fun r10 x) den.
															      { exact (andER (Rle (minus_SNo den) (apply_fun r10 x))
															                     (Rle (apply_fun r10 x) den)
															                     Hbounds). }
															      claim Hnlt_hi: ~(Rlt den (apply_fun r10 x)).
															      { exact (RleE_nlt (apply_fun r10 x) den Hhi). }
															      claim Hnlt_lo: ~(Rlt (apply_fun r10 x) (minus_SNo den)).
															      { exact (RleE_nlt (minus_SNo den) (apply_fun r10 x) Hlo). }
															      claim HyEq: apply_fun r10s x = div_SNo (apply_fun r10 x) den.
															      { rewrite (compose_fun_apply A r10 (div_const_fun den) x HxA).
															        rewrite (div_const_fun_apply den (apply_fun r10 x) H23R Hr10xR).
															        reflexivity. }
															      claim HyR: apply_fun r10s x :e R.
															      { rewrite HyEq.
															        exact (real_div_SNo (apply_fun r10 x) Hr10xR den H23R). }
															      claim HyS: SNo (apply_fun r10s x).
															      { exact (real_SNo (apply_fun r10s x) HyR). }
															      claim Hy_le_1: Rle (apply_fun r10s x) 1.
															      { apply (RleI (apply_fun r10s x) 1 HyR real_1).
															        prove ~(Rlt 1 (apply_fun r10s x)).
															        assume H1lt: Rlt 1 (apply_fun r10s x).
															        claim H1lty: 1 < apply_fun r10s x.
															        { exact (RltE_lt 1 (apply_fun r10s x) H1lt). }
															        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r10s x) den.
															        { exact (pos_mul_SNo_Lt' 1 (apply_fun r10s x) den SNo_1 HyS H23S H23pos H1lty). }
															        claim HmulLt': den < mul_SNo (apply_fun r10s x) den.
															        { rewrite <- (mul_SNo_oneL den H23S) at 1.
															          exact HmulLt. }
															        claim HmulEq: mul_SNo (apply_fun r10s x) den = apply_fun r10 x.
															        { rewrite HyEq at 1.
															          exact (mul_div_SNo_invL (apply_fun r10 x) den Hr10xS H23S H23ne0). }
															        claim Hden_lt_r10x: den < apply_fun r10 x.
															        { rewrite <- HmulEq.
															          exact HmulLt'. }
															        claim Hbad: Rlt den (apply_fun r10 x).
															        { exact (RltI den (apply_fun r10 x) H23R Hr10xR Hden_lt_r10x). }
															        exact (Hnlt_hi Hbad). }
															      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r10s x).
															      { apply (RleI (minus_SNo 1) (apply_fun r10s x) Hm1R HyR).
															        prove ~(Rlt (apply_fun r10s x) (minus_SNo 1)).
															        assume Hylt: Rlt (apply_fun r10s x) (minus_SNo 1).
															        claim Hylts: apply_fun r10s x < minus_SNo 1.
															        { exact (RltE_lt (apply_fun r10s x) (minus_SNo 1) Hylt). }
															        claim HmulLt: mul_SNo (apply_fun r10s x) den < mul_SNo (minus_SNo 1) den.
															        { exact (pos_mul_SNo_Lt' (apply_fun r10s x) (minus_SNo 1) den HyS
															                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
															        claim HmulEq: mul_SNo (apply_fun r10s x) den = apply_fun r10 x.
															        { rewrite HyEq at 1.
															          exact (mul_div_SNo_invL (apply_fun r10 x) den Hr10xS H23S H23ne0). }
															        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
															        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
															          rewrite (mul_SNo_oneL den H23S) at 1.
															          reflexivity. }
															        claim Hr10x_lt_mden: apply_fun r10 x < minus_SNo den.
															        { rewrite <- HmulEq.
															          rewrite <- HrhsEq.
															          exact HmulLt. }
															        claim Hbad: Rlt (apply_fun r10 x) (minus_SNo den).
															        { exact (RltI (apply_fun r10 x) (minus_SNo den) Hr10xR HmdenR Hr10x_lt_mden). }
															        exact (Hnlt_lo Hbad). }
															      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r10s x)
															                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
															    exact (continuous_map_range_restrict A Ta R R_standard_topology r10s I
															             Hr10s_contR HIcR Hr10s_I). }

														  (** further iteration scaffold: build u11 and g11 from residual r10s **)
														  claim Hex_u11:
														    exists u11:set,
														      continuous_map X Tx I0 T0 u11 /\
														      (forall x:set, x :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u11 x = minus_SNo one_third) /\
														      (forall x:set, x :e preimage_of A r10s ((closed_interval one_third 1) :/\: I) ->
														        apply_fun u11 x = one_third).
														  { exact (Tietze_stepI_g_exists X Tx A r10s Hnorm HA Hr10s_cont). }
														  apply Hex_u11.
														  let u11. assume Hu11.
														  claim Hu11contI0: continuous_map X Tx I0 T0 u11.
														  { claim Hu11AB:
														      continuous_map X Tx I0 T0 u11 /\
														      (forall x:set, x :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u11 x = minus_SNo one_third).
														    { exact (andEL
														        (continuous_map X Tx I0 T0 u11 /\
														         (forall x:set, x :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u11 x = minus_SNo one_third))
														        (forall x:set, x :e preimage_of A r10s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u11 x = one_third)
														        Hu11). }
														    exact (andEL
														        (continuous_map X Tx I0 T0 u11)
														        (forall x:set, x :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														          apply_fun u11 x = minus_SNo one_third)
														        Hu11AB). }
														  claim Hu11contR: continuous_map X Tx R R_standard_topology u11.
														  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
														    { reflexivity. }
														    claim HI0subR: I0 c= R.
														    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
														    exact (continuous_map_range_expand
														             X Tx I0 T0
														             R R_standard_topology
														             u11
														             Hu11contI0
														             HI0subR
														             R_standard_topology_is_topology_local
														             HT0eq). }
														  set den11 := mul_SNo den10 den.
														  claim Hden11R: den11 :e R.
														  { exact (real_mul_SNo den10 Hden10R den H23R). }
														  claim Hden11pos: 0 < den11.
														  { claim Hden10S: SNo den10.
														    { exact (real_SNo den10 Hden10R). }
														    exact (mul_SNo_pos_pos den10 den Hden10S H23S Hden10pos HdenPos). }
														  set u11s := compose_fun X u11 (mul_const_fun den11).
														  claim Hu11s_cont: continuous_map X Tx R R_standard_topology u11s.
														  { exact (scale_continuous_mul_const_pos X Tx u11 den11 HTx Hu11contR Hden11R Hden11pos). }
														  set g11 := compose_fun X (pair_map X g10 u11s) add_fun_R.
														  claim Hg11cont: continuous_map X Tx R R_standard_topology g11.
														  { exact (add_two_continuous_R X Tx g10 u11s HTx Hg10cont Hu11s_cont). }

														  (** further iteration scaffold: residual r11 on A and scaling r11s **)
														  claim Hu11contA: continuous_map A Ta R R_standard_topology u11.
														  { exact (continuous_on_subspace X Tx R R_standard_topology u11 A HTx HAsubX Hu11contR). }
														  set u11neg := compose_fun A u11 neg_fun.
														  claim Hu11neg_cont: continuous_map A Ta R R_standard_topology u11neg.
														  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
														           u11 neg_fun Hu11contA Hnegcont). }
														  claim Hr10s_contR: continuous_map A Ta R R_standard_topology r10s.
														  { claim HTiEq'': Ti = subspace_topology R R_standard_topology I.
														    { exact HTiEq. }
														    exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r10s
														             Hr10s_cont HIcR R_standard_topology_is_topology_local HTiEq''). }
														  set r11 := compose_fun A (pair_map A r10s u11neg) add_fun_R.
														  claim Hr11_cont: continuous_map A Ta R R_standard_topology r11.
														  { exact (add_two_continuous_R A Ta r10s u11neg HTa Hr10s_contR Hu11neg_cont). }
														  claim Hr11_apply: forall x:set, x :e A ->
														    apply_fun r11 x = add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)).
														  { let x. assume HxA: x :e A.
														    claim Hpimg: apply_fun (pair_map A r10s u11neg) x :e setprod R R.
														    { rewrite (pair_map_apply A R R r10s u11neg x HxA).
														      claim Hr10sxI: apply_fun r10s x :e I.
														      { exact (continuous_map_function_on A Ta I Ti r10s Hr10s_cont x HxA). }
														      claim Hr10sxR: apply_fun r10s x :e R.
														      { exact (HIcR (apply_fun r10s x) Hr10sxI). }
														      claim Hu11negRx: apply_fun u11neg x :e R.
														      { exact (continuous_map_function_on A Ta R R_standard_topology u11neg Hu11neg_cont x HxA). }
														      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r10s x) (apply_fun u11neg x) Hr10sxR Hu11negRx). }
														    rewrite (compose_fun_apply A (pair_map A r10s u11neg) add_fun_R x HxA).
														    rewrite (add_fun_R_apply (apply_fun (pair_map A r10s u11neg) x) Hpimg) at 1.
														    rewrite (pair_map_apply A R R r10s u11neg x HxA).
														    rewrite (tuple_2_0_eq (apply_fun r10s x) (apply_fun u11neg x)).
														    rewrite (tuple_2_1_eq (apply_fun r10s x) (apply_fun u11neg x)).
														    rewrite (compose_fun_apply A u11 neg_fun x HxA) at 1.
														    claim Hu11Rx: apply_fun u11 x :e R.
														    { exact (continuous_map_function_on A Ta R R_standard_topology u11 Hu11contA x HxA). }
														    rewrite (neg_fun_apply (apply_fun u11 x) Hu11Rx) at 1.
														    reflexivity. }
														  claim Hr11_range: forall x:set, x :e A -> apply_fun r11 x :e I2.
														  { claim Hu11AB:
														      continuous_map X Tx I0 T0 u11 /\
														      (forall x0:set, x0 :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u11 x0 = minus_SNo one_third).
														    { exact (andEL
														        (continuous_map X Tx I0 T0 u11 /\
														         (forall x0:set, x0 :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u11 x0 = minus_SNo one_third))
														        (forall x0:set, x0 :e preimage_of A r10s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u11 x0 = one_third)
														        Hu11). }
														    claim Hu11_on_B11:
														      forall x0:set, x0 :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u11 x0 = minus_SNo one_third.
														    { exact (andER
														        (continuous_map X Tx I0 T0 u11)
														        (forall x0:set, x0 :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														          apply_fun u11 x0 = minus_SNo one_third)
														        Hu11AB). }
														    claim Hu11_on_C11:
														      forall x0:set, x0 :e preimage_of A r10s ((closed_interval one_third 1) :/\: I) ->
														        apply_fun u11 x0 = one_third.
														    { exact (andER
														        (continuous_map X Tx I0 T0 u11 /\
														         (forall x0:set, x0 :e preimage_of A r10s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u11 x0 = minus_SNo one_third))
														        (forall x0:set, x0 :e preimage_of A r10s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u11 x0 = one_third)
														        Hu11). }
														    let x. assume HxA: x :e A.
														    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
														    set I3 := closed_interval one_third 1.
														    set B11 := preimage_of A r10s (I1 :/\: I).
														    set C11 := preimage_of A r10s (I3 :/\: I).
														    claim Hr10sIx: apply_fun r10s x :e I.
														    { exact (continuous_map_function_on A Ta I Ti r10s Hr10s_cont x HxA). }
														    claim HB11_cases: x :e B11 \/ ~(x :e B11).
														    { exact (xm (x :e B11)). }
														    apply (HB11_cases (apply_fun r11 x :e I2)).
														    - assume HxB11: x :e B11.
														      claim Hu11eq: apply_fun u11 x = minus_SNo one_third.
														      { exact (Hu11_on_B11 x HxB11). }
														      claim Hr11eq: apply_fun r11 x = add_SNo (apply_fun r10s x) one_third.
														      { rewrite (Hr11_apply x HxA).
														        rewrite Hu11eq at 1.
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
														        reflexivity. }
														      rewrite Hr11eq.
														      claim Hr10sI1I: apply_fun r10s x :e I1 :/\: I.
														      { exact (SepE2 A (fun x0:set => apply_fun r10s x0 :e I1 :/\: I) x HxB11). }
														      claim Hr10sI1: apply_fun r10s x :e I1.
														      { exact (binintersectE1 I1 I (apply_fun r10s x) Hr10sI1I). }
														      claim H13R: one_third :e R.
														      { exact one_third_in_R. }
														      claim H23R: two_thirds :e R.
														      { exact two_thirds_in_R. }
														      claim Hm23R: minus_SNo two_thirds :e R.
														      { exact (real_minus_SNo two_thirds H23R). }
														      claim Hm1R: minus_SNo 1 :e R.
														      { exact (real_minus_SNo 1 real_1). }
														      claim Hm13R: minus_SNo one_third :e R.
														      { exact (real_minus_SNo one_third H13R). }
														      claim Hr10sRx: apply_fun r10s x :e R.
														      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r10s x) Hr10sI1). }
														      claim Hr10s_bounds: Rle (minus_SNo 1) (apply_fun r10s x) /\ Rle (apply_fun r10s x) (minus_SNo one_third).
														      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r10s x)
														                                     Hm1R Hm13R Hr10sI1). }
														      claim Hm1le: Rle (minus_SNo 1) (apply_fun r10s x).
														      { exact (andEL (Rle (minus_SNo 1) (apply_fun r10s x))
														                     (Rle (apply_fun r10s x) (minus_SNo one_third)) Hr10s_bounds). }
														      claim HhiI1: Rle (apply_fun r10s x) (minus_SNo one_third).
														      { exact (andER (Rle (minus_SNo 1) (apply_fun r10s x))
														                     (Rle (apply_fun r10s x) (minus_SNo one_third)) Hr10s_bounds). }
														      claim Hr11xR: add_SNo (apply_fun r10s x) one_third :e R.
														      { exact (real_add_SNo (apply_fun r10s x) Hr10sRx one_third H13R). }
														      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r10s x) one_third).
														      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r10s x) one_third Hm1R Hr10sRx H13R Hm1le). }
														      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r10s x) one_third).
														      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
														        exact Hlow_tmp. }
														      claim Hup0_tmp: Rle (add_SNo (apply_fun r10s x) one_third) (add_SNo (minus_SNo one_third) one_third).
														      { exact (Rle_add_SNo_1 (apply_fun r10s x) (minus_SNo one_third) one_third Hr10sRx Hm13R H13R HhiI1). }
														      claim H13S: SNo one_third.
														      { exact (real_SNo one_third H13R). }
														      claim Hup0: Rle (add_SNo (apply_fun r10s x) one_third) 0.
														      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
														        exact Hup0_tmp. }
														      claim H0le23: Rle 0 two_thirds.
														      { exact Rle_0_two_thirds. }
														      claim Hup: Rle (add_SNo (apply_fun r10s x) one_third) two_thirds.
														      { exact (Rle_tra (add_SNo (apply_fun r10s x) one_third) 0 two_thirds Hup0 H0le23). }
														      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                     (add_SNo (apply_fun r10s x) one_third)
														                                     Hm23R H23R Hr11xR Hlow Hup).
														    - assume HxnotB11: ~(x :e B11).
														      claim HC11_cases: x :e C11 \/ ~(x :e C11).
														      { exact (xm (x :e C11)). }
														      apply (HC11_cases (apply_fun r11 x :e I2)).
														      + assume HxC11: x :e C11.
														        claim Hu11eq: apply_fun u11 x = one_third.
														        { exact (Hu11_on_C11 x HxC11). }
														        claim Hr11eq: apply_fun r11 x = add_SNo (apply_fun r10s x) (minus_SNo one_third).
														        { rewrite (Hr11_apply x HxA).
														          rewrite Hu11eq at 1.
														          reflexivity. }
														        rewrite Hr11eq.
														        claim Hr10sI3I: apply_fun r10s x :e I3 :/\: I.
														        { exact (SepE2 A (fun x0:set => apply_fun r10s x0 :e I3 :/\: I) x HxC11). }
														        claim Hr10sI3: apply_fun r10s x :e I3.
														        { exact (binintersectE1 I3 I (apply_fun r10s x) Hr10sI3I). }
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        claim H23R: two_thirds :e R.
														        { exact two_thirds_in_R. }
														        claim Hm23R: minus_SNo two_thirds :e R.
														        { exact (real_minus_SNo two_thirds H23R). }
														        claim Hm13R: minus_SNo one_third :e R.
														        { exact (real_minus_SNo one_third H13R). }
														        claim Hr10sRx: apply_fun r10s x :e R.
														        { exact (closed_interval_sub_R one_third 1 (apply_fun r10s x) Hr10sI3). }
														        claim Hr10s_bounds: Rle one_third (apply_fun r10s x) /\ Rle (apply_fun r10s x) 1.
														        { exact (closed_interval_bounds one_third 1 (apply_fun r10s x) H13R real_1 Hr10sI3). }
														        claim HloI3: Rle one_third (apply_fun r10s x).
														        { exact (andEL (Rle one_third (apply_fun r10s x)) (Rle (apply_fun r10s x) 1) Hr10s_bounds). }
														        claim HhiI3: Rle (apply_fun r10s x) 1.
														        { exact (andER (Rle one_third (apply_fun r10s x)) (Rle (apply_fun r10s x) 1) Hr10s_bounds). }
														        claim Hr11xR: add_SNo (apply_fun r10s x) (minus_SNo one_third) :e R.
														        { exact (real_add_SNo (apply_fun r10s x) Hr10sRx (minus_SNo one_third) Hm13R). }
														        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
														                          (add_SNo (apply_fun r10s x) (minus_SNo one_third)).
														        { exact (Rle_add_SNo_1 one_third (apply_fun r10s x) (minus_SNo one_third)
														                               H13R Hr10sRx Hm13R HloI3). }
														        claim H13S: SNo one_third.
														        { exact (real_SNo one_third H13R). }
														        claim H0le: Rle 0 (add_SNo (apply_fun r10s x) (minus_SNo one_third)).
														        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
														          exact H0le_tmp. }
														        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
														        { exact Rle_minus_two_thirds_0. }
														        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r10s x) (minus_SNo one_third)).
														        { exact (Rle_tra (minus_SNo two_thirds) 0
														                         (add_SNo (apply_fun r10s x) (minus_SNo one_third))
														                         Hm23le0 H0le). }
														        claim Hup_tmp: Rle (add_SNo (apply_fun r10s x) (minus_SNo one_third))
														                         (add_SNo 1 (minus_SNo one_third)).
														        { exact (Rle_add_SNo_1 (apply_fun r10s x) 1 (minus_SNo one_third)
														                               Hr10sRx real_1 Hm13R HhiI3). }
														        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
														        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
														          exact (Rle_refl two_thirds H23R). }
														        claim Hup: Rle (add_SNo (apply_fun r10s x) (minus_SNo one_third)) two_thirds.
														        { exact (Rle_tra (add_SNo (apply_fun r10s x) (minus_SNo one_third))
														                         (add_SNo 1 (minus_SNo one_third))
														                         two_thirds
														                         Hup_tmp Hup1). }
														        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                       (add_SNo (apply_fun r10s x) (minus_SNo one_third))
														                                       Hm23R H23R Hr11xR Hlow Hup).
														      + assume HxnotC11: ~(x :e C11).
														        claim HxX: x :e X.
														        { exact (HAsubX x HxA). }
														        claim HnotI1: ~(apply_fun r10s x :e I1).
														        { assume Hr10sI1': apply_fun r10s x :e I1.
														          claim Hr10sI1I: apply_fun r10s x :e I1 :/\: I.
														          { exact (binintersectI I1 I (apply_fun r10s x) Hr10sI1' Hr10sIx). }
														          claim HxB11': x :e B11.
														          { exact (SepI A (fun x0:set => apply_fun r10s x0 :e I1 :/\: I) x HxA Hr10sI1I). }
														          apply FalseE.
														          exact (HxnotB11 HxB11'). }
														        claim HnotI3: ~(apply_fun r10s x :e I3).
														        { assume Hr10sI3': apply_fun r10s x :e I3.
														          claim Hr10sI3I: apply_fun r10s x :e I3 :/\: I.
														          { exact (binintersectI I3 I (apply_fun r10s x) Hr10sI3' Hr10sIx). }
														          claim HxC11': x :e C11.
														          { exact (SepI A (fun x0:set => apply_fun r10s x0 :e I3 :/\: I) x HxA Hr10sI3I). }
														          apply FalseE.
														          exact (HxnotC11 HxC11'). }
														        claim Hr10sRx: apply_fun r10s x :e R.
														        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r10s x) Hr10sIx). }
														        claim Hm1R: minus_SNo 1 :e R.
														        { exact (real_minus_SNo 1 real_1). }
														        claim H13R: one_third :e R.
														        { exact one_third_in_R. }
														        claim Hm13R: minus_SNo one_third :e R.
														        { exact (real_minus_SNo one_third H13R). }
														        claim Hr10s_boundsI: Rle (minus_SNo 1) (apply_fun r10s x) /\ Rle (apply_fun r10s x) 1.
														        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r10s x) Hm1R real_1 Hr10sIx). }
														        claim Hnlt_fx_m1: ~(Rlt (apply_fun r10s x) (minus_SNo 1)).
														        { exact (RleE_nlt (minus_SNo 1) (apply_fun r10s x)
														                          (andEL (Rle (minus_SNo 1) (apply_fun r10s x)) (Rle (apply_fun r10s x) 1) Hr10s_boundsI)). }
														        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r10s x)).
														        { exact (RleE_nlt (apply_fun r10s x) 1
														                          (andER (Rle (minus_SNo 1) (apply_fun r10s x)) (Rle (apply_fun r10s x) 1) Hr10s_boundsI)). }
														        claim HnotI1_cases: Rlt (apply_fun r10s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r10s x).
														        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r10s x)
														                                              Hm1R Hm13R Hr10sRx HnotI1). }
														        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r10s x).
														        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r10s x))).
														          - assume Hbad: Rlt (apply_fun r10s x) (minus_SNo 1).
														            apply FalseE.
														            exact (Hnlt_fx_m1 Hbad).
														          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r10s x).
														            exact Hok. }
														        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r10s x) (minus_SNo one_third)).
														        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r10s x) Hm13lt_fx). }
														        claim HnotI3_cases: Rlt (apply_fun r10s x) one_third \/ Rlt 1 (apply_fun r10s x).
														        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r10s x)
														                                              H13R real_1 Hr10sRx HnotI3). }
														        claim Hfx_lt_13: Rlt (apply_fun r10s x) one_third.
														        { apply (HnotI3_cases (Rlt (apply_fun r10s x) one_third)).
														          - assume Hok: Rlt (apply_fun r10s x) one_third.
														            exact Hok.
														          - assume Hbad: Rlt 1 (apply_fun r10s x).
														            apply FalseE.
														            exact (Hnlt_1_fx Hbad). }
														        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r10s x)).
														        { exact (not_Rlt_sym (apply_fun r10s x) one_third Hfx_lt_13). }
														        claim Hr10sI0: apply_fun r10s x :e I0.
														        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
														          { reflexivity. }
														          claim HxSep: apply_fun r10s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
														          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
														                        (apply_fun r10s x) Hr10sRx (andI (~(Rlt (apply_fun r10s x) (minus_SNo one_third)))
														                                                        (~(Rlt one_third (apply_fun r10s x)))
														                                                        Hnot_fx_lt_m13
														                                                        Hnot_13_lt_fx)). }
														          rewrite HI0_def.
														          exact HxSep. }
														        claim Hu11funI0: function_on u11 X I0.
														        { exact (continuous_map_function_on X Tx I0 T0 u11 Hu11contI0). }
														        claim Hu11xI0: apply_fun u11 x :e I0.
														        { exact (Hu11funI0 x HxX). }
														        claim Hu11xR: apply_fun u11 x :e R.
														        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u11 x) Hu11xI0). }
														        claim Hm_u11x_R: minus_SNo (apply_fun u11 x) :e R.
														        { exact (real_minus_SNo (apply_fun u11 x) Hu11xR). }
														        rewrite (Hr11_apply x HxA).
														        claim Hr11xR: add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)) :e R.
														        { exact (real_add_SNo (apply_fun r10s x)
														                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r10s x) Hr10sI0)
														                              (minus_SNo (apply_fun u11 x)) Hm_u11x_R). }
														        claim H23R: two_thirds :e R.
														        { exact two_thirds_in_R. }
														        claim Hm23R: minus_SNo two_thirds :e R.
														        { exact (real_minus_SNo two_thirds H23R). }
														        claim Hr10s_bounds0: Rle (minus_SNo one_third) (apply_fun r10s x) /\ Rle (apply_fun r10s x) one_third.
														        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r10s x) Hm13R H13R Hr10sI0). }
														        claim Hu11_bounds0: Rle (minus_SNo one_third) (apply_fun u11 x) /\ Rle (apply_fun u11 x) one_third.
														        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u11 x) Hm13R H13R Hu11xI0). }
														        claim Hr10s_le_13: Rle (apply_fun r10s x) one_third.
														        { exact (andER
														            (Rle (minus_SNo one_third) (apply_fun r10s x))
														            (Rle (apply_fun r10s x) one_third)
														            Hr10s_bounds0). }
														        claim Hr10s_ge_m13: Rle (minus_SNo one_third) (apply_fun r10s x).
														        { exact (andEL
														            (Rle (minus_SNo one_third) (apply_fun r10s x))
														            (Rle (apply_fun r10s x) one_third)
														            Hr10s_bounds0). }
														        claim Hu11_le_13: Rle (apply_fun u11 x) one_third.
														        { exact (andER
														            (Rle (minus_SNo one_third) (apply_fun u11 x))
														            (Rle (apply_fun u11 x) one_third)
														            Hu11_bounds0). }
														        claim Hu11_ge_m13: Rle (minus_SNo one_third) (apply_fun u11 x).
														        { exact (andEL
														            (Rle (minus_SNo one_third) (apply_fun u11 x))
														            (Rle (apply_fun u11 x) one_third)
														            Hu11_bounds0). }
														        claim Hm13_le_mu11: Rle (minus_SNo one_third) (minus_SNo (apply_fun u11 x)).
														        { exact (Rle_minus_contra (apply_fun u11 x) one_third Hu11_le_13). }
														        claim Hmu11_le_13: Rle (minus_SNo (apply_fun u11 x)) one_third.
														        { claim Htmp: Rle (minus_SNo (apply_fun u11 x)) (minus_SNo (minus_SNo one_third)).
														          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u11 x) Hu11_ge_m13). }
														          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
														          exact Htmp. }
														        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                        (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u11 x))).
														        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u11 x))
														                               Hm13R Hm13R Hm_u11x_R Hm13_le_mu11). }
														        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u11 x)))
														                        (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x))).
														        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r10s x) (minus_SNo (apply_fun u11 x))
														                               Hm13R
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r10s x) Hr10sI0)
														                               Hm_u11x_R Hr10s_ge_m13). }
														        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                        (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x))).
														        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
														                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u11 x)))
														                         (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)))
														                         Hlow1 Hlow2). }
														        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x))).
														        { rewrite minus_two_thirds_eq at 1.
														          exact Hlow_tmp. }
														        claim Hup1: Rle (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)))
														                      (add_SNo (apply_fun r10s x) one_third).
														        { exact (Rle_add_SNo_2 (apply_fun r10s x) (minus_SNo (apply_fun u11 x)) one_third
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r10s x) Hr10sI0)
														                               Hm_u11x_R H13R Hmu11_le_13). }
														        claim Hup2: Rle (add_SNo (apply_fun r10s x) one_third)
														                      (add_SNo one_third one_third).
														        { exact (Rle_add_SNo_1 (apply_fun r10s x) one_third one_third
														                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r10s x) Hr10sI0)
														                               H13R H13R Hr10s_le_13). }
														        claim Hup_tmp: Rle (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)))
														                         (add_SNo one_third one_third).
														        { exact (Rle_tra (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)))
														                         (add_SNo (apply_fun r10s x) one_third)
														                         (add_SNo one_third one_third)
														                         Hup1 Hup2). }
														        claim Hdef23: two_thirds = add_SNo one_third one_third.
														        { reflexivity. }
														        claim Hup: Rle (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x))) two_thirds.
														        { rewrite Hdef23 at 1.
														          exact Hup_tmp. }
														        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
														                                       (add_SNo (apply_fun r10s x) (minus_SNo (apply_fun u11 x)))
														                                       Hm23R H23R Hr11xR Hlow Hup). }
														  set r11s := compose_fun A r11 (div_const_fun den).
														  claim Hr11s_cont: continuous_map A Ta I Ti r11s.
														  { (** structured: prove continuity into R, then restrict range to I **)
														    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
														    { exact (div_const_fun_continuous_pos den H23R H23pos). }
														    claim Hr11s_contR: continuous_map A Ta R R_standard_topology r11s.
														    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
														             r11 (div_const_fun den) Hr11_cont Hdivcont). }
														    claim Hr11s_I: forall x:set, x :e A -> apply_fun r11s x :e I.
														    { let x. assume HxA: x :e A.
														      claim Hr11xI2: apply_fun r11 x :e I2.
														      { exact (Hr11_range x HxA). }
														      claim Hm1R: (minus_SNo 1) :e R.
														      { exact (real_minus_SNo 1 real_1). }
														      claim HmdenR: (minus_SNo den) :e R.
														      { exact (real_minus_SNo den H23R). }
														      claim Hr11xR: apply_fun r11 x :e R.
														      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r11 x) Hr11xI2). }
														      claim Hr11xS: SNo (apply_fun r11 x).
														      { exact (real_SNo (apply_fun r11 x) Hr11xR). }
														      claim Hbounds: Rle (minus_SNo den) (apply_fun r11 x) /\ Rle (apply_fun r11 x) den.
														      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r11 x) HmdenR H23R Hr11xI2). }
														      claim Hlo: Rle (minus_SNo den) (apply_fun r11 x).
														      { exact (andEL (Rle (minus_SNo den) (apply_fun r11 x))
														                     (Rle (apply_fun r11 x) den)
														                     Hbounds). }
														      claim Hhi: Rle (apply_fun r11 x) den.
														      { exact (andER (Rle (minus_SNo den) (apply_fun r11 x))
														                     (Rle (apply_fun r11 x) den)
														                     Hbounds). }
														      claim Hnlt_hi: ~(Rlt den (apply_fun r11 x)).
														      { exact (RleE_nlt (apply_fun r11 x) den Hhi). }
														      claim Hnlt_lo: ~(Rlt (apply_fun r11 x) (minus_SNo den)).
														      { exact (RleE_nlt (minus_SNo den) (apply_fun r11 x) Hlo). }
														      claim HyEq: apply_fun r11s x = div_SNo (apply_fun r11 x) den.
														      { rewrite (compose_fun_apply A r11 (div_const_fun den) x HxA).
														        rewrite (div_const_fun_apply den (apply_fun r11 x) H23R Hr11xR).
														        reflexivity. }
														      claim HyR: apply_fun r11s x :e R.
														      { rewrite HyEq.
														        exact (real_div_SNo (apply_fun r11 x) Hr11xR den H23R). }
														      claim HyS: SNo (apply_fun r11s x).
														      { exact (real_SNo (apply_fun r11s x) HyR). }
														      claim Hy_le_1: Rle (apply_fun r11s x) 1.
														      { apply (RleI (apply_fun r11s x) 1 HyR real_1).
														        prove ~(Rlt 1 (apply_fun r11s x)).
														        assume H1lt: Rlt 1 (apply_fun r11s x).
														        claim H1lty: 1 < apply_fun r11s x.
														        { exact (RltE_lt 1 (apply_fun r11s x) H1lt). }
														        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r11s x) den.
														        { exact (pos_mul_SNo_Lt' 1 (apply_fun r11s x) den SNo_1 HyS H23S H23pos H1lty). }
														        claim HmulLt': den < mul_SNo (apply_fun r11s x) den.
														        { rewrite <- (mul_SNo_oneL den H23S) at 1.
														          exact HmulLt. }
														        claim HmulEq: mul_SNo (apply_fun r11s x) den = apply_fun r11 x.
														        { rewrite HyEq at 1.
														          exact (mul_div_SNo_invL (apply_fun r11 x) den Hr11xS H23S H23ne0). }
														        claim Hden_lt_r11x: den < apply_fun r11 x.
														        { rewrite <- HmulEq.
														          exact HmulLt'. }
														        claim Hbad: Rlt den (apply_fun r11 x).
														        { exact (RltI den (apply_fun r11 x) H23R Hr11xR Hden_lt_r11x). }
														        exact (Hnlt_hi Hbad). }
														      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r11s x).
														      { apply (RleI (minus_SNo 1) (apply_fun r11s x) Hm1R HyR).
														        prove ~(Rlt (apply_fun r11s x) (minus_SNo 1)).
														        assume Hylt: Rlt (apply_fun r11s x) (minus_SNo 1).
														        claim Hylts: apply_fun r11s x < minus_SNo 1.
														        { exact (RltE_lt (apply_fun r11s x) (minus_SNo 1) Hylt). }
														        claim HmulLt: mul_SNo (apply_fun r11s x) den < mul_SNo (minus_SNo 1) den.
														        { exact (pos_mul_SNo_Lt' (apply_fun r11s x) (minus_SNo 1) den HyS
														                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
														        claim HmulEq: mul_SNo (apply_fun r11s x) den = apply_fun r11 x.
														        { rewrite HyEq at 1.
														          exact (mul_div_SNo_invL (apply_fun r11 x) den Hr11xS H23S H23ne0). }
														        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
														        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
														          rewrite (mul_SNo_oneL den H23S) at 1.
														          reflexivity. }
														        claim Hr11x_lt_mden: apply_fun r11 x < minus_SNo den.
														        { rewrite <- HmulEq.
														          rewrite <- HrhsEq.
														          exact HmulLt. }
														        claim Hbad: Rlt (apply_fun r11 x) (minus_SNo den).
														        { exact (RltI (apply_fun r11 x) (minus_SNo den) Hr11xR HmdenR Hr11x_lt_mden). }
														        exact (Hnlt_lo Hbad). }
														      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r11s x)
														                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
														    exact (continuous_map_range_restrict A Ta R R_standard_topology r11s I
														             Hr11s_contR HIcR Hr11s_I). }

														  (** further iteration scaffold: build u12 and g12 from residual r11s **)
														  claim Hex_u12:
														    exists u12:set,
														      continuous_map X Tx I0 T0 u12 /\
														      (forall x:set, x :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u12 x = minus_SNo one_third) /\
														      (forall x:set, x :e preimage_of A r11s ((closed_interval one_third 1) :/\: I) ->
														        apply_fun u12 x = one_third).
														  { exact (Tietze_stepI_g_exists X Tx A r11s Hnorm HA Hr11s_cont). }
														  apply Hex_u12.
														  let u12. assume Hu12.
														  claim Hu12contI0: continuous_map X Tx I0 T0 u12.
														  { claim Hu12AB:
														      continuous_map X Tx I0 T0 u12 /\
														      (forall x:set, x :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														        apply_fun u12 x = minus_SNo one_third).
														    { exact (andEL
														        (continuous_map X Tx I0 T0 u12 /\
														         (forall x:set, x :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														           apply_fun u12 x = minus_SNo one_third))
														        (forall x:set, x :e preimage_of A r11s ((closed_interval one_third 1) :/\: I) ->
														          apply_fun u12 x = one_third)
														        Hu12). }
														    exact (andEL
														        (continuous_map X Tx I0 T0 u12)
														        (forall x:set, x :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
														          apply_fun u12 x = minus_SNo one_third)
														        Hu12AB). }
														  claim Hu12contR: continuous_map X Tx R R_standard_topology u12.
														  { claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
														    { reflexivity. }
														    claim HI0subR: I0 c= R.
														    { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
														    exact (continuous_map_range_expand
														             X Tx I0 T0
														             R R_standard_topology
														             u12
														             Hu12contI0
														             HI0subR
														             R_standard_topology_is_topology_local
														             HT0eq). }
														  set den12 := mul_SNo den11 den.
														  claim Hden12R: den12 :e R.
														  { exact (real_mul_SNo den11 Hden11R den H23R). }
														  claim Hden12pos: 0 < den12.
														  { claim Hden11S: SNo den11.
														    { exact (real_SNo den11 Hden11R). }
														    exact (mul_SNo_pos_pos den11 den Hden11S H23S Hden11pos HdenPos). }
														  set u12s := compose_fun X u12 (mul_const_fun den12).
														  claim Hu12s_cont: continuous_map X Tx R R_standard_topology u12s.
														  { exact (scale_continuous_mul_const_pos X Tx u12 den12 HTx Hu12contR Hden12R Hden12pos). }
														  set g12 := compose_fun X (pair_map X g11 u12s) add_fun_R.
														  claim Hg12cont: continuous_map X Tx R R_standard_topology g12.
														  { exact (add_two_continuous_R X Tx g11 u12s HTx Hg11cont Hu12s_cont). }

														  (** further iteration scaffold: residual r12 on A and scaling r12s **)
														  claim Hu12contA: continuous_map A Ta R R_standard_topology u12.
														  { exact (continuous_on_subspace X Tx R R_standard_topology u12 A HTx HAsubX Hu12contR). }
														  set u12neg := compose_fun A u12 neg_fun.
														  claim Hu12neg_cont: continuous_map A Ta R R_standard_topology u12neg.
														  { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
														           u12 neg_fun Hu12contA Hnegcont). }
														  claim Hr11s_contR: continuous_map A Ta R R_standard_topology r11s.
														  { claim HTiEq''': Ti = subspace_topology R R_standard_topology I.
														    { exact HTiEq. }
														    exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r11s
														             Hr11s_cont HIcR R_standard_topology_is_topology_local HTiEq'''). }
														  set r12 := compose_fun A (pair_map A r11s u12neg) add_fun_R.
														  claim Hr12_cont: continuous_map A Ta R R_standard_topology r12.
														  { exact (add_two_continuous_R A Ta r11s u12neg HTa Hr11s_contR Hu12neg_cont). }
														  claim Hr12_apply: forall x:set, x :e A ->
														    apply_fun r12 x = add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)).
														  { let x. assume HxA: x :e A.
														    claim Hpimg: apply_fun (pair_map A r11s u12neg) x :e setprod R R.
														    { rewrite (pair_map_apply A R R r11s u12neg x HxA).
														      claim Hr11sxI: apply_fun r11s x :e I.
														      { exact (continuous_map_function_on A Ta I Ti r11s Hr11s_cont x HxA). }
														      claim Hr11sxR: apply_fun r11s x :e R.
														      { exact (HIcR (apply_fun r11s x) Hr11sxI). }
														      claim Hu12negRx: apply_fun u12neg x :e R.
														      { exact (continuous_map_function_on A Ta R R_standard_topology u12neg Hu12neg_cont x HxA). }
														      exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun r11s x) (apply_fun u12neg x) Hr11sxR Hu12negRx). }
														    rewrite (compose_fun_apply A (pair_map A r11s u12neg) add_fun_R x HxA).
														    rewrite (add_fun_R_apply (apply_fun (pair_map A r11s u12neg) x) Hpimg) at 1.
														    rewrite (pair_map_apply A R R r11s u12neg x HxA).
														    rewrite (tuple_2_0_eq (apply_fun r11s x) (apply_fun u12neg x)).
														    rewrite (tuple_2_1_eq (apply_fun r11s x) (apply_fun u12neg x)).
														    rewrite (compose_fun_apply A u12 neg_fun x HxA) at 1.
														    claim Hu12Rx: apply_fun u12 x :e R.
														    { exact (continuous_map_function_on A Ta R R_standard_topology u12 Hu12contA x HxA). }
														    rewrite (neg_fun_apply (apply_fun u12 x) Hu12Rx) at 1.
														    reflexivity. }
															  claim Hr12_range: forall x:set, x :e A -> apply_fun r12 x :e I2.
															  { claim Hu12AB:
															      continuous_map X Tx I0 T0 u12 /\
															      (forall x0:set, x0 :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															        apply_fun u12 x0 = minus_SNo one_third).
															    { exact (andEL
															        (continuous_map X Tx I0 T0 u12 /\
															         (forall x0:set, x0 :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															           apply_fun u12 x0 = minus_SNo one_third))
															        (forall x0:set, x0 :e preimage_of A r11s ((closed_interval one_third 1) :/\: I) ->
															          apply_fun u12 x0 = one_third)
															        Hu12). }
															    claim Hu12_on_B12:
															      forall x0:set, x0 :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															        apply_fun u12 x0 = minus_SNo one_third.
															    { exact (andER
															        (continuous_map X Tx I0 T0 u12)
															        (forall x0:set, x0 :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															          apply_fun u12 x0 = minus_SNo one_third)
															        Hu12AB). }
															    claim Hu12_on_C12:
															      forall x0:set, x0 :e preimage_of A r11s ((closed_interval one_third 1) :/\: I) ->
															        apply_fun u12 x0 = one_third.
															    { exact (andER
															        (continuous_map X Tx I0 T0 u12 /\
															         (forall x0:set, x0 :e preimage_of A r11s ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															           apply_fun u12 x0 = minus_SNo one_third))
															        (forall x0:set, x0 :e preimage_of A r11s ((closed_interval one_third 1) :/\: I) ->
															          apply_fun u12 x0 = one_third)
															        Hu12). }
															    let x. assume HxA: x :e A.
															    set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
															    set I3 := closed_interval one_third 1.
															    set B12 := preimage_of A r11s (I1 :/\: I).
															    set C12 := preimage_of A r11s (I3 :/\: I).
															    claim Hr11sIx: apply_fun r11s x :e I.
															    { exact (continuous_map_function_on A Ta I Ti r11s Hr11s_cont x HxA). }
															    claim HB12_cases: x :e B12 \/ ~(x :e B12).
															    { exact (xm (x :e B12)). }
															    apply (HB12_cases (apply_fun r12 x :e I2)).
															    - assume HxB12: x :e B12.
															      claim Hu12eq: apply_fun u12 x = minus_SNo one_third.
															      { exact (Hu12_on_B12 x HxB12). }
															      claim Hr12eq: apply_fun r12 x = add_SNo (apply_fun r11s x) one_third.
															      { rewrite (Hr12_apply x HxA).
															        rewrite Hu12eq at 1.
															        claim H13R: one_third :e R.
															        { exact one_third_in_R. }
															        rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
															        reflexivity. }
															      rewrite Hr12eq.
															      claim Hr11sI1I: apply_fun r11s x :e I1 :/\: I.
															      { exact (SepE2 A (fun x0:set => apply_fun r11s x0 :e I1 :/\: I) x HxB12). }
															      claim Hr11sI1: apply_fun r11s x :e I1.
															      { exact (binintersectE1 I1 I (apply_fun r11s x) Hr11sI1I). }
															      claim H13R: one_third :e R.
															      { exact one_third_in_R. }
															      claim H23R: two_thirds :e R.
															      { exact two_thirds_in_R. }
															      claim Hm23R: minus_SNo two_thirds :e R.
															      { exact (real_minus_SNo two_thirds H23R). }
															      claim Hm1R: minus_SNo 1 :e R.
															      { exact (real_minus_SNo 1 real_1). }
															      claim Hm13R: minus_SNo one_third :e R.
															      { exact (real_minus_SNo one_third H13R). }
															      claim Hr11sRx: apply_fun r11s x :e R.
															      { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun r11s x) Hr11sI1). }
															      claim Hr11s_bounds: Rle (minus_SNo 1) (apply_fun r11s x) /\ Rle (apply_fun r11s x) (minus_SNo one_third).
															      { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun r11s x)
															                                     Hm1R Hm13R Hr11sI1). }
															      claim Hm1le: Rle (minus_SNo 1) (apply_fun r11s x).
															      { exact (andEL (Rle (minus_SNo 1) (apply_fun r11s x))
															                     (Rle (apply_fun r11s x) (minus_SNo one_third)) Hr11s_bounds). }
															      claim HhiI1: Rle (apply_fun r11s x) (minus_SNo one_third).
															      { exact (andER (Rle (minus_SNo 1) (apply_fun r11s x))
															                     (Rle (apply_fun r11s x) (minus_SNo one_third)) Hr11s_bounds). }
															      claim Hr12xR: add_SNo (apply_fun r11s x) one_third :e R.
															      { exact (real_add_SNo (apply_fun r11s x) Hr11sRx one_third H13R). }
															      claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r11s x) one_third).
															      { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r11s x) one_third Hm1R Hr11sRx H13R Hm1le). }
															      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r11s x) one_third).
															      { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
															        exact Hlow_tmp. }
															      claim Hup0_tmp: Rle (add_SNo (apply_fun r11s x) one_third) (add_SNo (minus_SNo one_third) one_third).
															      { exact (Rle_add_SNo_1 (apply_fun r11s x) (minus_SNo one_third) one_third Hr11sRx Hm13R H13R HhiI1). }
															      claim H13S: SNo one_third.
															      { exact (real_SNo one_third H13R). }
															      claim Hup0: Rle (add_SNo (apply_fun r11s x) one_third) 0.
															      { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
															        exact Hup0_tmp. }
															      claim H0le23: Rle 0 two_thirds.
															      { exact Rle_0_two_thirds. }
															      claim Hup: Rle (add_SNo (apply_fun r11s x) one_third) two_thirds.
															      { exact (Rle_tra (add_SNo (apply_fun r11s x) one_third) 0 two_thirds Hup0 H0le23). }
															      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
															                                     (add_SNo (apply_fun r11s x) one_third)
															                                     Hm23R H23R Hr12xR Hlow Hup).
															    - assume HxnotB12: ~(x :e B12).
															      claim HC12_cases: x :e C12 \/ ~(x :e C12).
															      { exact (xm (x :e C12)). }
															      apply (HC12_cases (apply_fun r12 x :e I2)).
															      + assume HxC12: x :e C12.
															        claim Hu12eq: apply_fun u12 x = one_third.
															        { exact (Hu12_on_C12 x HxC12). }
															        claim Hr12eq: apply_fun r12 x = add_SNo (apply_fun r11s x) (minus_SNo one_third).
															        { rewrite (Hr12_apply x HxA).
															          rewrite Hu12eq at 1.
															          reflexivity. }
															        rewrite Hr12eq.
															        claim Hr11sI3I: apply_fun r11s x :e I3 :/\: I.
															        { exact (SepE2 A (fun x0:set => apply_fun r11s x0 :e I3 :/\: I) x HxC12). }
															        claim Hr11sI3: apply_fun r11s x :e I3.
															        { exact (binintersectE1 I3 I (apply_fun r11s x) Hr11sI3I). }
															        claim H13R: one_third :e R.
															        { exact one_third_in_R. }
															        claim H23R: two_thirds :e R.
															        { exact two_thirds_in_R. }
															        claim Hm23R: minus_SNo two_thirds :e R.
															        { exact (real_minus_SNo two_thirds H23R). }
															        claim Hm13R: minus_SNo one_third :e R.
															        { exact (real_minus_SNo one_third H13R). }
															        claim Hr11sRx: apply_fun r11s x :e R.
															        { exact (closed_interval_sub_R one_third 1 (apply_fun r11s x) Hr11sI3). }
															        claim Hr11s_bounds: Rle one_third (apply_fun r11s x) /\ Rle (apply_fun r11s x) 1.
															        { exact (closed_interval_bounds one_third 1 (apply_fun r11s x) H13R real_1 Hr11sI3). }
															        claim HloI3: Rle one_third (apply_fun r11s x).
															        { exact (andEL (Rle one_third (apply_fun r11s x)) (Rle (apply_fun r11s x) 1) Hr11s_bounds). }
															        claim HhiI3: Rle (apply_fun r11s x) 1.
															        { exact (andER (Rle one_third (apply_fun r11s x)) (Rle (apply_fun r11s x) 1) Hr11s_bounds). }
															        claim Hr12xR: add_SNo (apply_fun r11s x) (minus_SNo one_third) :e R.
															        { exact (real_add_SNo (apply_fun r11s x) Hr11sRx (minus_SNo one_third) Hm13R). }
															        claim H0le_tmp: Rle (add_SNo one_third (minus_SNo one_third))
															                          (add_SNo (apply_fun r11s x) (minus_SNo one_third)).
															        { exact (Rle_add_SNo_1 one_third (apply_fun r11s x) (minus_SNo one_third)
															                               H13R Hr11sRx Hm13R HloI3). }
															        claim H13S: SNo one_third.
															        { exact (real_SNo one_third H13R). }
															        claim H0le: Rle 0 (add_SNo (apply_fun r11s x) (minus_SNo one_third)).
															        { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
															          exact H0le_tmp. }
															        claim Hm23le0: Rle (minus_SNo two_thirds) 0.
															        { exact Rle_minus_two_thirds_0. }
															        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r11s x) (minus_SNo one_third)).
															        { exact (Rle_tra (minus_SNo two_thirds) 0
															                         (add_SNo (apply_fun r11s x) (minus_SNo one_third))
															                         Hm23le0 H0le). }
															        claim Hup_tmp: Rle (add_SNo (apply_fun r11s x) (minus_SNo one_third))
															                         (add_SNo 1 (minus_SNo one_third)).
															        { exact (Rle_add_SNo_1 (apply_fun r11s x) 1 (minus_SNo one_third)
															                               Hr11sRx real_1 Hm13R HhiI3). }
															        claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
															        { rewrite <- two_thirds_eq_1_minus_one_third at 1.
															          exact (Rle_refl two_thirds H23R). }
															        claim Hup: Rle (add_SNo (apply_fun r11s x) (minus_SNo one_third)) two_thirds.
															        { exact (Rle_tra (add_SNo (apply_fun r11s x) (minus_SNo one_third))
															                         (add_SNo 1 (minus_SNo one_third))
															                         two_thirds
															                         Hup_tmp Hup1). }
															        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
															                                       (add_SNo (apply_fun r11s x) (minus_SNo one_third))
															                                       Hm23R H23R Hr12xR Hlow Hup).
															      + assume HxnotC12: ~(x :e C12).
															        claim HxX: x :e X.
															        { exact (HAsubX x HxA). }
															        claim HnotI1: ~(apply_fun r11s x :e I1).
															        { assume Hr11sI1': apply_fun r11s x :e I1.
															          claim Hr11sI1I: apply_fun r11s x :e I1 :/\: I.
															          { exact (binintersectI I1 I (apply_fun r11s x) Hr11sI1' Hr11sIx). }
															          claim HxB12': x :e B12.
															          { exact (SepI A (fun x0:set => apply_fun r11s x0 :e I1 :/\: I) x HxA Hr11sI1I). }
															          apply FalseE.
															          exact (HxnotB12 HxB12'). }
															        claim HnotI3: ~(apply_fun r11s x :e I3).
															        { assume Hr11sI3': apply_fun r11s x :e I3.
															          claim Hr11sI3I: apply_fun r11s x :e I3 :/\: I.
															          { exact (binintersectI I3 I (apply_fun r11s x) Hr11sI3' Hr11sIx). }
															          claim HxC12': x :e C12.
															          { exact (SepI A (fun x0:set => apply_fun r11s x0 :e I3 :/\: I) x HxA Hr11sI3I). }
															          apply FalseE.
															          exact (HxnotC12 HxC12'). }
															        claim Hr11sRx: apply_fun r11s x :e R.
															        { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun r11s x) Hr11sIx). }
															        claim Hm1R: minus_SNo 1 :e R.
															        { exact (real_minus_SNo 1 real_1). }
															        claim H13R: one_third :e R.
															        { exact one_third_in_R. }
															        claim Hm13R: minus_SNo one_third :e R.
															        { exact (real_minus_SNo one_third H13R). }
															        claim Hr11s_boundsI: Rle (minus_SNo 1) (apply_fun r11s x) /\ Rle (apply_fun r11s x) 1.
															        { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r11s x) Hm1R real_1 Hr11sIx). }
															        claim Hnlt_fx_m1: ~(Rlt (apply_fun r11s x) (minus_SNo 1)).
															        { exact (RleE_nlt (minus_SNo 1) (apply_fun r11s x)
															                          (andEL (Rle (minus_SNo 1) (apply_fun r11s x)) (Rle (apply_fun r11s x) 1) Hr11s_boundsI)). }
															        claim Hnlt_1_fx: ~(Rlt 1 (apply_fun r11s x)).
															        { exact (RleE_nlt (apply_fun r11s x) 1
															                          (andER (Rle (minus_SNo 1) (apply_fun r11s x)) (Rle (apply_fun r11s x) 1) Hr11s_boundsI)). }
															        claim HnotI1_cases: Rlt (apply_fun r11s x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun r11s x).
															        { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun r11s x)
															                                              Hm1R Hm13R Hr11sRx HnotI1). }
															        claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun r11s x).
															        { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun r11s x))).
															          - assume Hbad: Rlt (apply_fun r11s x) (minus_SNo 1).
															            apply FalseE.
															            exact (Hnlt_fx_m1 Hbad).
															          - assume Hok: Rlt (minus_SNo one_third) (apply_fun r11s x).
															            exact Hok. }
															        claim Hnot_fx_lt_m13: ~(Rlt (apply_fun r11s x) (minus_SNo one_third)).
															        { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun r11s x) Hm13lt_fx). }
															        claim HnotI3_cases: Rlt (apply_fun r11s x) one_third \/ Rlt 1 (apply_fun r11s x).
															        { exact (closed_interval_not_mem_cases one_third 1 (apply_fun r11s x)
															                                              H13R real_1 Hr11sRx HnotI3). }
															        claim Hfx_lt_13: Rlt (apply_fun r11s x) one_third.
															        { apply (HnotI3_cases (Rlt (apply_fun r11s x) one_third)).
															          - assume Hok: Rlt (apply_fun r11s x) one_third.
															            exact Hok.
															          - assume Hbad: Rlt 1 (apply_fun r11s x).
															            apply FalseE.
															            exact (Hnlt_1_fx Hbad). }
															        claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun r11s x)).
															        { exact (not_Rlt_sym (apply_fun r11s x) one_third Hfx_lt_13). }
															        claim Hr11sI0: apply_fun r11s x :e I0.
															        { claim HI0_def: I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
															          { reflexivity. }
															          claim HxSep: apply_fun r11s x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
															          { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
															                        (apply_fun r11s x) Hr11sRx (andI (~(Rlt (apply_fun r11s x) (minus_SNo one_third)))
															                                                        (~(Rlt one_third (apply_fun r11s x)))
															                                                        Hnot_fx_lt_m13
															                                                        Hnot_13_lt_fx)). }
															          rewrite HI0_def.
															          exact HxSep. }
															        claim Hu12funI0: function_on u12 X I0.
															        { exact (continuous_map_function_on X Tx I0 T0 u12 Hu12contI0). }
															        claim Hu12xI0: apply_fun u12 x :e I0.
															        { exact (Hu12funI0 x HxX). }
															        claim Hu12xR: apply_fun u12 x :e R.
															        { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun u12 x) Hu12xI0). }
															        claim Hm_u12x_R: minus_SNo (apply_fun u12 x) :e R.
															        { exact (real_minus_SNo (apply_fun u12 x) Hu12xR). }
															        rewrite (Hr12_apply x HxA).
															        claim Hr12xR: add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)) :e R.
															        { exact (real_add_SNo (apply_fun r11s x)
															                              (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r11s x) Hr11sI0)
															                              (minus_SNo (apply_fun u12 x)) Hm_u12x_R). }
															        claim H23R: two_thirds :e R.
															        { exact two_thirds_in_R. }
															        claim Hm23R: minus_SNo two_thirds :e R.
															        { exact (real_minus_SNo two_thirds H23R). }
															        claim Hr11s_bounds0: Rle (minus_SNo one_third) (apply_fun r11s x) /\ Rle (apply_fun r11s x) one_third.
															        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun r11s x) Hm13R H13R Hr11sI0). }
															        claim Hu12_bounds0: Rle (minus_SNo one_third) (apply_fun u12 x) /\ Rle (apply_fun u12 x) one_third.
															        { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun u12 x) Hm13R H13R Hu12xI0). }
															        claim Hr11s_le_13: Rle (apply_fun r11s x) one_third.
															        { exact (andER
															            (Rle (minus_SNo one_third) (apply_fun r11s x))
															            (Rle (apply_fun r11s x) one_third)
															            Hr11s_bounds0). }
															        claim Hr11s_ge_m13: Rle (minus_SNo one_third) (apply_fun r11s x).
															        { exact (andEL
															            (Rle (minus_SNo one_third) (apply_fun r11s x))
															            (Rle (apply_fun r11s x) one_third)
															            Hr11s_bounds0). }
															        claim Hu12_le_13: Rle (apply_fun u12 x) one_third.
															        { exact (andER
															            (Rle (minus_SNo one_third) (apply_fun u12 x))
															            (Rle (apply_fun u12 x) one_third)
															            Hu12_bounds0). }
															        claim Hu12_ge_m13: Rle (minus_SNo one_third) (apply_fun u12 x).
															        { exact (andEL
															            (Rle (minus_SNo one_third) (apply_fun u12 x))
															            (Rle (apply_fun u12 x) one_third)
															            Hu12_bounds0). }
															        claim Hm13_le_mu12: Rle (minus_SNo one_third) (minus_SNo (apply_fun u12 x)).
															        { exact (Rle_minus_contra (apply_fun u12 x) one_third Hu12_le_13). }
															        claim Hmu12_le_13: Rle (minus_SNo (apply_fun u12 x)) one_third.
															        { claim Htmp: Rle (minus_SNo (apply_fun u12 x)) (minus_SNo (minus_SNo one_third)).
															          { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun u12 x) Hu12_ge_m13). }
															          rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
															          exact Htmp. }
															        claim Hlow1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                        (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u12 x))).
															        { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun u12 x))
															                               Hm13R Hm13R Hm_u12x_R Hm13_le_mu12). }
															        claim Hlow2: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u12 x)))
															                        (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x))).
															        { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r11s x) (minus_SNo (apply_fun u12 x))
															                               Hm13R
															                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r11s x) Hr11sI0)
															                               Hm_u12x_R Hr11s_ge_m13). }
															        claim Hlow_tmp: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                        (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x))).
															        { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                         (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun u12 x)))
															                         (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)))
															                         Hlow1 Hlow2). }
															        claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x))).
															        { rewrite minus_two_thirds_eq at 1.
															          exact Hlow_tmp. }
															        claim Hup1: Rle (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)))
															                      (add_SNo (apply_fun r11s x) one_third).
															        { exact (Rle_add_SNo_2 (apply_fun r11s x) (minus_SNo (apply_fun u12 x)) one_third
															                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r11s x) Hr11sI0)
															                               Hm_u12x_R H13R Hmu12_le_13). }
															        claim Hup2: Rle (add_SNo (apply_fun r11s x) one_third)
															                      (add_SNo one_third one_third).
															        { exact (Rle_add_SNo_1 (apply_fun r11s x) one_third one_third
															                               (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun r11s x) Hr11sI0)
															                               H13R H13R Hr11s_le_13). }
															        claim Hup_tmp: Rle (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)))
															                         (add_SNo one_third one_third).
															        { exact (Rle_tra (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)))
															                         (add_SNo (apply_fun r11s x) one_third)
															                         (add_SNo one_third one_third)
															                         Hup1 Hup2). }
															        claim Hdef23: two_thirds = add_SNo one_third one_third.
															        { reflexivity. }
															        claim Hup: Rle (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x))) two_thirds.
															        { rewrite Hdef23 at 1.
															          exact Hup_tmp. }
															        exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
															                                       (add_SNo (apply_fun r11s x) (minus_SNo (apply_fun u12 x)))
															                                       Hm23R H23R Hr12xR Hlow Hup). }
															  set r12s := compose_fun A r12 (div_const_fun den).
															  claim Hr12s_cont: continuous_map A Ta I Ti r12s.
															  { (** structured: prove continuity into R, then restrict range to I **)
															    claim Hdivcont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
															    { exact (div_const_fun_continuous_pos den H23R H23pos). }
															    claim Hr12s_contR: continuous_map A Ta R R_standard_topology r12s.
															    { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
															             r12 (div_const_fun den) Hr12_cont Hdivcont). }
															    claim Hr12s_I: forall x:set, x :e A -> apply_fun r12s x :e I.
															    { let x. assume HxA: x :e A.
															      claim Hr12xI2: apply_fun r12 x :e I2.
															      { exact (Hr12_range x HxA). }
															      claim Hm1R: (minus_SNo 1) :e R.
															      { exact (real_minus_SNo 1 real_1). }
															      claim HmdenR: (minus_SNo den) :e R.
															      { exact (real_minus_SNo den H23R). }
															      claim Hr12xR: apply_fun r12 x :e R.
															      { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun r12 x) Hr12xI2). }
															      claim Hr12xS: SNo (apply_fun r12 x).
															      { exact (real_SNo (apply_fun r12 x) Hr12xR). }
															      claim Hbounds: Rle (minus_SNo den) (apply_fun r12 x) /\ Rle (apply_fun r12 x) den.
															      { exact (closed_interval_bounds (minus_SNo den) den (apply_fun r12 x) HmdenR H23R Hr12xI2). }
															      claim Hlo: Rle (minus_SNo den) (apply_fun r12 x).
															      { exact (andEL (Rle (minus_SNo den) (apply_fun r12 x))
															                     (Rle (apply_fun r12 x) den)
															                     Hbounds). }
															      claim Hhi: Rle (apply_fun r12 x) den.
															      { exact (andER (Rle (minus_SNo den) (apply_fun r12 x))
															                     (Rle (apply_fun r12 x) den)
															                     Hbounds). }
															      claim Hnlt_hi: ~(Rlt den (apply_fun r12 x)).
															      { exact (RleE_nlt (apply_fun r12 x) den Hhi). }
															      claim Hnlt_lo: ~(Rlt (apply_fun r12 x) (minus_SNo den)).
															      { exact (RleE_nlt (minus_SNo den) (apply_fun r12 x) Hlo). }
															      claim HyEq: apply_fun r12s x = div_SNo (apply_fun r12 x) den.
															      { rewrite (compose_fun_apply A r12 (div_const_fun den) x HxA).
															        rewrite (div_const_fun_apply den (apply_fun r12 x) H23R Hr12xR).
															        reflexivity. }
															      claim HyR: apply_fun r12s x :e R.
															      { rewrite HyEq.
															        exact (real_div_SNo (apply_fun r12 x) Hr12xR den H23R). }
															      claim HyS: SNo (apply_fun r12s x).
															      { exact (real_SNo (apply_fun r12s x) HyR). }
															      claim Hy_le_1: Rle (apply_fun r12s x) 1.
															      { apply (RleI (apply_fun r12s x) 1 HyR real_1).
															        prove ~(Rlt 1 (apply_fun r12s x)).
															        assume H1lt: Rlt 1 (apply_fun r12s x).
															        claim H1lty: 1 < apply_fun r12s x.
															        { exact (RltE_lt 1 (apply_fun r12s x) H1lt). }
															        claim HmulLt: mul_SNo 1 den < mul_SNo (apply_fun r12s x) den.
															        { exact (pos_mul_SNo_Lt' 1 (apply_fun r12s x) den SNo_1 HyS H23S H23pos H1lty). }
															        claim HmulLt': den < mul_SNo (apply_fun r12s x) den.
															        { rewrite <- (mul_SNo_oneL den H23S) at 1.
															          exact HmulLt. }
															        claim HmulEq: mul_SNo (apply_fun r12s x) den = apply_fun r12 x.
															        { rewrite HyEq at 1.
															          exact (mul_div_SNo_invL (apply_fun r12 x) den Hr12xS H23S H23ne0). }
															        claim Hden_lt_r12x: den < apply_fun r12 x.
															        { rewrite <- HmulEq.
															          exact HmulLt'. }
															        claim Hbad: Rlt den (apply_fun r12 x).
															        { exact (RltI den (apply_fun r12 x) H23R Hr12xR Hden_lt_r12x). }
															        exact (Hnlt_hi Hbad). }
															      claim Hm1_le_y: Rle (minus_SNo 1) (apply_fun r12s x).
															      { apply (RleI (minus_SNo 1) (apply_fun r12s x) Hm1R HyR).
															        prove ~(Rlt (apply_fun r12s x) (minus_SNo 1)).
															        assume Hylt: Rlt (apply_fun r12s x) (minus_SNo 1).
															        claim Hylts: apply_fun r12s x < minus_SNo 1.
															        { exact (RltE_lt (apply_fun r12s x) (minus_SNo 1) Hylt). }
															        claim HmulLt: mul_SNo (apply_fun r12s x) den < mul_SNo (minus_SNo 1) den.
															        { exact (pos_mul_SNo_Lt' (apply_fun r12s x) (minus_SNo 1) den HyS
															                                 (SNo_minus_SNo 1 SNo_1) H23S H23pos Hylts). }
															        claim HmulEq: mul_SNo (apply_fun r12s x) den = apply_fun r12 x.
															        { rewrite HyEq at 1.
															          exact (mul_div_SNo_invL (apply_fun r12 x) den Hr12xS H23S H23ne0). }
															        claim HrhsEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
															        { rewrite (mul_SNo_minus_distrL 1 den SNo_1 H23S) at 1.
															          rewrite (mul_SNo_oneL den H23S) at 1.
															          reflexivity. }
															        claim Hr12x_lt_mden: apply_fun r12 x < minus_SNo den.
															        { rewrite <- HmulEq.
															          rewrite <- HrhsEq.
															          exact HmulLt. }
															        claim Hbad: Rlt (apply_fun r12 x) (minus_SNo den).
															        { exact (RltI (apply_fun r12 x) (minus_SNo den) Hr12xR HmdenR Hr12x_lt_mden). }
															        exact (Hnlt_lo Hbad). }
															      exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun r12s x)
															                                     Hm1R real_1 HyR Hm1_le_y Hy_le_1). }
															    exact (continuous_map_range_restrict A Ta R R_standard_topology r12s I
															             Hr12s_contR HIcR Hr12s_I). }

														  (** pending: continue the iteration further and prove uniform convergence **)
														  claim Hexfn: exists fn:set,
														    function_on fn omega (function_space X R) /\
														    (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)) /\
														    (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I) /\
														    (forall x:set, x :e A ->
														      converges_to R (metric_topology R R_bounded_metric)
														        (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
														        (apply_fun f x)) /\
														    uniform_cauchy_metric X R R_bounded_metric fn.
														  { (** TeX Step II (in progress): define a full correction sequence by nat_primrec and prove it has the needed properties. **)
														    (** We keep the already-built finite scaffold above, but the infinite sequence is defined independently. **)
															    set I0 := closed_interval (minus_SNo one_third) one_third.
															    set T0 := closed_interval_topology (minus_SNo one_third) one_third.
															    set u_of := (fun r:set =>
															      Eps_i (fun u:set =>
															        continuous_map X Tx I0 T0 u /\
															        (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															          apply_fun u x = minus_SNo one_third) /\
															        (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															          apply_fun u x = one_third))).
															    (** helper: Step I witness extracted via Eps_i **)
															    claim Hu_of_prop: forall r:set, continuous_map A Ta I Ti r ->
															      continuous_map X Tx I0 T0 (u_of r) /\
															      (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															        apply_fun (u_of r) x = minus_SNo one_third) /\
															      (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															        apply_fun (u_of r) x = one_third).
															    { let r. assume Hr: continuous_map A Ta I Ti r.
															      set P := (fun u:set =>
															        continuous_map X Tx I0 T0 u /\
															        (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															          apply_fun u x = minus_SNo one_third) /\
															        (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															          apply_fun u x = one_third)).
															      claim Hexu: exists u:set, P u.
															      { exact (Tietze_stepI_g_exists X Tx A r Hnorm HA Hr). }
															      apply Hexu.
															      let u. assume Hu.
															      claim HP: P (Eps_i P).
															      { exact (Eps_i_ax P u Hu). }
															      claim Hu_eq: u_of r = Eps_i P.
															      { reflexivity. }
															      rewrite Hu_eq.
															      exact HP. }
															    (** base stage: graphify g0 so that it lies in function_space X R **)
															    set g0g := graph X (fun x:set => apply_fun g0 x).
															    set BaseState := (g0g, (f1s, den)).
															    set StepState := (fun n st:set =>
															      (compose_fun X
														         (pair_map X
														           (st 0)
														           (compose_fun X
														             (u_of ((st 1) 0))
														             (mul_const_fun ((st 1) 1))))
														         add_fun_R,
														       (compose_fun A
														          (compose_fun A
														            (pair_map A
														              ((st 1) 0)
														              (compose_fun A (u_of ((st 1) 0)) neg_fun))
														            add_fun_R)
														          (div_const_fun den),
														        mul_SNo ((st 1) 1) den))).
															    set State := (fun n:set => nat_primrec BaseState StepState n).
															    set fn := graph omega (fun n:set => (State n) 0).
															    witness fn.
															    (** helper: scalar component stays positive **)
															    claim HInv_cpos: forall n:set, n :e omega -> ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
															    { claim HInv_nat: forall n:set, nat_p n -> ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
															      { apply nat_ind.
															        - prove ((State 0) 1) 1 :e R /\ 0 < ((State 0) 1) 1.
															          claim H0: State 0 = BaseState.
															          { exact (nat_primrec_0 BaseState StepState). }
															          rewrite H0.
															          claim HBase: BaseState = (g0g, (f1s, den)).
															          { reflexivity. }
															          rewrite HBase.
															          claim HtEq: ((g0g, (f1s, den)) 1) 1 = den.
															          { rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
															            rewrite (tuple_2_1_eq f1s den) at 1.
															            reflexivity. }
															          apply andI.
															          + rewrite HtEq.
															            exact HdenR.
															          + rewrite HtEq.
															            exact HdenPos.
															        - let n. assume HnNat: nat_p n.
															          assume IH: ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
															          prove ((State (ordsucc n)) 1) 1 :e R /\ 0 < ((State (ordsucc n)) 1) 1.
															          claim HS: State (ordsucc n) = StepState n (State n).
															          { exact (nat_primrec_S BaseState StepState n HnNat). }
															          rewrite HS.
															          set st := State n.
															          set g := st 0.
															          set rpack := st 1.
															          set r := rpack 0.
															          set c := rpack 1.
															          set gNew := compose_fun X
															            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															            add_fun_R.
															          set rNew := compose_fun A
															            (compose_fun A
															              (pair_map A r (compose_fun A (u_of r) neg_fun))
															              add_fun_R)
															            (div_const_fun den).
															          set cNew := mul_SNo c den.
															          claim Hdef: StepState n st = (gNew, (rNew, cNew)).
															          { reflexivity. }
															          claim HtEq: ((StepState n st) 1) 1 = cNew.
															          { claim Hinner: (StepState n st) 1 = (rNew, cNew).
															            { rewrite Hdef.
															              exact (tuple_2_1_eq gNew (rNew, cNew)). }
															            rewrite Hinner.
															            exact (tuple_2_1_eq rNew cNew). }
															          claim Hc_eq: c = ((State n) 1) 1.
															          { reflexivity. }
															          claim HcR0: ((State n) 1) 1 :e R.
															          { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) IH). }
															          claim Hcpos0: 0 < ((State n) 1) 1.
															          { exact (andER (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) IH). }
															          claim HcR: c :e R.
															          { rewrite Hc_eq. exact HcR0. }
															          claim Hcpos: 0 < c.
															          { rewrite Hc_eq. exact Hcpos0. }
															          claim HcS: SNo c.
															          { exact (real_SNo c HcR). }
															          claim HdenS: SNo den.
															          { exact (real_SNo den HdenR). }
															          claim HcNewR: cNew :e R.
															          { exact (real_mul_SNo c HcR den HdenR). }
															          claim HcNewPos: 0 < cNew.
															          { exact (mul_SNo_pos_pos c den HcS HdenS Hcpos HdenPos). }
															          apply andI.
															          + rewrite HtEq.
															            exact HcNewR.
															          + rewrite HtEq.
															            exact HcNewPos. }
																      let n. assume HnO: n :e omega.
																      exact (HInv_nat n (omega_nat_p n HnO)). }
																    (** helper: scalar component is always strictly below 1 **)
																    claim HInv_c_lt1: forall n:set, n :e omega -> ((State n) 1) 1 < 1.
																    { claim HInv_nat: forall n:set, nat_p n -> ((State n) 1) 1 < 1.
																      { apply nat_ind.
																        - prove ((State 0) 1) 1 < 1.
																          claim H0: State 0 = BaseState.
																          { exact (nat_primrec_0 BaseState StepState). }
																          rewrite H0.
																          claim HBase: BaseState = (g0g, (f1s, den)).
																          { reflexivity. }
																          rewrite HBase.
																          claim HtEq: ((g0g, (f1s, den)) 1) 1 = den.
																          { rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
																            rewrite (tuple_2_1_eq f1s den) at 1.
																            reflexivity. }
																          rewrite HtEq.
																          claim HdenDef: den = two_thirds.
																          { reflexivity. }
																          rewrite HdenDef.
																          exact (RltE_lt two_thirds 1 Rlt_two_thirds_1).
																        - let n. assume HnNat: nat_p n.
																          assume IH: ((State n) 1) 1 < 1.
																          prove ((State (ordsucc n)) 1) 1 < 1.
																          claim HS: State (ordsucc n) = StepState n (State n).
																          { exact (nat_primrec_S BaseState StepState n HnNat). }
																          rewrite HS.
																          set st := State n.
																          set g := st 0.
																          set rpack := st 1.
																          set r := rpack 0.
																          set c := rpack 1.
																          set gNew := compose_fun X
																            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
																            add_fun_R.
																          set rNew := compose_fun A
																            (compose_fun A
																              (pair_map A r (compose_fun A (u_of r) neg_fun))
																              add_fun_R)
																            (div_const_fun den).
																          set cNew := mul_SNo c den.
																          claim Hdef: StepState n st = (gNew, (rNew, cNew)).
																          { reflexivity. }
																          claim HtEq: ((StepState n st) 1) 1 = cNew.
																          { claim Hinner: (StepState n st) 1 = (rNew, cNew).
																            { rewrite Hdef.
																              exact (tuple_2_1_eq gNew (rNew, cNew)). }
																            rewrite Hinner.
																            exact (tuple_2_1_eq rNew cNew). }
																          rewrite HtEq.
																          claim HnO: n :e omega.
																          { exact (nat_p_omega n HnNat). }
																          claim Hcpack: ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
																          { exact (HInv_cpos n HnO). }
																          claim HcR: ((State n) 1) 1 :e R.
																          { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) Hcpack). }
																          claim Hcpos: 0 < ((State n) 1) 1.
																          { exact (andER (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) Hcpack). }
																          claim HcS: SNo (((State n) 1) 1).
																          { exact (real_SNo (((State n) 1) 1) HcR). }
																          claim HdenDef: den = two_thirds.
																          { reflexivity. }
																          claim HdenLt1: den < 1.
																          { rewrite HdenDef.
																            exact (RltE_lt two_thirds 1 Rlt_two_thirds_1). }
																          claim HdenS: SNo den.
																          { exact (real_SNo den HdenR). }
																          claim HmulLt: mul_SNo den (((State n) 1) 1) < ((State n) 1) 1.
																          { exact (mul_SNo_Lt1_pos_Lt den (((State n) 1) 1) HdenS HcS HdenLt1 Hcpos). }
																          claim HmulEq: mul_SNo den (((State n) 1) 1) = mul_SNo (((State n) 1) 1) den.
																          { exact (mul_SNo_com den (((State n) 1) 1) HdenS HcS). }
																          claim HcNewLt: cNew < ((State n) 1) 1.
																          { claim HcEq: c = ((State n) 1) 1.
																            { reflexivity. }
																            rewrite HcEq at 1.
																            rewrite <- HmulEq at 1.
																            exact HmulLt. }
																          claim HcNewR: cNew :e R.
																          { claim HcEq: c = ((State n) 1) 1.
																            { reflexivity. }
																            rewrite HcEq.
																            exact (real_mul_SNo (((State n) 1) 1) HcR den HdenR). }
																          claim HcNewS: SNo cNew.
																          { exact (real_SNo cNew HcNewR). }
															          exact (SNoLt_tra cNew (((State n) 1) 1) 1
															            HcNewS
															            HcS
															            SNo_1
															            HcNewLt
															            IH). }
															      let n. assume HnO: n :e omega.
															      exact (HInv_nat n (omega_nat_p n HnO)). }
																    (** helper: residual component stays a continuous I-valued map on A **)
																    claim HInv_r_contI: forall n:set, n :e omega -> continuous_map A Ta I Ti (((State n) 1) 0).
															    { claim HInv_nat: forall n:set, nat_p n -> continuous_map A Ta I Ti (((State n) 1) 0).
															      { apply nat_ind.
															        - prove continuous_map A Ta I Ti (((State 0) 1) 0).
															          claim H0: State 0 = BaseState.
															          { exact (nat_primrec_0 BaseState StepState). }
															          rewrite H0.
															          claim HBase: BaseState = (g0g, (f1s, den)).
															          { reflexivity. }
															          rewrite HBase.
															          claim Hr0eq: (((g0g, (f1s, den)) 1) 0) = f1s.
															          { rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
															            rewrite (tuple_2_0_eq f1s den) at 1.
															            reflexivity. }
															          rewrite Hr0eq.
															          exact Hf1s_cont.
															        - let n. assume HnNat: nat_p n.
															          assume IH: continuous_map A Ta I Ti (((State n) 1) 0).
															          prove continuous_map A Ta I Ti (((State (ordsucc n)) 1) 0).
															          claim HS: State (ordsucc n) = StepState n (State n).
															          { exact (nat_primrec_S BaseState StepState n HnNat). }
															          rewrite HS.
															          set st := State n.
															          set g := st 0.
															          set rpack := st 1.
															          set r := rpack 0.
															          set c := rpack 1.
															          set gNew := compose_fun X
															            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															            add_fun_R.
															          set rNew := compose_fun A
															            (compose_fun A
															              (pair_map A r (compose_fun A (u_of r) neg_fun))
															              add_fun_R)
															            (div_const_fun den).
															          set cNew := mul_SNo c den.
															          claim Hdef: StepState n st = (gNew, (rNew, cNew)).
															          { reflexivity. }
															          claim HrEq: ((StepState n st) 1) 0 = rNew.
															          { claim Hinner: (StepState n st) 1 = (rNew, cNew).
															            { rewrite Hdef.
															              exact (tuple_2_1_eq gNew (rNew, cNew)). }
															            rewrite Hinner.
															            exact (tuple_2_0_eq rNew cNew). }
															          rewrite HrEq.
															          (** continuity of rNew into I, via range restriction **)
															          claim HIcR: I c= R.
															          { exact (closed_interval_sub_R (minus_SNo 1) 1). }
															          claim HTiEq: Ti = subspace_topology R R_standard_topology I.
															          { reflexivity. }
															          claim Hr_contI: continuous_map A Ta I Ti r.
															          { claim HrEq0: r = ((State n) 1) 0.
															            { reflexivity. }
															            rewrite HrEq0.
															            exact IH. }
															          claim Hr_contR: continuous_map A Ta R R_standard_topology r.
															          { exact (continuous_map_range_expand A Ta I Ti R R_standard_topology r
															                     Hr_contI HIcR R_standard_topology_is_topology_local HTiEq). }
															          claim Hu_pack:
															            continuous_map X Tx I0 T0 (u_of r) /\
															            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															              apply_fun (u_of r) x = minus_SNo one_third) /\
															            (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															              apply_fun (u_of r) x = one_third).
															          { exact (Hu_of_prop r Hr_contI). }
															          claim Hu_left:
															            continuous_map X Tx I0 T0 (u_of r) /\
															            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															              apply_fun (u_of r) x = minus_SNo one_third).
															          { exact (andEL
															            (continuous_map X Tx I0 T0 (u_of r) /\
															             (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															               apply_fun (u_of r) x = minus_SNo one_third))
															            (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															              apply_fun (u_of r) x = one_third)
															            Hu_pack). }
															          claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
															          { exact (andEL
															            (continuous_map X Tx I0 T0 (u_of r))
															            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															              apply_fun (u_of r) x = minus_SNo one_third)
															            Hu_left). }
															          claim HI0cR: I0 c= R.
															          { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
															          claim HT0eq: T0 = subspace_topology R R_standard_topology I0.
															          { reflexivity. }
															          claim Hu_contR: continuous_map X Tx R R_standard_topology (u_of r).
															          { exact (continuous_map_range_expand X Tx I0 T0 R R_standard_topology (u_of r)
															                     Hu_contI0 HI0cR R_standard_topology_is_topology_local HT0eq). }
															          claim HTx: topology_on X Tx.
															          { exact (normal_space_topology_on X Tx Hnorm). }
															          claim HAsubX: A c= X.
															          { exact (closed_in_subset X Tx A HA). }
															          claim HuA_contR: continuous_map A Ta R R_standard_topology (u_of r).
															          { exact (continuous_on_subspace X Tx R R_standard_topology (u_of r) A HTx HAsubX Hu_contR). }
															          claim Hneg_cont: continuous_map R R_standard_topology R R_standard_topology neg_fun.
															          { exact neg_fun_continuous. }
															          claim HnegA_contR: continuous_map A Ta R R_standard_topology (compose_fun A (u_of r) neg_fun).
															          { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology (u_of r) neg_fun
															                     HuA_contR Hneg_cont). }
															          claim Hpair_cont: continuous_map A Ta (setprod R R)
															            (product_topology R R_standard_topology R R_standard_topology)
															            (pair_map A r (compose_fun A (u_of r) neg_fun)).
															          { exact (maps_into_products_axiom A Ta R R_standard_topology R R_standard_topology r (compose_fun A (u_of r) neg_fun)
															                   Hr_contR HnegA_contR). }
															          claim Hadd_cont: continuous_map (setprod R R)
															            (product_topology R R_standard_topology R R_standard_topology)
															            R R_standard_topology add_fun_R.
															          { exact add_fun_R_continuous. }
															          claim Hh_cont: continuous_map A Ta R R_standard_topology
															            (compose_fun A (pair_map A r (compose_fun A (u_of r) neg_fun)) add_fun_R).
															          { exact (composition_continuous A Ta (setprod R R)
															                   (product_topology R R_standard_topology R R_standard_topology)
															                   R R_standard_topology
															                   (pair_map A r (compose_fun A (u_of r) neg_fun)) add_fun_R
															                   Hpair_cont Hadd_cont). }
															          claim Hdiv_cont: continuous_map R R_standard_topology R R_standard_topology (div_const_fun den).
															          { exact (div_const_fun_continuous_pos den HdenR HdenPos). }
															          claim HrNew_contR: continuous_map A Ta R R_standard_topology rNew.
															          { exact (composition_continuous A Ta R R_standard_topology R R_standard_topology
															                   (compose_fun A (pair_map A r (compose_fun A (u_of r) neg_fun)) add_fun_R)
															                   (div_const_fun den)
															                   Hh_cont Hdiv_cont). }
															          claim HrNew_img: forall x:set, x :e A -> apply_fun rNew x :e I.
															          { let x. assume HxA: x :e A.
															            set rNum := compose_fun A (pair_map A r (compose_fun A (u_of r) neg_fun)) add_fun_R.
															            set I2 := closed_interval (minus_SNo den) den.
															            claim HrNumI2: apply_fun rNum x :e I2.
															            { (** proof scaffold: rNum x = r x - u_of r x, then show bounds in [-den,den] **)
															              claim HxX: x :e X.
															              { exact (HAsubX x HxA). }
															              claim Hfun_r: function_on r A I.
															              { exact (continuous_map_function_on A Ta I Ti r Hr_contI). }
															              claim HrxI: apply_fun r x :e I.
															              { exact (Hfun_r x HxA). }
															              claim HrxR: apply_fun r x :e R.
															              { exact (HIcR (apply_fun r x) HrxI). }
															              claim Hfun_u: function_on (u_of r) X I0.
															              { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
															              claim HuxI0: apply_fun (u_of r) x :e I0.
															              { exact (Hfun_u x HxX). }
															              claim HuxR: apply_fun (u_of r) x :e R.
															              { exact (HI0cR (apply_fun (u_of r) x) HuxI0). }
															              claim HrNumEq:
															                apply_fun rNum x = add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)).
															              { exact (add_of_pair_map_neg_apply A r (u_of r) x HxA HrxR HuxR). }
															              apply (xm (Rlt (apply_fun r x) (minus_SNo one_third))).
															              - assume Hr_lt_left: Rlt (apply_fun r x) (minus_SNo one_third).
															                claim Hu_left_eq: forall y:set,
															                  y :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                  apply_fun (u_of r) y = minus_SNo one_third.
															                { exact (andER (continuous_map X Tx I0 T0 (u_of r))
															                               (forall y0:set, y0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                                 apply_fun (u_of r) y0 = minus_SNo one_third)
															                               Hu_left). }
															                claim Hm1R: (minus_SNo 1) :e R.
															                { exact (real_minus_SNo 1 real_1). }
															                claim Hm13R: (minus_SNo one_third) :e R.
															                { exact (real_minus_SNo one_third one_third_in_R). }
															                claim HrxB: Rle (minus_SNo 1) (apply_fun r x) /\ Rle (apply_fun r x) 1.
															                { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r x) Hm1R real_1 HrxI). }
															                claim Hlo: Rle (minus_SNo 1) (apply_fun r x).
															                { exact (andEL (Rle (minus_SNo 1) (apply_fun r x)) (Rle (apply_fun r x) 1) HrxB). }
															                claim Hhi: Rle (apply_fun r x) (minus_SNo one_third).
															                { exact (Rlt_implies_Rle (apply_fun r x) (minus_SNo one_third) Hr_lt_left). }
															                claim HrxIleft: apply_fun r x :e closed_interval (minus_SNo 1) (minus_SNo one_third).
															                { exact (closed_intervalI_of_Rle (minus_SNo 1) (minus_SNo one_third) (apply_fun r x)
															                         Hm1R Hm13R HrxR Hlo Hhi). }
															                claim HrxV: apply_fun r x :e (closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I.
															                { exact (binintersectI (closed_interval (minus_SNo 1) (minus_SNo one_third)) I (apply_fun r x) HrxIleft HrxI). }
															                claim HxPre: x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I).
															                { exact (SepI A (fun z:set => apply_fun r z :e ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I))
															                             x HxA HrxV). }
															                claim HuxEq: apply_fun (u_of r) x = minus_SNo one_third.
															                { exact (Hu_left_eq x HxPre). }
															                claim HrNumEqL: apply_fun rNum x = add_SNo (apply_fun r x) one_third.
															                { rewrite HrNumEq.
															                  rewrite HuxEq.
															                  rewrite (minus_SNo_minus_SNo_R one_third one_third_in_R) at 1.
															                  reflexivity. }
															                rewrite HrNumEqL.
															                claim H13R: one_third :e R.
															                { exact one_third_in_R. }
															                claim H13S: SNo one_third.
															                { exact (real_SNo one_third H13R). }
															                claim HdenDef: den = two_thirds.
															                { reflexivity. }
															                claim HmdenR: (minus_SNo den) :e R.
															                { exact (real_minus_SNo den HdenR). }
															                claim HsumR: add_SNo (apply_fun r x) one_third :e R.
															                { exact (real_add_SNo (apply_fun r x) HrxR one_third H13R). }
															                claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun r x) one_third).
															                { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun r x) one_third Hm1R HrxR H13R Hlo). }
															                claim Hlow: Rle (minus_SNo den) (add_SNo (apply_fun r x) one_third).
															                { rewrite HdenDef at 1.
															                  rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
															                  exact Hlow_tmp. }
															                claim Hup0_tmp: Rle (add_SNo (apply_fun r x) one_third) (add_SNo (minus_SNo one_third) one_third).
															                { exact (Rle_add_SNo_1 (apply_fun r x) (minus_SNo one_third) one_third HrxR Hm13R H13R Hhi). }
															                claim Hup0: Rle (add_SNo (apply_fun r x) one_third) 0.
															                { claim HtR: add_SNo (minus_SNo one_third) one_third :e R.
															                  { exact (real_add_SNo (minus_SNo one_third) Hm13R one_third H13R). }
															                  claim HtEq0: add_SNo (minus_SNo one_third) one_third = 0.
															                  { exact (add_SNo_minus_SNo_linv one_third H13S). }
															                  claim Ht0: Rle (add_SNo (minus_SNo one_third) one_third) 0.
															                  { rewrite HtEq0.
															                    exact (Rle_refl 0 real_0). }
															                  exact (Rle_tra (add_SNo (apply_fun r x) one_third)
															                                 (add_SNo (minus_SNo one_third) one_third)
															                                 0 Hup0_tmp Ht0). }
															                claim H0leDen: Rle 0 den.
															                { rewrite HdenDef at 1.
															                  exact Rle_0_two_thirds. }
															                claim Hup: Rle (add_SNo (apply_fun r x) one_third) den.
															                { exact (Rle_tra (add_SNo (apply_fun r x) one_third) 0 den Hup0 H0leDen). }
															                exact (closed_intervalI_of_Rle (minus_SNo den) den (add_SNo (apply_fun r x) one_third)
															                         HmdenR HdenR HsumR Hlow Hup).
															              - assume Hr_not_lt_left: ~(Rlt (apply_fun r x) (minus_SNo one_third)).
															                apply (xm (Rlt one_third (apply_fun r x))).
															                + assume Hr_lt_right: Rlt one_third (apply_fun r x).
															                  claim Hu_right_eq: forall y:set,
															                    y :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                    apply_fun (u_of r) y = one_third.
															                  { exact (andER
															                      (continuous_map X Tx I0 T0 (u_of r) /\
															                       (forall y0:set, y0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                         apply_fun (u_of r) y0 = minus_SNo one_third))
															                      (forall y0:set, y0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                        apply_fun (u_of r) y0 = one_third)
															                      Hu_pack). }
															                  claim HrxB: Rle (minus_SNo 1) (apply_fun r x) /\ Rle (apply_fun r x) 1.
															                  { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r x) (real_minus_SNo 1 real_1) real_1 HrxI). }
															                  claim Hhi: Rle (apply_fun r x) 1.
															                  { exact (andER (Rle (minus_SNo 1) (apply_fun r x)) (Rle (apply_fun r x) 1) HrxB). }
															                  claim Hlo: Rle one_third (apply_fun r x).
															                  { exact (Rlt_implies_Rle one_third (apply_fun r x) Hr_lt_right). }
															                  claim HrxIright: apply_fun r x :e closed_interval one_third 1.
															                  { exact (closed_intervalI_of_Rle one_third 1 (apply_fun r x)
															                           one_third_in_R real_1 HrxR Hlo Hhi). }
															                  claim HrxV: apply_fun r x :e (closed_interval one_third 1) :/\: I.
															                  { exact (binintersectI (closed_interval one_third 1) I (apply_fun r x) HrxIright HrxI). }
															                  claim HxPre: x :e preimage_of A r ((closed_interval one_third 1) :/\: I).
															                  { exact (SepI A (fun z:set => apply_fun r z :e ((closed_interval one_third 1) :/\: I))
															                               x HxA HrxV). }
															                  claim HuxEq: apply_fun (u_of r) x = one_third.
															                  { exact (Hu_right_eq x HxPre). }
															                  claim HrNumEqR: apply_fun rNum x = add_SNo (apply_fun r x) (minus_SNo one_third).
															                  { rewrite HrNumEq.
															                    rewrite HuxEq.
															                    reflexivity. }
															                  rewrite HrNumEqR.
															                  claim H13R: one_third :e R.
															                  { exact one_third_in_R. }
															                  claim H23R: two_thirds :e R.
															                  { exact two_thirds_in_R. }
															                  claim Hm23R: minus_SNo two_thirds :e R.
															                  { exact (real_minus_SNo two_thirds H23R). }
															                  claim Hm13R: minus_SNo one_third :e R.
															                  { exact (real_minus_SNo one_third H13R). }
															                  claim HrxB: Rle (minus_SNo 1) (apply_fun r x) /\ Rle (apply_fun r x) 1.
															                  { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun r x) (real_minus_SNo 1 real_1) real_1 HrxI). }
															                  claim Hrxle1: Rle (apply_fun r x) 1.
															                  { exact (andER (Rle (minus_SNo 1) (apply_fun r x)) (Rle (apply_fun r x) 1) HrxB). }
															                  claim HrNumR: add_SNo (apply_fun r x) (minus_SNo one_third) :e R.
															                  { exact (real_add_SNo (apply_fun r x) HrxR (minus_SNo one_third) Hm13R). }
															                  claim H0le_rNum_tmp: Rle (add_SNo one_third (minus_SNo one_third))
															                                         (add_SNo (apply_fun r x) (minus_SNo one_third)).
															                  { exact (Rle_add_SNo_1 one_third (apply_fun r x) (minus_SNo one_third) H13R HrxR Hm13R Hlo). }
															                  claim H13S: SNo one_third.
															                  { exact (real_SNo one_third H13R). }
															                  claim H0le_rNum: Rle 0 (add_SNo (apply_fun r x) (minus_SNo one_third)).
															                  { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
															                    exact H0le_rNum_tmp. }
															                  claim Hm23le0: Rle (minus_SNo two_thirds) 0.
															                  { exact Rle_minus_two_thirds_0. }
															                  claim HdenDef: den = two_thirds.
															                  { reflexivity. }
															                  claim Hlow0: Rle (minus_SNo two_thirds) (add_SNo (apply_fun r x) (minus_SNo one_third)).
															                  { exact (Rle_tra (minus_SNo two_thirds) 0 (add_SNo (apply_fun r x) (minus_SNo one_third)) Hm23le0 H0le_rNum). }
															                  claim Hlow: Rle (minus_SNo den) (add_SNo (apply_fun r x) (minus_SNo one_third)).
															                  { rewrite HdenDef at 1.
															                    exact Hlow0. }
															                  claim Hup_tmp: Rle (add_SNo (apply_fun r x) (minus_SNo one_third))
															                                       (add_SNo 1 (minus_SNo one_third)).
															                  { exact (Rle_add_SNo_1 (apply_fun r x) 1 (minus_SNo one_third) HrxR real_1 Hm13R Hrxle1). }
															                  claim Hup1: Rle (add_SNo 1 (minus_SNo one_third)) two_thirds.
															                  { rewrite <- two_thirds_eq_1_minus_one_third at 1.
															                    exact (Rle_refl two_thirds H23R). }
															                  claim Hup0: Rle (add_SNo (apply_fun r x) (minus_SNo one_third)) two_thirds.
															                  { exact (Rle_tra (add_SNo (apply_fun r x) (minus_SNo one_third))
															                                  (add_SNo 1 (minus_SNo one_third))
															                                  two_thirds
															                                  Hup_tmp Hup1). }
															                  claim Hup: Rle (add_SNo (apply_fun r x) (minus_SNo one_third)) den.
															                  { rewrite HdenDef at 1.
															                    exact Hup0. }
															                  claim HmdenR: minus_SNo den :e R.
															                  { exact (real_minus_SNo den HdenR). }
															                  exact (closed_intervalI_of_Rle (minus_SNo den) den
															                                                 (add_SNo (apply_fun r x) (minus_SNo one_third))
															                                                 HmdenR HdenR HrNumR Hlow Hup).
															                + assume Hr_not_lt_right: ~(Rlt one_third (apply_fun r x)).
															                  claim Hm13R: (minus_SNo one_third) :e R.
															                  { exact (real_minus_SNo one_third one_third_in_R). }
															                  claim Hm13_le_rx: Rle (minus_SNo one_third) (apply_fun r x).
															                  { apply (RleI (minus_SNo one_third) (apply_fun r x) Hm13R HrxR).
															                    prove ~(Rlt (apply_fun r x) (minus_SNo one_third)).
															                    exact Hr_not_lt_left. }
															                  claim Hrx_le_13: Rle (apply_fun r x) one_third.
															                  { apply (RleI (apply_fun r x) one_third HrxR one_third_in_R).
															                    prove ~(Rlt one_third (apply_fun r x)).
															                    exact Hr_not_lt_right. }
															                  claim HrxI0: apply_fun r x :e closed_interval (minus_SNo one_third) one_third.
															                  { exact (closed_intervalI_of_Rle (minus_SNo one_third) one_third (apply_fun r x)
															                           Hm13R one_third_in_R HrxR Hm13_le_rx Hrx_le_13). }
															                  rewrite HrNumEq.
															                  claim H13R: one_third :e R.
															                  { exact one_third_in_R. }
															                  claim H23R: two_thirds :e R.
															                  { exact two_thirds_in_R. }
															                  claim Hux_bounds: Rle (minus_SNo one_third) (apply_fun (u_of r) x) /\ Rle (apply_fun (u_of r) x) one_third.
															                  { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun (u_of r) x)
															                                                 Hm13R one_third_in_R HuxI0). }
															                  claim Hm13_le_ux: Rle (minus_SNo one_third) (apply_fun (u_of r) x).
															                  { exact (andEL (Rle (minus_SNo one_third) (apply_fun (u_of r) x))
															                                 (Rle (apply_fun (u_of r) x) one_third) Hux_bounds). }
															                  claim Hux_le_13: Rle (apply_fun (u_of r) x) one_third.
															                  { exact (andER (Rle (minus_SNo one_third) (apply_fun (u_of r) x))
															                                 (Rle (apply_fun (u_of r) x) one_third) Hux_bounds). }
															                  claim Hm13_le_negux: Rle (minus_SNo one_third) (minus_SNo (apply_fun (u_of r) x)).
															                  { exact (Rle_minus_contra (apply_fun (u_of r) x) one_third Hux_le_13). }
															                  claim Hnegux_le_13: Rle (minus_SNo (apply_fun (u_of r) x)) one_third.
															                  { claim Htmp: Rle (minus_SNo (apply_fun (u_of r) x)) (minus_SNo (minus_SNo one_third)).
															                    { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun (u_of r) x) Hm13_le_ux). }
															                    claim Hmid: Rle (minus_SNo (minus_SNo one_third)) one_third.
															                    { rewrite (minus_SNo_minus_SNo_R one_third one_third_in_R) at 1.
															                      exact (Rle_refl one_third one_third_in_R). }
															                    exact (Rle_tra (minus_SNo (apply_fun (u_of r) x))
															                                    (minus_SNo (minus_SNo one_third))
															                                    one_third
															                                    Htmp Hmid). }
															                  claim Hm13R2: minus_SNo one_third :e R.
															                  { exact Hm13R. }
															                  claim HneguxR: minus_SNo (apply_fun (u_of r) x) :e R.
															                  { exact (real_minus_SNo (apply_fun (u_of r) x) HuxR). }
															                  claim HrNumR: add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)) :e R.
															                  { exact (real_add_SNo (apply_fun r x) HrxR (minus_SNo (apply_fun (u_of r) x)) HneguxR). }
															                  claim Hlow0a: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                                    (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun (u_of r) x))).
															                  { exact (Rle_add_SNo_2 (minus_SNo one_third) (minus_SNo one_third) (minus_SNo (apply_fun (u_of r) x))
															                                         Hm13R2 Hm13R2 HneguxR Hm13_le_negux). }
															                  claim Hlow0b: Rle (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun (u_of r) x)))
															                                    (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))).
															                  { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))
															                                         Hm13R2 HrxR HneguxR Hm13_le_rx). }
															                  claim Hlow0: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                                   (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))).
															                  { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
															                                  (add_SNo (minus_SNo one_third) (minus_SNo (apply_fun (u_of r) x)))
															                                  (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)))
															                                  Hlow0a Hlow0b). }
															                  claim Hlow2: Rle (minus_SNo two_thirds)
															                                   (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))).
															                  { rewrite minus_two_thirds_eq at 1.
															                    exact Hlow0. }
															                  claim HdenDef: den = two_thirds.
															                  { reflexivity. }
															                  claim Hlow: Rle (minus_SNo den)
															                                  (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))).
															                  { rewrite HdenDef at 1.
															                    exact Hlow2. }
															                  claim Hup0a: Rle (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)))
															                                   (add_SNo (apply_fun r x) one_third).
															                  { exact (Rle_add_SNo_2 (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)) one_third
															                                         HrxR HneguxR H13R Hnegux_le_13). }
															                  claim Hup0b: Rle (add_SNo (apply_fun r x) one_third) (add_SNo one_third one_third).
															                  { exact (Rle_add_SNo_1 (apply_fun r x) one_third one_third HrxR H13R H13R Hrx_le_13). }
															                  claim Hup0c: Rle (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))) (add_SNo one_third one_third).
															                  { exact (Rle_tra (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)))
															                                  (add_SNo (apply_fun r x) one_third)
															                                  (add_SNo one_third one_third)
															                                  Hup0a Hup0b). }
															                  claim Htwo_def: two_thirds = add_SNo one_third one_third.
															                  { reflexivity. }
															                  claim Hup1: Rle (add_SNo one_third one_third) two_thirds.
															                  { rewrite <- Htwo_def at 1.
															                    exact (Rle_refl two_thirds H23R). }
															                  claim Hup2: Rle (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))) two_thirds.
															                  { exact (Rle_tra (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)))
															                                  (add_SNo one_third one_third)
															                                  two_thirds
															                                  Hup0c Hup1). }
															                  claim Hup: Rle (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x))) den.
															                  { rewrite HdenDef at 1.
															                    exact Hup2. }
															                  claim HmdenR: minus_SNo den :e R.
															                  { exact (real_minus_SNo den HdenR). }
															                  exact (closed_intervalI_of_Rle (minus_SNo den) den
															                                                 (add_SNo (apply_fun r x) (minus_SNo (apply_fun (u_of r) x)))
															                                                 HmdenR HdenR HrNumR Hlow Hup). }
															            claim HrNumR: apply_fun rNum x :e R.
															            { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun rNum x) HrNumI2). }
															            claim HrNewEq: apply_fun rNew x = div_SNo (apply_fun rNum x) den.
															            { exact (compose_div_const_fun_apply A rNum den x HxA HdenR HrNumR). }
															            rewrite HrNewEq.
															            exact (div_SNo_closed_interval_scale den (apply_fun rNum x) HdenR HdenPos HrNumI2). }
															          claim HrNew_contI': continuous_map A Ta I (subspace_topology R R_standard_topology I) rNew.
															          { exact (continuous_map_range_restrict A Ta R R_standard_topology rNew I HrNew_contR HIcR HrNew_img). }
															          rewrite HTiEq.
															          exact HrNew_contI'. }
															      let n. assume HnO: n :e omega.
															      exact (HInv_nat n (omega_nat_p n HnO)). }

															    (** Step II invariant on A: each g_n takes values in R **)
															    claim HInv_g_R_A: forall n:set, n :e omega -> forall x:set, x :e A ->
															      apply_fun ((State n) 0) x :e R.
															    { claim HInv_nat: forall n:set, nat_p n -> forall x:set, x :e A ->
															        apply_fun ((State n) 0) x :e R.
															      { apply nat_ind.
															        - let x. assume HxA: x :e A.
															          prove apply_fun ((State 0) 0) x :e R.
															          claim HxX: x :e X.
															          { exact (HAsubX x HxA). }
															          claim H0: State 0 = BaseState.
															          { exact (nat_primrec_0 BaseState StepState). }
															          rewrite H0.
															          claim HBase: BaseState = (g0g, (f1s, den)).
															          { reflexivity. }
															          rewrite HBase.
															          rewrite (tuple_2_0_eq g0g (f1s, den)).
															          rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX).
															          claim Hg0I0: apply_fun g0 x :e I0.
															          { exact (Hfung0 x HxX). }
															          exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0I0).
															        - let k. assume HkNat: nat_p k.
															          assume IH: forall x:set, x :e A -> apply_fun ((State k) 0) x :e R.
															          let x. assume HxA: x :e A.
															          prove apply_fun ((State (ordsucc k)) 0) x :e R.
															          claim HS: State (ordsucc k) = StepState k (State k).
															          { exact (nat_primrec_S BaseState StepState k HkNat). }
															          rewrite HS.
															          claim HkO: k :e omega.
															          { exact (nat_p_omega k HkNat). }
															          claim HxX: x :e X.
															          { exact (HAsubX x HxA). }
															          set st := State k.
															          set g := st 0.
															          set rpack := st 1.
															          set r := rpack 0.
															          set c := rpack 1.
															          set gNew := compose_fun X
															            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															            add_fun_R.
															          set rNew := compose_fun A
															            (compose_fun A
															              (pair_map A r (compose_fun A (u_of r) neg_fun))
															              add_fun_R)
															            (div_const_fun den).
															          set cNew := mul_SNo c den.
															          claim Hdef: StepState k st = (gNew, (rNew, cNew)).
															          { reflexivity. }
															          claim HgStep: (StepState k st) 0 = gNew.
															          { rewrite Hdef.
															            exact (tuple_2_0_eq gNew (rNew, cNew)). }
															          rewrite HgStep.
															          claim HgEq: g = (State k) 0.
															          { reflexivity. }
															          claim HgxR: apply_fun g x :e R.
															          { rewrite HgEq.
															            exact (IH x HxA). }
															          claim HrEq: r = ((State k) 1) 0.
															          { reflexivity. }
															          claim Hr_contI: continuous_map A Ta I Ti r.
															          { rewrite HrEq.
															            exact (HInv_r_contI k HkO). }
															          claim Hu_pack:
															            continuous_map X Tx I0 T0 (u_of r) /\
															            (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															              apply_fun (u_of r) x0 = minus_SNo one_third) /\
															            (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															              apply_fun (u_of r) x0 = one_third).
															          { exact (Hu_of_prop r Hr_contI). }
															          claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
															          { exact (andEL
															              (continuous_map X Tx I0 T0 (u_of r))
															              (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                apply_fun (u_of r) x0 = minus_SNo one_third)
															              (andEL
															                ((continuous_map X Tx I0 T0 (u_of r)) /\
															                 (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                   apply_fun (u_of r) x0 = minus_SNo one_third))
															                (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                  apply_fun (u_of r) x0 = one_third)
															                Hu_pack)). }
															          claim Hu_fun: function_on (u_of r) X I0.
															          { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
															          claim HuxI0: apply_fun (u_of r) x :e I0.
															          { exact (Hu_fun x HxX). }
															          claim HuxR: apply_fun (u_of r) x :e R.
															          { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun (u_of r) x) HuxI0). }
															          claim HcEq: c = ((State k) 1) 1.
															          { reflexivity. }
															          claim HcR: c :e R.
															          { rewrite HcEq.
															            exact (andEL
															              (((State k) 1) 1 :e R)
															              (0 < ((State k) 1) 1)
															              (HInv_cpos k HkO)). }
															          claim HcorrEq:
															            apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
															              mul_SNo (apply_fun (u_of r) x) c.
															          { claim Hcomp:
															              apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
															                apply_fun (mul_const_fun c) (apply_fun (u_of r) x).
															            { exact (compose_fun_apply X (u_of r) (mul_const_fun c) x HxX). }
															            rewrite Hcomp.
															            exact (mul_const_fun_apply c (apply_fun (u_of r) x) HcR HuxR). }
															          claim HcorrR: apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x :e R.
															          { rewrite HcorrEq.
															            exact (real_mul_SNo (apply_fun (u_of r) x) HuxR c HcR). }
															          claim HgNewEval:
															            apply_fun gNew x =
															              add_SNo (apply_fun g x)
															                (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x).
															          { exact (add_of_pair_map_apply X g (compose_fun X (u_of r) (mul_const_fun c)) x HxX HgxR HcorrR). }
															          rewrite HgNewEval.
															          exact (real_add_SNo (apply_fun g x) HgxR
															            (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x) HcorrR). }
															      let n. assume HnO: n :e omega.
															      exact (HInv_nat n (omega_nat_p n HnO)). }

															    (** Step II invariant on A: f(x) = g_n(x) + c_n times r_n(x) **)
															    claim HInv_residual_identity_A:
															      forall n:set, n :e omega -> forall x:set, x :e A ->
															        add_SNo (apply_fun ((State n) 0) x)
															          (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) =
															        apply_fun f x.
															    { claim HInv_nat: forall n:set, nat_p n -> forall x:set, x :e A ->
															        add_SNo (apply_fun ((State n) 0) x)
															          (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) =
															        apply_fun f x.
															      { apply nat_ind.
															        - let x. assume HxA: x :e A.
															          prove add_SNo (apply_fun ((State 0) 0) x)
															                  (mul_SNo (apply_fun (((State 0) 1) 0) x) (((State 0) 1) 1)) =
															                apply_fun f x.
															          claim HxX: x :e X.
															          { exact (HAsubX x HxA). }
															          claim H0: State 0 = BaseState.
															          { exact (nat_primrec_0 BaseState StepState). }
															          rewrite H0.
															          claim HBase: BaseState = (g0g, (f1s, den)).
															          { reflexivity. }
															          rewrite HBase.
															          rewrite (tuple_2_0_eq g0g (f1s, den)) at 1.
															          rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
															          rewrite (tuple_2_0_eq f1s den) at 1.
															          rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
															          rewrite (tuple_2_1_eq f1s den) at 1.
															          claim Hg0g_app: apply_fun g0g x = apply_fun g0 x.
															          { rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX).
															            reflexivity. }
															          rewrite Hg0g_app at 1.
															          claim Hf1s_app: apply_fun f1s x = div_SNo (apply_fun f1 x) den.
															          { exact (Hf1s_apply x HxA). }
															          rewrite Hf1s_app at 1.
															          claim Hf1xI2: apply_fun f1 x :e I2.
															          { exact (Hf1_range x HxA). }
															          claim Hf1xI2': apply_fun f1 x :e closed_interval (minus_SNo den) den.
															          { claim HI2def: I2 = closed_interval (minus_SNo den) den.
															            { reflexivity. }
															            rewrite HI2def.
															            exact Hf1xI2. }
															          claim Hf1xR: apply_fun f1 x :e R.
															          { exact (closed_interval_sub_R (minus_SNo den) den (apply_fun f1 x) Hf1xI2'). }
															          claim Hf1xS: SNo (apply_fun f1 x).
															          { exact (real_SNo (apply_fun f1 x) Hf1xR). }
															          claim HmulDiv: mul_SNo (div_SNo (apply_fun f1 x) den) den = apply_fun f1 x.
															          { exact (mul_div_SNo_invL (apply_fun f1 x) den Hf1xS H23S H23ne0). }
															          rewrite HmulDiv at 1.
															          rewrite (Hf1_apply x HxA) at 1.
															          claim HfxR: apply_fun f x :e R.
															          { exact (Hf_R x HxA). }
															          claim HfxS: SNo (apply_fun f x).
															          { exact (real_SNo (apply_fun f x) HfxR). }
															          claim Hg0I0: apply_fun g0 x :e I0.
															          { exact (Hfung0 x HxX). }
															          claim Hg0R: apply_fun g0 x :e R.
															          { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0I0). }
															          claim Hg0S: SNo (apply_fun g0 x).
															          { exact (real_SNo (apply_fun g0 x) Hg0R). }
															          rewrite (add_SNo_assoc (apply_fun g0 x) (apply_fun f x) (minus_SNo (apply_fun g0 x))
															            Hg0S HfxS (SNo_minus_SNo (apply_fun g0 x) Hg0S)) at 1.
															          rewrite (add_SNo_com (apply_fun g0 x) (apply_fun f x) Hg0S HfxS) at 1.
															          rewrite <- (add_SNo_assoc (apply_fun f x) (apply_fun g0 x) (minus_SNo (apply_fun g0 x))
															            HfxS Hg0S (SNo_minus_SNo (apply_fun g0 x) Hg0S)) at 1.
															          rewrite (add_SNo_minus_SNo_rinv (apply_fun g0 x) Hg0S) at 1.
															          rewrite (add_SNo_0R (apply_fun f x) HfxS) at 1.
															          reflexivity.
															        - let k. assume HkNat: nat_p k.
															          assume IH: forall x:set, x :e A ->
															            add_SNo (apply_fun ((State k) 0) x)
															              (mul_SNo (apply_fun (((State k) 1) 0) x) (((State k) 1) 1)) =
															            apply_fun f x.
															          let x. assume HxA: x :e A.
															          prove add_SNo (apply_fun ((State (ordsucc k)) 0) x)
															                  (mul_SNo (apply_fun (((State (ordsucc k)) 1) 0) x) (((State (ordsucc k)) 1) 1)) =
															                apply_fun f x.
															          claim HS: State (ordsucc k) = StepState k (State k).
															          { exact (nat_primrec_S BaseState StepState k HkNat). }
															          rewrite HS.
															          rewrite <- (IH x HxA).
															          claim HkO: k :e omega.
															          { exact (nat_p_omega k HkNat). }
															          claim HxX: x :e X.
															          { exact (HAsubX x HxA). }
															          set st := State k.
															          set g := st 0.
															          set rpack := st 1.
															          set r := rpack 0.
															          set c := rpack 1.
															          set gNew := compose_fun X
															            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															            add_fun_R.
															          set rNew := compose_fun A
															            (compose_fun A
															              (pair_map A r (compose_fun A (u_of r) neg_fun))
															              add_fun_R)
															            (div_const_fun den).
															          set cNew := mul_SNo c den.
															          claim Hdef: StepState k st = (gNew, (rNew, cNew)).
															          { reflexivity. }
															          claim HgStep: (StepState k st) 0 = gNew.
															          { rewrite Hdef.
															            exact (tuple_2_0_eq gNew (rNew, cNew)). }
															          claim HrpackStep: (StepState k st) 1 = (rNew, cNew).
															          { rewrite Hdef.
															            exact (tuple_2_1_eq gNew (rNew, cNew)). }
															          claim HrStep: ((StepState k st) 1) 0 = rNew.
															          { rewrite HrpackStep.
															            exact (tuple_2_0_eq rNew cNew). }
															          claim HcStep: ((StepState k st) 1) 1 = cNew.
															          { rewrite HrpackStep.
															            exact (tuple_2_1_eq rNew cNew). }
															          rewrite HgStep at 1.
															          rewrite HrStep at 1.
															          rewrite HcStep at 1.
															          set gx := apply_fun g x.
															          set rx := apply_fun r x.
															          set ux := apply_fun (u_of r) x.
															          claim HgxR: gx :e R.
															          { claim HgEq: g = (State k) 0.
															            { reflexivity. }
															            rewrite HgEq.
															            exact (HInv_g_R_A k HkO x HxA). }
															          claim HgxS: SNo gx.
															          { exact (real_SNo gx HgxR). }
															          claim HrEq: r = ((State k) 1) 0.
															          { reflexivity. }
															          claim Hr_contI: continuous_map A Ta I Ti r.
															          { rewrite HrEq.
															            exact (HInv_r_contI k HkO). }
															          claim Hr_fun: function_on r A I.
															          { exact (continuous_map_function_on A Ta I Ti r Hr_contI). }
															          claim HrxI: rx :e I.
															          { exact (Hr_fun x HxA). }
															          claim HrxR: rx :e R.
															          { exact (closed_interval_sub_R (minus_SNo 1) 1 rx HrxI). }
															          claim HrxS: SNo rx.
															          { exact (real_SNo rx HrxR). }
															          claim Hu_pack:
															            continuous_map X Tx I0 T0 (u_of r) /\
															            (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															              apply_fun (u_of r) x0 = minus_SNo one_third) /\
															            (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															              apply_fun (u_of r) x0 = one_third).
															          { exact (Hu_of_prop r Hr_contI). }
															          claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
															          { exact (andEL
															              (continuous_map X Tx I0 T0 (u_of r))
															              (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                apply_fun (u_of r) x0 = minus_SNo one_third)
															              (andEL
															                ((continuous_map X Tx I0 T0 (u_of r)) /\
															                 (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                   apply_fun (u_of r) x0 = minus_SNo one_third))
															                (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                  apply_fun (u_of r) x0 = one_third)
															                Hu_pack)). }
															          claim Hu_fun: function_on (u_of r) X I0.
															          { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
															          claim HuxI0: ux :e I0.
															          { exact (Hu_fun x HxX). }
															          claim HuxR: ux :e R.
															          { exact (closed_interval_sub_R (minus_SNo one_third) one_third ux HuxI0). }
															          claim HuxS: SNo ux.
															          { exact (real_SNo ux HuxR). }
															          claim HcEq: c = ((State k) 1) 1.
															          { reflexivity. }
															          claim HcR: c :e R.
															          { rewrite HcEq.
															            exact (andEL
															              (((State k) 1) 1 :e R)
															              (0 < ((State k) 1) 1)
															              (HInv_cpos k HkO)). }
															          claim HcS: SNo c.
															          { exact (real_SNo c HcR). }
															          claim HcorrEq:
															            apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x = mul_SNo ux c.
															          { claim Hcomp:
															              apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
															                apply_fun (mul_const_fun c) ux.
															            { exact (compose_fun_apply X (u_of r) (mul_const_fun c) x HxX). }
															            rewrite Hcomp.
															            exact (mul_const_fun_apply c ux HcR HuxR). }
															          claim HcorrR: apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x :e R.
															          { rewrite HcorrEq.
															            exact (real_mul_SNo ux HuxR c HcR). }
															          claim HgNewEval:
															            apply_fun gNew x =
															              add_SNo gx (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x).
															          { exact (add_of_pair_map_apply X g (compose_fun X (u_of r) (mul_const_fun c)) x HxX HgxR HcorrR). }
															          rewrite HgNewEval.
															          rewrite HcorrEq at 1.
															          set uxc := mul_SNo ux c.
															          claim HuxcR: uxc :e R.
															          { exact (real_mul_SNo ux HuxR c HcR). }
															          claim HuxcS: SNo uxc.
															          { exact (real_SNo uxc HuxcR). }
															          set rNum := compose_fun A (pair_map A r (compose_fun A (u_of r) neg_fun)) add_fun_R.
															          claim HrNumEval: apply_fun rNum x = add_SNo rx (minus_SNo ux).
															          { exact (add_of_pair_map_neg_apply A r (u_of r) x HxA HrxR HuxR). }
															          claim HrNumR: apply_fun rNum x :e R.
															          { rewrite HrNumEval.
															            exact (real_add_SNo rx HrxR (minus_SNo ux) (real_minus_SNo ux HuxR)). }
															          claim HrNewEq: apply_fun rNew x = div_SNo (apply_fun rNum x) den.
															          { exact (compose_div_const_fun_apply A rNum den x HxA HdenR HrNumR). }
															          rewrite HrNewEq.
															          rewrite HrNumEval at 1.
															          set num := add_SNo rx (minus_SNo ux).
															          claim HnumDef: num = add_SNo rx (minus_SNo ux).
															          { reflexivity. }
															          rewrite <- HnumDef at 1.
															          claim HnumR: num :e R.
															          { exact (real_add_SNo rx HrxR (minus_SNo ux) (real_minus_SNo ux HuxR)). }
															          claim HnumS: SNo num.
															          { exact (real_SNo num HnumR). }
															          claim HdenS: SNo den.
															          { exact (real_SNo den HdenR). }
															          claim HdivR: div_SNo num den :e R.
															          { exact (real_div_SNo num HnumR den HdenR). }
															          claim HdivS: SNo (div_SNo num den).
															          { exact (real_SNo (div_SNo num den) HdivR). }
															          (** reduce the correction term algebraically **)
															          claim HcNewDef: cNew = mul_SNo c den.
															          { reflexivity. }
															          rewrite HcNewDef.
															          claim HmulAssoc: mul_SNo (div_SNo num den) (mul_SNo c den) =
															            mul_SNo (mul_SNo (div_SNo num den) c) den.
															          { exact (mul_SNo_assoc (div_SNo num den) c den HdivS HcS HdenS). }
															          rewrite HmulAssoc.
															          claim HmulSwap: mul_SNo (mul_SNo (div_SNo num den) c) den =
															            mul_SNo (mul_SNo (div_SNo num den) den) c.
															          { exact (mul_SNo_com_3b_1_2 (div_SNo num den) c den HdivS HcS HdenS). }
															          rewrite HmulSwap.
															          claim Hdenne0: den <> 0.
															          { exact H23ne0. }
															          claim Hcancel: mul_SNo (div_SNo num den) den = num.
															          { exact (mul_div_SNo_invL num den HnumS HdenS Hdenne0). }
															          rewrite Hcancel.
															          claim HnumEq: num = add_SNo rx (minus_SNo ux).
															          { reflexivity. }
															          rewrite HnumEq.
															          claim HuxcDef: uxc = mul_SNo ux c.
															          { reflexivity. }
															          rewrite HuxcDef at 1.
															          exact (Tietze_stepII_algebra_tail gx rx ux c HgxS HrxS HuxS HcS). }
																      let n. assume HnO: n :e omega.
																      let x. assume HxA: x :e A.
																      exact (HInv_nat n (omega_nat_p n HnO) x HxA). }
																    (** The remaining proof obligations are split so they can be refined independently later. **)
																    (** helper: State n yields a real-valued map on X (in function_space X R) **)
																    claim HInv_g_FS: forall n:set, n :e omega -> (State n) 0 :e function_space X R.
																    { claim Hfun_g0: function_on g0 X R.
																      { exact (continuous_map_function_on X Tx R R_standard_topology g0 Hg0contR). }
																      claim Hg0g_FS: g0g :e function_space X R.
																      { set gg := (fun x:set => apply_fun g0 x).
																        claim Hgg: forall x:set, x :e X -> gg x :e R.
																        { let x. assume HxX: x :e X.
																          exact (Hfun_g0 x HxX). }
																        claim Hg0g_def: g0g = graph X gg.
																        { reflexivity. }
																        rewrite Hg0g_def.
																        exact (graph_in_function_space X R gg Hgg). }
																      claim HInv_nat: forall n:set, nat_p n -> (State n) 0 :e function_space X R.
																      { apply nat_ind.
																        - (** base case **)
																          prove (State 0) 0 :e function_space X R.
																          claim H0: State 0 = BaseState.
																          { exact (nat_primrec_0 BaseState StepState). }
																          rewrite H0.
																          claim HBase: BaseState = (g0g, (f1s, den)).
																          { reflexivity. }
																          rewrite HBase.
																          rewrite (tuple_2_0_eq g0g (f1s, den)).
																          exact Hg0g_FS.
																        - let n. assume HnNat: nat_p n.
																          assume IH: (State n) 0 :e function_space X R.
																          prove (State (ordsucc n)) 0 :e function_space X R.
																          claim HS: State (ordsucc n) = StepState n (State n).
																          { exact (nat_primrec_S BaseState StepState n HnNat). }
																          rewrite HS.
																          set st := State n.
																          set g := st 0.
																          set rpack := st 1.
																          set r := rpack 0.
																          set c := rpack 1.
																          set gNew := compose_fun X
																            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
																            add_fun_R.
																          set rNew := compose_fun A
																            (compose_fun A
																              (pair_map A r (compose_fun A (u_of r) neg_fun))
																              add_fun_R)
																            (div_const_fun den).
																          set cNew := mul_SNo c den.
																          claim HStep0: (StepState n st) 0 = gNew.
																          { claim Hdef: StepState n st = (gNew, (rNew, cNew)).
																            { reflexivity. }
																            rewrite Hdef.
																            exact (tuple_2_0_eq gNew (rNew, cNew)). }
																          rewrite HStep0.
																          claim Hg_on: function_on g X R.
																          { exact (function_on_of_function_space g X R IH). }
																          claim HnO: n :e omega.
																          { exact (nat_p_omega n HnNat). }
																          claim Hcpack: ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
																          { exact (HInv_cpos n HnO). }
																          claim Hc_eq: c = ((State n) 1) 1.
																          { reflexivity. }
																          claim HcR0: ((State n) 1) 1 :e R.
																          { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) Hcpack). }
																          claim HcR: c :e R.
																          { rewrite Hc_eq. exact HcR0. }
																          claim Hr_contI: continuous_map A Ta I Ti r.
																          { exact (HInv_r_contI n HnO). }
																          claim Hu_pack:
																            continuous_map X Tx I0 T0 (u_of r) /\
																            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																              apply_fun (u_of r) x = minus_SNo one_third) /\
																            (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																              apply_fun (u_of r) x = one_third).
																          { exact (Hu_of_prop r Hr_contI). }
																          claim Hu_left:
																            continuous_map X Tx I0 T0 (u_of r) /\
																            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																              apply_fun (u_of r) x = minus_SNo one_third).
																          { exact (andEL
																            (continuous_map X Tx I0 T0 (u_of r) /\
																             (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																               apply_fun (u_of r) x = minus_SNo one_third))
																            (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																              apply_fun (u_of r) x = one_third)
																            Hu_pack). }
																          claim Hu_cont: continuous_map X Tx I0 T0 (u_of r).
																          { exact (andEL
																            (continuous_map X Tx I0 T0 (u_of r))
																            (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																              apply_fun (u_of r) x = minus_SNo one_third)
																            Hu_left). }
																          claim Hu_fun_I0: function_on (u_of r) X I0.
																          { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_cont). }
																          claim HI0SubR: I0 c= R.
																          { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
																          claim Hu_fun_R: function_on (u_of r) X R.
																          { let x. assume HxX: x :e X.
																            exact (HI0SubR (apply_fun (u_of r) x) (Hu_fun_I0 x HxX)). }
																          claim HmulFS: mul_const_fun c :e function_space R R.
																          { exact (mul_const_fun_in_function_space c HcR). }
																          claim Hmul_on_R: function_on (mul_const_fun c) R R.
																          { exact (function_on_of_function_space (mul_const_fun c) R R HmulFS). }
																          claim Hmul_on_I0: function_on (mul_const_fun c) I0 R.
																          { exact (function_on_restrict_dom (mul_const_fun c) R I0 R Hmul_on_R HI0SubR). }
																          claim Hh_on: function_on (compose_fun X (u_of r) (mul_const_fun c)) X R.
																          { exact (function_on_compose_fun X I0 R (u_of r) (mul_const_fun c) Hu_fun_I0 Hmul_on_I0). }
																          claim Hpair_FS: pair_map X g (compose_fun X (u_of r) (mul_const_fun c)) :e function_space X (setprod R R).
																          { exact (pair_map_in_function_space X R R g (compose_fun X (u_of r) (mul_const_fun c)) Hg_on Hh_on). }
																          claim Hpair_on: function_on (pair_map X g (compose_fun X (u_of r) (mul_const_fun c))) X (setprod R R).
																          { exact (function_on_of_function_space (pair_map X g (compose_fun X (u_of r) (mul_const_fun c))) X (setprod R R) Hpair_FS). }
																          claim HaddFS: add_fun_R :e function_space (setprod R R) R.
																          { exact add_fun_R_in_function_space. }
																          claim Hadd_on: function_on add_fun_R (setprod R R) R.
																          { exact (function_on_of_function_space add_fun_R (setprod R R) R HaddFS). }
																          exact (compose_fun_in_function_space X (setprod R R) R
																                  (pair_map X g (compose_fun X (u_of r) (mul_const_fun c))) add_fun_R
																                  Hpair_on Hadd_on). }
																      let n. assume HnO: n :e omega.
																      exact (HInv_nat n (omega_nat_p n HnO)). }
																    apply andI.
															    - prove (((function_on fn omega (function_space X R) /\
															              (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
														             /\
														             (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
														            /\
														            (forall x:set, x :e A ->
														              converges_to R (metric_topology R R_bounded_metric)
														                (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
														                (apply_fun f x))).
														      apply andI.
														      + prove ((function_on fn omega (function_space X R) /\
														                (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
														               /\
														               (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I)).
														        apply andI.
														        * prove (function_on fn omega (function_space X R) /\
														                 (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n))).
																          apply andI.
																          - (** fn n lies in function_space X R (invariant on State n) **)
																            let n. assume HnO: n :e omega.
																            prove apply_fun fn n :e function_space X R.
																            claim Hdef: fn = graph omega (fun n0:set => (State n0) 0).
																            { reflexivity. }
														            rewrite (apply_fun_of_graph_eq fn omega (fun n0:set => (State n0) 0) n Hdef HnO).
														            exact (HInv_g_FS n HnO).
															          - (** continuity of each fn n (invariant on State n) **)
															            claim HInv_g_cont: forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology ((State n) 0).
															            { claim Hg0g_cont: continuous_map X Tx R R_standard_topology g0g.
															              { claim HTx': topology_on X Tx.
															                { exact (continuous_map_topology_dom X Tx R R_standard_topology g0 Hg0contR). }
															                claim HTR: topology_on R R_standard_topology.
															                { exact (continuous_map_topology_cod X Tx R R_standard_topology g0 Hg0contR). }
															                claim Hfun_g0: function_on g0 X R.
															                { exact (continuous_map_function_on X Tx R R_standard_topology g0 Hg0contR). }
															                claim Hfun_g0g: function_on g0g X R.
															                { let x. assume HxX: x :e X.
															                  prove apply_fun g0g x :e R.
															                  rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX) at 1.
															                  exact (Hfun_g0 x HxX). }
															                claim Hpre_g0g: forall V:set, V :e R_standard_topology -> preimage_of X g0g V :e Tx.
															                { let V. assume HV: V :e R_standard_topology.
															                  claim Hpre_g0: preimage_of X g0 V :e Tx.
															                  { exact (continuous_map_preimage X Tx R R_standard_topology g0 Hg0contR V HV). }
															                  claim Heq: preimage_of X g0g V = preimage_of X g0 V.
															                  { apply set_ext.
															                    - let x. assume Hx: x :e preimage_of X g0g V.
															                      prove x :e preimage_of X g0 V.
															                      claim HxX: x :e X.
															                      { exact (SepE1 X (fun y:set => apply_fun g0g y :e V) x Hx). }
															                      claim Himg: apply_fun g0g x :e V.
															                      { exact (SepE2 X (fun y:set => apply_fun g0g y :e V) x Hx). }
															                      claim Himg': apply_fun g0 x :e V.
															                      { rewrite <- (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX) at 1.
															                        exact Himg. }
															                      exact (SepI X (fun y:set => apply_fun g0 y :e V) x HxX Himg').
															                    - let x. assume Hx: x :e preimage_of X g0 V.
															                      prove x :e preimage_of X g0g V.
															                      claim HxX: x :e X.
															                      { exact (SepE1 X (fun y:set => apply_fun g0 y :e V) x Hx). }
															                      claim Himg: apply_fun g0 x :e V.
															                      { exact (SepE2 X (fun y:set => apply_fun g0 y :e V) x Hx). }
															                      claim Himg': apply_fun g0g x :e V.
															                      { rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX) at 1.
															                        exact Himg. }
															                      exact (SepI X (fun y:set => apply_fun g0g y :e V) x HxX Himg'). }
															                  rewrite Heq.
															                  exact Hpre_g0. }
															                prove continuous_map X Tx R R_standard_topology g0g.
															                prove topology_on X Tx /\ topology_on R R_standard_topology /\
															                  function_on g0g X R /\
															                  forall V:set, V :e R_standard_topology -> preimage_of X g0g V :e Tx.
															                claim Htop: topology_on X Tx /\ topology_on R R_standard_topology.
															                { apply andI. exact HTx'. exact HTR. }
															                claim Htopfun: (topology_on X Tx /\ topology_on R R_standard_topology) /\ function_on g0g X R.
															                { apply andI. exact Htop. exact Hfun_g0g. }
															                apply andI.
															                - exact Htopfun.
															                - exact Hpre_g0g. }
															              claim HInv_nat: forall n:set, nat_p n -> continuous_map X Tx R R_standard_topology ((State n) 0).
															              { apply nat_ind.
															                - prove continuous_map X Tx R R_standard_topology ((State 0) 0).
															                  claim H0: State 0 = BaseState.
															                  { exact (nat_primrec_0 BaseState StepState). }
															                  rewrite H0.
															                  claim HBase: BaseState = (g0g, (f1s, den)).
															                  { reflexivity. }
															                  rewrite HBase.
															                  rewrite (tuple_2_0_eq g0g (f1s, den)).
															                  exact Hg0g_cont.
															                - let n. assume HnNat: nat_p n.
															                  assume IH: continuous_map X Tx R R_standard_topology ((State n) 0).
															                  prove continuous_map X Tx R R_standard_topology ((State (ordsucc n)) 0).
															                  claim HS: State (ordsucc n) = StepState n (State n).
															                  { exact (nat_primrec_S BaseState StepState n HnNat). }
															                  rewrite HS.
															                  set st := State n.
															                  set g := st 0.
															                  set rpack := st 1.
															                  set r := rpack 0.
															                  set c := rpack 1.
															                  set gNew := compose_fun X
															                    (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															                    add_fun_R.
															                  set rNew := compose_fun A
															                    (compose_fun A
															                      (pair_map A r (compose_fun A (u_of r) neg_fun))
															                      add_fun_R)
															                    (div_const_fun den).
															                  set cNew := mul_SNo c den.
															                  claim HStep0: (StepState n st) 0 = gNew.
															                  { claim Hdef: StepState n st = (gNew, (rNew, cNew)).
															                    { reflexivity. }
															                    rewrite Hdef.
															                    exact (tuple_2_0_eq gNew (rNew, cNew)). }
															                  rewrite HStep0.
															                  claim Hg_cont: continuous_map X Tx R R_standard_topology g.
															                  { exact IH. }
															                  claim HnO: n :e omega.
															                  { exact (nat_p_omega n HnNat). }
															                  claim Hcpack: ((State n) 1) 1 :e R /\ 0 < ((State n) 1) 1.
															                  { exact (HInv_cpos n HnO). }
															                  claim Hc_eq: c = ((State n) 1) 1.
															                  { reflexivity. }
															                  claim HcR0: ((State n) 1) 1 :e R.
															                  { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) Hcpack). }
															                  claim Hcpos0: 0 < ((State n) 1) 1.
															                  { exact (andER (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) Hcpack). }
															                  claim HcR: c :e R.
															                  { rewrite Hc_eq. exact HcR0. }
															                  claim Hcpos: 0 < c.
															                  { rewrite Hc_eq. exact Hcpos0. }
															                  claim Hr_contI: continuous_map A Ta I Ti r.
															                  { exact (HInv_r_contI n HnO). }
															                  claim Hu_pack:
															                    continuous_map X Tx I0 T0 (u_of r) /\
															                    (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                      apply_fun (u_of r) x = minus_SNo one_third) /\
															                    (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                      apply_fun (u_of r) x = one_third).
															                  { exact (Hu_of_prop r Hr_contI). }
															                  claim Hu_left:
															                    continuous_map X Tx I0 T0 (u_of r) /\
															                    (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                      apply_fun (u_of r) x = minus_SNo one_third).
															                  { exact (andEL
															                    (continuous_map X Tx I0 T0 (u_of r) /\
															                     (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                       apply_fun (u_of r) x = minus_SNo one_third))
															                    (forall x:set, x :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                      apply_fun (u_of r) x = one_third)
															                    Hu_pack). }
															                  claim Hu_cont: continuous_map X Tx I0 T0 (u_of r).
															                  { exact (andEL
															                    (continuous_map X Tx I0 T0 (u_of r))
															                    (forall x:set, x :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                      apply_fun (u_of r) x = minus_SNo one_third)
															                    Hu_left). }
															                  claim HI0SubR: I0 c= R.
															                  { exact (closed_interval_sub_R (minus_SNo one_third) one_third). }
															                  claim HT0: T0 = subspace_topology R R_standard_topology I0.
															                  { reflexivity. }
															                  claim Hmul_contR: continuous_map R R_standard_topology R R_standard_topology (mul_const_fun c).
															                  { exact (mul_const_fun_continuous_pos c HcR Hcpos). }
															                  claim Hmul_contI0: continuous_map I0 T0 R R_standard_topology (mul_const_fun c).
															                  { rewrite HT0.
															                    exact (continuous_on_subspace R R_standard_topology R R_standard_topology (mul_const_fun c) I0
															                             R_standard_topology_is_topology HI0SubR Hmul_contR). }
															                  claim Hh_cont: continuous_map X Tx R R_standard_topology (compose_fun X (u_of r) (mul_const_fun c)).
															                  { exact (composition_continuous X Tx I0 T0 R R_standard_topology (u_of r) (mul_const_fun c)
															                           Hu_cont Hmul_contI0). }
															                  claim Hpair_cont: continuous_map X Tx (setprod R R)
															                    (product_topology R R_standard_topology R R_standard_topology)
															                    (pair_map X g (compose_fun X (u_of r) (mul_const_fun c))).
															                  { exact (maps_into_products_axiom X Tx R R_standard_topology R R_standard_topology
															                           g (compose_fun X (u_of r) (mul_const_fun c))
															                           Hg_cont Hh_cont). }
															                  claim Hadd_cont: continuous_map (setprod R R)
															                    (product_topology R R_standard_topology R R_standard_topology)
															                    R R_standard_topology add_fun_R.
															                  { exact add_fun_R_continuous. }
															                  exact (composition_continuous
															                           X Tx
															                           (setprod R R) (product_topology R R_standard_topology R R_standard_topology)
															                           R R_standard_topology
															                           (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															                           add_fun_R
															                           Hpair_cont Hadd_cont). }
															              let n. assume HnO: n :e omega.
															              exact (HInv_nat n (omega_nat_p n HnO)). }
															            let n. assume HnO: n :e omega.
															            prove continuous_map X Tx R R_standard_topology (apply_fun fn n).
															            claim Hdef: fn = graph omega (fun n0:set => (State n0) 0).
															            { reflexivity. }
														            rewrite (apply_fun_of_graph_eq fn omega (fun n0:set => (State n0) 0) n Hdef HnO).
														            exact (HInv_g_cont n HnO).
															        * (** range-in-I of each fn n (invariant on State n) **)
															          claim HInv_g_I: forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun ((State n) 0) x :e I.
															          { claim HInv_nat: forall n:set, nat_p n -> forall x:set, x :e X ->
															              apply_fun ((State n) 0) x :e I /\
															              apply_fun ((State n) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State n) 1) 1))
															                                                   (add_SNo 1 (minus_SNo (((State n) 1) 1))).
															            { apply nat_ind.
															              - let x. assume HxX: x :e X.
															                prove apply_fun ((State 0) 0) x :e I /\
															                  apply_fun ((State 0) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State 0) 1) 1))
															                                                     (add_SNo 1 (minus_SNo (((State 0) 1) 1))).
															                claim H0: State 0 = BaseState.
															                { exact (nat_primrec_0 BaseState StepState). }
															                rewrite H0.
															                claim HBase: BaseState = (g0g, (f1s, den)).
															                { reflexivity. }
															                rewrite HBase.
															                rewrite (tuple_2_0_eq g0g (f1s, den)).
															                rewrite (tuple_2_0_eq g0g (f1s, den)).
															                claim Hc0Eq: ((g0g, (f1s, den)) 1) 1 = den.
															                { rewrite (tuple_2_1_eq g0g (f1s, den)) at 1.
															                  rewrite (tuple_2_1_eq f1s den) at 1.
															                  reflexivity. }
															                apply andI.
															                + (** in I **)
															                rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX).
															                claim Hg0xI0: apply_fun g0 x :e I0.
															                { exact (Hfung0 x HxX). }
															                exact (closed_interval_minus_one_third_one_third_sub_closed_interval_minus1_1 (apply_fun g0 x) Hg0xI0).
															                + (** in the shrinking interval for c0=den=2/3 **)
															                  rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX).
															                  claim Hg0xI0: apply_fun g0 x :e I0.
															                  { exact (Hfung0 x HxX). }
															                  claim HdenDef: den = two_thirds.
															                  { reflexivity. }
															                  claim HlowEq0:
															                    add_SNo (minus_SNo 1) (((g0g, (f1s, den)) 1) 1) = minus_SNo one_third.
															                  { rewrite Hc0Eq.
															                    rewrite HdenDef.
															                    exact add_minus1_two_thirds_eq_minus_one_third. }
															                  claim HupEq0:
															                    add_SNo 1 (minus_SNo (((g0g, (f1s, den)) 1) 1)) = one_third.
															                  { rewrite Hc0Eq.
															                    rewrite HdenDef.
															                    exact add_1_minus_two_thirds_eq_one_third. }
															                  rewrite HlowEq0.
															                  rewrite HupEq0.
															                  exact Hg0xI0.
															              - let n. assume HnNat: nat_p n.
															                assume IH: forall x:set, x :e X ->
															                  apply_fun ((State n) 0) x :e I /\
															                  apply_fun ((State n) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State n) 1) 1))
															                                                       (add_SNo 1 (minus_SNo (((State n) 1) 1))).
															                let x. assume HxX: x :e X.
															                prove apply_fun ((State (ordsucc n)) 0) x :e I /\
															                  apply_fun ((State (ordsucc n)) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State (ordsucc n)) 1) 1))
															                                                       (add_SNo 1 (minus_SNo (((State (ordsucc n)) 1) 1))).
															                (** TODO: step case needs the geometric-series bound plus range control of the correction term. **)
															                claim HSnat: State (ordsucc n) = StepState n (State n).
															                { exact (nat_primrec_S BaseState StepState n HnNat). }
															                rewrite HSnat.
															                set st := State n.
															                set g := st 0.
															                set rpack := st 1.
															                set r := rpack 0.
															                set c := rpack 1.
															                set gNew := compose_fun X
															                  (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
															                  add_fun_R.
															                set rNew := compose_fun A
															                  (compose_fun A
															                    (pair_map A r (compose_fun A (u_of r) neg_fun))
															                    add_fun_R)
															                  (div_const_fun den).
															                set cNew := mul_SNo c den.
															                claim HdefStep: StepState n st = (gNew, (rNew, cNew)).
															                { reflexivity. }
															                rewrite HdefStep.
															                claim HgStep: ((gNew, (rNew, cNew)) 0) = gNew.
															                { exact (tuple_2_0_eq gNew (rNew, cNew)). }
															                rewrite HgStep.
															                claim HnO: n :e omega.
															                { exact (nat_p_omega n HnNat). }
															                claim HrEq: r = ((State n) 1) 0.
															                { reflexivity. }
															                claim HcEq: c = ((State n) 1) 1.
															                { reflexivity. }
															                claim Hr_contI: continuous_map A Ta I Ti r.
															                { rewrite HrEq.
															                  exact (HInv_r_contI n HnO). }
															                claim Hu_pack:
															                  continuous_map X Tx I0 T0 (u_of r) /\
															                  (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                    apply_fun (u_of r) x0 = minus_SNo one_third) /\
															                  (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                    apply_fun (u_of r) x0 = one_third).
															                { exact (Hu_of_prop r Hr_contI). }
															                claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
															                { exact (andEL
															                    (continuous_map X Tx I0 T0 (u_of r))
															                    (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                      apply_fun (u_of r) x0 = minus_SNo one_third)
															                    (andEL
															                      ((continuous_map X Tx I0 T0 (u_of r)) /\
															                       (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
															                         apply_fun (u_of r) x0 = minus_SNo one_third))
															                      (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
															                        apply_fun (u_of r) x0 = one_third)
															                      Hu_pack)). }
															                claim Hu_fun: function_on (u_of r) X I0.
															                { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
															                claim HuxI0: apply_fun (u_of r) x :e I0.
															                { exact (Hu_fun x HxX). }
															                claim HuxR: apply_fun (u_of r) x :e R.
															                { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun (u_of r) x) HuxI0). }
															                claim HcR: c :e R.
															                { rewrite HcEq.
															                  exact (andEL
															                    (((State n) 1) 1 :e R)
															                    (0 < ((State n) 1) 1)
															                    (HInv_cpos n HnO)). }
															                claim HgEq: g = (State n) 0.
															                { reflexivity. }
															                claim HgxI: apply_fun g x :e I.
															                { rewrite HgEq.
															                  exact (andEL
															                    (apply_fun ((State n) 0) x :e I)
															                    (apply_fun ((State n) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State n) 1) 1))
															                                                         (add_SNo 1 (minus_SNo (((State n) 1) 1))))
															                    (IH x HxX)). }
															                claim HgxR: apply_fun g x :e R.
															                { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun g x) HgxI). }
															                claim HcorrEq:
															                  apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
															                    mul_SNo (apply_fun (u_of r) x) c.
															                { claim Hcomp:
															                    apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
															                      apply_fun (mul_const_fun c) (apply_fun (u_of r) x).
															                  { exact (compose_fun_apply X (u_of r) (mul_const_fun c) x HxX). }
															                  rewrite Hcomp.
															                  exact (mul_const_fun_apply c (apply_fun (u_of r) x) HcR HuxR). }
															                claim HcorrR: apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x :e R.
															                { rewrite HcorrEq.
															                  exact (real_mul_SNo (apply_fun (u_of r) x) HuxR c HcR). }
															                claim HgNewEval:
															                  apply_fun gNew x =
															                    add_SNo (apply_fun g x) (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x).
															                { exact (add_of_pair_map_apply X g (compose_fun X (u_of r) (mul_const_fun c)) x HxX HgxR HcorrR). }
															                (** TODO: finish by bounding the correction term and using interval closure under this controlled addition. **)
															                rewrite HgNewEval.
															                rewrite HcorrEq.
															                claim Hcpos: 0 < c.
															                { rewrite HcEq.
															                  exact (andER
															                    (((State n) 1) 1 :e R)
															                    (0 < ((State n) 1) 1)
															                    (HInv_cpos n HnO)). }
															                claim HyIshrink:
															                  apply_fun g x :e closed_interval (add_SNo (minus_SNo 1) c) (add_SNo 1 (minus_SNo c)).
															                { rewrite HgEq.
															                  rewrite HcEq.
															                  exact (andER
															                    (apply_fun ((State n) 0) x :e I)
															                    (apply_fun ((State n) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State n) 1) 1))
															                                                         (add_SNo 1 (minus_SNo (((State n) 1) 1))))
															                    (IH x HxX)). }
															                claim HzIthird:
															                  mul_SNo (apply_fun (u_of r) x) c :e
															                    closed_interval (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third).
															                { prove mul_SNo (apply_fun (u_of r) x) c :e closed_interval (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third).
															                  claim H13R: one_third :e R.
															                  { exact one_third_in_R. }
															                  claim H13S: SNo one_third.
															                  { exact (real_SNo one_third H13R). }
															                  claim Hm13R: minus_SNo one_third :e R.
															                  { exact (real_minus_SNo one_third H13R). }
															                  claim Hm13S: SNo (minus_SNo one_third).
															                  { exact (SNo_minus_SNo one_third H13S). }
															                  claim HuS: SNo (apply_fun (u_of r) x).
															                  { exact (real_SNo (apply_fun (u_of r) x) HuxR). }
															                  claim HcS: SNo c.
															                  { exact (real_SNo c HcR). }
															                  claim Hbnds0:
															                    Rle (minus_SNo one_third) (apply_fun (u_of r) x) /\
															                    Rle (apply_fun (u_of r) x) one_third.
															                  { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun (u_of r) x)
															                    Hm13R H13R HuxI0). }
															                  claim HloRle: Rle (minus_SNo one_third) (apply_fun (u_of r) x).
															                  { exact (andEL
															                    (Rle (minus_SNo one_third) (apply_fun (u_of r) x))
															                    (Rle (apply_fun (u_of r) x) one_third)
															                    Hbnds0). }
															                  claim HhiRle: Rle (apply_fun (u_of r) x) one_third.
															                  { exact (andER
															                    (Rle (minus_SNo one_third) (apply_fun (u_of r) x))
															                    (Rle (apply_fun (u_of r) x) one_third)
															                    Hbnds0). }
															                  claim Hnot_lt_lo: ~((apply_fun (u_of r) x) < (minus_SNo one_third)).
															                  { assume Hlt: (apply_fun (u_of r) x) < (minus_SNo one_third).
															                    claim Hrlt: Rlt (apply_fun (u_of r) x) (minus_SNo one_third).
															                    { exact (RltI (apply_fun (u_of r) x) (minus_SNo one_third) HuxR Hm13R Hlt). }
															                    exact ((RleE_nlt (minus_SNo one_third) (apply_fun (u_of r) x) HloRle) Hrlt). }
															                  claim Hnot_lt_hi: ~(one_third < (apply_fun (u_of r) x)).
															                  { assume Hlt: one_third < (apply_fun (u_of r) x).
															                    claim Hrlt: Rlt one_third (apply_fun (u_of r) x).
															                    { exact (RltI one_third (apply_fun (u_of r) x) H13R HuxR Hlt). }
															                    exact ((RleE_nlt (apply_fun (u_of r) x) one_third HhiRle) Hrlt). }
															                  claim Hm13_le_u: (minus_SNo one_third) <= (apply_fun (u_of r) x).
															                  { apply (SNoLtLe_or (apply_fun (u_of r) x) (minus_SNo one_third) HuS Hm13S).
															                    - assume Hlt: (apply_fun (u_of r) x) < (minus_SNo one_third).
															                      exact (FalseE (Hnot_lt_lo Hlt) ((minus_SNo one_third) <= (apply_fun (u_of r) x))).
															                    - assume Hle: (minus_SNo one_third) <= (apply_fun (u_of r) x).
															                      exact Hle. }
															                  claim Hu_le_13: (apply_fun (u_of r) x) <= one_third.
															                  { apply (SNoLtLe_or one_third (apply_fun (u_of r) x) H13S HuS).
															                    - assume Hlt: one_third < (apply_fun (u_of r) x).
															                      exact (FalseE (Hnot_lt_hi Hlt) ((apply_fun (u_of r) x) <= one_third)).
															                    - assume Hle: (apply_fun (u_of r) x) <= one_third.
															                      exact Hle. }
															                  claim H0le_c: 0 <= c.
															                  { exact (SNoLtLe 0 c Hcpos). }
															                  claim HmulLeHi: mul_SNo (apply_fun (u_of r) x) c <= mul_SNo one_third c.
															                  { exact (nonneg_mul_SNo_Le' (apply_fun (u_of r) x) one_third c HuS H13S HcS H0le_c Hu_le_13). }
															                  claim HmulLeLo: mul_SNo (minus_SNo one_third) c <= mul_SNo (apply_fun (u_of r) x) c.
															                  { exact (nonneg_mul_SNo_Le' (minus_SNo one_third) (apply_fun (u_of r) x) c Hm13S HuS HcS H0le_c Hm13_le_u). }
															                  claim HmulR: mul_SNo (apply_fun (u_of r) x) c :e R.
															                  { exact (real_mul_SNo (apply_fun (u_of r) x) HuxR c HcR). }
															                  claim Hc13R: mul_SNo c one_third :e R.
															                  { exact (real_mul_SNo c HcR one_third H13R). }
															                  claim Hm_c13R: minus_SNo (mul_SNo c one_third) :e R.
															                  { exact (real_minus_SNo (mul_SNo c one_third) Hc13R). }
															                  claim HhiEq: mul_SNo one_third c = mul_SNo c one_third.
															                  { exact (mul_SNo_com one_third c H13S HcS). }
															                  claim HloEq: mul_SNo (minus_SNo one_third) c = minus_SNo (mul_SNo c one_third).
															                  { rewrite (mul_SNo_minus_distrL one_third c H13S HcS) at 1.
															                    rewrite HhiEq at 1.
															                    reflexivity. }
															                  claim HhiLe': mul_SNo (apply_fun (u_of r) x) c <= mul_SNo c one_third.
															                  { rewrite <- HhiEq.
															                    exact HmulLeHi. }
															                  claim HloLe': (minus_SNo (mul_SNo c one_third)) <= mul_SNo (apply_fun (u_of r) x) c.
															                  { rewrite <- HloEq at 1.
															                    exact HmulLeLo. }
															                  claim HhiRle': Rle (mul_SNo (apply_fun (u_of r) x) c) (mul_SNo c one_third).
															                  { exact (Rle_of_SNoLe (mul_SNo (apply_fun (u_of r) x) c) (mul_SNo c one_third) HmulR Hc13R HhiLe'). }
															                  claim HloRle': Rle (minus_SNo (mul_SNo c one_third)) (mul_SNo (apply_fun (u_of r) x) c).
															                  { exact (Rle_of_SNoLe (minus_SNo (mul_SNo c one_third)) (mul_SNo (apply_fun (u_of r) x) c) Hm_c13R HmulR HloLe'). }
															                  exact (closed_intervalI_of_Rle (minus_SNo (mul_SNo c one_third)) (mul_SNo c one_third)
															                    (mul_SNo (apply_fun (u_of r) x) c)
															                    Hm_c13R Hc13R HmulR
															                    HloRle' HhiRle'). }
															                claim HsumShrink:
															                  add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c) :e
															                    closed_interval (add_SNo (minus_SNo 1) (mul_SNo c two_thirds))
															                                  (add_SNo 1 (minus_SNo (mul_SNo c two_thirds))).
															                { exact (add_SNo_interval_expand_by_third_stub c
															                  (apply_fun g x)
															                  (mul_SNo (apply_fun (u_of r) x) c)
															                  HcR Hcpos HyIshrink HzIthird). }
															                apply andI.
															                + (** in I (existing argument via HsumShrink) **)
															                set t := mul_SNo c two_thirds.
															                claim H23R: two_thirds :e R.
															                { exact two_thirds_in_R. }
															                claim HtR: t :e R.
															                { exact (real_mul_SNo c HcR two_thirds H23R). }
															                claim Htpos: 0 < t.
															                { claim H23S: SNo two_thirds.
															                  { exact (real_SNo two_thirds H23R). }
															                  claim HcS: SNo c.
															                  { exact (real_SNo c HcR). }
															                  exact (mul_SNo_pos_pos c two_thirds HcS H23S Hcpos two_thirds_pos). }
															                claim H0lt_t: Rlt 0 t.
															                { exact (RltI 0 t real_0 HtR Htpos). }
															                claim H0le_t: Rle 0 t.
															                { exact (Rlt_implies_Rle 0 t H0lt_t). }
															                claim Hm1R: (minus_SNo 1) :e R.
															                { exact (real_minus_SNo 1 real_1). }
															                claim Hm1S: SNo (minus_SNo 1).
															                { exact (SNo_minus_SNo 1 SNo_1). }
															                claim Ha_low: Rle (minus_SNo 1) (add_SNo (minus_SNo 1) t).
															                { claim Htmp: Rle (add_SNo (minus_SNo 1) 0) (add_SNo (minus_SNo 1) t).
															                  { exact (Rle_add_SNo_2 (minus_SNo 1) 0 t Hm1R real_0 HtR H0le_t). }
															                  rewrite <- (add_SNo_0R (minus_SNo 1) Hm1S) at 1.
															                  exact Htmp. }
															                claim Hneg_t_le0: Rle (minus_SNo t) 0.
															                { exact (Rle_minus_nonneg t HtR (RleE_nlt 0 t H0le_t)). }
															                claim Hb_up: Rle (add_SNo 1 (minus_SNo t)) 1.
															                { claim Htmp: Rle (add_SNo 1 (minus_SNo t)) (add_SNo 1 0).
															                  { exact (Rle_add_SNo_2 1 (minus_SNo t) 0 real_1 (real_minus_SNo t HtR) real_0 Hneg_t_le0). }
															                  claim H10Eq: add_SNo 1 0 = 1.
															                  { exact (add_SNo_0R 1 SNo_1). }
															                  claim Hmid: Rle (add_SNo 1 0) 1.
															                  { rewrite H10Eq at 1.
															                    exact (Rle_refl 1 real_1). }
															                  exact (Rle_tra (add_SNo 1 (minus_SNo t)) (add_SNo 1 0) 1 Htmp Hmid). }
															                claim HyR:
															                  add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c) :e R.
															                { exact (closed_interval_sub_R (add_SNo (minus_SNo 1) (mul_SNo c two_thirds))
															                    (add_SNo 1 (minus_SNo (mul_SNo c two_thirds)))
															                    (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c))
															                    HsumShrink). }
															                claim Hbnds:
															                  Rle (add_SNo (minus_SNo 1) t) (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)) /\
															                  Rle (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)) (add_SNo 1 (minus_SNo t)).
															                { exact (closed_interval_bounds (add_SNo (minus_SNo 1) t) (add_SNo 1 (minus_SNo t))
															                    (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c))
															                    (real_add_SNo (minus_SNo 1) Hm1R t HtR)
															                    (real_add_SNo 1 real_1 (minus_SNo t) (real_minus_SNo t HtR))
															                    HsumShrink). }
															                claim Hlo:
															                  Rle (minus_SNo 1) (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)).
															                { exact (Rle_tra (minus_SNo 1) (add_SNo (minus_SNo 1) t)
															                    (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c))
															                    Ha_low
															                    (andEL
															                      (Rle (add_SNo (minus_SNo 1) t) (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)))
															                      (Rle (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)) (add_SNo 1 (minus_SNo t)))
															                      Hbnds)). }
															                claim Hhi:
															                  Rle (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)) 1.
															                { exact (Rle_tra (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c))
															                    (add_SNo 1 (minus_SNo t)) 1
															                    (andER
															                      (Rle (add_SNo (minus_SNo 1) t) (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)))
															                      (Rle (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c)) (add_SNo 1 (minus_SNo t)))
															                      Hbnds)
															                    Hb_up). }
															                exact (closed_intervalI_of_Rle (minus_SNo 1) 1
															                  (add_SNo (apply_fun g x) (mul_SNo (apply_fun (u_of r) x) c))
															                  Hm1R real_1 HyR Hlo Hhi).
															                + (** in the shrinking interval for the successor scalar **)
															                  claim HdenDef: den = two_thirds.
															                  { reflexivity. }
															                  claim HcNewEq: cNew = mul_SNo c two_thirds.
															                  { rewrite HdenDef.
															                    reflexivity. }
															                  claim HcPairEq: ((gNew, (rNew, cNew)) 1) 1 = cNew.
															                  { claim Hinner: ((gNew, (rNew, cNew)) 1) = (rNew, cNew).
															                    { exact (tuple_2_1_eq gNew (rNew, cNew)). }
															                    rewrite Hinner at 1.
															                    exact (tuple_2_1_eq rNew cNew). }
															                  claim HcGoalEq: ((gNew, (rNew, cNew)) 1) 1 = mul_SNo c two_thirds.
															                  { rewrite HcPairEq.
															                    rewrite HcNewEq.
															                    reflexivity. }
															                  claim HlowEq:
															                    add_SNo (minus_SNo 1) (((gNew, (rNew, cNew)) 1) 1) =
															                      add_SNo (minus_SNo 1) (mul_SNo c two_thirds).
															                  { rewrite HcGoalEq.
															                    reflexivity. }
															                  claim HupEq:
															                    add_SNo 1 (minus_SNo (((gNew, (rNew, cNew)) 1) 1)) =
															                      add_SNo 1 (minus_SNo (mul_SNo c two_thirds)).
															                  { rewrite HcGoalEq.
															                    reflexivity. }
															                  rewrite HlowEq.
															                  rewrite HupEq.
															                  exact HsumShrink. }
															            let n. assume HnO: n :e omega.
															            let x. assume HxX: x :e X.
															            exact (andEL
															              (apply_fun ((State n) 0) x :e I)
															              (apply_fun ((State n) 0) x :e closed_interval (add_SNo (minus_SNo 1) (((State n) 1) 1))
															                                                   (add_SNo 1 (minus_SNo (((State n) 1) 1))))
															              (HInv_nat n (omega_nat_p n HnO) x HxX)). }
															          let n. assume HnO: n :e omega.
															          let x. assume HxX: x :e X.
															          prove apply_fun (apply_fun fn n) x :e I.
															          claim Hdef: fn = graph omega (fun n0:set => (State n0) 0).
														          { reflexivity. }
														          rewrite (apply_fun_of_graph_eq fn omega (fun n0:set => (State n0) 0) n Hdef HnO).
														          exact (HInv_g_I n HnO x HxX).
														      + (** pointwise convergence on A (to be proved from residual convergence / geometric tail bounds) **)
														        let x. assume HxA: x :e A.
														        prove converges_to R (metric_topology R R_bounded_metric)
														          (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
														          (apply_fun f x).
														        set seq1 := graph omega (fun n:set => apply_fun (apply_fun fn n) x).
														        set seq2 := graph omega (fun n:set => apply_fun ((State n) 0) x).
															        claim HseqEq: seq1 = seq2.
															        { apply set_ext.
															          - let p. assume Hp: p :e seq1.
															            prove p :e seq2.
														            apply (ReplE_impred omega (fun n0:set => (n0, apply_fun (apply_fun fn n0) x)) p Hp (p :e seq2)).
														            let n. assume HnO: n :e omega.
														            assume HpEq: p = (n, apply_fun (apply_fun fn n) x).
														            rewrite HpEq.
														            claim Hdef: fn = graph omega (fun n0:set => (State n0) 0).
														            { reflexivity. }
														            rewrite (apply_fun_of_graph_eq fn omega (fun n0:set => (State n0) 0) n Hdef HnO) at 1.
														            exact (ReplI omega (fun n0:set => (n0, apply_fun ((State n0) 0) x)) n HnO).
														          - let p. assume Hp: p :e seq2.
														            prove p :e seq1.
														            apply (ReplE_impred omega (fun n0:set => (n0, apply_fun ((State n0) 0) x)) p Hp (p :e seq1)).
														            let n. assume HnO: n :e omega.
														            assume HpEq: p = (n, apply_fun ((State n) 0) x).
														            rewrite HpEq.
															            claim Hdef: fn = graph omega (fun n0:set => (State n0) 0).
															            { reflexivity. }
															            rewrite <- (apply_fun_of_graph_eq fn omega (fun n0:set => (State n0) 0) n Hdef HnO) at 1.
															            exact (ReplI omega (fun n0:set => (n0, apply_fun (apply_fun fn n0) x)) n HnO). }
															        claim Hseq1def:
															          seq1 = (graph omega (fun n:set => apply_fun (apply_fun fn n) x)).
															        { reflexivity. }
															        rewrite <- Hseq1def.
															        rewrite HseqEq.
															        (** TODO: show seq2 converges to f x in the bounded-metric topology using the residual recursion. **)
															        claim Hseq2_conv:
															          converges_to R (metric_topology R R_bounded_metric)
															            seq2
															            (apply_fun f x).
															        { (** TODO: derive the usual bound |(State n)0 x - f x| <= ((State n)1)1 on A and use ((State n)1)1 -> 0. **)
															          set lim := apply_fun f x.
																          claim HconvM: sequence_converges_metric R R_bounded_metric seq2 lim.
																          { prove metric_on R R_bounded_metric /\ sequence_on seq2 R /\ lim :e R /\
																              forall eps:set, eps :e R /\ Rlt 0 eps ->
																                exists N:set, N :e omega /\
																                  forall n:set, n :e omega -> N c= n ->
																                    Rlt (apply_fun R_bounded_metric (apply_fun seq2 n, lim)) eps.
																            claim Hseq2On: sequence_on seq2 R.
																            { prove sequence_on seq2 R.
																              let n. assume HnO: n :e omega.
																              prove apply_fun seq2 n :e R.
																              claim HxX: x :e X.
																              { exact (HAsubX x HxA). }
																              claim Hseq2def: seq2 = graph omega (fun n0:set => apply_fun ((State n0) 0) x).
																              { reflexivity. }
																              rewrite Hseq2def.
																              rewrite (apply_fun_graph omega (fun n0:set => apply_fun ((State n0) 0) x) n HnO).
																              claim HgR_nat: forall k:set, nat_p k -> apply_fun ((State k) 0) x :e R.
																              { apply nat_ind.
																                - prove apply_fun ((State 0) 0) x :e R.
																                  claim H0: State 0 = BaseState.
																                  { exact (nat_primrec_0 BaseState StepState). }
																                  rewrite H0.
																                  claim HBase: BaseState = (g0g, (f1s, den)).
																                  { reflexivity. }
																                  rewrite HBase.
																                  rewrite (tuple_2_0_eq g0g (f1s, den)).
																                  claim HxX0: x :e X.
																                  { exact (HAsubX x HxA). }
																                  rewrite (apply_fun_graph X (fun x0:set => apply_fun g0 x0) x HxX0).
																                  claim Hg0I0: apply_fun g0 x :e I0.
																                  { exact (Hfung0 x HxX0). }
																                  exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0I0).
																                - let k. assume HkNat: nat_p k.
																                  assume IHk: apply_fun ((State k) 0) x :e R.
																                  prove apply_fun ((State (ordsucc k)) 0) x :e R.
																                  claim HS: State (ordsucc k) = StepState k (State k).
																                  { exact (nat_primrec_S BaseState StepState k HkNat). }
																                  rewrite HS.
																                  set st := State k.
																                  set g := st 0.
																                  set rpack := st 1.
																                  set r := rpack 0.
																                  set c := rpack 1.
																                  set gNew := compose_fun X
																                    (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
																                    add_fun_R.
																                  set rNew := compose_fun A
																                    (compose_fun A
																                      (pair_map A r (compose_fun A (u_of r) neg_fun))
																                      add_fun_R)
																                    (div_const_fun den).
																                  set cNew := mul_SNo c den.
																                  claim Hdef: StepState k st = (gNew, (rNew, cNew)).
																                  { reflexivity. }
																                  claim HgStep: (StepState k st) 0 = gNew.
																                  { rewrite Hdef.
																                    exact (tuple_2_0_eq gNew (rNew, cNew)). }
																                  rewrite HgStep.
																                  claim HxX0: x :e X.
																                  { exact (HAsubX x HxA). }
																                  claim HgEq: g = (State k) 0.
																                  { reflexivity. }
																                  claim HgxR: apply_fun g x :e R.
																                  { rewrite HgEq.
																                    exact IHk. }
																                  claim HkO: k :e omega.
																                  { exact (nat_p_omega k HkNat). }
																                  claim HrEq: r = ((State k) 1) 0.
																                  { reflexivity. }
																                  claim Hr_contI: continuous_map A Ta I Ti r.
																                  { rewrite HrEq.
																                    exact (HInv_r_contI k HkO). }
																                  claim Hu_pack:
																                    continuous_map X Tx I0 T0 (u_of r) /\
																                    (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																                      apply_fun (u_of r) x0 = minus_SNo one_third) /\
																                    (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																                      apply_fun (u_of r) x0 = one_third).
																                  { exact (Hu_of_prop r Hr_contI). }
																                  claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
																                  { exact (andEL
																                      (continuous_map X Tx I0 T0 (u_of r))
																                      (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																                        apply_fun (u_of r) x0 = minus_SNo one_third)
																                      (andEL
																                        ((continuous_map X Tx I0 T0 (u_of r)) /\
																                         (forall x0:set, x0 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																                           apply_fun (u_of r) x0 = minus_SNo one_third))
																                        (forall x0:set, x0 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																                          apply_fun (u_of r) x0 = one_third)
																                        Hu_pack)). }
																                  claim Hu_fun: function_on (u_of r) X I0.
																                  { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
																                  claim HuxI0: apply_fun (u_of r) x :e I0.
																                  { exact (Hu_fun x HxX0). }
																                  claim HuxR: apply_fun (u_of r) x :e R.
																                  { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun (u_of r) x) HuxI0). }
																                  claim HcEq: c = ((State k) 1) 1.
																                  { reflexivity. }
																                  claim HcR: c :e R.
																                  { rewrite HcEq.
																                    exact (andEL
																                      (((State k) 1) 1 :e R)
																                      (0 < ((State k) 1) 1)
																                      (HInv_cpos k HkO)). }
																                  claim HcorrEq:
																                    apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
																                      mul_SNo (apply_fun (u_of r) x) c.
																                  { claim Hcomp:
																                      apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x =
																                        apply_fun (mul_const_fun c) (apply_fun (u_of r) x).
																                    { exact (compose_fun_apply X (u_of r) (mul_const_fun c) x HxX0). }
																                    rewrite Hcomp.
																                    exact (mul_const_fun_apply c (apply_fun (u_of r) x) HcR HuxR). }
																                  claim HcorrR: apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x :e R.
																                  { rewrite HcorrEq.
																                    exact (real_mul_SNo (apply_fun (u_of r) x) HuxR c HcR). }
																                  claim HgNewEval:
																                    apply_fun gNew x =
																                      add_SNo (apply_fun g x) (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x).
																                  { exact (add_of_pair_map_apply X g (compose_fun X (u_of r) (mul_const_fun c)) x HxX0 HgxR HcorrR). }
																                  rewrite HgNewEval.
																                  exact (real_add_SNo (apply_fun g x) HgxR
																                    (apply_fun (compose_fun X (u_of r) (mul_const_fun c)) x) HcorrR).
																              }
																              exact (HgR_nat n (omega_nat_p n HnO)). }
																            apply andI.
																            - prove (metric_on R R_bounded_metric /\ sequence_on seq2 R) /\ lim :e R.
																              apply andI.
																              + prove metric_on R R_bounded_metric /\ sequence_on seq2 R.
																                apply andI.
																                * exact R_bounded_metric_is_metric_on_early.
																                * exact Hseq2On.
															              + claim HlimR: lim :e R.
															                { exact (Hf_R x HxA). }
															                exact HlimR.
	                                                                            - let eps. assume Heps: eps :e R /\ Rlt 0 eps.
	                                                                              (** ABY: try_aby at line 132949 column 1 failed **)
	                                                                              (** TODO: use the Step II residual invariant on A to get abs((State n)0 x - f x) <= ((State n)1)1,
	                                                                                  then pick N so that ((State n)1)1 < min(eps,one_third) and conclude using
	                                                                                  abs_lt_lt1_imp_R_bounded_distance_lt. **)
	                                                                              claim HepsR: eps :e R.
	                                                                              { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
	                                                                              claim HepsPos: Rlt 0 eps.
	                                                                              { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
	                                                                              claim HepsS: SNo eps.
	                                                                              { exact (real_SNo eps HepsR). }
	                                                                              apply (SNoLt_trichotomy_or_impred eps 1 HepsS SNo_1
	                                                                                (exists N:set, N :e omega /\
	                                                                                  forall n:set, n :e omega -> N c= n ->
	                                                                                    Rlt (apply_fun R_bounded_metric (apply_fun seq2 n, lim)) eps)).
		                                                                              - assume HepsLt1S: eps < 1.
		                                                                                (** TODO: show eps-step for eps<1 using the residual bound on A and a decay bound for ((State n)1)1. **)
		                                                                                claim HepsLt1: Rlt eps 1.
		                                                                                { exact (RltI eps 1 HepsR real_1 HepsLt1S). }
				                                                                                claim Hex_c_small:
				                                                                                  exists N:set, N :e omega /\
				                                                                                    forall n:set, n :e omega -> N c= n ->
				                                                                                      ((State n) 1) 1 < eps.
				                                                                                { (** reduce to a dyadic bound eps_ K and a geometric bound for the scalar component **)
				                                                                                  claim HexK: exists K :e omega, eps_ K < eps.
				                                                                                  { exact (exists_eps_lt_pos_Euclid eps HepsR HepsPos). }
				                                                                                  apply HexK.
				                                                                                  let K. assume HK.
				                                                                                  claim HKomega: K :e omega.
				                                                                                  { exact (andEL (K :e omega) (eps_ K < eps) HK). }
				                                                                                  claim HepsKltEpsS: eps_ K < eps.
				                                                                                  { exact (andER (K :e omega) (eps_ K < eps) HK). }
				                                                                                  claim HepsKR: eps_ K :e R.
				                                                                                  { exact (SNoS_omega_real (eps_ K) (SNo_eps_SNoS_omega K HKomega)). }
				                                                                                  claim HepsKltEps: Rlt (eps_ K) eps.
				                                                                                  { exact (RltI (eps_ K) eps HepsKR HepsR HepsKltEpsS). }
				                                                                                  (** remaining goal: find N with ((State n)1)1 < eps_ K uniformly for n>=N **)
				                                                                                  claim HexN: exists N:set, N :e omega /\
				                                                                                    forall n:set, n :e omega -> N c= n ->
				                                                                                      ((State n) 1) 1 < eps_ K.
				                                                                                  { claim HKnat: nat_p K.
				                                                                                    { exact (omega_nat_p K HKomega). }
				                                                                                    claim HKcase: K = 0 \/ exists k:set, nat_p k /\ K = ordsucc k.
				                                                                                    { exact (nat_inv K HKnat). }
				                                                                                    apply HKcase.
				                                                                                    - assume HK0: K = 0.
				                                                                                      witness 0.
				                                                                                      apply andI.
				                                                                                      + exact (nat_p_omega 0 nat_0).
				                                                                                      + let n. assume HnO: n :e omega.
				                                                                                        assume H0sub: 0 c= n.
				                                                                                        prove ((State n) 1) 1 < eps_ K.
				                                                                                        rewrite HK0.
				                                                                                        rewrite eps_0_1.
				                                                                                        exact (HInv_c_lt1 n HnO).
				                                                                                    - assume Hexk: exists k:set, nat_p k /\ K = ordsucc k.
				                                                                                      apply Hexk.
				                                                                                      let k. assume Hkconj: nat_p k /\ K = ordsucc k.
				                                                                                      claim HkNat: nat_p k.
				                                                                                      { exact (andEL (nat_p k) (K = ordsucc k) Hkconj). }
				                                                                                      claim HKeq: K = ordsucc k.
				                                                                                      { exact (andER (nat_p k) (K = ordsucc k) Hkconj). }
				                                                                                      (** TODO: prove geometric decay of the scalar component and compare with eps_(ordsucc k) **)
				                                                                                      set N0 := add_nat K K.
				                                                                                      witness N0.
				                                                                                      apply andI.
				                                                                                      + claim HN0O: N0 :e omega.
				                                                                                        { rewrite (add_nat_add_SNo K HKomega K HKomega).
				                                                                                          exact (add_SNo_In_omega K HKomega K HKomega). }
				                                                                                        exact HN0O.
				                                                                                      + let n. assume HnO: n :e omega.
				                                                                                        assume HN0sub: N0 c= n.
				                                                                                        (** show ((State n) 1) 1 < eps_ K from a dyadic bound at N0 and monotone decay **)
				                                                                                        claim HKnat: nat_p K.
				                                                                                        { exact (omega_nat_p K HKomega). }
				                                                                                        claim HdenS: SNo den.
				                                                                                        { exact (real_SNo den HdenR). }
				                                                                                        claim HdenDef: den = two_thirds.
				                                                                                        { reflexivity. }
				                                                                                        claim HdenLt1: den < 1.
				                                                                                        { rewrite HdenDef.
				                                                                                          exact (RltE_lt two_thirds 1 Rlt_two_thirds_1). }
				                                                                                        set den2 := mul_SNo den den.
				                                                                                        claim Hden2S: SNo den2.
				                                                                                        { exact (SNo_mul_SNo den den HdenS HdenS). }
				                                                                                        claim Hden2Lt_eps1: den2 < eps_ 1.
				                                                                                        { rewrite HdenDef at 1.
				                                                                                          rewrite HdenDef at 2.
				                                                                                          exact two_thirds_sq_lt_eps_1. }
				                                                                                        (** scalar recursion: c_{S m} = c_m times den **)
				                                                                                        claim Hc_step: forall m:set, nat_p m ->
				                                                                                          ((State (ordsucc m)) 1) 1 = mul_SNo (((State m) 1) 1) den.
				                                                                                        { let m. assume HmNat: nat_p m.
				                                                                                          claim HS: State (ordsucc m) = StepState m (State m).
				                                                                                          { exact (nat_primrec_S BaseState StepState m HmNat). }
				                                                                                          rewrite HS.
				                                                                                          set st := State m.
				                                                                                          set g := st 0.
				                                                                                          set rpack := st 1.
				                                                                                          set r := rpack 0.
				                                                                                          set c := rpack 1.
				                                                                                          set gNew := compose_fun X
				                                                                                            (pair_map X g (compose_fun X (u_of r) (mul_const_fun c)))
				                                                                                            add_fun_R.
				                                                                                          set rNew := compose_fun A
				                                                                                            (compose_fun A
				                                                                                              (pair_map A r (compose_fun A (u_of r) neg_fun))
				                                                                                              add_fun_R)
				                                                                                            (div_const_fun den).
				                                                                                          set cNew := mul_SNo c den.
				                                                                                          claim Hdef: StepState m st = (gNew, (rNew, cNew)).
				                                                                                          { reflexivity. }
				                                                                                          claim HtEq: ((StepState m st) 1) 1 = cNew.
				                                                                                          { claim Hinner: (StepState m st) 1 = (rNew, cNew).
				                                                                                            { rewrite Hdef.
				                                                                                              exact (tuple_2_1_eq gNew (rNew, cNew)). }
				                                                                                            rewrite Hinner.
				                                                                                            exact (tuple_2_1_eq rNew cNew). }
				                                                                                          rewrite HtEq.
				                                                                                          claim HcEq: c = ((State m) 1) 1.
				                                                                                          { reflexivity. }
				                                                                                          rewrite HcEq.
				                                                                                          reflexivity. }
				                                                                                        (** monotone decay: c_{S t + a} < c_{t + a} for t in omega **)
				                                                                                        claim Hc_succ_lt: forall t:set, t :e omega ->
				                                                                                          ((State (ordsucc t)) 1) 1 < ((State t) 1) 1.
				                                                                                        { let t. assume HtO: t :e omega.
				                                                                                          claim HtNat: nat_p t.
				                                                                                          { exact (omega_nat_p t HtO). }
				                                                                                          claim HcEq: ((State (ordsucc t)) 1) 1 = mul_SNo (((State t) 1) 1) den.
				                                                                                          { exact (Hc_step t HtNat). }
				                                                                                          rewrite HcEq.
				                                                                                          claim HctR: ((State t) 1) 1 :e R.
				                                                                                          { exact (andEL (((State t) 1) 1 :e R) (0 < ((State t) 1) 1) (HInv_cpos t HtO)). }
				                                                                                          claim HctS: SNo (((State t) 1) 1).
				                                                                                          { exact (real_SNo (((State t) 1) 1) HctR). }
				                                                                                          claim HctPos: 0 < (((State t) 1) 1).
				                                                                                          { exact (andER (((State t) 1) 1 :e R) (0 < ((State t) 1) 1) (HInv_cpos t HtO)). }
				                                                                                          claim HmulLt: mul_SNo den (((State t) 1) 1) < ((State t) 1) 1.
				                                                                                          { exact (mul_SNo_Lt1_pos_Lt den (((State t) 1) 1) HdenS HctS HdenLt1 HctPos). }
				                                                                                          claim HmulEq: mul_SNo den (((State t) 1) 1) = mul_SNo (((State t) 1) 1) den.
				                                                                                          { exact (mul_SNo_com den (((State t) 1) 1) HdenS HctS). }
				                                                                                          rewrite <- HmulEq.
				                                                                                          exact HmulLt. }
				                                                                                        (** dyadic bound at even indices: c_{K+K} < eps_K **)
				                                                                                        claim Hc_even_lt: forall t:set, nat_p t ->
				                                                                                          ((State (add_nat t t)) 1) 1 < eps_ t.
				                                                                                        { apply nat_ind.
				                                                                                          - prove ((State (add_nat 0 0)) 1) 1 < eps_ 0.
				                                                                                            rewrite (add_nat_0R 0) at 1.
				                                                                                            rewrite eps_0_1.
				                                                                                            exact (HInv_c_lt1 0 (nat_p_omega 0 nat_0)).
				                                                                                          - let t. assume HtNat: nat_p t.
				                                                                                            assume IH: ((State (add_nat t t)) 1) 1 < eps_ t.
				                                                                                            prove ((State (add_nat (ordsucc t) (ordsucc t))) 1) 1 < eps_ (ordsucc t).
				                                                                                            set N := add_nat t t.
				                                                                                            claim HNnat: nat_p N.
				                                                                                            { exact (add_nat_p t HtNat t HtNat). }
				                                                                                            claim Hidx: add_nat (ordsucc t) (ordsucc t) = ordsucc (ordsucc N).
				                                                                                            { rewrite (add_nat_SL t HtNat (ordsucc t) (nat_ordsucc t HtNat)).
				                                                                                              rewrite (add_nat_SR t t HtNat).
				                                                                                              reflexivity. }
				                                                                                            rewrite Hidx.
				                                                                                            claim HN0: N :e omega.
				                                                                                            { exact (nat_p_omega N HNnat). }
				                                                                                            claim HcSN: ((State (ordsucc N)) 1) 1 = mul_SNo (((State N) 1) 1) den.
				                                                                                            { exact (Hc_step N HNnat). }
				                                                                                            claim HcSSN: ((State (ordsucc (ordsucc N))) 1) 1 =
				                                                                                              mul_SNo (mul_SNo (((State N) 1) 1) den) den.
				                                                                                            { claim HSNnat: nat_p (ordsucc N).
				                                                                                                { exact (nat_ordsucc N HNnat). }
				                                                                                                rewrite (Hc_step (ordsucc N) HSNnat).
				                                                                                                rewrite HcSN.
				                                                                                                reflexivity. }
				                                                                                            rewrite HcSSN.
				                                                                                            rewrite <- (mul_SNo_assoc (((State N) 1) 1) den den
				                                                                                                              (real_SNo (((State N) 1) 1) (andEL (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0)))
				                                                                                                              HdenS HdenS).
				                                                                                            claim Hden2Def: den2 = mul_SNo den den.
				                                                                                            { reflexivity. }
				                                                                                            rewrite <- Hden2Def.
				                                                                                            claim HcNpos: 0 < ((State N) 1) 1.
				                                                                                            { exact (andER (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0)). }
				                                                                                            claim HcNS: SNo (((State N) 1) 1).
				                                                                                            { exact (real_SNo (((State N) 1) 1) (andEL (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0))). }
				                                                                                            rewrite (mul_SNo_com (((State N) 1) 1) den2 HcNS Hden2S).
				                                                                                            claim Heps1R: (eps_ 1) :e R.
				                                                                                            { exact (SNoS_omega_real (eps_ 1) (SNo_eps_SNoS_omega 1 (nat_p_omega 1 nat_1))). }
				                                                                                            claim Heps1S: SNo (eps_ 1).
				                                                                                            { exact (real_SNo (eps_ 1) Heps1R). }
				                                                                                            claim Heps1pos: 0 < eps_ 1.
				                                                                                            { exact (RltE_lt 0 (eps_ 1) eps_1_pos_R). }
				                                                                                            claim Hmul1: mul_SNo den2 (((State N) 1) 1) < mul_SNo (eps_ 1) (((State N) 1) 1).
				                                                                                            { exact (pos_mul_SNo_Lt' den2 (eps_ 1) (((State N) 1) 1)
				                                                                                                                   Hden2S Heps1S HcNS HcNpos Hden2Lt_eps1). }
				                                                                                            claim Heps_tR: (eps_ t) :e R.
				                                                                                            { exact (SNoS_omega_real (eps_ t) (SNo_eps_SNoS_omega t (nat_p_omega t HtNat))). }
				                                                                                            claim Heps_tS: SNo (eps_ t).
				                                                                                            { exact (real_SNo (eps_ t) Heps_tR). }
				                                                                                            claim Hmul2: mul_SNo (eps_ 1) (((State N) 1) 1) < mul_SNo (eps_ 1) (eps_ t).
				                                                                                            { claim HcomL: mul_SNo (eps_ 1) (((State N) 1) 1) = mul_SNo (((State N) 1) 1) (eps_ 1).
				                                                                                              { exact (mul_SNo_com (eps_ 1) (((State N) 1) 1) Heps1S HcNS). }
				                                                                                              claim HcomR: mul_SNo (eps_ 1) (eps_ t) = mul_SNo (eps_ t) (eps_ 1).
				                                                                                              { exact (mul_SNo_com (eps_ 1) (eps_ t) Heps1S Heps_tS). }
				                                                                                              rewrite HcomL.
				                                                                                              rewrite HcomR.
				                                                                                              exact (pos_mul_SNo_Lt' (((State N) 1) 1) (eps_ t) (eps_ 1)
				                                                                                                                     HcNS Heps_tS Heps1S Heps1pos IH). }
				                                                                                            claim HmulTra: mul_SNo den2 (((State N) 1) 1) < mul_SNo (eps_ 1) (eps_ t).
				                                                                                            { exact (SNoLt_tra (mul_SNo den2 (((State N) 1) 1))
				                                                                                                               (mul_SNo (eps_ 1) (((State N) 1) 1))
				                                                                                                               (mul_SNo (eps_ 1) (eps_ t))
				                                                                                                               (SNo_mul_SNo den2 (((State N) 1) 1) Hden2S HcNS)
				                                                                                                               (SNo_mul_SNo (eps_ 1) (((State N) 1) 1) Heps1S HcNS)
				                                                                                                               (SNo_mul_SNo (eps_ 1) (eps_ t) Heps1S Heps_tS)
				                                                                                                               Hmul1 Hmul2). }
				                                                                                            claim HepsEq: mul_SNo (eps_ 1) (eps_ t) = eps_ (ordsucc t).
				                                                                                            { rewrite (mul_SNo_eps_eps_add_SNo 1 (nat_p_omega 1 nat_1) t (nat_p_omega t HtNat)).
				                                                                                              claim Hordt: ordinal t.
				                                                                                              { exact (nat_p_ordinal t HtNat). }
				                                                                                              rewrite <- (ordinal_ordsucc_SNo_eq t Hordt).
				                                                                                              reflexivity. }
				                                                                                            rewrite <- HepsEq.
				                                                                                            exact HmulTra. }
				                                                                                        claim HcN0: ((State N0) 1) 1 < eps_ K.
				                                                                                        { exact (Hc_even_lt K HKnat). }
				                                                                                        (** show n is N0 plus a natural shift and reduce to k=0 or successor **)
				                                                                                        claim HnNat: nat_p n.
				                                                                                        { exact (omega_nat_p n HnO). }
				                                                                                        claim HN0O: N0 :e omega.
				                                                                                        { rewrite (add_nat_add_SNo K HKomega K HKomega).
				                                                                                          exact (add_SNo_In_omega K HKomega K HKomega). }
				                                                                                        claim HN0Nat: nat_p N0.
				                                                                                        { exact (omega_nat_p N0 HN0O). }
				                                                                                        claim Hexk: exists k:set, nat_p k /\ n = add_nat k N0.
				                                                                                        { exact (nat_Subq_add_ex N0 HN0Nat n HnNat HN0sub). }
				                                                                                        apply Hexk.
				                                                                                        let k1. assume Hk1.
				                                                                                        claim Hk1Nat: nat_p k1.
				                                                                                        { exact (andEL (nat_p k1) (n = add_nat k1 N0) Hk1). }
				                                                                                        claim HnEq: n = add_nat k1 N0.
				                                                                                        { exact (andER (nat_p k1) (n = add_nat k1 N0) Hk1). }
				                                                                                        rewrite HnEq.
				                                                                                        claim Hkcase: k1 = 0 \/ exists j:set, nat_p j /\ k1 = ordsucc j.
				                                                                                        { exact (nat_inv k1 Hk1Nat). }
				                                                                                        apply Hkcase.
				                                                                                        - assume Hk10: k1 = 0.
				                                                                                          rewrite Hk10.
				                                                                                          rewrite (add_nat_0L N0 HN0Nat).
				                                                                                          exact HcN0.
				                                                                                        - assume Hk1S: exists j:set, nat_p j /\ k1 = ordsucc j.
				                                                                                          apply Hk1S.
				                                                                                          let j. assume Hj.
				                                                                                          claim HjNat: nat_p j.
				                                                                                          { exact (andEL (nat_p j) (k1 = ordsucc j) Hj). }
				                                                                                          claim Hk1Eq: k1 = ordsucc j.
				                                                                                          { exact (andER (nat_p j) (k1 = ordsucc j) Hj). }
				                                                                                          rewrite Hk1Eq.
				                                                                                          claim Hdec: forall j:set, nat_p j ->
				                                                                                            ((State (add_nat (ordsucc j) N0)) 1) 1 < ((State N0) 1) 1.
				                                                                                          { apply nat_ind.
				                                                                                            - prove ((State (add_nat (ordsucc 0) N0)) 1) 1 < ((State N0) 1) 1.
				                                                                                              rewrite (add_nat_SL 0 nat_0 N0 HN0Nat).
				                                                                                              rewrite (add_nat_0L N0 HN0Nat).
				                                                                                              exact (Hc_succ_lt N0 HN0O).
				                                                                                            - let j. assume HjNat: nat_p j.
				                                                                                              assume IHj: ((State (add_nat (ordsucc j) N0)) 1) 1 < ((State N0) 1) 1.
				                                                                                              prove ((State (add_nat (ordsucc (ordsucc j)) N0)) 1) 1 < ((State N0) 1) 1.
				                                                                                              rewrite (add_nat_SL (ordsucc j) (nat_ordsucc j HjNat) N0 HN0Nat).
				                                                                                              claim HstepLt: ((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1 < ((State (add_nat (ordsucc j) N0)) 1) 1.
				                                                                                              { exact (Hc_succ_lt (add_nat (ordsucc j) N0)
				                                                                                                                (nat_p_omega (add_nat (ordsucc j) N0)
				                                                                                                                  (add_nat_p (ordsucc j) (nat_ordsucc j HjNat) N0 HN0Nat))). }
				                                                                                              claim HaO: ordsucc (add_nat (ordsucc j) N0) :e omega.
				                                                                                              { exact (nat_p_omega (ordsucc (add_nat (ordsucc j) N0))
				                                                                                                (nat_ordsucc (add_nat (ordsucc j) N0)
				                                                                                                  (add_nat_p (ordsucc j) (nat_ordsucc j HjNat) N0 HN0Nat))). }
				                                                                                              claim HbO: add_nat (ordsucc j) N0 :e omega.
				                                                                                              { exact (nat_p_omega (add_nat (ordsucc j) N0)
				                                                                                                (add_nat_p (ordsucc j) (nat_ordsucc j HjNat) N0 HN0Nat)). }
				                                                                                              claim HaR: ((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1 :e R.
				                                                                                              { exact (andEL (((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1 :e R)
				                                                                                                         (0 < ((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1)
				                                                                                                         (HInv_cpos (ordsucc (add_nat (ordsucc j) N0)) HaO)). }
				                                                                                              claim HbR: ((State (add_nat (ordsucc j) N0)) 1) 1 :e R.
				                                                                                              { exact (andEL (((State (add_nat (ordsucc j) N0)) 1) 1 :e R)
				                                                                                                         (0 < ((State (add_nat (ordsucc j) N0)) 1) 1)
				                                                                                                         (HInv_cpos (add_nat (ordsucc j) N0) HbO)). }
				                                                                                              claim HcR0: ((State N0) 1) 1 :e R.
				                                                                                              { exact (andEL (((State N0) 1) 1 :e R) (0 < ((State N0) 1) 1) (HInv_cpos N0 HN0O)). }
				                                                                                              claim HaS: SNo (((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1).
				                                                                                              { exact (real_SNo (((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1) HaR). }
				                                                                                              claim HbS: SNo (((State (add_nat (ordsucc j) N0)) 1) 1).
				                                                                                              { exact (real_SNo (((State (add_nat (ordsucc j) N0)) 1) 1) HbR). }
				                                                                                              claim HcS0: SNo (((State N0) 1) 1).
				                                                                                              { exact (real_SNo (((State N0) 1) 1) HcR0). }
				                                                                                              exact (SNoLt_tra (((State (ordsucc (add_nat (ordsucc j) N0))) 1) 1)
				                                                                                                               (((State (add_nat (ordsucc j) N0)) 1) 1)
				                                                                                                               (((State N0) 1) 1)
				                                                                                                               HaS HbS HcS0 HstepLt IHj). }
				                                                                                          claim HltN0: ((State (add_nat (ordsucc j) N0)) 1) 1 < ((State N0) 1) 1.
				                                                                                          { exact (Hdec j HjNat). }
				                                                                                          claim HxO: add_nat (ordsucc j) N0 :e omega.
				                                                                                          { exact (nat_p_omega (add_nat (ordsucc j) N0)
				                                                                                            (add_nat_p (ordsucc j) (nat_ordsucc j HjNat) N0 HN0Nat)). }
				                                                                                          claim HxR: ((State (add_nat (ordsucc j) N0)) 1) 1 :e R.
				                                                                                          { exact (andEL (((State (add_nat (ordsucc j) N0)) 1) 1 :e R)
				                                                                                                     (0 < ((State (add_nat (ordsucc j) N0)) 1) 1)
				                                                                                                     (HInv_cpos (add_nat (ordsucc j) N0) HxO)). }
				                                                                                          claim HxS: SNo (((State (add_nat (ordsucc j) N0)) 1) 1).
				                                                                                          { exact (real_SNo (((State (add_nat (ordsucc j) N0)) 1) 1) HxR). }
				                                                                                          claim HN0R: ((State N0) 1) 1 :e R.
				                                                                                          { exact (andEL (((State N0) 1) 1 :e R) (0 < ((State N0) 1) 1) (HInv_cpos N0 HN0O)). }
				                                                                                          claim HN0S: SNo (((State N0) 1) 1).
				                                                                                          { exact (real_SNo (((State N0) 1) 1) HN0R). }
				                                                                                          claim HepsKS: SNo (eps_ K).
				                                                                                          { exact (real_SNo (eps_ K) HepsKR). }
				                                                                                          exact (SNoLt_tra (((State (add_nat (ordsucc j) N0)) 1) 1)
				                                                                                                           (((State N0) 1) 1)
				                                                                                                           (eps_ K)
				                                                                                                           HxS HN0S HepsKS HltN0 HcN0). }
				                                                                                  apply HexN.
				                                                                                  let N. assume HN.
				                                                                                  witness N.
				                                                                                  apply andI.
				                                                                                  - exact (andEL (N :e omega)
				                                                                                      (forall n:set, n :e omega -> N c= n -> ((State n) 1) 1 < eps_ K)
				                                                                                      HN).
				                                                                                  - let n. assume HnO: n :e omega.
				                                                                                    assume HNsub: N c= n.
				                                                                                    claim HNprop:
				                                                                                      forall t:set, t :e omega -> N c= t -> ((State t) 1) 1 < eps_ K.
				                                                                                    { exact (andER (N :e omega)
				                                                                                        (forall n:set, n :e omega -> N c= n -> ((State n) 1) 1 < eps_ K)
				                                                                                        HN). }
				                                                                                    claim HcLtEpsK: ((State n) 1) 1 < eps_ K.
				                                                                                    { exact (HNprop n HnO HNsub). }
				                                                                                    claim HcR: ((State n) 1) 1 :e R.
				                                                                                    { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
				                                                                                    claim HcS: SNo (((State n) 1) 1).
				                                                                                    { exact (real_SNo (((State n) 1) 1) HcR). }
				                                                                                    claim HepsKS: SNo (eps_ K).
				                                                                                    { exact (real_SNo (eps_ K) HepsKR). }
				                                                                                    claim HepsS0: SNo eps.
				                                                                                    { exact (real_SNo eps HepsR). }
				                                                                                    exact (SNoLt_tra (((State n) 1) 1) (eps_ K) eps HcS HepsKS HepsS0
				                                                                                      HcLtEpsK HepsKltEpsS). }
				                                                                                apply Hex_c_small.
		                                                                                let N. assume HNpair.
		                                                                                witness N.
		                                                                                apply andI.
		                                                                                + exact (andEL (N :e omega)
		                                                                                    (forall n:set, n :e omega -> N c= n -> ((State n) 1) 1 < eps)
		                                                                                    HNpair).
		                                                                                + let n. assume HnO: n :e omega.
		                                                                                  assume HNsub: N c= n.
		                                                                                  prove Rlt (apply_fun R_bounded_metric (apply_fun seq2 n, lim)) eps.
		                                                                                  claim Hseq2nR: apply_fun seq2 n :e R.
		                                                                                  { exact (Hseq2On n HnO). }
		                                                                                  claim HlimR: lim :e R.
		                                                                                  { exact (Hf_R x HxA). }
		                                                                                  claim Hpair: (apply_fun seq2 n, lim) :e setprod R R.
		                                                                                  { exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun seq2 n) lim Hseq2nR HlimR). }
		                                                                                  claim HdefM: R_bounded_metric =
		                                                                                    graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).
		                                                                                  { reflexivity. }
		                                                                                  rewrite HdefM.
		                                                                                  rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1))
		                                                                                                        (apply_fun seq2 n, lim) Hpair).
		                                                                                  rewrite (tuple_2_0_eq (apply_fun seq2 n) lim).
		                                                                                  rewrite (tuple_2_1_eq (apply_fun seq2 n) lim).
		                                                                                  set a := apply_fun seq2 n.
		                                                                                  set b := lim.
		                                                                                  set t := add_SNo a (minus_SNo b).
		                                                                                  claim HmbR: minus_SNo b :e R.
		                                                                                  { exact (real_minus_SNo b HlimR). }
		                                                                                  claim HtR: t :e R.
		                                                                                  { exact (real_add_SNo a Hseq2nR (minus_SNo b) HmbR). }
		                                                                                  claim HtS: SNo t.
		                                                                                  { exact (real_SNo t HtR). }
		                                                                                  claim HaS: SNo a.
		                                                                                  { exact (real_SNo a Hseq2nR). }
		                                                                                  claim HbS: SNo b.
		                                                                                  { exact (real_SNo b HlimR). }
		                                                                                  claim HabsEq: abs_SNo t = abs_SNo (add_SNo b (minus_SNo a)).
		                                                                                  { exact (abs_SNo_dist_swap a b HaS HbS). }
		                                                                                  claim HaEq: a = apply_fun ((State n) 0) x.
		                                                                                  { claim Hseq2def: seq2 = graph omega (fun n0:set => apply_fun ((State n0) 0) x).
		                                                                                    { reflexivity. }
		                                                                                    rewrite Hseq2def.
		                                                                                    rewrite (apply_fun_graph omega (fun n0:set => apply_fun ((State n0) 0) x) n HnO).
		                                                                                    reflexivity. }
		                                                                                  claim Hident:
		                                                                                    add_SNo a
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) = b.
		                                                                                  { rewrite HaEq.
		                                                                                    exact (HInv_residual_identity_A n HnO x HxA). }
		                                                                                  claim HrcEq:
		                                                                                    add_SNo b (minus_SNo a) =
		                                                                                      mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                  { rewrite <- Hident at 1.
		                                                                                    set rc := mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                    claim HrcR: rc :e R.
		                                                                                    { claim Hrfun: continuous_map A Ta I Ti (((State n) 1) 0).
		                                                                                      { exact (HInv_r_contI n HnO). }
		                                                                                      claim Hrfun_on: function_on (((State n) 1) 0) A I.
		                                                                                      { exact (continuous_map_function_on A Ta I Ti (((State n) 1) 0) Hrfun). }
		                                                                                      claim HrxI: apply_fun (((State n) 1) 0) x :e I.
		                                                                                      { exact (Hrfun_on x HxA). }
		                                                                                      claim HrxR: apply_fun (((State n) 1) 0) x :e R.
		                                                                                      { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun (((State n) 1) 0) x) HrxI). }
		                                                                                      claim HcR: ((State n) 1) 1 :e R.
		                                                                                      { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                      exact (real_mul_SNo (apply_fun (((State n) 1) 0) x) HrxR (((State n) 1) 1) HcR). }
		                                                                                    claim HrcS: SNo rc.
		                                                                                    { exact (real_SNo rc HrcR). }
		                                                                                    claim HaS0: SNo a.
		                                                                                    { exact (real_SNo a Hseq2nR). }
		                                                                                    rewrite (add_SNo_com a rc HaS0 HrcS) at 1.
		                                                                                    exact (add_SNo_minus_R2 rc a HrcS HaS0). }
		                                                                                  claim HcR: ((State n) 1) 1 :e R.
		                                                                                  { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                  claim HcS: SNo (((State n) 1) 1).
		                                                                                  { exact (real_SNo (((State n) 1) 1) HcR). }
		                                                                                  claim HcLtEps: ((State n) 1) 1 < eps.
		                                                                                  { exact (andER (N :e omega)
		                                                                                      (forall n0:set, n0 :e omega -> N c= n0 -> ((State n0) 1) 1 < eps)
		                                                                                      HNpair n HnO HNsub). }
		                                                                                  claim Hcpos: 0 < ((State n) 1) 1.
		                                                                                  { exact (andER (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                  claim H0le_c: 0 <= ((State n) 1) 1.
		                                                                                  { exact (SNoLtLe 0 (((State n) 1) 1) Hcpos). }
		                                                                                  claim Hrfun: continuous_map A Ta I Ti (((State n) 1) 0).
		                                                                                  { exact (HInv_r_contI n HnO). }
		                                                                                  claim Hrfun_on: function_on (((State n) 1) 0) A I.
		                                                                                  { exact (continuous_map_function_on A Ta I Ti (((State n) 1) 0) Hrfun). }
		                                                                                  claim HrxI: apply_fun (((State n) 1) 0) x :e I.
		                                                                                  { exact (Hrfun_on x HxA). }
		                                                                                  claim HrxR: apply_fun (((State n) 1) 0) x :e R.
		                                                                                  { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun (((State n) 1) 0) x) HrxI). }
		                                                                                  claim HprodI: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) :e
		                                                                                    closed_interval (minus_SNo (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (mul_nonneg_closed_interval_minus1_1 (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)
		                                                                                    HrxI HcR H0le_c). }
		                                                                                  claim Hmcr: (minus_SNo (((State n) 1) 1)) :e R.
		                                                                                  { exact (real_minus_SNo (((State n) 1) 1) HcR). }
		                                                                                  claim HprodR: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) :e R.
		                                                                                  { exact (real_mul_SNo (apply_fun (((State n) 1) 0) x) HrxR (((State n) 1) 1) HcR). }
		                                                                                  claim HprodS: SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)).
		                                                                                  { exact (real_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) HprodR). }
		                                                                                  claim Hbounds:
		                                                                                    Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) /\
		                                                                                    Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (closed_interval_bounds (minus_SNo (((State n) 1) 1)) (((State n) 1) 1)
		                                                                                    (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) Hmcr HcR HprodI). }
		                                                                                  claim HloRle:
		                                                                                    Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)).
		                                                                                  { exact (andEL
		                                                                                      (Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1))
		                                                                                      Hbounds). }
		                                                                                  claim HhiRle:
		                                                                                    Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (andER
		                                                                                      (Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1))
		                                                                                      Hbounds). }
		                                                                                  claim HloLe: minus_SNo (((State n) 1) 1) <= mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                  { exact (SNoLe_of_Rle (minus_SNo (((State n) 1) 1))
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      HloRle). }
		                                                                                  claim HhiLe: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) <= ((State n) 1) 1.
		                                                                                  { exact (SNoLe_of_Rle
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      (((State n) 1) 1)
		                                                                                      HhiRle). }
		                                                                                  claim HabsLe: abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) <= ((State n) 1) 1.
		                                                                                  { exact (abs_SNo_Le_of_bounds
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      (((State n) 1) 1)
		                                                                                      HprodS
		                                                                                      HcS
		                                                                                      HloLe
		                                                                                      HhiLe). }
		                                                                                  claim HabsR: abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) :e R.
		                                                                                  { exact (abs_SNo_in_R (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) HprodR). }
		                                                                                  claim HabsS: SNo (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))).
		                                                                                  { exact (real_SNo (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))) HabsR). }
		                                                                                  claim HabsLtEps:
		                                                                                    abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) < eps.
		                                                                                  { exact (SNoLeLt_tra
		                                                                                      (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (((State n) 1) 1)
		                                                                                      eps
		                                                                                      HabsS
		                                                                                      HcS
		                                                                                      HepsS
		                                                                                      HabsLe
		                                                                                      HcLtEps). }
		                                                                                  claim HabstLtEps: abs_SNo t < eps.
		                                                                                  { rewrite HabsEq.
		                                                                                    rewrite HrcEq.
		                                                                                    exact HabsLtEps. }
		                                                                                  exact (abs_lt_lt1_imp_R_bounded_distance_lt a b eps
		                                                                                    Hseq2nR HlimR HepsR HepsLt1 HabstLtEps).
		                                                                              - assume HepsEq1: eps = 1.
		                                                                                (** TODO: show eventually R_bounded_distance < 1 using abs difference < 1 from the residual bound on A. **)
		                                                                                rewrite HepsEq1.
		                                                                                witness 0.
		                                                                                apply andI.
		                                                                                + exact (nat_p_omega 0 nat_0).
		                                                                                + let n. assume HnO: n :e omega.
		                                                                                  assume H0sub: 0 c= n.
		                                                                                  prove Rlt (apply_fun R_bounded_metric (apply_fun seq2 n, lim)) 1.
		                                                                                  claim Hseq2nR: apply_fun seq2 n :e R.
		                                                                                  { exact (Hseq2On n HnO). }
		                                                                                  claim HlimR: lim :e R.
		                                                                                  { exact (Hf_R x HxA). }
		                                                                                  claim Hpair: (apply_fun seq2 n, lim) :e setprod R R.
		                                                                                  { exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun seq2 n) lim Hseq2nR HlimR). }
		                                                                                  claim HdefM: R_bounded_metric =
		                                                                                    graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).
		                                                                                  { reflexivity. }
		                                                                                  rewrite HdefM.
		                                                                                  rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1))
		                                                                                                        (apply_fun seq2 n, lim) Hpair).
		                                                                                  rewrite (tuple_2_0_eq (apply_fun seq2 n) lim).
		                                                                                  rewrite (tuple_2_1_eq (apply_fun seq2 n) lim).
		                                                                                  set a := apply_fun seq2 n.
		                                                                                  set b := lim.
		                                                                                  set t := add_SNo a (minus_SNo b).
		                                                                                  claim HmbR: minus_SNo b :e R.
		                                                                                  { exact (real_minus_SNo b HlimR). }
		                                                                                  claim HtR: t :e R.
		                                                                                  { exact (real_add_SNo a Hseq2nR (minus_SNo b) HmbR). }
		                                                                                  claim HtS: SNo t.
		                                                                                  { exact (real_SNo t HtR). }
		                                                                                  claim HaS: SNo a.
		                                                                                  { exact (real_SNo a Hseq2nR). }
		                                                                                  claim HbS: SNo b.
		                                                                                  { exact (real_SNo b HlimR). }
		                                                                                  claim HabsEq: abs_SNo t = abs_SNo (add_SNo b (minus_SNo a)).
		                                                                                  { exact (abs_SNo_dist_swap a b HaS HbS). }
		                                                                                  claim HaEq: a = apply_fun ((State n) 0) x.
		                                                                                  { claim Hseq2def: seq2 = graph omega (fun n0:set => apply_fun ((State n0) 0) x).
		                                                                                    { reflexivity. }
		                                                                                    rewrite Hseq2def.
		                                                                                    rewrite (apply_fun_graph omega (fun n0:set => apply_fun ((State n0) 0) x) n HnO).
		                                                                                    reflexivity. }
		                                                                                  claim Hident:
		                                                                                    add_SNo a
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) = b.
		                                                                                  { rewrite HaEq.
		                                                                                    exact (HInv_residual_identity_A n HnO x HxA). }
		                                                                                  claim HrcEq:
		                                                                                    add_SNo b (minus_SNo a) =
		                                                                                      mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                  { rewrite <- Hident at 1.
		                                                                                    set rc := mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                    claim HrcR: rc :e R.
		                                                                                    { claim Hrfun: continuous_map A Ta I Ti (((State n) 1) 0).
		                                                                                      { exact (HInv_r_contI n HnO). }
		                                                                                      claim Hrfun_on: function_on (((State n) 1) 0) A I.
		                                                                                      { exact (continuous_map_function_on A Ta I Ti (((State n) 1) 0) Hrfun). }
		                                                                                      claim HrxI: apply_fun (((State n) 1) 0) x :e I.
		                                                                                      { exact (Hrfun_on x HxA). }
		                                                                                      claim HrxR: apply_fun (((State n) 1) 0) x :e R.
		                                                                                      { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun (((State n) 1) 0) x) HrxI). }
		                                                                                      claim HcR: ((State n) 1) 1 :e R.
		                                                                                      { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                      exact (real_mul_SNo (apply_fun (((State n) 1) 0) x) HrxR (((State n) 1) 1) HcR). }
		                                                                                    claim HrcS: SNo rc.
		                                                                                    { exact (real_SNo rc HrcR). }
		                                                                                    claim HaS0: SNo a.
		                                                                                    { exact (real_SNo a Hseq2nR). }
		                                                                                    rewrite (add_SNo_com a rc HaS0 HrcS) at 1.
		                                                                                    exact (add_SNo_minus_R2 rc a HrcS HaS0). }
		                                                                                  claim HcR: ((State n) 1) 1 :e R.
		                                                                                  { exact (andEL (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                  claim HcS: SNo (((State n) 1) 1).
		                                                                                  { exact (real_SNo (((State n) 1) 1) HcR). }
		                                                                                  claim HcLt1: ((State n) 1) 1 < 1.
		                                                                                  { exact (HInv_c_lt1 n HnO). }
		                                                                                  claim Hcpos: 0 < ((State n) 1) 1.
		                                                                                  { exact (andER (((State n) 1) 1 :e R) (0 < ((State n) 1) 1) (HInv_cpos n HnO)). }
		                                                                                  claim H0le_c: 0 <= ((State n) 1) 1.
		                                                                                  { exact (SNoLtLe 0 (((State n) 1) 1) Hcpos). }
		                                                                                  claim Hrfun: continuous_map A Ta I Ti (((State n) 1) 0).
		                                                                                  { exact (HInv_r_contI n HnO). }
		                                                                                  claim Hrfun_on: function_on (((State n) 1) 0) A I.
		                                                                                  { exact (continuous_map_function_on A Ta I Ti (((State n) 1) 0) Hrfun). }
		                                                                                  claim HrxI: apply_fun (((State n) 1) 0) x :e I.
		                                                                                  { exact (Hrfun_on x HxA). }
		                                                                                  claim HrxR: apply_fun (((State n) 1) 0) x :e R.
		                                                                                  { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun (((State n) 1) 0) x) HrxI). }
		                                                                                  claim HrxS: SNo (apply_fun (((State n) 1) 0) x).
		                                                                                  { exact (real_SNo (apply_fun (((State n) 1) 0) x) HrxR). }
		                                                                                  claim HprodI: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) :e
		                                                                                    closed_interval (minus_SNo (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (mul_nonneg_closed_interval_minus1_1 (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)
		                                                                                    HrxI HcR H0le_c). }
		                                                                                  claim Hmcr: (minus_SNo (((State n) 1) 1)) :e R.
		                                                                                  { exact (real_minus_SNo (((State n) 1) 1) HcR). }
		                                                                                  claim HprodR: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) :e R.
		                                                                                  { exact (real_mul_SNo (apply_fun (((State n) 1) 0) x) HrxR (((State n) 1) 1) HcR). }
		                                                                                  claim HprodS: SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)).
		                                                                                  { exact (real_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) HprodR). }
		                                                                                  claim Hbounds:
		                                                                                    Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) /\
		                                                                                    Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (closed_interval_bounds (minus_SNo (((State n) 1) 1)) (((State n) 1) 1)
		                                                                                    (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) Hmcr HcR HprodI). }
		                                                                                  claim HloRle:
		                                                                                    Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)).
		                                                                                  { exact (andEL
		                                                                                      (Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1))
		                                                                                      Hbounds). }
		                                                                                  claim HhiRle:
		                                                                                    Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1).
		                                                                                  { exact (andER
		                                                                                      (Rle (minus_SNo (((State n) 1) 1)) (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (Rle (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) (((State n) 1) 1))
		                                                                                      Hbounds). }
		                                                                                  claim HloLe: minus_SNo (((State n) 1) 1) <= mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1).
		                                                                                  { exact (SNoLe_of_Rle (minus_SNo (((State n) 1) 1))
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      HloRle). }
		                                                                                  claim HhiLe: mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1) <= ((State n) 1) 1.
		                                                                                  { exact (SNoLe_of_Rle
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      (((State n) 1) 1)
		                                                                                      HhiRle). }
		                                                                                  claim HabsLe: abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) <= ((State n) 1) 1.
		                                                                                  { exact (abs_SNo_Le_of_bounds
		                                                                                      (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))
		                                                                                      (((State n) 1) 1)
		                                                                                      HprodS
		                                                                                      HcS
		                                                                                      HloLe
		                                                                                      HhiLe). }
		                                                                                  claim HabsR: abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) :e R.
		                                                                                  { exact (abs_SNo_in_R (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) HprodR). }
		                                                                                  claim HabsS: SNo (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))).
		                                                                                  { exact (real_SNo (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))) HabsR). }
		                                                                                  claim HabsLt1:
		                                                                                    abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)) < 1.
		                                                                                  { exact (SNoLeLt_tra
		                                                                                      (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      (((State n) 1) 1)
		                                                                                      1
		                                                                                      HabsS
		                                                                                      HcS
		                                                                                      SNo_1
		                                                                                      HabsLe
		                                                                                      HcLt1). }
		                                                                                  claim HabsLt1R: Rlt (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1))) 1.
		                                                                                  { exact (RltI
		                                                                                      (abs_SNo (mul_SNo (apply_fun (((State n) 1) 0) x) (((State n) 1) 1)))
		                                                                                      1
		                                                                                      HabsR
		                                                                                      real_1
		                                                                                      HabsLt1). }
		                                                                                  claim HabstLt1: Rlt (abs_SNo t) 1.
		                                                                                  { rewrite HabsEq.
		                                                                                    rewrite HrcEq.
		                                                                                    exact HabsLt1R. }
		                                                                                  claim Hbddef: R_bounded_distance a b =
		                                                                                    If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
		                                                                                  { reflexivity. }
		                                                                                  rewrite Hbddef.
		                                                                                  rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 HabstLt1).
		                                                                                  exact HabstLt1.
	                                                                              - assume H1LtEpsS: 1 < eps.
	                                                                                claim H1LtEps: Rlt 1 eps.
	                                                                                { exact (RltI 1 eps real_1 HepsR H1LtEpsS). }
	                                                                                witness 0.
	                                                                                apply andI.
	                                                                                + exact (nat_p_omega 0 nat_0).
	                                                                                + let n. assume HnO: n :e omega.
	                                                                                  assume H0sub: 0 c= n.
	                                                                                  prove Rlt (apply_fun R_bounded_metric (apply_fun seq2 n, lim)) eps.
	                                                                                  claim Hseq2nR: apply_fun seq2 n :e R.
	                                                                                  { exact (Hseq2On n HnO). }
	                                                                                  claim HlimR: lim :e R.
	                                                                                  { exact (Hf_R x HxA). }
	                                                                                  claim Hpair: (apply_fun seq2 n, lim) :e setprod R R.
	                                                                                  { exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun seq2 n) lim Hseq2nR HlimR). }
	                                                                                  claim HdefM: R_bounded_metric =
	                                                                                    graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).
	                                                                                  { reflexivity. }
	                                                                                  rewrite HdefM.
	                                                                                  rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1))
	                                                                                                        (apply_fun seq2 n, lim) Hpair).
	                                                                                  rewrite (tuple_2_0_eq (apply_fun seq2 n) lim).
	                                                                                  rewrite (tuple_2_1_eq (apply_fun seq2 n) lim).
	                                                                                  claim Hle1: Rle (R_bounded_distance (apply_fun seq2 n) lim) 1.
	                                                                                  { exact (R_bounded_distance_le_1 (apply_fun seq2 n) lim Hseq2nR HlimR). }
	                                                                                  exact (Rle_Rlt_tra (R_bounded_distance (apply_fun seq2 n) lim) 1 eps Hle1 H1LtEps). }
															          exact (sequence_converges_metric_imp_converges_to_metric_topology
															            R R_bounded_metric seq2 lim HconvM). }
															        exact Hseq2_conv.
																    - (** uniform Cauchy (to be proved from a geometric tail estimate for the correction terms) **)
																      let eps. assume HepsR: eps :e R. assume HepsPos: Rlt 0 eps.
																      prove exists N:set, N :e omega /\
																        forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																          forall x:set, x :e X ->
																            Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps.
																      (** TODO: derive from the recursive definition of State and the bounds u_of(r) :e I0 with coefficients (2/3)^k. **)
																      (** TODO: pick N using an eps_N tail bound smaller than eps and compare in the bounded metric. **)
																	      claim HepsS: SNo eps.
																	      { exact (real_SNo eps HepsR). }
																	      claim Huc_small:
																	        forall eps0:set, eps0 :e R -> Rlt 0 eps0 -> Rlt eps0 1 ->
																	          exists N:set, N :e omega /\
																	            forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	              forall x:set, x :e X ->
																	                Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps0.
																	      { let eps0. assume Heps0R: eps0 :e R. assume Heps0Pos: Rlt 0 eps0. assume Heps0Lt1: Rlt eps0 1.
																	        claim Heps0S: SNo eps0.
																	        { exact (real_SNo eps0 Heps0R). }
																	        set eta := mul_SNo eps0 (eps_ 1).
																	        claim HetaR: eta :e R.
																	        { exact (real_mul_SNo eps0 Heps0R (eps_ 1) eps_1_in_R). }
																	        claim HetaS: SNo eta.
																	        { exact (real_SNo eta HetaR). }
																	        claim Heps0PosS: 0 < eps0.
																	        { exact (RltE_lt 0 eps0 Heps0Pos). }
																	        claim Heps1S: SNo (eps_ 1).
																	        { exact (real_SNo (eps_ 1) eps_1_in_R). }
																	        claim Heps1PosS: 0 < eps_ 1.
																	        { exact (RltE_lt 0 (eps_ 1) eps_1_pos_R). }
																	        claim HetaPosS: 0 < eta.
																	        { exact (mul_SNo_pos_pos eps0 (eps_ 1) Heps0S Heps1S Heps0PosS Heps1PosS). }
																	        claim HetaPos: Rlt 0 eta.
																	        { exact (RltI 0 eta real_0 HetaR HetaPosS). }
																	        claim HexK: exists K :e omega, eps_ K < eta.
																	        { exact (exists_eps_lt_pos_Euclid eta HetaR HetaPos). }
																	        apply HexK.
																	        let K. assume HK.
																	        claim HKomega: K :e omega.
																	        { exact (andEL (K :e omega) (eps_ K < eta) HK). }
																	        claim HKnat: nat_p K.
																	        { exact (omega_nat_p K HKomega). }
																	        claim HepsKltEtaS: eps_ K < eta.
																	        { exact (andER (K :e omega) (eps_ K < eta) HK). }
																	        claim HepsKR: eps_ K :e R.
																	        { exact (SNoS_omega_real (eps_ K) (SNo_eps_SNoS_omega K HKomega)). }
																	        claim HepsKS: SNo (eps_ K).
																	        { exact (real_SNo (eps_ K) HepsKR). }
																	        set N0 := add_nat K K.
																	        claim HN0O: N0 :e omega.
																	        { rewrite (add_nat_add_SNo K HKomega K HKomega).
																	          exact (add_SNo_In_omega K HKomega K HKomega). }
																	        claim HN0Nat: nat_p N0.
																	        { exact (omega_nat_p N0 HN0O). }
																	        claim HdenS: SNo den.
																	        { exact (real_SNo den HdenR). }
																	        claim HdenDef: den = two_thirds.
																	        { reflexivity. }
																	        claim HdenLt1: den < 1.
																	        { rewrite HdenDef.
																	          exact (RltE_lt two_thirds 1 Rlt_two_thirds_1). }
																	        set den2 := mul_SNo den den.
																	        claim Hden2S: SNo den2.
																	        { exact (SNo_mul_SNo den den HdenS HdenS). }
																	        claim Hden2Lt_eps1: den2 < eps_ 1.
																	        { rewrite HdenDef at 1.
																	          rewrite HdenDef at 2.
																	          exact two_thirds_sq_lt_eps_1. }
																	        claim Hc_step: forall m:set, nat_p m ->
																	          ((State (ordsucc m)) 1) 1 = mul_SNo (((State m) 1) 1) den.
																	        { let m. assume HmNat: nat_p m.
																	          claim HS: State (ordsucc m) = StepState m (State m).
																	          { exact (nat_primrec_S BaseState StepState m HmNat). }
																	          rewrite HS.
																	          set st := State m.
																	          set c := (st 1) 1.
																	          set cNew := mul_SNo c den.
																	          claim Hdef: StepState m st =
																	            (compose_fun X
																	               (pair_map X
																	                 (st 0)
																	                 (compose_fun X (u_of ((st 1) 0)) (mul_const_fun c)))
																	               add_fun_R,
																	             (compose_fun A
																	                (compose_fun A
																	                  (pair_map A ((st 1) 0) (compose_fun A (u_of ((st 1) 0)) neg_fun))
																	                  add_fun_R)
																	                (div_const_fun den),
																	              cNew)).
																	          { reflexivity. }
																	          claim HtEq: ((StepState m st) 1) 1 = cNew.
																	          { claim Hinner: (StepState m st) 1 =
																	              (compose_fun A
																	                 (compose_fun A
																	                   (pair_map A ((st 1) 0) (compose_fun A (u_of ((st 1) 0)) neg_fun))
																	                   add_fun_R)
																	                 (div_const_fun den),
																	               cNew).
																	            { rewrite Hdef.
																	              exact (tuple_2_1_eq
																	                (compose_fun X
																	                   (pair_map X
																	                     (st 0)
																	                     (compose_fun X (u_of ((st 1) 0)) (mul_const_fun c)))
																	                   add_fun_R)
																	                (compose_fun A
																	                   (compose_fun A
																	                     (pair_map A ((st 1) 0) (compose_fun A (u_of ((st 1) 0)) neg_fun))
																	                     add_fun_R)
																	                   (div_const_fun den),
																	                 cNew)). }
																	            rewrite Hinner.
																	            exact (tuple_2_1_eq
																	              (compose_fun A
																	                 (compose_fun A
																	                   (pair_map A ((st 1) 0) (compose_fun A (u_of ((st 1) 0)) neg_fun))
																	                   add_fun_R)
																	                 (div_const_fun den))
																	              cNew). }
																	          rewrite HtEq.
																	          claim HstEq: st = State m.
																	          { reflexivity. }
																	          claim HcEq2: c = ((State m) 1) 1.
																	          { rewrite HstEq.
																	            reflexivity. }
																	          rewrite HcEq2.
																	          reflexivity. }
																	        claim Hc_even_lt: forall t:set, nat_p t ->
																	          ((State (add_nat t t)) 1) 1 < eps_ t.
																	        { apply nat_ind.
																	          - prove ((State (add_nat 0 0)) 1) 1 < eps_ 0.
																	            rewrite (add_nat_0R 0) at 1.
																	            rewrite eps_0_1.
																	            exact (HInv_c_lt1 0 (nat_p_omega 0 nat_0)).
																	          - let t. assume HtNat: nat_p t.
																	            assume IH: ((State (add_nat t t)) 1) 1 < eps_ t.
																	            prove ((State (add_nat (ordsucc t) (ordsucc t))) 1) 1 < eps_ (ordsucc t).
																	            set N := add_nat t t.
																	            claim HNnat: nat_p N.
																	            { exact (add_nat_p t HtNat t HtNat). }
																	            claim Hidx: add_nat (ordsucc t) (ordsucc t) = ordsucc (ordsucc N).
																	            { rewrite (add_nat_SL t HtNat (ordsucc t) (nat_ordsucc t HtNat)).
																	              rewrite (add_nat_SR t t HtNat).
																	              reflexivity. }
																	            rewrite Hidx.
																	            claim HN0: N :e omega.
																	            { exact (nat_p_omega N HNnat). }
																	            claim HcSN: ((State (ordsucc N)) 1) 1 = mul_SNo (((State N) 1) 1) den.
																	            { exact (Hc_step N HNnat). }
																	            claim HcSSN: ((State (ordsucc (ordsucc N))) 1) 1 =
																	              mul_SNo (mul_SNo (((State N) 1) 1) den) den.
																	            { claim HSNnat: nat_p (ordsucc N).
																	              { exact (nat_ordsucc N HNnat). }
																	              rewrite (Hc_step (ordsucc N) HSNnat).
																	              rewrite HcSN.
																	              reflexivity. }
																	            rewrite HcSSN.
																	            rewrite <- (mul_SNo_assoc (((State N) 1) 1) den den
																	              (real_SNo (((State N) 1) 1) (andEL (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0)))
																	              HdenS HdenS).
																	            claim Hden2Def: den2 = mul_SNo den den.
																	            { reflexivity. }
																	            rewrite <- Hden2Def.
																	            claim HcNpos: 0 < ((State N) 1) 1.
																	            { exact (andER (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0)). }
																	            claim HcNS: SNo (((State N) 1) 1).
																	            { exact (real_SNo (((State N) 1) 1) (andEL (((State N) 1) 1 :e R) (0 < ((State N) 1) 1) (HInv_cpos N HN0))). }
																	            rewrite (mul_SNo_com (((State N) 1) 1) den2 HcNS Hden2S).
																	            claim Heps1S0: SNo (eps_ 1).
																	            { exact (real_SNo (eps_ 1) eps_1_in_R). }
																	            claim Heps1pos: 0 < eps_ 1.
																	            { exact (RltE_lt 0 (eps_ 1) eps_1_pos_R). }
																	            claim Hmul1: mul_SNo den2 (((State N) 1) 1) < mul_SNo (eps_ 1) (((State N) 1) 1).
																	            { exact (pos_mul_SNo_Lt' den2 (eps_ 1) (((State N) 1) 1)
																	              Hden2S Heps1S0 HcNS HcNpos Hden2Lt_eps1). }
																	            claim Heps_tR: (eps_ t) :e R.
																	            { exact (SNoS_omega_real (eps_ t) (SNo_eps_SNoS_omega t (nat_p_omega t HtNat))). }
																	            claim Heps_tS: SNo (eps_ t).
																	            { exact (real_SNo (eps_ t) Heps_tR). }
																	            claim Hmul2: mul_SNo (eps_ 1) (((State N) 1) 1) < mul_SNo (eps_ 1) (eps_ t).
																	            { claim HcomL: mul_SNo (eps_ 1) (((State N) 1) 1) = mul_SNo (((State N) 1) 1) (eps_ 1).
																	              { exact (mul_SNo_com (eps_ 1) (((State N) 1) 1) Heps1S0 HcNS). }
																	              claim HcomR: mul_SNo (eps_ 1) (eps_ t) = mul_SNo (eps_ t) (eps_ 1).
																	              { exact (mul_SNo_com (eps_ 1) (eps_ t) Heps1S0 Heps_tS). }
																	              rewrite HcomL.
																	              rewrite HcomR.
																	              exact (pos_mul_SNo_Lt' (((State N) 1) 1) (eps_ t) (eps_ 1)
																	                HcNS Heps_tS Heps1S0 Heps1pos IH). }
																	            claim HmulTra: mul_SNo den2 (((State N) 1) 1) < mul_SNo (eps_ 1) (eps_ t).
																	            { exact (SNoLt_tra (mul_SNo den2 (((State N) 1) 1))
																	              (mul_SNo (eps_ 1) (((State N) 1) 1))
																	              (mul_SNo (eps_ 1) (eps_ t))
																	              (SNo_mul_SNo den2 (((State N) 1) 1) Hden2S HcNS)
																	              (SNo_mul_SNo (eps_ 1) (((State N) 1) 1) Heps1S0 HcNS)
																	              (SNo_mul_SNo (eps_ 1) (eps_ t) Heps1S0 Heps_tS)
																	              Hmul1 Hmul2). }
																	            claim HepsEq: mul_SNo (eps_ 1) (eps_ t) = eps_ (ordsucc t).
																	            { rewrite (mul_SNo_eps_eps_add_SNo 1 (nat_p_omega 1 nat_1) t (nat_p_omega t HtNat)).
																	              claim Hordt: ordinal t.
																	              { exact (nat_p_ordinal t HtNat). }
																	              rewrite <- (ordinal_ordsucc_SNo_eq t Hordt).
																	              reflexivity. }
																	            rewrite <- HepsEq.
																	            exact HmulTra. }
																	        claim HcN0: ((State N0) 1) 1 < eps_ K.
																	        { exact (Hc_even_lt K HKnat). }
																	        claim HcN0R: ((State N0) 1) 1 :e R.
																	        { exact (andEL (((State N0) 1) 1 :e R) (0 < ((State N0) 1) 1) (HInv_cpos N0 HN0O)). }
																	        claim HcN0S: SNo (((State N0) 1) 1).
																	        { exact (real_SNo (((State N0) 1) 1) HcN0R). }
																	        claim HcN0ltEta: ((State N0) 1) 1 < eta.
																	        { exact (SNoLt_tra (((State N0) 1) 1) (eps_ K) eta HcN0S HepsKS HetaS HcN0 HepsKltEtaS). }
																	        witness N0.
																	        apply andI.
																	        - exact HN0O.
																	        - let m n. assume HmO: m :e omega. assume HnO: n :e omega.
																	          assume HNm: N0 c= m. assume HNn: N0 c= n.
																	          let x. assume HxX: x :e X.
																	          prove Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps0.
																	          claim HmNat: nat_p m.
																	          { exact (omega_nat_p m HmO). }
																	          claim HnNat: nat_p n.
																	          { exact (omega_nat_p n HnO). }
																	          claim Hexkm: exists km:set, nat_p km /\ m = add_nat km N0.
																	          { exact (nat_Subq_add_ex N0 HN0Nat m HmNat HNm). }
																	          apply Hexkm.
																	          let km. assume Hkm.
																	          claim HkmNat: nat_p km.
																	          { exact (andEL (nat_p km) (m = add_nat km N0) Hkm). }
																	          claim HmEq: m = add_nat km N0.
																	          { exact (andER (nat_p km) (m = add_nat km N0) Hkm). }
																	          rewrite HmEq.
																	          claim Hexkn: exists kn:set, nat_p kn /\ n = add_nat kn N0.
																	          { exact (nat_Subq_add_ex N0 HN0Nat n HnNat HNn). }
																	          apply Hexkn.
																	          let kn. assume Hkn.
																	          claim HknNat: nat_p kn.
																	          { exact (andEL (nat_p kn) (n = add_nat kn N0) Hkn). }
																	          claim HnEq: n = add_nat kn N0.
																	          { exact (andER (nat_p kn) (n = add_nat kn N0) Hkn). }
																	          rewrite HnEq.
																	          claim HmO2: (add_nat km N0) :e omega.
																	          { exact (nat_p_omega (add_nat km N0) (add_nat_p km HkmNat N0 HN0Nat)). }
																	          claim HnO2: (add_nat kn N0) :e omega.
																	          { exact (nat_p_omega (add_nat kn N0) (add_nat_p kn HknNat N0 HN0Nat)). }
																	          claim HfnDef: fn = graph omega (fun k:set => (State k) 0).
																	          { reflexivity. }
																	          rewrite (apply_fun_of_graph_eq fn omega (fun k:set => (State k) 0) (add_nat km N0) HfnDef HmO2).
																	          rewrite (apply_fun_of_graph_eq fn omega (fun k:set => (State k) 0) (add_nat kn N0) HfnDef HnO2).
																	          claim HmFS: (State (add_nat km N0)) 0 :e function_space X R.
																	          { exact (HInv_g_FS (add_nat km N0) HmO2). }
																	          claim HnFS: (State (add_nat kn N0)) 0 :e function_space X R.
																	          { exact (HInv_g_FS (add_nat kn N0) HnO2). }
																	          claim Hm_on: function_on ((State (add_nat km N0)) 0) X R.
																	          { exact (function_on_of_function_space ((State (add_nat km N0)) 0) X R HmFS). }
																	          claim Hn_on: function_on ((State (add_nat kn N0)) 0) X R.
																	          { exact (function_on_of_function_space ((State (add_nat kn N0)) 0) X R HnFS). }
																	          claim HmxR: apply_fun ((State (add_nat km N0)) 0) x :e R.
																	          { exact (Hm_on x HxX). }
																	          claim HnxR: apply_fun ((State (add_nat kn N0)) 0) x :e R.
																	          { exact (Hn_on x HxX). }
																	          claim HmxS: SNo (apply_fun ((State (add_nat km N0)) 0) x).
																	          { exact (real_SNo (apply_fun ((State (add_nat km N0)) 0) x) HmxR). }
																	          claim HnxS: SNo (apply_fun ((State (add_nat kn N0)) 0) x).
																	          { exact (real_SNo (apply_fun ((State (add_nat kn N0)) 0) x) HnxR). }
																	          claim HgN0FS: (State N0) 0 :e function_space X R.
																	          { exact (HInv_g_FS N0 HN0O). }
																	          claim HgN0_on: function_on ((State N0) 0) X R.
																	          { exact (function_on_of_function_space ((State N0) 0) X R HgN0FS). }
																	          claim HgN0xR: apply_fun ((State N0) 0) x :e R.
																	          { exact (HgN0_on x HxX). }
																	          claim HgN0xS: SNo (apply_fun ((State N0) 0) x).
																	          { exact (real_SNo (apply_fun ((State N0) 0) x) HgN0xR). }
																	          claim HcN0S0: SNo (((State N0) 1) 1).
																	          { exact (real_SNo (((State N0) 1) 1) HcN0R). }
																	          (** step bound for the g component **)
																	          claim Hstep_budget: forall t:set, nat_p t ->
																	            forall x0:set, x0 :e X ->
																	              abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x0) (minus_SNo (apply_fun ((State t) 0) x0)))
																	              <= add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)).
																	          { let t. assume HtNat: nat_p t.
																	            let x0. assume Hx0X: x0 :e X.
																	            claim HtO: t :e omega.
																	            { exact (nat_p_omega t HtNat). }
																	            claim HtSuccO: ordsucc t :e omega.
																	            { exact (omega_ordsucc t HtO). }
																		            set r := ((State t) 1) 0.
																		            set c := ((State t) 1) 1.
																		            set corr := compose_fun X (u_of r) (mul_const_fun c).
																		            set gNew := compose_fun X (pair_map X ((State t) 0) corr) add_fun_R.
																		            set cNew := mul_SNo c den.
																	            claim HS: State (ordsucc t) = StepState t (State t).
																	            { exact (nat_primrec_S BaseState StepState t HtNat). }
																	            rewrite (Hc_step t HtNat) at 1.
																		            claim HgSucc: (State (ordsucc t)) 0 = gNew.
																		            { rewrite HS.
																		              claim HdefS: StepState t (State t) =
																		                (compose_fun X
																		                   (pair_map X
																		                     ((State t) 0)
																		                     (compose_fun X (u_of (((State t) 1) 0)) (mul_const_fun (((State t) 1) 1))))
																		                   add_fun_R,
																			              (compose_fun A
																			                 (compose_fun A
																			                   (pair_map A (((State t) 1) 0) (compose_fun A (u_of (((State t) 1) 0)) neg_fun))
																			                   add_fun_R)
																			                 (div_const_fun den),
																			               mul_SNo (((State t) 1) 1) den)).
																			              { reflexivity. }
																			              rewrite HdefS.
																			              claim Hproj0:
																			                ((compose_fun X
																			                    (pair_map X
																			                      ((State t) 0)
																			                      (compose_fun X (u_of (((State t) 1) 0)) (mul_const_fun (((State t) 1) 1))))
																			                    add_fun_R,
																			                  (compose_fun A
																			                     (compose_fun A
																			                       (pair_map A (((State t) 1) 0) (compose_fun A (u_of (((State t) 1) 0)) neg_fun))
																			                       add_fun_R)
																			                     (div_const_fun den),
																			                   mul_SNo (((State t) 1) 1) den)) 0)
																			                =
																			                (compose_fun X
																			                   (pair_map X
																			                     ((State t) 0)
																			                     (compose_fun X (u_of (((State t) 1) 0)) (mul_const_fun (((State t) 1) 1))))
																			                   add_fun_R).
																			              { exact (tuple_2_0_eq
																			                  (compose_fun X
																			                     (pair_map X
																			                       ((State t) 0)
																			                       (compose_fun X (u_of (((State t) 1) 0)) (mul_const_fun (((State t) 1) 1))))
																			                     add_fun_R)
																			                  (compose_fun A
																			                     (compose_fun A
																			                       (pair_map A (((State t) 1) 0) (compose_fun A (u_of (((State t) 1) 0)) neg_fun))
																			                       add_fun_R)
																			                     (div_const_fun den),
																			                   mul_SNo (((State t) 1) 1) den)). }
																			              rewrite Hproj0.
																			              claim HrEq: r = ((State t) 1) 0.
																			              { reflexivity. }
																			              claim HcEq0: c = ((State t) 1) 1.
																			              { reflexivity. }
																		              rewrite <- HrEq.
																		              rewrite <- HcEq0.
																			              claim HcorrDef: corr = compose_fun X (u_of r) (mul_const_fun c).
																			              { reflexivity. }
																			              rewrite <- HcorrDef.
																			              claim HgNewDef: gNew = compose_fun X (pair_map X ((State t) 0) corr) add_fun_R.
																			              { reflexivity. }
																			              rewrite HgNewDef.
																			              reflexivity. }
																	            claim HcEq: c = ((State t) 1) 1.
																	            { reflexivity. }
																	            claim HcR: c :e R.
																	            { rewrite HcEq.
																	              exact (andEL (((State t) 1) 1 :e R) (0 < ((State t) 1) 1) (HInv_cpos t HtO)). }
																	            claim HcS: SNo c.
																	            { exact (real_SNo c HcR). }
																	            claim HcPos: 0 < c.
																	            { rewrite HcEq.
																	              exact (andER (((State t) 1) 1 :e R) (0 < ((State t) 1) 1) (HInv_cpos t HtO)). }
																	            claim H0le_c: 0 <= c.
																	            { exact (SNoLtLe 0 c HcPos). }
																	            claim Hr_contI: continuous_map A Ta I Ti r.
																	            { exact (HInv_r_contI t HtO). }
																	            claim Hu_pack:
																	              continuous_map X Tx I0 T0 (u_of r) /\
																	              (forall x1:set, x1 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																	                apply_fun (u_of r) x1 = minus_SNo one_third) /\
																	              (forall x1:set, x1 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																	                apply_fun (u_of r) x1 = one_third).
																	            { exact (Hu_of_prop r Hr_contI). }
																	            claim Hu_contI0: continuous_map X Tx I0 T0 (u_of r).
																	            { exact (andEL (continuous_map X Tx I0 T0 (u_of r))
																	                (forall x1:set, x1 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																	                  apply_fun (u_of r) x1 = minus_SNo one_third)
																	                (andEL ((continuous_map X Tx I0 T0 (u_of r)) /\
																	                       (forall x1:set, x1 :e preimage_of A r ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: I) ->
																	                         apply_fun (u_of r) x1 = minus_SNo one_third))
																	                      (forall x1:set, x1 :e preimage_of A r ((closed_interval one_third 1) :/\: I) ->
																	                        apply_fun (u_of r) x1 = one_third)
																	                      Hu_pack)). }
																	            claim Hu_fun: function_on (u_of r) X I0.
																	            { exact (continuous_map_function_on X Tx I0 T0 (u_of r) Hu_contI0). }
																	            claim HuxI0: apply_fun (u_of r) x0 :e I0.
																	            { exact (Hu_fun x0 Hx0X). }
																	            claim HuxR: apply_fun (u_of r) x0 :e R.
																	            { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun (u_of r) x0) HuxI0). }
																	            claim HuxS: SNo (apply_fun (u_of r) x0).
																	            { exact (real_SNo (apply_fun (u_of r) x0) HuxR). }
																		            claim HcorrEq:
																		              apply_fun corr x0 = mul_SNo (apply_fun (u_of r) x0) c.
																		            { claim HcorrDef0: corr = compose_fun X (u_of r) (mul_const_fun c).
																		              { reflexivity. }
																		              claim Hcomp:
																		                apply_fun corr x0 = apply_fun (mul_const_fun c) (apply_fun (u_of r) x0).
																		              { rewrite HcorrDef0.
																		                exact (compose_fun_apply X (u_of r) (mul_const_fun c) x0 Hx0X). }
																		              rewrite Hcomp.
																		              exact (mul_const_fun_apply c (apply_fun (u_of r) x0) HcR HuxR). }
																		            claim HgxR: apply_fun ((State t) 0) x0 :e R.
																		            { exact (function_on_of_function_space ((State t) 0) X R (HInv_g_FS t HtO) x0 Hx0X). }
																	            claim HcorrR: apply_fun corr x0 :e R.
																	            { rewrite HcorrEq.
																	              exact (real_mul_SNo (apply_fun (u_of r) x0) HuxR c HcR). }
																		            claim HgNewEval:
																		              apply_fun gNew x0 = add_SNo (apply_fun ((State t) 0) x0) (apply_fun corr x0).
																			            { exact (add_of_pair_map_apply X ((State t) 0) corr x0 Hx0X HgxR HcorrR). }
																			            rewrite HgSucc.
																		            rewrite HgNewEval.
																			            claim Ha0S: SNo (apply_fun ((State t) 0) x0).
																			            { exact (real_SNo (apply_fun ((State t) 0) x0) HgxR). }
																			            claim Hb0S: SNo (apply_fun corr x0).
																			            { exact (real_SNo (apply_fun corr x0) HcorrR). }
																				            claim Hcancel:
																				              add_SNo (add_SNo (apply_fun ((State t) 0) x0) (apply_fun corr x0)) (minus_SNo (apply_fun ((State t) 0) x0))
																				              = apply_fun corr x0.
																				            { claim Hma0S: SNo (minus_SNo (apply_fun ((State t) 0) x0)).
																				              { exact (SNo_minus_SNo (apply_fun ((State t) 0) x0) Ha0S). }
																				              claim Hassoc1:
																				                add_SNo (apply_fun ((State t) 0) x0)
																				                  (add_SNo (apply_fun corr x0) (minus_SNo (apply_fun ((State t) 0) x0)))
																				                =
																				                add_SNo (add_SNo (apply_fun ((State t) 0) x0) (apply_fun corr x0))
																				                  (minus_SNo (apply_fun ((State t) 0) x0)).
																				              { exact (add_SNo_assoc
																				                  (apply_fun ((State t) 0) x0)
																				                  (apply_fun corr x0)
																				                  (minus_SNo (apply_fun ((State t) 0) x0))
																				                  Ha0S Hb0S Hma0S). }
																				              rewrite <- Hassoc1 at 1.
																				              claim Hcom1:
																				                add_SNo (apply_fun corr x0) (minus_SNo (apply_fun ((State t) 0) x0)) =
																				                  add_SNo (minus_SNo (apply_fun ((State t) 0) x0)) (apply_fun corr x0).
																				              { exact (add_SNo_com (apply_fun corr x0) (minus_SNo (apply_fun ((State t) 0) x0)) Hb0S Hma0S). }
																				              rewrite Hcom1 at 1.
																				              claim Hassoc2:
																				                add_SNo (apply_fun ((State t) 0) x0)
																				                  (add_SNo (minus_SNo (apply_fun ((State t) 0) x0)) (apply_fun corr x0))
																				                =
																				                add_SNo (add_SNo (apply_fun ((State t) 0) x0) (minus_SNo (apply_fun ((State t) 0) x0)))
																				                  (apply_fun corr x0).
																				              { exact (add_SNo_assoc
																				                  (apply_fun ((State t) 0) x0)
																				                  (minus_SNo (apply_fun ((State t) 0) x0))
																				                  (apply_fun corr x0)
																				                  Ha0S Hma0S Hb0S). }
																				              rewrite Hassoc2.
																				              claim Hinv: add_SNo (apply_fun ((State t) 0) x0) (minus_SNo (apply_fun ((State t) 0) x0)) = 0.
																				              { exact (add_SNo_minus_SNo_rinv (apply_fun ((State t) 0) x0) Ha0S). }
																				              rewrite Hinv at 1.
																				              exact (add_SNo_0L (apply_fun corr x0) Hb0S). }
																			            rewrite Hcancel at 1.
																			            rewrite HcorrEq.
																			            set u := apply_fun (u_of r) x0.
																	            claim HuAbsLe: abs_SNo u <= one_third.
																	            { claim Hm13R: minus_SNo one_third :e R.
																	              { exact (real_minus_SNo one_third one_third_in_R). }
																	              claim Hm13S: SNo (minus_SNo one_third).
																	              { exact (real_SNo (minus_SNo one_third) Hm13R). }
																	              claim H13S: SNo one_third.
																	              { exact (real_SNo one_third one_third_in_R). }
																	              claim Hbounds: Rle (minus_SNo one_third) u /\ Rle u one_third.
																	              { exact (closed_interval_bounds (minus_SNo one_third) one_third u Hm13R one_third_in_R HuxI0). }
																	              claim Hlo: minus_SNo one_third <= u.
																	              { exact (SNoLe_of_Rle (minus_SNo one_third) u (andEL (Rle (minus_SNo one_third) u) (Rle u one_third) Hbounds)). }
																	              claim Hhi: u <= one_third.
																	              { exact (SNoLe_of_Rle u one_third (andER (Rle (minus_SNo one_third) u) (Rle u one_third) Hbounds)). }
																	              exact (abs_SNo_Le_of_bounds u one_third HuxS H13S Hlo Hhi). }
																	            claim Habsc: abs_SNo (mul_SNo u c) = mul_SNo (abs_SNo u) (abs_SNo c).
																	            { exact (abs_SNo_mul_eq u c HuxS HcS). }
																	            rewrite Habsc.
																	            rewrite (nonneg_abs_SNo c H0le_c).
																	            claim H13S: SNo one_third.
																	            { exact (real_SNo one_third one_third_in_R). }
																	            claim HabsuS: SNo (abs_SNo u).
																	            { exact (SNo_abs_SNo u HuxS). }
																		            claim Hc13Le: mul_SNo (abs_SNo u) c <= mul_SNo one_third c.
																		            { exact (nonneg_mul_SNo_Le' (abs_SNo u) one_third c HabsuS H13S HcS H0le_c HuAbsLe). }
																			            claim HdenEq: den = two_thirds.
																			            { reflexivity. }
																			            rewrite HdenEq at 1.
																					            claim H13Eq: mul_SNo one_third c = add_SNo c (minus_SNo (mul_SNo c two_thirds)).
																					            { claim H23S: SNo two_thirds.
																					              { exact (real_SNo two_thirds two_thirds_in_R). }
																					              claim Hc13S: SNo (mul_SNo c one_third).
																					              { exact (SNo_mul_SNo c one_third HcS H13S). }
																					              claim Hc23S: SNo (mul_SNo c two_thirds).
																					              { exact (SNo_mul_SNo c two_thirds HcS H23S). }
																					              rewrite (mul_SNo_com one_third c H13S HcS).
																					              claim HsumEq: add_SNo (mul_SNo c one_third) (mul_SNo c two_thirds) = c.
																					              { rewrite <- (mul_SNo_distrL c one_third two_thirds HcS H13S H23S).
																					                rewrite add_one_third_two_thirds_eq_1 at 1.
																					                exact (mul_SNo_oneR c HcS). }
																					              claim Hcan: add_SNo (add_SNo (mul_SNo c one_third) (mul_SNo c two_thirds)) (minus_SNo (mul_SNo c two_thirds)) =
																					                mul_SNo c one_third.
																					              { exact (add_SNo_minus_R2 (mul_SNo c one_third) (mul_SNo c two_thirds) Hc13S Hc23S). }
																					              claim Htmp: add_SNo (add_SNo (mul_SNo c one_third) (mul_SNo c two_thirds)) (minus_SNo (mul_SNo c two_thirds)) =
																					                add_SNo c (minus_SNo (mul_SNo c two_thirds)).
																					              { rewrite HsumEq at 1.
																					                reflexivity. }
																					              rewrite <- Hcan at 1.
																					              rewrite Htmp at 1.
																					              reflexivity. }
																		            rewrite <- H13Eq at 1.
																		            exact Hc13Le. }
																	          (** tail budget from N0 via nat induction on shift **)
																		          claim Htail_budget: forall k:set, nat_p k ->
																		            forall x0:set, x0 :e X ->
																		              abs_SNo (add_SNo (apply_fun ((State (add_nat k N0)) 0) x0) (minus_SNo (apply_fun ((State N0) 0) x0)))
																		              <= ((State N0) 1) 1.
																		          { let k. assume HkNat: nat_p k.
																		            let x0. assume Hx0X: x0 :e X.
																		            claim Htail_strong_all: forall kk:set, nat_p kk ->
																		              forall x1:set, x1 :e X ->
																		                abs_SNo (add_SNo (apply_fun ((State (add_nat kk N0)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                <= add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat kk N0)) 1) 1)).
																		            { apply nat_ind.
																		              - prove forall x1:set, x1 :e X ->
																		                  abs_SNo (add_SNo (apply_fun ((State (add_nat 0 N0)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                  <= add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat 0 N0)) 1) 1)).
																		                let x1. assume Hx1X: x1 :e X.
																		                claim Hadd0: add_nat 0 N0 = N0.
																		                { exact (add_nat_0L N0 HN0Nat). }
																		                rewrite Hadd0 at 1.
																		                rewrite Hadd0 at 1.
																		                claim HgN0FS: (State N0) 0 :e function_space X R.
																		                { exact (HInv_g_FS N0 HN0O). }
																		                claim HgN0_on: function_on ((State N0) 0) X R.
																		                { exact (function_on_of_function_space ((State N0) 0) X R HgN0FS). }
																		                claim HgN0xR: apply_fun ((State N0) 0) x1 :e R.
																		                { exact (HgN0_on x1 Hx1X). }
																		                claim HgN0xS: SNo (apply_fun ((State N0) 0) x1).
																		                { exact (real_SNo (apply_fun ((State N0) 0) x1) HgN0xR). }
																		                rewrite (add_SNo_minus_SNo_rinv (apply_fun ((State N0) 0) x1) HgN0xS) at 1.
																		                rewrite (nonneg_abs_SNo 0 (SNoLe_ref 0)) at 1.
																		                rewrite (add_SNo_minus_SNo_rinv (((State N0) 1) 1) HcN0S0) at 1.
																		                exact (SNoLe_ref 0).
																		              - let kk. assume HkkNat: nat_p kk.
																		                assume IH: forall x1:set, x1 :e X ->
																		                  abs_SNo (add_SNo (apply_fun ((State (add_nat kk N0)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                  <= add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat kk N0)) 1) 1)).
																		                prove forall x1:set, x1 :e X ->
																		                  abs_SNo (add_SNo (apply_fun ((State (add_nat (ordsucc kk) N0)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                  <= add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat (ordsucc kk) N0)) 1) 1)).
																		                let x1. assume Hx1X: x1 :e X.
																		                set t := add_nat kk N0.
																		                claim HtNat: nat_p t.
																		                { exact (add_nat_p kk HkkNat N0 HN0Nat). }
																		                claim HtO: t :e omega.
																		                { exact (nat_p_omega t HtNat). }
																		                claim Hidx: add_nat (ordsucc kk) N0 = ordsucc t.
																		                { rewrite (add_nat_SL kk HkkNat N0 HN0Nat).
																		                  reflexivity. }
																		                rewrite Hidx at 1.
																		                rewrite Hidx at 1.
																		                claim HtSuccNat: nat_p (ordsucc t).
																		                { exact (nat_ordsucc t HtNat). }
																		                claim HtSuccO: ordsucc t :e omega.
																		                { exact (nat_p_omega (ordsucc t) HtSuccNat). }
																		                claim HgN0FS: (State N0) 0 :e function_space X R.
																		                { exact (HInv_g_FS N0 HN0O). }
																		                claim HgN0_on: function_on ((State N0) 0) X R.
																		                { exact (function_on_of_function_space ((State N0) 0) X R HgN0FS). }
																		                claim HgN0xR: apply_fun ((State N0) 0) x1 :e R.
																		                { exact (HgN0_on x1 Hx1X). }
																		                claim HgN0xS: SNo (apply_fun ((State N0) 0) x1).
																		                { exact (real_SNo (apply_fun ((State N0) 0) x1) HgN0xR). }
																		                claim HtFS: (State t) 0 :e function_space X R.
																		                { exact (HInv_g_FS t HtO). }
																		                claim Ht_on: function_on ((State t) 0) X R.
																		                { exact (function_on_of_function_space ((State t) 0) X R HtFS). }
																		                claim HtxR: apply_fun ((State t) 0) x1 :e R.
																		                { exact (Ht_on x1 Hx1X). }
																		                claim HtxS: SNo (apply_fun ((State t) 0) x1).
																		                { exact (real_SNo (apply_fun ((State t) 0) x1) HtxR). }
																		                claim HtSuccFS: (State (ordsucc t)) 0 :e function_space X R.
																		                { exact (HInv_g_FS (ordsucc t) HtSuccO). }
																		                claim HtSucc_on: function_on ((State (ordsucc t)) 0) X R.
																		                { exact (function_on_of_function_space ((State (ordsucc t)) 0) X R HtSuccFS). }
																		                claim HtSuccxR: apply_fun ((State (ordsucc t)) 0) x1 :e R.
																		                { exact (HtSucc_on x1 Hx1X). }
																		                claim HtSuccxS: SNo (apply_fun ((State (ordsucc t)) 0) x1).
																		                { exact (real_SNo (apply_fun ((State (ordsucc t)) 0) x1) HtSuccxR). }
																		                claim Htri:
																		                  abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                  <= add_SNo
																		                    (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))))
																		                    (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))).
																		                { exact (abs_SNo_triangle
																		                    (apply_fun ((State (ordsucc t)) 0) x1)
																		                    (apply_fun ((State t) 0) x1)
																		                    (apply_fun ((State N0) 0) x1)
																		                    HtSuccxS HtxS HgN0xS). }
																		                claim HstepLe:
																		                  abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1)))
																		                  <= add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)).
																		                { exact (Hstep_budget t HtNat x1 Hx1X). }
																		                claim HihLe:
																		                  abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                  <= add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)).
																		                { exact (IH x1 Hx1X). }
																		                claim Habs1S: SNo (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1)))).
																		                { exact (SNo_abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1)))
																		                    (SNo_add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))
																		                      HtSuccxS (SNo_minus_SNo (apply_fun ((State t) 0) x1) HtxS))). }
																		                claim Habs2S: SNo (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))).
																		                { exact (SNo_abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                    (SNo_add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))
																		                      HtxS (SNo_minus_SNo (apply_fun ((State N0) 0) x1) HgN0xS))). }
																		                claim HctR: (((State t) 1) 1) :e R.
																		                { exact (andEL ((((State t) 1) 1 :e R)) (0 < (((State t) 1) 1)) (HInv_cpos t HtO)). }
																		                claim HctS: SNo (((State t) 1) 1).
																		                { exact (real_SNo (((State t) 1) 1) HctR). }
																		                claim HctsR: (((State (ordsucc t)) 1) 1) :e R.
																		                { exact (andEL ((((State (ordsucc t)) 1) 1 :e R)) (0 < (((State (ordsucc t)) 1) 1)) (HInv_cpos (ordsucc t) HtSuccO)). }
																		                claim HctsS: SNo (((State (ordsucc t)) 1) 1).
																		                { exact (real_SNo (((State (ordsucc t)) 1) 1) HctsR). }
																		                claim Hc0S: SNo (((State N0) 1) 1).
																		                { exact HcN0S0. }
																		                claim HmctS: SNo (minus_SNo (((State t) 1) 1)).
																		                { exact (SNo_minus_SNo (((State t) 1) 1) HctS). }
																		                claim HmctsS: SNo (minus_SNo (((State (ordsucc t)) 1) 1)).
																		                { exact (SNo_minus_SNo (((State (ordsucc t)) 1) 1) HctsS). }
																		                claim Hrhs1S: SNo (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1))).
																		                { exact (SNo_add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)) HctS HmctsS). }
																		                claim Hrhs2S: SNo (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1))).
																		                { exact (SNo_add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)) Hc0S HmctS). }
																		                claim HsumLe:
																		                  add_SNo
																		                    (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))))
																		                    (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))))
																		                  <= add_SNo (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                       (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1))).
																		                { exact (add_SNo_Le3
																		                    (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))))
																		                    (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))))
																		                    (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                    (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)))
																		                    Habs1S Habs2S Hrhs1S Hrhs2S HstepLe HihLe). }
																		                claim HsumEq:
																		                  add_SNo (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                        (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)))
																		                  =
																		                  add_SNo (((State N0) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)).
																		                { rewrite (add_SNo_com
																		                    (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                    (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)))
																		                    Hrhs1S Hrhs2S) at 1.
																		                  rewrite (add_SNo_com_4_inner_mid
																		                    (((State N0) 1) 1)
																		                    (minus_SNo (((State t) 1) 1))
																		                    (((State t) 1) 1)
																		                    (minus_SNo (((State (ordsucc t)) 1) 1))
																		                    Hc0S HmctS HctS HmctsS) at 1.
																		                  claim Ht2S: SNo (add_SNo (((State N0) 1) 1) (((State t) 1) 1)).
																		                  { exact (SNo_add_SNo (((State N0) 1) 1) (((State t) 1) 1) Hc0S HctS). }
																		                  claim Ht3S: SNo (add_SNo (minus_SNo (((State t) 1) 1)) (minus_SNo (((State (ordsucc t)) 1) 1))).
																		                  { exact (SNo_add_SNo (minus_SNo (((State t) 1) 1)) (minus_SNo (((State (ordsucc t)) 1) 1)) HmctS HmctsS). }
																		                  rewrite <- (add_SNo_assoc (((State N0) 1) 1) (((State t) 1) 1)
																		                    (add_SNo (minus_SNo (((State t) 1) 1)) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                    Hc0S HctS Ht3S) at 1.
																		                  rewrite (add_SNo_assoc (((State t) 1) 1) (minus_SNo (((State t) 1) 1)) (minus_SNo (((State (ordsucc t)) 1) 1))
																		                    HctS HmctS HmctsS) at 1.
																		                  claim Hinv: add_SNo (((State t) 1) 1) (minus_SNo (((State t) 1) 1)) = 0.
																		                  { exact (add_SNo_minus_SNo_rinv (((State t) 1) 1) HctS). }
																		                  rewrite Hinv at 1.
																		                  rewrite (add_SNo_0L (minus_SNo (((State (ordsucc t)) 1) 1)) HmctsS) at 1.
																		                  reflexivity. }
																		                rewrite <- HsumEq at 1.
																		                exact (SNoLe_tra
																		                  (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))))
																		                  (add_SNo
																		                    (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))))
																		                    (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))))
																		                  (add_SNo (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                    (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1))))
																		                  (SNo_abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1)))
																		                    (SNo_add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))
																		                      HtSuccxS (SNo_minus_SNo (apply_fun ((State N0) 0) x1) HgN0xS)))
																		                  (SNo_add_SNo
																		                    (abs_SNo (add_SNo (apply_fun ((State (ordsucc t)) 0) x1) (minus_SNo (apply_fun ((State t) 0) x1))))
																		                    (abs_SNo (add_SNo (apply_fun ((State t) 0) x1) (minus_SNo (apply_fun ((State N0) 0) x1))))
																		                    Habs1S Habs2S)
																		                  (SNo_add_SNo
																		                    (add_SNo (((State t) 1) 1) (minus_SNo (((State (ordsucc t)) 1) 1)))
																		                    (add_SNo (((State N0) 1) 1) (minus_SNo (((State t) 1) 1)))
																		                    Hrhs1S Hrhs2S)
																		                  Htri HsumLe). }
																		            claim Hstrong:
																		              abs_SNo (add_SNo (apply_fun ((State (add_nat k N0)) 0) x0) (minus_SNo (apply_fun ((State N0) 0) x0)))
																		              <= add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)).
																		            { exact (Htail_strong_all k HkNat x0 Hx0X). }
																		            claim HkN0Nat: nat_p (add_nat k N0).
																		            { exact (add_nat_p k HkNat N0 HN0Nat). }
																		            claim HkN0O: (add_nat k N0) :e omega.
																		            { exact (nat_p_omega (add_nat k N0) HkN0Nat). }
																		            claim HckR: (((State (add_nat k N0)) 1) 1) :e R.
																		            { exact (andEL ((((State (add_nat k N0)) 1) 1 :e R)) (0 < (((State (add_nat k N0)) 1) 1)) (HInv_cpos (add_nat k N0) HkN0O)). }
																		            claim HckS: SNo (((State (add_nat k N0)) 1) 1).
																		            { exact (real_SNo (((State (add_nat k N0)) 1) 1) HckR). }
																		            claim HckPos: 0 < (((State (add_nat k N0)) 1) 1).
																		            { exact (andER ((((State (add_nat k N0)) 1) 1 :e R)) (0 < (((State (add_nat k N0)) 1) 1)) (HInv_cpos (add_nat k N0) HkN0O)). }
																		            claim H0le_ck: 0 <= (((State (add_nat k N0)) 1) 1).
																		            { exact (SNoLtLe 0 (((State (add_nat k N0)) 1) 1) HckPos). }
																		            claim HmckLe0: minus_SNo (((State (add_nat k N0)) 1) 1) <= 0.
																		            { claim Htmp: minus_SNo (((State (add_nat k N0)) 1) 1) <= minus_SNo 0.
																		              { exact (minus_SNo_Le_contra 0 (((State (add_nat k N0)) 1) 1) SNo_0 HckS H0le_ck). }
																		              claim Hm0le0: minus_SNo 0 <= 0.
																		              { rewrite minus_SNo_0.
																		                exact (SNoLe_ref 0). }
																		              exact (SNoLe_tra
																		                (minus_SNo (((State (add_nat k N0)) 1) 1))
																		                (minus_SNo 0)
																		                0
																		                (SNo_minus_SNo (((State (add_nat k N0)) 1) 1) HckS)
																		                (SNo_minus_SNo 0 SNo_0)
																		                SNo_0
																		                Htmp Hm0le0). }
																		            claim HrhsLe:
																		              add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)) <= ((State N0) 1) 1.
																		            { claim HsumLe0:
																		                add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1))
																		                <= add_SNo (((State N0) 1) 1) 0.
																		              { exact (add_SNo_Le2 (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)) 0 HcN0S0 (SNo_minus_SNo (((State (add_nat k N0)) 1) 1) HckS) SNo_0 HmckLe0). }
																		              claim HmidLe:
																		                add_SNo (((State N0) 1) 1) 0 <= ((State N0) 1) 1.
																		              { rewrite (add_SNo_0R (((State N0) 1) 1) HcN0S0).
																		                exact (SNoLe_ref (((State N0) 1) 1)). }
																		              exact (SNoLe_tra
																		                (add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)))
																		                (add_SNo (((State N0) 1) 1) 0)
																		                (((State N0) 1) 1)
																		                (SNo_add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)) HcN0S0 (SNo_minus_SNo (((State (add_nat k N0)) 1) 1) HckS))
																		                (SNo_add_SNo (((State N0) 1) 1) 0 HcN0S0 SNo_0)
																		                HcN0S0
																		                HsumLe0 HmidLe). }
																		            claim HgN0xS: SNo (apply_fun ((State N0) 0) x0).
																		            { claim HgN0FS: (State N0) 0 :e function_space X R.
																		              { exact (HInv_g_FS N0 HN0O). }
																		              claim HgN0_on: function_on ((State N0) 0) X R.
																		              { exact (function_on_of_function_space ((State N0) 0) X R HgN0FS). }
																		              claim HgN0xR: apply_fun ((State N0) 0) x0 :e R.
																		              { exact (HgN0_on x0 Hx0X). }
																		              exact (real_SNo (apply_fun ((State N0) 0) x0) HgN0xR). }
																		            exact (SNoLe_tra
																		              (abs_SNo (add_SNo (apply_fun ((State (add_nat k N0)) 0) x0) (minus_SNo (apply_fun ((State N0) 0) x0))))
																		              (add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)))
																		              (((State N0) 1) 1)
																		              (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat k N0)) 0) x0) (minus_SNo (apply_fun ((State N0) 0) x0)))
																		                (SNo_add_SNo (apply_fun ((State (add_nat k N0)) 0) x0) (minus_SNo (apply_fun ((State N0) 0) x0))
																		                  (real_SNo (apply_fun ((State (add_nat k N0)) 0) x0)
																		                    (function_on_of_function_space ((State (add_nat k N0)) 0) X R (HInv_g_FS (add_nat k N0) HkN0O) x0 Hx0X))
																		                  (SNo_minus_SNo (apply_fun ((State N0) 0) x0) HgN0xS)))
																		              (SNo_add_SNo (((State N0) 1) 1) (minus_SNo (((State (add_nat k N0)) 1) 1)) HcN0S0 (SNo_minus_SNo (((State (add_nat k N0)) 1) 1) HckS))
																		              HcN0S0
																		              Hstrong HrhsLe). }
																	          (** derive abs difference < eps0 and conclude in bounded distance **)
																	          claim Habs_mN0: abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))) < eta.
																	          { exact (SNoLeLt_tra
																	              (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	              (((State N0) 1) 1) eta
																	              (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)))
																	                (SNo_add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)) HmxS (SNo_minus_SNo (apply_fun ((State N0) 0) x) HgN0xS)))
																	              HcN0S0 HetaS
																	              (Htail_budget km HkmNat x HxX)
																	              HcN0ltEta). }
																	          claim HabSwap: abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))) =
																	            abs_SNo (add_SNo (apply_fun ((State (add_nat kn N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))).
																	          { exact (abs_SNo_dist_swap (apply_fun ((State N0) 0) x) (apply_fun ((State (add_nat kn N0)) 0) x) HgN0xS HnxS). }
																	          claim Habs_nN0: abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))) < eta.
																	          { rewrite HabSwap.
																	            exact (SNoLeLt_tra
																	              (abs_SNo (add_SNo (apply_fun ((State (add_nat kn N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	              (((State N0) 1) 1) eta
																	              (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat kn N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)))
																	                (SNo_add_SNo (apply_fun ((State (add_nat kn N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)) HnxS (SNo_minus_SNo (apply_fun ((State N0) 0) x) HgN0xS)))
																	              HcN0S0 HetaS
																	              (Htail_budget kn HknNat x HxX)
																	              HcN0ltEta). }
																	          claim HetaSumEq: add_SNo eta eta = eps0.
																	          { rewrite <- (mul_SNo_distrL eps0 (eps_ 1) (eps_ 1) Heps0S Heps1S Heps1S).
																	            rewrite (eps_ordsucc_half_add 0 nat_0).
																	            rewrite eps_0_1.
																	            rewrite (mul_SNo_oneR eps0 Heps0S).
																	            reflexivity. }
																	          claim HsumLt: add_SNo
																	            (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	            (abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))))
																	            < eps0.
																	          { rewrite <- HetaSumEq.
																	            exact (add_SNo_Lt3
																	              (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	              (abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))))
																	              eta eta
																	              (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)))
																	                (SNo_add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)) HmxS (SNo_minus_SNo (apply_fun ((State N0) 0) x) HgN0xS)))
																	              (SNo_abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)))
																	                (SNo_add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)) HgN0xS (SNo_minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x) HnxS)))
																	              HetaS HetaS
																	              Habs_mN0 Habs_nN0). }
																	          claim HtriMN: abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)))
																	            <= add_SNo
																	              (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	              (abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)))).
																	          { exact (abs_SNo_triangle (apply_fun ((State (add_nat km N0)) 0) x) (apply_fun ((State N0) 0) x) (apply_fun ((State (add_nat kn N0)) 0) x)
																	              HmxS HgN0xS HnxS). }
																	          claim HabsLt: abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))) < eps0.
																	          { exact (SNoLeLt_tra
																	              (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))))
																	              (add_SNo
																	                (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	                (abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))))
																	              )
																	              eps0
																	              (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)))
																	                (SNo_add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)) HmxS (SNo_minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x) HnxS)))
																	              (SNo_add_SNo
																	                (abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x))))
																	                (abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x))))
																	                (SNo_abs_SNo (add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)))
																	                  (SNo_add_SNo (apply_fun ((State (add_nat km N0)) 0) x) (minus_SNo (apply_fun ((State N0) 0) x)) HmxS (SNo_minus_SNo (apply_fun ((State N0) 0) x) HgN0xS)))
																	                (SNo_abs_SNo (add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)))
																	                  (SNo_add_SNo (apply_fun ((State N0) 0) x) (minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x)) HgN0xS (SNo_minus_SNo (apply_fun ((State (add_nat kn N0)) 0) x) HnxS))))
																	              Heps0S
																	              HtriMN
																	              HsumLt). }
																	          claim Hpair: (apply_fun ((State (add_nat km N0)) 0) x, apply_fun ((State (add_nat kn N0)) 0) x) :e setprod R R.
																	          { exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun ((State (add_nat km N0)) 0) x) (apply_fun ((State (add_nat kn N0)) 0) x) HmxR HnxR). }
																	          claim HdefM: R_bounded_metric =
																	            graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).
																	          { reflexivity. }
																	          rewrite HdefM.
																	          rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1))
																	            (apply_fun ((State (add_nat km N0)) 0) x, apply_fun ((State (add_nat kn N0)) 0) x) Hpair).
																	          rewrite (tuple_2_0_eq (apply_fun ((State (add_nat km N0)) 0) x) (apply_fun ((State (add_nat kn N0)) 0) x)).
																	          rewrite (tuple_2_1_eq (apply_fun ((State (add_nat km N0)) 0) x) (apply_fun ((State (add_nat kn N0)) 0) x)).
																	          exact (abs_lt_lt1_imp_R_bounded_distance_lt
																	            (apply_fun ((State (add_nat km N0)) 0) x)
																	            (apply_fun ((State (add_nat kn N0)) 0) x)
																	            eps0
																		            HmxR HnxR Heps0R Heps0Lt1 HabsLt). }
																	      apply (SNoLt_trichotomy_or_impred eps 1 HepsS SNo_1
																	        (exists N:set, N :e omega /\
																	          forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	            forall x:set, x :e X ->
																	              Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps)).
																	      - assume HepsLt1S: eps < 1.
																	        claim HepsLt1: Rlt eps 1.
																	        { exact (RltI eps 1 HepsR real_1 HepsLt1S). }
																	        exact (Huc_small eps HepsR HepsPos HepsLt1).
																	      - assume HepsEq1: eps = 1.
																	        claim HexN: exists N:set, N :e omega /\
																	          forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	            forall x:set, x :e X ->
																	              Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1).
																	        { exact (Huc_small (eps_ 1) eps_1_in_R eps_1_pos_R eps_1_lt1_R). }
																	        apply HexN.
																	        let N. assume HN.
																	        witness N.
																	        apply andI.
																	        + exact (andEL (N :e omega)
																	            (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	              forall x:set, x :e X ->
																	                Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1))
																	            HN).
																	        + let m n. assume HmO: m :e omega. assume HnO: n :e omega.
																	          assume HNm: N c= m. assume HNn: N c= n.
																	          let x. assume HxX: x :e X.
																	          claim HNprop:
																	            forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	              forall x:set, x :e X ->
																	                Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1).
																	          { exact (andER (N :e omega)
																	              (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
																	                forall x:set, x :e X ->
																	                  Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1))
																	              HN). }
																	          claim Hlt1: Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1).
																	          { exact (HNprop m n HmO HnO HNm HNn x HxX). }
																	          claim Hlt2: Rlt (eps_ 1) eps.
																	          { rewrite HepsEq1.
																	            exact eps_1_lt1_R. }
																	          exact (Rlt_tra (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) (eps_ 1) eps Hlt1 Hlt2).
																	      - assume H1LtEpsS: 1 < eps.
																	        claim H1LtEps: Rlt 1 eps.
																	        { exact (RltI 1 eps real_1 HepsR H1LtEpsS). }
																	        witness 0.
																        apply andI.
																        + exact (nat_p_omega 0 nat_0).
																        + let m n. assume HmO: m :e omega. assume HnO: n :e omega.
																          assume HNm: 0 c= m. assume HNn: 0 c= n.
																          let x. assume HxX: x :e X.
																          prove Rlt (apply_fun R_bounded_metric (apply_fun (apply_fun fn m) x, apply_fun (apply_fun fn n) x)) eps.
																          claim HfnDef: fn = graph omega (fun k:set => (State k) 0).
																          { reflexivity. }
																          rewrite (apply_fun_of_graph_eq fn omega (fun k:set => (State k) 0) m HfnDef HmO).
																          rewrite (apply_fun_of_graph_eq fn omega (fun k:set => (State k) 0) n HfnDef HnO).
																          claim HmFS: (State m) 0 :e function_space X R.
																          { exact (HInv_g_FS m HmO). }
																          claim HnFS: (State n) 0 :e function_space X R.
																          { exact (HInv_g_FS n HnO). }
																          claim Hm_on: function_on ((State m) 0) X R.
																          { exact (function_on_of_function_space ((State m) 0) X R HmFS). }
																          claim Hn_on: function_on ((State n) 0) X R.
																          { exact (function_on_of_function_space ((State n) 0) X R HnFS). }
																          claim HmxR: apply_fun ((State m) 0) x :e R.
																          { exact (Hm_on x HxX). }
																          claim HnxR: apply_fun ((State n) 0) x :e R.
																          { exact (Hn_on x HxX). }
																          claim Hpair: (apply_fun ((State m) 0) x, apply_fun ((State n) 0) x) :e setprod R R.
																          { exact (tuple_2_setprod_by_pair_Sigma R R (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x) HmxR HnxR). }
																          claim HdefM: R_bounded_metric =
																            graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)).
																          { reflexivity. }
																          rewrite HdefM.
																          rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1))
																                                    (apply_fun ((State m) 0) x, apply_fun ((State n) 0) x) Hpair).
																          rewrite (tuple_2_0_eq (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x)).
																          rewrite (tuple_2_1_eq (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x)).
																          claim Hle1: Rle (R_bounded_distance (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x)) 1.
																          { exact (R_bounded_distance_le_1 (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x) HmxR HnxR). }
																          exact (Rle_Rlt_tra (R_bounded_distance (apply_fun ((State m) 0) x) (apply_fun ((State n) 0) x)) 1 eps Hle1 H1LtEps). }
														  apply Hexfn.
															  let fn. assume Hfnpack:
															    function_on fn omega (function_space X R) /\
															    (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)) /\
															    (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I) /\
															    (forall x:set, x :e A ->
															      converges_to R (metric_topology R R_bounded_metric)
															        (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
															        (apply_fun f x)) /\
															    uniform_cauchy_metric X R R_bounded_metric fn.
															  claim Hfn1234:
															    ((function_on fn omega (function_space X R) /\
															      (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
															     /\
															     (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
															    /\
															    (forall x:set, x :e A ->
															      converges_to R (metric_topology R R_bounded_metric)
															        (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
															        (apply_fun f x)).
															  { exact (andEL
															      (((function_on fn omega (function_space X R) /\
															         (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
															        /\
															        (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
															       /\
															       (forall x:set, x :e A ->
															         converges_to R (metric_topology R R_bounded_metric)
															           (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
															           (apply_fun f x)))
															      (uniform_cauchy_metric X R R_bounded_metric fn)
															      Hfnpack). }
															  claim Hfn3: uniform_cauchy_metric X R R_bounded_metric fn.
															  { exact (andER
															      ((((function_on fn omega (function_space X R) /\
															          (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
															         /\
															         (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
															        /\
															        (forall x:set, x :e A ->
															          converges_to R (metric_topology R R_bounded_metric)
															            (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
															            (apply_fun f x))))
															      (uniform_cauchy_metric X R R_bounded_metric fn)
															      Hfnpack). }
																  claim Hfn123:
																    (function_on fn omega (function_space X R) /\
																     (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
																    /\
																    (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I).
																  { exact (andEL
																      ((function_on fn omega (function_space X R) /\
																        (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
																       /\
																       (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
																      (forall x:set, x :e A ->
																        converges_to R (metric_topology R R_bounded_metric)
																          (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
																          (apply_fun f x))
																      Hfn1234). }
																  claim HfnLimA:
																    forall x:set, x :e A ->
																      converges_to R (metric_topology R R_bounded_metric)
																        (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
																        (apply_fun f x).
																  { exact (andER
																      ((function_on fn omega (function_space X R) /\
																        (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
																       /\
																       (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I))
																      (forall x:set, x :e A ->
																        converges_to R (metric_topology R R_bounded_metric)
																          (graph omega (fun n:set => apply_fun (apply_fun fn n) x))
																          (apply_fun f x))
																      Hfn1234). }
															  claim Hfn12:
															    function_on fn omega (function_space X R) /\
															    (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)).
															  { exact (andEL
															      (function_on fn omega (function_space X R) /\
															       (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
															      (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I)
															      Hfn123). }
															  claim HfnRange:
															    forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I.
															  { exact (andER
															      (function_on fn omega (function_space X R) /\
															       (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n)))
															      (forall n:set, n :e omega -> forall x:set, x :e X -> apply_fun (apply_fun fn n) x :e I)
															      Hfn123). }
															  claim Hfn1: function_on fn omega (function_space X R).
															  { exact (andEL
															      (function_on fn omega (function_space X R))
															      (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n))
															      Hfn12). }
															  claim Hfn2: forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n).
															  { exact (andER
															      (function_on fn omega (function_space X R))
															      (forall n:set, n :e omega -> continuous_map X Tx R R_standard_topology (apply_fun fn n))
															      Hfn12). }
														  claim HexgR: exists gR:set,
														    function_on gR X R /\
														    uniform_limit_metric X R R_bounded_metric fn gR /\
														    continuous_map X Tx R R_standard_topology gR.
														  { exact (uniform_cauchy_continuous_to_R_has_continuous_limit
														           X Tx fn
														           HTx
														           Hfn1
														           Hfn2
														           Hfn3). }
														  apply HexgR.
															  let gR. assume HgRpack:
															    function_on gR X R /\
															    uniform_limit_metric X R R_bounded_metric fn gR /\
															    continuous_map X Tx R R_standard_topology gR.
															  witness gR.
															  apply andI.
															  - apply andI.
															    + exact (andER (function_on gR X R /\ uniform_limit_metric X R R_bounded_metric fn gR)
															                   (continuous_map X Tx R R_standard_topology gR)
															                   HgRpack).
															    + let x. assume HxA: x :e A.
															      prove apply_fun gR x = apply_fun f x.
															      apply (xm (apply_fun gR x = apply_fun f x)).
															      - assume Heq: apply_fun gR x = apply_fun f x.
															        exact Heq.
															      - assume Hneq: ~(apply_fun gR x = apply_fun f x).
															        prove apply_fun gR x = apply_fun f x.
															        apply FalseE.
															        claim HxX': x :e X.
															        { exact (HAsubX x HxA). }
															        claim HmR: metric_on R R_bounded_metric.
															        { exact R_bounded_metric_is_metric_on_early. }
															        claim HHaus: Hausdorff_space R (metric_topology R R_bounded_metric).
															        { exact (metric_topology_Hausdorff R R_bounded_metric HmR). }
															        claim HgR12: function_on gR X R /\ uniform_limit_metric X R R_bounded_metric fn gR.
															        { exact (andEL
															            (function_on gR X R /\ uniform_limit_metric X R R_bounded_metric fn gR)
															            (continuous_map X Tx R R_standard_topology gR)
															            HgRpack). }
															        claim HgRfun: function_on gR X R.
															        { exact (andEL
															            (function_on gR X R)
															            (uniform_limit_metric X R R_bounded_metric fn gR)
															            HgR12). }
															        claim HunifRgR: uniform_limit_metric X R R_bounded_metric fn gR.
															        { exact (andER
															            (function_on gR X R)
															            (uniform_limit_metric X R R_bounded_metric fn gR)
															            HgR12). }
															        set seqx := graph omega (fun n:set => apply_fun (apply_fun fn n) x).
															        claim Hxlim_g: converges_to R (metric_topology R R_bounded_metric) seqx (apply_fun gR x).
															        { exact (uniform_limit_metric_imp_converges_to_metric_topology_at_point
															                 X R R_bounded_metric fn gR x
															                 HmR Hfn1 HgRfun HxX' HunifRgR). }
															        claim Hxlim_f: converges_to R (metric_topology R R_bounded_metric) seqx (apply_fun f x).
															        { exact (HfnLimA x HxA). }
															        claim HgxR: apply_fun gR x :e R.
															        { exact (HgRfun x HxX'). }
															        claim HfxR: apply_fun f x :e R.
															        { exact (Hf_R x HxA). }
															        claim Hneqxy: apply_fun gR x <> apply_fun f x.
															        { assume Heq: apply_fun gR x = apply_fun f x.
															          exact (Hneq Heq). }
															        claim Hseq_on: function_on seqx omega R.
															        { let n. assume HnO: n :e omega.
															          prove apply_fun seqx n :e R.
															          claim Hseqxdef: seqx = graph omega (fun n0:set => apply_fun (apply_fun fn n0) x).
															          { reflexivity. }
															          rewrite (apply_fun_of_graph_eq seqx omega (fun n0:set => apply_fun (apply_fun fn n0) x) n Hseqxdef HnO).
															          claim HfnnxI: apply_fun (apply_fun fn n) x :e I.
															          { exact (HfnRange n HnO x HxX'). }
															          exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun (apply_fun fn n) x) HfnnxI). }
															        claim Hnbhd_g:
															          forall U:set, U :e metric_topology R R_bounded_metric -> apply_fun gR x :e U ->
															            exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seqx n :e U.
															        { exact (converges_to_neighborhoods
															            R (metric_topology R R_bounded_metric) seqx (apply_fun gR x)
															            Hxlim_g). }
															        claim Hnbhd_f:
															          forall U:set, U :e metric_topology R R_bounded_metric -> apply_fun f x :e U ->
															            exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seqx n :e U.
															        { exact (converges_to_neighborhoods
															            R (metric_topology R R_bounded_metric) seqx (apply_fun f x)
															            Hxlim_f). }
															        exact (Hausdorff_unique_limits
															            R (metric_topology R R_bounded_metric) seqx (apply_fun gR x) (apply_fun f x)
															            HHaus
															            HgxR
															            HfxR
															            Hneqxy
															            Hseq_on
															            Hnbhd_g
															            Hnbhd_f).
															  - let x. assume HxX: x :e X.
															    prove apply_fun gR x :e I.
															    claim HmR: metric_on R R_bounded_metric.
															    { exact R_bounded_metric_is_metric_on_early. }
															    claim HTmR: topology_on R (metric_topology R R_bounded_metric).
															    { exact (metric_topology_is_topology R R_bounded_metric HmR). }
															    claim HI_sub_R: I c= R.
															    { exact (closed_interval_sub_R (minus_SNo 1) 1). }
															    claim Hm1R': (minus_SNo 1) :e R.
															    { exact (real_minus_SNo 1 real_1). }
															    claim HI_closed: closed_in R (metric_topology R R_bounded_metric) I.
															    { rewrite metric_topology_R_bounded_metric_eq_R_standard_topology_early.
															      exact (closed_interval_closed_in_R_standard_topology (minus_SNo 1) 1 Hm1R' real_1). }
															    claim HgR12: function_on gR X R /\ uniform_limit_metric X R R_bounded_metric fn gR.
															    { exact (andEL
															        (function_on gR X R /\ uniform_limit_metric X R R_bounded_metric fn gR)
															        (continuous_map X Tx R R_standard_topology gR)
															        HgRpack). }
															    claim HgRfun: function_on gR X R.
															    { exact (andEL
															        (function_on gR X R)
															        (uniform_limit_metric X R R_bounded_metric fn gR)
															        HgR12). }
															    claim HunifRgR: uniform_limit_metric X R R_bounded_metric fn gR.
															    { exact (andER
															        (function_on gR X R)
															        (uniform_limit_metric X R R_bounded_metric fn gR)
															        HgR12). }
															    set seqx := graph omega (fun n:set => apply_fun (apply_fun fn n) x).
															    claim Hconvx: converges_to R (metric_topology R R_bounded_metric) seqx (apply_fun gR x).
															    { exact (uniform_limit_metric_imp_converges_to_metric_topology_at_point
															             X R R_bounded_metric fn gR x
															             HmR Hfn1 HgRfun HxX HunifRgR). }
															    claim HseqxI: forall n:set, n :e omega -> apply_fun seqx n :e I.
															    { let n. assume HnO: n :e omega.
															      claim Hseqxdef: seqx = graph omega (fun n0:set => apply_fun (apply_fun fn n0) x).
															      { reflexivity. }
															      rewrite (apply_fun_of_graph_eq seqx omega (fun n0:set => apply_fun (apply_fun fn n0) x) n Hseqxdef HnO).
															      exact (HfnRange n HnO x HxX). }
															    exact (converges_to_closed_in_contains_limit
															           R (metric_topology R R_bounded_metric) I seqx (apply_fun gR x)
															           HTmR
															           HI_sub_R
															           HI_closed
															           Hconvx
															           HseqxI). }
														exact Hseries.
											Qed.

Theorem Tietze_stepII_real_extension : forall X Tx A f:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f ->
  exists gR:set,
    continuous_map X Tx R R_standard_topology gR /\
    (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
    (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f.
prove exists gR:set,
  continuous_map X Tx R R_standard_topology gR /\
  (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
  (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1).
claim HA_cases: A = Empty \/ ~(A = Empty).
{ exact (xm (A = Empty)). }
apply (HA_cases (exists gR:set,
  continuous_map X Tx R R_standard_topology gR /\
  (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
  (forall x:set, x :e X -> apply_fun gR x :e closed_interval (minus_SNo 1) 1))).
- assume HAemp: A = Empty.
  witness (const_fun X 0).
  prove continuous_map X Tx R R_standard_topology (const_fun X 0) /\
    (forall x:set, x :e A -> apply_fun (const_fun X 0) x = apply_fun f x) /\
    (forall x:set, x :e X -> apply_fun (const_fun X 0) x :e closed_interval (minus_SNo 1) 1).
  apply andI.
  - (** left: continuity and agreement on A **)
    apply andI.
    + (** continuity of the constant map **)
      claim HTx: topology_on X Tx.
      { exact (normal_space_topology_on X Tx Hnorm). }
      exact (const_fun_continuous X Tx R R_standard_topology 0 HTx R_standard_topology_is_topology_local real_0).
    + (** agreement on A (vacuous) **)
      let x. assume HxA: x :e A.
      prove apply_fun (const_fun X 0) x = apply_fun f x.
      apply FalseE.
      claim HxE: x :e Empty.
      { rewrite <- HAemp.
        exact HxA. }
      exact (EmptyE x HxE).
  - (** range in [-1,1] **)
    let x. assume HxX: x :e X.
    prove apply_fun (const_fun X 0) x :e closed_interval (minus_SNo 1) 1.
    rewrite (const_fun_apply X 0 x HxX).
    exact zero_in_closed_interval_minus1_1.
- assume HAnemp: ~(A = Empty).
  exact (Tietze_stepII_real_extension_nonempty X Tx A f Hnorm HA HAnemp Hf).
Qed.

(** helper for §35: Tietze extension theorem for the range [-1,1] (Step I-II skeleton) **)
Theorem Tietze_extension_minus1_1 : forall X Tx A f:set,
  normal_space X Tx -> closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f ->
  exists g:set,
    continuous_map X Tx (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) f.
prove exists g:set,
  continuous_map X Tx (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
claim HA_cases: A = Empty \/ ~(A = Empty).
{ exact (xm (A = Empty)). }
apply (HA_cases (exists g:set,
  continuous_map X Tx (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x))).
- assume HAemp: A = Empty.
  witness (const_fun X 0).
  apply andI.
  + (** const_fun is continuous into [-1,1] **)
    claim HTx: topology_on X Tx.
    { exact (normal_space_topology_on X Tx Hnorm). }
    claim HCI_top: topology_on (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1).
    { exact (closed_interval_topology_on (minus_SNo 1) 1). }
    claim H0I: 0 :e closed_interval (minus_SNo 1) 1.
    { exact zero_in_closed_interval_minus1_1. }
    exact (const_fun_continuous X Tx
            (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
            0 HTx HCI_top H0I).
  + let x. assume HxA: x :e A.
    prove apply_fun (const_fun X 0) x = apply_fun f x.
    claim HxE: x :e Empty.
    { rewrite <- HAemp. exact HxA. }
    apply FalseE.
    exact ((EmptyE x) HxE).
- assume HAne: ~(A = Empty).
(** TeX §35: Step I uses Urysohn lemma to build a continuous g0:X -> [-1/3,1/3] with prescribed values on the extreme preimage sets. **)
claim HstepI:
  exists g0:set,
    continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0 /\
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = minus_SNo one_third) /\
    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = one_third).
{ exact (Tietze_stepI_g_exists X Tx A f Hnorm HA Hf). }
(** TeX §35: Step II iterates Step I to obtain a uniformly convergent series of continuous functions on X approximating f on A. **)
apply HstepI.
let g0.
assume Hg0:
  continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0 /\
  (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g0 x = minus_SNo one_third) /\
  (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g0 x = one_third).
claim Hcore:
  continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0
  /\
  (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g0 x = minus_SNo one_third).
{ exact (andEL
    (continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0
     /\
     (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
       apply_fun g0 x = minus_SNo one_third))
    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = one_third)
    Hg0). }
claim Hg0cont:
  continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0.
{ exact (andEL
    (continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0)
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = minus_SNo one_third)
    Hcore). }
claim Hg0_on_B:
  forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g0 x = minus_SNo one_third.
{ exact (andER
    (continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0)
    (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = minus_SNo one_third)
    Hcore). }
claim Hg0_on_C:
  forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
    apply_fun g0 x = one_third.
{ exact (andER
    (continuous_map X Tx (closed_interval (minus_SNo one_third) one_third) (closed_interval_topology (minus_SNo one_third) one_third) g0
     /\
     (forall x:set, x :e preimage_of A f ((closed_interval (minus_SNo 1) (minus_SNo one_third)) :/\: (closed_interval (minus_SNo 1) 1)) ->
       apply_fun g0 x = minus_SNo one_third))
    (forall x:set, x :e preimage_of A f ((closed_interval one_third 1) :/\: (closed_interval (minus_SNo 1) 1)) ->
      apply_fun g0 x = one_third)
    Hg0). }

claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A HA). }

(** TeX §35: define the Step I residual on A as f1 = f - g0|A and show f1 maps into [-2/3,2/3]. **)
set f1 := graph A (fun x:set => add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
set I := closed_interval (minus_SNo 1) 1.
set Ti := closed_interval_topology (minus_SNo 1) 1.
set I0 := closed_interval (minus_SNo one_third) one_third.
set T0 := closed_interval_topology (minus_SNo one_third) one_third.

claim Hfunf: function_on f A I.
{ exact (continuous_map_function_on A (subspace_topology X Tx A) I Ti f Hf). }
claim Hfung0: function_on g0 X I0.
{ exact (continuous_map_function_on X Tx I0 T0 g0 Hg0cont). }

claim Hf1_total: total_function_on f1 A R.
{ apply (total_function_on_graph A R (fun x:set => add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))).
  let x. assume HxA: x :e A.
  prove add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)) :e R.
  claim HfxI: apply_fun f x :e I.
  { exact (Hfunf x HxA). }
  claim HfxR: apply_fun f x :e R.
  { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun f x) HfxI). }
  claim HxX: x :e X.
  { exact (HAsubX x HxA). }
  claim Hg0xI0: apply_fun g0 x :e I0.
  { exact (Hfung0 x HxX). }
  claim Hg0xR: apply_fun g0 x :e R.
  { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0xI0). }
  claim HnegR: minus_SNo (apply_fun g0 x) :e R.
  { exact (real_minus_SNo (apply_fun g0 x) Hg0xR). }
  exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo (apply_fun g0 x)) HnegR). }
claim Hf1fun: function_on f1 A R.
{ exact (andEL (function_on f1 A R)
               (forall a:set, a :e A -> exists y:set, y :e R /\ (a,y) :e f1)
               Hf1_total). }
claim Hf1_apply: forall x:set, x :e A ->
  apply_fun f1 x = add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)).
{ let x. assume HxA: x :e A.
  rewrite (apply_fun_graph A (fun x0:set => add_SNo (apply_fun f x0) (minus_SNo (apply_fun g0 x0))) x HxA).
  reflexivity. }

(** TeX §35 Step I: define the extreme subintervals and corresponding preimages **)
set I1 := closed_interval (minus_SNo 1) (minus_SNo one_third).
set I3 := closed_interval one_third 1.
set I2 := closed_interval (minus_SNo two_thirds) two_thirds.
set B := preimage_of A f (I1 :/\: I).
set C := preimage_of A f (I3 :/\: I).

(** TeX §35 Step I: residual range bound, used for Step II scaling **)
claim Hf1_range: forall x:set, x :e A -> apply_fun f1 x :e I2.
{ let x. assume HxA: x :e A.
  claim HfxI: apply_fun f x :e I.
  { exact (Hfunf x HxA). }
  claim HxX: x :e X.
  { exact (HAsubX x HxA). }
  claim Hcase1: apply_fun f x :e I1 \/ ~(apply_fun f x :e I1).
  { exact (xm (apply_fun f x :e I1)). }
  apply (Hcase1 (apply_fun f1 x :e I2)).
  - assume HfxI1: apply_fun f x :e I1.
    claim HfxI1I: apply_fun f x :e I1 :/\: I.
    { exact (binintersectI I1 I (apply_fun f x) HfxI1 HfxI). }
    claim HxB: x :e B.
    { exact (SepI A (fun x0:set => apply_fun f x0 :e I1 :/\: I) x HxA HfxI1I). }
    claim Hg0eq: apply_fun g0 x = minus_SNo one_third.
    { exact (Hg0_on_B x HxB). }
    claim Hf1eq: apply_fun f1 x = add_SNo (apply_fun f x) one_third.
    { rewrite (Hf1_apply x HxA).
      rewrite Hg0eq at 1.
      claim H13R: one_third :e R.
      { exact one_third_in_R. }
      rewrite (minus_SNo_minus_SNo_real one_third H13R) at 1.
      reflexivity. }
    rewrite Hf1eq.
    claim H13R: one_third :e R.
    { exact one_third_in_R. }
    claim H23R: two_thirds :e R.
    { exact two_thirds_in_R. }
    claim Hm23R: minus_SNo two_thirds :e R.
    { exact (real_minus_SNo two_thirds H23R). }
    claim Hm1R: minus_SNo 1 :e R.
    { exact (real_minus_SNo 1 real_1). }
    claim Hm13R: minus_SNo one_third :e R.
    { exact (real_minus_SNo one_third H13R). }
    claim HfxR: apply_fun f x :e R.
    { exact (closed_interval_sub_R (minus_SNo 1) (minus_SNo one_third) (apply_fun f x) HfxI1). }
    claim Hfx_bounds: Rle (minus_SNo 1) (apply_fun f x) /\ Rle (apply_fun f x) (minus_SNo one_third).
    { exact (closed_interval_bounds (minus_SNo 1) (minus_SNo one_third) (apply_fun f x)
                                   Hm1R Hm13R HfxI1). }
    claim Hm1lefx: Rle (minus_SNo 1) (apply_fun f x).
    { exact (andEL (Rle (minus_SNo 1) (apply_fun f x))
                   (Rle (apply_fun f x) (minus_SNo one_third)) Hfx_bounds). }
    claim Hfxlem13: Rle (apply_fun f x) (minus_SNo one_third).
    { exact (andER (Rle (minus_SNo 1) (apply_fun f x))
                   (Rle (apply_fun f x) (minus_SNo one_third)) Hfx_bounds). }
    claim Hf1R: add_SNo (apply_fun f x) one_third :e R.
    { exact (real_add_SNo (apply_fun f x) HfxR one_third H13R). }
    claim Hlow_tmp: Rle (add_SNo (minus_SNo 1) one_third) (add_SNo (apply_fun f x) one_third).
    { exact (Rle_add_SNo_1 (minus_SNo 1) (apply_fun f x) one_third Hm1R HfxR H13R Hm1lefx). }
    claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) one_third).
    { rewrite minus_two_thirds_eq_minus1_plus_one_third at 1.
      exact Hlow_tmp. }
    claim Hup0_tmp: Rle (add_SNo (apply_fun f x) one_third) (add_SNo (minus_SNo one_third) one_third).
    { exact (Rle_add_SNo_1 (apply_fun f x) (minus_SNo one_third) one_third HfxR Hm13R H13R Hfxlem13). }
    claim H13S: SNo one_third.
    { exact (real_SNo one_third H13R). }
    claim Hup0: Rle (add_SNo (apply_fun f x) one_third) 0.
    { rewrite <- (add_SNo_minus_SNo_linv one_third H13S) at 1.
      exact Hup0_tmp. }
    claim H0le23: Rle 0 two_thirds.
    { exact Rle_0_two_thirds. }
    claim Hup: Rle (add_SNo (apply_fun f x) one_third) two_thirds.
    { exact (Rle_tra (add_SNo (apply_fun f x) one_third) 0 two_thirds Hup0 H0le23). }
    exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds (add_SNo (apply_fun f x) one_third)
                                  Hm23R H23R Hf1R Hlow Hup).
  - assume HnotI1: ~(apply_fun f x :e I1).
    claim Hcase3: apply_fun f x :e I3 \/ ~(apply_fun f x :e I3).
    { exact (xm (apply_fun f x :e I3)). }
    apply (Hcase3 (apply_fun f1 x :e I2)).
    + assume HfxI3: apply_fun f x :e I3.
      claim HfxI3I: apply_fun f x :e I3 :/\: I.
      { exact (binintersectI I3 I (apply_fun f x) HfxI3 HfxI). }
      claim HxC: x :e C.
      { exact (SepI A (fun x0:set => apply_fun f x0 :e I3 :/\: I) x HxA HfxI3I). }
      claim Hg0eq: apply_fun g0 x = one_third.
      { exact (Hg0_on_C x HxC). }
	      claim Hf1eq: apply_fun f1 x = add_SNo (apply_fun f x) (minus_SNo one_third).
	      { rewrite (Hf1_apply x HxA).
	        rewrite Hg0eq at 1.
	        reflexivity. }
	      rewrite Hf1eq.
	      claim H13R: one_third :e R.
	      { exact one_third_in_R. }
	      claim H23R: two_thirds :e R.
	      { exact two_thirds_in_R. }
	      claim Hm23R: minus_SNo two_thirds :e R.
	      { exact (real_minus_SNo two_thirds H23R). }
	      claim Hm13R: minus_SNo one_third :e R.
	      { exact (real_minus_SNo one_third H13R). }
	      claim HfxR: apply_fun f x :e R.
	      { exact (closed_interval_sub_R one_third 1 (apply_fun f x) HfxI3). }
	      claim Hfx_bounds: Rle one_third (apply_fun f x) /\ Rle (apply_fun f x) 1.
	      { exact (closed_interval_bounds one_third 1 (apply_fun f x) H13R real_1 HfxI3). }
	      claim H13lefx: Rle one_third (apply_fun f x).
	      { exact (andEL (Rle one_third (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds). }
	      claim Hfxle1: Rle (apply_fun f x) 1.
	      { exact (andER (Rle one_third (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds). }
	      claim Hf1R: add_SNo (apply_fun f x) (minus_SNo one_third) :e R.
	      { exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo one_third) Hm13R). }
	      claim H0le_f1_tmp: Rle (add_SNo one_third (minus_SNo one_third))
	                             (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 one_third (apply_fun f x) (minus_SNo one_third) H13R HfxR Hm13R H13lefx). }
	      claim H13S: SNo one_third.
	      { exact (real_SNo one_third H13R). }
	      claim H0le_f1: Rle 0 (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { rewrite <- (add_SNo_minus_SNo_rinv one_third H13S) at 1.
	        exact H0le_f1_tmp. }
	      claim Hm23le0: Rle (minus_SNo two_thirds) 0.
	      { exact Rle_minus_two_thirds_0. }
	      claim Hlow: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_tra (minus_SNo two_thirds) 0 (add_SNo (apply_fun f x) (minus_SNo one_third)) Hm23le0 H0le_f1). }
	      claim Hup_tmp: Rle (add_SNo (apply_fun f x) (minus_SNo one_third))
	                           (add_SNo 1 (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 (apply_fun f x) 1 (minus_SNo one_third) HfxR real_1 Hm13R Hfxle1). }
	      claim Hup: Rle (add_SNo (apply_fun f x) (minus_SNo one_third)) two_thirds.
	      { rewrite two_thirds_eq_1_minus_one_third at 1.
	        exact Hup_tmp. }
	      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
	                                     (add_SNo (apply_fun f x) (minus_SNo one_third))
	                                     Hm23R H23R Hf1R Hlow Hup).
	    + assume HnotI3: ~(apply_fun f x :e I3).
	      (** TeX §35 Step I: middle case, show f(x) is in [-1/3,1/3] **)
	      claim HfxR: apply_fun f x :e R.
	      { exact (closed_interval_sub_R (minus_SNo 1) 1 (apply_fun f x) HfxI). }
      claim Hm1R: (minus_SNo 1) :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim H13R: one_third :e R.
      { exact one_third_in_R. }
      claim Hm13R: (minus_SNo one_third) :e R.
      { exact (real_minus_SNo one_third H13R). }
      claim Hfx_bounds: Rle (minus_SNo 1) (apply_fun f x) /\ Rle (apply_fun f x) 1.
      { exact (closed_interval_bounds (minus_SNo 1) 1 (apply_fun f x) Hm1R real_1 HfxI). }
      claim Hnlt_fx_m1: ~(Rlt (apply_fun f x) (minus_SNo 1)).
      { exact (RleE_nlt (minus_SNo 1) (apply_fun f x)
                        (andEL (Rle (minus_SNo 1) (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds)). }
      claim Hnlt_1_fx: ~(Rlt 1 (apply_fun f x)).
      { exact (RleE_nlt (apply_fun f x) 1
                        (andER (Rle (minus_SNo 1) (apply_fun f x)) (Rle (apply_fun f x) 1) Hfx_bounds)). }
      claim HnotI1_cases: Rlt (apply_fun f x) (minus_SNo 1) \/ Rlt (minus_SNo one_third) (apply_fun f x).
      { exact (closed_interval_not_mem_cases (minus_SNo 1) (minus_SNo one_third) (apply_fun f x)
                                            Hm1R Hm13R HfxR HnotI1). }
      claim Hm13lt_fx: Rlt (minus_SNo one_third) (apply_fun f x).
      { apply (HnotI1_cases (Rlt (minus_SNo one_third) (apply_fun f x))).
        - assume Hbad: Rlt (apply_fun f x) (minus_SNo 1).
          apply FalseE.
          exact (Hnlt_fx_m1 Hbad).
        - assume Hok: Rlt (minus_SNo one_third) (apply_fun f x).
          exact Hok. }
      claim Hnot_fx_lt_m13: ~(Rlt (apply_fun f x) (minus_SNo one_third)).
      { exact (not_Rlt_sym (minus_SNo one_third) (apply_fun f x) Hm13lt_fx). }
      claim HnotI3_cases: Rlt (apply_fun f x) one_third \/ Rlt 1 (apply_fun f x).
      { exact (closed_interval_not_mem_cases one_third 1 (apply_fun f x)
                                            H13R real_1 HfxR HnotI3). }
      claim Hfx_lt_13: Rlt (apply_fun f x) one_third.
      { apply (HnotI3_cases (Rlt (apply_fun f x) one_third)).
        - assume Hok: Rlt (apply_fun f x) one_third.
          exact Hok.
        - assume Hbad: Rlt 1 (apply_fun f x).
          apply FalseE.
          exact (Hnlt_1_fx Hbad). }
      claim Hnot_13_lt_fx: ~(Rlt one_third (apply_fun f x)).
      { exact (not_Rlt_sym (apply_fun f x) one_third Hfx_lt_13). }
	      claim HfxI0: apply_fun f x :e I0.
	      { claim HI0_def:
	          I0 = {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
        { reflexivity. }
        claim HxSep: apply_fun f x :e {t :e R | ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t)}.
        { exact (SepI R (fun t:set => ~(Rlt t (minus_SNo one_third)) /\ ~(Rlt one_third t))
                      (apply_fun f x) HfxR (andI (~(Rlt (apply_fun f x) (minus_SNo one_third)))
                                                 (~(Rlt one_third (apply_fun f x)))
                                                 Hnot_fx_lt_m13
                                                 Hnot_13_lt_fx)). }
	        rewrite HI0_def.
	        exact HxSep. }
	      rewrite (Hf1_apply x HxA).
	      claim Hg0xI0: apply_fun g0 x :e I0.
	      { exact (Hfung0 x HxX). }
	      claim Hg0xR: apply_fun g0 x :e R.
	      { exact (closed_interval_sub_R (minus_SNo one_third) one_third (apply_fun g0 x) Hg0xI0). }
	      claim Hm_g0x_R: minus_SNo (apply_fun g0 x) :e R.
	      { exact (real_minus_SNo (apply_fun g0 x) Hg0xR). }
	      claim Hf1xR: add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)) :e R.
	      { exact (real_add_SNo (apply_fun f x) HfxR (minus_SNo (apply_fun g0 x)) Hm_g0x_R). }
	      claim H13R: one_third :e R.
	      { exact one_third_in_R. }
	      claim Hm13R: (minus_SNo one_third) :e R.
	      { exact (real_minus_SNo one_third H13R). }
	      claim H23R: two_thirds :e R.
	      { exact two_thirds_in_R. }
	      claim Hm23R: (minus_SNo two_thirds) :e R.
	      { exact (real_minus_SNo two_thirds H23R). }
	      claim Hfx0_bounds: Rle (minus_SNo one_third) (apply_fun f x) /\ Rle (apply_fun f x) one_third.
	      { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun f x) Hm13R H13R HfxI0). }
	      claim Hg0x_bounds: Rle (minus_SNo one_third) (apply_fun g0 x) /\ Rle (apply_fun g0 x) one_third.
	      { exact (closed_interval_bounds (minus_SNo one_third) one_third (apply_fun g0 x) Hm13R H13R Hg0xI0). }
	      claim Hm13_le_fx: Rle (minus_SNo one_third) (apply_fun f x).
	      { exact (andEL (Rle (minus_SNo one_third) (apply_fun f x)) (Rle (apply_fun f x) one_third) Hfx0_bounds). }
	      claim Hfx_le_13: Rle (apply_fun f x) one_third.
	      { exact (andER (Rle (minus_SNo one_third) (apply_fun f x)) (Rle (apply_fun f x) one_third) Hfx0_bounds). }
	      claim Hm13_le_g0x: Rle (minus_SNo one_third) (apply_fun g0 x).
	      { exact (andEL (Rle (minus_SNo one_third) (apply_fun g0 x)) (Rle (apply_fun g0 x) one_third) Hg0x_bounds). }
	      claim Hg0x_le_13: Rle (apply_fun g0 x) one_third.
	      { exact (andER (Rle (minus_SNo one_third) (apply_fun g0 x)) (Rle (apply_fun g0 x) one_third) Hg0x_bounds). }
	      claim Hm13_le_mg0x: Rle (minus_SNo one_third) (minus_SNo (apply_fun g0 x)).
	      { exact (Rle_minus_contra (apply_fun g0 x) one_third Hg0x_le_13). }
      claim Hmg0x_le_13: Rle (minus_SNo (apply_fun g0 x)) one_third.
      { claim Htmp: Rle (minus_SNo (apply_fun g0 x)) (minus_SNo (minus_SNo one_third)).
        { exact (Rle_minus_contra (minus_SNo one_third) (apply_fun g0 x) Hm13_le_g0x). }
        claim H13R: one_third :e R.
        { exact one_third_in_R. }
        rewrite <- (minus_SNo_minus_SNo_real one_third H13R) at 1.
        exact Htmp. }
	
	      claim Hlo1: Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
	                     (add_SNo (apply_fun f x) (minus_SNo one_third)).
	      { exact (Rle_add_SNo_1 (minus_SNo one_third) (apply_fun f x) (minus_SNo one_third)
	                             Hm13R HfxR Hm13R Hm13_le_fx). }
	      claim Hlo2: Rle (add_SNo (apply_fun f x) (minus_SNo one_third))
	                     (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
	      { exact (Rle_add_SNo_2 (apply_fun f x) (minus_SNo one_third) (minus_SNo (apply_fun g0 x))
	                             HfxR Hm13R Hm_g0x_R Hm13_le_mg0x). }
      claim Hlo': Rle (add_SNo (minus_SNo one_third) (minus_SNo one_third))
                     (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
      { exact (Rle_tra (add_SNo (minus_SNo one_third) (minus_SNo one_third))
                       (add_SNo (apply_fun f x) (minus_SNo one_third))
                       (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
                       Hlo1 Hlo2). }
	      claim Hlo: Rle (minus_SNo two_thirds) (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))).
	      { rewrite (minus_two_thirds_eq) at 1.
	        exact Hlo'. }
	
	      claim Hhi1: Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third (minus_SNo (apply_fun g0 x))).
	      { exact (Rle_add_SNo_1 (apply_fun f x) one_third (minus_SNo (apply_fun g0 x))
	                             HfxR H13R Hm_g0x_R Hfx_le_13). }
	      claim Hhi2: Rle (add_SNo one_third (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third one_third).
	      { exact (Rle_add_SNo_2 one_third (minus_SNo (apply_fun g0 x)) one_third
	                             H13R Hm_g0x_R H13R Hmg0x_le_13). }
	      claim Hhi': Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                     (add_SNo one_third one_third).
	      { exact (Rle_tra (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	                       (add_SNo one_third (minus_SNo (apply_fun g0 x)))
	                       (add_SNo one_third one_third)
	                       Hhi1 Hhi2). }
      claim Hhi: Rle (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x))) two_thirds.
      { claim Hdef23: two_thirds = add_SNo one_third one_third.
        { reflexivity. }
        rewrite Hdef23.
        exact Hhi'. }
	
	      exact (closed_intervalI_of_Rle (minus_SNo two_thirds) two_thirds
	              (add_SNo (apply_fun f x) (minus_SNo (apply_fun g0 x)))
	              Hm23R H23R Hf1xR Hlo Hhi).
	}

	(** TeX §35 Step II: construct a uniformly convergent series of continuous functions on X whose sum extends f. **)
	(** This is the remaining core of the Tietze construction after finishing Step I range control. **)
		claim HstepII:
		  exists g:set,
		    continuous_map X Tx I Ti g /\
		    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
		{ (** structural reduction: first build a real-valued extension, then range-restrict to I **)
		  claim HstepII_R:
		    exists gR:set,
		      continuous_map X Tx R R_standard_topology gR /\
		      (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
		      (forall x:set, x :e X -> apply_fun gR x :e I).
		  { exact (Tietze_stepII_real_extension X Tx A f Hnorm HA Hf). }
		  apply HstepII_R.
		  let gR.
		  assume HgR:
		    continuous_map X Tx R R_standard_topology gR /\
		    (forall x:set, x :e A -> apply_fun gR x = apply_fun f x) /\
		    (forall x:set, x :e X -> apply_fun gR x :e I).
		  witness gR.
		  apply andI.
		  - claim HgRcont: continuous_map X Tx R R_standard_topology gR.
		    { exact (andEL
		      (continuous_map X Tx R R_standard_topology gR)
		      (forall x:set, x :e A -> apply_fun gR x = apply_fun f x)
		      (andEL
		        (continuous_map X Tx R R_standard_topology gR /\ (forall x:set, x :e A -> apply_fun gR x = apply_fun f x))
		        (forall x:set, x :e X -> apply_fun gR x :e I)
		        HgR)). }
		    claim HimgI: forall x:set, x :e X -> apply_fun gR x :e I.
		    { exact (andER
		        (continuous_map X Tx R R_standard_topology gR /\ (forall x:set, x :e A -> apply_fun gR x = apply_fun f x))
		        (forall x:set, x :e X -> apply_fun gR x :e I)
		        HgR). }
		    claim HISubR: I c= R.
		    { exact (closed_interval_sub_R (minus_SNo 1) 1). }
		    claim HTiEq: Ti = subspace_topology R R_standard_topology I.
		    { reflexivity. }
		    rewrite HTiEq.
		    exact (continuous_map_range_restrict X Tx R R_standard_topology gR I HgRcont HISubR HimgI).
		  - exact (andER
		      (continuous_map X Tx R R_standard_topology gR)
		      (forall x:set, x :e A -> apply_fun gR x = apply_fun f x)
		      (andEL
		        (continuous_map X Tx R R_standard_topology gR /\ (forall x:set, x :e A -> apply_fun gR x = apply_fun f x))
		        (forall x:set, x :e X -> apply_fun gR x :e I)
		        HgR)). }
		exact HstepII.
	Qed.

(** helper for §35: existence of an affine homeomorphism between a nondegenerate closed interval and [-1,1] **)
(** LATEX VERSION: For a<b there is an affine homeomorphism between [a,b] and [-1,1], with both directions continuous. **)
Theorem closed_interval_affine_equiv_minus1_1 : forall a b:set,
  Rle a b -> ~(a = b) ->
  exists h:set, exists hinv:set,
    continuous_map (closed_interval a b) (closed_interval_topology a b)
      (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) h /\
    (continuous_map (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
      (closed_interval a b) (closed_interval_topology a b) hinv /\
     ((forall t:set, t :e closed_interval a b -> apply_fun hinv (apply_fun h t) = t) /\
      (forall s:set, s :e closed_interval (minus_SNo 1) 1 -> apply_fun h (apply_fun hinv s) = s))).
let a b.
assume Hab: Rle a b.
assume Hneq: ~(a = b).
prove exists h:set, exists hinv:set,
  continuous_map (closed_interval a b) (closed_interval_topology a b)
    (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1) h /\
  (continuous_map (closed_interval (minus_SNo 1) 1) (closed_interval_topology (minus_SNo 1) 1)
    (closed_interval a b) (closed_interval_topology a b) hinv /\
   ((forall t:set, t :e closed_interval a b -> apply_fun hinv (apply_fun h t) = t) /\
    (forall s:set, s :e closed_interval (minus_SNo 1) 1 -> apply_fun h (apply_fun hinv s) = s))).
set h := graph R (fun t:set =>
  div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t) (minus_SNo (add_SNo a b)))
         (add_SNo b (minus_SNo a))).
set hinv := graph R (fun s:set =>
  div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s) (add_SNo a b))
         (add_SNo 1 1)).
witness h.
witness hinv.
apply andI.
- set Iab := closed_interval a b.
  set Im1 := closed_interval (minus_SNo 1) 1.
  claim HIabSub: Iab c= R.
  { exact (closed_interval_sub_R a b). }
  claim HIm1Sub: Im1 c= R.
  { exact (closed_interval_sub_R (minus_SNo 1) 1). }
  claim HTstd: topology_on R R_standard_topology.
  { exact R_standard_topology_is_topology. }
  claim HhR: continuous_map R R_standard_topology R R_standard_topology h.
  { set Tx := R_standard_topology.
    set S := open_rays_subbasis R.
    claim HTx: topology_on R Tx.
    { exact R_standard_topology_is_topology. }
    claim HaR: a :e R.
    { exact (RleE_left a b Hab). }
    claim HbR: b :e R.
    { exact (RleE_right a b Hab). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    set den := add_SNo b (minus_SNo a).
    set two := add_SNo 1 1.
    set ab := add_SNo a b.
    claim Hablt: Rlt a b.
    { exact (Rle_neq_implies_Rlt a b Hab Hneq). }
    claim H0ltDenR: Rlt 0 den.
    { exact (Rlt_0_diff_of_lt a b Hablt). }
    claim HdenPos: 0 < den.
    { exact (RltE_lt 0 den H0ltDenR). }
    claim HdenR: den :e R.
    { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
    claim HdenS: SNo den.
    { exact (real_SNo den HdenR). }
    claim Hden_ne0: den <> 0.
    { assume Hden0: den = 0.
      claim H0lt0S: 0 < 0.
      { rewrite <- Hden0 at 2.
        exact HdenPos. }
      claim H0lt0R: Rlt 0 0.
      { exact (RltI 0 0 real_0 real_0 H0lt0S). }
      exact ((not_Rlt_refl 0 real_0) H0lt0R). }
    claim HtwoS: SNo two.
    { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
    claim H0lttwo: 0 < two.
    { claim Htwo2: two = 2.
      { rewrite (add_SNo_1_1_2). reflexivity. }
      rewrite Htwo2.
      exact SNoLt_0_2. }
    claim Htwo_ne0: two <> 0.
    { assume Htwo0: two = 0.
      claim Htwo2: two = 2.
      { rewrite (add_SNo_1_1_2). reflexivity. }
      claim H20: 2 = 0.
      { rewrite <- Htwo2 at 1. exact Htwo0. }
      exact (neq_2_0 H20). }
    claim HabR: ab :e R.
    { exact (real_add_SNo a HaR b HbR). }
    claim HabS: SNo ab.
    { exact (real_SNo ab HabR). }

    claim Hfun: function_on h R R.
    { let t. assume HtR: t :e R.
      prove apply_fun h t :e R.
      claim HtS: SNo t.
      { exact (real_SNo t HtR). }
      set num := add_SNo (mul_SNo two t) (minus_SNo ab).
      claim HnumR: num :e R.
      { claim HtwoR: two :e R.
        { exact (real_add_SNo 1 real_1 1 real_1). }
        claim HmulR: mul_SNo two t :e R.
        { exact (real_mul_SNo two HtwoR t HtR). }
        claim HabmR: minus_SNo ab :e R.
        { exact (real_minus_SNo ab HabR). }
        exact (real_add_SNo (mul_SNo two t) HmulR (minus_SNo ab) HabmR). }
      claim Hhdef: h = graph R (fun t0:set =>
        div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
               (add_SNo b (minus_SNo a))).
      { reflexivity. }
      claim Hht: apply_fun h t = div_SNo num den.
      { rewrite Hhdef.
        rewrite (apply_fun_graph R
          (fun t0:set =>
            div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                   (add_SNo b (minus_SNo a)))
          t HtR).
        reflexivity. }
      rewrite Hht.
      exact (real_div_SNo num HnumR den HdenR). }

    claim HS: subbasis_on R S.
    { exact (open_rays_subbasis_is_subbasis R). }
    claim Hgen: generated_topology_from_subbasis R S = Tx.
    { rewrite open_rays_subbasis_for_order_topology_R.
      rewrite standard_topology_is_order_topology.
      reflexivity. }
    rewrite <- Hgen at 2.

    apply (continuous_map_from_subbasis R Tx R S h HTx Hfun HS).
    let s. assume HsS: s :e S.
    prove preimage_of R h s :e Tx.
    claim HSdef: S =
      (({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
        :\/:
        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
       :\/:
       {R}).
    { reflexivity. }
    claim HsS': s :e
      (({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
        :\/:
        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
       :\/:
       {R}).
    { rewrite <- HSdef.
      exact HsS. }

    apply (binunionE'
      ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
       :\/:
       {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
      {R}
      s
      (preimage_of R h s :e Tx)).
    - assume HsAB: s :e ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
                         :\/:
                         {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}).
      apply (binunionE'
        {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
        {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}
        s
        (preimage_of R h s :e Tx)).
      + assume HsUpper: s :e {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}.
        claim Hex: exists c :e R, s = open_ray_upper R c.
        { exact (SepE2 (Power R) (fun I0:set => exists a0 :e R, I0 = open_ray_upper R a0) s HsUpper). }
        apply Hex.
        let c. assume Hccore.
        apply Hccore.
        assume HcR: c :e R.
        assume Hseq: s = open_ray_upper R c.
        rewrite Hseq.
        set k := div_SNo (add_SNo (mul_SNo den c) ab) two.
        claim HkR: k :e R.
        { claim HmulR: mul_SNo den c :e R.
          { exact (real_mul_SNo den HdenR c HcR). }
          claim HnumR: add_SNo (mul_SNo den c) ab :e R.
          { exact (real_add_SNo (mul_SNo den c) HmulR ab HabR). }
          exact (real_div_SNo (add_SNo (mul_SNo den c) ab) HnumR two (real_add_SNo 1 real_1 1 real_1)). }
        claim HkS: SNo k.
        { exact (real_SNo k HkR). }
        claim HpreEq: preimage_of R h (open_ray_upper R c) = open_ray_upper R k.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of R h (open_ray_upper R c).
            prove t :e open_ray_upper R k.
            claim HtR: t :e R.
            { exact (SepE1 R (fun x:set => apply_fun h x :e open_ray_upper R c) t Ht). }
            claim HhtRay: apply_fun h t :e open_ray_upper R c.
            { exact (SepE2 R (fun x:set => apply_fun h x :e open_ray_upper R c) t Ht). }
            claim Hrel: order_rel R c (apply_fun h t).
            { exact (SepE2 R (fun x0:set => order_rel R c x0) (apply_fun h t) HhtRay). }
            claim HltR: Rlt c (apply_fun h t).
            { exact (order_rel_R_implies_Rlt c (apply_fun h t) Hrel). }
            claim HtS: SNo t.
            { exact (real_SNo t HtR). }
            claim HcS: SNo c.
            { exact (real_SNo c HcR). }
            set numt := add_SNo (mul_SNo two t) (minus_SNo ab).
            claim HnumtR: numt :e R.
            { claim HtwoR: two :e R.
              { exact (real_add_SNo 1 real_1 1 real_1). }
              claim HmulR: mul_SNo two t :e R.
              { exact (real_mul_SNo two HtwoR t HtR). }
              claim HabmR: minus_SNo ab :e R.
              { exact (real_minus_SNo ab HabR). }
              exact (real_add_SNo (mul_SNo two t) HmulR (minus_SNo ab) HabmR). }
            claim HnumtS: SNo numt.
            { exact (real_SNo numt HnumtR). }
            claim Hhdef: h = graph R (fun t0:set =>
              div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                     (add_SNo b (minus_SNo a))).
            { reflexivity. }
            claim Hht: apply_fun h t = div_SNo numt den.
            { rewrite Hhdef.
              rewrite (apply_fun_graph R
                (fun t0:set =>
                  div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                         (add_SNo b (minus_SNo a)))
                t HtR).
              reflexivity. }
            claim HltS: c < apply_fun h t.
            { exact (RltE_lt c (apply_fun h t) HltR). }
            claim HdivLt: c < div_SNo numt den.
            { rewrite <- Hht.
              exact HltS. }
            claim HmulLt: mul_SNo c den < numt.
            { exact (div_SNo_pos_LtR' numt den c HnumtS HdenS HcS HdenPos HdivLt). }
            claim HmulLt': mul_SNo den c < numt.
            { rewrite (mul_SNo_com den c HdenS HcS) at 1.
              exact HmulLt. }
            claim HsumLt: add_SNo (mul_SNo den c) ab < add_SNo numt ab.
            { exact (add_SNo_Lt1 (mul_SNo den c) ab numt
                     (SNo_mul_SNo den c HdenS HcS) HabS HnumtS HmulLt'). }
            claim HrightEq: add_SNo numt ab = mul_SNo two t.
            { claim Hnumdef: numt = add_SNo (mul_SNo two t) (minus_SNo ab).
              { reflexivity. }
              rewrite Hnumdef.
              exact (add_SNo_minus_R2' (mul_SNo two t) ab (SNo_mul_SNo two t HtwoS HtS) HabS). }
            claim Hlt2t: add_SNo (mul_SNo den c) ab < mul_SNo two t.
            { rewrite <- HrightEq at 1.
              exact HsumLt. }
            claim Hlt_t2: add_SNo (mul_SNo den c) ab < mul_SNo t two.
            { rewrite <- (mul_SNo_com two t HtwoS HtS).
              exact Hlt2t. }
            claim Hklt: k < t.
            { exact (div_SNo_pos_LtL (add_SNo (mul_SNo den c) ab) two t
                     (SNo_add_SNo (mul_SNo den c) ab (SNo_mul_SNo den c HdenS HcS) HabS)
                     HtwoS HtS H0lttwo Hlt_t2). }
            claim HkltR: Rlt k t.
            { exact (RltI k t HkR HtR Hklt). }
            claim Hrelkt: order_rel R k t.
            { exact (Rlt_implies_order_rel_R k t HkltR). }
            exact (SepI R (fun x0:set => order_rel R k x0) t HtR Hrelkt).
          - let t. assume Ht: t :e open_ray_upper R k.
            prove t :e preimage_of R h (open_ray_upper R c).
            claim HtR: t :e R.
            { exact (SepE1 R (fun x0:set => order_rel R k x0) t Ht). }
            claim Hrelkt: order_rel R k t.
            { exact (SepE2 R (fun x0:set => order_rel R k x0) t Ht). }
            claim HltR: Rlt k t.
            { exact (order_rel_R_implies_Rlt k t Hrelkt). }
            claim HtS: SNo t.
            { exact (real_SNo t HtR). }
            claim HcS: SNo c.
            { exact (real_SNo c HcR). }
            claim HkS: SNo k.
            { exact (real_SNo k HkR). }
            claim HltS: k < t.
            { exact (RltE_lt k t HltR). }
            claim HmulLt: add_SNo (mul_SNo den c) ab < mul_SNo t two.
            { exact (div_SNo_pos_LtL' (add_SNo (mul_SNo den c) ab) two t
                     (SNo_add_SNo (mul_SNo den c) ab (SNo_mul_SNo den c HdenS HcS) HabS)
                     HtwoS HtS H0lttwo HltS). }
            claim HmulLt2: add_SNo (mul_SNo den c) ab < mul_SNo two t.
            { rewrite (mul_SNo_com two t HtwoS HtS).
              exact HmulLt. }
            set numt := add_SNo (mul_SNo two t) (minus_SNo ab).
            claim HnumtS: SNo numt.
            { exact (SNo_add_SNo (mul_SNo two t) (minus_SNo ab) (SNo_mul_SNo two t HtwoS HtS) (SNo_minus_SNo ab HabS)). }
            claim HrhsLt: mul_SNo den c < numt.
            { claim HrightEq: add_SNo numt ab = mul_SNo two t.
              { claim Hnumdef: numt = add_SNo (mul_SNo two t) (minus_SNo ab).
                { reflexivity. }
                rewrite Hnumdef.
                exact (add_SNo_minus_R2' (mul_SNo two t) ab (SNo_mul_SNo two t HtwoS HtS) HabS). }
	              claim HsumLt': add_SNo (mul_SNo den c) ab < add_SNo numt ab.
	              { rewrite HrightEq.
	                exact HmulLt2. }
              exact (add_SNo_Lt1_cancel (mul_SNo den c) ab numt
                       (SNo_mul_SNo den c HdenS HcS) HabS HnumtS HsumLt'). }
            claim HrhsLt': mul_SNo c den < numt.
            { rewrite (mul_SNo_com c den HcS HdenS).
              exact HrhsLt. }
            claim HdivLt: c < div_SNo numt den.
            { exact (div_SNo_pos_LtR numt den c HnumtS HdenS HcS HdenPos HrhsLt'). }
            claim Hhdef: h = graph R (fun t0:set =>
              div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                     (add_SNo b (minus_SNo a))).
            { reflexivity. }
            claim Hht: apply_fun h t = div_SNo numt den.
            { rewrite Hhdef.
              rewrite (apply_fun_graph R
                (fun t0:set =>
                  div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                         (add_SNo b (minus_SNo a)))
                t HtR).
              reflexivity. }
            claim HcLtHtS: c < apply_fun h t.
            { rewrite Hht.
              exact HdivLt. }
            claim HhtR: apply_fun h t :e R.
            { exact (Hfun t HtR). }
            claim HcLtHtR: Rlt c (apply_fun h t).
            { exact (RltI c (apply_fun h t) HcR HhtR HcLtHtS). }
            claim Hrelct: order_rel R c (apply_fun h t).
            { exact (Rlt_implies_order_rel_R c (apply_fun h t) HcLtHtR). }
            claim HhtRay: apply_fun h t :e open_ray_upper R c.
            { exact (SepI R (fun x0:set => order_rel R c x0) (apply_fun h t) HhtR Hrelct). }
            exact (SepI R (fun x0:set => apply_fun h x0 :e open_ray_upper R c) t HtR HhtRay). }
        rewrite HpreEq.
        rewrite <- standard_topology_is_order_topology.
        claim HsRay: open_ray_upper R k :e open_rays_subbasis R.
        { exact (open_ray_upper_in_open_rays_subbasis R k HkR). }
        exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R k) HsRay).
      + assume HsLower: s :e {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}.
        claim Hex: exists c :e R, s = open_ray_lower R c.
        { exact (SepE2 (Power R) (fun I0:set => exists b0 :e R, I0 = open_ray_lower R b0) s HsLower). }
        apply Hex.
        let c. assume Hccore.
        apply Hccore.
        assume HcR: c :e R.
        assume Hseq: s = open_ray_lower R c.
        rewrite Hseq.
        set k := div_SNo (add_SNo (mul_SNo den c) ab) two.
        claim HkR: k :e R.
        { claim HmulR: mul_SNo den c :e R.
          { exact (real_mul_SNo den HdenR c HcR). }
          claim HnumR: add_SNo (mul_SNo den c) ab :e R.
          { exact (real_add_SNo (mul_SNo den c) HmulR ab HabR). }
          exact (real_div_SNo (add_SNo (mul_SNo den c) ab) HnumR two (real_add_SNo 1 real_1 1 real_1)). }
        claim HkS: SNo k.
        { exact (real_SNo k HkR). }
        claim HpreEq: preimage_of R h (open_ray_lower R c) = open_ray_lower R k.
        { apply set_ext.
          - let t. assume Ht: t :e preimage_of R h (open_ray_lower R c).
            prove t :e open_ray_lower R k.
            claim HtR: t :e R.
            { exact (SepE1 R (fun x:set => apply_fun h x :e open_ray_lower R c) t Ht). }
            claim HhtRay: apply_fun h t :e open_ray_lower R c.
            { exact (SepE2 R (fun x:set => apply_fun h x :e open_ray_lower R c) t Ht). }
            claim Hrel: order_rel R (apply_fun h t) c.
            { exact (SepE2 R (fun x0:set => order_rel R x0 c) (apply_fun h t) HhtRay). }
            claim HltR: Rlt (apply_fun h t) c.
            { exact (order_rel_R_implies_Rlt (apply_fun h t) c Hrel). }
            claim HtS: SNo t.
            { exact (real_SNo t HtR). }
            claim HcS: SNo c.
            { exact (real_SNo c HcR). }
            set numt := add_SNo (mul_SNo two t) (minus_SNo ab).
            claim HnumtR: numt :e R.
            { claim HtwoR: two :e R.
              { exact (real_add_SNo 1 real_1 1 real_1). }
              claim HmulR: mul_SNo two t :e R.
              { exact (real_mul_SNo two HtwoR t HtR). }
              claim HabmR: minus_SNo ab :e R.
              { exact (real_minus_SNo ab HabR). }
              exact (real_add_SNo (mul_SNo two t) HmulR (minus_SNo ab) HabmR). }
            claim HnumtS: SNo numt.
            { exact (real_SNo numt HnumtR). }
            claim Hhdef: h = graph R (fun t0:set =>
              div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                     (add_SNo b (minus_SNo a))).
            { reflexivity. }
            claim Hht: apply_fun h t = div_SNo numt den.
            { rewrite Hhdef.
              rewrite (apply_fun_graph R
                (fun t0:set =>
                  div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                         (add_SNo b (minus_SNo a)))
                t HtR).
              reflexivity. }
            claim HltS: apply_fun h t < c.
            { exact (RltE_lt (apply_fun h t) c HltR). }
            claim HdivLt: div_SNo numt den < c.
            { rewrite <- Hht.
              exact HltS. }
            claim HrhsLt: numt < mul_SNo c den.
            { exact (div_SNo_pos_LtL' numt den c HnumtS HdenS HcS HdenPos HdivLt). }
            claim HrhsLt': numt < mul_SNo den c.
            { rewrite (mul_SNo_com den c HdenS HcS).
              exact HrhsLt. }
            claim HsumLt: add_SNo numt ab < add_SNo (mul_SNo den c) ab.
            { exact (add_SNo_Lt1 numt ab (mul_SNo den c) HnumtS HabS (SNo_mul_SNo den c HdenS HcS) HrhsLt'). }
            claim HleftEq: add_SNo numt ab = mul_SNo two t.
            { claim Hnumdef: numt = add_SNo (mul_SNo two t) (minus_SNo ab).
              { reflexivity. }
              rewrite Hnumdef.
              exact (add_SNo_minus_R2' (mul_SNo two t) ab (SNo_mul_SNo two t HtwoS HtS) HabS). }
            claim Hlt2t: mul_SNo two t < add_SNo (mul_SNo den c) ab.
            { rewrite <- HleftEq at 1.
              exact HsumLt. }
            claim Hlt_t2: mul_SNo t two < add_SNo (mul_SNo den c) ab.
            { rewrite (mul_SNo_com t two HtS HtwoS).
              exact Hlt2t. }
            claim Htlt: t < k.
            { exact (div_SNo_pos_LtR (add_SNo (mul_SNo den c) ab) two t
                     (SNo_add_SNo (mul_SNo den c) ab (SNo_mul_SNo den c HdenS HcS) HabS)
                     HtwoS HtS H0lttwo Hlt_t2). }
            claim HtltR: Rlt t k.
            { exact (RltI t k HtR HkR Htlt). }
            claim Hreltk: order_rel R t k.
            { exact (Rlt_implies_order_rel_R t k HtltR). }
            exact (SepI R (fun x0:set => order_rel R x0 k) t HtR Hreltk).
          - let t. assume Ht: t :e open_ray_lower R k.
            prove t :e preimage_of R h (open_ray_lower R c).
            claim HtR: t :e R.
            { exact (SepE1 R (fun x0:set => order_rel R x0 k) t Ht). }
            claim Hreltk: order_rel R t k.
            { exact (SepE2 R (fun x0:set => order_rel R x0 k) t Ht). }
            claim HltR: Rlt t k.
            { exact (order_rel_R_implies_Rlt t k Hreltk). }
            claim HtS: SNo t.
            { exact (real_SNo t HtR). }
            claim HcS: SNo c.
            { exact (real_SNo c HcR). }
            claim HkS: SNo k.
            { exact (real_SNo k HkR). }
            claim HltS: t < k.
            { exact (RltE_lt t k HltR). }
            claim HmulLt: mul_SNo t two < add_SNo (mul_SNo den c) ab.
            { exact (div_SNo_pos_LtR' (add_SNo (mul_SNo den c) ab) two t
                     (SNo_add_SNo (mul_SNo den c) ab (SNo_mul_SNo den c HdenS HcS) HabS)
                     HtwoS HtS H0lttwo HltS). }
            claim HmulLt2: mul_SNo two t < add_SNo (mul_SNo den c) ab.
            { rewrite (mul_SNo_com two t HtwoS HtS).
              exact HmulLt. }
            claim HmulLt2c: mul_SNo two t < add_SNo (mul_SNo c den) ab.
            { rewrite (mul_SNo_com c den HcS HdenS).
              exact HmulLt2. }
            set numt := add_SNo (mul_SNo two t) (minus_SNo ab).
            claim HnumtS: SNo numt.
            { exact (SNo_add_SNo (mul_SNo two t) (minus_SNo ab) (SNo_mul_SNo two t HtwoS HtS) (SNo_minus_SNo ab HabS)). }
            claim HrhsLt: numt < mul_SNo c den.
            { claim HleftEq: add_SNo numt ab = mul_SNo two t.
              { claim Hnumdef: numt = add_SNo (mul_SNo two t) (minus_SNo ab).
                { reflexivity. }
                rewrite Hnumdef.
                exact (add_SNo_minus_R2' (mul_SNo two t) ab (SNo_mul_SNo two t HtwoS HtS) HabS). }
              claim HsumLt': add_SNo numt ab < add_SNo (mul_SNo c den) ab.
              { rewrite HleftEq.
                exact HmulLt2c. }
              exact (add_SNo_Lt1_cancel numt ab (mul_SNo c den)
                       HnumtS HabS (SNo_mul_SNo c den HcS HdenS) HsumLt'). }
            claim HdivLt: div_SNo numt den < c.
            { exact (div_SNo_pos_LtL numt den c HnumtS HdenS HcS HdenPos HrhsLt). }
            claim Hhdef: h = graph R (fun t0:set =>
              div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                     (add_SNo b (minus_SNo a))).
            { reflexivity. }
            claim Hht: apply_fun h t = div_SNo numt den.
            { rewrite Hhdef.
              rewrite (apply_fun_graph R
                (fun t0:set =>
                  div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                         (add_SNo b (minus_SNo a)))
                t HtR).
              reflexivity. }
            claim HhtR: apply_fun h t :e R.
            { exact (Hfun t HtR). }
            claim HhtLtC: apply_fun h t < c.
            { rewrite Hht.
              exact HdivLt. }
            claim HhtLtCR: Rlt (apply_fun h t) c.
            { exact (RltI (apply_fun h t) c HhtR HcR HhtLtC). }
            claim Hrelct: order_rel R (apply_fun h t) c.
            { exact (Rlt_implies_order_rel_R (apply_fun h t) c HhtLtCR). }
            claim HhtRay: apply_fun h t :e open_ray_lower R c.
            { exact (SepI R (fun x0:set => order_rel R x0 c) (apply_fun h t) HhtR Hrelct). }
            exact (SepI R (fun x0:set => apply_fun h x0 :e open_ray_lower R c) t HtR HhtRay). }
        rewrite HpreEq.
        rewrite <- standard_topology_is_order_topology.
        claim HsRay: open_ray_lower R k :e open_rays_subbasis R.
        { exact (open_ray_lower_in_open_rays_subbasis R k HkR). }
        exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R k) HsRay).
      + exact HsAB.
    - assume HsR: s :e {R}.
      claim Hseq: s = R.
      { exact (SingE R s HsR). }
      rewrite Hseq.
      rewrite (preimage_of_whole R R h Hfun).
      exact (topology_has_X R Tx HTx).
    - exact HsS'. }
  claim HhDom: continuous_map Iab (subspace_topology R R_standard_topology Iab) R R_standard_topology h.
  { exact (continuous_on_subspace_rule R R_standard_topology R R_standard_topology h Iab
           HTstd HTstd HIabSub HhR). }
  claim HhImg: forall x:set, x :e Iab -> apply_fun h x :e Im1.
  { let x. assume HxI: x :e Iab.
    prove apply_fun h x :e Im1.
    claim HaR: a :e R.
    { exact (RleE_left a b Hab). }
    claim HbR: b :e R.
    { exact (RleE_right a b Hab). }
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim HxR: x :e R.
    { exact (HIabSub x HxI). }
    claim HxS: SNo x.
    { exact (real_SNo x HxR). }
    claim Hbounds: Rle a x /\ Rle x b.
    { exact (closed_interval_bounds a b x HaR HbR HxI). }
    claim Hax: Rle a x.
    { exact (andEL (Rle a x) (Rle x b) Hbounds). }
    claim Hxb: Rle x b.
    { exact (andER (Rle a x) (Rle x b) Hbounds). }
    set den := add_SNo b (minus_SNo a).
    set two := add_SNo 1 1.
    set ab := add_SNo a b.
    set num := add_SNo (mul_SNo two x) (minus_SNo ab).
    claim HdenR: den :e R.
    { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
    claim HdenS: SNo den.
    { exact (real_SNo den HdenR). }
    claim HtwoS: SNo two.
    { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
    claim Htwo_ne0: two <> 0.
    { assume Htwo0: two = 0.
      claim Htwo2: two = 2.
      { rewrite (add_SNo_1_1_2). reflexivity. }
      claim H20: 2 = 0.
      { rewrite <- Htwo2 at 1. exact Htwo0. }
      exact (neq_2_0 H20). }
    claim Hablt: Rlt a b.
    { exact (Rle_neq_implies_Rlt a b Hab Hneq). }
    claim H0ltDenR: Rlt 0 den.
    { exact (Rlt_0_diff_of_lt a b Hablt). }
    claim HdenPos: 0 < den.
    { exact (RltE_lt 0 den H0ltDenR). }
    claim Hden_ne0: den <> 0.
      { assume Hden0: den = 0.
        claim H0lt0S: 0 < 0.
      { rewrite <- Hden0 at 2.
        exact HdenPos. }
        claim H0lt0R: Rlt 0 0.
        { exact (RltI 0 0 real_0 real_0 H0lt0S). }
        exact ((not_Rlt_refl 0 real_0) H0lt0R). }
    claim HabR: ab :e R.
    { exact (real_add_SNo a HaR b HbR). }
    claim HabS: SNo ab.
    { exact (real_SNo ab HabR). }
    claim HnumR: num :e R.
    { claim HtwoR: two :e R.
      { exact (real_add_SNo 1 real_1 1 real_1). }
      claim HmulR: mul_SNo two x :e R.
      { exact (real_mul_SNo two HtwoR x HxR). }
      claim HabmR: minus_SNo ab :e R.
      { exact (real_minus_SNo ab HabR). }
      exact (real_add_SNo (mul_SNo two x) HmulR (minus_SNo ab) HabmR). }
    claim HnumS: SNo num.
    { exact (real_SNo num HnumR). }
    claim Hhdef: h = graph R (fun t0:set =>
      div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
             (add_SNo b (minus_SNo a))).
    { reflexivity. }
    claim Hhx: apply_fun h x = div_SNo num den.
    { rewrite Hhdef.
      rewrite (apply_fun_graph R
        (fun t0:set =>
          div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
                 (add_SNo b (minus_SNo a)))
        x HxR).
      reflexivity. }
    claim HhxR: apply_fun h x :e R.
    { rewrite Hhx.
      exact (real_div_SNo num HnumR den HdenR). }
    claim Hm1R: minus_SNo 1 :e R.
    { exact (real_minus_SNo 1 real_1). }
    claim Hlo: Rle (minus_SNo 1) (apply_fun h x).
    { apply (RleI (minus_SNo 1) (apply_fun h x) Hm1R HhxR).
      assume Hlt: Rlt (apply_fun h x) (minus_SNo 1).
      claim HltS: apply_fun h x < minus_SNo 1.
      { exact (RltE_lt (apply_fun h x) (minus_SNo 1) Hlt). }
      claim HdivLt: div_SNo num den < minus_SNo 1.
      { rewrite <- Hhx.
        exact HltS. }
      claim Hm1S: SNo (minus_SNo 1).
      { exact (SNo_minus_SNo 1 SNo_1). }
      claim HnumLt: num < mul_SNo (minus_SNo 1) den.
      { exact (div_SNo_pos_LtL' num den (minus_SNo 1) HnumS HdenS Hm1S HdenPos HdivLt). }
      claim Hm1denEq: mul_SNo (minus_SNo 1) den = add_SNo a (minus_SNo b).
      { claim Hm1den: mul_SNo (minus_SNo 1) den = minus_SNo den.
        { claim Hcomm: mul_SNo (minus_SNo 1) den = mul_SNo den (minus_SNo 1).
          { exact (mul_SNo_com (minus_SNo 1) den (SNo_minus_SNo 1 SNo_1) HdenS). }
          rewrite Hcomm.
          rewrite (mul_SNo_minus_distrR den 1 HdenS SNo_1).
          rewrite (mul_SNo_oneR den HdenS).
          reflexivity. }
        rewrite Hm1den.
        rewrite (minus_add_SNo_distr b (minus_SNo a) HbS (SNo_minus_SNo a HaS)).
        rewrite (minus_SNo_minus_SNo_real a HaR).
        claim Hcom: add_SNo (minus_SNo b) a = add_SNo a (minus_SNo b).
        { exact (add_SNo_com (minus_SNo b) a (SNo_minus_SNo b HbS) HaS). }
        rewrite Hcom.
        reflexivity. }
      claim HrhsS: SNo (add_SNo a (minus_SNo b)).
      { exact (SNo_add_SNo a (minus_SNo b) HaS (SNo_minus_SNo b HbS)). }
      claim HnumLt2: num < add_SNo a (minus_SNo b).
      { rewrite <- Hm1denEq at 1.
        exact HnumLt. }
      claim HsumLt: add_SNo num ab < add_SNo (add_SNo a (minus_SNo b)) ab.
      { exact (add_SNo_Lt1 num ab (add_SNo a (minus_SNo b)) HnumS HabS HrhsS HnumLt2). }
      claim HleftEq: add_SNo num ab = mul_SNo two x.
      { claim Hnumdef: num = add_SNo (mul_SNo two x) (minus_SNo ab).
        { reflexivity. }
        rewrite Hnumdef.
        exact (add_SNo_minus_R2' (mul_SNo two x) ab (SNo_mul_SNo two x HtwoS HxS) HabS). }
      claim HrightEq: add_SNo (add_SNo a (minus_SNo b)) ab = mul_SNo two a.
      { claim Habdef: ab = add_SNo a b.
        { reflexivity. }
        rewrite Habdef.
        claim Hmul2a: mul_SNo two a = add_SNo a a.
        { claim HtwoDef: two = add_SNo 1 1.
          { reflexivity. }
          rewrite HtwoDef.
          rewrite (mul_SNo_distrR 1 1 a SNo_1 SNo_1 HaS).
          rewrite (mul_SNo_oneL a HaS) at 1.
          rewrite (mul_SNo_oneL a HaS).
          reflexivity. }
        rewrite Hmul2a.
        rewrite (add_SNo_assoc (add_SNo a (minus_SNo b)) a b
                 (SNo_add_SNo a (minus_SNo b) HaS (SNo_minus_SNo b HbS)) HaS HbS).
        rewrite (add_SNo_com_3b_1_2 a (minus_SNo b) a HaS (SNo_minus_SNo b HbS) HaS) at 1.
        rewrite <- (add_SNo_assoc (add_SNo a a) (minus_SNo b) b
                 (SNo_add_SNo a a HaS HaS) (SNo_minus_SNo b HbS) HbS).
        rewrite (add_SNo_minus_SNo_linv b HbS).
        rewrite (add_SNo_0R (add_SNo a a) (SNo_add_SNo a a HaS HaS)).
        reflexivity. }
      claim H2xLt: mul_SNo two x < mul_SNo two a.
      { rewrite <- HleftEq at 1.
        rewrite <- HrightEq at 1.
        exact HsumLt. }
      claim H2xLt': mul_SNo two x < mul_SNo a two.
      { rewrite (mul_SNo_com a two HaS HtwoS) at 1.
        exact H2xLt. }
      claim H0lttwo: 0 < two.
      { claim Htwo2: two = 2.
        { rewrite (add_SNo_1_1_2). reflexivity. }
        rewrite Htwo2.
        exact SNoLt_0_2. }
      claim HxLtA: div_SNo (mul_SNo two x) two < a.
      { exact (div_SNo_pos_LtL (mul_SNo two x) two a
	               (SNo_mul_SNo two x HtwoS HxS) HtwoS HaS H0lttwo
	               H2xLt'). }
      claim HdivEq: div_SNo (mul_SNo two x) two = x.
      { claim HmulId: mul_SNo two x = mul_SNo two x.
        { reflexivity. }
        exact (mul_div_SNo_nonzero_eq (mul_SNo two x) two x
	              (SNo_mul_SNo two x HtwoS HxS) HtwoS HxS Htwo_ne0 HmulId). }
      claim HxLtAS: x < a.
      { rewrite <- HdivEq at 1.
        exact HxLtA. }
      claim HxLtAR: Rlt x a.
      { exact (RltI x a HxR HaR HxLtAS). }
      exact ((RleE_nlt a x Hax) HxLtAR).
    }
    claim Hhi: Rle (apply_fun h x) 1.
    { apply (RleI (apply_fun h x) 1 HhxR real_1).
      assume Hlt: Rlt 1 (apply_fun h x).
      claim HltS: 1 < apply_fun h x.
      { exact (RltE_lt 1 (apply_fun h x) Hlt). }
      claim HdivLt: 1 < div_SNo num den.
      { rewrite <- Hhx.
        exact HltS. }
      claim HnumGt: mul_SNo 1 den < num.
      { exact (div_SNo_pos_LtR' num den 1 HnumS HdenS SNo_1 HdenPos HdivLt). }
      claim HdenEq: mul_SNo 1 den = den.
      { exact (mul_SNo_oneL den HdenS). }
      claim HdenLtNum: den < num.
      { rewrite <- HdenEq at 1.
        exact HnumGt. }
      claim HsumLt: add_SNo den ab < add_SNo num ab.
      { exact (add_SNo_Lt1 den ab num HdenS HabS HnumS HdenLtNum). }
      claim HleftEq: add_SNo den ab = mul_SNo two b.
      { claim Hdendef: den = add_SNo b (minus_SNo a).
        { reflexivity. }
        claim Habdef: ab = add_SNo a b.
        { reflexivity. }
        rewrite Hdendef.
        rewrite Habdef.
        rewrite (add_SNo_assoc (add_SNo b (minus_SNo a)) a b
                 (SNo_add_SNo b (minus_SNo a) HbS (SNo_minus_SNo a HaS)) HaS HbS).
        rewrite (add_SNo_com_3b_1_2 b (minus_SNo a) a HbS (SNo_minus_SNo a HaS) HaS) at 1.
        rewrite (add_SNo_minus_R2 b a HbS HaS) at 1.
        claim Hmul2b: mul_SNo two b = add_SNo b b.
        { claim HtwoDef: two = add_SNo 1 1.
          { reflexivity. }
          rewrite HtwoDef.
          rewrite (mul_SNo_distrR 1 1 b SNo_1 SNo_1 HbS).
          rewrite (mul_SNo_oneL b HbS) at 1.
          rewrite (mul_SNo_oneL b HbS).
          reflexivity. }
        rewrite Hmul2b.
        reflexivity. }
      claim HrightEq: add_SNo num ab = mul_SNo two x.
      { claim Hnumdef: num = add_SNo (mul_SNo two x) (minus_SNo ab).
        { reflexivity. }
        rewrite Hnumdef.
        exact (add_SNo_minus_R2' (mul_SNo two x) ab (SNo_mul_SNo two x HtwoS HxS) HabS). }
      claim H2bLt2x: mul_SNo two b < mul_SNo two x.
      { rewrite <- HleftEq at 1.
        rewrite <- HrightEq at 1.
        exact HsumLt. }
      claim H2bLt2x': mul_SNo b two < mul_SNo two x.
      { rewrite (mul_SNo_com b two HbS HtwoS) at 1.
        exact H2bLt2x. }
      claim H0lttwo: 0 < two.
      { claim Htwo2: two = 2.
        { rewrite (add_SNo_1_1_2). reflexivity. }
        rewrite Htwo2.
        exact SNoLt_0_2. }
      claim HbLtX: b < div_SNo (mul_SNo two x) two.
      { exact (div_SNo_pos_LtR (mul_SNo two x) two b
	               (SNo_mul_SNo two x HtwoS HxS) HtwoS HbS H0lttwo
	               H2bLt2x'). }
      claim HdivEq: div_SNo (mul_SNo two x) two = x.
      { claim HmulId: mul_SNo two x = mul_SNo two x.
        { reflexivity. }
        exact (mul_div_SNo_nonzero_eq (mul_SNo two x) two x
	              (SNo_mul_SNo two x HtwoS HxS) HtwoS HxS Htwo_ne0 HmulId). }
      claim HbLtX': b < x.
      { rewrite <- HdivEq at 1.
        exact HbLtX. }
      claim HbLtXR: Rlt b x.
      { exact (RltI b x HbR HxR HbLtX'). }
      exact ((RleE_nlt x b Hxb) HbLtXR). }
    exact (closed_intervalI_of_Rle (minus_SNo 1) 1 (apply_fun h x) Hm1R real_1 HhxR Hlo Hhi). }
  claim HhCod: continuous_map Iab (subspace_topology R R_standard_topology Iab)
                 Im1 (subspace_topology R R_standard_topology Im1) h.
  { exact (continuous_map_range_restrict Iab (subspace_topology R R_standard_topology Iab)
           R R_standard_topology h Im1 HhDom HIm1Sub HhImg). }
  claim HTiabEq: closed_interval_topology a b = subspace_topology R R_standard_topology Iab.
  { reflexivity. }
  claim HTim1Eq: closed_interval_topology (minus_SNo 1) 1 = subspace_topology R R_standard_topology Im1.
  { reflexivity. }
  rewrite HTiabEq.
  rewrite HTim1Eq.
  exact HhCod.
- apply andI.
	  + set Iab := closed_interval a b.
	    set Im1 := closed_interval (minus_SNo 1) 1.
	    claim HIabSub: Iab c= R.
	    { exact (closed_interval_sub_R a b). }
	    claim HIm1Sub: Im1 c= R.
	    { exact (closed_interval_sub_R (minus_SNo 1) 1). }
		    claim HTstd: topology_on R R_standard_topology.
		    { exact R_standard_topology_is_topology. }
		    claim HhinvR: continuous_map R R_standard_topology R R_standard_topology hinv.
		    { set Tx := R_standard_topology.
		      set S := open_rays_subbasis R.
		      claim HTx: topology_on R Tx.
		      { exact R_standard_topology_is_topology. }
		      claim HaR: a :e R.
		      { exact (RleE_left a b Hab). }
		      claim HbR: b :e R.
		      { exact (RleE_right a b Hab). }
		      claim HaS: SNo a.
		      { exact (real_SNo a HaR). }
		      claim HbS: SNo b.
		      { exact (real_SNo b HbR). }
		      set den := add_SNo b (minus_SNo a).
		      set two := add_SNo 1 1.
		      set ab := add_SNo a b.
		      claim Hablt: Rlt a b.
		      { exact (Rle_neq_implies_Rlt a b Hab Hneq). }
		      claim H0ltDenR: Rlt 0 den.
		      { exact (Rlt_0_diff_of_lt a b Hablt). }
		      claim HdenPos: 0 < den.
		      { exact (RltE_lt 0 den H0ltDenR). }
		      claim HdenR: den :e R.
		      { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
		      claim HdenS: SNo den.
		      { exact (real_SNo den HdenR). }
		      claim HtwoR: two :e R.
		      { exact (real_add_SNo 1 real_1 1 real_1). }
		      claim HtwoS: SNo two.
		      { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
		      claim H0lttwo: 0 < two.
		      { claim Htwo2: two = 2.
		        { rewrite (add_SNo_1_1_2). reflexivity. }
		        rewrite Htwo2.
		        exact SNoLt_0_2. }
		      claim HabR: ab :e R.
		      { exact (real_add_SNo a HaR b HbR). }
		      claim HabS: SNo ab.
		      { exact (real_SNo ab HabR). }

		      claim Hfun: function_on hinv R R.
		      { let s. assume HsR: s :e R.
		        prove apply_fun hinv s :e R.
		        claim HsS: SNo s.
		        { exact (real_SNo s HsR). }
		        set num := add_SNo (mul_SNo den s) ab.
		        claim HnumR: num :e R.
		        { claim HmulR: mul_SNo den s :e R.
		          { exact (real_mul_SNo den HdenR s HsR). }
		          exact (real_add_SNo (mul_SNo den s) HmulR ab HabR). }
		        claim Hhinvdef: hinv = graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two).
		        { reflexivity. }
		        claim Hhs: apply_fun hinv s = div_SNo num two.
		        { rewrite Hhinvdef.
		          rewrite (apply_fun_graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two) s HsR).
		          reflexivity. }
		        rewrite Hhs.
		        exact (real_div_SNo num HnumR two HtwoR). }

		      claim HS: subbasis_on R S.
		      { exact (open_rays_subbasis_is_subbasis R). }
		      claim Hgen: generated_topology_from_subbasis R S = Tx.
		      { rewrite open_rays_subbasis_for_order_topology_R.
		        rewrite standard_topology_is_order_topology.
		        reflexivity. }
		      rewrite <- Hgen at 2.
		      apply (continuous_map_from_subbasis R Tx R S hinv HTx Hfun HS).
		      let s. assume HsS: s :e S.
		      prove preimage_of R hinv s :e Tx.
		      claim HSdef: S =
		        (({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
		          :\/:
		          {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
		         :\/:
		         {R}).
		      { reflexivity. }
		      claim HsS': s :e
		        (({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
		          :\/:
		          {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
		         :\/:
		         {R}).
		      { rewrite <- HSdef.
		        exact HsS. }

		      apply (binunionE'
		        ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
		         :\/:
		         {I :e Power R | exists b0 :e R, I = open_ray_lower R b0})
		        {R}
		        s
		        (preimage_of R hinv s :e Tx)).
		      - assume HsAB: s :e ({I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
		                           :\/:
		                           {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}).
		        apply (binunionE'
		          {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}
		          {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}
		          s
		          (preimage_of R hinv s :e Tx)).
		        + assume HsUpper: s :e {I :e Power R | exists a0 :e R, I = open_ray_upper R a0}.
		          claim Hex: exists c :e R, s = open_ray_upper R c.
		          { exact (SepE2 (Power R) (fun I0:set => exists a0 :e R, I0 = open_ray_upper R a0) s HsUpper). }
		          apply Hex.
		          let c. assume Hccore.
		          apply Hccore.
		          assume HcR: c :e R.
		          assume Hseq: s = open_ray_upper R c.
		          rewrite Hseq.
		          set k := div_SNo (add_SNo (mul_SNo two c) (minus_SNo ab)) den.
		          claim HkR: k :e R.
		          { claim HcS: SNo c.
		            { exact (real_SNo c HcR). }
		            claim HmulR: mul_SNo two c :e R.
		            { exact (real_mul_SNo two HtwoR c HcR). }
		            claim HabmR: minus_SNo ab :e R.
		            { exact (real_minus_SNo ab HabR). }
		            claim HnumR: add_SNo (mul_SNo two c) (minus_SNo ab) :e R.
		            { exact (real_add_SNo (mul_SNo two c) HmulR (minus_SNo ab) HabmR). }
		            exact (real_div_SNo (add_SNo (mul_SNo two c) (minus_SNo ab)) HnumR den HdenR). }
			          claim HpreEq: preimage_of R hinv (open_ray_upper R c) = open_ray_upper R k.
			          { set numk := add_SNo (mul_SNo two c) (minus_SNo ab).
			            claim Hkdef: k = div_SNo numk den.
			            { reflexivity. }
			            claim HnumkS: SNo numk.
			            { claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              exact (SNo_add_SNo (mul_SNo two c) (minus_SNo ab)
			                       (SNo_mul_SNo two c HtwoS HcS) (SNo_minus_SNo ab HabS)). }
			            apply set_ext.
			            - let t. assume Ht: t :e preimage_of R hinv (open_ray_upper R c).
			              prove t :e open_ray_upper R k.
			              claim HtR: t :e R.
			              { exact (SepE1 R (fun x:set => apply_fun hinv x :e open_ray_upper R c) t Ht). }
			              claim HhinvRay: apply_fun hinv t :e open_ray_upper R c.
			              { exact (SepE2 R (fun x:set => apply_fun hinv x :e open_ray_upper R c) t Ht). }
			              claim Hrel: order_rel R c (apply_fun hinv t).
			              { exact (SepE2 R (fun x0:set => order_rel R c x0) (apply_fun hinv t) HhinvRay). }
			              claim HltR: Rlt c (apply_fun hinv t).
			              { exact (order_rel_R_implies_Rlt c (apply_fun hinv t) Hrel). }
			              claim HtS: SNo t.
			              { exact (real_SNo t HtR). }
			              claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              set numt := add_SNo (mul_SNo den t) ab.
			              claim HnumtR: numt :e R.
			              { claim HmulR: mul_SNo den t :e R.
			                { exact (real_mul_SNo den HdenR t HtR). }
			                exact (real_add_SNo (mul_SNo den t) HmulR ab HabR). }
			              claim HnumtS: SNo numt.
			              { exact (real_SNo numt HnumtR). }
			              claim Hhinvdef2: hinv = graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two).
			              { reflexivity. }
			              claim Hht: apply_fun hinv t = div_SNo numt two.
			              { rewrite Hhinvdef2.
			                rewrite (apply_fun_graph R
			                  (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two)
			                  t HtR).
			                reflexivity. }
			              claim HltS: c < apply_fun hinv t.
			              { exact (RltE_lt c (apply_fun hinv t) HltR). }
			              claim HdivLt: c < div_SNo numt two.
			              { rewrite <- Hht.
			                exact HltS. }
			              claim HmulLt: mul_SNo c two < numt.
			              { exact (div_SNo_pos_LtR' numt two c HnumtS HtwoS HcS H0lttwo HdivLt). }
			              claim HmulLt2: mul_SNo two c < numt.
			              { rewrite <- (mul_SNo_com c two HcS HtwoS) at 1.
			                exact HmulLt. }
			              claim HsumLt: add_SNo (mul_SNo two c) (minus_SNo ab) < add_SNo numt (minus_SNo ab).
			              { exact (add_SNo_Lt1 (mul_SNo two c) (minus_SNo ab) numt
			                       (SNo_mul_SNo two c HtwoS HcS) (SNo_minus_SNo ab HabS) HnumtS HmulLt2). }
			              claim HrightEq: add_SNo numt (minus_SNo ab) = mul_SNo den t.
			              { claim Hnumdef: numt = add_SNo (mul_SNo den t) ab.
			                { reflexivity. }
			                rewrite Hnumdef.
			                exact (add_SNo_minus_R2 (mul_SNo den t) ab (SNo_mul_SNo den t HdenS HtS) HabS). }
				              claim HnumkLt: numk < mul_SNo den t.
				              { rewrite <- HrightEq.
				                exact HsumLt. }
			              claim HnumkLt2: numk < mul_SNo t den.
			              { rewrite (mul_SNo_com t den HtS HdenS).
			                exact HnumkLt. }
				              claim Hklt: k < t.
				              { rewrite Hkdef.
				                exact (div_SNo_pos_LtL numk den t HnumkS HdenS HtS HdenPos HnumkLt2). }
			              claim HkltR: Rlt k t.
			              { exact (RltI k t HkR HtR Hklt). }
			              claim Hrelkt: order_rel R k t.
			              { exact (Rlt_implies_order_rel_R k t HkltR). }
			              exact (SepI R (fun x0:set => order_rel R k x0) t HtR Hrelkt).
			            - let t. assume Ht: t :e open_ray_upper R k.
			              prove t :e preimage_of R hinv (open_ray_upper R c).
			              claim HtR: t :e R.
			              { exact (SepE1 R (fun x0:set => order_rel R k x0) t Ht). }
			              claim Hrelkt: order_rel R k t.
			              { exact (SepE2 R (fun x0:set => order_rel R k x0) t Ht). }
			              claim HltR: Rlt k t.
			              { exact (order_rel_R_implies_Rlt k t Hrelkt). }
			              claim HtS: SNo t.
			              { exact (real_SNo t HtR). }
			              claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              claim HltS: k < t.
			              { exact (RltE_lt k t HltR). }
			              claim HkS: SNo k.
			              { exact (real_SNo k HkR). }
				              claim HltS': div_SNo numk den < t.
				              { rewrite <- Hkdef at 1.
				                exact HltS. }
				              claim HnumkLt: numk < mul_SNo t den.
				              { exact (div_SNo_pos_LtL' numk den t HnumkS HdenS HtS HdenPos HltS'). }
				              claim HnumkLt2: numk < mul_SNo den t.
				              { rewrite <- (mul_SNo_com t den HtS HdenS).
				                exact HnumkLt. }
			              claim HsumLt: add_SNo numk ab < add_SNo (mul_SNo den t) ab.
			              { exact (add_SNo_Lt1 numk ab (mul_SNo den t)
			                       HnumkS HabS (SNo_mul_SNo den t HdenS HtS) HnumkLt2). }
			              claim HnumkEq: add_SNo numk ab = mul_SNo two c.
			              { claim Hnumkdef2: numk = add_SNo (mul_SNo two c) (minus_SNo ab).
			                { reflexivity. }
			                rewrite Hnumkdef2.
			                exact (add_SNo_minus_R2' (mul_SNo two c) ab (SNo_mul_SNo two c HtwoS HcS) HabS). }
			              claim HnumtLt: mul_SNo two c < add_SNo (mul_SNo den t) ab.
			              { rewrite <- HnumkEq at 1.
			                exact HsumLt. }
			              claim HnumtLt2: mul_SNo c two < add_SNo (mul_SNo den t) ab.
			              { rewrite (mul_SNo_com c two HcS HtwoS).
			                exact HnumtLt. }
			              set numt := add_SNo (mul_SNo den t) ab.
			              claim HnumtR: numt :e R.
			              { claim HmulR: mul_SNo den t :e R.
			                { exact (real_mul_SNo den HdenR t HtR). }
			                exact (real_add_SNo (mul_SNo den t) HmulR ab HabR). }
			              claim HnumtS: SNo numt.
			              { exact (real_SNo numt HnumtR). }
			              claim HdivLt: c < div_SNo numt two.
			              { exact (div_SNo_pos_LtR numt two c HnumtS HtwoS HcS H0lttwo HnumtLt2). }
			              claim Hhinvdef2: hinv = graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two).
			              { reflexivity. }
			              claim Hht: apply_fun hinv t = div_SNo numt two.
			              { rewrite Hhinvdef2.
			                rewrite (apply_fun_graph R
			                  (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two)
			                  t HtR).
			                reflexivity. }
			              claim HltS2: c < apply_fun hinv t.
			              { rewrite Hht.
			                exact HdivLt. }
			              claim HhinvRt: apply_fun hinv t :e R.
			              { exact (Hfun t HtR). }
			              claim HltR2: Rlt c (apply_fun hinv t).
			              { exact (RltI c (apply_fun hinv t) HcR HhinvRt HltS2). }
			              claim Hrelct: order_rel R c (apply_fun hinv t).
			              { exact (Rlt_implies_order_rel_R c (apply_fun hinv t) HltR2). }
			              claim Hray: apply_fun hinv t :e open_ray_upper R c.
			              { exact (SepI R (fun x0:set => order_rel R c x0) (apply_fun hinv t) HhinvRt Hrelct). }
			              exact (SepI R (fun x0:set => apply_fun hinv x0 :e open_ray_upper R c) t HtR Hray). }
			          rewrite HpreEq.
			          rewrite <- standard_topology_is_order_topology.
			          claim HsRay: open_ray_upper R k :e open_rays_subbasis R.
			          { exact (open_ray_upper_in_open_rays_subbasis R k HkR). }
			          exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R k) HsRay).
		        + assume HsLower: s :e {I :e Power R | exists b0 :e R, I = open_ray_lower R b0}.
		          claim Hex: exists c :e R, s = open_ray_lower R c.
		          { exact (SepE2 (Power R) (fun I0:set => exists b0 :e R, I0 = open_ray_lower R b0) s HsLower). }
		          apply Hex.
		          let c. assume Hccore.
		          apply Hccore.
		          assume HcR: c :e R.
		          assume Hseq: s = open_ray_lower R c.
		          rewrite Hseq.
		          set k := div_SNo (add_SNo (mul_SNo two c) (minus_SNo ab)) den.
		          claim HkR: k :e R.
		          { claim HcS: SNo c.
		            { exact (real_SNo c HcR). }
		            claim HmulR: mul_SNo two c :e R.
		            { exact (real_mul_SNo two HtwoR c HcR). }
		            claim HabmR: minus_SNo ab :e R.
		            { exact (real_minus_SNo ab HabR). }
		            claim HnumR: add_SNo (mul_SNo two c) (minus_SNo ab) :e R.
		            { exact (real_add_SNo (mul_SNo two c) HmulR (minus_SNo ab) HabmR). }
		            exact (real_div_SNo (add_SNo (mul_SNo two c) (minus_SNo ab)) HnumR den HdenR). }
			          claim HpreEq: preimage_of R hinv (open_ray_lower R c) = open_ray_lower R k.
			          { set numk := add_SNo (mul_SNo two c) (minus_SNo ab).
			            claim Hkdef: k = div_SNo numk den.
			            { reflexivity. }
			            claim HnumkS: SNo numk.
			            { claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              exact (SNo_add_SNo (mul_SNo two c) (minus_SNo ab)
			                       (SNo_mul_SNo two c HtwoS HcS) (SNo_minus_SNo ab HabS)). }
			            apply set_ext.
			            - let t. assume Ht: t :e preimage_of R hinv (open_ray_lower R c).
			              prove t :e open_ray_lower R k.
			              claim HtR: t :e R.
			              { exact (SepE1 R (fun x:set => apply_fun hinv x :e open_ray_lower R c) t Ht). }
			              claim HhinvRay: apply_fun hinv t :e open_ray_lower R c.
			              { exact (SepE2 R (fun x:set => apply_fun hinv x :e open_ray_lower R c) t Ht). }
			              claim Hrel: order_rel R (apply_fun hinv t) c.
			              { exact (SepE2 R (fun x0:set => order_rel R x0 c) (apply_fun hinv t) HhinvRay). }
			              claim HltR: Rlt (apply_fun hinv t) c.
			              { exact (order_rel_R_implies_Rlt (apply_fun hinv t) c Hrel). }
			              claim HtS: SNo t.
			              { exact (real_SNo t HtR). }
			              claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              set numt := add_SNo (mul_SNo den t) ab.
			              claim HnumtR: numt :e R.
			              { claim HmulR: mul_SNo den t :e R.
			                { exact (real_mul_SNo den HdenR t HtR). }
			                exact (real_add_SNo (mul_SNo den t) HmulR ab HabR). }
			              claim HnumtS: SNo numt.
			              { exact (real_SNo numt HnumtR). }
			              claim Hhinvdef2: hinv = graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two).
			              { reflexivity. }
			              claim Hht: apply_fun hinv t = div_SNo numt two.
			              { rewrite Hhinvdef2.
			                rewrite (apply_fun_graph R
			                  (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two)
			                  t HtR).
			                reflexivity. }
			              claim HltS: apply_fun hinv t < c.
			              { exact (RltE_lt (apply_fun hinv t) c HltR). }
			              claim HdivLt: div_SNo numt two < c.
			              { rewrite <- Hht.
			                exact HltS. }
			              claim HmulLt: numt < mul_SNo c two.
			              { exact (div_SNo_pos_LtL' numt two c HnumtS HtwoS HcS H0lttwo HdivLt). }
				              claim HmulLt2: numt < mul_SNo two c.
				              { rewrite <- (mul_SNo_com c two HcS HtwoS).
				                exact HmulLt. }
			              claim HsumLt: add_SNo numt (minus_SNo ab) < add_SNo (mul_SNo two c) (minus_SNo ab).
			              { exact (add_SNo_Lt1 numt (minus_SNo ab) (mul_SNo two c)
			                       HnumtS (SNo_minus_SNo ab HabS) (SNo_mul_SNo two c HtwoS HcS) HmulLt2). }
			              claim HleftEq: add_SNo numt (minus_SNo ab) = mul_SNo den t.
			              { claim Hnumdef: numt = add_SNo (mul_SNo den t) ab.
			                { reflexivity. }
			                rewrite Hnumdef.
			                exact (add_SNo_minus_R2 (mul_SNo den t) ab (SNo_mul_SNo den t HdenS HtS) HabS). }
			              claim HdtLt: mul_SNo den t < numk.
			              { rewrite <- HleftEq at 1.
			                exact HsumLt. }
			              claim HdtLt2: mul_SNo t den < numk.
			              { rewrite (mul_SNo_com t den HtS HdenS).
			                exact HdtLt. }
			              claim Htlt: t < div_SNo numk den.
			              { exact (div_SNo_pos_LtR numk den t HnumkS HdenS HtS HdenPos HdtLt2). }
				              claim Htlt2: t < k.
				              { rewrite Hkdef.
				                exact Htlt. }
			              claim HtltR: Rlt t k.
			              { exact (RltI t k HtR HkR Htlt2). }
			              claim Hreltk: order_rel R t k.
			              { exact (Rlt_implies_order_rel_R t k HtltR). }
			              exact (SepI R (fun x0:set => order_rel R x0 k) t HtR Hreltk).
			            - let t. assume Ht: t :e open_ray_lower R k.
			              prove t :e preimage_of R hinv (open_ray_lower R c).
			              claim HtR: t :e R.
			              { exact (SepE1 R (fun x0:set => order_rel R x0 k) t Ht). }
			              claim Hreltk: order_rel R t k.
			              { exact (SepE2 R (fun x0:set => order_rel R x0 k) t Ht). }
			              claim HltR: Rlt t k.
			              { exact (order_rel_R_implies_Rlt t k Hreltk). }
			              claim HtS: SNo t.
			              { exact (real_SNo t HtR). }
			              claim HcS: SNo c.
			              { exact (real_SNo c HcR). }
			              claim HltS: t < k.
			              { exact (RltE_lt t k HltR). }
			              claim HkS: SNo k.
			              { exact (real_SNo k HkR). }
				              claim HltS': t < div_SNo numk den.
				              { rewrite <- Hkdef.
				                exact HltS. }
			              claim HdtLt: mul_SNo t den < numk.
			              { exact (div_SNo_pos_LtR' numk den t HnumkS HdenS HtS HdenPos HltS'). }
			              claim HdtLt2: mul_SNo den t < numk.
			              { rewrite <- (mul_SNo_com t den HtS HdenS) at 1.
			                exact HdtLt. }
			              claim HsumLt: add_SNo (mul_SNo den t) ab < add_SNo numk ab.
			              { exact (add_SNo_Lt1 (mul_SNo den t) ab numk
			                       (SNo_mul_SNo den t HdenS HtS) HabS HnumkS HdtLt2). }
			              claim HnumkEq: add_SNo numk ab = mul_SNo two c.
			              { claim Hnumkdef2: numk = add_SNo (mul_SNo two c) (minus_SNo ab).
			                { reflexivity. }
			                rewrite Hnumkdef2.
			                exact (add_SNo_minus_R2' (mul_SNo two c) ab (SNo_mul_SNo two c HtwoS HcS) HabS). }
				              claim HnumtLt: add_SNo (mul_SNo den t) ab < mul_SNo two c.
				              { rewrite <- HnumkEq.
				                exact HsumLt. }
			              claim HnumtLt2: add_SNo (mul_SNo den t) ab < mul_SNo c two.
			              { rewrite (mul_SNo_com c two HcS HtwoS).
			                exact HnumtLt. }
			              set numt := add_SNo (mul_SNo den t) ab.
			              claim HnumtR: numt :e R.
			              { claim HmulR: mul_SNo den t :e R.
			                { exact (real_mul_SNo den HdenR t HtR). }
			                exact (real_add_SNo (mul_SNo den t) HmulR ab HabR). }
			              claim HnumtS: SNo numt.
			              { exact (real_SNo numt HnumtR). }
			              claim HdivLt: div_SNo numt two < c.
			              { exact (div_SNo_pos_LtL numt two c HnumtS HtwoS HcS H0lttwo HnumtLt2). }
			              claim Hhinvdef2: hinv = graph R (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two).
			              { reflexivity. }
			              claim Hht: apply_fun hinv t = div_SNo numt two.
			              { rewrite Hhinvdef2.
			                rewrite (apply_fun_graph R
			                  (fun s0:set => div_SNo (add_SNo (mul_SNo den s0) ab) two)
			                  t HtR).
			                reflexivity. }
			              claim HltS2: apply_fun hinv t < c.
			              { rewrite Hht.
			                exact HdivLt. }
			              claim HhinvRt: apply_fun hinv t :e R.
			              { exact (Hfun t HtR). }
			              claim HltR2: Rlt (apply_fun hinv t) c.
			              { exact (RltI (apply_fun hinv t) c HhinvRt HcR HltS2). }
			              claim Hrelct: order_rel R (apply_fun hinv t) c.
			              { exact (Rlt_implies_order_rel_R (apply_fun hinv t) c HltR2). }
			              claim Hray: apply_fun hinv t :e open_ray_lower R c.
			              { exact (SepI R (fun x0:set => order_rel R x0 c) (apply_fun hinv t) HhinvRt Hrelct). }
			              exact (SepI R (fun x0:set => apply_fun hinv x0 :e open_ray_lower R c) t HtR Hray). }
			          rewrite HpreEq.
			          rewrite <- standard_topology_is_order_topology.
				          claim HsRay: open_ray_lower R k :e open_rays_subbasis R.
				          { exact (open_ray_lower_in_open_rays_subbasis R k HkR). }
				          exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R k) HsRay).
			        + exact HsAB.
		      - assume HsR: s :e {R}.
		        claim Hseq: s = R.
		        { exact (SingE R s HsR). }
		        rewrite Hseq.
		        rewrite (preimage_of_whole R R hinv Hfun).
		        exact (topology_has_X R Tx HTx).
		      - exact HsS'. }
		    claim HhinvDom: continuous_map Im1 (subspace_topology R R_standard_topology Im1) R R_standard_topology hinv.
		    { exact (continuous_on_subspace_rule R R_standard_topology R R_standard_topology hinv Im1
		             HTstd HTstd HIm1Sub HhinvR). }
		    claim HhinvImg: forall s:set, s :e Im1 -> apply_fun hinv s :e Iab.
		    { let s. assume HsI: s :e Im1.
		      prove apply_fun hinv s :e Iab.
		      claim HaR: a :e R.
		      { exact (RleE_left a b Hab). }
		      claim HbR: b :e R.
		      { exact (RleE_right a b Hab). }
		      claim HaS: SNo a.
		      { exact (real_SNo a HaR). }
		      claim HbS: SNo b.
		      { exact (real_SNo b HbR). }
		      claim Hm1R: minus_SNo 1 :e R.
		      { exact (real_minus_SNo 1 real_1). }
		      claim HsR: s :e R.
		      { exact (HIm1Sub s HsI). }
		      claim HsS: SNo s.
		      { exact (real_SNo s HsR). }
		      claim Hsbounds: Rle (minus_SNo 1) s /\ Rle s 1.
		      { exact (closed_interval_bounds (minus_SNo 1) 1 s Hm1R real_1 HsI). }
		      claim Hm1leS: Rle (minus_SNo 1) s.
		      { exact (andEL (Rle (minus_SNo 1) s) (Rle s 1) Hsbounds). }
		      claim Hsle1: Rle s 1.
		      { exact (andER (Rle (minus_SNo 1) s) (Rle s 1) Hsbounds). }

		      set den := add_SNo b (minus_SNo a).
		      set two := add_SNo 1 1.
		      set ab := add_SNo a b.
		      set num := add_SNo (mul_SNo den s) ab.
		      claim Hablt: Rlt a b.
		      { exact (Rle_neq_implies_Rlt a b Hab Hneq). }
		      claim H0ltDenR: Rlt 0 den.
		      { exact (Rlt_0_diff_of_lt a b Hablt). }
		      claim HdenPos: 0 < den.
		      { exact (RltE_lt 0 den H0ltDenR). }
		      claim HdenR: den :e R.
		      { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
		      claim HdenS: SNo den.
		      { exact (real_SNo den HdenR). }
		      claim Hden_ne0: den <> 0.
		      { assume Hden0: den = 0.
		        claim H0lt0S: 0 < 0.
		        { rewrite <- Hden0 at 2.
		          exact (RltE_lt 0 den H0ltDenR). }
		        claim H0lt0R: Rlt 0 0.
		        { exact (RltI 0 0 real_0 real_0 H0lt0S). }
		        exact ((not_Rlt_refl 0 real_0) H0lt0R). }
		      claim HtwoS: SNo two.
		      { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
		      claim H0lttwo: 0 < two.
		      { claim Htwo2: two = 2.
		        { rewrite (add_SNo_1_1_2). reflexivity. }
		        rewrite Htwo2.
		        exact SNoLt_0_2. }
		      claim Htwo_ne0: two <> 0.
		      { assume Htwo0: two = 0.
		        claim Htwo2: two = 2.
		        { rewrite (add_SNo_1_1_2). reflexivity. }
		        claim H20: 2 = 0.
		        { rewrite <- Htwo2 at 1. exact Htwo0. }
		        exact (neq_2_0 H20). }
		      claim HabR: ab :e R.
		      { exact (real_add_SNo a HaR b HbR). }
		      claim HabS: SNo ab.
		      { exact (real_SNo ab HabR). }
		      claim HnumR: num :e R.
		      { claim HmulR: mul_SNo den s :e R.
		        { exact (real_mul_SNo den HdenR s HsR). }
		        exact (real_add_SNo (mul_SNo den s) HmulR ab HabR). }
		      claim HnumS: SNo num.
		      { exact (real_SNo num HnumR). }
		      claim Hhinvdef: hinv = graph R (fun s0:set =>
		        div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
		               (add_SNo 1 1)).
		      { reflexivity. }
		      claim Hhinvs: apply_fun hinv s = div_SNo num two.
		      { rewrite Hhinvdef.
		        rewrite (apply_fun_graph R
		          (fun s0:set =>
		            div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
		                   (add_SNo 1 1))
		          s HsR).
		        reflexivity. }
		      claim HhinvsR: apply_fun hinv s :e R.
		      { rewrite Hhinvs.
		        exact (real_div_SNo num HnumR two (real_add_SNo 1 real_1 1 real_1)). }

		      claim Hlo: Rle a (apply_fun hinv s).
		      { apply (RleI a (apply_fun hinv s) HaR HhinvsR).
		        assume Hlt: Rlt (apply_fun hinv s) a.
		        claim HltS: apply_fun hinv s < a.
		        { exact (RltE_lt (apply_fun hinv s) a Hlt). }
		        claim HdivLt: div_SNo num two < a.
		        { rewrite <- Hhinvs.
		          exact HltS. }
		        claim HnumLt: num < mul_SNo a two.
		        { exact (div_SNo_pos_LtL' num two a HnumS HtwoS HaS H0lttwo HdivLt). }
		        claim Hm1denEq: mul_SNo (minus_SNo 1) den = add_SNo a (minus_SNo b).
		        { claim Hm1S: SNo (minus_SNo 1).
		          { exact (SNo_minus_SNo 1 SNo_1). }
		          claim Hm1den: mul_SNo (minus_SNo 1) den = minus_SNo den.
		          { claim Hcomm: mul_SNo (minus_SNo 1) den = mul_SNo den (minus_SNo 1).
		            { exact (mul_SNo_com (minus_SNo 1) den Hm1S HdenS). }
		            rewrite Hcomm.
		            rewrite (mul_SNo_minus_distrR den 1 HdenS SNo_1).
		            rewrite (mul_SNo_oneR den HdenS).
		            reflexivity. }
		          rewrite Hm1den.
		          rewrite (minus_add_SNo_distr b (minus_SNo a) HbS (SNo_minus_SNo a HaS)).
		          rewrite (minus_SNo_minus_SNo_real a HaR).
		          claim Hcom: add_SNo (minus_SNo b) a = add_SNo a (minus_SNo b).
		          { exact (add_SNo_com (minus_SNo b) a (SNo_minus_SNo b HbS) HaS). }
		          rewrite Hcom.
		          reflexivity. }
		        claim H2aEq: mul_SNo a two = add_SNo (add_SNo a (minus_SNo b)) ab.
		        { claim Habdef: ab = add_SNo a b.
		          { reflexivity. }
		          rewrite Habdef.
		          rewrite (mul_SNo_com a two HaS HtwoS).
		          claim Hmul2a: mul_SNo two a = add_SNo a a.
		          { claim HtwoDef: two = add_SNo 1 1.
		            { reflexivity. }
		            rewrite HtwoDef.
		            rewrite (mul_SNo_distrR 1 1 a SNo_1 SNo_1 HaS).
		            rewrite (mul_SNo_oneL a HaS) at 1.
		            rewrite (mul_SNo_oneL a HaS).
		            reflexivity. }
		          rewrite Hmul2a.
		          rewrite (add_SNo_assoc (add_SNo a (minus_SNo b)) a b
		                   (SNo_add_SNo a (minus_SNo b) HaS (SNo_minus_SNo b HbS)) HaS HbS).
		          rewrite (add_SNo_com_3b_1_2 a (minus_SNo b) a HaS (SNo_minus_SNo b HbS) HaS) at 1.
		          rewrite <- (add_SNo_assoc (add_SNo a a) (minus_SNo b) b
		                   (SNo_add_SNo a a HaS HaS) (SNo_minus_SNo b HbS) HbS).
		          rewrite (add_SNo_minus_SNo_linv b HbS).
		          rewrite (add_SNo_0R (add_SNo a a) (SNo_add_SNo a a HaS HaS)).
		          reflexivity. }
			        claim HrhsS: SNo (add_SNo a (minus_SNo b)).
			        { exact (SNo_add_SNo a (minus_SNo b) HaS (SNo_minus_SNo b HbS)). }
			        claim HmulLt: num < add_SNo (add_SNo a (minus_SNo b)) ab.
			        { rewrite <- H2aEq at 1.
			          exact HnumLt. }
			        claim Hnumdef: num = add_SNo (mul_SNo den s) ab.
			        { reflexivity. }
			        claim HmulLt': add_SNo (mul_SNo den s) ab < add_SNo (add_SNo a (minus_SNo b)) ab.
			        { rewrite Hnumdef at 1.
			          exact HmulLt. }
			        claim Hcancel: mul_SNo den s < add_SNo a (minus_SNo b).
			        { exact (add_SNo_Lt1_cancel (mul_SNo den s) ab (add_SNo a (minus_SNo b))
			                 (SNo_mul_SNo den s HdenS HsS) HabS HrhsS HmulLt'). }
		        claim Hm1S: SNo (minus_SNo 1).
		        { exact (SNo_minus_SNo 1 SNo_1). }
			        claim HsdLt: mul_SNo den s < mul_SNo (minus_SNo 1) den.
			        { rewrite Hm1denEq at 1.
			          exact Hcancel. }
		        claim HsLt: div_SNo (mul_SNo den s) den < minus_SNo 1.
		        { exact (div_SNo_pos_LtL (mul_SNo den s) den (minus_SNo 1)
		                 (SNo_mul_SNo den s HdenS HsS) HdenS Hm1S HdenPos HsdLt). }
		        claim HdivEq: div_SNo (mul_SNo den s) den = s.
		        { claim HmulId: mul_SNo den s = mul_SNo den s.
		          { reflexivity. }
		          exact (mul_div_SNo_nonzero_eq (mul_SNo den s) den s
		                (SNo_mul_SNo den s HdenS HsS) HdenS HsS Hden_ne0 HmulId). }
		        claim HsLtS: s < minus_SNo 1.
		        { rewrite <- HdivEq at 1.
		          exact HsLt. }
		        claim HsLtR: Rlt s (minus_SNo 1).
		        { exact (RltI s (minus_SNo 1) HsR Hm1R HsLtS). }
		        exact ((RleE_nlt (minus_SNo 1) s Hm1leS) HsLtR). }

		      claim Hhi: Rle (apply_fun hinv s) b.
		      { apply (RleI (apply_fun hinv s) b HhinvsR HbR).
		        assume Hlt: Rlt b (apply_fun hinv s).
		        claim HltS: b < apply_fun hinv s.
		        { exact (RltE_lt b (apply_fun hinv s) Hlt). }
		        claim HdivLt: b < div_SNo num two.
		        { rewrite <- Hhinvs.
		          exact HltS. }
		        claim HnumGt: mul_SNo b two < num.
		        { exact (div_SNo_pos_LtR' num two b HnumS HtwoS HbS H0lttwo HdivLt). }
		        claim Hm1S: SNo (minus_SNo 1).
		        { exact (SNo_minus_SNo 1 SNo_1). }
		        claim Hb2Eq: mul_SNo b two = add_SNo den ab.
		        { claim Habdef: ab = add_SNo a b.
		          { reflexivity. }
		          claim Hdendef: den = add_SNo b (minus_SNo a).
		          { reflexivity. }
		          rewrite Habdef.
		          rewrite Hdendef.
		          claim Hmul2b: mul_SNo two b = add_SNo b b.
		          { claim HtwoDef: two = add_SNo 1 1.
		            { reflexivity. }
		            rewrite HtwoDef.
		            rewrite (mul_SNo_distrR 1 1 b SNo_1 SNo_1 HbS).
		            rewrite (mul_SNo_oneL b HbS) at 1.
		            rewrite (mul_SNo_oneL b HbS).
		            reflexivity. }
		          rewrite (mul_SNo_com b two HbS HtwoS).
		          rewrite Hmul2b.
		          rewrite (add_SNo_assoc (add_SNo b (minus_SNo a)) a b
		                   (SNo_add_SNo b (minus_SNo a) HbS (SNo_minus_SNo a HaS)) HaS HbS).
		          rewrite (add_SNo_com_3b_1_2 b (minus_SNo a) a HbS (SNo_minus_SNo a HaS) HaS) at 1.
		          rewrite (add_SNo_minus_R2 b a HbS HaS) at 1.
		          reflexivity. }
		        claim Hnumdef: num = add_SNo (mul_SNo den s) ab.
		        { reflexivity. }
			        claim HrhsLt: add_SNo den ab < add_SNo (mul_SNo den s) ab.
			        { rewrite <- Hb2Eq at 1.
			          rewrite <- Hnumdef at 1.
			          exact HnumGt. }
		        claim HdenLt: den < mul_SNo den s.
		        { exact (add_SNo_Lt1_cancel den ab (mul_SNo den s)
		                 HdenS HabS (SNo_mul_SNo den s HdenS HsS) HrhsLt). }
			        claim HoneDenLt: mul_SNo 1 den < mul_SNo den s.
			        { rewrite (mul_SNo_oneL den HdenS) at 1.
			          exact HdenLt. }
		        claim HsGt: 1 < div_SNo (mul_SNo den s) den.
		        { exact (div_SNo_pos_LtR (mul_SNo den s) den 1
		                 (SNo_mul_SNo den s HdenS HsS) HdenS SNo_1 HdenPos HoneDenLt). }
		        claim HdivEq: div_SNo (mul_SNo den s) den = s.
		        { claim HmulId: mul_SNo den s = mul_SNo den s.
		          { reflexivity. }
		          exact (mul_div_SNo_nonzero_eq (mul_SNo den s) den s
		                (SNo_mul_SNo den s HdenS HsS) HdenS HsS Hden_ne0 HmulId). }
			        claim H1LtS: 1 < s.
			        { rewrite <- HdivEq at 1.
			          exact HsGt. }
		        claim H1LtSR: Rlt 1 s.
		        { exact (RltI 1 s real_1 HsR H1LtS). }
		        exact ((RleE_nlt s 1 Hsle1) H1LtSR). }

		      exact (closed_intervalI_of_Rle a b (apply_fun hinv s) HaR HbR HhinvsR Hlo Hhi). }
		    claim HhinvCod: continuous_map Im1 (subspace_topology R R_standard_topology Im1)
		                      Iab (subspace_topology R R_standard_topology Iab) hinv.
		    { exact (continuous_map_range_restrict Im1 (subspace_topology R R_standard_topology Im1)
		             R R_standard_topology hinv Iab HhinvDom HIabSub HhinvImg). }
	    claim HTiabEq: closed_interval_topology a b = subspace_topology R R_standard_topology Iab.
	    { reflexivity. }
	    claim HTim1Eq: closed_interval_topology (minus_SNo 1) 1 = subspace_topology R R_standard_topology Im1.
	    { reflexivity. }
	    rewrite HTim1Eq.
	    rewrite HTiabEq.
	    exact HhinvCod.
	  + apply andI.
	    * let t. assume Ht: t :e closed_interval a b.
	      prove apply_fun hinv (apply_fun h t) = t.
	      claim HaR: a :e R.
	      { exact (RleE_left a b Hab). }
	      claim HbR: b :e R.
	      { exact (RleE_right a b Hab). }
	      claim HaS: SNo a.
	      { exact (real_SNo a HaR). }
	      claim HbS: SNo b.
	      { exact (real_SNo b HbR). }
	      claim HsubI: closed_interval a b c= R.
	      { exact (closed_interval_sub_R a b). }
	      claim HtR: t :e R.
	      { exact (HsubI t Ht). }
	      claim HtS: SNo t.
	      { exact (real_SNo t HtR). }
	      set den := add_SNo b (minus_SNo a).
	      set two := add_SNo 1 1.
	      set ab := add_SNo a b.
	      set num := add_SNo (mul_SNo two t) (minus_SNo ab).
	      claim HabR: ab :e R.
	      { exact (real_add_SNo a HaR b HbR). }
	      claim HabS: SNo ab.
	      { exact (real_SNo ab HabR). }
	      claim HdenR: den :e R.
	      { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
	      claim HdenS: SNo den.
	      { exact (real_SNo den HdenR). }
	      claim HtwoS: SNo two.
	      { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
	      claim Htwo_ne0: two <> 0.
	      { assume Htwo0: two = 0.
	        claim Htwo2: two = 2.
	        { rewrite (add_SNo_1_1_2). reflexivity. }
	        claim H20: 2 = 0.
	        { rewrite <- Htwo2 at 1. exact Htwo0. }
	        exact (neq_2_0 H20). }
	      claim Hden_ne0: den <> 0.
	      { assume Hden0: den = 0.
	        claim Hmab: minus_SNo a :e R.
	        { exact (real_minus_SNo a HaR). }
	        claim HmabS: SNo (minus_SNo a).
	        { exact (real_SNo (minus_SNo a) Hmab). }
	        claim Hlhs0: add_SNo b (minus_SNo a) = add_SNo a (minus_SNo a).
	        { rewrite Hden0 at 1.
	          rewrite (add_SNo_minus_SNo_rinv a HaS).
	          reflexivity. }
	        claim Hba: b = a.
	        { exact (add_SNo_cancel_R b (minus_SNo a) a HbS HmabS HaS Hlhs0). }
	        claim Habeq: a = b.
	        { rewrite <- Hba. reflexivity. }
	        exact (Hneq Habeq). }
	      claim HnumR: num :e R.
	      { claim HtwoR: two :e R.
	        { exact (real_add_SNo 1 real_1 1 real_1). }
	        claim HmulR: mul_SNo two t :e R.
	        { exact (real_mul_SNo two HtwoR t HtR). }
	        claim HabmR: minus_SNo ab :e R.
	        { exact (real_minus_SNo ab HabR). }
	        exact (real_add_SNo (mul_SNo two t) HmulR (minus_SNo ab) HabmR). }
	      claim HnumS: SNo num.
	      { exact (real_SNo num HnumR). }
	      claim Hhdef: h = graph R (fun t0:set =>
	        div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
	               (add_SNo b (minus_SNo a))).
	      { reflexivity. }
	      claim Hhinvdef: hinv = graph R (fun s0:set =>
	        div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
	               (add_SNo 1 1)).
	      { reflexivity. }
	      claim Hht: apply_fun h t = div_SNo num den.
	      { rewrite Hhdef.
	        rewrite (apply_fun_graph R
	          (fun t0:set =>
	            div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
	                   (add_SNo b (minus_SNo a)))
	          t HtR).
	        reflexivity. }
	      claim HhtR: apply_fun h t :e R.
	      { rewrite Hht.
	        exact (real_div_SNo num HnumR den HdenR). }
	      rewrite Hhinvdef.
	      rewrite (apply_fun_graph R
	        (fun s0:set =>
	          div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
	                 (add_SNo 1 1))
	        (apply_fun h t) HhtR).
	      rewrite Hht.
		      claim Hmul_cancel: mul_SNo den (div_SNo num den) = num.
		      { exact (mul_div_SNo_invR num den HnumS HdenS Hden_ne0). }
		      rewrite Hmul_cancel.
		      claim Hnumdef: num = add_SNo (mul_SNo two t) (minus_SNo ab).
		      { reflexivity. }
		      rewrite Hnumdef.
		      rewrite (add_SNo_minus_R2' (mul_SNo two t) ab
		                                 (SNo_mul_SNo two t HtwoS HtS) HabS).
		      claim Hdiv_eq: div_SNo (mul_SNo two t) two = t.
		      { claim HmulId: mul_SNo two t = mul_SNo two t.
		        { reflexivity. }
		        exact (mul_div_SNo_nonzero_eq (mul_SNo two t) two t
		                                      (SNo_mul_SNo two t HtwoS HtS) HtwoS HtS
		                                      Htwo_ne0 HmulId). }
	      exact Hdiv_eq.
	    * let s. assume Hs: s :e closed_interval (minus_SNo 1) 1.
	      prove apply_fun h (apply_fun hinv s) = s.
	      claim HaR: a :e R.
	      { exact (RleE_left a b Hab). }
	      claim HbR: b :e R.
	      { exact (RleE_right a b Hab). }
	      claim HaS: SNo a.
	      { exact (real_SNo a HaR). }
	      claim HbS: SNo b.
	      { exact (real_SNo b HbR). }
	      claim HsR: s :e R.
	      { exact (closed_interval_sub_R (minus_SNo 1) 1 s Hs). }
	      claim HsS: SNo s.
	      { exact (real_SNo s HsR). }
	      set den := add_SNo b (minus_SNo a).
	      set two := add_SNo 1 1.
	      set ab := add_SNo a b.
	      claim HabR: ab :e R.
	      { exact (real_add_SNo a HaR b HbR). }
	      claim HabS: SNo ab.
	      { exact (real_SNo ab HabR). }
	      claim HdenR: den :e R.
	      { exact (real_add_SNo b HbR (minus_SNo a) (real_minus_SNo a HaR)). }
	      claim HdenS: SNo den.
	      { exact (real_SNo den HdenR). }
	      claim HtwoS: SNo two.
	      { exact (SNo_add_SNo 1 1 SNo_1 SNo_1). }
	      claim Htwo_ne0: two <> 0.
	      { assume Htwo0: two = 0.
	        claim Htwo2: two = 2.
	        { rewrite (add_SNo_1_1_2). reflexivity. }
	        claim H20: 2 = 0.
	        { rewrite <- Htwo2 at 1. exact Htwo0. }
	        exact (neq_2_0 H20). }
	      claim Hden_ne0: den <> 0.
	      { assume Hden0: den = 0.
	        claim Hmab: minus_SNo a :e R.
	        { exact (real_minus_SNo a HaR). }
	        claim HmabS: SNo (minus_SNo a).
	        { exact (real_SNo (minus_SNo a) Hmab). }
	        claim Hlhs0: add_SNo b (minus_SNo a) = add_SNo a (minus_SNo a).
	        { rewrite Hden0 at 1.
	          rewrite (add_SNo_minus_SNo_rinv a HaS).
	          reflexivity. }
	        claim Hba: b = a.
	        { exact (add_SNo_cancel_R b (minus_SNo a) a HbS HmabS HaS Hlhs0). }
	        claim Habeq: a = b.
	        { rewrite <- Hba. reflexivity. }
	        exact (Hneq Habeq). }
	      claim Hhdef: h = graph R (fun t0:set =>
	        div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
	               (add_SNo b (minus_SNo a))).
	      { reflexivity. }
	      claim Hhinvdef: hinv = graph R (fun s0:set =>
	        div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
	               (add_SNo 1 1)).
	      { reflexivity. }
	      claim Hhinvs: apply_fun hinv s =
	        div_SNo (add_SNo (mul_SNo den s) ab) two.
	      { rewrite Hhinvdef.
	        rewrite (apply_fun_graph R
	          (fun s0:set =>
	            div_SNo (add_SNo (mul_SNo (add_SNo b (minus_SNo a)) s0) (add_SNo a b))
	                   (add_SNo 1 1))
	          s HsR).
	        reflexivity. }
	      claim HhinvsR: apply_fun hinv s :e R.
	      { rewrite Hhinvs.
	        claim HmulR: mul_SNo den s :e R.
	        { exact (real_mul_SNo den HdenR s HsR). }
	        claim HnumR: add_SNo (mul_SNo den s) ab :e R.
	        { exact (real_add_SNo (mul_SNo den s) HmulR ab HabR). }
	        exact (real_div_SNo (add_SNo (mul_SNo den s) ab) HnumR two (real_add_SNo 1 real_1 1 real_1)). }
	      rewrite Hhdef.
	      rewrite (apply_fun_graph R
	        (fun t0:set =>
	          div_SNo (add_SNo (mul_SNo (add_SNo 1 1) t0) (minus_SNo (add_SNo a b)))
	                 (add_SNo b (minus_SNo a)))
	        (apply_fun hinv s) HhinvsR).
	      rewrite Hhinvs.
	      claim Hmul2_cancel: mul_SNo two (div_SNo (add_SNo (mul_SNo den s) ab) two) =
	                         add_SNo (mul_SNo den s) ab.
	      { exact (mul_div_SNo_invR (add_SNo (mul_SNo den s) ab) two
	                                (SNo_add_SNo (mul_SNo den s) ab (SNo_mul_SNo den s HdenS HsS) HabS)
	                                HtwoS Htwo_ne0). }
	      rewrite Hmul2_cancel.
	      rewrite (add_SNo_minus_R2 (mul_SNo den s) ab
	                                (SNo_mul_SNo den s HdenS HsS) HabS).
	      claim Hdiv_eq: div_SNo (mul_SNo den s) den = s.
	      { claim HmulId: mul_SNo den s = mul_SNo den s.
	        { reflexivity. }
	        exact (mul_div_SNo_nonzero_eq (mul_SNo den s) den s
	                                      (SNo_mul_SNo den s HdenS HsS) HdenS HsS
	                                      Hden_ne0 HmulId). }
	      rewrite Hdiv_eq.
	      reflexivity.
Qed.

Theorem Tietze_extension_interval : forall X Tx A a b f:set,
  Rle a b ->
  normal_space X Tx -> closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A) (closed_interval a b) (closed_interval_topology a b) f ->
  exists g:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
let X Tx A a b f.
assume Hab: Rle a b.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A) (closed_interval a b) (closed_interval_topology a b) f.
prove exists g:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
(** TeX §35 Step 1–2: the proof uses Urysohn lemma iteratively to build a uniformly convergent series of continuous functions on X approximating f on A. **)
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A HA). }
(** reduction: handle the degenerate interval case a=b without using the main construction **)
claim HaR: a :e R.
{ exact (RleE_left a b Hab). }
claim HaIab: a :e closed_interval a b.
{ exact (left_endpoint_in_closed_interval a b Hab). }
claim HCI_top: topology_on (closed_interval a b) (closed_interval_topology a b).
{ exact (closed_interval_topology_on a b). }
claim Hfunf: function_on f A (closed_interval a b).
{ exact (continuous_map_function_on A (subspace_topology X Tx A) (closed_interval a b) (closed_interval_topology a b) f Hf). }
claim HA_cases: A = Empty \/ ~(A = Empty).
{ exact (xm (A = Empty)). }
apply (HA_cases (exists g:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x))).
- assume HAemp: A = Empty.
  witness (const_fun X a).
  apply andI.
  + exact (const_fun_continuous X Tx (closed_interval a b) (closed_interval_topology a b) a HTx HCI_top HaIab).
  + let x. assume HxA: x :e A.
    prove apply_fun (const_fun X a) x = apply_fun f x.
    claim HxE: x :e Empty.
    { rewrite <- HAemp. exact HxA. }
    apply FalseE.
    exact ((EmptyE x) HxE).
- assume HAne: ~(A = Empty).
claim Hab_cases: a = b \/ ~(a = b).
{ exact (xm (a = b)). }
apply (Hab_cases (exists g:set, continuous_map X Tx (closed_interval a b) (closed_interval_topology a b) g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x))).
- assume Heq: a = b.
  witness (const_fun X a).
  apply andI.
  + exact (const_fun_continuous X Tx (closed_interval a b) (closed_interval_topology a b) a HTx HCI_top HaIab).
  + let x. assume HxA: x :e A.
    prove apply_fun (const_fun X a) x = apply_fun f x.
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    rewrite (const_fun_apply X a x HxX).
    set y := apply_fun f x.
    prove a = y.
    claim HyIab: y :e closed_interval a b.
    { exact (Hfunf x HxA). }
    claim HeqCI: closed_interval a b = closed_interval a a.
    { rewrite <- Heq. reflexivity. }
    claim HyIaa: y :e closed_interval a a.
    { rewrite <- HeqCI. exact HyIab. }
    claim Hyeq: y = a.
    { exact (closed_interval_degenerate a y HaR HyIaa). }
    rewrite Hyeq.
    reflexivity.
- assume Hneq: ~(a = b).
  (** TeX §35 Step I–II skeleton: reduce [a,b] to [-1,1], then build a uniformly convergent series via repeated Urysohn applications. **)
  set I := closed_interval a b.
  set Ti := closed_interval_topology a b.
  set I01 := closed_interval (minus_SNo 1) 1.
  set T01 := closed_interval_topology (minus_SNo 1) 1.
  claim Hh: exists h:set, exists hinv:set,
    continuous_map I Ti I01 T01 h /\
    (continuous_map I01 T01 I Ti hinv /\
     ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
      (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s))).
  { exact (closed_interval_affine_equiv_minus1_1 a b Hab Hneq). }
  apply Hh.
  let h.
  assume Hhex: exists hinv:set,
    continuous_map I Ti I01 T01 h /\
    (continuous_map I01 T01 I Ti hinv /\
     ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
      (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s))).
  apply Hhex.
  let hinv.
  assume Hhcore:
    continuous_map I Ti I01 T01 h /\
    (continuous_map I01 T01 I Ti hinv /\
     ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
      (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s))).
  claim Hhcont: continuous_map I Ti I01 T01 h.
  { exact (andEL (continuous_map I Ti I01 T01 h)
                 (continuous_map I01 T01 I Ti hinv /\
                  ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
                   (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s)))
                 Hhcore). }
  claim Hrest:
    continuous_map I01 T01 I Ti hinv /\
    ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
     (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s)).
  { exact (andER (continuous_map I Ti I01 T01 h)
                 (continuous_map I01 T01 I Ti hinv /\
                  ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
                   (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s)))
                 Hhcore). }
  claim Hhinvcont: continuous_map I01 T01 I Ti hinv.
  { exact (andEL (continuous_map I01 T01 I Ti hinv)
                 ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
                  (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s))
                 Hrest). }
  claim Hhrest2:
    (forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
    (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s).
  { exact (andER (continuous_map I01 T01 I Ti hinv)
                 ((forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t) /\
                  (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s))
                 Hrest). }
  claim Hhinv_after_h: forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t.
  { exact (andEL (forall t:set, t :e I -> apply_fun hinv (apply_fun h t) = t)
                 (forall s:set, s :e I01 -> apply_fun h (apply_fun hinv s) = s)
                 Hhrest2). }

  set f01 := compose_fun A f h.
  claim Hf01cont: continuous_map A (subspace_topology X Tx A) I01 T01 f01.
  { exact (composition_continuous A (subspace_topology X Tx A) I Ti I01 T01 f h Hf Hhcont). }
  claim Hext01:
    exists g01:set,
      continuous_map X Tx I01 T01 g01 /\
      (forall x:set, x :e A -> apply_fun g01 x = apply_fun f01 x).
  { exact (Tietze_extension_minus1_1 X Tx A f01 Hnorm HA Hf01cont). }
  apply Hext01.
  let g01.
  assume Hg01:
    continuous_map X Tx I01 T01 g01 /\
    (forall x:set, x :e A -> apply_fun g01 x = apply_fun f01 x).
  claim Hg01cont: continuous_map X Tx I01 T01 g01.
  { exact (andEL (continuous_map X Tx I01 T01 g01)
                 (forall x:set, x :e A -> apply_fun g01 x = apply_fun f01 x)
                 Hg01). }
  claim Hg01eq: forall x:set, x :e A -> apply_fun g01 x = apply_fun f01 x.
  { exact (andER (continuous_map X Tx I01 T01 g01)
                 (forall x:set, x :e A -> apply_fun g01 x = apply_fun f01 x)
                 Hg01). }

  set g := compose_fun X g01 hinv.
  witness g.
  apply andI.
  + exact (composition_continuous X Tx I01 T01 I Ti g01 hinv Hg01cont Hhinvcont).
  + let x. assume HxA: x :e A.
    prove apply_fun g x = apply_fun f x.
    claim HAsubX: A c= X.
    { exact (closed_in_subset X Tx A HA). }
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    claim Hcompg: apply_fun g x = apply_fun hinv (apply_fun g01 x).
    { rewrite (compose_fun_apply X g01 hinv x HxX). reflexivity. }
    rewrite Hcompg.
    rewrite (Hg01eq x HxA).
    claim Hcompf01: apply_fun f01 x = apply_fun h (apply_fun f x).
    { rewrite (compose_fun_apply A f h x HxA). reflexivity. }
    rewrite Hcompf01.
    claim Hfunf: function_on f A I.
    { exact (continuous_map_function_on A (subspace_topology X Tx A) I Ti f Hf). }
    claim HfxI: apply_fun f x :e I.
    { exact (Hfunf x HxA). }
    rewrite (Hhinv_after_h (apply_fun f x) HfxI).
    reflexivity.
Qed.

(** helper: inclusion of a subspace is continuous (local lemma for later sections) **)
(** LATEX VERSION: If A ⊂ X then the inclusion map A → X is continuous for the subspace topology. **)
Theorem subspace_inclusion_continuous : forall X Tx A:set,
  topology_on X Tx -> A c= X ->
  continuous_map A (subspace_topology X Tx A) X Tx {(y,y) | y :e A}.
let X Tx A.
assume HTx: topology_on X Tx.
assume HA: A c= X.
set j := {(y,y) | y :e A}.
prove continuous_map A (subspace_topology X Tx A) X Tx j.
prove topology_on A (subspace_topology X Tx A) /\ topology_on X Tx /\ function_on j A X /\
      forall V:set, V :e Tx -> preimage_of A j V :e subspace_topology X Tx A.
apply andI.
- apply andI.
  + apply andI.
    * exact (subspace_topology_is_topology X Tx A HTx HA).
    * exact HTx.
  + let a. assume HaA: a :e A.
    prove apply_fun j a :e X.
    claim Haj: apply_fun j a = a.
    { exact (identity_function_apply A a HaA). }
    rewrite Haj.
    exact (HA a HaA).
- let V. assume HV: V :e Tx.
  prove preimage_of A j V :e subspace_topology X Tx A.
  claim Heq: preimage_of A j V = V :/\: A.
  { apply set_ext.
    - let a. assume Ha: a :e preimage_of A j V.
      prove a :e V :/\: A.
      claim HaA: a :e A.
      { exact (SepE1 A (fun u:set => apply_fun j u :e V) a Ha). }
      claim Haj: apply_fun j a = a.
      { exact (identity_function_apply A a HaA). }
      claim HaV: a :e V.
      { rewrite <- Haj.
        exact (SepE2 A (fun u:set => apply_fun j u :e V) a Ha). }
      exact (binintersectI V A a HaV HaA).
    - let a. assume Ha: a :e V :/\: A.
      prove a :e preimage_of A j V.
      claim HaV: a :e V.
      { exact (binintersectE1 V A a Ha). }
      claim HaA: a :e A.
      { exact (binintersectE2 V A a Ha). }
      prove a :e {u :e A | apply_fun j u :e V}.
      apply (SepI A (fun u:set => apply_fun j u :e V) a HaA).
      claim Haj: apply_fun j a = a.
      { exact (identity_function_apply A a HaA). }
      rewrite Haj.
      exact HaV. }
  rewrite Heq.
  exact (subspace_topologyI X Tx A V HV).
Qed.

(** helper for §35: interval-valued Tietze gives a real-valued extension when the range is already bounded **)
(** LATEX VERSION: If f maps into [a,b], then extending f to [a,b] and composing with the inclusion yields a real-valued extension. **)
Theorem Tietze_extension_real_bounded_interval : forall X Tx A a b f:set,
  Rle a b ->
  normal_space X Tx -> closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A) R R_standard_topology f ->
  (forall x:set, x :e A -> apply_fun f x :e closed_interval a b) ->
  exists g:set, continuous_map X Tx R R_standard_topology g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
let X Tx A a b f.
assume Hab: Rle a b.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A) R R_standard_topology f.
assume HfI: forall x:set, x :e A -> apply_fun f x :e closed_interval a b.
prove exists g:set, continuous_map X Tx R R_standard_topology g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
set I := closed_interval a b.
set Ti := closed_interval_topology a b.
claim HIsubR: I c= R.
{ exact (closed_interval_sub_R a b). }
claim Hf_to_I: continuous_map A (subspace_topology X Tx A) I Ti f.
{ claim HfRng: continuous_map A (subspace_topology X Tx A) I (subspace_topology R R_standard_topology I) f.
  { exact (continuous_map_range_restrict A (subspace_topology X Tx A) R R_standard_topology f I Hf HIsubR HfI). }
  exact HfRng. }
claim HexgI: exists gI:set,
  continuous_map X Tx I Ti gI /\
  (forall x:set, x :e A -> apply_fun gI x = apply_fun f x).
{ exact (Tietze_extension_interval X Tx A a b f Hab Hnorm HA Hf_to_I). }
apply HexgI.
let gI. assume HgI.
claim HgIcont: continuous_map X Tx I Ti gI.
{ exact (andEL (continuous_map X Tx I Ti gI)
               (forall x:set, x :e A -> apply_fun gI x = apply_fun f x)
               HgI). }
claim HgIeq: forall x:set, x :e A -> apply_fun gI x = apply_fun f x.
{ exact (andER (continuous_map X Tx I Ti gI)
               (forall x:set, x :e A -> apply_fun gI x = apply_fun f x)
               HgI). }
set inc := {(y,y) | y :e I}.
claim Hinc: continuous_map I Ti R R_standard_topology inc.
{ claim HRtop: topology_on R R_standard_topology.
  { exact (R_standard_topology_is_topology_local). }
  exact (subspace_inclusion_continuous R R_standard_topology I HRtop HIsubR). }
set g := compose_fun X gI inc.
witness g.
apply andI.
- exact (composition_continuous X Tx I Ti R R_standard_topology gI inc HgIcont Hinc).
- let x. assume HxA: x :e A.
  prove apply_fun g x = apply_fun f x.
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HA). }
  claim HxX: x :e X.
  { exact (HAsubX x HxA). }
  claim Hcomp: apply_fun g x = apply_fun inc (apply_fun gI x).
  { rewrite (compose_fun_apply X gI inc x HxX). reflexivity. }
  rewrite Hcomp.
  claim HgIxI: apply_fun gI x :e I.
  { exact (continuous_map_function_on X Tx I Ti gI HgIcont x HxX). }
  claim HincId: apply_fun inc (apply_fun gI x) = apply_fun gI x.
  { exact (identity_function_apply I (apply_fun gI x) HgIxI). }
  rewrite HincId.
  exact (HgIeq x HxA).
Qed.

(** helper for §35: open interval valued extension (needed for composing with the inverse bounded transform) **)
(** LATEX VERSION: Extend a continuous f:A->(-1,1) to a continuous g:X->(-1,1) in a normal space. **)
Theorem Tietze_extension_open_interval : forall X Tx A f:set,
  normal_space X Tx -> closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A)
    (open_interval (minus_SNo 1) 1)
    (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
    f ->
  exists g:set,
    continuous_map X Tx
      (open_interval (minus_SNo 1) 1)
      (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
      g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A)
  (open_interval (minus_SNo 1) 1)
  (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
  f.
prove exists g:set,
  continuous_map X Tx
    (open_interval (minus_SNo 1) 1)
    (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
    g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
set U := open_interval (minus_SNo 1) 1.
set Tu := subspace_topology R R_standard_topology U.
set I := closed_interval (minus_SNo 1) 1.
set Ti := closed_interval_topology (minus_SNo 1) 1.
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HIsubR: I c= R.
{ exact (closed_interval_sub_R (minus_SNo 1) 1). }
claim HUsubR: U c= R.
{ let y. assume Hy: y :e U.
  exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) y Hy). }
claim HUsubI: U c= I.
{ let y. assume Hy: y :e U.
  prove y :e I.
  claim HyR: y :e R.
  { exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) y Hy). }
  claim Hyconj: Rlt (minus_SNo 1) y /\ Rlt y 1.
  { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) y Hy). }
  claim Hm1y: Rlt (minus_SNo 1) y.
  { exact (andEL (Rlt (minus_SNo 1) y) (Rlt y 1) Hyconj). }
  claim Hy1: Rlt y 1.
  { exact (andER (Rlt (minus_SNo 1) y) (Rlt y 1) Hyconj). }
  claim HIdef: I = {x0 :e R | ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)}.
  { reflexivity. }
  rewrite HIdef.
  apply (SepI R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) y HyR).
  apply andI.
  - exact (not_Rlt_sym (minus_SNo 1) y Hm1y).
  - exact (not_Rlt_sym y 1 Hy1). }

(** build fI : A -> I by composing with the inclusion U -> I **)
set j := {(y,y) | y :e U}.
claim HjR: continuous_map U Tu R R_standard_topology j.
{ exact (subspace_inclusion_continuous R R_standard_topology U
         R_standard_topology_is_topology_local HUsubR). }
claim HjI: continuous_map U Tu I Ti j.
{ claim Hrng: forall y:set, y :e U -> apply_fun j y :e I.
  { let y. assume HyU: y :e U.
    rewrite (identity_function_apply U y HyU).
    exact (HUsubI y HyU). }
  exact (continuous_map_range_restrict U Tu R R_standard_topology j I
         HjR HIsubR Hrng). }
set fI := compose_fun A f j.
claim HfI: continuous_map A (subspace_topology X Tx A) I Ti fI.
{ exact (composition_continuous A (subspace_topology X Tx A)
         U Tu I Ti f j Hf HjI). }

(** extend fI to gI : X -> I using Tietze_extension_interval **)
claim Hm1R: minus_SNo 1 :e R.
{ exact (real_minus_SNo 1 real_1). }
claim Hm10: Rlt (minus_SNo 1) 0.
{ exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0). }
claim Hm11: Rlt (minus_SNo 1) 1.
{ exact (Rlt_tra (minus_SNo 1) 0 1 Hm10 Rlt_0_1). }
claim Hab: Rle (minus_SNo 1) 1.
{ exact (Rlt_implies_Rle (minus_SNo 1) 1 Hm11). }
claim HexgI: exists gI:set,
  continuous_map X Tx I Ti gI /\
  (forall x:set, x :e A -> apply_fun gI x = apply_fun fI x).
{ exact (Tietze_extension_interval X Tx A (minus_SNo 1) 1 fI Hab Hnorm HA HfI). }
apply HexgI.
let gI. assume HgI.
claim HgIcont: continuous_map X Tx I Ti gI.
{ exact (andEL (continuous_map X Tx I Ti gI)
               (forall x:set, x :e A -> apply_fun gI x = apply_fun fI x)
               HgI). }
claim HgIeq: forall x:set, x :e A -> apply_fun gI x = apply_fun fI x.
{ exact (andER (continuous_map X Tx I Ti gI)
               (forall x:set, x :e A -> apply_fun gI x = apply_fun fI x)
               HgI). }

(** view gI as a real-valued map gR : X -> R by inclusion I -> R **)
set incI := {(y,y) | y :e I}.
claim HincI: continuous_map I Ti R R_standard_topology incI.
{ exact (subspace_inclusion_continuous R R_standard_topology I
         R_standard_topology_is_topology_local HIsubR). }
set gR := compose_fun X gI incI.
claim HgRcont: continuous_map X Tx R R_standard_topology gR.
{ exact (composition_continuous X Tx I Ti R R_standard_topology gI incI HgIcont HincI). }
claim HgR_eq_on_A: forall x:set, x :e A -> apply_fun gR x = apply_fun f x.
{ let x. assume HxA: x :e A.
  prove apply_fun gR x = apply_fun f x.
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HA). }
  claim HxX: x :e X.
  { exact (HAsubX x HxA). }
  claim Hcomp: apply_fun gR x = apply_fun incI (apply_fun gI x).
  { rewrite (compose_fun_apply X gI incI x HxX). reflexivity. }
  rewrite Hcomp.
  rewrite (HgIeq x HxA).
  claim HfunfI: function_on fI A I.
  { exact (continuous_map_function_on A (subspace_topology X Tx A) I Ti fI HfI). }
  claim HfIxI: apply_fun fI x :e I.
  { exact (HfunfI x HxA). }
  rewrite (identity_function_apply I (apply_fun fI x) HfIxI).
  claim HcompfI: apply_fun fI x = apply_fun j (apply_fun f x).
  { rewrite (compose_fun_apply A f j x HxA). reflexivity. }
  rewrite HcompfI.
  claim Hfunf: function_on f A U.
  { exact (continuous_map_function_on A (subspace_topology X Tx A) U Tu f Hf). }
  claim HfxU: apply_fun f x :e U.
  { exact (Hfunf x HxA). }
  rewrite (identity_function_apply U (apply_fun f x) HfxU).
  reflexivity. }

(** define the boundary set D where gR hits the endpoints {-1,1} **)
set Dm1 := preimage_of X gR {minus_SNo 1}.
set D1 := preimage_of X gR {1}.
set D := Dm1 :\/: D1.
claim Hm1closed: closed_in R R_standard_topology {minus_SNo 1}.
{ exact (Hausdorff_singletons_closed R R_standard_topology (minus_SNo 1)
         R_standard_topology_Hausdorff Hm1R). }
claim H1closed: closed_in R R_standard_topology {1}.
{ exact (Hausdorff_singletons_closed R R_standard_topology 1
         R_standard_topology_Hausdorff real_1). }
claim HDm1cl: closed_in X Tx Dm1.
{ exact (continuous_map_preimage_closed X Tx R R_standard_topology gR {minus_SNo 1}
         HgRcont Hm1closed). }
claim HD1cl: closed_in X Tx D1.
{ exact (continuous_map_preimage_closed X Tx R R_standard_topology gR {1}
         HgRcont H1closed). }
claim HDcl: closed_in X Tx D.
{ exact (union_of_closed_is_closed X Tx Dm1 D1 HTx HDm1cl HD1cl). }

(** D and A are disjoint **)
claim Hdisj: D :/\: A = Empty.
{ apply set_ext.
  - let x. assume Hx: x :e D :/\: A.
    prove x :e Empty.
    claim HxD: x :e D.
    { exact (binintersectE1 D A x Hx). }
    claim HxA: x :e A.
    { exact (binintersectE2 D A x Hx). }
    apply (binunionE' Dm1 D1 x (x :e Empty)).
    + assume HxDm1: x :e Dm1.
      claim HgRx: apply_fun gR x :e {minus_SNo 1}.
      { exact (SepE2 X (fun u:set => apply_fun gR u :e {minus_SNo 1}) x HxDm1). }
      claim HgReq: apply_fun gR x = minus_SNo 1.
      { exact (SingE (minus_SNo 1) (apply_fun gR x) HgRx). }
      claim Hgxfx: apply_fun gR x = apply_fun f x.
      { exact (HgR_eq_on_A x HxA). }
      claim HfxU: apply_fun f x :e U.
      { claim Hfunf: function_on f A U.
        { exact (continuous_map_function_on A (subspace_topology X Tx A) U Tu f Hf). }
        exact (Hfunf x HxA). }
      claim Hfxconj: Rlt (minus_SNo 1) (apply_fun f x) /\ Rlt (apply_fun f x) 1.
      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) (apply_fun f x) HfxU). }
      claim Hlt: Rlt (minus_SNo 1) (apply_fun f x).
      { exact (andEL (Rlt (minus_SNo 1) (apply_fun f x)) (Rlt (apply_fun f x) 1) Hfxconj). }
      claim HfxEq: apply_fun f x = minus_SNo 1.
      { rewrite <- Hgxfx at 1.
        exact HgReq. }
      claim Hltself: Rlt (minus_SNo 1) (minus_SNo 1).
      { rewrite <- HfxEq at 2.
        exact Hlt. }
      apply FalseE.
      exact ((not_Rlt_refl (minus_SNo 1) Hm1R) Hltself).
    + assume HxD1: x :e D1.
      claim HgRx: apply_fun gR x :e {1}.
      { exact (SepE2 X (fun u:set => apply_fun gR u :e {1}) x HxD1). }
      claim HgReq: apply_fun gR x = 1.
      { exact (SingE 1 (apply_fun gR x) HgRx). }
      claim Hgxfx: apply_fun gR x = apply_fun f x.
      { exact (HgR_eq_on_A x HxA). }
      claim HfxU: apply_fun f x :e U.
      { claim Hfunf: function_on f A U.
        { exact (continuous_map_function_on A (subspace_topology X Tx A) U Tu f Hf). }
        exact (Hfunf x HxA). }
      claim Hfxconj: Rlt (minus_SNo 1) (apply_fun f x) /\ Rlt (apply_fun f x) 1.
      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) (apply_fun f x) HfxU). }
      claim Hlt: Rlt (apply_fun f x) 1.
      { exact (andER (Rlt (minus_SNo 1) (apply_fun f x)) (Rlt (apply_fun f x) 1) Hfxconj). }
      claim HfxEq: apply_fun f x = 1.
      { rewrite <- Hgxfx at 1.
        exact HgReq. }
      claim Hltself: Rlt 1 1.
      { rewrite <- HfxEq at 1.
        exact Hlt. }
      apply FalseE.
      exact ((not_Rlt_refl 1 real_1) Hltself).
    + exact HxD.
  - let x. assume Hx: x :e Empty.
    prove x :e D :/\: A.
    exact (EmptyE x Hx (x :e D :/\: A)). }

(** apply Urysohn lemma to separate D and A by phi : X -> [0,1] **)
claim Hab01: Rle 0 1.
{ exact (Rlt_implies_Rle 0 1 Rlt_0_1). }
claim Hexphi: exists phiI:set,
  continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI /\
  (forall x:set, x :e D -> apply_fun phiI x = 0) /\
  (forall x:set, x :e A -> apply_fun phiI x = 1).
{ exact (Urysohn_lemma X Tx D A 0 1 Hab01 Hnorm HDcl HA Hdisj). }
apply Hexphi.
let phiI. assume Hphi.
claim Hphi12:
  continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI /\
  (forall x:set, x :e D -> apply_fun phiI x = 0).
{ exact (andEL
           (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI /\
            (forall x:set, x :e D -> apply_fun phiI x = 0))
           (forall x:set, x :e A -> apply_fun phiI x = 1)
           Hphi). }
claim HphiContI: continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI.
{ exact (andEL (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI)
               (forall x:set, x :e D -> apply_fun phiI x = 0)
               Hphi12). }
claim HphiD0: forall x:set, x :e D -> apply_fun phiI x = 0.
{ exact (andER (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI)
               (forall x:set, x :e D -> apply_fun phiI x = 0)
               Hphi12). }
claim HphiA1: forall x:set, x :e A -> apply_fun phiI x = 1.
{ exact (andER
           (continuous_map X Tx (closed_interval 0 1) (closed_interval_topology 0 1) phiI /\
            (forall x:set, x :e D -> apply_fun phiI x = 0))
           (forall x:set, x :e A -> apply_fun phiI x = 1)
           Hphi). }

(** view phiI as a real-valued map phiR : X -> R by inclusion [0,1] -> R **)
set I01 := closed_interval 0 1.
set T01 := closed_interval_topology 0 1.
claim HI01subR: I01 c= R.
{ exact (closed_interval_sub_R 0 1). }
set inc01 := {(y,y) | y :e I01}.
claim Hinc01: continuous_map I01 T01 R R_standard_topology inc01.
{ exact (subspace_inclusion_continuous R R_standard_topology I01
         R_standard_topology_is_topology_local HI01subR). }
set phiR := compose_fun X phiI inc01.
claim HphiRcont: continuous_map X Tx R R_standard_topology phiR.
{ exact (composition_continuous X Tx I01 T01 R R_standard_topology phiI inc01 HphiContI Hinc01). }

(** define hR(x) = phiR(x) times gR(x) and restrict its range to U **)
set hR := compose_fun X (pair_map X phiR gR) mul_fun_R.
claim HhRcont: continuous_map X Tx R R_standard_topology hR.
{ exact (mul_two_continuous_R X Tx phiR gR HTx HphiRcont HgRcont). }
claim HhRinU: forall x:set, x :e X -> apply_fun hR x :e U.
{ let x. assume HxX: x :e X.
  prove apply_fun hR x :e U.
  (** compute the value hR x = phiR x times gR x **)
  set p := apply_fun phiR x.
  set t := apply_fun gR x.
  claim HpR: p :e R.
  { exact (continuous_map_function_on X Tx R R_standard_topology phiR HphiRcont x HxX). }
  claim HtR: t :e R.
  { exact (continuous_map_function_on X Tx R R_standard_topology gR HgRcont x HxX). }
  claim HpS: SNo p.
  { exact (real_SNo p HpR). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  set hval := apply_fun hR x.
  claim HpairRR: (p,t) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R p t HpR HtR). }
  claim HhvalEq:
    hval = mul_SNo p t.
  { rewrite (compose_fun_apply X (pair_map X phiR gR) mul_fun_R x HxX).
    rewrite (pair_map_apply X R R phiR gR x HxX).
    rewrite (apply_fun_graph (setprod R R) (fun q:set => mul_SNo (q 0) (q 1)) (p,t) HpairRR).
    rewrite (tuple_2_0_eq p t).
    rewrite (tuple_2_1_eq p t).
    reflexivity. }
  claim HmulR: mul_SNo p t :e R.
  { exact (real_mul_SNo p HpR t HtR). }
  (** show membership in open_interval(-1,1) by cases on x in D **)
  apply (xm (x :e D)).
  - assume HxD: x :e D.
    prove hval :e U.
    (** on D, phiI is 0, hence hval = 0 **)
    claim HphiIx0: apply_fun phiI x = 0.
    { exact (HphiD0 x HxD). }
    claim HphiFun: function_on phiI X I01.
    { exact (continuous_map_function_on X Tx I01 T01 phiI HphiContI). }
    claim HphiIxI01: apply_fun phiI x :e I01.
    { exact (HphiFun x HxX). }
    claim HphiRval: p = apply_fun phiI x.
    { prove apply_fun phiR x = apply_fun phiI x.
      rewrite (compose_fun_apply X phiI inc01 x HxX).
      rewrite (identity_function_apply I01 (apply_fun phiI x) HphiIxI01).
      reflexivity. }
    claim Hp0: p = 0.
    { rewrite HphiRval.
      exact HphiIx0. }
    rewrite HhvalEq.
    rewrite Hp0.
    rewrite (mul_SNo_zeroL t HtS).
    (** 0 is in the open interval (-1,1) **)
    claim HUdef: U = {y0 :e R | Rlt (minus_SNo 1) y0 /\ Rlt y0 1}.
    { reflexivity. }
    rewrite HUdef.
    apply (SepI R (fun y0:set => Rlt (minus_SNo 1) y0 /\ Rlt y0 1) 0 real_0).
    apply andI.
    + exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0).
    + exact Rlt_0_1.
  - assume HxNotD: ~(x :e D).
    prove hval :e U.
    (** first show that t is in the closed interval I and not equal to the endpoints **)
    claim HgIfun: function_on gI X I.
    { exact (continuous_map_function_on X Tx I Ti gI HgIcont). }
    claim HgIxI: apply_fun gI x :e I.
    { exact (HgIfun x HxX). }
    claim HgRval: t = apply_fun gI x.
    { prove apply_fun gR x = apply_fun gI x.
      rewrite (compose_fun_apply X gI incI x HxX).
      rewrite (identity_function_apply I (apply_fun gI x) HgIxI).
      reflexivity. }
    claim HtI: t :e I.
    { rewrite HgRval.
      exact HgIxI. }
    claim HtIdef: I = {y0 :e R | ~(Rlt y0 (minus_SNo 1)) /\ ~(Rlt 1 y0)}.
    { reflexivity. }
    claim HtIsep: t :e {y0 :e R | ~(Rlt y0 (minus_SNo 1)) /\ ~(Rlt 1 y0)}.
    { rewrite HtIdef.
      exact HtI. }
    claim Htconj: ~(Rlt t (minus_SNo 1)) /\ ~(Rlt 1 t).
    { exact (SepE2 R (fun y0:set => ~(Rlt y0 (minus_SNo 1)) /\ ~(Rlt 1 y0)) t HtIsep). }
    claim Htge_m1: ~(Rlt t (minus_SNo 1)).
    { exact (andEL (~(Rlt t (minus_SNo 1))) (~(Rlt 1 t)) Htconj). }
    claim Htle_1: ~(Rlt 1 t).
    { exact (andER (~(Rlt t (minus_SNo 1))) (~(Rlt 1 t)) Htconj). }
    claim HtR2: t :e R.
    { exact (SepE1 R (fun y0:set => ~(Rlt y0 (minus_SNo 1)) /\ ~(Rlt 1 y0)) t HtIsep). }
    (** show t <> -1 and t <> 1 using x not in D **)
    claim HxNotDm1: ~(x :e Dm1).
    { assume HxDm1: x :e Dm1.
      apply HxNotD.
      exact (binunionI1 Dm1 D1 x HxDm1). }
    claim HxNotD1: ~(x :e D1).
    { assume HxD1: x :e D1.
      apply HxNotD.
      exact (binunionI2 Dm1 D1 x HxD1). }
    claim Hneq_m1: ~(t = minus_SNo 1).
    { assume Heq: t = minus_SNo 1.
      apply HxNotDm1.
      claim HDm1def: Dm1 = {u :e X | apply_fun gR u :e {minus_SNo 1}}.
      { reflexivity. }
      rewrite HDm1def.
      apply (SepI X (fun u:set => apply_fun gR u :e {minus_SNo 1}) x HxX).
      claim Htdef: t = apply_fun gR x.
      { reflexivity. }
      rewrite <- Htdef.
      rewrite Heq.
      exact (SingI (minus_SNo 1)). }
    claim Hneq_1: ~(t = 1).
    { assume Heq: t = 1.
      apply HxNotD1.
      claim HD1def: D1 = {u :e X | apply_fun gR u :e {1}}.
      { reflexivity. }
      rewrite HD1def.
      apply (SepI X (fun u:set => apply_fun gR u :e {1}) x HxX).
      claim Htdef: t = apply_fun gR x.
      { reflexivity. }
      rewrite <- Htdef.
      rewrite Heq.
      exact (SingI 1). }
    (** strict bounds for t: -1 < t and t < 1 **)
    claim Hm1le_t: Rle (minus_SNo 1) t.
    { apply (RleI (minus_SNo 1) t Hm1R HtR2).
      exact Htge_m1. }
    claim Ht_le1: Rle t 1.
    { apply (RleI t 1 HtR2 real_1).
      exact Htle_1. }
    claim Hm1lt_t: Rlt (minus_SNo 1) t.
    { claim HneqL: ~(minus_SNo 1 = t).
      { assume Heq: minus_SNo 1 = t.
        apply Hneq_m1.
        rewrite <- Heq.
        reflexivity. }
      exact (Rle_neq_implies_Rlt (minus_SNo 1) t Hm1le_t HneqL). }
    claim Htlt1: Rlt t 1.
    { exact (Rle_neq_implies_Rlt t 1 Ht_le1 Hneq_1). }
    claim Hm1lt_tS: minus_SNo 1 < t.
    { exact (RltE_lt (minus_SNo 1) t Hm1lt_t). }
    claim Htlt1S: t < 1.
    { exact (RltE_lt t 1 Htlt1). }
    (** bounds for p in [0,1] (from phiI range) **)
    claim HpI01: p :e I01.
    { claim HphiFun: function_on phiI X I01.
      { exact (continuous_map_function_on X Tx I01 T01 phiI HphiContI). }
      claim HphiIxI01: apply_fun phiI x :e I01.
      { exact (HphiFun x HxX). }
      claim HphiRval: p = apply_fun phiI x.
      { prove apply_fun phiR x = apply_fun phiI x.
        rewrite (compose_fun_apply X phiI inc01 x HxX).
        rewrite (identity_function_apply I01 (apply_fun phiI x) HphiIxI01).
        reflexivity. }
      rewrite HphiRval.
      exact HphiIxI01. }
    claim HpI01def: I01 = {y0 :e R | ~(Rlt y0 0) /\ ~(Rlt 1 y0)}.
    { reflexivity. }
    claim HpI01sep: p :e {y0 :e R | ~(Rlt y0 0) /\ ~(Rlt 1 y0)}.
    { rewrite HpI01def.
      exact HpI01. }
    claim Hpconj: ~(Rlt p 0) /\ ~(Rlt 1 p).
    { exact (SepE2 R (fun y0:set => ~(Rlt y0 0) /\ ~(Rlt 1 y0)) p HpI01sep). }
    claim Hpnotlt0: ~(Rlt p 0).
    { exact (andEL (~(Rlt p 0)) (~(Rlt 1 p)) Hpconj). }
    claim Hpnotgt1: ~(Rlt 1 p).
    { exact (andER (~(Rlt p 0)) (~(Rlt 1 p)) Hpconj). }
    (** final: show mul_SNo p t is in U by cases on p = 0 and p = 1 and sign of t **)
    rewrite HhvalEq.
    claim HUdef: U = {y0 :e R | Rlt (minus_SNo 1) y0 /\ Rlt y0 1}.
    { reflexivity. }
    rewrite HUdef.
    apply (SepI R (fun y0:set => Rlt (minus_SNo 1) y0 /\ Rlt y0 1) (mul_SNo p t) HmulR).
    apply andI.
    - apply (SNoLt_trichotomy_or_impred p 0 HpS SNo_0 (Rlt (minus_SNo 1) (mul_SNo p t))).
      - assume Hplt0: p < 0.
        apply FalseE.
        claim HpRlt0: Rlt p 0.
        { exact (RltI p 0 HpR real_0 Hplt0). }
        exact (Hpnotlt0 HpRlt0).
      - assume Hpeq0: p = 0.
        rewrite Hpeq0.
        rewrite (mul_SNo_zeroL t HtS).
        exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0).
      - assume H0ltp: 0 < p.
        (** split on sign of t **)
        apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (Rlt (minus_SNo 1) (mul_SNo p t))).
        - assume Htlt0: t < 0.
          (** in the negative case, use either p=1 (then product=t) or p<1 (then product >= t) **)
          apply (SNoLt_trichotomy_or_impred p 1 HpS SNo_1 (Rlt (minus_SNo 1) (mul_SNo p t))).
          - assume Hplt1: p < 1.
            claim Hple1: p <= 1.
            { exact (SNoLtLe p 1 Hplt1). }
            claim HtLe0: t <= 0.
            { exact (SNoLtLe t 0 Htlt0). }
            claim Htpt_ge: t <= mul_SNo p t.
            { claim H1S: SNo 1.
              { exact SNo_1. }
              claim Hcomm: mul_SNo p t = mul_SNo t p.
              { exact (mul_SNo_com p t HpS HtS). }
              rewrite Hcomm.
              claim Hineq: mul_SNo t 1 <= mul_SNo t p.
              { exact (nonpos_mul_SNo_Le t 1 p HtS HtLe0 H1S HpS Hple1). }
              claim Hineq2: t <= mul_SNo t p.
              { rewrite <- (mul_SNo_oneR t HtS) at 1.
                exact Hineq. }
              exact Hineq2. }
            claim Hm1lt_tS2: minus_SNo 1 < t.
            { exact Hm1lt_tS. }
            claim Hm1lt_ptS: minus_SNo 1 < mul_SNo p t.
            { exact (SNoLtLe_tra (minus_SNo 1) t (mul_SNo p t)
                      (SNo_minus_SNo 1 SNo_1) HtS (SNo_mul_SNo p t HpS HtS) Hm1lt_tS2 Htpt_ge). }
            exact (RltI (minus_SNo 1) (mul_SNo p t) Hm1R HmulR Hm1lt_ptS).
          - assume Hpeq1: p = 1.
            rewrite Hpeq1.
            rewrite (mul_SNo_oneL t HtS).
            exact Hm1lt_t.
          - assume H1ltp: 1 < p.
            apply FalseE.
            claim H1ltpR: Rlt 1 p.
            { exact (RltI 1 p real_1 HpR H1ltp). }
            exact (Hpnotgt1 H1ltpR).
        - assume Hteq0: t = 0.
          rewrite Hteq0.
          rewrite (mul_SNo_zeroR p HpS).
          exact (RltI (minus_SNo 1) 0 Hm1R real_0 minus_1_lt_0).
        - assume H0ltt: 0 < t.
          claim H0le_pt: 0 <= mul_SNo p t.
          { exact (SNoLtLe 0 (mul_SNo p t) (mul_SNo_pos_pos p t HpS HtS H0ltp H0ltt)). }
          claim Hm10S: minus_SNo 1 < 0.
          { exact minus_1_lt_0. }
          claim Hm1lt_ptS: minus_SNo 1 < mul_SNo p t.
          { exact (SNoLtLe_tra (minus_SNo 1) 0 (mul_SNo p t)
                    (SNo_minus_SNo 1 SNo_1) SNo_0 (SNo_mul_SNo p t HpS HtS)
                    Hm10S H0le_pt). }
          exact (RltI (minus_SNo 1) (mul_SNo p t) Hm1R HmulR Hm1lt_ptS).
    - apply (SNoLt_trichotomy_or_impred p 0 HpS SNo_0 (Rlt (mul_SNo p t) 1)).
      - assume Hplt0: p < 0.
        apply FalseE.
        claim HpRlt0: Rlt p 0.
        { exact (RltI p 0 HpR real_0 Hplt0). }
        exact (Hpnotlt0 HpRlt0).
      - assume Hpeq0: p = 0.
        rewrite Hpeq0.
        rewrite (mul_SNo_zeroL t HtS).
        exact Rlt_0_1.
      - assume H0ltp: 0 < p.
        apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (Rlt (mul_SNo p t) 1)).
        - assume Htlt0: t < 0.
          (** product is negative, hence < 1 **)
          claim Hptlt0: mul_SNo p t < 0.
          { exact (mul_SNo_pos_neg p t HpS HtS H0ltp Htlt0). }
          claim H0lt1: 0 < 1.
          { exact SNoLt_0_1. }
          claim Hptlt1: mul_SNo p t < 1.
          { exact (SNoLt_tra (mul_SNo p t) 0 1 (SNo_mul_SNo p t HpS HtS) SNo_0 SNo_1 Hptlt0 H0lt1). }
          exact (RltI (mul_SNo p t) 1 HmulR real_1 Hptlt1).
        - assume Hteq0: t = 0.
          rewrite Hteq0.
          rewrite (mul_SNo_zeroR p HpS).
          exact Rlt_0_1.
        - assume H0ltt: 0 < t.
          (** split on p = 1 or p < 1 to bound product by t < 1 **)
          apply (SNoLt_trichotomy_or_impred p 1 HpS SNo_1 (Rlt (mul_SNo p t) 1)).
          - assume Hplt1: p < 1.
            claim Hptlt_t: mul_SNo p t < t.
            { exact (mul_SNo_Lt1_pos_Lt p t HpS HtS Hplt1 H0ltt). }
            claim Hptlt1: mul_SNo p t < 1.
            { exact (SNoLt_tra (mul_SNo p t) t 1 (SNo_mul_SNo p t HpS HtS) HtS SNo_1 Hptlt_t Htlt1S). }
            exact (RltI (mul_SNo p t) 1 HmulR real_1 Hptlt1).
          - assume Hpeq1: p = 1.
            rewrite Hpeq1.
            rewrite (mul_SNo_oneL t HtS).
            exact Htlt1.
          - assume H1ltp: 1 < p.
            apply FalseE.
            claim H1ltpR: Rlt 1 p.
            { exact (RltI 1 p real_1 HpR H1ltp). }
            exact (Hpnotgt1 H1ltpR).
}
set g := hR.
witness g.
apply andI.
- exact (continuous_map_range_restrict X Tx R R_standard_topology g U HhRcont HUsubR HhRinU).
- let x. assume HxA: x :e A.
  prove apply_fun g x = apply_fun f x.
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HA). }
  claim HxX: x :e X.
  { exact (HAsubX x HxA). }
  claim Hcomp: apply_fun g x = apply_fun mul_fun_R (apply_fun (pair_map X phiR gR) x).
  { rewrite (compose_fun_apply X (pair_map X phiR gR) mul_fun_R x HxX). reflexivity. }
  rewrite Hcomp.
  rewrite (pair_map_apply X R R phiR gR x HxX).
  claim HphiIx: apply_fun phiI x = 1.
  { exact (HphiA1 x HxA). }
  claim HphiFun: function_on phiI X I01.
  { exact (continuous_map_function_on X Tx I01 T01 phiI HphiContI). }
  claim HphiIxI01: apply_fun phiI x :e I01.
  { exact (HphiFun x HxX). }
  claim HphiRval: apply_fun phiR x = apply_fun phiI x.
  { rewrite (compose_fun_apply X phiI inc01 x HxX).
    rewrite (identity_function_apply I01 (apply_fun phiI x) HphiIxI01).
    reflexivity. }
  rewrite HphiRval.
  rewrite HphiIx.
  claim HgRxR: apply_fun gR x :e R.
  { exact (continuous_map_function_on X Tx R R_standard_topology gR HgRcont x HxX). }
  claim HpairRR: (1, apply_fun gR x) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R 1 (apply_fun gR x) real_1 HgRxR). }
  rewrite (apply_fun_graph (setprod R R) (fun p0:set => mul_SNo (p0 0) (p0 1)) (1, apply_fun gR x) HpairRR).
  rewrite (tuple_2_0_eq 1 (apply_fun gR x)).
  rewrite (tuple_2_1_eq 1 (apply_fun gR x)).
  claim HgRxS: SNo (apply_fun gR x).
  { exact (real_SNo (apply_fun gR x) HgRxR). }
  rewrite (mul_SNo_oneL (apply_fun gR x) HgRxS).
  exact (HgR_eq_on_A x HxA).
Qed.

(** helper for §35: bounded transform phi(t) = t / (1 + |t|) **)
Definition bounded_transform_phi : set :=
  graph R (fun t:set => div_SNo t (add_SNo 1 (abs_SNo t))).

(** helper for §35: bounded transform maps reals to reals **)
Theorem bounded_transform_phi_value_in_R : forall t:set,
  t :e R -> apply_fun bounded_transform_phi t :e R.
let t.
assume HtR: t :e R.
prove apply_fun bounded_transform_phi t :e R.
claim Hdef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HdenR: add_SNo 1 (abs_SNo t) :e R.
{ exact (real_add_SNo 1 real_1 (abs_SNo t) HabsR). }
exact (real_div_SNo t HtR (add_SNo 1 (abs_SNo t)) HdenR).
Qed.

(** helper for §35: bounded transform range is within the closed interval [-1,1] **)
Theorem bounded_transform_phi_range_in_closed_interval_minus1_1 : forall t:set,
  t :e R ->
  apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
let t.
assume HtR: t :e R.
prove apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
set f := apply_fun bounded_transform_phi t.
claim HfR: f :e R.
{ exact (bounded_transform_phi_value_in_R t HtR). }
claim HfDef: f = apply_fun bounded_transform_phi t.
{ reflexivity. }
claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
claim HdenS: SNo (add_SNo 1 (abs_SNo t)).
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < add_SNo 1 (abs_SNo t).
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < add_SNo 1 (abs_SNo t).
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim HfEq: f = div_SNo t (add_SNo 1 (abs_SNo t)).
{ rewrite HfDef.
  rewrite HphiDef.
  rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
  reflexivity. }

(** show t < 1 + |t| **)
claim HtLeAbs: t <= abs_SNo t.
{ exact (abs_SNo_upper_bound t HtS). }
claim HtLtT1_raw: add_SNo t 0 < add_SNo t 1.
{ exact (add_SNo_Lt2 t 0 1 HtS SNo_0 SNo_1 SNoLt_0_1). }
claim HtLtT1: t < add_SNo t 1.
{ rewrite <- (add_SNo_0R t HtS) at 1.
  exact HtLtT1_raw. }
claim Ht1LeAbs1: add_SNo t 1 <= add_SNo (abs_SNo t) 1.
{ exact (add_SNo_Le1 t 1 (abs_SNo t) HtS SNo_1 HabsS HtLeAbs). }
claim Hab1S: SNo (add_SNo (abs_SNo t) 1).
{ exact (SNo_add_SNo (abs_SNo t) 1 HabsS SNo_1). }
claim Ht1S: SNo (add_SNo t 1).
{ exact (SNo_add_SNo t 1 HtS SNo_1). }
claim HtLtAbs1: t < add_SNo (abs_SNo t) 1.
{ exact (SNoLtLe_tra t (add_SNo t 1) (add_SNo (abs_SNo t) 1) HtS Ht1S Hab1S HtLtT1 Ht1LeAbs1). }
claim Habs1EqDen: add_SNo (abs_SNo t) 1 = add_SNo 1 (abs_SNo t).
{ exact (add_SNo_com (abs_SNo t) 1 HabsS SNo_1). }
claim HtLtDen: t < add_SNo 1 (abs_SNo t).
{ rewrite <- Habs1EqDen at 1.
  exact HtLtAbs1. }

(** membership in closed interval is non-strict bounds **)
claim HCI_def: closed_interval (minus_SNo 1) 1 = {x :e R | ~(Rlt x (minus_SNo 1)) /\ ~(Rlt 1 x)}.
{ reflexivity. }
rewrite HCI_def.
apply (SepI R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) f HfR).
apply andI.
- assume Hlt: Rlt f (minus_SNo 1).
  prove False.
  claim HfLtM1: f < minus_SNo 1.
  { exact (RltE_lt f (minus_SNo 1) Hlt). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim HdivLt: div_SNo t (add_SNo 1 (abs_SNo t)) < minus_SNo 1.
  { rewrite <- HfEq.
    exact HfLtM1. }
  claim HtLtM1den: t < mul_SNo (minus_SNo 1) (add_SNo 1 (abs_SNo t)).
  { exact (div_SNo_pos_LtL' t (add_SNo 1 (abs_SNo t)) (minus_SNo 1) HtS HdenS Hm1S HdenPos HdivLt). }
  claim Hm1denEq: mul_SNo (minus_SNo 1) (add_SNo 1 (abs_SNo t)) = minus_SNo (add_SNo 1 (abs_SNo t)).
  { rewrite (mul_SNo_minus_distrL 1 (add_SNo 1 (abs_SNo t)) SNo_1 HdenS).
    rewrite (mul_SNo_oneL (add_SNo 1 (abs_SNo t)) HdenS).
    reflexivity. }
  claim HtLtMden: t < minus_SNo (add_SNo 1 (abs_SNo t)).
  { rewrite <- Hm1denEq at 1.
    exact HtLtM1den. }
  (** show - (1+|t|) < t **)
  claim HabsLtAbs1_raw: add_SNo (abs_SNo t) 0 < add_SNo (abs_SNo t) 1.
  { exact (add_SNo_Lt2 (abs_SNo t) 0 1 HabsS SNo_0 SNo_1 SNoLt_0_1). }
  claim HabsLtAbs1: abs_SNo t < add_SNo (abs_SNo t) 1.
  { rewrite <- (add_SNo_0R (abs_SNo t) HabsS) at 1.
    exact HabsLtAbs1_raw. }
  claim HabsLtDen: abs_SNo t < add_SNo 1 (abs_SNo t).
  { rewrite <- Habs1EqDen.
    exact HabsLtAbs1. }
  claim HnegDenLtNegAbs: minus_SNo (add_SNo 1 (abs_SNo t)) < minus_SNo (abs_SNo t).
  { exact (minus_SNo_Lt_contra (abs_SNo t) (add_SNo 1 (abs_SNo t)) HabsS HdenS HabsLtDen). }
  claim HnegAbsLeT: minus_SNo (abs_SNo t) <= t.
  { exact (abs_SNo_lower_bound t HtS). }
  claim HmdenLtT: minus_SNo (add_SNo 1 (abs_SNo t)) < t.
  { claim HmabsS: SNo (minus_SNo (abs_SNo t)).
    { exact (SNo_minus_SNo (abs_SNo t) HabsS). }
    claim HmdenS: SNo (minus_SNo (add_SNo 1 (abs_SNo t))).
    { exact (SNo_minus_SNo (add_SNo 1 (abs_SNo t)) HdenS). }
    exact (SNoLtLe_tra (minus_SNo (add_SNo 1 (abs_SNo t))) (minus_SNo (abs_SNo t)) t HmdenS HmabsS HtS HnegDenLtNegAbs HnegAbsLeT). }
  claim Hbad: t < t.
  { exact (SNoLt_tra t (minus_SNo (add_SNo 1 (abs_SNo t))) t HtS
          (SNo_minus_SNo (add_SNo 1 (abs_SNo t)) HdenS) HtS HtLtMden HmdenLtT). }
  exact (FalseE ((SNoLt_irref t) Hbad) False).
- assume Hlt: Rlt 1 f.
  prove False.
  claim H1Lt: 1 < f.
  { exact (RltE_lt 1 f Hlt). }
  claim H1LtDiv: 1 < div_SNo t (add_SNo 1 (abs_SNo t)).
  { rewrite <- HfEq.
    exact H1Lt. }
  claim HdenLtT_raw: mul_SNo 1 (add_SNo 1 (abs_SNo t)) < t.
  { exact (div_SNo_pos_LtR' t (add_SNo 1 (abs_SNo t)) 1 HtS HdenS SNo_1 HdenPos H1LtDiv). }
  claim HdenLtT: add_SNo 1 (abs_SNo t) < t.
  { rewrite <- (mul_SNo_oneL (add_SNo 1 (abs_SNo t)) HdenS) at 1.
    exact HdenLtT_raw. }
  claim Hbad: add_SNo 1 (abs_SNo t) < add_SNo 1 (abs_SNo t).
  { exact (SNoLt_tra (add_SNo 1 (abs_SNo t)) t (add_SNo 1 (abs_SNo t))
          HdenS HtS HdenS HdenLtT HtLtDen). }
  exact (FalseE ((SNoLt_irref (add_SNo 1 (abs_SNo t))) Hbad) False).
Qed.

(** helper for §35: strict range is within the open interval (-1,1) **)
Theorem bounded_transform_phi_strict_bounds : forall t:set,
  t :e R ->
  Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t) /\
  Rlt (apply_fun bounded_transform_phi t) 1.
let t.
assume HtR: t :e R.
prove Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t) /\
  Rlt (apply_fun bounded_transform_phi t) 1.
set f := apply_fun bounded_transform_phi t.
claim HfR: f :e R.
{ exact (bounded_transform_phi_value_in_R t HtR). }
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
set den := add_SNo 1 (abs_SNo t).
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < den.
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim HdenR: den :e R.
{ exact (real_add_SNo 1 real_1 (abs_SNo t) HabsR). }

claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
claim HfEq: f = div_SNo t den.
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
  reflexivity. }

(** show t < den **)
claim HtLeAbs: t <= abs_SNo t.
{ exact (abs_SNo_upper_bound t HtS). }
claim HabsLtDen_raw: add_SNo (abs_SNo t) 0 < add_SNo (abs_SNo t) 1.
{ exact (add_SNo_Lt2 (abs_SNo t) 0 1 HabsS SNo_0 SNo_1 SNoLt_0_1). }
claim HabsLtAbs1: abs_SNo t < add_SNo (abs_SNo t) 1.
{ rewrite <- (add_SNo_0R (abs_SNo t) HabsS) at 1.
  exact HabsLtDen_raw. }
claim Habs1EqDen: add_SNo (abs_SNo t) 1 = den.
{ exact (add_SNo_com (abs_SNo t) 1 HabsS SNo_1). }
claim HabsLtDen: abs_SNo t < den.
{ rewrite <- Habs1EqDen.
  exact HabsLtAbs1. }
claim HabS: SNo (abs_SNo t).
{ exact HabsS. }
claim HtLtDen: t < den.
{ exact (SNoLeLt_tra t (abs_SNo t) den HtS HabS HdenS HtLeAbs HabsLtDen). }

(** show -den < t **)
claim HnegDenLtNegAbs: minus_SNo den < minus_SNo (abs_SNo t).
{ exact (minus_SNo_Lt_contra (abs_SNo t) den HabsS HdenS HabsLtDen). }
claim HnegAbsLeT: minus_SNo (abs_SNo t) <= t.
{ exact (abs_SNo_lower_bound t HtS). }
claim HnegDenLtT: minus_SNo den < t.
{ claim HmdenS: SNo (minus_SNo den).
  { exact (SNo_minus_SNo den HdenS). }
  claim HmabsS: SNo (minus_SNo (abs_SNo t)).
  { exact (SNo_minus_SNo (abs_SNo t) HabsS). }
  exact (SNoLtLe_tra (minus_SNo den) (minus_SNo (abs_SNo t)) t HmdenS HmabsS HtS HnegDenLtNegAbs HnegAbsLeT). }

apply andI.
- (** -1 < f **)
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim Hm1denLt: mul_SNo (minus_SNo 1) den < t.
  { claim HmdenEq: mul_SNo (minus_SNo 1) den = minus_SNo den.
    { rewrite (mul_SNo_minus_distrL 1 den SNo_1 HdenS).
      rewrite (mul_SNo_oneL den HdenS).
      reflexivity. }
    rewrite HmdenEq.
    exact HnegDenLtT. }
  claim Hm1LtDiv: minus_SNo 1 < div_SNo t den.
  { exact (div_SNo_pos_LtR t den (minus_SNo 1) HtS HdenS Hm1S HdenPos Hm1denLt). }
  claim Hm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim HdivR: div_SNo t den :e R.
  { exact (real_div_SNo t HtR den HdenR). }
  claim Hm1Ltf: minus_SNo 1 < f.
  { rewrite HfEq.
    exact Hm1LtDiv. }
  exact (RltI (minus_SNo 1) f Hm1R HfR Hm1Ltf).
- (** f < 1 **)
  claim H1S: SNo 1.
  { exact SNo_1. }
  claim HtLt1den: t < mul_SNo 1 den.
  { rewrite (mul_SNo_oneL den HdenS).
    exact HtLtDen. }
  claim HdivLt1: div_SNo t den < 1.
  { exact (div_SNo_pos_LtL t den 1 HtS HdenS H1S HdenPos HtLt1den). }
  claim Hflt1: f < 1.
  { rewrite HfEq at 1.
    exact HdivLt1. }
  exact (RltI f 1 HfR real_1 Hflt1).
Qed.

(** helper for §35: inverse bounded transform psi(s) = s / (1 - |s|) **)
Definition bounded_transform_psi : set :=
  graph R (fun s:set => div_SNo s (add_SNo 1 (minus_SNo (abs_SNo s)))).

(** helper for §35: abs distributes over division by positive denominator **)
Theorem abs_div_SNo_pos : forall x y:set,
  SNo x -> SNo y -> 0 < y ->
  abs_SNo (div_SNo x y) = div_SNo (abs_SNo x) y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume Hypos: 0 < y.
prove abs_SNo (div_SNo x y) = div_SNo (abs_SNo x) y.
claim Hy0: y <> 0.
{ exact (SNo_pos_ne0 y HyS Hypos). }
claim HdivS: SNo (div_SNo x y).
{ exact (SNo_div_SNo x y HxS HyS). }
apply (xm (0 <= x)).
- assume H0lex: 0 <= x.
  rewrite (nonneg_abs_SNo x H0lex).
  claim H0lediv: 0 <= div_SNo x y.
  { apply (SNoLt_trichotomy_or_impred (div_SNo x y) 0 HdivS SNo_0 (0 <= div_SNo x y)).
    - assume Hdivlt0: div_SNo x y < 0.
      claim Hxlt0': x < 0.
      { claim Hxlt0y: x < mul_SNo 0 y.
        { exact (div_SNo_pos_LtL' x y 0 HxS HyS SNo_0 Hypos Hdivlt0). }
        prove x < 0.
        rewrite <- (mul_SNo_zeroL y HyS) at 1.
        exact Hxlt0y. }
      claim Hxle0: x <= 0.
      { exact (SNoLtLe x 0 Hxlt0'). }
      claim Heq0: x = 0.
      { exact (SNoLe_antisym x 0 HxS SNo_0 Hxle0 H0lex). }
      claim H00: 0 < 0.
      { rewrite <- Heq0 at 1.
        exact Hxlt0'. }
      exact (FalseE ((SNoLt_irref 0) H00) (0 <= div_SNo x y)).
    - assume Hdiv0: div_SNo x y = 0.
      rewrite Hdiv0.
      exact (SNoLe_ref 0).
    - assume H0ltdiv: 0 < div_SNo x y.
      exact (SNoLtLe 0 (div_SNo x y) H0ltdiv). }
  rewrite (nonneg_abs_SNo (div_SNo x y) H0lediv).
  reflexivity.
- assume Hn0lex: ~(0 <= x).
  claim Hxlt0: x < 0.
  { apply (SNoLt_trichotomy_or_impred x 0 HxS SNo_0 (x < 0)).
    - assume H: x < 0.
      exact H.
    - assume Hx0: x = 0.
      claim H0lex: 0 <= x.
      { rewrite Hx0.
        exact (SNoLe_ref 0). }
      exact (FalseE (Hn0lex H0lex) (x < 0)).
    - assume H0ltx: 0 < x.
      claim H0lex: 0 <= x.
      { exact (SNoLtLe 0 x H0ltx). }
      exact (FalseE (Hn0lex H0lex) (x < 0)). }
  rewrite (neg_abs_SNo x HxS Hxlt0).
  claim Hdivlt0: div_SNo x y < 0.
  { exact (div_SNo_neg_pos x y HxS HyS Hxlt0 Hypos). }
  rewrite (neg_abs_SNo (div_SNo x y) HdivS Hdivlt0).
  claim HdivNeg: div_SNo (minus_SNo x) y = minus_SNo (div_SNo x y).
  { apply (mul_div_SNo_nonzero_eq (minus_SNo x) y (minus_SNo (div_SNo x y))
            (SNo_minus_SNo x HxS) HyS (SNo_minus_SNo (div_SNo x y) HdivS) Hy0).
    claim Hmul: mul_SNo y (minus_SNo (div_SNo x y)) = minus_SNo x.
    { rewrite (mul_SNo_minus_distrR y (div_SNo x y) HyS HdivS).
      rewrite (mul_div_SNo_invR x y HxS HyS Hy0).
      reflexivity. }
    rewrite <- Hmul at 1.
    reflexivity. }
	rewrite <- HdivNeg at 1.
	reflexivity.
Qed.

(** helper for §35: nonneg numerator over positive denominator is nonneg **)
Theorem div_SNo_nonneg_pos_nonneg : forall x y:set,
  SNo x -> SNo y -> 0 <= x -> 0 < y -> 0 <= div_SNo x y.
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume H0lex: 0 <= x.
assume Hypos: 0 < y.
prove 0 <= div_SNo x y.
claim HdivS: SNo (div_SNo x y).
{ exact (SNo_div_SNo x y HxS HyS). }
apply (SNoLt_trichotomy_or_impred (div_SNo x y) 0 HdivS SNo_0 (0 <= div_SNo x y)).
- assume Hdivlt0: div_SNo x y < 0.
  claim Hxlt0y: x < mul_SNo 0 y.
  { exact (div_SNo_pos_LtL' x y 0 HxS HyS SNo_0 Hypos Hdivlt0). }
  claim Hxlt0: x < 0.
  { rewrite <- (mul_SNo_zeroL y HyS) at 1.
    exact Hxlt0y. }
  claim Hxle0: x <= 0.
  { exact (SNoLtLe x 0 Hxlt0). }
  claim Heq0: x = 0.
  { exact (SNoLe_antisym x 0 HxS SNo_0 Hxle0 H0lex). }
  claim H00: 0 < 0.
  { rewrite <- Heq0 at 1.
    exact Hxlt0. }
  exact (FalseE ((SNoLt_irref 0) H00) (0 <= div_SNo x y)).
- assume Hdiv0: div_SNo x y = 0.
  rewrite Hdiv0.
  exact (SNoLe_ref 0).
- assume H0ltdiv: 0 < div_SNo x y.
  exact (SNoLtLe 0 (div_SNo x y) H0ltdiv).
Qed.

(** helper for §35: division by a nonzero denominator distributes over unary minus on numerator **)
Theorem div_SNo_minus_num : forall x y:set,
  SNo x -> SNo y -> y <> 0 -> div_SNo (minus_SNo x) y = minus_SNo (div_SNo x y).
let x y.
assume HxS: SNo x.
assume HyS: SNo y.
assume Hy0: y <> 0.
prove div_SNo (minus_SNo x) y = minus_SNo (div_SNo x y).
claim HdivS: SNo (div_SNo x y).
{ exact (SNo_div_SNo x y HxS HyS). }
apply (mul_div_SNo_nonzero_eq (minus_SNo x) y (minus_SNo (div_SNo x y))
       (SNo_minus_SNo x HxS) HyS (SNo_minus_SNo (div_SNo x y) HdivS) Hy0).
claim Hmul: mul_SNo y (minus_SNo (div_SNo x y)) = minus_SNo x.
{ rewrite (mul_SNo_minus_distrR y (div_SNo x y) HyS HdivS).
  rewrite (mul_div_SNo_invR x y HxS HyS Hy0).
  reflexivity. }
rewrite <- Hmul at 1.
reflexivity.
Qed.

(** helper for §35: absolute value is less than 1 on the open interval (-1,1) **)
Theorem abs_lt_one_of_open_interval : forall s:set,
  s :e open_interval (minus_SNo 1) 1 -> abs_SNo s < 1.
let s.
assume HsI: s :e open_interval (minus_SNo 1) 1.
claim HsR: s :e R.
{ exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
claim HsS: SNo s.
{ exact (real_SNo s HsR). }
claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
{ exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
claim Hslt1: Rlt s 1.
{ exact (andER (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
claim Hslt1S: s < 1.
{ exact (RltE_lt s 1 Hslt1). }
apply (xm (0 <= s)).
- assume H0les: 0 <= s.
  rewrite (nonneg_abs_SNo s H0les).
  exact Hslt1S.
- assume Hn0les: ~(0 <= s).
  claim Hslt0: s < 0.
  { apply (SNoLt_trichotomy_or_impred s 0 HsS SNo_0 (s < 0)).
    - assume H: s < 0. exact H.
    - assume Hs0: s = 0.
      claim H0les: 0 <= s.
      { rewrite Hs0. exact (SNoLe_ref 0). }
      exact (FalseE (Hn0les H0les) (s < 0)).
    - assume H0lts: 0 < s.
      claim H0les: 0 <= s.
      { exact (SNoLtLe 0 s H0lts). }
      exact (FalseE (Hn0les H0les) (s < 0)). }
  rewrite (not_nonneg_abs_SNo s Hn0les).
  claim Hm1lts: Rlt (minus_SNo 1) s.
  { exact (andEL (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
  claim Hm1ltsS: minus_SNo 1 < s.
  { exact (RltE_lt (minus_SNo 1) s Hm1lts). }
  claim HmsLt1': minus_SNo s < minus_SNo (minus_SNo 1).
  { exact (minus_SNo_Lt_contra (minus_SNo 1) s (SNo_minus_SNo 1 SNo_1) HsS Hm1ltsS). }
  claim HmsLt1: minus_SNo s < 1.
  { rewrite <- (minus_SNo_invol 1 SNo_1) at 1.
    exact HmsLt1'. }
  exact HmsLt1.
Qed.

(** helper for §35: open interval (-1,1) is closed under unary minus **)
Theorem neg_closed_open_interval_minus1_1 : forall s:set,
  s :e open_interval (minus_SNo 1) 1 -> (minus_SNo s) :e open_interval (minus_SNo 1) 1.
let s.
assume HsI: s :e open_interval (minus_SNo 1) 1.
claim HsR: s :e R.
{ exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
claim HmsR: minus_SNo s :e R.
{ exact (real_minus_SNo s HsR). }
claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
{ exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
claim Hm1lts: Rlt (minus_SNo 1) s.
{ exact (andEL (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
claim Hslt1: Rlt s 1.
{ exact (andER (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
claim Hmslt1: Rlt (minus_SNo s) 1.
{ claim Hmslt1S: minus_SNo s < 1.
  { claim Hmslt1S': minus_SNo s < minus_SNo (minus_SNo 1).
    { exact (minus_SNo_Lt_contra (minus_SNo 1) s (SNo_minus_SNo 1 SNo_1) (real_SNo s HsR)
             (RltE_lt (minus_SNo 1) s Hm1lts)). }
    rewrite <- (minus_SNo_invol 1 SNo_1) at 1.
    exact Hmslt1S'. }
  exact (RltI (minus_SNo s) 1 HmsR real_1 Hmslt1S). }
claim Hm1ltms: Rlt (minus_SNo 1) (minus_SNo s).
{ claim Hm1ltmsS: minus_SNo 1 < minus_SNo s.
  { exact (minus_SNo_Lt_contra s 1 (real_SNo s HsR) SNo_1 (RltE_lt s 1 Hslt1)). }
  exact (RltI (minus_SNo 1) (minus_SNo s) (real_minus_SNo 1 real_1) HmsR Hm1ltmsS). }
claim HIdef: open_interval (minus_SNo 1) 1 = {x0 :e R | Rlt (minus_SNo 1) x0 /\ Rlt x0 1}.
{ reflexivity. }
rewrite HIdef.
apply (SepI R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) (minus_SNo s) HmsR).
apply andI.
- exact Hm1ltms.
- exact Hmslt1.
Qed.

(** helper for §35: bounded transform phi is odd **)
Theorem bounded_transform_phi_odd : forall t:set,
  t :e R -> apply_fun bounded_transform_phi (minus_SNo t) = minus_SNo (apply_fun bounded_transform_phi t).
let t.
assume HtR: t :e R.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HmtR: minus_SNo t :e R.
{ exact (real_minus_SNo t HtR). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
set den := add_SNo 1 (abs_SNo t).
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < den.
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim Hden0: den <> 0.
{ exact (SNo_pos_ne0 den HdenS HdenPos). }
claim HphiDef: bounded_transform_phi = graph R (fun u:set => div_SNo u (add_SNo 1 (abs_SNo u))).
{ reflexivity. }
claim Hphi_t: apply_fun bounded_transform_phi t = div_SNo t den.
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun u:set => div_SNo u (add_SNo 1 (abs_SNo u))) t HtR).
  reflexivity. }
claim Hphi_mt: apply_fun bounded_transform_phi (minus_SNo t) =
  div_SNo (minus_SNo t) (add_SNo 1 (abs_SNo (minus_SNo t))).
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun u:set => div_SNo u (add_SNo 1 (abs_SNo u))) (minus_SNo t) HmtR).
  reflexivity. }
rewrite Hphi_mt.
rewrite (abs_SNo_minus t HtS).
rewrite Hphi_t.
exact (div_SNo_minus_num t den HtS HdenS Hden0).
Qed.

(** helper for §35: bounded transform psi is odd on the open interval (-1,1) **)
Theorem bounded_transform_psi_odd_open_interval : forall s:set,
  s :e open_interval (minus_SNo 1) 1 ->
  apply_fun bounded_transform_psi (minus_SNo s) = minus_SNo (apply_fun bounded_transform_psi s).
let s.
assume HsI: s :e open_interval (minus_SNo 1) 1.
claim HsR: s :e R.
{ exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
claim HsS: SNo s.
{ exact (real_SNo s HsR). }
claim HmsR: minus_SNo s :e R.
{ exact (real_minus_SNo s HsR). }
claim HabLt1: abs_SNo s < 1.
{ exact (abs_lt_one_of_open_interval s HsI). }
claim HabsR: abs_SNo s :e R.
{ exact (abs_SNo_in_R s HsR). }
claim HabsS: SNo (abs_SNo s).
{ exact (real_SNo (abs_SNo s) HabsR). }
set den := add_SNo 1 (minus_SNo (abs_SNo s)).
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo (abs_SNo s) HabsS)). }
claim Hneg1LtNegAbs: minus_SNo 1 < minus_SNo (abs_SNo s).
{ exact (minus_SNo_Lt_contra (abs_SNo s) 1 HabsS SNo_1 HabLt1). }
claim HdenPos0: add_SNo 1 (minus_SNo 1) < den.
{ exact (add_SNo_Lt2 1 (minus_SNo 1) (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo 1 SNo_1)
         (SNo_minus_SNo (abs_SNo s) HabsS) Hneg1LtNegAbs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
  exact HdenPos0. }
claim Hden0: den <> 0.
{ exact (SNo_pos_ne0 den HdenS HdenPos). }
claim HpsiDef: bounded_transform_psi =
  graph R (fun u:set => div_SNo u (add_SNo 1 (minus_SNo (abs_SNo u)))).
{ reflexivity. }
claim Hpsi_s: apply_fun bounded_transform_psi s = div_SNo s den.
{ rewrite HpsiDef.
  rewrite (apply_fun_graph R (fun u:set => div_SNo u (add_SNo 1 (minus_SNo (abs_SNo u)))) s HsR).
  reflexivity. }
claim Hpsi_ms: apply_fun bounded_transform_psi (minus_SNo s) =
  div_SNo (minus_SNo s) (add_SNo 1 (minus_SNo (abs_SNo (minus_SNo s)))).
{ rewrite HpsiDef.
  rewrite (apply_fun_graph R (fun u:set => div_SNo u (add_SNo 1 (minus_SNo (abs_SNo u)))) (minus_SNo s) HmsR).
  reflexivity. }
rewrite Hpsi_ms.
rewrite (abs_SNo_minus s HsS).
rewrite Hpsi_s.
exact (div_SNo_minus_num s den HsS HdenS Hden0).
Qed.

(** helper for §35: preimage of an upper open ray under psi on the open interval **)
Theorem bounded_transform_psi_preimage_open_ray_upper : forall a:set,
  a :e R ->
  preimage_of (open_interval (minus_SNo 1) 1)
              bounded_transform_psi
              (open_ray_upper R a)
  :e subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1).
let a.
assume HaR: a :e R.
prove preimage_of (open_interval (minus_SNo 1) 1)
                  bounded_transform_psi
                  (open_ray_upper R a)
      :e subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1).
set I := open_interval (minus_SNo 1) 1.
set U := preimage_of I bounded_transform_psi (open_ray_upper R a).
claim HI_sub_R: I c= R.
{ let x. assume HxI: x :e I.
  exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) x HxI). }
set c := apply_fun bounded_transform_phi a.
claim HcR: c :e R.
{ exact (bounded_transform_phi_value_in_R a HaR). }
claim HrayOpen: open_ray_upper R c :e R_standard_topology.
{ rewrite <- standard_topology_is_order_topology.
  claim Hsub: open_ray_upper R c :e open_rays_subbasis R.
  { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
  exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) Hsub). }
(** main set equality: U = (c,∞) ∩ I **)
claim Heq: U = (open_ray_upper R c) :/\: I.
{ claim HUdef: U = preimage_of I bounded_transform_psi (open_ray_upper R a).
  { reflexivity. }
  claim Hpredef: preimage_of I bounded_transform_psi (open_ray_upper R a) =
    {x0 :e I | apply_fun bounded_transform_psi x0 :e open_ray_upper R a}.
  { reflexivity. }
  apply set_ext.
  - let s. assume HsU: s :e U.
    prove s :e (open_ray_upper R c) :/\: I.
    claim HsU0: s :e preimage_of I bounded_transform_psi (open_ray_upper R a).
    { rewrite <- HUdef.
      exact HsU. }
    claim HsU1: s :e {x0 :e I | apply_fun bounded_transform_psi x0 :e open_ray_upper R a}.
    { rewrite <- Hpredef.
      exact HsU0. }
    claim HsI: s :e I.
    { exact (SepE1 I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_upper R a) s HsU1). }
    claim HsR: s :e R.
    { exact (HI_sub_R s HsI). }
    claim HpsiRay: apply_fun bounded_transform_psi s :e open_ray_upper R a.
    { exact (SepE2 I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_upper R a) s HsU1). }
    claim HpsiR: apply_fun bounded_transform_psi s :e R.
    { (** unfold bounded_transform_psi and use closure of R under div_SNo **)
      claim HabsR: abs_SNo s :e R.
      { exact (abs_SNo_in_R s HsR). }
      claim HminR: minus_SNo (abs_SNo s) :e R.
      { exact (real_minus_SNo (abs_SNo s) HabsR). }
      claim HdenR: add_SNo 1 (minus_SNo (abs_SNo s)) :e R.
      { exact (real_add_SNo 1 real_1 (minus_SNo (abs_SNo s)) HminR). }
      claim HpsiDef: bounded_transform_psi =
        graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
      { reflexivity. }
      rewrite HpsiDef.
      rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
      exact (real_div_SNo s HsR (add_SNo 1 (minus_SNo (abs_SNo s))) HdenR). }
    claim HrelA: order_rel R a (apply_fun bounded_transform_psi s).
    { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_psi s) HpsiRay). }
    claim HaltA: Rlt a (apply_fun bounded_transform_psi s).
    { exact (order_rel_R_implies_Rlt a (apply_fun bounded_transform_psi s) HrelA). }
    (** derive c < s by case analysis on a and s **)
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim HsS: SNo s.
    { exact (real_SNo s HsR). }
    claim HcS: SNo c.
    { exact (real_SNo c HcR). }
    apply (xm (Rlt a 0)).
    + assume Halt0: Rlt a 0.
      claim Halt0S: a < 0.
      { exact (RltE_lt a 0 Halt0). }
      apply (xm (0 <= s)).
      * assume H0les: 0 <= s.
        (** show c < 0 **)
        claim HdenApos: 0 < add_SNo 1 (abs_SNo a).
        { claim HabsR: abs_SNo a :e R.
          { exact (abs_SNo_in_R a HaR). }
          claim HabsS: SNo (abs_SNo a).
          { exact (real_SNo (abs_SNo a) HabsR). }
          claim H0le_abs: 0 <= abs_SNo a.
          { exact (abs_SNo_nonneg a HaS). }
          claim HdenPos0: add_SNo 0 0 < add_SNo 1 (abs_SNo a).
          { exact (add_SNo_Lt3a 0 0 1 (abs_SNo a) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
          rewrite <- (add_SNo_0L 0 SNo_0) at 1.
          exact HdenPos0. }
        claim HcLt0S: c < 0.
        { (** c = a / (1+abs(a)) with negative numerator and positive denom **)
          claim HabsR: abs_SNo a :e R.
          { exact (abs_SNo_in_R a HaR). }
          claim HabsS: SNo (abs_SNo a).
          { exact (real_SNo (abs_SNo a) HabsR). }
          claim HdenS: SNo (add_SNo 1 (abs_SNo a)).
          { exact (SNo_add_SNo 1 (abs_SNo a) SNo_1 HabsS). }
          claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
          { reflexivity. }
          claim HcEq: c = div_SNo a (add_SNo 1 (abs_SNo a)).
          { rewrite HphiDef.
            rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) a HaR).
            reflexivity. }
          rewrite HcEq.
          exact (div_SNo_neg_pos a (add_SNo 1 (abs_SNo a)) HaS HdenS Halt0S HdenApos). }
        claim HcLtS: c < s.
        { exact (SNoLtLe_tra c 0 s HcS SNo_0 HsS HcLt0S H0les). }
        claim HcLt: Rlt c s.
        { exact (RltI c s HcR HsR HcLtS). }
        claim HrelC: order_rel R c s.
        { exact (Rlt_implies_order_rel_R c s HcLt). }
        claim HsRayC: s :e open_ray_upper R c.
        { exact (SepI R (fun x0:set => order_rel R c x0) s HsR HrelC). }
        exact (binintersectI (open_ray_upper R c) I s HsRayC HsI).
      * assume Hn0les: ~(0 <= s).
        (** negative s-case: use algebra with abs(s) = -s and denom = 1+s **)
        claim HsLt0S: s < 0.
        { apply (SNoLt_trichotomy_or_impred s 0 HsS SNo_0 (s < 0)).
          - assume H: s < 0. exact H.
          - assume Hs0: s = 0.
            claim H0les: 0 <= s.
            { rewrite Hs0. exact (SNoLe_ref 0). }
            exact (FalseE (Hn0les H0les) (s < 0)).
          - assume H0lts: 0 < s.
            claim H0les: 0 <= s.
            { exact (SNoLtLe 0 s H0lts). }
            exact (FalseE (Hn0les H0les) (s < 0)). }
        claim HsLt0: Rlt s 0.
        { exact (RltI s 0 HsR real_0 HsLt0S). }
        (** show 0 < 1+s from -1 < s **)
        claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
        { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
        claim Hm1lts: Rlt (minus_SNo 1) s.
        { exact (andEL (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
        claim Hm1ltsS: minus_SNo 1 < s.
        { exact (RltE_lt (minus_SNo 1) s Hm1lts). }
        claim H0Lt1sS0: add_SNo 1 (minus_SNo 1) < add_SNo 1 s.
        { exact (add_SNo_Lt2 1 (minus_SNo 1) s SNo_1 (SNo_minus_SNo 1 SNo_1) HsS Hm1ltsS). }
        claim H0Lt1sS: 0 < add_SNo 1 s.
        { rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
          exact H0Lt1sS0. }
        (** derive c < s using the explicit formula on the negative side **)
        claim HabsEq: abs_SNo s = minus_SNo s.
        { exact (not_nonneg_abs_SNo s Hn0les). }
        claim HdenEq: add_SNo 1 (minus_SNo (abs_SNo s)) = add_SNo 1 s.
        { rewrite HabsEq.
          rewrite (minus_SNo_invol s HsS).
          reflexivity. }
        claim HpsiDef: bounded_transform_psi =
          graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
        { reflexivity. }
        claim HpsiEq0: apply_fun bounded_transform_psi s =
          div_SNo s (add_SNo 1 (minus_SNo (abs_SNo s))).
        { rewrite HpsiDef.
          rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
          reflexivity. }
        claim HpsiEq: apply_fun bounded_transform_psi s = div_SNo s (add_SNo 1 s).
        { rewrite HpsiEq0.
          rewrite HdenEq.
          reflexivity. }
        claim HaltAS: a < div_SNo s (add_SNo 1 s).
        { claim HaltS: a < apply_fun bounded_transform_psi s.
          { exact (RltE_lt a (apply_fun bounded_transform_psi s) HaltA). }
          rewrite <- HpsiEq at 1.
          exact HaltS. }
        claim HdenS: SNo (add_SNo 1 s).
        { exact (SNo_add_SNo 1 s SNo_1 HsS). }
        claim HmulLt: mul_SNo a (add_SNo 1 s) < s.
        { exact (div_SNo_pos_LtR' s (add_SNo 1 s) a HsS HdenS HaS H0Lt1sS HaltAS). }
        (** transform inequality to a < s mul (1-a) **)
        claim Ha1sEq: mul_SNo a (add_SNo 1 s) = add_SNo (mul_SNo a 1) (mul_SNo a s).
        { exact (mul_SNo_distrL a 1 s HaS SNo_1 HsS). }
        claim Ha1Eq: mul_SNo a 1 = a.
        { exact (mul_SNo_oneR a HaS). }
        claim HmulLt2: add_SNo a (mul_SNo a s) < s.
        { claim Ha1sEq2: mul_SNo a (add_SNo 1 s) = add_SNo a (mul_SNo a s).
          { rewrite Ha1sEq.
            rewrite Ha1Eq.
            reflexivity. }
          rewrite <- Ha1sEq2 at 1.
          exact HmulLt. }
        set kas := minus_SNo (mul_SNo a s).
        claim HkasS: SNo kas.
        { exact (SNo_minus_SNo (mul_SNo a s) (SNo_mul_SNo a s HaS HsS)). }
        claim HsumLt: add_SNo kas (add_SNo a (mul_SNo a s)) < add_SNo kas s.
        { exact (add_SNo_Lt2 kas (add_SNo a (mul_SNo a s)) s HkasS (SNo_add_SNo a (mul_SNo a s) HaS (SNo_mul_SNo a s HaS HsS)) HsS HmulLt2). }
        claim HlhsEq0: add_SNo kas (add_SNo a (mul_SNo a s)) = a.
        { rewrite (add_SNo_assoc kas a (mul_SNo a s) HkasS HaS (SNo_mul_SNo a s HaS HsS)).
          rewrite (add_SNo_com kas a HkasS HaS) at 1.
          rewrite <- (add_SNo_assoc a kas (mul_SNo a s) HaS HkasS (SNo_mul_SNo a s HaS HsS)) at 1.
          rewrite (add_SNo_minus_SNo_linv (mul_SNo a s) (SNo_mul_SNo a s HaS HsS)) at 1.
          rewrite (add_SNo_0R a HaS).
          reflexivity. }
        claim HrhsEq0: add_SNo kas s = add_SNo s (minus_SNo (mul_SNo a s)).
        { rewrite (add_SNo_com kas s HkasS HsS).
          reflexivity. }
        claim HaLt: a < add_SNo s (minus_SNo (mul_SNo a s)).
        { rewrite <- HlhsEq0 at 1.
          rewrite <- HrhsEq0 at 1.
          exact HsumLt. }
        (** relate c = a/(1-a) and conclude c < s **)
        claim Hn0lea: ~(0 <= a).
        { assume H0lea: 0 <= a.
          claim Hcases: 0 < a \/ 0 = a.
          { exact (SNoLeE 0 a SNo_0 HaS H0lea). }
          apply Hcases.
          - assume H0lta: 0 < a.
            claim H00: 0 < 0.
            { exact (SNoLt_tra 0 a 0 SNo_0 HaS SNo_0 H0lta Halt0S). }
            exact (FalseE ((SNoLt_irref 0) H00) False).
          - assume H0eq: 0 = a.
            claim Ha0: a = 0.
            { rewrite <- H0eq.
              reflexivity. }
            claim H00: 0 < 0.
            { rewrite <- Ha0 at 1.
              exact Halt0S. }
            exact (FalseE ((SNoLt_irref 0) H00) False). }
        claim HabsAeq: abs_SNo a = minus_SNo a.
        { exact (not_nonneg_abs_SNo a Hn0lea). }
        claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
        { reflexivity. }
        claim HcEq0: c = div_SNo a (add_SNo 1 (abs_SNo a)).
        { rewrite HphiDef.
          rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) a HaR).
          reflexivity. }
        claim HcEq: c = div_SNo a (add_SNo 1 (minus_SNo a)).
        { rewrite HcEq0.
          rewrite HabsAeq.
          reflexivity. }
        claim HdenApos: 0 < add_SNo 1 (minus_SNo a).
        { claim HmaS: SNo (minus_SNo a).
          { exact (SNo_minus_SNo a HaS). }
          claim H0ltma: 0 < minus_SNo a.
          { claim H0ltma0: minus_SNo 0 < minus_SNo a.
            { exact (minus_SNo_Lt_contra a 0 HaS SNo_0 Halt0S). }
            rewrite <- (minus_SNo_0) at 1.
            exact H0ltma0. }
          claim H0lema: 0 <= minus_SNo a.
          { exact (SNoLtLe 0 (minus_SNo a) H0ltma). }
          claim HdenPos0: add_SNo 0 0 < add_SNo 1 (minus_SNo a).
          { exact (add_SNo_Lt3a 0 0 1 (minus_SNo a) SNo_0 SNo_0 SNo_1 HmaS SNoLt_0_1 H0lema). }
          rewrite <- (add_SNo_0L 0 SNo_0) at 1.
          exact HdenPos0. }
        claim HdenAS: SNo (add_SNo 1 (minus_SNo a)).
        { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 (SNo_minus_SNo a HaS)). }
        claim HmulSA: mul_SNo s (add_SNo 1 (minus_SNo a)) = add_SNo s (minus_SNo (mul_SNo a s)).
        { rewrite (mul_SNo_com s (add_SNo 1 (minus_SNo a)) HsS HdenAS) at 1.
          rewrite (mul_SNo_distrR 1 (minus_SNo a) s SNo_1 (SNo_minus_SNo a HaS) HsS).
          rewrite (mul_SNo_oneL s HsS) at 1.
          rewrite (mul_SNo_com (minus_SNo a) s (SNo_minus_SNo a HaS) HsS) at 1.
          rewrite (mul_SNo_minus_distrR s a HsS HaS) at 1.
          rewrite (mul_SNo_com s a HsS HaS) at 1.
          reflexivity. }
        claim HaLt2: a < mul_SNo s (add_SNo 1 (minus_SNo a)).
        { rewrite HmulSA at 1.
          exact HaLt. }
        claim HcLtS: div_SNo a (add_SNo 1 (minus_SNo a)) < s.
        { exact (div_SNo_pos_LtL a (add_SNo 1 (minus_SNo a)) s HaS HdenAS HsS HdenApos HaLt2). }
        claim HcLtS': c < s.
        { rewrite HcEq.
          exact HcLtS. }
        claim HcLt: Rlt c s.
        { exact (RltI c s HcR HsR HcLtS'). }
        claim HrelC: order_rel R c s.
        { exact (Rlt_implies_order_rel_R c s HcLt). }
        claim HsRayC: s :e open_ray_upper R c.
        { exact (SepI R (fun x0:set => order_rel R c x0) s HsR HrelC). }
        exact (binintersectI (open_ray_upper R c) I s HsRayC HsI).
	    + assume Hnlt0: ~(Rlt a 0).
	      (** nonnegative a: show s > 0 then solve inequality with abs(s)=s **)
	      claim HaNonneg: 0 <= a.
	      { apply (SNoLt_trichotomy_or_impred a 0 HaS SNo_0 (0 <= a)).
	        - assume Halt0S': a < 0.
	          apply FalseE.
	          claim Halt0': Rlt a 0.
	          { exact (RltI a 0 HaR real_0 Halt0S'). }
	          exact (Hnlt0 Halt0').
	        - assume Ha0: a = 0.
	          rewrite Ha0.
	          exact (SNoLe_ref 0).
	        - assume H0lta: 0 < a.
	          exact (SNoLtLe 0 a H0lta). }
	      claim HpsiS: SNo (apply_fun bounded_transform_psi s).
	      { exact (real_SNo (apply_fun bounded_transform_psi s) HpsiR). }
	      claim HaltAS: a < apply_fun bounded_transform_psi s.
	      { exact (RltE_lt a (apply_fun bounded_transform_psi s) HaltA). }
	      claim H0ltPsi: 0 < apply_fun bounded_transform_psi s.
	      { exact (SNoLeLt_tra 0 a (apply_fun bounded_transform_psi s) SNo_0 HaS HpsiS HaNonneg HaltAS). }
	      (** denominator is positive on I: 0 < 1 - abs(s) **)
	      claim HabsR: abs_SNo s :e R.
	      { exact (abs_SNo_in_R s HsR). }
	      claim HabsS: SNo (abs_SNo s).
	      { exact (real_SNo (abs_SNo s) HabsR). }
	      claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
	      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
	      claim Hslt1: Rlt s 1.
	      { exact (andER (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
	      claim Hslt1S: s < 1.
	      { exact (RltE_lt s 1 Hslt1). }
	      claim HabLt1: abs_SNo s < 1.
	      { apply (xm (0 <= s)).
	        - assume H0les: 0 <= s.
	          rewrite (nonneg_abs_SNo s H0les).
	          exact Hslt1S.
	        - assume Hn0les: ~(0 <= s).
	          claim Hslt0: s < 0.
	          { apply (SNoLt_trichotomy_or_impred s 0 HsS SNo_0 (s < 0)).
	            - assume H: s < 0. exact H.
	            - assume Hs0: s = 0.
	              claim H0les: 0 <= s.
	              { rewrite Hs0. exact (SNoLe_ref 0). }
	              exact (FalseE (Hn0les H0les) (s < 0)).
	            - assume H0lts: 0 < s.
	              claim H0les: 0 <= s.
	              { exact (SNoLtLe 0 s H0lts). }
	              exact (FalseE (Hn0les H0les) (s < 0)). }
	          rewrite (not_nonneg_abs_SNo s Hn0les).
	          claim Hm1lts: Rlt (minus_SNo 1) s.
	          { exact (andEL (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
	          claim Hm1ltsS: minus_SNo 1 < s.
	          { exact (RltE_lt (minus_SNo 1) s Hm1lts). }
	          claim HmsLt1: minus_SNo s < 1.
	          { claim HmsLt1': minus_SNo s < minus_SNo (minus_SNo 1).
	            { exact (minus_SNo_Lt_contra (minus_SNo 1) s (SNo_minus_SNo 1 SNo_1) HsS Hm1ltsS). }
	            rewrite <- (minus_SNo_invol 1 SNo_1) at 1.
	            exact HmsLt1'. }
	          exact HmsLt1. }
	      set den := add_SNo 1 (minus_SNo (abs_SNo s)).
	      claim HdenS: SNo den.
	      { exact (SNo_add_SNo 1 (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo (abs_SNo s) HabsS)). }
	      claim HdenPos0: add_SNo 1 (minus_SNo 1) < den.
	      { claim Hneg1LtNegAbs: minus_SNo 1 < minus_SNo (abs_SNo s).
	        { exact (minus_SNo_Lt_contra (abs_SNo s) 1 HabsS SNo_1 HabLt1). }
	        exact (add_SNo_Lt2 1 (minus_SNo 1) (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo 1 SNo_1)
	               (SNo_minus_SNo (abs_SNo s) HabsS) Hneg1LtNegAbs). }
	      claim HdenPos: 0 < den.
	      { rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
	        exact HdenPos0. }
	      (** rewrite psi(s) as s/den and infer 0 < s **)
	      claim HpsiEq0: apply_fun bounded_transform_psi s = div_SNo s den.
	      { claim HpsiDef: bounded_transform_psi =
	          graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
	        { reflexivity. }
	        rewrite HpsiDef.
	        rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
	        reflexivity. }
	      claim H0ltDiv: 0 < div_SNo s den.
	      { rewrite <- HpsiEq0 at 1.
	        exact H0ltPsi. }
	      claim H0LtS_raw: mul_SNo 0 den < s.
	      { exact (div_SNo_pos_LtR' s den 0 HsS HdenS SNo_0 HdenPos H0ltDiv). }
	      claim H0LtS: 0 < s.
	      { rewrite <- (mul_SNo_zeroL den HdenS) at 1.
	        exact H0LtS_raw. }
	      claim H0les: 0 <= s.
	      { exact (SNoLtLe 0 s H0LtS). }
	      (** now abs(s)=s and den = 1-s; solve for c < s **)
	      claim HabsEq: abs_SNo s = s.
	      { exact (nonneg_abs_SNo s H0les). }
	      claim HdenEq: den = add_SNo 1 (minus_SNo s).
	      { rewrite HabsEq.
	        reflexivity. }
	      claim HpsiEq: apply_fun bounded_transform_psi s = div_SNo s (add_SNo 1 (minus_SNo s)).
	      { rewrite HpsiEq0.
	        rewrite HdenEq.
	        reflexivity. }
	      claim HaltAS2: a < div_SNo s (add_SNo 1 (minus_SNo s)).
	      { rewrite <- HpsiEq at 1.
	        exact HaltAS. }
	      claim Hden2S: SNo (add_SNo 1 (minus_SNo s)).
	      { exact (SNo_add_SNo 1 (minus_SNo s) SNo_1 (SNo_minus_SNo s HsS)). }
	      (** show 0 < 1-s from s<1 **)
	      claim Hden2Pos0: add_SNo (minus_SNo s) s < add_SNo (minus_SNo s) 1.
	      { exact (add_SNo_Lt2 (minus_SNo s) s 1 (SNo_minus_SNo s HsS) HsS SNo_1 Hslt1S). }
		      claim Hden2Pos: 0 < add_SNo 1 (minus_SNo s).
		      { claim Htmp: 0 < add_SNo (minus_SNo s) 1.
		        { rewrite <- (add_SNo_minus_SNo_linv s HsS) at 1.
		          exact Hden2Pos0. }
			        rewrite <- (add_SNo_com (minus_SNo s) 1 (SNo_minus_SNo s HsS) SNo_1) at 1.
			        exact Htmp. }
	      claim HmulLt: mul_SNo a (add_SNo 1 (minus_SNo s)) < s.
	      { exact (div_SNo_pos_LtR' s (add_SNo 1 (minus_SNo s)) a HsS Hden2S HaS Hden2Pos HaltAS2). }
	      (** turn into a < s mul (1+a) **)
	      claim HmulEq: mul_SNo a (add_SNo 1 (minus_SNo s)) = add_SNo a (minus_SNo (mul_SNo a s)).
	      { rewrite (mul_SNo_distrL a 1 (minus_SNo s) HaS SNo_1 (SNo_minus_SNo s HsS)).
	        rewrite (mul_SNo_oneR a HaS) at 1.
	        rewrite (mul_SNo_minus_distrR a s HaS HsS) at 1.
	        reflexivity. }
		      claim HmulLt2: add_SNo a (minus_SNo (mul_SNo a s)) < s.
		      { rewrite <- HmulEq at 1.
		        exact HmulLt. }
	      set kas := mul_SNo a s.
	      claim HkasS: SNo kas.
	      { exact (SNo_mul_SNo a s HaS HsS). }
	      claim HsumLt: add_SNo kas (add_SNo a (minus_SNo kas)) < add_SNo kas s.
	      { exact (add_SNo_Lt2 kas (add_SNo a (minus_SNo kas)) s HkasS (SNo_add_SNo a (minus_SNo kas) HaS (SNo_minus_SNo kas HkasS)) HsS HmulLt2). }
	      claim HlhsEq0: add_SNo kas (add_SNo a (minus_SNo kas)) = a.
	      { rewrite (add_SNo_assoc kas a (minus_SNo kas) HkasS HaS (SNo_minus_SNo kas HkasS)).
	        rewrite (add_SNo_com kas a HkasS HaS) at 1.
	        rewrite <- (add_SNo_assoc a kas (minus_SNo kas) HaS HkasS (SNo_minus_SNo kas HkasS)) at 1.
		        rewrite (add_SNo_minus_SNo_rinv kas HkasS) at 1.
	        rewrite (add_SNo_0R a HaS).
	        reflexivity. }
	      claim HrhsEq0: add_SNo kas s = add_SNo s kas.
	      { rewrite (add_SNo_com kas s HkasS HsS).
	        reflexivity. }
		      claim HaLt: a < add_SNo s (mul_SNo a s).
		      { rewrite <- HlhsEq0 at 1.
		        rewrite <- HrhsEq0 at 1.
		        exact HsumLt. }
	      claim HdenApos: 0 < add_SNo 1 a.
	      { claim H0leA: 0 <= a.
	        { exact HaNonneg. }
	        claim HdenPos0: add_SNo 0 0 < add_SNo 1 a.
	        { exact (add_SNo_Lt3a 0 0 1 a SNo_0 SNo_0 SNo_1 HaS SNoLt_0_1 H0leA). }
	        rewrite <- (add_SNo_0L 0 SNo_0) at 1.
	        exact HdenPos0. }
	      claim HdenAS: SNo (add_SNo 1 a).
	      { exact (SNo_add_SNo 1 a SNo_1 HaS). }
	      claim HcEq0: c = div_SNo a (add_SNo 1 (abs_SNo a)).
	      { claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
	        { reflexivity. }
	        rewrite HphiDef.
	        rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) a HaR).
	        reflexivity. }
	      claim HcEq: c = div_SNo a (add_SNo 1 a).
	      { rewrite HcEq0.
	        rewrite (nonneg_abs_SNo a HaNonneg).
	        reflexivity. }
		      claim HcLtS: div_SNo a (add_SNo 1 a) < s.
		      { claim HmulSA: mul_SNo s (add_SNo 1 a) = add_SNo s (mul_SNo a s).
		        { rewrite (mul_SNo_distrL s 1 a HsS SNo_1 HaS).
		          rewrite (mul_SNo_oneR s HsS) at 1.
		          rewrite (mul_SNo_com s a HsS HaS) at 1.
		          reflexivity. }
		        claim HaLt2: a < mul_SNo s (add_SNo 1 a).
		        { rewrite HmulSA at 1.
		          exact HaLt. }
		        exact (div_SNo_pos_LtL a (add_SNo 1 a) s HaS HdenAS HsS HdenApos HaLt2). }
	      claim HcLtS': c < s.
	      { rewrite HcEq.
	        exact HcLtS. }
	      claim HcLt: Rlt c s.
	      { exact (RltI c s HcR HsR HcLtS'). }
	      claim HrelC: order_rel R c s.
	      { exact (Rlt_implies_order_rel_R c s HcLt). }
	      claim HsRayC: s :e open_ray_upper R c.
	      { exact (SepI R (fun x0:set => order_rel R c x0) s HsR HrelC). }
	      exact (binintersectI (open_ray_upper R c) I s HsRayC HsI).
  - let s. assume HsInt: s :e (open_ray_upper R c) :/\: I.
    prove s :e U.
    claim HsRayC: s :e open_ray_upper R c.
    { exact (binintersectE1 (open_ray_upper R c) I s HsInt). }
    claim HsI: s :e I.
    { exact (binintersectE2 (open_ray_upper R c) I s HsInt). }
	    rewrite HUdef.
	    rewrite Hpredef.
	    apply (SepI I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_upper R a) s HsI).
	    (** TODO: show apply_fun bounded_transform_psi s :e open_ray_upper R a from c < s **)
	    claim HsR: s :e R.
	    { exact (HI_sub_R s HsI). }
	    claim HpsiR: apply_fun bounded_transform_psi s :e R.
	    { claim HabsR: abs_SNo s :e R.
	      { exact (abs_SNo_in_R s HsR). }
	      claim HminR: minus_SNo (abs_SNo s) :e R.
	      { exact (real_minus_SNo (abs_SNo s) HabsR). }
	      claim HdenR: add_SNo 1 (minus_SNo (abs_SNo s)) :e R.
	      { exact (real_add_SNo 1 real_1 (minus_SNo (abs_SNo s)) HminR). }
	      claim HpsiDef: bounded_transform_psi =
	        graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
	      { reflexivity. }
	      rewrite HpsiDef.
	      rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
	      exact (real_div_SNo s HsR (add_SNo 1 (minus_SNo (abs_SNo s))) HdenR). }
	    claim HaS: SNo a.
	    { exact (real_SNo a HaR). }
	    claim HsS: SNo s.
	    { exact (real_SNo s HsR). }
	    claim HcS: SNo c.
	    { exact (real_SNo c HcR). }
	    claim HrelC: order_rel R c s.
	    { exact (SepE2 R (fun x0:set => order_rel R c x0) s HsRayC). }
	    claim HcLt: Rlt c s.
	    { exact (order_rel_R_implies_Rlt c s HrelC). }
	    claim HcLtS: c < s.
	    { exact (RltE_lt c s HcLt). }
	    (** split on the sign of a **)
	    apply (xm (Rlt a 0)).
	    - assume Halt0: Rlt a 0.
	      claim Halt0S: a < 0.
	      { exact (RltE_lt a 0 Halt0). }
	      apply (xm (0 <= s)).
	      + assume H0les: 0 <= s.
	        (** psi(s) is nonnegative and hence > a **)
	        set den := add_SNo 1 (minus_SNo (abs_SNo s)).
	        claim HabsR: abs_SNo s :e R.
	        { exact (abs_SNo_in_R s HsR). }
	        claim HabsS: SNo (abs_SNo s).
	        { exact (real_SNo (abs_SNo s) HabsR). }
	        claim HdenS: SNo den.
	        { exact (SNo_add_SNo 1 (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo (abs_SNo s) HabsS)). }
	        claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
	        { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
	        claim Hslt1: Rlt s 1.
	        { exact (andER (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
	        claim Hslt1S: s < 1.
	        { exact (RltE_lt s 1 Hslt1). }
	        claim HabLt1: abs_SNo s < 1.
	        { rewrite (nonneg_abs_SNo s H0les).
	          exact Hslt1S. }
	        claim Hneg1LtNegAbs: minus_SNo 1 < minus_SNo (abs_SNo s).
	        { exact (minus_SNo_Lt_contra (abs_SNo s) 1 HabsS SNo_1 HabLt1). }
	        claim HdenPos0: add_SNo 1 (minus_SNo 1) < den.
	        { exact (add_SNo_Lt2 1 (minus_SNo 1) (minus_SNo (abs_SNo s)) SNo_1 (SNo_minus_SNo 1 SNo_1)
	               (SNo_minus_SNo (abs_SNo s) HabsS) Hneg1LtNegAbs). }
	        claim HdenPos: 0 < den.
	        { rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
	          exact HdenPos0. }
	        claim HpsiEq: apply_fun bounded_transform_psi s = div_SNo s den.
	        { claim HpsiDef: bounded_transform_psi =
	            graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
	          { reflexivity. }
	          rewrite HpsiDef.
	          rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
	          reflexivity. }
	        claim HpsiS: SNo (apply_fun bounded_transform_psi s).
	        { exact (real_SNo (apply_fun bounded_transform_psi s) HpsiR). }
	        claim H0lePsi: 0 <= apply_fun bounded_transform_psi s.
	        { rewrite HpsiEq.
	          exact (div_SNo_nonneg_pos_nonneg s den HsS HdenS H0les HdenPos). }
	        claim HaltPsiS: a < apply_fun bounded_transform_psi s.
	        { exact (SNoLtLe_tra a 0 (apply_fun bounded_transform_psi s) HaS SNo_0 HpsiS Halt0S H0lePsi). }
	        claim HaltPsi: Rlt a (apply_fun bounded_transform_psi s).
	        { exact (RltI a (apply_fun bounded_transform_psi s) HaR HpsiR HaltPsiS). }
	        claim HrelA: order_rel R a (apply_fun bounded_transform_psi s).
	        { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_psi s) HaltPsi). }
	        exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_psi s) HpsiR HrelA).
	      + assume Hn0les: ~(0 <= s).
	        (** both a and s are negative; use explicit inequality with c < s **)
	        set denA := add_SNo 1 (minus_SNo a).
	        claim Hn0lea: ~(0 <= a).
	        { assume H0lea: 0 <= a.
	          claim Hcases: 0 < a \/ 0 = a.
	          { exact (SNoLeE 0 a SNo_0 HaS H0lea). }
	          apply Hcases.
	          - assume H0lta: 0 < a.
	            claim H00: 0 < 0.
	            { exact (SNoLt_tra 0 a 0 SNo_0 HaS SNo_0 H0lta Halt0S). }
	            exact (FalseE ((SNoLt_irref 0) H00) False).
	          - assume H0eq: 0 = a.
	            claim Ha0: a = 0.
	            { rewrite <- H0eq. reflexivity. }
	            claim H00: 0 < 0.
	            { rewrite <- Ha0 at 1.
	              exact Halt0S. }
	            exact (FalseE ((SNoLt_irref 0) H00) False). }
	        claim HabsAeq: abs_SNo a = minus_SNo a.
	        { exact (not_nonneg_abs_SNo a Hn0lea). }
	        claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
	        { reflexivity. }
	        claim HcEq0: c = div_SNo a (add_SNo 1 (abs_SNo a)).
	        { rewrite HphiDef.
	          rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) a HaR).
	          reflexivity. }
	        claim HcEq: c = div_SNo a denA.
	        { rewrite HcEq0.
	          rewrite HabsAeq.
	          reflexivity. }
	        claim HdenAS: SNo denA.
	        { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 (SNo_minus_SNo a HaS)). }
	        claim HmaS: SNo (minus_SNo a).
	        { exact (SNo_minus_SNo a HaS). }
	        claim H0ltma: 0 < minus_SNo a.
	        { claim H0ltma0: minus_SNo 0 < minus_SNo a.
	          { exact (minus_SNo_Lt_contra a 0 HaS SNo_0 Halt0S). }
	          rewrite <- (minus_SNo_0) at 1.
	          exact H0ltma0. }
	        claim H0lema: 0 <= minus_SNo a.
	        { exact (SNoLtLe 0 (minus_SNo a) H0ltma). }
	        claim HdenApos0: add_SNo 0 0 < denA.
	        { exact (add_SNo_Lt3a 0 0 1 (minus_SNo a) SNo_0 SNo_0 SNo_1 HmaS SNoLt_0_1 H0lema). }
	        claim HdenApos: 0 < denA.
	        { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
	          exact HdenApos0. }
		        claim HcLtS2: div_SNo a denA < s.
		        { rewrite <- HcEq at 1.
		          exact HcLtS. }
		        claim HaLt2: a < mul_SNo s denA.
		        { exact (div_SNo_pos_LtL' a denA s HaS HdenAS HsS HdenApos HcLtS2). }
		        (** turn into a < psi(s) using the negative-side algebra **)
		        set denS := add_SNo 1 s.
		        claim HdenSS: SNo denS.
		        { exact (SNo_add_SNo 1 s SNo_1 HsS). }
		        claim HpsiEq0: apply_fun bounded_transform_psi s =
		          div_SNo s (add_SNo 1 (minus_SNo (abs_SNo s))).
		        { claim HpsiDef: bounded_transform_psi =
		            graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
		          { reflexivity. }
		          rewrite HpsiDef.
		          rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
		          reflexivity. }
		        claim HabsEq: abs_SNo s = minus_SNo s.
		        { exact (not_nonneg_abs_SNo s Hn0les). }
		        claim HdenEq: add_SNo 1 (minus_SNo (abs_SNo s)) = denS.
		        { rewrite HabsEq.
		          rewrite (minus_SNo_invol s HsS).
		          reflexivity. }
		        claim HpsiEq: apply_fun bounded_transform_psi s = div_SNo s denS.
		        { rewrite HpsiEq0.
		          rewrite HdenEq.
		          reflexivity. }
		        set asb := mul_SNo a s.
		        claim HasbS: SNo asb.
		        { exact (SNo_mul_SNo a s HaS HsS). }
		        claim HmulSA: mul_SNo s denA = add_SNo s (minus_SNo asb).
		        { rewrite (mul_SNo_distrL s 1 (minus_SNo a) HsS SNo_1 (SNo_minus_SNo a HaS)).
		          rewrite (mul_SNo_oneR s HsS) at 1.
		          rewrite (mul_SNo_minus_distrR s a HsS HaS) at 1.
		          rewrite (mul_SNo_com s a HsS HaS) at 1.
		          reflexivity. }
		        claim HaLt3: a < add_SNo s (minus_SNo asb).
		        { rewrite <- HmulSA at 1.
		          exact HaLt2. }
		        claim Hshift: add_SNo asb a < add_SNo asb (add_SNo s (minus_SNo asb)).
		        { exact (add_SNo_Lt2 asb a (add_SNo s (minus_SNo asb)) HasbS HaS
		                 (SNo_add_SNo s (minus_SNo asb) HsS (SNo_minus_SNo asb HasbS)) HaLt3). }
		        claim HlhsEq: add_SNo asb a = add_SNo a asb.
		        { exact (add_SNo_com asb a HasbS HaS). }
		        claim HrhsEq0: add_SNo asb (add_SNo s (minus_SNo asb)) = add_SNo (add_SNo asb s) (minus_SNo asb).
		        { exact (add_SNo_assoc asb s (minus_SNo asb) HasbS HsS (SNo_minus_SNo asb HasbS)). }
		        claim HrhsEq1: add_SNo (add_SNo asb s) (minus_SNo asb) = add_SNo (add_SNo s asb) (minus_SNo asb).
		        { rewrite (add_SNo_com asb s HasbS HsS) at 1.
		          reflexivity. }
		        claim HrhsEq2: add_SNo (add_SNo s asb) (minus_SNo asb) = add_SNo s (add_SNo asb (minus_SNo asb)).
		        { rewrite <- (add_SNo_assoc s asb (minus_SNo asb) HsS HasbS (SNo_minus_SNo asb HasbS)).
		          reflexivity. }
		        claim HrhsEq3: add_SNo asb (minus_SNo asb) = 0.
		        { exact (add_SNo_minus_SNo_rinv asb HasbS). }
		        claim HrhsEq: add_SNo asb (add_SNo s (minus_SNo asb)) = s.
		        { rewrite HrhsEq0.
		          rewrite HrhsEq1.
		          rewrite HrhsEq2.
		          rewrite HrhsEq3.
		          rewrite (add_SNo_0R s HsS).
		          reflexivity. }
		        claim HmulLt: mul_SNo a denS < s.
		        { claim HmulDen: mul_SNo a denS = add_SNo a asb.
		          { rewrite (mul_SNo_distrL a 1 s HaS SNo_1 HsS).
		            rewrite (mul_SNo_oneR a HaS) at 1.
		            reflexivity. }
		          rewrite HmulDen.
		          rewrite <- HlhsEq at 1.
		          rewrite <- HrhsEq at 2.
		          exact Hshift. }
		        claim HdenSpos0: add_SNo 1 (minus_SNo 1) < denS.
		        { claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
		          { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
		          claim Hm1lts: Rlt (minus_SNo 1) s.
		          { exact (andEL (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
		          claim Hm1ltsS: minus_SNo 1 < s.
		          { exact (RltE_lt (minus_SNo 1) s Hm1lts). }
		          exact (add_SNo_Lt2 1 (minus_SNo 1) s SNo_1 (SNo_minus_SNo 1 SNo_1) HsS Hm1ltsS). }
		        claim HdenSpos: 0 < denS.
		        { rewrite <- (add_SNo_minus_SNo_rinv 1 SNo_1) at 1.
		          exact HdenSpos0. }
		        claim HaltPsiS: a < div_SNo s denS.
		        { exact (div_SNo_pos_LtR s denS a HsS HdenSS HaS HdenSpos HmulLt). }
		        claim HaltPsi: Rlt a (apply_fun bounded_transform_psi s).
		        { claim HdenSR: denS :e R.
		          { exact (real_add_SNo 1 real_1 s HsR). }
		          rewrite HpsiEq.
		          exact (RltI a (div_SNo s denS) HaR (real_div_SNo s HsR denS HdenSR) HaltPsiS). }
		        claim HrelA: order_rel R a (apply_fun bounded_transform_psi s).
		        { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_psi s) HaltPsi). }
		        exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_psi s) HpsiR HrelA).
		    - assume Hnlt0a: ~(Rlt a 0).
		      (** a is nonnegative **)
		      claim HaNonneg: 0 <= a.
		      { apply (SNoLt_trichotomy_or_impred a 0 HaS SNo_0 (0 <= a)).
	        - assume Halt0S': a < 0.
	          apply FalseE.
	          claim Halt0': Rlt a 0.
	          { exact (RltI a 0 HaR real_0 Halt0S'). }
	          exact (Hnlt0a Halt0').
	        - assume Ha0: a = 0.
	          rewrite Ha0.
	          exact (SNoLe_ref 0).
	        - assume H0lta: 0 < a.
	          exact (SNoLtLe 0 a H0lta). }
	      set denA := add_SNo 1 a.
	      claim HdenAS: SNo denA.
	      { exact (SNo_add_SNo 1 a SNo_1 HaS). }
	      claim HdenApos0: add_SNo 0 0 < denA.
	      { exact (add_SNo_Lt3a 0 0 1 a SNo_0 SNo_0 SNo_1 HaS SNoLt_0_1 HaNonneg). }
	      claim HdenApos: 0 < denA.
	      { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
	        exact HdenApos0. }
	      claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
	      { reflexivity. }
	      claim HcEq0: c = div_SNo a (add_SNo 1 (abs_SNo a)).
	      { rewrite HphiDef.
	        rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) a HaR).
	        reflexivity. }
	      claim HcEq: c = div_SNo a denA.
	      { rewrite HcEq0.
	        rewrite (nonneg_abs_SNo a HaNonneg).
	        reflexivity. }
		      claim HcLtS2: div_SNo a denA < s.
		      { rewrite <- HcEq at 1.
		        exact HcLtS. }
		      claim HaLt2: a < mul_SNo s denA.
		      { exact (div_SNo_pos_LtL' a denA s HaS HdenAS HsS HdenApos HcLtS2). }
		      (** finish by converting to a < psi(s) using the positive-side algebra **)
		      claim HcNonneg: 0 <= c.
		      { rewrite HcEq.
		        exact (div_SNo_nonneg_pos_nonneg a denA HaS HdenAS HaNonneg HdenApos). }
		      claim H0ltS: 0 < s.
		      { exact (SNoLeLt_tra 0 c s SNo_0 HcS HsS HcNonneg HcLtS). }
		      claim H0les: 0 <= s.
		      { exact (SNoLtLe 0 s H0ltS). }
		      claim HabsEq: abs_SNo s = s.
		      { exact (nonneg_abs_SNo s H0les). }
		      set denS := add_SNo 1 (minus_SNo s).
		      claim HdenSS: SNo denS.
		      { exact (SNo_add_SNo 1 (minus_SNo s) SNo_1 (SNo_minus_SNo s HsS)). }
		      claim Hbds: Rlt (minus_SNo 1) s /\ Rlt s 1.
		      { exact (SepE2 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) s HsI). }
		      claim Hslt1: Rlt s 1.
		      { exact (andER (Rlt (minus_SNo 1) s) (Rlt s 1) Hbds). }
		      claim Hslt1S: s < 1.
		      { exact (RltE_lt s 1 Hslt1). }
		      claim HdenSpos0: add_SNo (minus_SNo s) s < add_SNo (minus_SNo s) 1.
		      { exact (add_SNo_Lt2 (minus_SNo s) s 1 (SNo_minus_SNo s HsS) HsS SNo_1 Hslt1S). }
		      claim HdenSpos: 0 < denS.
		      { claim Htmp: 0 < add_SNo (minus_SNo s) 1.
		        { rewrite <- (add_SNo_minus_SNo_linv s HsS) at 1.
		          exact HdenSpos0. }
		        rewrite <- (add_SNo_com (minus_SNo s) 1 (SNo_minus_SNo s HsS) SNo_1) at 1.
		        exact Htmp. }
		      claim HpsiEq0: apply_fun bounded_transform_psi s =
		        div_SNo s (add_SNo 1 (minus_SNo (abs_SNo s))).
		      { claim HpsiDef: bounded_transform_psi =
		          graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
		        { reflexivity. }
		        rewrite HpsiDef.
		        rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
		        reflexivity. }
		      claim HpsiEq: apply_fun bounded_transform_psi s = div_SNo s denS.
		      { rewrite HpsiEq0.
		        rewrite HabsEq.
		        reflexivity. }
		      set asb := mul_SNo a s.
		      claim HasbS: SNo asb.
		      { exact (SNo_mul_SNo a s HaS HsS). }
		      claim HmulSA: mul_SNo s denA = add_SNo s asb.
		      { rewrite (mul_SNo_distrL s 1 a HsS SNo_1 HaS).
		        rewrite (mul_SNo_oneR s HsS) at 1.
		        rewrite (mul_SNo_com s a HsS HaS) at 1.
		        reflexivity. }
		      claim HaLt3: a < add_SNo s asb.
		      { rewrite <- HmulSA at 1.
		        exact HaLt2. }
		      claim Hshift: add_SNo (minus_SNo asb) a < add_SNo (minus_SNo asb) (add_SNo s asb).
		      { exact (add_SNo_Lt2 (minus_SNo asb) a (add_SNo s asb) (SNo_minus_SNo asb HasbS) HaS (SNo_add_SNo s asb HsS HasbS) HaLt3). }
		      claim HlhsEq: add_SNo (minus_SNo asb) a = add_SNo a (minus_SNo asb).
		      { exact (add_SNo_com (minus_SNo asb) a (SNo_minus_SNo asb HasbS) HaS). }
		      claim HrhsEq0: add_SNo (minus_SNo asb) (add_SNo s asb) = add_SNo (add_SNo (minus_SNo asb) s) asb.
		      { exact (add_SNo_assoc (minus_SNo asb) s asb (SNo_minus_SNo asb HasbS) HsS HasbS). }
		      claim HrhsEq1: add_SNo (add_SNo (minus_SNo asb) s) asb = add_SNo (add_SNo s (minus_SNo asb)) asb.
		      { rewrite (add_SNo_com (minus_SNo asb) s (SNo_minus_SNo asb HasbS) HsS) at 1.
		        reflexivity. }
		      claim HrhsEq2: add_SNo (add_SNo s (minus_SNo asb)) asb = add_SNo s (add_SNo (minus_SNo asb) asb).
		      { rewrite <- (add_SNo_assoc s (minus_SNo asb) asb HsS (SNo_minus_SNo asb HasbS) HasbS).
		        reflexivity. }
		      claim HrhsEq3: add_SNo (minus_SNo asb) asb = 0.
		      { exact (add_SNo_minus_SNo_linv asb HasbS). }
		      claim HrhsEq: add_SNo (minus_SNo asb) (add_SNo s asb) = s.
		      { rewrite HrhsEq0.
		        rewrite HrhsEq1.
		        rewrite HrhsEq2.
		        rewrite HrhsEq3.
		        rewrite (add_SNo_0R s HsS).
		        reflexivity. }
		      claim HmulLt: mul_SNo a denS < s.
		      { (** a mul (1 - s) equals a plus minus (a mul s); use Hshift **)
		        claim HmulDen: mul_SNo a denS = add_SNo a (minus_SNo asb).
		        { rewrite (mul_SNo_distrL a 1 (minus_SNo s) HaS SNo_1 (SNo_minus_SNo s HsS)).
		          rewrite (mul_SNo_oneR a HaS) at 1.
		          rewrite (mul_SNo_minus_distrR a s HaS HsS) at 1.
		          reflexivity. }
		        rewrite HmulDen.
		        rewrite <- HlhsEq at 1.
		        rewrite <- HrhsEq at 2.
		        exact Hshift. }
		      claim HaltPsiS: a < div_SNo s denS.
		      { exact (div_SNo_pos_LtR s denS a HsS HdenSS HaS HdenSpos HmulLt). }
		      claim HaltPsi: Rlt a (apply_fun bounded_transform_psi s).
		      { claim HdenSR: denS :e R.
		        { exact (real_add_SNo 1 real_1 (minus_SNo s) (real_minus_SNo s HsR)). }
		        rewrite HpsiEq.
		        exact (RltI a (div_SNo s denS) HaR (real_div_SNo s HsR denS HdenSR) HaltPsiS). }
		      claim HrelA: order_rel R a (apply_fun bounded_transform_psi s).
		      { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_psi s) HaltPsi). }
		      exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_psi s) HpsiR HrelA).
	}
rewrite Heq.
exact (subspace_topologyI R R_standard_topology I (open_ray_upper R c) HrayOpen).
Qed.

(** helper for §35: preimage of a lower open ray under psi on the open interval **)
Theorem bounded_transform_psi_preimage_open_ray_lower : forall b:set,
  b :e R ->
  preimage_of (open_interval (minus_SNo 1) 1)
              bounded_transform_psi
              (open_ray_lower R b)
  :e subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1).
let b.
assume HbR: b :e R.
prove preimage_of (open_interval (minus_SNo 1) 1)
                  bounded_transform_psi
                  (open_ray_lower R b)
      :e subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1).
set I := open_interval (minus_SNo 1) 1.
set U := preimage_of I bounded_transform_psi (open_ray_lower R b).
claim HI_sub_R: I c= R.
{ let x. assume HxI: x :e I.
  exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) x HxI). }
set mb := minus_SNo b.
claim HmbR: mb :e R.
{ exact (real_minus_SNo b HbR). }
set V := preimage_of I bounded_transform_psi (open_ray_upper R mb).
claim HVopen: V :e subspace_topology R R_standard_topology I.
{ exact (bounded_transform_psi_preimage_open_ray_upper mb HmbR). }
set Ti := subspace_topology R R_standard_topology I.
claim HnegcontR: continuous_map R R_standard_topology R R_standard_topology neg_fun.
{ exact neg_fun_continuous. }
claim HnegcontI_R: continuous_map I Ti R R_standard_topology neg_fun.
{ exact (continuous_on_subspace R R_standard_topology R R_standard_topology neg_fun I
         R_standard_topology_is_topology HI_sub_R HnegcontR). }
claim HnegImgI: forall x:set, x :e I -> apply_fun neg_fun x :e I.
{ let x. assume HxI: x :e I.
  claim HxR: x :e R.
  { exact (HI_sub_R x HxI). }
  claim HnegEq: apply_fun neg_fun x = minus_SNo x.
  { exact (neg_fun_apply x HxR). }
  rewrite HnegEq.
  exact (neg_closed_open_interval_minus1_1 x HxI). }
claim HnegcontI_I: continuous_map I Ti I Ti neg_fun.
{ exact (continuous_map_range_restrict I Ti R R_standard_topology neg_fun I HnegcontI_R HI_sub_R HnegImgI). }
claim Heq: U = preimage_of I neg_fun V.
{ apply set_ext.
  - let s. assume HsU: s :e U.
    prove s :e preimage_of I neg_fun V.
    claim HsI: s :e I.
    { exact (SepE1 I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_lower R b) s HsU). }
    claim HpsiLower: apply_fun bounded_transform_psi s :e open_ray_lower R b.
    { exact (SepE2 I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_lower R b) s HsU). }
    claim HsR: s :e R.
    { exact (HI_sub_R s HsI). }
    claim HnegS: apply_fun neg_fun s = minus_SNo s.
    { exact (neg_fun_apply s HsR). }
    claim HmsI: minus_SNo s :e I.
    { exact (neg_closed_open_interval_minus1_1 s HsI). }
    claim HpsR: apply_fun bounded_transform_psi s :e R.
    { exact (SepE1 R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_psi s) HpsiLower). }
    claim HpreEq0: preimage_of R neg_fun (open_ray_upper R mb) = open_ray_lower R (minus_SNo mb).
    { exact (preimage_neg_fun_open_ray_upper mb HmbR). }
    claim HpreEq: preimage_of R neg_fun (open_ray_upper R mb) = open_ray_lower R b.
    { claim HmbDef: mb = minus_SNo b.
      { reflexivity. }
      claim HmmbEq: minus_SNo mb = b.
      { rewrite HmbDef.
        exact (minus_SNo_invol b (real_SNo b HbR)). }
      rewrite HpreEq0.
      rewrite HmmbEq.
      reflexivity. }
    claim HpsPre: apply_fun bounded_transform_psi s :e preimage_of R neg_fun (open_ray_upper R mb).
    { rewrite HpreEq.
      exact HpsiLower. }
    claim HnegPs: apply_fun neg_fun (apply_fun bounded_transform_psi s) :e open_ray_upper R mb.
    { exact (SepE2 R (fun x0:set => apply_fun neg_fun x0 :e open_ray_upper R mb) (apply_fun bounded_transform_psi s) HpsPre). }
    claim HnegPsEq: apply_fun neg_fun (apply_fun bounded_transform_psi s) = minus_SNo (apply_fun bounded_transform_psi s).
    { exact (neg_fun_apply (apply_fun bounded_transform_psi s) HpsR). }
    claim HpsiOdd: apply_fun bounded_transform_psi (minus_SNo s) = minus_SNo (apply_fun bounded_transform_psi s).
    { exact (bounded_transform_psi_odd_open_interval s HsI). }
    claim HpsiUpper: apply_fun bounded_transform_psi (minus_SNo s) :e open_ray_upper R mb.
    { rewrite HpsiOdd.
      rewrite <- HnegPsEq.
      exact HnegPs. }
    claim HmSinV2: (minus_SNo s) :e V.
    { exact (SepI I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_upper R mb) (minus_SNo s) HmsI HpsiUpper). }
    claim HpreNegDef: preimage_of I neg_fun V = {x0 :e I | apply_fun neg_fun x0 :e V}.
    { reflexivity. }
    rewrite HpreNegDef.
    apply (SepI I (fun x0:set => apply_fun neg_fun x0 :e V) s HsI).
    rewrite HnegS.
    exact HmSinV2.
  - let s. assume HsPre: s :e preimage_of I neg_fun V.
    prove s :e U.
    claim HsI: s :e I.
    { exact (SepE1 I (fun x0:set => apply_fun neg_fun x0 :e V) s HsPre). }
    claim HnegInV: apply_fun neg_fun s :e V.
    { exact (SepE2 I (fun x0:set => apply_fun neg_fun x0 :e V) s HsPre). }
    claim HsR: s :e R.
    { exact (HI_sub_R s HsI). }
    claim HnegS: apply_fun neg_fun s = minus_SNo s.
    { exact (neg_fun_apply s HsR). }
    claim HmsI: minus_SNo s :e I.
    { exact (neg_closed_open_interval_minus1_1 s HsI). }
    claim HmSinV: (minus_SNo s) :e V.
    { rewrite <- HnegS.
      exact HnegInV. }
    claim HpsiUpper: apply_fun bounded_transform_psi (minus_SNo s) :e open_ray_upper R mb.
    { exact (SepE2 I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_upper R mb) (minus_SNo s) HmSinV). }
    claim HpsiOdd: apply_fun bounded_transform_psi (minus_SNo s) = minus_SNo (apply_fun bounded_transform_psi s).
    { exact (bounded_transform_psi_odd_open_interval s HsI). }
    claim HnegPs: minus_SNo (apply_fun bounded_transform_psi s) :e open_ray_upper R mb.
    { rewrite <- HpsiOdd.
      exact HpsiUpper. }
    claim HpsiMsR: apply_fun bounded_transform_psi (minus_SNo s) :e R.
    { exact (SepE1 R (fun x0:set => order_rel R mb x0) (apply_fun bounded_transform_psi (minus_SNo s)) HpsiUpper). }
    claim HpsiOdd2: apply_fun bounded_transform_psi s = minus_SNo (apply_fun bounded_transform_psi (minus_SNo s)).
    { claim Hraw: apply_fun bounded_transform_psi (minus_SNo (minus_SNo s)) =
                  minus_SNo (apply_fun bounded_transform_psi (minus_SNo s)).
      { exact (bounded_transform_psi_odd_open_interval (minus_SNo s) HmsI). }
      rewrite <- (minus_SNo_invol s (real_SNo s HsR)) at 1.
      exact Hraw. }
    claim HminusPsiMsR: minus_SNo (apply_fun bounded_transform_psi (minus_SNo s)) :e R.
    { exact (real_minus_SNo (apply_fun bounded_transform_psi (minus_SNo s)) HpsiMsR). }
    claim HpsR: apply_fun bounded_transform_psi s :e R.
    { rewrite HpsiOdd2.
      exact HminusPsiMsR. }
    claim HnegPsEq: apply_fun neg_fun (apply_fun bounded_transform_psi s) = minus_SNo (apply_fun bounded_transform_psi s).
    { exact (neg_fun_apply (apply_fun bounded_transform_psi s) HpsR). }
    claim HnegPs2: apply_fun neg_fun (apply_fun bounded_transform_psi s) :e open_ray_upper R mb.
    { rewrite HnegPsEq.
      exact HnegPs. }
    claim HpreEq0: preimage_of R neg_fun (open_ray_upper R mb) = open_ray_lower R (minus_SNo mb).
    { exact (preimage_neg_fun_open_ray_upper mb HmbR). }
    claim HpreEq: preimage_of R neg_fun (open_ray_upper R mb) = open_ray_lower R b.
    { claim HmbDef: mb = minus_SNo b.
      { reflexivity. }
      claim HmmbEq: minus_SNo mb = b.
      { rewrite HmbDef.
        exact (minus_SNo_invol b (real_SNo b HbR)). }
      rewrite HpreEq0.
      rewrite HmmbEq.
      reflexivity. }
    claim HpsPre: apply_fun bounded_transform_psi s :e preimage_of R neg_fun (open_ray_upper R mb).
    { set P := (fun x0:set => apply_fun neg_fun x0 :e open_ray_upper R mb).
      exact (SepI R P (apply_fun bounded_transform_psi s) HpsR HnegPs2). }
    claim HpsiLower: apply_fun bounded_transform_psi s :e open_ray_lower R b.
    { rewrite <- HpreEq.
      exact HpsPre. }
    exact (SepI I (fun x0:set => apply_fun bounded_transform_psi x0 :e open_ray_lower R b) s HsI HpsiLower). }
rewrite Heq.
exact (continuous_map_preimage I Ti I Ti neg_fun HnegcontI_I V HVopen).
Qed.

(** helper for §35: psi cancels phi on R (intended inverse identity) **)
Theorem bounded_transform_psi_phi_cancel : forall t:set,
  t :e R ->
  apply_fun bounded_transform_psi (apply_fun bounded_transform_phi t) = t.
let t.
assume HtR: t :e R.
prove apply_fun bounded_transform_psi (apply_fun bounded_transform_phi t) = t.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
set den := add_SNo 1 (abs_SNo t).
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < den.
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim Hden0: den <> 0.
{ exact (SNo_pos_ne0 den HdenS HdenPos). }
claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
set s := apply_fun bounded_transform_phi t.
claim HsDef0: s = apply_fun bounded_transform_phi t.
{ reflexivity. }
rewrite <- HsDef0 at 1.
claim HsDef: s = div_SNo t den.
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
  reflexivity. }
claim HsR: s :e R.
{ exact (bounded_transform_phi_value_in_R t HtR). }
claim HsS: SNo s.
{ exact (real_SNo s HsR). }
claim HabsSDef: abs_SNo s = div_SNo (abs_SNo t) den.
{ rewrite HsDef.
  exact (abs_div_SNo_pos t den HtS HdenS HdenPos). }
claim HpsiDef: bounded_transform_psi = graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
{ reflexivity. }
claim HpsiEq: apply_fun bounded_transform_psi s =
              div_SNo s (add_SNo 1 (minus_SNo (abs_SNo s))).
{ rewrite HpsiDef.
  rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
  reflexivity. }
rewrite HpsiEq at 1.
rewrite HsDef at 1.
rewrite HabsSDef.
set denom2 := add_SNo 1 (minus_SNo (div_SNo (abs_SNo t) den)).
claim Hdenom2Def: denom2 = add_SNo 1 (minus_SNo (div_SNo (abs_SNo t) den)).
{ reflexivity. }
claim HdivAbsS: SNo (div_SNo (abs_SNo t) den).
{ exact (SNo_div_SNo (abs_SNo t) den HabsS HdenS). }
claim HminS: SNo (minus_SNo (div_SNo (abs_SNo t) den)).
{ exact (SNo_minus_SNo (div_SNo (abs_SNo t) den) HdivAbsS). }
claim Hdenom2S: SNo denom2.
{ rewrite Hdenom2Def.
  exact (SNo_add_SNo 1 (minus_SNo (div_SNo (abs_SNo t) den)) SNo_1 HminS). }
rewrite <- Hdenom2Def at 1.
rewrite (div_div_SNo t den denom2 HtS HdenS Hdenom2S).
claim HdenMul: mul_SNo den denom2 = 1.
{ rewrite Hdenom2Def.
  rewrite (mul_SNo_distrL den 1 (minus_SNo (div_SNo (abs_SNo t) den)) HdenS SNo_1 HminS).
  rewrite (mul_SNo_oneR den HdenS).
  rewrite (mul_SNo_minus_distrR den (div_SNo (abs_SNo t) den) HdenS HdivAbsS).
  rewrite (mul_div_SNo_invR (abs_SNo t) den HabsS HdenS Hden0).
  claim HdenDef: den = add_SNo 1 (abs_SNo t).
  { reflexivity. }
  rewrite HdenDef.
  rewrite <- (add_SNo_assoc 1 (abs_SNo t) (minus_SNo (abs_SNo t)) SNo_1 HabsS (SNo_minus_SNo (abs_SNo t) HabsS)) at 1.
  rewrite (add_SNo_minus_SNo_rinv (abs_SNo t) HabsS).
  rewrite (add_SNo_0R 1 SNo_1).
  reflexivity. }
rewrite HdenMul.
claim Hdiv1: div_SNo t 1 = t.
{ apply (mul_div_SNo_nonzero_eq t 1 t HtS SNo_1 HtS neq_1_0).
  rewrite (mul_SNo_oneL t HtS).
  reflexivity. }
rewrite Hdiv1.
reflexivity.
Qed.

(** helper for §35: continuity of psi on the open interval (-1,1) **)
Theorem bounded_transform_psi_continuous_open_interval :
  continuous_map (open_interval (minus_SNo 1) 1)
                 (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
                 R R_standard_topology
                 bounded_transform_psi.
prove continuous_map (open_interval (minus_SNo 1) 1)
       (subspace_topology R R_standard_topology (open_interval (minus_SNo 1) 1))
       R R_standard_topology
       bounded_transform_psi.
set I := open_interval (minus_SNo 1) 1.
set Ti := subspace_topology R R_standard_topology I.
set S := open_rays_subbasis R.
claim HI_sub_R: I c= R.
{ let x. assume HxI: x :e I.
  exact (SepE1 R (fun x0:set => Rlt (minus_SNo 1) x0 /\ Rlt x0 1) x HxI). }
claim HTi: topology_on I Ti.
{ exact (subspace_topology_is_topology R R_standard_topology I
          R_standard_topology_is_topology
          HI_sub_R). }
claim Hfun: function_on bounded_transform_psi I R.
{ let s. assume HsI: s :e I.
  prove apply_fun bounded_transform_psi s :e R.
  claim HsR: s :e R.
  { exact (HI_sub_R s HsI). }
  claim HabsR: abs_SNo s :e R.
  { exact (abs_SNo_in_R s HsR). }
  claim HminR: minus_SNo (abs_SNo s) :e R.
  { exact (real_minus_SNo (abs_SNo s) HabsR). }
  claim HdenR: add_SNo 1 (minus_SNo (abs_SNo s)) :e R.
  { exact (real_add_SNo 1 real_1 (minus_SNo (abs_SNo s)) HminR). }
  claim HpsiDef: bounded_transform_psi = graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))).
  { reflexivity. }
  rewrite HpsiDef.
  rewrite (apply_fun_graph R (fun s0:set => div_SNo s0 (add_SNo 1 (minus_SNo (abs_SNo s0)))) s HsR).
  exact (real_div_SNo s HsR (add_SNo 1 (minus_SNo (abs_SNo s))) HdenR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim HTyEq: R_standard_topology = generated_topology_from_subbasis R S.
{ claim HSdef0: S = open_rays_subbasis R.
  { reflexivity. }
  rewrite HSdef0.
  rewrite <- standard_topology_is_order_topology.
  rewrite <- open_rays_subbasis_for_order_topology_R.
  reflexivity. }
rewrite HTyEq at 2.
apply (continuous_map_from_subbasis I Ti R S bounded_transform_psi HTi Hfun HS).
let s.
assume HsS: s :e S.
prove preimage_of I bounded_transform_psi s :e Ti.
claim HSdef: S =
  (({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
    :\/:
    {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b})
   :\/:
   {R}).
{ reflexivity. }
claim HsS': s :e
  (({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
    :\/:
    {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b})
   :\/:
   {R}).
{ rewrite <- HSdef.
  exact HsS. }
apply (binunionE'
  ({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
   :\/:
   {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b})
  {R}
  s
  (preimage_of I bounded_transform_psi s :e Ti)).
- assume HsAB: s :e ({I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
                     :\/:
                     {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}).
  apply (binunionE'
    {I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}
    {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}
    s
    (preimage_of I bounded_transform_psi s :e Ti)).
  + assume HsUpper: s :e {I0 :e Power R | exists a :e R, I0 = open_ray_upper R a}.
    claim Hex: exists a :e R, s = open_ray_upper R a.
    { exact (SepE2 (Power R) (fun I1:set => exists a :e R, I1 = open_ray_upper R a) s HsUpper). }
    apply Hex.
    let a. assume Hacore.
    apply Hacore.
    assume HaR: a :e R.
    assume Hseq: s = open_ray_upper R a.
    rewrite Hseq.
    exact (bounded_transform_psi_preimage_open_ray_upper a HaR).
  + assume HsLower: s :e {I0 :e Power R | exists b :e R, I0 = open_ray_lower R b}.
    claim Hex: exists b :e R, s = open_ray_lower R b.
    { exact (SepE2 (Power R) (fun I1:set => exists b :e R, I1 = open_ray_lower R b) s HsLower). }
    apply Hex.
    let b. assume Hbcore.
    apply Hbcore.
    assume HbR: b :e R.
    assume Hseq: s = open_ray_lower R b.
    rewrite Hseq.
    exact (bounded_transform_psi_preimage_open_ray_lower b HbR).
  + exact HsAB.
- assume HsR: s :e {R}.
  claim Hseq: s = R.
  { exact (SingE R s HsR). }
  rewrite Hseq.
  rewrite (preimage_of_whole I R bounded_transform_psi Hfun).
  exact (topology_has_X I Ti HTi).
- exact HsS'.
Qed.

(** helper for §35: positivity reflects through bounded transform **)
Theorem bounded_transform_phi_Rlt0_implies_Rlt0 : forall t:set,
  t :e R -> Rlt 0 (apply_fun bounded_transform_phi t) -> Rlt 0 t.
let t.
assume HtR: t :e R.
assume H0ltf: Rlt 0 (apply_fun bounded_transform_phi t).
prove Rlt 0 t.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim H0ltfS: 0 < apply_fun bounded_transform_phi t.
{ exact (RltE_lt 0 (apply_fun bounded_transform_phi t) H0ltf). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
set den := add_SNo 1 (abs_SNo t).
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < den.
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
  reflexivity. }
claim HdivPos: 0 < div_SNo t den.
{ rewrite <- HfEq.
  exact H0ltfS. }
claim H0denLt: mul_SNo 0 den < t.
{ exact (div_SNo_pos_LtR' t den 0 HtS HdenS SNo_0 HdenPos HdivPos). }
claim HtPosS: 0 < t.
{ rewrite <- (mul_SNo_zeroL den HdenS) at 1.
  exact H0denLt. }
exact (RltI 0 t real_0 HtR HtPosS).
Qed.

(** helper for §35: negativity reflects through bounded transform **)
Theorem bounded_transform_phi_Rlt0_implies_Rlt0_neg : forall t:set,
  t :e R -> Rlt (apply_fun bounded_transform_phi t) 0 -> Rlt t 0.
let t.
assume HtR: t :e R.
assume Hflt0: Rlt (apply_fun bounded_transform_phi t) 0.
prove Rlt t 0.
claim HtS: SNo t.
{ exact (real_SNo t HtR). }
claim HfLt0S: apply_fun bounded_transform_phi t < 0.
{ exact (RltE_lt (apply_fun bounded_transform_phi t) 0 Hflt0). }
claim HabsR: abs_SNo t :e R.
{ exact (abs_SNo_in_R t HtR). }
claim HabsS: SNo (abs_SNo t).
{ exact (real_SNo (abs_SNo t) HabsR). }
set den := add_SNo 1 (abs_SNo t).
claim HdenS: SNo den.
{ exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
claim H0le_abs: 0 <= abs_SNo t.
{ exact (abs_SNo_nonneg t HtS). }
claim HdenPos0: add_SNo 0 0 < den.
{ exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
claim HdenPos: 0 < den.
{ rewrite <- (add_SNo_0L 0 SNo_0) at 1.
  exact HdenPos0. }
claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
{ reflexivity. }
claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
{ rewrite HphiDef.
  rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
  reflexivity. }
claim HdivLt0: div_SNo t den < 0.
{ rewrite <- HfEq.
  exact HfLt0S. }
claim HtLt0den: t < mul_SNo 0 den.
{ exact (div_SNo_pos_LtL' t den 0 HtS HdenS SNo_0 HdenPos HdivLt0). }
claim HtLt0S: t < 0.
{ rewrite <- (mul_SNo_zeroL den HdenS) at 1.
  exact HtLt0den. }
exact (RltI t 0 HtR real_0 HtLt0S).
Qed.

(** helper for §35: preimage of an upper open ray, strict middle case **)
Theorem bounded_transform_phi_preimage_open_ray_upper_neg_case_eq : forall a:set,
  a :e R -> Rlt a 0 -> Rlt (minus_SNo 1) a ->
  preimage_of R bounded_transform_phi (open_ray_upper R a) =
  open_ray_upper R (div_SNo a (add_SNo 1 a)).
let a.
assume HaR: a :e R.
assume Halt0: Rlt a 0.
assume Hm1lta: Rlt (minus_SNo 1) a.
set denA := add_SNo 1 a.
set c := div_SNo a denA.
prove preimage_of R bounded_transform_phi (open_ray_upper R a) = open_ray_upper R c.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
  prove t :e open_ray_upper R c.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
  claim Hrel: order_rel R a (apply_fun bounded_transform_phi t).
  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfRay). }
  claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
  { exact (order_rel_R_implies_Rlt a (apply_fun bounded_transform_phi t) Hrel). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim Halt0S: a < 0.
  { exact (RltE_lt a 0 Halt0). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim Hm1ltaS: minus_SNo 1 < a.
  { exact (RltE_lt (minus_SNo 1) a Hm1lta). }
  claim HdenAS: SNo denA.
  { exact (SNo_add_SNo 1 a SNo_1 HaS). }
  claim Htmp: add_SNo (minus_SNo 1) 1 < add_SNo a 1.
  { exact (add_SNo_Lt1 (minus_SNo 1) 1 a Hm1S SNo_1 HaS Hm1ltaS). }
  claim HdenApos0: 0 < add_SNo 1 a.
  { rewrite <- (add_SNo_minus_SNo_linv 1 SNo_1) at 1.
    rewrite (add_SNo_com 1 a SNo_1 HaS).
    exact Htmp. }
  claim HdenApos: 0 < denA.
  { exact HdenApos0. }
  claim HcR: c :e R.
  { exact (real_div_SNo a HaR denA (real_add_SNo 1 real_1 a HaR)). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HcLt0S: c < 0.
  { exact (div_SNo_neg_pos a denA HaS HdenAS Halt0S HdenApos). }
  apply xm (0 <= t).
  + assume H0let: 0 <= t.
    claim HcLtT: c < t.
    { exact (SNoLtLe_tra c 0 t HcS SNo_0 HtS HcLt0S H0let). }
    claim HcLtTR: Rlt c t.
    { exact (RltI c t HcR HtR HcLtT). }
    claim Hrelct: order_rel R c t.
    { exact (Rlt_implies_order_rel_R c t HcLtTR). }
    exact (SepI R (fun x0:set => order_rel R c x0) t HtR Hrelct).
	  + assume Hn0let: ~(0 <= t).
	    claim HabsEq: abs_SNo t = minus_SNo t.
	    { exact (not_nonneg_abs_SNo t Hn0let). }
	    set den := add_SNo 1 (abs_SNo t).
	    claim HdenS: SNo den.
	    { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR))). }
	    claim H0le_abs: 0 <= abs_SNo t.
	    { exact (abs_SNo_nonneg t HtS). }
	    claim HdenPos0: add_SNo 0 0 < den.
	    { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR)) SNoLt_0_1 H0le_abs). }
	    claim HdenPos: 0 < den.
	    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
	      exact HdenPos0. }
	    claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
	    { reflexivity. }
	    claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
	    { rewrite HphiDef.
	      rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
	      reflexivity. }
	    claim HaltS: a < div_SNo t den.
	    { rewrite <- HfEq.
	      exact (RltE_lt a (apply_fun bounded_transform_phi t) Haltf). }
	    claim HaDenLtT: mul_SNo a den < t.
	    { exact (div_SNo_pos_LtR' t den a HtS HdenS HaS HdenPos HaltS). }
	    set atv := mul_SNo a t.
	    claim HatS: SNo atv.
	    { exact (SNo_mul_SNo a t HaS HtS). }
	    claim HmatS: SNo (minus_SNo atv).
	    { exact (SNo_minus_SNo atv HatS). }
	    claim HaDenEq: mul_SNo a den = add_SNo a (minus_SNo atv).
	    { rewrite HabsEq at 1.
	      rewrite (mul_SNo_distrL a 1 (minus_SNo t) HaS SNo_1 (SNo_minus_SNo t HtS)).
	      rewrite (mul_SNo_oneR a HaS).
	      rewrite (mul_SNo_minus_distrR a t HaS HtS).
	      reflexivity. }
	    claim HaMinusAlt: add_SNo a (minus_SNo atv) < t.
	    { rewrite <- HaDenEq.
	      exact HaDenLtT. }
	    claim Hstep: add_SNo (add_SNo a (minus_SNo atv)) atv < add_SNo t atv.
	    { exact (add_SNo_Lt1 (add_SNo a (minus_SNo atv)) atv t
	             (SNo_add_SNo a (minus_SNo atv) HaS HmatS) HatS HtS HaMinusAlt). }
	    claim HleftEq: add_SNo (add_SNo a (minus_SNo atv)) atv = a.
	    { exact (add_SNo_minus_R2' a atv HaS HatS). }
	    claim HaLtTplusa: a < add_SNo t atv.
	    { rewrite <- HleftEq at 1.
	      exact Hstep. }
	    claim HtDenAeq: mul_SNo t denA = add_SNo t atv.
	    { rewrite (mul_SNo_distrL t 1 a HtS SNo_1 HaS).
	      rewrite (mul_SNo_oneR t HtS).
	      rewrite (mul_SNo_com t a HtS HaS).
	      reflexivity. }
  claim HaLtTdenA: a < mul_SNo t denA.
  { rewrite HtDenAeq.
    exact HaLtTplusa. }
	    claim HcLtT: c < t.
	    { exact (div_SNo_pos_LtL a denA t HaS HdenAS HtS HdenApos HaLtTdenA). }
	    claim HcLtTR: Rlt c t.
	    { exact (RltI c t HcR HtR HcLtT). }
	    claim Hrelct: order_rel R c t.
	    { exact (Rlt_implies_order_rel_R c t HcLtTR). }
	    exact (SepI R (fun x0:set => order_rel R c x0) t HtR Hrelct).
- let t. assume HtRay: t :e open_ray_upper R c.
  prove t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R c x0) t HtRay). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim Hrelct: order_rel R c t.
  { exact (SepE2 R (fun x0:set => order_rel R c x0) t HtRay). }
  claim Hcltt: Rlt c t.
  { exact (order_rel_R_implies_Rlt c t Hrelct). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim Halt0S: a < 0.
  { exact (RltE_lt a 0 Halt0). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim Hm1ltaS: minus_SNo 1 < a.
  { exact (RltE_lt (minus_SNo 1) a Hm1lta). }
  claim HdenAS: SNo denA.
  { exact (SNo_add_SNo 1 a SNo_1 HaS). }
  claim Htmp: add_SNo (minus_SNo 1) 1 < add_SNo a 1.
  { exact (add_SNo_Lt1 (minus_SNo 1) 1 a Hm1S SNo_1 HaS Hm1ltaS). }
  claim HdenApos0: 0 < add_SNo 1 a.
  { rewrite <- (add_SNo_minus_SNo_linv 1 SNo_1) at 1.
    rewrite (add_SNo_com 1 a SNo_1 HaS).
    exact Htmp. }
  claim HdenApos: 0 < denA.
  { exact HdenApos0. }
  claim HcR: c :e R.
  { exact (real_div_SNo a HaR denA (real_add_SNo 1 real_1 a HaR)). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HcLtS: c < t.
  { exact (RltE_lt c t Hcltt). }
  apply xm (0 <= t).
  + assume H0let: 0 <= t.
    apply xm (t = 0).
    - assume Ht0: t = 0.
      claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
      { reflexivity. }
      claim HfEq0: apply_fun bounded_transform_phi t = 0.
      { rewrite Ht0.
        rewrite HphiDef.
        rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) 0 real_0).
        claim Habs0: abs_SNo 0 = 0.
        { exact (nonneg_abs_SNo 0 (SNoLe_ref 0)). }
        rewrite Habs0.
        rewrite (div_SNo_0_num (add_SNo 1 0) (SNo_add_SNo 1 0 SNo_1 SNo_0)).
        reflexivity. }
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
      { rewrite HfEq0.
        exact Halt0. }
      claim Hrelaf: order_rel R a (apply_fun bounded_transform_phi t).
      { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) Haltf). }
      claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
      { exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfR Hrelaf). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HfRay).
    - assume HtNeq0: ~(t = 0).
      claim HtPos: Rlt 0 t.
      { apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (Rlt 0 t)).
        - assume Htlt0: t < 0.
          apply FalseE.
          claim HtLe0: t <= 0.
          { exact (SNoLtLe t 0 Htlt0). }
          claim HtEq0: t = 0.
          { exact (SNoLe_antisym t 0 HtS SNo_0 HtLe0 H0let). }
          exact (HtNeq0 HtEq0).
        - assume Heq: t = 0.
          apply FalseE.
          exact (HtNeq0 Heq).
        - assume Htgt0: 0 < t.
          exact (RltI 0 t real_0 HtR Htgt0). }
      claim HtPosS: 0 < t.
      { exact (RltE_lt 0 t HtPos). }
      claim HabsEq: abs_SNo t = t.
      { exact (nonneg_abs_SNo t H0let). }
      set den := add_SNo 1 t.
      claim HdenS: SNo den.
      { exact (SNo_add_SNo 1 t SNo_1 HtS). }
      claim HdenPos0: add_SNo 0 0 < den.
      { exact (add_SNo_Lt3a 0 0 1 t SNo_0 SNo_0 SNo_1 HtS SNoLt_0_1 H0let). }
      claim HdenPos: 0 < den.
      { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
        exact HdenPos0. }
      claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
      { reflexivity. }
      claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
      { rewrite HphiDef.
        rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
        rewrite HabsEq.
        reflexivity. }
      claim HdivPos: 0 < div_SNo t den.
      { exact (div_SNo_pos_pos t den HtS HdenS HtPosS HdenPos). }
      claim HphiPosS: 0 < apply_fun bounded_transform_phi t.
      { rewrite HfEq.
        exact HdivPos. }
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim HphiPos: Rlt 0 (apply_fun bounded_transform_phi t).
      { exact (RltI 0 (apply_fun bounded_transform_phi t) real_0 HfR HphiPosS). }
      claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
      { exact (Rlt_tra a 0 (apply_fun bounded_transform_phi t) Halt0 HphiPos). }
      claim Hrelaf: order_rel R a (apply_fun bounded_transform_phi t).
      { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) Haltf). }
      claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
      { exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfR Hrelaf). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HfRay).
  + assume Hn0let: ~(0 <= t).
	    claim HabsEq: abs_SNo t = minus_SNo t.
	    { exact (not_nonneg_abs_SNo t Hn0let). }
	    set den := add_SNo 1 (abs_SNo t).
	    claim HdenS: SNo den.
	    { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR))). }
	    claim H0le_abs: 0 <= abs_SNo t.
	    { exact (abs_SNo_nonneg t HtS). }
	    claim HdenPos0: add_SNo 0 0 < den.
	    { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR)) SNoLt_0_1 H0le_abs). }
	    claim HdenPos: 0 < den.
	    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
	      exact HdenPos0. }
	    claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
	    { reflexivity. }
	    claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
	    { rewrite HphiDef.
	      rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
	      reflexivity. }
	    claim HcLtS: c < t.
	    { exact (RltE_lt c t Hcltt). }
	    claim HaLtTdenA: a < mul_SNo t denA.
	    { exact (div_SNo_pos_LtL' a denA t HaS HdenAS HtS HdenApos HcLtS). }
	    set atv := mul_SNo a t.
	    claim HatS: SNo atv.
	    { exact (SNo_mul_SNo a t HaS HtS). }
	    claim HtDenAeq: mul_SNo t denA = add_SNo t atv.
	    { rewrite (mul_SNo_distrL t 1 a HtS SNo_1 HaS).
	      rewrite (mul_SNo_oneR t HtS).
	      rewrite (mul_SNo_com t a HtS HaS).
	      reflexivity. }
	    claim HaLtTplusa: a < add_SNo t atv.
	    { rewrite <- HtDenAeq at 1.
	      exact HaLtTdenA. }
	    claim Hstep: add_SNo a (minus_SNo atv) < add_SNo (add_SNo t atv) (minus_SNo atv).
	    { exact (add_SNo_Lt1 a (minus_SNo atv) (add_SNo t atv) HaS (SNo_minus_SNo atv HatS)
	             (SNo_add_SNo t atv HtS HatS) HaLtTplusa). }
	    claim HrightEq: add_SNo (add_SNo t atv) (minus_SNo atv) = t.
	    { exact (add_SNo_minus_R2 t atv HtS HatS). }
		    claim HaMinusAlt: add_SNo a (minus_SNo atv) < t.
		    { rewrite <- HrightEq at 2.
		      exact Hstep. }
	    claim HaDenEq: mul_SNo a den = add_SNo a (minus_SNo atv).
	    { rewrite HabsEq at 1.
	      rewrite (mul_SNo_distrL a 1 (minus_SNo t) HaS SNo_1 (SNo_minus_SNo t HtS)).
	      rewrite (mul_SNo_oneR a HaS).
	      rewrite (mul_SNo_minus_distrR a t HaS HtS).
	      reflexivity. }
	    claim HaDenLtT: mul_SNo a den < t.
	    { rewrite HaDenEq.
	      exact HaMinusAlt. }
	    claim HaLtDiv: a < div_SNo t den.
	    { exact (div_SNo_pos_LtR t den a HtS HdenS HaS HdenPos HaDenLtT). }
	    claim HaLtF: a < apply_fun bounded_transform_phi t.
	    { rewrite HfEq.
	      exact HaLtDiv. }
	    claim HfR: apply_fun bounded_transform_phi t :e R.
	    { exact (bounded_transform_phi_value_in_R t HtR). }
	    claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
	    { exact (RltI a (apply_fun bounded_transform_phi t) HaR HfR HaLtF). }
	    claim Hrelaf: order_rel R a (apply_fun bounded_transform_phi t).
	    { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) Haltf). }
	    claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
	    { exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfR Hrelaf). }
	    exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_upper_pos_case_eq : forall a:set,
  a :e R -> Rlt 0 a -> Rlt a 1 ->
  preimage_of R bounded_transform_phi (open_ray_upper R a) =
  open_ray_upper R (div_SNo a (add_SNo 1 (minus_SNo a))).
let a.
assume HaR: a :e R.
assume H0lta: Rlt 0 a.
assume Halt1: Rlt a 1.
set denA := add_SNo 1 (minus_SNo a).
set c := div_SNo a denA.
prove preimage_of R bounded_transform_phi (open_ray_upper R a) = open_ray_upper R c.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
  prove t :e open_ray_upper R c.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
  claim Hrel: order_rel R a (apply_fun bounded_transform_phi t).
  { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfRay). }
  claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
  { exact (order_rel_R_implies_Rlt a (apply_fun bounded_transform_phi t) Hrel). }
  claim H0ltf: Rlt 0 (apply_fun bounded_transform_phi t).
  { exact (Rlt_tra 0 a (apply_fun bounded_transform_phi t) H0lta Haltf). }
  claim HfR: apply_fun bounded_transform_phi t :e R.
  { exact (bounded_transform_phi_value_in_R t HtR). }
  claim Hrel0: order_rel R 0 (apply_fun bounded_transform_phi t).
  { exact (Rlt_implies_order_rel_R 0 (apply_fun bounded_transform_phi t) H0ltf). }
  claim HfRay0: apply_fun bounded_transform_phi t :e open_ray_upper R 0.
  { exact (SepI R (fun x0:set => order_rel R 0 x0) (apply_fun bounded_transform_phi t) HfR Hrel0). }
  claim HtPos: Rlt 0 t.
  { exact (bounded_transform_phi_Rlt0_implies_Rlt0 t HtR H0ltf). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HtPosS: 0 < t.
  { exact (RltE_lt 0 t HtPos). }
  claim H0let: 0 <= t.
  { exact (SNoLtLe 0 t HtPosS). }
  claim HabsEq: abs_SNo t = t.
  { exact (nonneg_abs_SNo t H0let). }
  set den := add_SNo 1 t.
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 t SNo_1 HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 t SNo_0 SNo_0 SNo_1 HtS SNoLt_0_1 H0let). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    rewrite HabsEq.
    reflexivity. }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HaltS: a < div_SNo t den.
  { rewrite <- HfEq.
    exact (RltE_lt a (apply_fun bounded_transform_phi t) Haltf). }
  claim HaDenLtT: mul_SNo a den < t.
  { exact (div_SNo_pos_LtR' t den a HtS HdenS HaS HdenPos HaltS). }
  set atv := mul_SNo a t.
  claim HatS: SNo atv.
  { exact (SNo_mul_SNo a t HaS HtS). }
  claim HaDenEq: mul_SNo a den = add_SNo a atv.
  { rewrite (mul_SNo_distrL a 1 t HaS SNo_1 HtS).
    rewrite (mul_SNo_oneR a HaS).
    reflexivity. }
  claim HaPlusAlt: add_SNo a atv < t.
  { rewrite <- HaDenEq.
    exact HaDenLtT. }
  claim HmatS: SNo (minus_SNo atv).
  { exact (SNo_minus_SNo atv HatS). }
  claim Hstep: add_SNo (add_SNo a atv) (minus_SNo atv) < add_SNo t (minus_SNo atv).
  { exact (add_SNo_Lt1 (add_SNo a atv) (minus_SNo atv) t (SNo_add_SNo a atv HaS HatS) HmatS HtS HaPlusAlt). }
  claim HleftEq: add_SNo (add_SNo a atv) (minus_SNo atv) = a.
  { exact (add_SNo_minus_R2 a atv HaS HatS). }
  claim HaLtTminus: a < add_SNo t (minus_SNo atv).
  { rewrite <- HleftEq at 1.
    exact Hstep. }
  claim HmaS: SNo (minus_SNo a).
  { exact (SNo_minus_SNo a HaS). }
  claim HdenAS: SNo denA.
  { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 HmaS). }
  claim HaLt1S: a < 1.
  { exact (RltE_lt a 1 Halt1). }
  claim Htmp: add_SNo a (minus_SNo a) < add_SNo 1 (minus_SNo a).
  { exact (add_SNo_Lt1 a (minus_SNo a) 1 HaS HmaS SNo_1 HaLt1S). }
  claim HdenApos: 0 < denA.
  { rewrite <- (add_SNo_minus_SNo_rinv a HaS) at 1.
    exact Htmp. }
  claim HtDenEq: mul_SNo t denA = add_SNo t (minus_SNo atv).
  { rewrite (mul_SNo_distrL t 1 (minus_SNo a) HtS SNo_1 HmaS).
    rewrite (mul_SNo_oneR t HtS).
    rewrite (mul_SNo_minus_distrR t a HtS HaS).
    rewrite (mul_SNo_com t a HtS HaS).
    reflexivity. }
  claim HaLtTden: a < mul_SNo t denA.
  { rewrite HtDenEq at 1.
    exact HaLtTminus. }
  claim HcLtT: div_SNo a denA < t.
  { exact (div_SNo_pos_LtL a denA t HaS HdenAS HtS HdenApos HaLtTden). }
  claim HcR: c :e R.
  { claim HmaR: minus_SNo a :e R.
    { exact (real_minus_SNo a HaR). }
    exact (real_div_SNo a HaR denA (real_add_SNo 1 real_1 (minus_SNo a) HmaR)). }
  claim HcLtTR: Rlt c t.
  { exact (RltI c t HcR HtR HcLtT). }
  claim Hrelct: order_rel R c t.
  { exact (Rlt_implies_order_rel_R c t HcLtTR). }
  exact (SepI R (fun x0:set => order_rel R c x0) t HtR Hrelct).
- let t. assume HtRay: t :e open_ray_upper R c.
  prove t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R c x0) t HtRay). }
  claim Hrelct: order_rel R c t.
  { exact (SepE2 R (fun x0:set => order_rel R c x0) t HtRay). }
  claim Hcltt: Rlt c t.
  { exact (order_rel_R_implies_Rlt c t Hrelct). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HaPosS: 0 < a.
  { exact (RltE_lt 0 a H0lta). }
  claim HaLt1S: a < 1.
  { exact (RltE_lt a 1 Halt1). }
  claim HmaS: SNo (minus_SNo a).
  { exact (SNo_minus_SNo a HaS). }
  claim HdenAS: SNo denA.
  { exact (SNo_add_SNo 1 (minus_SNo a) SNo_1 HmaS). }
  claim Htmp: add_SNo a (minus_SNo a) < add_SNo 1 (minus_SNo a).
  { exact (add_SNo_Lt1 a (minus_SNo a) 1 HaS HmaS SNo_1 HaLt1S). }
  claim HdenApos: 0 < denA.
  { rewrite <- (add_SNo_minus_SNo_rinv a HaS) at 1.
    exact Htmp. }
  claim HcR: c :e R.
  { claim HmaR: minus_SNo a :e R.
    { exact (real_minus_SNo a HaR). }
    exact (real_div_SNo a HaR denA (real_add_SNo 1 real_1 (minus_SNo a) HmaR)). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HcPosS: 0 < c.
  { exact (div_SNo_pos_pos a denA HaS HdenAS HaPosS HdenApos). }
  claim H0ltc: Rlt 0 c.
  { exact (RltI 0 c real_0 HcR HcPosS). }
  claim H0ltt: Rlt 0 t.
  { exact (Rlt_tra 0 c t H0ltc Hcltt). }
  claim HtPosS: 0 < t.
  { exact (RltE_lt 0 t H0ltt). }
  claim H0let: 0 <= t.
  { exact (SNoLtLe 0 t HtPosS). }
  claim HabsEq: abs_SNo t = t.
  { exact (nonneg_abs_SNo t H0let). }
  set denT := add_SNo 1 t.
  claim HdenTS: SNo denT.
  { exact (SNo_add_SNo 1 t SNo_1 HtS). }
  claim HdenTPos0: add_SNo 0 0 < denT.
  { exact (add_SNo_Lt3a 0 0 1 t SNo_0 SNo_0 SNo_1 HtS SNoLt_0_1 H0let). }
  claim HdenTPos: 0 < denT.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenTPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t denT.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    rewrite HabsEq.
    reflexivity. }
  claim HcLtS: c < t.
  { exact (RltE_lt c t Hcltt). }
  claim HaLtTdenA: a < mul_SNo t denA.
  { exact (div_SNo_pos_LtL' a denA t HaS HdenAS HtS HdenApos HcLtS). }
  set atv2 := mul_SNo a t.
  claim HatS: SNo atv2.
  { exact (SNo_mul_SNo a t HaS HtS). }
  claim HtDenEq: mul_SNo t denA = add_SNo t (minus_SNo atv2).
  { rewrite (mul_SNo_distrL t 1 (minus_SNo a) HtS SNo_1 HmaS).
    rewrite (mul_SNo_oneR t HtS).
    rewrite (mul_SNo_minus_distrR t a HtS HaS).
    rewrite (mul_SNo_com t a HtS HaS).
    reflexivity. }
  claim HaLtTminus: a < add_SNo t (minus_SNo atv2).
  { rewrite <- HtDenEq at 1.
    exact HaLtTdenA. }
  claim Hstep2: add_SNo a atv2 < add_SNo (add_SNo t (minus_SNo atv2)) atv2.
  { exact (add_SNo_Lt1 a atv2 (add_SNo t (minus_SNo atv2)) HaS HatS (SNo_add_SNo t (minus_SNo atv2) HtS (SNo_minus_SNo atv2 HatS)) HaLtTminus). }
  claim HrightEq: add_SNo (add_SNo t (minus_SNo atv2)) atv2 = t.
  { exact (add_SNo_minus_R2' t atv2 HtS HatS). }
  claim HaPlusAlt: add_SNo a atv2 < t.
  { rewrite <- HrightEq at 2.
    exact Hstep2. }
  claim HaDenEq: mul_SNo a denT = add_SNo a atv2.
  { rewrite (mul_SNo_distrL a 1 t HaS SNo_1 HtS).
    rewrite (mul_SNo_oneR a HaS).
    reflexivity. }
  claim HaDenLtT: mul_SNo a denT < t.
  { rewrite HaDenEq.
    exact HaPlusAlt. }
  claim HaLtDiv: a < div_SNo t denT.
  { exact (div_SNo_pos_LtR t denT a HtS HdenTS HaS HdenTPos HaDenLtT). }
  claim HfR: apply_fun bounded_transform_phi t :e R.
  { exact (bounded_transform_phi_value_in_R t HtR). }
  claim HaLtF: a < apply_fun bounded_transform_phi t.
  { rewrite HfEq.
    exact HaLtDiv. }
  claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
  { exact (RltI a (apply_fun bounded_transform_phi t) HaR HfR HaLtF). }
  claim Hrelaf: order_rel R a (apply_fun bounded_transform_phi t).
  { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) Haltf). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
  { exact (SepI R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfR Hrelaf). }
  exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_upper_zero_eq :
  preimage_of R bounded_transform_phi (open_ray_upper R 0) = open_ray_upper R 0.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R 0).
  prove t :e open_ray_upper R 0.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R 0) t HtPre). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R 0.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R 0) t HtPre). }
  claim Hrel: order_rel R 0 (apply_fun bounded_transform_phi t).
  { exact (SepE2 R (fun x0:set => order_rel R 0 x0) (apply_fun bounded_transform_phi t) HfRay). }
  claim Hlt0f: Rlt 0 (apply_fun bounded_transform_phi t).
  { exact (order_rel_R_implies_Rlt 0 (apply_fun bounded_transform_phi t) Hrel). }
  claim HfLtS: 0 < apply_fun bounded_transform_phi t.
  { exact (RltE_lt 0 (apply_fun bounded_transform_phi t) Hlt0f). }
  claim HabsR: abs_SNo t :e R.
  { exact (abs_SNo_in_R t HtR). }
  claim HabsS: SNo (abs_SNo t).
  { exact (real_SNo (abs_SNo t) HabsR). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HdivPos: 0 < div_SNo t den.
  { rewrite <- HfEq.
    exact HfLtS. }
  claim H0denLt: mul_SNo 0 den < t.
  { exact (div_SNo_pos_LtR' t den 0 HtS HdenS SNo_0 HdenPos HdivPos). }
  claim HtPosS: 0 < t.
  { rewrite <- (mul_SNo_zeroL den HdenS) at 1.
    exact H0denLt. }
  claim HtPos: Rlt 0 t.
  { exact (RltI 0 t real_0 HtR HtPosS). }
  claim HrelT: order_rel R 0 t.
  { exact (Rlt_implies_order_rel_R 0 t HtPos). }
  exact (SepI R (fun x0:set => order_rel R 0 x0) t HtR HrelT).
- let t. assume HtRay: t :e open_ray_upper R 0.
  prove t :e preimage_of R bounded_transform_phi (open_ray_upper R 0).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R 0 x0) t HtRay). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HrelT: order_rel R 0 t.
  { exact (SepE2 R (fun x0:set => order_rel R 0 x0) t HtRay). }
  claim Hlt0t: Rlt 0 t.
  { exact (order_rel_R_implies_Rlt 0 t HrelT). }
  claim HtPosS: 0 < t.
  { exact (RltE_lt 0 t Hlt0t). }
  claim HabsR: abs_SNo t :e R.
  { exact (abs_SNo_in_R t HtR). }
  claim HabsS: SNo (abs_SNo t).
  { exact (real_SNo (abs_SNo t) HabsR). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HdivPos: 0 < div_SNo t den.
  { exact (div_SNo_pos_pos t den HtS HdenS HtPosS HdenPos). }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HfPos: 0 < apply_fun bounded_transform_phi t.
  { rewrite HfEq.
    exact HdivPos. }
  claim HfR: apply_fun bounded_transform_phi t :e R.
  { exact (bounded_transform_phi_value_in_R t HtR). }
  claim Hlt0f: Rlt 0 (apply_fun bounded_transform_phi t).
  { exact (RltI 0 (apply_fun bounded_transform_phi t) real_0 HfR HfPos). }
  claim HrelF: order_rel R 0 (apply_fun bounded_transform_phi t).
  { exact (Rlt_implies_order_rel_R 0 (apply_fun bounded_transform_phi t) Hlt0f). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_upper R 0.
  { exact (SepI R (fun x0:set => order_rel R 0 x0) (apply_fun bounded_transform_phi t) HfR HrelF). }
  exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R 0) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_upper_strict_mid : forall a:set,
  a :e R -> Rlt (minus_SNo 1) a -> Rlt a 1 ->
  preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
let a.
assume HaR: a :e R.
assume Hm1lta: Rlt (minus_SNo 1) a.
assume Halt1: Rlt a 1.
prove preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
apply xm (Rlt a 0).
- assume Halt0: Rlt a 0.
  set c := div_SNo a (add_SNo 1 a).
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = open_ray_upper R c.
  { rewrite (bounded_transform_phi_preimage_open_ray_upper_neg_case_eq a HaR Halt0 Hm1lta).
    reflexivity. }
  rewrite HpreEq.
  claim HcR: c :e R.
  { exact (real_div_SNo a HaR (add_SNo 1 a) (real_add_SNo 1 real_1 a HaR)). }
  (** open rays are open in the standard topology **)
  rewrite <- standard_topology_is_order_topology.
  claim HsRay: open_ray_upper R c :e open_rays_subbasis R.
  { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
  exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) HsRay).
- assume Hnlt0: ~(Rlt a 0).
  claim Ha0le: Rle 0 a.
  { exact (RleI 0 a real_0 HaR Hnlt0). }
  apply xm (a = 0).
  + assume Ha0: a = 0.
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = open_ray_upper R 0.
    { rewrite Ha0.
      exact bounded_transform_phi_preimage_open_ray_upper_zero_eq. }
    rewrite HpreEq.
    rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_upper R 0 :e open_rays_subbasis R.
    { exact (open_ray_upper_in_open_rays_subbasis R 0 real_0). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R 0) HsRay).
  + assume HaNeq0: ~(a = 0).
    claim HaS: SNo a.
    { exact (real_SNo a HaR). }
    claim H0lta: Rlt 0 a.
    { apply (SNoLt_trichotomy_or_impred a 0 HaS SNo_0 (Rlt 0 a)).
      - assume Halt: a < 0.
        apply FalseE.
        exact (Hnlt0 (RltI a 0 HaR real_0 Halt)).
      - assume Heq: a = 0.
        apply FalseE.
        exact (HaNeq0 Heq).
      - assume Hgt: 0 < a.
        exact (RltI 0 a real_0 HaR Hgt). }
    set c := div_SNo a (add_SNo 1 (minus_SNo a)).
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = open_ray_upper R c.
    { rewrite (bounded_transform_phi_preimage_open_ray_upper_pos_case_eq a HaR H0lta Halt1).
      reflexivity. }
    rewrite HpreEq.
    claim HcR: c :e R.
    { claim HmaR: minus_SNo a :e R.
      { exact (real_minus_SNo a HaR). }
      exact (real_div_SNo a HaR (add_SNo 1 (minus_SNo a)) (real_add_SNo 1 real_1 (minus_SNo a) HmaR)). }
    rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_upper R c :e open_rays_subbasis R.
    { exact (open_ray_upper_in_open_rays_subbasis R c HcR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_upper R c) HsRay).
Qed.

(** helper for §35: preimage of an upper open ray, middle case **)
Theorem bounded_transform_phi_preimage_open_ray_upper_mid : forall a:set,
  a :e R -> ~(Rlt a (minus_SNo 1)) -> Rlt a 1 ->
  preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
let a.
assume HaR: a :e R.
assume Hnltm1: ~(Rlt a (minus_SNo 1)).
assume Halt1: Rlt a 1.
prove preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
apply xm (a = minus_SNo 1).
- assume HaEq: a = minus_SNo 1.
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
      exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre).
    - let t. assume HtR: t :e R.
      prove t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim Hbounds: Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t) /\
                     Rlt (apply_fun bounded_transform_phi t) 1.
      { exact (bounded_transform_phi_strict_bounds t HtR). }
      claim Hm1lt: Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t).
      { exact (andEL (Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t))
                     (Rlt (apply_fun bounded_transform_phi t) 1) Hbounds). }
      claim HltA: Rlt a (apply_fun bounded_transform_phi t).
      { rewrite HaEq.
        exact Hm1lt. }
      claim Hrel: order_rel R a (apply_fun bounded_transform_phi t).
      { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) HltA). }
      claim HftRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
      { exact (SepI R (fun x:set => order_rel R a x) (apply_fun bounded_transform_phi t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume HaNeq: ~(a = minus_SNo 1).
  claim Hm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (SNo_minus_SNo 1 SNo_1). }
  claim Hm1lta: Rlt (minus_SNo 1) a.
  { apply (SNoLt_trichotomy_or_impred a (minus_SNo 1) HaS Hm1S (Rlt (minus_SNo 1) a)).
    - assume Halt: a < minus_SNo 1.
      apply FalseE.
      claim HaltR: Rlt a (minus_SNo 1).
      { exact (RltI a (minus_SNo 1) HaR Hm1R Halt). }
      exact (Hnltm1 HaltR).
    - assume Heq: a = minus_SNo 1.
      apply FalseE.
      exact (HaNeq Heq).
    - assume Hgt: minus_SNo 1 < a.
      exact (RltI (minus_SNo 1) a Hm1R HaR Hgt). }
  exact (bounded_transform_phi_preimage_open_ray_upper_strict_mid a HaR Hm1lta Halt1).
Qed.

(** helper for §35: preimage of an upper open ray **)
Theorem bounded_transform_phi_preimage_open_ray_upper : forall a:set,
  a :e R -> preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
let a.
assume HaR: a :e R.
prove preimage_of R bounded_transform_phi (open_ray_upper R a) :e R_standard_topology.
apply xm (Rlt a (minus_SNo 1)).
- assume Haltm1: Rlt a (minus_SNo 1).
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
      exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre).
    - let t. assume HtR: t :e R.
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim HfCI: apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
      { exact (bounded_transform_phi_range_in_closed_interval_minus1_1 t HtR). }
      claim Hbounds: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)) /\ ~(Rlt 1 (apply_fun bounded_transform_phi t)).
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) (apply_fun bounded_transform_phi t) HfCI). }
      claim Hnlt: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)).
      { exact (andEL (~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)))
                     (~(Rlt 1 (apply_fun bounded_transform_phi t))) Hbounds). }
      claim Hm1R: minus_SNo 1 :e R.
      { exact (real_minus_SNo 1 real_1). }
      claim Hm1le: Rle (minus_SNo 1) (apply_fun bounded_transform_phi t).
      { exact (RleI (minus_SNo 1) (apply_fun bounded_transform_phi t) Hm1R HfR Hnlt). }
      claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
      { exact (Rlt_Rle_tra a (minus_SNo 1) (apply_fun bounded_transform_phi t) Haltm1 Hm1le). }
      claim Hrel: order_rel R a (apply_fun bounded_transform_phi t).
      { exact (Rlt_implies_order_rel_R a (apply_fun bounded_transform_phi t) Haltf). }
      claim HftRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
      { exact (SepI R (fun x:set => order_rel R a x) (apply_fun bounded_transform_phi t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume Hnltm1: ~(Rlt a (minus_SNo 1)).
  apply xm (Rlt a 1).
  + assume Halt1: Rlt a 1.
    exact (bounded_transform_phi_preimage_open_ray_upper_mid a HaR Hnltm1 Halt1).
  + assume Hnlt1: ~(Rlt a 1).
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_upper R a) = Empty.
    { apply set_ext.
      - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
        prove t :e Empty.
        apply FalseE.
        claim HtR: t :e R.
        { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
        claim HfR: apply_fun bounded_transform_phi t :e R.
        { exact (bounded_transform_phi_value_in_R t HtR). }
        claim HfCI: apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
        { exact (bounded_transform_phi_range_in_closed_interval_minus1_1 t HtR). }
        claim Hbounds: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)) /\ ~(Rlt 1 (apply_fun bounded_transform_phi t)).
        { exact (SepE2 R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) (apply_fun bounded_transform_phi t) HfCI). }
        claim Hnlt1f: ~(Rlt 1 (apply_fun bounded_transform_phi t)).
        { exact (andER (~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)))
                       (~(Rlt 1 (apply_fun bounded_transform_phi t))) Hbounds). }
        claim HfaRay: apply_fun bounded_transform_phi t :e open_ray_upper R a.
        { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_upper R a) t HtPre). }
        claim Hrel: order_rel R a (apply_fun bounded_transform_phi t).
        { exact (SepE2 R (fun x0:set => order_rel R a x0) (apply_fun bounded_transform_phi t) HfaRay). }
        claim Haltf: Rlt a (apply_fun bounded_transform_phi t).
        { exact (order_rel_R_implies_Rlt a (apply_fun bounded_transform_phi t) Hrel). }
        claim Hle1A: Rle 1 a.
        { exact (RleI 1 a real_1 HaR Hnlt1). }
        claim H1ltf: Rlt 1 (apply_fun bounded_transform_phi t).
        { exact (Rle_Rlt_tra 1 a (apply_fun bounded_transform_phi t) Hle1A Haltf). }
        exact (Hnlt1f H1ltf).
      - let t. assume HtE: t :e Empty.
        prove t :e preimage_of R bounded_transform_phi (open_ray_upper R a).
        apply FalseE.
        exact (EmptyE t HtE). }
    rewrite HpreEq.
    exact (topology_has_empty R R_standard_topology R_standard_topology_is_topology).
Qed.

(** helper for §35: preimage of a lower open ray, middle case **)
Theorem bounded_transform_phi_preimage_open_ray_lower_neg_case_eq : forall b:set,
  b :e R -> Rlt b 0 -> Rlt (minus_SNo 1) b ->
  preimage_of R bounded_transform_phi (open_ray_lower R b) =
  open_ray_lower R (div_SNo b (add_SNo 1 b)).
let b.
assume HbR: b :e R.
assume Hblt0: Rlt b 0.
assume Hm1ltb: Rlt (minus_SNo 1) b.
set denB := add_SNo 1 b.
set c := div_SNo b denB.
prove preimage_of R bounded_transform_phi (open_ray_lower R b) = open_ray_lower R c.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
  prove t :e open_ray_lower R c.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
  claim Hrel: order_rel R (apply_fun bounded_transform_phi t) b.
  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfRay). }
  claim HfltB: Rlt (apply_fun bounded_transform_phi t) b.
  { exact (order_rel_R_implies_Rlt (apply_fun bounded_transform_phi t) b Hrel). }
  claim Hflt0: Rlt (apply_fun bounded_transform_phi t) 0.
  { exact (Rlt_tra (apply_fun bounded_transform_phi t) b 0 HfltB Hblt0). }
  claim Htlt0: Rlt t 0.
  { exact (bounded_transform_phi_Rlt0_implies_Rlt0_neg t HtR Hflt0). }
  claim Htlt0S: t < 0.
  { exact (RltE_lt t 0 Htlt0). }
  claim HabsEq: abs_SNo t = minus_SNo t.
  { exact (neg_abs_SNo t HtS Htlt0S). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR))). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR)) SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HfltS: div_SNo t den < b.
  { rewrite <- HfEq.
    exact (RltE_lt (apply_fun bounded_transform_phi t) b HfltB). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HtLtBden: t < mul_SNo b den.
  { exact (div_SNo_pos_LtL' t den b HtS HdenS HbS HdenPos HfltS). }
  set bt := mul_SNo b t.
  claim HbtS: SNo bt.
  { exact (SNo_mul_SNo b t HbS HtS). }
  claim HtDenEq: mul_SNo b den = add_SNo b (minus_SNo bt).
  { rewrite HabsEq at 1.
    rewrite (mul_SNo_distrL b 1 (minus_SNo t) HbS SNo_1 (SNo_minus_SNo t HtS)).
    rewrite (mul_SNo_oneR b HbS).
    rewrite (mul_SNo_minus_distrR b t HbS HtS).
    reflexivity. }
  claim HtLtBminus: t < add_SNo b (minus_SNo bt).
  { rewrite <- HtDenEq.
    exact HtLtBden. }
  claim Hstep: add_SNo t bt < add_SNo (add_SNo b (minus_SNo bt)) bt.
  { exact (add_SNo_Lt1 t bt (add_SNo b (minus_SNo bt)) HtS HbtS (SNo_add_SNo b (minus_SNo bt) HbS (SNo_minus_SNo bt HbtS)) HtLtBminus). }
  claim HrightEq: add_SNo (add_SNo b (minus_SNo bt)) bt = b.
  { exact (add_SNo_minus_R2' b bt HbS HbtS). }
  claim HtPlusBtLtB: add_SNo t bt < b.
  { rewrite <- HrightEq at 2.
    exact Hstep. }
  claim HdenBS: SNo denB.
  { exact (SNo_add_SNo 1 b SNo_1 HbS). }
  claim Htmp: add_SNo (minus_SNo 1) 1 < add_SNo b 1.
  { exact (add_SNo_Lt1 (minus_SNo 1) 1 b (SNo_minus_SNo 1 SNo_1) SNo_1 HbS (RltE_lt (minus_SNo 1) b Hm1ltb)). }
  claim HdenBpos0: 0 < add_SNo 1 b.
  { rewrite <- (add_SNo_minus_SNo_linv 1 SNo_1) at 1.
    rewrite (add_SNo_com 1 b SNo_1 HbS).
    exact Htmp. }
  claim HdenBpos: 0 < denB.
  { exact HdenBpos0. }
  claim HtDenBEq: mul_SNo t denB = add_SNo t bt.
  { rewrite (mul_SNo_distrL t 1 b HtS SNo_1 HbS).
    rewrite (mul_SNo_oneR t HtS).
    rewrite (mul_SNo_com t b HtS HbS).
    reflexivity. }
  claim HtDenBLtB: mul_SNo t denB < b.
  { rewrite HtDenBEq.
    exact HtPlusBtLtB. }
  claim HcLtT: t < div_SNo b denB.
  { exact (div_SNo_pos_LtR b denB t HbS HdenBS HtS HdenBpos HtDenBLtB). }
  claim HcR: c :e R.
  { exact (real_div_SNo b HbR denB (real_add_SNo 1 real_1 b HbR)). }
  claim HcLtTR: Rlt t c.
  { exact (RltI t c HtR HcR HcLtT). }
  claim Hrelct: order_rel R t c.
  { exact (Rlt_implies_order_rel_R t c HcLtTR). }
  exact (SepI R (fun x0:set => order_rel R x0 c) t HtR Hrelct).
- let t. assume HtRay: t :e open_ray_lower R c.
  prove t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R x0 c) t HtRay). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim Hrelct: order_rel R t c.
  { exact (SepE2 R (fun x0:set => order_rel R x0 c) t HtRay). }
  claim Htltc: Rlt t c.
  { exact (order_rel_R_implies_Rlt t c Hrelct). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HdenBS: SNo denB.
  { exact (SNo_add_SNo 1 b SNo_1 HbS). }
  claim Htmp: add_SNo (minus_SNo 1) 1 < add_SNo b 1.
  { exact (add_SNo_Lt1 (minus_SNo 1) 1 b (SNo_minus_SNo 1 SNo_1) SNo_1 HbS (RltE_lt (minus_SNo 1) b Hm1ltb)). }
  claim HdenBpos0: 0 < add_SNo 1 b.
  { rewrite <- (add_SNo_minus_SNo_linv 1 SNo_1) at 1.
    rewrite (add_SNo_com 1 b SNo_1 HbS).
    exact Htmp. }
  claim HdenBpos: 0 < denB.
  { exact HdenBpos0. }
  claim HcS: SNo c.
  { exact (real_SNo c (real_div_SNo b HbR denB (real_add_SNo 1 real_1 b HbR))). }
  claim HtLtS: t < c.
  { exact (RltE_lt t c Htltc). }
  claim HtDenBLtB: mul_SNo t denB < b.
  { exact (div_SNo_pos_LtR' b denB t HbS HdenBS HtS HdenBpos HtLtS). }
  set bt := mul_SNo b t.
  claim HbtS: SNo bt.
  { exact (SNo_mul_SNo b t HbS HtS). }
  claim HtDenBEq: mul_SNo t denB = add_SNo t bt.
  { rewrite (mul_SNo_distrL t 1 b HtS SNo_1 HbS).
    rewrite (mul_SNo_oneR t HtS).
    rewrite (mul_SNo_com t b HtS HbS).
    reflexivity. }
  claim HtPlusBtLtB: add_SNo t bt < b.
  { rewrite <- HtDenBEq.
    exact HtDenBLtB. }
  claim Hstep: add_SNo (add_SNo t bt) (minus_SNo bt) < add_SNo b (minus_SNo bt).
  { exact (add_SNo_Lt1 (add_SNo t bt) (minus_SNo bt) b (SNo_add_SNo t bt HtS HbtS) (SNo_minus_SNo bt HbtS) HbS HtPlusBtLtB). }
  claim HleftEq: add_SNo (add_SNo t bt) (minus_SNo bt) = t.
  { exact (add_SNo_minus_R2 t bt HtS HbtS). }
  claim HtLtBminus: t < add_SNo b (minus_SNo bt).
  { rewrite <- HleftEq at 1.
    exact Hstep. }
  claim HcLt0S: c < 0.
  { exact (div_SNo_neg_pos b denB HbS HdenBS (RltE_lt b 0 Hblt0) HdenBpos). }
  claim HtltcS: t < c.
  { exact (RltE_lt t c Htltc). }
  claim HtLt0S: t < 0.
  { exact (SNoLt_tra t c 0 HtS HcS SNo_0 HtltcS HcLt0S). }
  claim HabsEq: abs_SNo t = minus_SNo t.
  { exact (neg_abs_SNo t HtS HtLt0S). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR))). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR)) SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HtDenEq: mul_SNo b den = add_SNo b (minus_SNo bt).
  { rewrite HabsEq at 1.
    rewrite (mul_SNo_distrL b 1 (minus_SNo t) HbS SNo_1 (SNo_minus_SNo t HtS)).
    rewrite (mul_SNo_oneR b HbS).
    rewrite (mul_SNo_minus_distrR b t HbS HtS).
    reflexivity. }
  claim HtLtBden: t < mul_SNo b den.
  { rewrite HtDenEq.
    exact HtLtBminus. }
  claim HfltS: div_SNo t den < b.
  { exact (div_SNo_pos_LtL t den b HtS HdenS HbS HdenPos HtLtBden). }
  claim HfR: apply_fun bounded_transform_phi t :e R.
  { exact (bounded_transform_phi_value_in_R t HtR). }
  claim HfltB: Rlt (apply_fun bounded_transform_phi t) b.
  { rewrite HfEq.
    exact (RltI (div_SNo t den) b (real_div_SNo t HtR den (real_add_SNo 1 real_1 (abs_SNo t) (abs_SNo_in_R t HtR))) HbR HfltS). }
  claim Hrelfb: order_rel R (apply_fun bounded_transform_phi t) b.
  { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) b HfltB). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
  { exact (SepI R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfR Hrelfb). }
  exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_lower_pos_case_eq : forall b:set,
  b :e R -> Rlt 0 b -> Rlt b 1 ->
  preimage_of R bounded_transform_phi (open_ray_lower R b) =
  open_ray_lower R (div_SNo b (add_SNo 1 (minus_SNo b))).
let b.
assume HbR: b :e R.
assume H0ltb: Rlt 0 b.
assume Hblt1: Rlt b 1.
set denB := add_SNo 1 (minus_SNo b).
set c := div_SNo b denB.
prove preimage_of R bounded_transform_phi (open_ray_lower R b) = open_ray_lower R c.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
  prove t :e open_ray_lower R c.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
  claim Hrel: order_rel R (apply_fun bounded_transform_phi t) b.
  { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfRay). }
  claim HfltB: Rlt (apply_fun bounded_transform_phi t) b.
  { exact (order_rel_R_implies_Rlt (apply_fun bounded_transform_phi t) b Hrel). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HbPosS: 0 < b.
  { exact (RltE_lt 0 b H0ltb). }
  claim HbLt1S: b < 1.
  { exact (RltE_lt b 1 Hblt1). }
  claim HmaS: SNo (minus_SNo b).
  { exact (SNo_minus_SNo b HbS). }
  claim HdenBS: SNo denB.
  { exact (SNo_add_SNo 1 (minus_SNo b) SNo_1 HmaS). }
  claim Htmp: add_SNo b (minus_SNo b) < add_SNo 1 (minus_SNo b).
  { exact (add_SNo_Lt1 b (minus_SNo b) 1 HbS HmaS SNo_1 HbLt1S). }
  claim HdenBpos: 0 < denB.
  { rewrite <- (add_SNo_minus_SNo_rinv b HbS) at 1.
    exact Htmp. }
  claim HcR: c :e R.
  { claim HmbR: minus_SNo b :e R.
    { exact (real_minus_SNo b HbR). }
    exact (real_div_SNo b HbR denB (real_add_SNo 1 real_1 (minus_SNo b) HmbR)). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HcPosS: 0 < c.
  { exact (div_SNo_pos_pos b denB HbS HdenBS HbPosS HdenBpos). }
  apply xm (0 <= t).
  + assume H0let: 0 <= t.
    claim HabsEq: abs_SNo t = t.
    { exact (nonneg_abs_SNo t H0let). }
    set den := add_SNo 1 t.
    claim HdenS: SNo den.
    { exact (SNo_add_SNo 1 t SNo_1 HtS). }
    claim HdenPos0: add_SNo 0 0 < den.
    { exact (add_SNo_Lt3a 0 0 1 t SNo_0 SNo_0 SNo_1 HtS SNoLt_0_1 H0let). }
    claim HdenPos: 0 < den.
    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact HdenPos0. }
    claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
    { reflexivity. }
    claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
    { rewrite HphiDef.
      rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
      rewrite HabsEq.
      reflexivity. }
    claim HfltS: div_SNo t den < b.
    { rewrite <- HfEq.
      exact (RltE_lt (apply_fun bounded_transform_phi t) b HfltB). }
    claim HtLtBden: t < mul_SNo b den.
    { exact (div_SNo_pos_LtL' t den b HtS HdenS HbS HdenPos HfltS). }
    set bt := mul_SNo b t.
    claim HbtS: SNo bt.
    { exact (SNo_mul_SNo b t HbS HtS). }
    claim HtDenEq: mul_SNo b den = add_SNo b bt.
    { rewrite (mul_SNo_distrL b 1 t HbS SNo_1 HtS).
      rewrite (mul_SNo_oneR b HbS).
      reflexivity. }
    claim HtLtBplus: t < add_SNo b bt.
    { rewrite <- HtDenEq.
      exact HtLtBden. }
    claim Hstep1: add_SNo t (minus_SNo bt) < add_SNo (add_SNo b bt) (minus_SNo bt).
    { exact (add_SNo_Lt1 t (minus_SNo bt) (add_SNo b bt) HtS (SNo_minus_SNo bt HbtS)
             (SNo_add_SNo b bt HbS HbtS) HtLtBplus). }
    claim HrightEq1: add_SNo (add_SNo b bt) (minus_SNo bt) = b.
    { exact (add_SNo_minus_R2 b bt HbS HbtS). }
    claim HtMinusBtLtB: add_SNo t (minus_SNo bt) < b.
    { rewrite <- HrightEq1 at 2.
      exact Hstep1. }
    claim HtDenBEq: mul_SNo t denB = add_SNo t (minus_SNo bt).
    { rewrite (mul_SNo_distrL t 1 (minus_SNo b) HtS SNo_1 HmaS).
      rewrite (mul_SNo_oneR t HtS).
      rewrite (mul_SNo_minus_distrR t b HtS HbS).
      rewrite (mul_SNo_com t b HtS HbS).
      reflexivity. }
    claim HtDenBLtB: mul_SNo t denB < b.
    { rewrite HtDenBEq.
      exact HtMinusBtLtB. }
    claim HtLtC: t < div_SNo b denB.
    { exact (div_SNo_pos_LtR b denB t HbS HdenBS HtS HdenBpos HtDenBLtB). }
    claim HtLtCR: Rlt t c.
    { exact (RltI t c HtR HcR HtLtC). }
    claim Hreltc: order_rel R t c.
    { exact (Rlt_implies_order_rel_R t c HtLtCR). }
    exact (SepI R (fun x0:set => order_rel R x0 c) t HtR Hreltc).
	  + assume Hn0let: ~(0 <= t).
	    claim HtLt0S: t < 0.
	    { apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (t < 0)).
	      - assume Htlt0: t < 0.
	        exact Htlt0.
	      - assume Heq: t = 0.
	        apply FalseE.
		        claim H0let: 0 <= t.
		        { rewrite Heq.
		          exact (SNoLe_ref 0). }
	        exact (Hn0let H0let).
	      - assume Htgt0: 0 < t.
	        apply FalseE.
	        exact (Hn0let (SNoLtLe 0 t Htgt0)). }
	    claim HtLtC: t < c.
	    { exact (SNoLt_tra t 0 c HtS SNo_0 HcS HtLt0S HcPosS). }
	    claim HtLtCR: Rlt t c.
	    { exact (RltI t c HtR HcR HtLtC). }
	    claim Hreltc: order_rel R t c.
	    { exact (Rlt_implies_order_rel_R t c HtLtCR). }
	    exact (SepI R (fun x0:set => order_rel R x0 c) t HtR Hreltc).
- let t. assume HtRay: t :e open_ray_lower R c.
  prove t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R x0 c) t HtRay). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim Hreltc: order_rel R t c.
  { exact (SepE2 R (fun x0:set => order_rel R x0 c) t HtRay). }
  claim Htltc: Rlt t c.
  { exact (order_rel_R_implies_Rlt t c Hreltc). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HbPosS: 0 < b.
  { exact (RltE_lt 0 b H0ltb). }
  claim HbLt1S: b < 1.
  { exact (RltE_lt b 1 Hblt1). }
  claim HmaS: SNo (minus_SNo b).
  { exact (SNo_minus_SNo b HbS). }
  claim HdenBS: SNo denB.
  { exact (SNo_add_SNo 1 (minus_SNo b) SNo_1 HmaS). }
  claim Htmp: add_SNo b (minus_SNo b) < add_SNo 1 (minus_SNo b).
  { exact (add_SNo_Lt1 b (minus_SNo b) 1 HbS HmaS SNo_1 HbLt1S). }
  claim HdenBpos: 0 < denB.
  { rewrite <- (add_SNo_minus_SNo_rinv b HbS) at 1.
    exact Htmp. }
  claim HcR: c :e R.
  { claim HmbR: minus_SNo b :e R.
    { exact (real_minus_SNo b HbR). }
    exact (real_div_SNo b HbR denB (real_add_SNo 1 real_1 (minus_SNo b) HmbR)). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  apply xm (0 <= t).
  + assume H0let: 0 <= t.
    claim HabsEq: abs_SNo t = t.
    { exact (nonneg_abs_SNo t H0let). }
    set den := add_SNo 1 t.
    claim HdenS: SNo den.
    { exact (SNo_add_SNo 1 t SNo_1 HtS). }
    claim HdenPos0: add_SNo 0 0 < den.
    { exact (add_SNo_Lt3a 0 0 1 t SNo_0 SNo_0 SNo_1 HtS SNoLt_0_1 H0let). }
    claim HdenPos: 0 < den.
    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact HdenPos0. }
    claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
    { reflexivity. }
    claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
    { rewrite HphiDef.
      rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
      rewrite HabsEq.
      reflexivity. }
    claim HtLtC: t < div_SNo b denB.
    { exact (RltE_lt t c Htltc). }
    claim HtDenBLtB: mul_SNo t denB < b.
    { exact (div_SNo_pos_LtR' b denB t HbS HdenBS HtS HdenBpos HtLtC). }
    set bt := mul_SNo b t.
    claim HbtS: SNo bt.
    { exact (SNo_mul_SNo b t HbS HtS). }
    claim HtDenBEq: mul_SNo t denB = add_SNo t (minus_SNo bt).
    { rewrite (mul_SNo_distrL t 1 (minus_SNo b) HtS SNo_1 HmaS).
      rewrite (mul_SNo_oneR t HtS).
      rewrite (mul_SNo_minus_distrR t b HtS HbS).
      rewrite (mul_SNo_com t b HtS HbS).
      reflexivity. }
    claim HtMinusBtLtB: add_SNo t (minus_SNo bt) < b.
    { rewrite <- HtDenBEq.
      exact HtDenBLtB. }
    claim Hstep1: add_SNo (add_SNo t (minus_SNo bt)) bt < add_SNo b bt.
    { exact (add_SNo_Lt1 (add_SNo t (minus_SNo bt)) bt b
             (SNo_add_SNo t (minus_SNo bt) HtS (SNo_minus_SNo bt HbtS)) HbtS HbS HtMinusBtLtB). }
    claim HleftEq1: add_SNo (add_SNo t (minus_SNo bt)) bt = t.
    { exact (add_SNo_minus_R2' t bt HtS HbtS). }
    claim HtLtBplus: t < add_SNo b bt.
    { rewrite <- HleftEq1 at 1.
      exact Hstep1. }
    claim HbDenEq: mul_SNo b den = add_SNo b bt.
    { rewrite (mul_SNo_distrL b 1 t HbS SNo_1 HtS).
      rewrite (mul_SNo_oneR b HbS).
      reflexivity. }
    claim HtLtBden: t < mul_SNo b den.
    { rewrite HbDenEq.
      exact HtLtBplus. }
    claim HfltS: div_SNo t den < b.
    { exact (div_SNo_pos_LtL t den b HtS HdenS HbS HdenPos HtLtBden). }
    claim HfR: apply_fun bounded_transform_phi t :e R.
    { exact (bounded_transform_phi_value_in_R t HtR). }
    claim HfltB: Rlt (apply_fun bounded_transform_phi t) b.
    { rewrite HfEq.
      exact (RltI (div_SNo t den) b (real_div_SNo t HtR den (real_add_SNo 1 real_1 t HtR)) HbR HfltS). }
    claim Hrelfb: order_rel R (apply_fun bounded_transform_phi t) b.
    { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) b HfltB). }
    claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
    { exact (SepI R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfR Hrelfb). }
    exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtR HfRay).
  + assume Hn0let: ~(0 <= t).
    claim HtLt0S: t < 0.
    { apply (SNoLt_trichotomy_or_impred t 0 HtS SNo_0 (t < 0)).
      - assume Htlt0: t < 0.
        exact Htlt0.
      - assume Heq: t = 0.
        apply FalseE.
        claim H0let: 0 <= t.
        { rewrite Heq.
          exact (SNoLe_ref 0). }
        exact (Hn0let H0let).
      - assume Htgt0: 0 < t.
        apply FalseE.
        exact (Hn0let (SNoLtLe 0 t Htgt0)). }
    claim HabsEq: abs_SNo t = minus_SNo t.
    { exact (neg_abs_SNo t HtS HtLt0S). }
    set den := add_SNo 1 (abs_SNo t).
    claim HdenS: SNo den.
    { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR))). }
    claim H0le_abs: 0 <= abs_SNo t.
    { exact (abs_SNo_nonneg t HtS). }
    claim HdenPos0: add_SNo 0 0 < den.
    { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 (real_SNo (abs_SNo t) (abs_SNo_in_R t HtR)) SNoLt_0_1 H0le_abs). }
    claim HdenPos: 0 < den.
    { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
      exact HdenPos0. }
    claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
    { reflexivity. }
    claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
    { rewrite HphiDef.
      rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
      reflexivity. }
    claim HdivNeg: div_SNo t den < 0.
    { exact (div_SNo_neg_pos t den HtS HdenS HtLt0S HdenPos). }
    claim HfLt0: Rlt (apply_fun bounded_transform_phi t) 0.
    { rewrite HfEq.
      exact (RltI (div_SNo t den) 0 (real_div_SNo t HtR den (real_add_SNo 1 real_1 (abs_SNo t) (abs_SNo_in_R t HtR))) real_0 HdivNeg). }
    claim HfltB: Rlt (apply_fun bounded_transform_phi t) b.
    { exact (Rlt_tra (apply_fun bounded_transform_phi t) 0 b HfLt0 H0ltb). }
    claim HfR: apply_fun bounded_transform_phi t :e R.
    { exact (bounded_transform_phi_value_in_R t HtR). }
    claim Hrelfb: order_rel R (apply_fun bounded_transform_phi t) b.
    { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) b HfltB). }
    claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
    { exact (SepI R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfR Hrelfb). }
    exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_lower_zero_eq :
  preimage_of R bounded_transform_phi (open_ray_lower R 0) = open_ray_lower R 0.
apply set_ext.
- let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R 0).
  prove t :e open_ray_lower R 0.
  claim HtR: t :e R.
  { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R 0) t HtPre). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R 0.
  { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R 0) t HtPre). }
  claim Hrel: order_rel R (apply_fun bounded_transform_phi t) 0.
  { exact (SepE2 R (fun x0:set => order_rel R x0 0) (apply_fun bounded_transform_phi t) HfRay). }
  claim Hltf0: Rlt (apply_fun bounded_transform_phi t) 0.
  { exact (order_rel_R_implies_Rlt (apply_fun bounded_transform_phi t) 0 Hrel). }
  claim HfLtS: apply_fun bounded_transform_phi t < 0.
  { exact (RltE_lt (apply_fun bounded_transform_phi t) 0 Hltf0). }
  claim HabsR: abs_SNo t :e R.
  { exact (abs_SNo_in_R t HtR). }
  claim HabsS: SNo (abs_SNo t).
  { exact (real_SNo (abs_SNo t) HabsR). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HdivLt: div_SNo t den < 0.
  { rewrite <- HfEq.
    exact HfLtS. }
  claim HtLt0den: t < mul_SNo 0 den.
  { exact (div_SNo_pos_LtL' t den 0 HtS HdenS SNo_0 HdenPos HdivLt). }
  claim HtNegS: t < 0.
  { rewrite <- (mul_SNo_zeroL den HdenS).
    exact HtLt0den. }
  claim HtNeg: Rlt t 0.
  { exact (RltI t 0 HtR real_0 HtNegS). }
  claim HrelT: order_rel R t 0.
  { exact (Rlt_implies_order_rel_R t 0 HtNeg). }
  exact (SepI R (fun x0:set => order_rel R x0 0) t HtR HrelT).
- let t. assume HtRay: t :e open_ray_lower R 0.
  prove t :e preimage_of R bounded_transform_phi (open_ray_lower R 0).
  claim HtR: t :e R.
  { exact (SepE1 R (fun x0:set => order_rel R x0 0) t HtRay). }
  claim HtS: SNo t.
  { exact (real_SNo t HtR). }
  claim HrelT: order_rel R t 0.
  { exact (SepE2 R (fun x0:set => order_rel R x0 0) t HtRay). }
  claim Hlt0t: Rlt t 0.
  { exact (order_rel_R_implies_Rlt t 0 HrelT). }
  claim HtNegS: t < 0.
  { exact (RltE_lt t 0 Hlt0t). }
  claim HabsR: abs_SNo t :e R.
  { exact (abs_SNo_in_R t HtR). }
  claim HabsS: SNo (abs_SNo t).
  { exact (real_SNo (abs_SNo t) HabsR). }
  set den := add_SNo 1 (abs_SNo t).
  claim HdenS: SNo den.
  { exact (SNo_add_SNo 1 (abs_SNo t) SNo_1 HabsS). }
  claim H0le_abs: 0 <= abs_SNo t.
  { exact (abs_SNo_nonneg t HtS). }
  claim HdenPos0: add_SNo 0 0 < den.
  { exact (add_SNo_Lt3a 0 0 1 (abs_SNo t) SNo_0 SNo_0 SNo_1 HabsS SNoLt_0_1 H0le_abs). }
  claim HdenPos: 0 < den.
  { rewrite <- (add_SNo_0L 0 SNo_0) at 1.
    exact HdenPos0. }
  claim HdivNeg: div_SNo t den < 0.
  { exact (div_SNo_neg_pos t den HtS HdenS HtNegS HdenPos). }
  claim HphiDef: bounded_transform_phi = graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))).
  { reflexivity. }
  claim HfEq: apply_fun bounded_transform_phi t = div_SNo t den.
  { rewrite HphiDef.
    rewrite (apply_fun_graph R (fun t0:set => div_SNo t0 (add_SNo 1 (abs_SNo t0))) t HtR).
    reflexivity. }
  claim HfNegS: apply_fun bounded_transform_phi t < 0.
  { rewrite HfEq.
    exact HdivNeg. }
  claim HfR: apply_fun bounded_transform_phi t :e R.
  { exact (bounded_transform_phi_value_in_R t HtR). }
  claim Hltf0: Rlt (apply_fun bounded_transform_phi t) 0.
  { exact (RltI (apply_fun bounded_transform_phi t) 0 HfR real_0 HfNegS). }
  claim HrelF: order_rel R (apply_fun bounded_transform_phi t) 0.
  { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) 0 Hltf0). }
  claim HfRay: apply_fun bounded_transform_phi t :e open_ray_lower R 0.
  { exact (SepI R (fun x0:set => order_rel R x0 0) (apply_fun bounded_transform_phi t) HfR HrelF). }
  exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R 0) t HtR HfRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_lower_strict_mid : forall b:set,
  b :e R -> Rlt (minus_SNo 1) b -> Rlt b 1 ->
  preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
let b.
assume HbR: b :e R.
assume Hm1ltb: Rlt (minus_SNo 1) b.
assume Hblt1: Rlt b 1.
prove preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
apply xm (Rlt b 0).
- assume Hlt0: Rlt b 0.
  set c := div_SNo b (add_SNo 1 b).
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = open_ray_lower R c.
  { rewrite (bounded_transform_phi_preimage_open_ray_lower_neg_case_eq b HbR Hlt0 Hm1ltb).
    reflexivity. }
  rewrite HpreEq.
  claim HcR: c :e R.
  { exact (real_div_SNo b HbR (add_SNo 1 b) (real_add_SNo 1 real_1 b HbR)). }
  rewrite <- standard_topology_is_order_topology.
  claim HsRay: open_ray_lower R c :e open_rays_subbasis R.
  { exact (open_ray_lower_in_open_rays_subbasis R c HcR). }
  exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R c) HsRay).
- assume Hnlt0: ~(Rlt b 0).
  claim Hb0le: Rle 0 b.
  { exact (RleI 0 b real_0 HbR Hnlt0). }
  apply xm (b = 0).
  + assume Hb0: b = 0.
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = open_ray_lower R 0.
    { rewrite Hb0.
      exact bounded_transform_phi_preimage_open_ray_lower_zero_eq. }
    rewrite HpreEq.
    rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_lower R 0 :e open_rays_subbasis R.
    { exact (open_ray_lower_in_open_rays_subbasis R 0 real_0). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R 0) HsRay).
  + assume HbNeq0: ~(b = 0).
    claim HbS: SNo b.
    { exact (real_SNo b HbR). }
    claim H0ltb: Rlt 0 b.
    { apply (SNoLt_trichotomy_or_impred b 0 HbS SNo_0 (Rlt 0 b)).
      - assume Hlt: b < 0.
        apply FalseE.
        exact (Hnlt0 (RltI b 0 HbR real_0 Hlt)).
      - assume Heq: b = 0.
        apply FalseE.
        exact (HbNeq0 Heq).
      - assume Hgt: 0 < b.
        exact (RltI 0 b real_0 HbR Hgt). }
    set c := div_SNo b (add_SNo 1 (minus_SNo b)).
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = open_ray_lower R c.
    { rewrite (bounded_transform_phi_preimage_open_ray_lower_pos_case_eq b HbR H0ltb Hblt1).
      reflexivity. }
    rewrite HpreEq.
    claim HcR: c :e R.
    { claim HmbR: minus_SNo b :e R.
      { exact (real_minus_SNo b HbR). }
      exact (real_div_SNo b HbR (add_SNo 1 (minus_SNo b)) (real_add_SNo 1 real_1 (minus_SNo b) HmbR)). }
    rewrite <- standard_topology_is_order_topology.
    claim HsRay: open_ray_lower R c :e open_rays_subbasis R.
    { exact (open_ray_lower_in_open_rays_subbasis R c HcR). }
    exact (open_rays_subbasis_sub_order_topology_R (open_ray_lower R c) HsRay).
Qed.

Theorem bounded_transform_phi_preimage_open_ray_lower_mid : forall b:set,
  b :e R -> ~(Rlt 1 b) -> Rlt (minus_SNo 1) b ->
  preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
let b.
assume HbR: b :e R.
assume Hnlt1: ~(Rlt 1 b).
assume Hm1ltb: Rlt (minus_SNo 1) b.
prove preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
apply xm (b = 1).
- assume HbEq: b = 1.
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
      exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre).
    - let t. assume HtR: t :e R.
      prove t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim Hbounds: Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t) /\
                     Rlt (apply_fun bounded_transform_phi t) 1.
      { exact (bounded_transform_phi_strict_bounds t HtR). }
      claim Hlt1: Rlt (apply_fun bounded_transform_phi t) 1.
      { exact (andER (Rlt (minus_SNo 1) (apply_fun bounded_transform_phi t))
                     (Rlt (apply_fun bounded_transform_phi t) 1) Hbounds). }
      claim HltB: Rlt (apply_fun bounded_transform_phi t) b.
      { rewrite HbEq.
        exact Hlt1. }
      claim Hrel: order_rel R (apply_fun bounded_transform_phi t) b.
      { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) b HltB). }
      claim HftRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
      { exact (SepI R (fun x:set => order_rel R x b) (apply_fun bounded_transform_phi t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume HbNeq: ~(b = 1).
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HbLt1: Rlt b 1.
  { apply (SNoLt_trichotomy_or_impred 1 b SNo_1 HbS (Rlt b 1)).
    - assume H1ltbS: 1 < b.
      apply FalseE.
      claim H1ltb: Rlt 1 b.
      { exact (RltI 1 b real_1 HbR H1ltbS). }
      exact (Hnlt1 H1ltb).
    - assume Heq: 1 = b.
      apply FalseE.
      claim Hb1: b = 1.
      { rewrite <- Heq.
        reflexivity. }
      exact (HbNeq Hb1).
    - assume Hblt1S: b < 1.
      exact (RltI b 1 HbR real_1 Hblt1S). }
  exact (bounded_transform_phi_preimage_open_ray_lower_strict_mid b HbR Hm1ltb HbLt1).
Qed.

(** helper for §35: preimage of a lower open ray **)
Theorem bounded_transform_phi_preimage_open_ray_lower : forall b:set,
  b :e R -> preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
let b.
assume HbR: b :e R.
prove preimage_of R bounded_transform_phi (open_ray_lower R b) :e R_standard_topology.
apply xm (Rlt 1 b).
- assume H1ltb: Rlt 1 b.
  claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = R.
  { apply set_ext.
    - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
      exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre).
    - let t. assume HtR: t :e R.
      claim HfR: apply_fun bounded_transform_phi t :e R.
      { exact (bounded_transform_phi_value_in_R t HtR). }
      claim HfCI: apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
      { exact (bounded_transform_phi_range_in_closed_interval_minus1_1 t HtR). }
      claim Hbounds: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)) /\ ~(Rlt 1 (apply_fun bounded_transform_phi t)).
      { exact (SepE2 R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) (apply_fun bounded_transform_phi t) HfCI). }
      claim Hnlt1f: ~(Rlt 1 (apply_fun bounded_transform_phi t)).
      { exact (andER (~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)))
                     (~(Rlt 1 (apply_fun bounded_transform_phi t))) Hbounds). }
      claim Hle: Rle (apply_fun bounded_transform_phi t) 1.
      { exact (RleI (apply_fun bounded_transform_phi t) 1 HfR real_1 Hnlt1f). }
      claim Hlt: Rlt (apply_fun bounded_transform_phi t) b.
      { exact (Rle_Rlt_tra (apply_fun bounded_transform_phi t) 1 b Hle H1ltb). }
      claim Hrel: order_rel R (apply_fun bounded_transform_phi t) b.
      { exact (Rlt_implies_order_rel_R (apply_fun bounded_transform_phi t) b Hlt). }
      claim HftRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
      { exact (SepI R (fun x:set => order_rel R x b) (apply_fun bounded_transform_phi t) HfR Hrel). }
      exact (SepI R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtR HftRay). }
  rewrite HpreEq.
  exact (topology_has_X R R_standard_topology R_standard_topology_is_topology).
- assume Hnlt1: ~(Rlt 1 b).
  apply xm (Rlt (minus_SNo 1) b).
  + assume Hm1ltb: Rlt (minus_SNo 1) b.
    exact (bounded_transform_phi_preimage_open_ray_lower_mid b HbR Hnlt1 Hm1ltb).
  + assume Hnltm1: ~(Rlt (minus_SNo 1) b).
    claim HpreEq: preimage_of R bounded_transform_phi (open_ray_lower R b) = Empty.
    { apply set_ext.
      - let t. assume HtPre: t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
        prove t :e Empty.
        apply FalseE.
        claim HtR: t :e R.
        { exact (SepE1 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
        claim HfR: apply_fun bounded_transform_phi t :e R.
        { exact (bounded_transform_phi_value_in_R t HtR). }
        claim HfCI: apply_fun bounded_transform_phi t :e closed_interval (minus_SNo 1) 1.
        { exact (bounded_transform_phi_range_in_closed_interval_minus1_1 t HtR). }
        claim Hbounds: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)) /\ ~(Rlt 1 (apply_fun bounded_transform_phi t)).
        { exact (SepE2 R (fun x0:set => ~(Rlt x0 (minus_SNo 1)) /\ ~(Rlt 1 x0)) (apply_fun bounded_transform_phi t) HfCI). }
        claim Hnltm1f: ~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)).
        { exact (andEL (~(Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1)))
                       (~(Rlt 1 (apply_fun bounded_transform_phi t))) Hbounds). }
        claim HfaRay: apply_fun bounded_transform_phi t :e open_ray_lower R b.
        { exact (SepE2 R (fun x:set => apply_fun bounded_transform_phi x :e open_ray_lower R b) t HtPre). }
        claim Hrel: order_rel R (apply_fun bounded_transform_phi t) b.
        { exact (SepE2 R (fun x0:set => order_rel R x0 b) (apply_fun bounded_transform_phi t) HfaRay). }
        claim Hlt: Rlt (apply_fun bounded_transform_phi t) b.
        { exact (order_rel_R_implies_Rlt (apply_fun bounded_transform_phi t) b Hrel). }
        claim HbLe: Rle b (minus_SNo 1).
        { claim Hm1R: minus_SNo 1 :e R.
          { exact (real_minus_SNo 1 real_1). }
          exact (RleI b (minus_SNo 1) HbR Hm1R Hnltm1). }
        claim Hltm1: Rlt (apply_fun bounded_transform_phi t) (minus_SNo 1).
        { exact (Rlt_Rle_tra (apply_fun bounded_transform_phi t) b (minus_SNo 1) Hlt HbLe). }
        exact (Hnltm1f Hltm1).
      - let t. assume HtE: t :e Empty.
        prove t :e preimage_of R bounded_transform_phi (open_ray_lower R b).
        apply FalseE.
        exact (EmptyE t HtE). }
    rewrite HpreEq.
    exact (topology_has_empty R R_standard_topology R_standard_topology_is_topology).
Qed.

(** helper for §35: bounded transform is continuous in the standard topology on R **)
Theorem bounded_transform_phi_continuous :
  continuous_map R R_standard_topology R R_standard_topology bounded_transform_phi.
prove continuous_map R R_standard_topology R R_standard_topology bounded_transform_phi.
set Tx := R_standard_topology.
set S := open_rays_subbasis R.
claim HTx: topology_on R Tx.
{ exact R_standard_topology_is_topology. }
claim Hfun: function_on bounded_transform_phi R R.
{ let t. assume HtR: t :e R.
  exact (bounded_transform_phi_value_in_R t HtR). }
claim HS: subbasis_on R S.
{ exact (open_rays_subbasis_is_subbasis R). }
claim Hgen: generated_topology_from_subbasis R S = Tx.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- Hgen at 2.
apply (continuous_map_from_subbasis R Tx R S bounded_transform_phi HTx Hfun HS).
let s. assume HsS: s :e S.
prove preimage_of R bounded_transform_phi s :e Tx.
claim HSdef: S =
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ reflexivity. }
claim HsS': s :e
  (({I :e Power R | exists a :e R, I = open_ray_upper R a}
    :\/:
    {I :e Power R | exists b :e R, I = open_ray_lower R b})
   :\/:
   {R}).
{ rewrite <- HSdef.
  exact HsS. }
apply (binunionE'
  ({I :e Power R | exists a :e R, I = open_ray_upper R a}
   :\/:
   {I :e Power R | exists b :e R, I = open_ray_lower R b})
  {R}
  s
  (preimage_of R bounded_transform_phi s :e Tx)).
- assume HsAB: s :e ({I :e Power R | exists a :e R, I = open_ray_upper R a}
                     :\/:
                     {I :e Power R | exists b :e R, I = open_ray_lower R b}).
  apply (binunionE'
    {I :e Power R | exists a :e R, I = open_ray_upper R a}
    {I :e Power R | exists b :e R, I = open_ray_lower R b}
    s
    (preimage_of R bounded_transform_phi s :e Tx)).
  + assume HsUpper: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
    claim Hex: exists a :e R, s = open_ray_upper R a.
    { exact (SepE2 (Power R) (fun I0:set => exists a :e R, I0 = open_ray_upper R a) s HsUpper). }
    apply Hex.
    let a. assume Hacore.
    apply Hacore.
    assume HaR: a :e R.
    assume Hseq: s = open_ray_upper R a.
    rewrite Hseq.
    exact (bounded_transform_phi_preimage_open_ray_upper a HaR).
  + assume HsLower: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
    claim Hex: exists b :e R, s = open_ray_lower R b.
    { exact (SepE2 (Power R) (fun I0:set => exists b :e R, I0 = open_ray_lower R b) s HsLower). }
    apply Hex.
    let b. assume Hbcore.
    apply Hbcore.
    assume HbR: b :e R.
    assume Hseq: s = open_ray_lower R b.
    rewrite Hseq.
    exact (bounded_transform_phi_preimage_open_ray_lower b HbR).
  + exact HsAB.
- assume HsR: s :e {R}.
  claim Hseq: s = R.
  { exact (SingE R s HsR). }
  rewrite Hseq.
  rewrite (preimage_of_whole R R bounded_transform_phi Hfun).
  exact (topology_has_X R Tx HTx).
- exact HsS'.
Qed.

Theorem Tietze_extension_real : forall X Tx A f:set,
  normal_space X Tx -> closed_in X Tx A ->
  continuous_map A (subspace_topology X Tx A) R R_standard_topology f ->
  exists g:set, continuous_map X Tx R R_standard_topology g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
let X Tx A f.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume Hf: continuous_map A (subspace_topology X Tx A) R R_standard_topology f.
prove exists g:set, continuous_map X Tx R R_standard_topology g /\
    (forall x:set, x :e A -> apply_fun g x = apply_fun f x).
claim HA_cases: A = Empty \/ ~(A = Empty).
{ exact (xm (A = Empty)). }
apply (HA_cases (exists g:set, continuous_map X Tx R R_standard_topology g /\
  (forall x:set, x :e A -> apply_fun g x = apply_fun f x))).
- assume HAemp: A = Empty.
  witness (const_fun X 0).
  apply andI.
  + claim HTx: topology_on X Tx.
    { exact (normal_space_topology_on X Tx Hnorm). }
    claim HRtop: topology_on R R_standard_topology.
    { exact (R_standard_topology_is_topology_local). }
    exact (const_fun_continuous X Tx R R_standard_topology 0 HTx HRtop real_0).
  + let x. assume HxA: x :e A.
    prove apply_fun (const_fun X 0) x = apply_fun f x.
    claim HxE: x :e Empty.
    { rewrite <- HAemp. exact HxA. }
    apply FalseE.
    exact ((EmptyE x) HxE).
- assume HAne: ~(A = Empty).
  claim HTx: topology_on X Tx.
  { exact (normal_space_topology_on X Tx Hnorm). }
  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HA). }
  set J := open_interval (minus_SNo 1) 1.
  set Tj := subspace_topology R R_standard_topology J.
  (** map f into (-1,1) using phi and extend within (-1,1) **)
  set phi := bounded_transform_phi.
  claim Hphi_cont: continuous_map R R_standard_topology R R_standard_topology phi.
  { claim HphiDef: phi = bounded_transform_phi.
    { reflexivity. }
    rewrite HphiDef.
    exact bounded_transform_phi_continuous. }
  set h := compose_fun A f phi.
  claim Hh_cont_R: continuous_map A (subspace_topology X Tx A) R R_standard_topology h.
  { exact (composition_continuous A (subspace_topology X Tx A) R R_standard_topology R R_standard_topology
           f phi Hf Hphi_cont). }
  claim HJsubR: J c= R.
  { let s. assume HsJ: s :e J.
    exact (open_interval_Subq_R (minus_SNo 1) 1 s HsJ). }
  claim HhJimg: forall x:set, x :e A -> apply_fun h x :e J.
  { let x. assume HxA: x :e A.
    prove apply_fun h x :e J.
    claim HxR: apply_fun f x :e R.
    { exact (continuous_map_function_on A (subspace_topology X Tx A) R R_standard_topology f Hf x HxA). }
    claim Hhapp: apply_fun h x = apply_fun phi (apply_fun f x).
    { rewrite (compose_fun_apply A f phi x HxA).
      reflexivity. }
    rewrite Hhapp.
    claim HphiDef: phi = bounded_transform_phi.
    { reflexivity. }
    rewrite HphiDef.
    claim Hbnds: Rlt (minus_SNo 1) (apply_fun bounded_transform_phi (apply_fun f x)) /\
                 Rlt (apply_fun bounded_transform_phi (apply_fun f x)) 1.
    { exact (bounded_transform_phi_strict_bounds (apply_fun f x) HxR). }
    claim Hltm1: Rlt (minus_SNo 1) (apply_fun bounded_transform_phi (apply_fun f x)).
    { exact (andEL (Rlt (minus_SNo 1) (apply_fun bounded_transform_phi (apply_fun f x)))
                   (Rlt (apply_fun bounded_transform_phi (apply_fun f x)) 1) Hbnds). }
    claim Hlt1: Rlt (apply_fun bounded_transform_phi (apply_fun f x)) 1.
    { exact (andER (Rlt (minus_SNo 1) (apply_fun bounded_transform_phi (apply_fun f x)))
                   (Rlt (apply_fun bounded_transform_phi (apply_fun f x)) 1) Hbnds). }
    claim HyR: apply_fun bounded_transform_phi (apply_fun f x) :e R.
    { exact (bounded_transform_phi_value_in_R (apply_fun f x) HxR). }
    claim HJdef: J = {z :e R|Rlt (minus_SNo 1) z /\ Rlt z 1}.
    { reflexivity. }
    rewrite HJdef.
    apply (SepI R (fun z:set => Rlt (minus_SNo 1) z /\ Rlt z 1)
                 (apply_fun bounded_transform_phi (apply_fun f x)) HyR).
    exact (andI (Rlt (minus_SNo 1) (apply_fun bounded_transform_phi (apply_fun f x)))
                (Rlt (apply_fun bounded_transform_phi (apply_fun f x)) 1)
                Hltm1 Hlt1). }
  claim Hh_cont_J: continuous_map A (subspace_topology X Tx A) J Tj h.
  { exact (continuous_map_range_restrict A (subspace_topology X Tx A) R R_standard_topology
           h J Hh_cont_R HJsubR HhJimg). }
  claim HexgJ: exists gJ:set,
    continuous_map X Tx J Tj gJ /\ (forall x:set, x :e A -> apply_fun gJ x = apply_fun h x).
  { exact (Tietze_extension_open_interval X Tx A h Hnorm HA Hh_cont_J). }
  apply HexgJ.
  let gJ. assume HgJ.
  claim HgJ_cont: continuous_map X Tx J Tj gJ.
  { exact (andEL
           (continuous_map X Tx J Tj gJ)
           (forall x:set, x :e A -> apply_fun gJ x = apply_fun h x)
           HgJ). }
  claim HgJ_eq: forall x:set, x :e A -> apply_fun gJ x = apply_fun h x.
  { exact (andER
           (continuous_map X Tx J Tj gJ)
           (forall x:set, x :e A -> apply_fun gJ x = apply_fun h x)
           HgJ). }
  set psi := bounded_transform_psi.
  claim Hpsi_cont: continuous_map J Tj R R_standard_topology psi.
  { exact bounded_transform_psi_continuous_open_interval. }
  set g := compose_fun X gJ psi.
  witness g.
  apply andI.
  + exact (composition_continuous X Tx J Tj R R_standard_topology gJ psi HgJ_cont Hpsi_cont).
  + let x. assume HxA: x :e A.
    prove apply_fun g x = apply_fun f x.
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    claim Hgapp: apply_fun g x = apply_fun psi (apply_fun gJ x).
    { rewrite (compose_fun_apply X gJ psi x HxX).
      reflexivity. }
    rewrite Hgapp.
    rewrite (HgJ_eq x HxA).
    claim HxR: apply_fun f x :e R.
    { exact (continuous_map_function_on A (subspace_topology X Tx A) R R_standard_topology f Hf x HxA). }
    claim Hhapp: apply_fun h x = apply_fun bounded_transform_phi (apply_fun f x).
    { rewrite (compose_fun_apply A f phi x HxA).
      claim HphiDef: phi = bounded_transform_phi.
      { reflexivity. }
      rewrite HphiDef.
      reflexivity. }
    rewrite Hhapp.
    exact (bounded_transform_psi_phi_cancel (apply_fun f x) HxR).
Qed.

(** from §36 Definition: m-manifold **) 
(** LATEX VERSION: An m-manifold is Hausdorff and second countable (dimension suppressed here). **)
(** LATEX VERSION: An m-manifold is a Hausdorff space with a countable basis such that each point has a neighborhood homeomorphic with an open subset of R^m. **)
Definition m_manifold : set -> set -> set -> prop := fun X Tx m =>
  Hausdorff_space X Tx /\
  second_countable_space X Tx /\
  m :e omega /\
  forall x:set, x :e X ->
    exists U:set, U :e Tx /\ x :e U /\
      exists V:set, V :e (euclidean_topology m) /\
        exists f:set,
          homeomorphism U (subspace_topology X Tx U)
                       V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f.

(** from §36 Definition: support of a function **)
(** LATEX VERSION: If phi:X→R, support(phi) is the closure of {x∈X | phi(x)≠0}. **)
Definition support_of : set -> set -> set -> set := fun X Tx phi =>
  closure_of X Tx {x :e X | apply_fun phi x <> 0}.

(** helper: support is a subset of the ambient space **)
Theorem support_of_sub_X : forall X Tx phi:set,
  topology_on X Tx ->
  support_of X Tx phi c= X.
let X Tx phi.
assume HTx: topology_on X Tx.
prove support_of X Tx phi c= X.
claim Hdef: support_of X Tx phi = closure_of X Tx {x :e X | apply_fun phi x <> 0}.
{ reflexivity. }
rewrite Hdef.
exact (closure_in_space X Tx {x :e X | apply_fun phi x <> 0} HTx).
Qed.

(** helper: support is closed **)
Theorem support_of_closed_in : forall X Tx phi:set,
  topology_on X Tx ->
  closed_in X Tx (support_of X Tx phi).
let X Tx phi.
assume HTx: topology_on X Tx.
prove closed_in X Tx (support_of X Tx phi).
claim Hdef: support_of X Tx phi = closure_of X Tx {x :e X | apply_fun phi x <> 0}.
{ reflexivity. }
rewrite Hdef.
claim Hsub: {x :e X | apply_fun phi x <> 0} c= X.
{ let x. assume Hx: x :e {x0 :e X | apply_fun phi x0 <> 0}.
  exact (SepE1 X (fun x0:set => apply_fun phi x0 <> 0) x Hx). }
exact (closure_is_closed X Tx {x :e X | apply_fun phi x <> 0} HTx Hsub).
Qed.

(** from §36 Definition: partition of unity dominated by a cover **) 
(** LATEX VERSION: For an indexed open cover {U_i}, a family of continuous functions phi_i:X→[0,1] is a partition of unity dominated by {U_i} if: (1) support(phi_i)⊂U_i, (2) the supports are locally finite (automatic in the finite case), and (3) sum phi_i(x)=1 for all x. **)
Definition partition_of_unity_dominated : set -> set -> set -> prop := fun X Tx U =>
  topology_on X Tx /\ open_cover X Tx U /\
  exists P:set,
    P c= function_space X R /\
    (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
    (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
    (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
    (forall x:set, x :e X ->
      exists N:set, N :e Tx /\ x :e N /\
        exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
          forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S) /\
    (forall x:set, x :e X ->
      exists F:set, finite F /\ F c= P /\
        (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
        exists n:set, n :e omega /\
          exists e:set, bijection n F e /\
            exists p:set,
              function_on p (ordsucc n) R /\
              apply_fun p Empty = 0 /\
              (forall k:set, k :e n ->
                apply_fun p (ordsucc k) =
                  add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
              apply_fun p n = 1).

(** helper: predicate for the partition-of-unity function family itself **)
(** LATEX VERSION: The family P of functions satisfies continuity, [0,1]-valuedness, domination by U via supports, local finiteness of supports, and pointwise finite summation to 1. **)
Definition partition_of_unity_family : set -> set -> set -> set -> prop := fun X Tx U P =>
  P c= function_space X R /\
  (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
  (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
  (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
  (forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
        forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S) /\
  (forall x:set, x :e X ->
    exists F:set, finite F /\ F c= P /\
      (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
      exists n:set, n :e omega /\
        exists e:set, bijection n F e /\
          exists p:set,
            function_on p (ordsucc n) R /\
            apply_fun p Empty = 0 /\
            (forall k:set, k :e n ->
              apply_fun p (ordsucc k) =
                add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
            apply_fun p n = 1).

(** helper: extract P subset of function_space from partition_of_unity_family **)
Theorem partition_of_unity_family_sub_function_space : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  P c= function_space X R.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume Hleft _.
apply Hleft. assume Hleft2 _.
apply Hleft2. assume Hleft3 _.
apply Hleft3. assume Hleft4 _.
apply Hleft4. assume HA _.
exact HA.
Qed.

(** helper: extract continuity of members from partition_of_unity_family **)
Theorem partition_of_unity_family_continuous : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume Hleft _.
apply Hleft. assume Hleft2 _.
apply Hleft2. assume Hleft3 _.
apply Hleft3. assume Hleft4 _.
apply Hleft4. assume _ HB.
exact HB.
Qed.

(** helper: extract unit_interval range from partition_of_unity_family **)
Theorem partition_of_unity_family_unit_interval : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume Hleft _.
apply Hleft. assume Hleft2 _.
apply Hleft2. assume Hleft3 _.
apply Hleft3. assume _ HC.
exact HC.
Qed.

(** helper: extract support domination by U from partition_of_unity_family **)
Theorem partition_of_unity_family_support_dominated : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume Hleft _.
apply Hleft. assume Hleft2 _.
apply Hleft2. assume _ HD.
exact HD.
Qed.

(** helper: extract local finiteness of supports from partition_of_unity_family **)
Theorem partition_of_unity_family_supports_locally_finite : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
        forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume Hleft _.
apply Hleft. assume _ HE.
exact HE.
Qed.

(** helper: extract pointwise finite summation from partition_of_unity_family **)
Theorem partition_of_unity_family_pointwise_finite_sum : forall X Tx U P:set,
  partition_of_unity_family X Tx U P ->
  forall x:set, x :e X ->
    exists F:set, finite F /\ F c= P /\
      (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
      exists n:set, n :e omega /\
        exists e:set, bijection n F e /\
          exists p:set,
            function_on p (ordsucc n) R /\
            apply_fun p Empty = 0 /\
            (forall k:set, k :e n ->
              apply_fun p (ordsucc k) =
                add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
            apply_fun p n = 1.
let X Tx U P.
assume HP: partition_of_unity_family X Tx U P.
apply HP. assume _ HF.
exact HF.
Qed.

(** helper: extract the family predicate from partition_of_unity_dominated **)
(** LATEX VERSION: If a cover admits a partition of unity, then there exists a family P satisfying the partition-of-unity family conditions. **)
Theorem partition_of_unity_dominated_ex_family_pred : forall X Tx U:set,
  partition_of_unity_dominated X Tx U ->
  exists P:set, partition_of_unity_family X Tx U P.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
exact (andER (topology_on X Tx /\ open_cover X Tx U)
             (exists P:set, partition_of_unity_family X Tx U P)
             H).
Qed.

(** helper: extract topology_on and open_cover together from partition_of_unity_dominated **)
(** LATEX VERSION: A partition of unity dominated by U presupposes that Tx is a topology on X and that U is an open cover. **)
Theorem partition_of_unity_dominated_topology_open_cover : forall X Tx U:set,
  partition_of_unity_dominated X Tx U -> topology_on X Tx /\ open_cover X Tx U.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
exact (andEL (topology_on X Tx /\ open_cover X Tx U)
             (exists P:set, partition_of_unity_family X Tx U P)
             H).
Qed.

(** helper: extract topology_on from partition_of_unity_dominated **)
Theorem partition_of_unity_dominated_topology : forall X Tx U:set,
  partition_of_unity_dominated X Tx U -> topology_on X Tx.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
exact (andEL (topology_on X Tx)
             (open_cover X Tx U)
             (partition_of_unity_dominated_topology_open_cover X Tx U H)).
Qed.

(** helper: extract open_cover from partition_of_unity_dominated **)
Theorem partition_of_unity_dominated_open_cover : forall X Tx U:set,
  partition_of_unity_dominated X Tx U -> open_cover X Tx U.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
exact (andER (topology_on X Tx)
             (open_cover X Tx U)
             (partition_of_unity_dominated_topology_open_cover X Tx U H)).
Qed.

(** helper: extract existence of the partition family P **)
Theorem partition_of_unity_dominated_ex_family : forall X Tx U:set,
  partition_of_unity_dominated X Tx U ->
  exists P:set,
    P c= function_space X R /\
    (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
    (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
    (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
    (forall x:set, x :e X ->
      exists N:set, N :e Tx /\ x :e N /\
        exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
          forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S) /\
    (forall x:set, x :e X ->
      exists F:set, finite F /\ F c= P /\
        (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
        exists n:set, n :e omega /\
          exists e:set, bijection n F e /\
            exists p:set,
              function_on p (ordsucc n) R /\
              apply_fun p Empty = 0 /\
              (forall k:set, k :e n ->
                apply_fun p (ordsucc k) =
                  add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
              apply_fun p n = 1).
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
exact (partition_of_unity_dominated_ex_family_pred X Tx U H).
Qed.

(** helper: partition_of_unity_dominated implies the cover is a family of subsets of X **)
(** LATEX VERSION: If U admits a partition of unity on X, then U is a family of subsets of X. **)
Theorem partition_of_unity_dominated_cover_sub_Power : forall X Tx U:set,
  partition_of_unity_dominated X Tx U -> U c= Power X.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
claim Hpair: topology_on X Tx /\ open_cover X Tx U.
{ exact (partition_of_unity_dominated_topology_open_cover X Tx U H). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (open_cover X Tx U) Hpair). }
claim HUcov: open_cover X Tx U.
{ exact (andER (topology_on X Tx) (open_cover X Tx U) Hpair). }
exact (open_cover_family_sub X Tx U HTx HUcov).
Qed.

(** helper: partition_of_unity_dominated implies U covers X **)
(** LATEX VERSION: A partition of unity subordinate to U implies U covers X. **)
Theorem partition_of_unity_dominated_covers : forall X Tx U:set,
  partition_of_unity_dominated X Tx U -> covers X U.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
claim HUcov: open_cover X Tx U.
{ exact (andER (topology_on X Tx)
               (open_cover X Tx U)
               (partition_of_unity_dominated_topology_open_cover X Tx U H)). }
exact (andER (forall u:set, u :e U -> u :e Tx)
             (covers X U)
             HUcov).
Qed.

(** helper: extract the local finiteness of supports from partition_of_unity_dominated **)
(** LATEX VERSION: A partition of unity is locally finite in the sense that each point has a neighborhood meeting only finitely many supports. **)
Theorem partition_of_unity_dominated_supports_locally_finite : forall X Tx U:set,
  partition_of_unity_dominated X Tx U ->
  exists P:set,
    P c= function_space X R /\
    (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
    (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
    (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
    (forall x:set, x :e X ->
      exists N:set, N :e Tx /\ x :e N /\
        exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
          forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S).
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
apply (partition_of_unity_dominated_ex_family_pred X Tx U H).
let P. assume HP: partition_of_unity_family X Tx U P.
witness P.
claim HA: P c= function_space X R.
{ exact (partition_of_unity_family_sub_function_space X Tx U P HP). }
claim HB: forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f.
{ exact (partition_of_unity_family_continuous X Tx U P HP). }
claim HC: forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval.
{ exact (partition_of_unity_family_unit_interval X Tx U P HP). }
claim HD: forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u.
{ exact (partition_of_unity_family_support_dominated X Tx U P HP). }
claim HE: forall x:set, x :e X ->
  exists N:set, N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
      forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S.
{ exact (partition_of_unity_family_supports_locally_finite X Tx U P HP). }

prove P c= function_space X R /\
  (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
  (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
  (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
  (forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
        forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S).
apply andI.
- apply andI.
  * apply andI.
    { apply andI.
      - exact HA.
      - exact HB. }
    { exact HC. }
  * exact HD.
- exact HE.
Qed.

(** helper: extract the pointwise finite summation clause from partition_of_unity_dominated **)
(** LATEX VERSION: For each x in X, only finitely many functions of the partition are nonzero at x, and their sum equals 1. **)
Theorem partition_of_unity_dominated_pointwise_finite_sum : forall X Tx U:set,
  partition_of_unity_dominated X Tx U ->
  exists P:set,
    forall x:set, x :e X ->
      exists F:set, finite F /\ F c= P /\
        (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
        exists n:set, n :e omega /\
          exists e:set, bijection n F e /\
            exists p:set,
              function_on p (ordsucc n) R /\
              apply_fun p Empty = 0 /\
              (forall k:set, k :e n ->
                apply_fun p (ordsucc k) =
                  add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
              apply_fun p n = 1.
let X Tx U.
assume H: partition_of_unity_dominated X Tx U.
apply (partition_of_unity_dominated_ex_family_pred X Tx U H).
let P. assume HP: partition_of_unity_family X Tx U P.
witness P.
exact (partition_of_unity_family_pointwise_finite_sum X Tx U P HP).
Qed.

(** from §36 Theorem 36.1: existence of finite partition of unity on normal space **) 
(** LATEX VERSION: On a normal space, every finite open cover has a partition of unity subordinate to it. **)
Theorem finite_partition_of_unity_exists : forall X Tx U:set,
  normal_space X Tx -> finite U -> open_cover X Tx U -> partition_of_unity_dominated X Tx U.
let X Tx U.
assume Hnorm: normal_space X Tx.
assume Hfin: finite U.
assume Hcover: open_cover X Tx U.
prove partition_of_unity_dominated X Tx U.
prove topology_on X Tx /\ open_cover X Tx U /\
  exists P:set, partition_of_unity_family X Tx U P.
apply andI.
- (** topology_on X Tx /\ open_cover X Tx U **)
  apply andI.
  * exact (normal_space_topology_on X Tx Hnorm).
  * exact Hcover.
- (** construction of partition of unity (pending) **)
  admit. (** FAIL **)
Qed.

(** from §36 Theorem: compact manifold embeds in Euclidean space **) 
(** LATEX VERSION: Any compact manifold embeds in some Euclidean space. **)
Theorem compact_manifold_embeds_in_Euclidean : forall X Tx:set,
  forall m:set, m_manifold X Tx m -> compact_space X Tx ->
    exists N:set, exists e:set,
      N :e omega /\ N <> Empty /\
      embedding_of X Tx (euclidean_space N) (euclidean_topology N) e.
let X Tx.
let m.
assume Hman: m_manifold X Tx m.
assume Hcomp: compact_space X Tx.
prove exists N:set, exists e:set,
    N :e omega /\ N <> Empty /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e.
admit. (** FAIL **)
Qed.

(** from §37 Theorem: Tychonoff theorem **)
(** LATEX VERSION: Arbitrary product of compact spaces is compact (Tychonoff). **)
(** FIXED: Hypothesis quantifies i only over i:e I (not all sets). **) 
Theorem Tychonoff_theorem : forall I Xi:set,
  (forall i:set, i :e I -> compact_space (product_component Xi i) (product_component_topology Xi i)) ->
  compact_space (product_space I Xi) (product_topology_full I Xi).
let I Xi.
assume Hcomp: forall i:set, i :e I -> compact_space (product_component Xi i) (product_component_topology Xi i).
prove compact_space (product_space I Xi) (product_topology_full I Xi).
admit. (** FAIL **)
Qed.

(** from §38 Definition: Stone-Cech compactification and universal property **) 
(** LATEX VERSION: Stone–Čech compactification βX defined via universal property; placeholder representation. **)
Definition Stone_Cech_compactification : set -> set -> set := fun X Tx =>
  {p :e Power (Power (Power X)) |
    exists Y Ty e:set,
      p = setprod (setprod Y Ty) e /\
      compact_space Y Ty /\ Hausdorff_space Y Ty /\ embedding_of X Tx Y Ty e}.
Theorem Stone_Cech_universal_property : forall X Tx:set,
  Tychonoff_space X Tx ->
  exists Ty:set,
    compact_space (Stone_Cech_compactification X Tx) Ty /\
    Hausdorff_space (Stone_Cech_compactification X Tx) Ty.
let X Tx.
assume HT: Tychonoff_space X Tx.
prove exists Ty:set,
  compact_space (Stone_Cech_compactification X Tx) Ty /\
  Hausdorff_space (Stone_Cech_compactification X Tx) Ty.
admit. (** FAIL **)
Qed.

(** from §39 Definition: locally finite family and refinement **) 
(** LATEX VERSION: Refinement and locally finite families/bases (Nagata–Smirnov context). **)
Definition refine_of : set -> set -> prop := fun V U =>
  forall v:set, v :e V -> exists u:set, u :e U /\ v c= u.

(** helper: refinement transitivity **) 
Theorem refine_trans : forall U V W:set,
  refine_of W V -> refine_of V U -> refine_of W U.
let U V W.
assume HWV: refine_of W V.
assume HVU: refine_of V U.
prove refine_of W U.
let w. assume HwW: w :e W.
apply (HWV w HwW).
let v. assume Hv: v :e V /\ w c= v.
claim HvV: v :e V.
{ exact (andEL (v :e V) (w c= v) Hv). }
claim Hwsubv: w c= v.
{ exact (andER (v :e V) (w c= v) Hv). }
apply (HVU v HvV).
let u. assume Hu: u :e U /\ v c= u.
witness u.
apply andI.
- exact (andEL (u :e U) (v c= u) Hu).
- exact (Subq_tra w v u Hwsubv (andER (u :e U) (v c= u) Hu)).
Qed.

(** helper: transfer partition-of-unity family domination along a refinement **) 
(** LATEX VERSION: If the supports are dominated by a refining cover V and V refines U, then the same family is dominated by U. **)
Theorem partition_of_unity_family_refine : forall X Tx U V P:set,
  partition_of_unity_family X Tx V P ->
  refine_of V U ->
  partition_of_unity_family X Tx U P.
let X Tx U V P.
assume HP: partition_of_unity_family X Tx V P.
assume Href: refine_of V U.
prove partition_of_unity_family X Tx U P.
claim HA: P c= function_space X R.
{ exact (partition_of_unity_family_sub_function_space X Tx V P HP). }
claim HB: forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f.
{ exact (partition_of_unity_family_continuous X Tx V P HP). }
claim HC: forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval.
{ exact (partition_of_unity_family_unit_interval X Tx V P HP). }
claim HDV: forall f:set, f :e P -> exists v:set, v :e V /\ support_of X Tx f c= v.
{ exact (partition_of_unity_family_support_dominated X Tx V P HP). }
claim HE: forall x:set, x :e X ->
  exists N:set, N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
      forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S.
{ exact (partition_of_unity_family_supports_locally_finite X Tx V P HP). }
claim HF: forall x:set, x :e X ->
  exists F:set, finite F /\ F c= P /\
    (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
    exists n:set, n :e omega /\
      exists e:set, bijection n F e /\
        exists p:set,
          function_on p (ordsucc n) R /\
          apply_fun p Empty = 0 /\
          (forall k:set, k :e n ->
            apply_fun p (ordsucc k) =
              add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
          apply_fun p n = 1.
{ exact (partition_of_unity_family_pointwise_finite_sum X Tx V P HP). }

claim HdomU: forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u.
{ let f. assume HfP: f :e P.
  apply (HDV f HfP).
  let v. assume Hv: v :e V /\ support_of X Tx f c= v.
  claim HvV: v :e V.
  { exact (andEL (v :e V) (support_of X Tx f c= v) Hv). }
  claim Hsuppsubv: support_of X Tx f c= v.
  { exact (andER (v :e V) (support_of X Tx f c= v) Hv). }
  apply (Href v HvV).
  let u. assume Hu: u :e U /\ v c= u.
  witness u.
  apply andI.
  - exact (andEL (u :e U) (v c= u) Hu).
  - exact (Subq_tra (support_of X Tx f) v u Hsuppsubv (andER (u :e U) (v c= u) Hu)). }

prove P c= function_space X R /\
  (forall f:set, f :e P -> continuous_map X Tx R R_standard_topology f) /\
  (forall f x:set, f :e P -> x :e X -> apply_fun f x :e unit_interval) /\
  (forall f:set, f :e P -> exists u:set, u :e U /\ support_of X Tx f c= u) /\
  (forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= {support_of X Tx f | f :e P} /\
        forall A:set, A :e {support_of X Tx f | f :e P} -> A :/\: N <> Empty -> A :e S) /\
  (forall x:set, x :e X ->
    exists F:set, finite F /\ F c= P /\
      (forall f:set, f :e P -> apply_fun f x <> 0 -> f :e F) /\
      exists n:set, n :e omega /\
        exists e:set, bijection n F e /\
          exists p:set,
            function_on p (ordsucc n) R /\
            apply_fun p Empty = 0 /\
            (forall k:set, k :e n ->
              apply_fun p (ordsucc k) =
                add_SNo (apply_fun p k) (apply_fun (apply_fun e k) x)) /\
            apply_fun p n = 1).
apply and6I.
- exact HA.
- exact HB.
- exact HC.
- exact HdomU.
- exact HE.
- exact HF.
Qed.

(** helper: transfer partition-of-unity domination along a refinement **) 
Theorem partition_of_unity_dominated_refine : forall X Tx U V:set,
  open_cover X Tx U ->
  partition_of_unity_dominated X Tx V ->
  refine_of V U ->
  partition_of_unity_dominated X Tx U.
let X Tx U V.
assume HUcov: open_cover X Tx U.
assume HPV: partition_of_unity_dominated X Tx V.
assume Href: refine_of V U.
prove partition_of_unity_dominated X Tx U.
claim HTx: topology_on X Tx.
{ exact (partition_of_unity_dominated_topology X Tx V HPV). }
prove topology_on X Tx /\ open_cover X Tx U /\
  exists P:set, partition_of_unity_family X Tx U P.
apply andI.
- apply andI.
  * exact HTx.
  * exact HUcov.
- apply (partition_of_unity_dominated_ex_family_pred X Tx V HPV).
  let P. assume HPfamV: partition_of_unity_family X Tx V P.
  witness P.
  exact (partition_of_unity_family_refine X Tx U V P HPfamV Href).
Qed.
Definition locally_finite_family : set -> set -> set -> prop := fun X Tx F =>
  topology_on X Tx /\
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= F /\
        forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.

(** helper: every finite family is locally finite **)
(** LATEX VERSION: Every finite family of subsets is locally finite. **)
Theorem finite_family_locally_finite_family : forall X Tx F:set,
  topology_on X Tx ->
  finite F ->
  locally_finite_family X Tx F.
let X Tx F.
assume HTx: topology_on X Tx.
assume HFfin: finite F.
prove locally_finite_family X Tx F.
prove topology_on X Tx /\
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= F /\
        forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
apply andI.
- exact HTx.
- let x. assume HxX: x :e X.
  witness X.
  apply andI.
  * apply andI.
    { exact (topology_has_X X Tx HTx). }
    { exact HxX. }
  * witness F.
    apply andI.
    - apply andI.
      + exact HFfin.
      + exact (Subq_ref F).
    - let A. assume HA: A :e F.
      assume _: A :/\: X <> Empty.
      exact HA.
Qed.

(** helper: finite open cover is a locally finite family **)
(** LATEX VERSION: Every finite family (in particular, every finite open cover) is locally finite. **)
Theorem finite_open_cover_locally_finite_family : forall X Tx U:set,
  topology_on X Tx ->
  open_cover X Tx U ->
  finite U ->
  locally_finite_family X Tx U.
let X Tx U.
assume HTx: topology_on X Tx.
assume _: open_cover X Tx U.
assume HUfin: finite U.
exact (finite_family_locally_finite_family X Tx U HTx HUfin).
Qed.

(** helper: locally finite open covers admit a partition of unity on normal spaces (placeholder) **) 
Theorem normal_locally_finite_partition_of_unity_dominated : forall X Tx W:set,
  normal_space X Tx ->
  open_cover X Tx W ->
  locally_finite_family X Tx W ->
  partition_of_unity_dominated X Tx W.
let X Tx W.
assume Hnorm: normal_space X Tx.
assume HWcov: open_cover X Tx W.
assume HWlf: locally_finite_family X Tx W.
prove partition_of_unity_dominated X Tx W.
prove topology_on X Tx /\ open_cover X Tx W /\
  exists P:set, partition_of_unity_family X Tx W P.
apply andI.
- (** topology_on X Tx /\ open_cover X Tx W **)
  apply andI.
  * exact (normal_space_topology_on X Tx Hnorm).
  * exact HWcov.
- (** Pending: construct a partition-of-unity family subordinate to the locally finite open cover W using normality, and use local-finiteness to justify the finite-support and summation clauses. **)
  claim HTx: topology_on X Tx.
  { exact (normal_space_topology_on X Tx Hnorm). }
  claim Hreg: regular_space X Tx.
  { exact (normal_space_implies_regular X Tx Hnorm). }
  claim HWopen: forall w:set, w :e W -> w :e Tx.
  { exact (andEL (forall w:set, w :e W -> w :e Tx) (covers X W) HWcov). }
  claim HWcovers: covers X W.
  { exact (andER (forall w:set, w :e W -> w :e Tx) (covers X W) HWcov). }
  claim HWsubPow: W c= Power X.
  { exact (open_cover_family_sub X Tx W HTx HWcov). }
  (** Intended route: use regularity/normality to build an open shrinking of W with closures inside W-members, then combine Urysohn-type bump functions and local finiteness to produce the required locally finite family of supports and pointwise finite summation. **)
  admit. (** FAIL **)
Qed.

(** helper: partitions of unity along locally finite refinements (placeholder) **) 
Theorem normal_locally_finite_refinement_partition_of_unity : forall X Tx U W:set,
  normal_space X Tx ->
  open_cover X Tx U ->
  open_cover X Tx W ->
  locally_finite_family X Tx W ->
  refine_of W U ->
  partition_of_unity_dominated X Tx U.
let X Tx U W.
assume Hnorm: normal_space X Tx.
assume HUcov: open_cover X Tx U.
assume HWcov: open_cover X Tx W.
assume HWlf: locally_finite_family X Tx W.
assume Href: refine_of W U.
prove partition_of_unity_dominated X Tx U.
(** First build a partition of unity dominated by W, then transfer domination along the refinement W ≺ U. **)
claim HPW: partition_of_unity_dominated X Tx W.
{ exact (normal_locally_finite_partition_of_unity_dominated X Tx W Hnorm HWcov HWlf). }
exact (partition_of_unity_dominated_refine X Tx U W HUcov HPW Href).
Qed.

(** helper: subfamily of a locally finite family is locally finite **)
Theorem locally_finite_subfamily : forall X Tx F G:set,
  locally_finite_family X Tx F ->
  G c= F ->
  locally_finite_family X Tx G.
let X Tx F G.
assume HLF: locally_finite_family X Tx F.
assume HGF: G c= F.
prove locally_finite_family X Tx G.
prove topology_on X Tx /\
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= G /\
        forall A:set, A :e G -> A :/\: N <> Empty -> A :e S.
apply andI.
- exact (andEL (topology_on X Tx)
               (forall x:set, x :e X ->
                 exists N:set, N :e Tx /\ x :e N /\
                   exists S:set, finite S /\ S c= F /\
                     forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
               HLF).
- let x. assume HxX: x :e X.
  claim HLFx: exists N:set, N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= F /\
      forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
  { exact (andER (topology_on X Tx)
                 (forall x0:set, x0 :e X ->
                   exists N:set, N :e Tx /\ x0 :e N /\
                     exists S:set, finite S /\ S c= F /\
                       forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
                 HLF x HxX). }
  apply HLFx.
  let N. assume HN: N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= F /\
      forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
  witness N.
  claim HNpair: N :e Tx /\ x :e N.
  { exact (andEL (N :e Tx /\ x :e N)
                 (exists S:set, finite S /\ S c= F /\ forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
                 HN). }
  claim HexS: exists S:set, finite S /\ S c= F /\ forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
  { exact (andER (N :e Tx /\ x :e N)
                 (exists S:set, finite S /\ S c= F /\ forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
                 HN). }
  apply andI.
  - exact HNpair.
  - apply HexS.
    let S. assume HS: finite S /\ S c= F /\ forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
      claim HS1: finite S /\ S c= F.
      { exact (andEL (finite S /\ S c= F)
                     (forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
                     HS). }
      claim HSfin: finite S.
      { exact (andEL (finite S) (S c= F) HS1). }
      claim HSsubF: S c= F.
      { exact (andER (finite S) (S c= F) HS1). }
      claim HSprop: forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
      { exact (andER (finite S /\ S c= F)
                     (forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
                     HS). }
      set SG := {A :e S | A :e G}.
      witness SG.
      prove (finite SG /\ SG c= G) /\
        forall A:set, A :e G -> A :/\: N <> Empty -> A :e SG.
      apply andI.
      - prove finite SG /\ SG c= G.
        apply andI.
        * (** SG finite **)
          claim HSGsub: SG c= S.
          { exact (Sep_Subq S (fun A:set => A :e G)). }
          exact (Subq_finite S HSfin SG HSGsub).
        * (** SG c= G **)
          let A. assume HA: A :e SG.
          exact (SepE2 S (fun A0:set => A0 :e G) A HA).
      - (** membership property **)
        let A. assume HAG: A :e G.
        assume HAnN: A :/\: N <> Empty.
        claim HAF: A :e F.
        { exact (HGF A HAG). }
        claim HAS: A :e S.
        { exact (HSprop A HAF HAnN). }
        apply SepI.
        - exact HAS.
        - exact HAG.
Qed.

(** helper: extract topology_on from locally_finite_family **)
Theorem locally_finite_family_topology : forall X Tx F:set,
  locally_finite_family X Tx F -> topology_on X Tx.
let X Tx F.
assume HLF: locally_finite_family X Tx F.
exact (andEL (topology_on X Tx)
             (forall x:set, x :e X ->
               exists N:set, N :e Tx /\ x :e N /\
                 exists S:set, finite S /\ S c= F /\
                   forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
             HLF).
Qed.

(** helper: extract the neighborhood-finite part from locally_finite_family **)
Theorem locally_finite_family_property : forall X Tx F:set,
  locally_finite_family X Tx F ->
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= F /\
        forall A:set, A :e F -> A :/\: N <> Empty -> A :e S.
let X Tx F.
assume HLF: locally_finite_family X Tx F.
exact (andER (topology_on X Tx)
             (forall x:set, x :e X ->
               exists N:set, N :e Tx /\ x :e N /\
                 exists S:set, finite S /\ S c= F /\
                   forall A:set, A :e F -> A :/\: N <> Empty -> A :e S)
             HLF).
Qed.

(** helper: closure of a union is contained in the union of closures for locally finite families **)
Theorem closure_Union_locally_finite_subset_Union_closures : forall X Tx Fam:set,
  (forall A:set, A :e Fam -> A c= X) ->
  locally_finite_family X Tx Fam ->
  closure_of X Tx (Union Fam) c= Union {closure_of X Tx A|A :e Fam}.
let X Tx Fam.
assume HFsubX: forall A:set, A :e Fam -> A c= X.
assume HLF: locally_finite_family X Tx Fam.
claim HTx: topology_on X Tx.
{ exact (locally_finite_family_topology X Tx Fam HLF). }
set ClFam := {closure_of X Tx A|A :e Fam}.
let x. assume Hxcl: x :e closure_of X Tx (Union Fam).
prove x :e Union ClFam.
apply (xm (x :e Union ClFam)).
- assume H. exact H.
- assume Hnot: x /:e Union ClFam.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: (Union Fam) <> Empty) x Hxcl). }
  claim HxNbhd: forall U:set, U :e Tx -> x :e U -> U :/\: (Union Fam) <> Empty.
  { exact (SepE2 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: (Union Fam) <> Empty) x Hxcl). }
  claim HexLF: exists N:set, N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= Fam /\
      forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S.
  { exact (locally_finite_family_property X Tx Fam HLF x HxX). }
  apply HexLF.
  let N. assume HN: N :e Tx /\ x :e N /\
    exists S:set, finite S /\ S c= Fam /\
      forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S.
  claim HN1: N :e Tx /\ x :e N.
  { exact (andEL (N :e Tx /\ x :e N)
                 (exists S:set, finite S /\ S c= Fam /\ forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S)
                 HN). }
  claim HNTx: N :e Tx.
  { exact (andEL (N :e Tx) (x :e N) HN1). }
  claim HxN: x :e N.
  { exact (andER (N :e Tx) (x :e N) HN1). }
  claim HexS: exists S:set, finite S /\ S c= Fam /\ forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S.
  { exact (andER (N :e Tx /\ x :e N)
                 (exists S:set, finite S /\ S c= Fam /\ forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S)
                 HN). }
  apply HexS.
  let S. assume HS: finite S /\ S c= Fam /\ forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S.
  claim HS1: finite S /\ S c= Fam.
  { exact (andEL (finite S /\ S c= Fam)
                 (forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S)
                 HS). }
  claim HSfin: finite S.
  { exact (andEL (finite S) (S c= Fam) HS1). }
  claim HSsubFam: S c= Fam.
  { exact (andER (finite S) (S c= Fam) HS1). }
  claim HSprop: forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S.
  { exact (andER (finite S /\ S c= Fam)
                 (forall A:set, A :e Fam -> A :/\: N <> Empty -> A :e S)
                 HS). }

  (** choose for each A in S an open neighborhood of x disjoint from A **)
  set sep_open := fun A:set => Eps_i (fun U:set => U :e Tx /\ x :e U /\ U :/\: A = Empty).
  set UFam := {sep_open A|A :e S}.

  claim HUFamFin: finite UFam.
  { exact (Repl_finite (fun A:set => sep_open A) S HSfin). }
  claim HUFamSubTx: UFam c= Tx.
  { let U. assume HU: U :e UFam.
    apply (ReplE_impred S (fun A:set => sep_open A) U HU (U :e Tx)).
    let A. assume HA: A :e S.
    assume HUeq: U = sep_open A.
    claim HAFam: A :e Fam.
    { exact (HSsubFam A HA). }
    claim HxNotClA: x /:e closure_of X Tx A.
    { assume HxClA: x :e closure_of X Tx A.
      claim HclAin: closure_of X Tx A :e ClFam.
      { exact (ReplI Fam (fun A0:set => closure_of X Tx A0) A HAFam). }
      claim HxInUnion: x :e Union ClFam.
      { exact (UnionI ClFam x (closure_of X Tx A) HxClA HclAin). }
      exact (Hnot HxInUnion). }
    claim HAX: A c= X.
    { exact (HFsubX A HAFam). }
    claim HexU: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 :/\: A = Empty.
    { exact (not_in_closure_has_disjoint_open X Tx A x HTx HAX HxX HxNotClA). }
    claim Hsep: (sep_open A) :e Tx /\ x :e (sep_open A) /\ (sep_open A) :/\: A = Empty.
    { exact (Eps_i_ex (fun U0:set => U0 :e Tx /\ x :e U0 /\ U0 :/\: A = Empty) HexU). }
    rewrite HUeq.
    claim HsepAB: (sep_open A) :e Tx /\ x :e (sep_open A).
    { exact (andEL ((sep_open A) :e Tx /\ x :e (sep_open A))
                   ((sep_open A) :/\: A = Empty)
                   Hsep). }
    exact (andEL ((sep_open A) :e Tx)
                 (x :e (sep_open A))
                 HsepAB). }
  claim HUFamPow: UFam :e Power Tx.
  { apply PowerI.
    exact HUFamSubTx. }
  set Uinter := intersection_of_family X UFam.
  claim HUinterTx: Uinter :e Tx.
  { exact (finite_intersection_in_topology X Tx UFam HTx HUFamPow HUFamFin). }

  set M := N :/\: Uinter.
  claim HMTx: M :e Tx.
  { exact (topology_binintersect_closed X Tx N Uinter HTx HNTx HUinterTx). }
  claim HxUinter: x :e Uinter.
  { claim HallUFam: forall U:set, U :e UFam -> x :e U.
    { let U. assume HU: U :e UFam.
      prove x :e U.
      apply (ReplE_impred S (fun A:set => sep_open A) U HU (x :e U)).
      let A. assume HA: A :e S.
      assume HUeq: U = sep_open A.
      claim HAFam: A :e Fam.
      { exact (HSsubFam A HA). }
      claim HxNotClA: x /:e closure_of X Tx A.
      { assume HxClA: x :e closure_of X Tx A.
        claim HclAin: closure_of X Tx A :e ClFam.
        { exact (ReplI Fam (fun A0:set => closure_of X Tx A0) A HAFam). }
        claim HxInUnion: x :e Union ClFam.
        { exact (UnionI ClFam x (closure_of X Tx A) HxClA HclAin). }
        exact (Hnot HxInUnion). }
      claim HAX: A c= X.
      { exact (HFsubX A HAFam). }
      claim HexU: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 :/\: A = Empty.
      { exact (not_in_closure_has_disjoint_open X Tx A x HTx HAX HxX HxNotClA). }
      claim Hsep: (sep_open A) :e Tx /\ x :e (sep_open A) /\ (sep_open A) :/\: A = Empty.
      { exact (Eps_i_ex (fun U0:set => U0 :e Tx /\ x :e U0 /\ U0 :/\: A = Empty) HexU). }
      rewrite HUeq.
      claim HsepAB: (sep_open A) :e Tx /\ x :e (sep_open A).
      { exact (andEL ((sep_open A) :e Tx /\ x :e (sep_open A))
                     ((sep_open A) :/\: A = Empty)
                     Hsep). }
      exact (andER ((sep_open A) :e Tx)
                   (x :e (sep_open A))
                   HsepAB). }
    exact (SepI X (fun x0:set => forall U:set, U :e UFam -> x0 :e U) x
                HxX
                HallUFam). }
  claim HxM: x :e M.
  { exact (binintersectI N Uinter x HxN HxUinter). }

  claim HMEmpty: M :/\: (Union Fam) = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e M :/\: (Union Fam).
    prove z :e Empty.
    claim HzM: z :e M.
    { exact (binintersectE1 M (Union Fam) z Hz). }
    claim HzUF: z :e Union Fam.
    { exact (binintersectE2 M (Union Fam) z Hz). }
    claim HzN: z :e N.
    { exact (binintersectE1 N Uinter z HzM). }
    claim HzUinter: z :e Uinter.
    { exact (binintersectE2 N Uinter z HzM). }
    apply (UnionE_impred Fam z HzUF).
    let A0. assume HzA0: z :e A0.
    assume HA0Fam: A0 :e Fam.
    claim HA0Nnon: A0 :/\: N <> Empty.
    { exact (elem_implies_nonempty (A0 :/\: N) z (binintersectI A0 N z HzA0 HzN)). }
    claim HA0S: A0 :e S.
    { exact (HSprop A0 HA0Fam HA0Nnon). }
    claim HUA0: (sep_open A0) :e UFam.
    { exact (ReplI S (fun A:set => sep_open A) A0 HA0S). }
    claim HzInSep: z :e sep_open A0.
    { exact (SepE2 X (fun x0:set => forall U:set, U :e UFam -> x0 :e U) z HzUinter (sep_open A0) HUA0). }
    claim HxNotClA0: x /:e closure_of X Tx A0.
    { assume HxClA0: x :e closure_of X Tx A0.
      claim HclAin: closure_of X Tx A0 :e ClFam.
      { exact (ReplI Fam (fun A1:set => closure_of X Tx A1) A0 HA0Fam). }
      claim HxInUnion: x :e Union ClFam.
      { exact (UnionI ClFam x (closure_of X Tx A0) HxClA0 HclAin). }
      exact (Hnot HxInUnion). }
    claim HA0X: A0 c= X.
    { exact (HFsubX A0 HA0Fam). }
    claim HexU: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 :/\: A0 = Empty.
    { exact (not_in_closure_has_disjoint_open X Tx A0 x HTx HA0X HxX HxNotClA0). }
    claim Hsep: (sep_open A0) :e Tx /\ x :e (sep_open A0) /\ (sep_open A0) :/\: A0 = Empty.
    { exact (Eps_i_ex (fun U0:set => U0 :e Tx /\ x :e U0 /\ U0 :/\: A0 = Empty) HexU). }
    claim HsepEq: (sep_open A0) :/\: A0 = Empty.
    { exact (andER ((sep_open A0) :e Tx /\ x :e (sep_open A0))
                   ((sep_open A0) :/\: A0 = Empty)
                   Hsep). }
    claim HzInInt: z :e (sep_open A0) :/\: A0.
    { exact (binintersectI (sep_open A0) A0 z HzInSep HzA0). }
    rewrite <- HsepEq.
    exact HzInInt. }

  (** contradiction with x being in the closure of Union Fam **)
  claim Hcontra: M :/\: (Union Fam) <> Empty.
  { exact (HxNbhd M HMTx HxM). }
  apply FalseE.
  exact (Hcontra HMEmpty).
Qed.
(** from §39 Definition: locally finite collection (applied to a basis) **)
(** LATEX VERSION: A collection A is locally finite in X if every point has a neighborhood intersecting only finitely many elements of A. **)
Definition locally_finite_basis : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  exists B:set, basis_on X B /\ locally_finite_family X Tx B /\ (forall b:set, b :e B -> b :e Tx).
(** from §39 Definition: countably locally finite (sigma-locally finite) collection **)
(** LATEX VERSION: A collection B is countably locally finite if it is the countable union of collections B_n, each locally finite. **)
Definition sigma_locally_finite_basis : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  exists Fams:set, countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall F:set, F :e Fams -> locally_finite_family X Tx F) /\
    basis_on X (Union Fams) /\
    forall b:set, b :e Union Fams -> b :e Tx.

(** helper: second countable implies sigma locally finite basis (singleton decomposition) **)
Theorem second_countable_implies_sigma_locally_finite_basis : forall X Tx:set,
  second_countable_space X Tx -> sigma_locally_finite_basis X Tx.
let X Tx.
assume Hscc: second_countable_space X Tx.
prove sigma_locally_finite_basis X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hscc). }
prove topology_on X Tx /\
  exists Fams:set, countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall F:set, F :e Fams -> locally_finite_family X Tx F) /\
    basis_on X (Union Fams) /\
    forall b:set, b :e Union Fams -> b :e Tx.
apply andI.
- exact HTx.
- apply HexB.
  let B. assume HB: basis_on X B /\ countable_set B /\ basis_generates X B Tx.
  set Fams := {{b}|b :e B}.
  witness Fams.
  claim HB12: (basis_on X B /\ countable_set B) /\ basis_generates X B Tx.
  { exact HB. }
  claim HBasisCount: basis_on X B /\ countable_set B.
  { exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HB12). }
  claim HBgener: basis_generates X B Tx.
  { exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HB12). }
  claim HBasis: basis_on X B.
  { exact (andEL (basis_on X B) (countable_set B) HBasisCount). }
  claim HBcount: countable_set B.
  { exact (andER (basis_on X B) (countable_set B) HBasisCount). }
  claim HgenEq: generated_topology X B = Tx.
  { exact (andER (basis_on X B) (generated_topology X B = Tx) HBgener). }
  claim HBsubPow: B c= Power X.
  { exact (basis_on_sub_Power X B HBasis). }
  claim HUnionEq: Union Fams = B.
  { apply set_ext.
    - let u. assume Hu: u :e Union Fams.
      prove u :e B.
      apply (UnionE_impred Fams u Hu (u :e B)).
      let G. assume HuG: u :e G. assume HGF: G :e Fams.
      apply (ReplE_impred B (fun b0:set => {b0}) G HGF).
      let u0. assume Hu0B: u0 :e B.
      assume HeqG: G = {u0}.
      claim HuEq: u = u0.
      { claim HuG0: u :e {u0}.
        { rewrite <- HeqG.
          exact HuG. }
        exact (SingE u0 u HuG0). }
      rewrite HuEq.
      exact Hu0B.
    - let u. assume HuB: u :e B.
      prove u :e Union Fams.
      claim HuFam: {u} :e Fams.
      { exact (ReplI B (fun b0:set => {b0}) u HuB). }
      exact (UnionI Fams u {u} (SingI u) HuFam). }
  prove countable_set Fams /\ Fams c= Power (Power X) /\
    (forall F:set, F :e Fams -> locally_finite_family X Tx F) /\
    basis_on X (Union Fams) /\
    forall b:set, b :e Union Fams -> b :e Tx.
  apply and5I.
  - (** countable_set Fams **)
    exact (countable_image B HBcount (fun b:set => {b})).
  - (** Fams c= Power (Power X) **)
    prove Fams c= Power (Power X).
    let G. assume HG: G :e Fams.
    prove G :e Power (Power X).
    apply (ReplE_impred B (fun b:set => {b}) G HG).
    let u. assume HuB: u :e B.
    assume HeqG: G = {u}.
    rewrite HeqG.
    claim HuPow: u :e Power X.
    { exact (HBsubPow u HuB). }
    claim HsubPow: {u} c= Power X.
    { let z. assume Hz: z :e {u}.
      prove z :e Power X.
      claim Hzu: z = u.
      { exact (SingE u z Hz). }
      rewrite Hzu.
      exact HuPow. }
    exact (PowerI (Power X) {u} HsubPow).
  - (** each family is locally finite **)
    let G. assume HG: G :e Fams.
    prove locally_finite_family X Tx G.
    apply (ReplE_impred B (fun b:set => {b}) G HG).
    let u. assume HuB: u :e B.
    assume HeqG: G = {u}.
    rewrite HeqG.
    exact (finite_family_locally_finite_family X Tx {u} HTx (Sing_finite u)).
  - (** Union Fams is a basis **)
    rewrite HUnionEq.
    exact HBasis.
  - (** basis elements are open in Tx **)
    let u. assume HuFam: u :e Union Fams.
    prove u :e Tx.
    claim HuB: u :e B.
    { rewrite <- HUnionEq.
      exact HuFam. }
    claim HuPow: u :e Power X.
    { exact (HBsubPow u HuB). }
    claim HuTop: u :e generated_topology X B.
    { exact (generated_topology_contains_elem X B u HuPow HuB). }
    rewrite <- HgenEq.
    exact HuTop.
Qed.

(** from §40 Nagata-Smirnov metrization theorem **) 
(** LATEX VERSION: Nagata–Smirnov: A regular space with a σ-locally-finite basis is metrizable. **)
Theorem Nagata_Smirnov_metrization : forall X Tx:set,
  regular_space X Tx -> sigma_locally_finite_basis X Tx -> metrizable X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume Hbasis: sigma_locally_finite_basis X Tx.
prove metrizable X Tx.
admit. (** FAIL **)
Qed.

(** helper: locally finite basis implies sigma-locally finite basis (singleton family) **)
Theorem locally_finite_basis_imp_sigma_locally_finite_basis : forall X Tx:set,
  locally_finite_basis X Tx -> sigma_locally_finite_basis X Tx.
let X Tx.
assume Hlfb: locally_finite_basis X Tx.
prove sigma_locally_finite_basis X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ locally_finite_family X Tx B /\ (forall b:set, b :e B -> b :e Tx))
               Hlfb). }
prove topology_on X Tx /\
  exists Fams:set, countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall F:set, F :e Fams -> locally_finite_family X Tx F) /\
    basis_on X (Union Fams) /\
    forall b:set, b :e Union Fams -> b :e Tx.
apply andI.
- exact HTx.
- claim HexB: exists B:set, basis_on X B /\ locally_finite_family X Tx B /\ (forall b:set, b :e B -> b :e Tx).
  { exact (andER (topology_on X Tx)
                 (exists B:set, basis_on X B /\ locally_finite_family X Tx B /\ (forall b:set, b :e B -> b :e Tx))
                 Hlfb). }
  apply HexB.
  let B. assume HB: basis_on X B /\ locally_finite_family X Tx B /\ (forall b:set, b :e B -> b :e Tx).
  claim HBpair: basis_on X B /\ locally_finite_family X Tx B.
  { exact (andEL (basis_on X B /\ locally_finite_family X Tx B)
                 (forall b:set, b :e B -> b :e Tx)
                 HB). }
  claim HBbasis: basis_on X B.
  { exact (andEL (basis_on X B) (locally_finite_family X Tx B) HBpair). }
  claim HBlf: locally_finite_family X Tx B.
  { exact (andER (basis_on X B) (locally_finite_family X Tx B) HBpair). }
  claim HBopen: forall b:set, b :e B -> b :e Tx.
  { exact (andER (basis_on X B /\ locally_finite_family X Tx B)
                 (forall b:set, b :e B -> b :e Tx)
                 HB). }
  set Fams := Sing B.
  witness Fams.
  (** follow left associativity: (((A /\ B) /\ C) /\ D) /\ E **)
  apply andI.
  - (** left part: ((countable_set Fams /\ Fams c= Power(Power X)) /\ ...) /\ basis_on ... **)
    apply andI.
    + (** left: (countable_set Fams /\ Fams c= Power (Power X)) /\ (forall F, ...) **)
      apply andI.
      * (** countable_set Fams /\ Fams c= Power (Power X) **)
        apply andI.
        - prove countable_set Fams.
           prove countable Fams.
           exact (finite_countable Fams (Sing_finite B)).
        - (** Fams c= Power (Power X) **)
           prove Fams c= Power (Power X).
           let F. assume HF: F :e Fams.
           prove F :e Power (Power X).
           claim HeqF: F = B.
           { exact (SingE B F HF). }
           rewrite HeqF.
           claim HBsub: B c= Power X.
           { exact (basis_on_sub_Power X B HBbasis). }
           exact (PowerI (Power X) B HBsub).
      * (** each F in Fams is locally_finite_family **)
        let F. assume HF: F :e Fams.
        prove locally_finite_family X Tx F.
        claim HeqF: F = B.
        { exact (SingE B F HF). }
        rewrite HeqF.
        exact HBlf.
    + (** basis_on X (Union Fams) **)
      prove basis_on X (Union Fams).
      claim HUnionEq: Union Fams = B.
      { apply (set_ext (Union Fams) B).
        - let y. assume Hy: y :e Union Fams.
          apply (UnionE_impred Fams y Hy (y :e B)).
          let Y. assume HyY: y :e Y. assume HYF: Y :e Fams.
          claim HeqY: Y = B.
          { exact (SingE B Y HYF). }
          rewrite <- HeqY.
          exact HyY.
        - let y. assume Hy: y :e B.
          exact (UnionI Fams y B Hy (SingI B)). }
      rewrite HUnionEq.
      exact HBbasis.
  - (** every b in Union Fams is open **)
    let b. assume Hb: b :e Union Fams.
    prove b :e Tx.
    claim HUnionEq: Union Fams = B.
    { apply (set_ext (Union Fams) B).
      - let y. assume Hy: y :e Union Fams.
        apply (UnionE_impred Fams y Hy (y :e B)).
        let Y. assume HyY: y :e Y. assume HYF: Y :e Fams.
        claim HeqY: Y = B.
        { exact (SingE B Y HYF). }
        rewrite <- HeqY.
        exact HyY.
      - let y. assume Hy: y :e B.
        exact (UnionI Fams y B Hy (SingI B)). }
    claim HbB: b :e B.
    { rewrite <- HUnionEq.
      exact Hb. }
    exact (HBopen b HbB).
Qed.

(** from §41 Definition: paracompact space **) 
(** LATEX VERSION: Paracompact = every open cover has a locally finite open refinement. **)
Definition paracompact_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall U:set, open_cover X Tx U ->
    exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.

(** from §41 Theorem: existence of locally finite refinements **) 
(** LATEX VERSION: Any paracompact space admits a locally finite open refinement of every open cover. **)
Theorem locally_finite_refinement : forall X Tx U:set,
  paracompact_space X Tx -> open_cover X Tx U -> exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V.
let X Tx U.
assume Hpara: paracompact_space X Tx.
assume Hcover: open_cover X Tx U.
prove exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V.
(** Extract the forall from paracompact definition **)
claim Hforall: forall U0:set, open_cover X Tx U0 ->
    exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U0.
{ exact (andER (topology_on X Tx)
               (forall U0:set, open_cover X Tx U0 ->
                  exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U0)
               Hpara). }
(** Apply to U and extract V **)
claim Hexists: exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
{ exact (Hforall U Hcover). }
apply Hexists.
let V. assume HV.
witness V.
(** Extract just the first two conjuncts, dropping refine_of **)
exact (andEL (open_cover X Tx V /\ locally_finite_family X Tx V) (refine_of V U) HV).
Qed.

(** helper: paracompact Hausdorff implies regular **)
(** LATEX VERSION: Standard separation upgrade using locally finite refinement of the Hausdorff point-separators. **)
Theorem paracompact_Hausdorff_regular : forall X Tx:set,
  paracompact_space X Tx -> Hausdorff_space X Tx -> regular_space X Tx.
let X Tx.
assume Hpara: paracompact_space X Tx.
assume HH: Hausdorff_space X Tx.
prove regular_space X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                 exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
               Hpara). }
prove one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- prove topology_on X Tx /\ forall x:set, x :e X -> closed_in X Tx {x}.
  apply andI.
  - exact HTx.
  - let x. assume HxX: x :e X.
    exact (Hausdorff_singletons_closed X Tx x HH HxX).
- let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxNotF: x /:e F.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.

  claim HFsubX: F c= X.
  { exact (closed_in_subset X Tx F HFcl). }
  set U0 := X :\: F.
  claim HU0open: open_in X Tx U0.
  { exact (open_of_closed_complement X Tx F HFcl). }
  claim HU0Tx: U0 :e Tx.
  { exact (open_in_elem X Tx U0 HU0open). }
  claim HxU0: x :e U0.
  { apply setminusI.
    - exact HxX.
    - exact HxNotF. }

  (** choose separating neighborhoods of x and each point of F **)
  set sepU := fun y:set =>
    Eps_i (fun U:set => exists V:set,
      U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty).
  set sepV := fun y:set =>
    Eps_i (fun V:set =>
      (sepU y) :e Tx /\ V :e Tx /\ x :e (sepU y) /\ y :e V /\ (sepU y) :/\: V = Empty).

  claim HsepVprop: forall y:set, y :e F ->
    (sepU y) :e Tx /\ (sepV y) :e Tx /\ x :e (sepU y) /\ y :e (sepV y) /\ (sepU y) :/\: (sepV y) = Empty.
  { let y. assume HyF: y :e F.
    claim HyX: y :e X.
    { exact (HFsubX y HyF). }
    claim Hneq: x <> y.
    { assume Hxy: x = y.
      claim HxF: x :e F.
      { rewrite Hxy.
        exact HyF. }
      exact (HxNotF HxF). }
    claim HexSep: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
    { exact (Hausdorff_space_separation X Tx x y HH HxX HyX Hneq). }
    claim HexU: exists U:set, exists V:set, U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty.
    { exact HexSep. }
    claim HsepUex: exists V:set,
      (sepU y) :e Tx /\ V :e Tx /\ x :e (sepU y) /\ y :e V /\ (sepU y) :/\: V = Empty.
    { exact (Eps_i_ex (fun U:set => exists V:set,
               U :e Tx /\ V :e Tx /\ x :e U /\ y :e V /\ U :/\: V = Empty) HexU). }
    claim HexV: exists V:set,
      (sepU y) :e Tx /\ V :e Tx /\ x :e (sepU y) /\ y :e V /\ (sepU y) :/\: V = Empty.
    { exact HsepUex. }
    claim HsepVex: (sepU y) :e Tx /\ (sepV y) :e Tx /\ x :e (sepU y) /\ y :e (sepV y) /\ (sepU y) :/\: (sepV y) = Empty.
    { exact (Eps_i_ex (fun V:set =>
             (sepU y) :e Tx /\ V :e Tx /\ x :e (sepU y) /\ y :e V /\ (sepU y) :/\: V = Empty) HexV). }
    exact HsepVex. }

  set VFam := {sepV y|y :e F}.
  set Cover := {U0} :\/: VFam.

  claim HCoverOpen: forall u:set, u :e Cover -> u :e Tx.
  { let u. assume Hu: u :e Cover.
    prove u :e Tx.
    apply (binunionE' {U0} VFam u (u :e Tx)).
    - assume Hu0: u :e {U0}.
      claim Heq: u = U0.
      { exact (SingE U0 u Hu0). }
      rewrite Heq.
      exact HU0Tx.
    - assume HuV: u :e VFam.
      apply (ReplE_impred F (fun y:set => sepV y) u HuV (u :e Tx)).
      let y. assume HyF: y :e F.
      assume Hueq: u = sepV y.
      claim Hsep: (sepU y) :e Tx /\ (sepV y) :e Tx /\ x :e (sepU y) /\ y :e (sepV y) /\ (sepU y) :/\: (sepV y) = Empty.
      { exact (HsepVprop y HyF). }
      rewrite Hueq.
      claim H1: (((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y) /\ y :e (sepV y)).
      { exact (andEL ((((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y) /\ y :e (sepV y)))
                     ((sepU y) :/\: (sepV y) = Empty)
                     Hsep). }
      claim H2: (((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y)).
      { exact (andEL ((((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y)))
                     (y :e (sepV y))
                     H1). }
      claim H3: ((sepU y) :e Tx /\ (sepV y) :e Tx).
      { exact (andEL (((sepU y) :e Tx /\ (sepV y) :e Tx))
                     (x :e (sepU y))
                     H2). }
      exact (andER ((sepU y) :e Tx) ((sepV y) :e Tx) H3).
    - exact Hu. }

  claim HCoverCovers: covers X Cover.
  { let z. assume HzX: z :e X.
    apply (xm (z :e F)).
    - assume HzF: z :e F.
      witness (sepV z).
      apply andI.
      + exact (binunionI2 {U0} VFam (sepV z) (ReplI F (fun y:set => sepV y) z HzF)).
      + claim Hsep: (sepU z) :e Tx /\ (sepV z) :e Tx /\ x :e (sepU z) /\ z :e (sepV z) /\ (sepU z) :/\: (sepV z) = Empty.
        { exact (HsepVprop z HzF). }
        claim Hleft: (((sepU z) :e Tx /\ (sepV z) :e Tx) /\ x :e (sepU z) /\ z :e (sepV z)).
        { exact (andEL ((((sepU z) :e Tx /\ (sepV z) :e Tx) /\ x :e (sepU z) /\ z :e (sepV z)))
                       ((sepU z) :/\: (sepV z) = Empty)
                       Hsep). }
        exact (andER (((sepU z) :e Tx /\ (sepV z) :e Tx) /\ x :e (sepU z))
                     (z :e (sepV z))
                     Hleft).
    - assume HzNotF: ~(z :e F).
      witness U0.
      apply andI.
      + exact (binunionI1 {U0} VFam U0 (SingI U0)).
      + exact (setminusI X F z HzX HzNotF). }

  claim Hcover: open_cover X Tx Cover.
  { exact (andI (forall u:set, u :e Cover -> u :e Tx)
                (covers X Cover)
                HCoverOpen
                HCoverCovers). }

  (** paracompactness yields a locally finite open refinement **)
  claim Href: exists W:set, open_cover X Tx W /\ locally_finite_family X Tx W /\ refine_of W Cover.
  { exact (andER (topology_on X Tx)
                 (forall U:set, open_cover X Tx U ->
                   exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
                 Hpara Cover Hcover). }

  apply Href.
  let W. assume HW: open_cover X Tx W /\ locally_finite_family X Tx W /\ refine_of W Cover.

  set WF := {w :e W | w :/\: F <> Empty}.
  set V := Union WF.

  (** unpack refinement data **)
  claim HWpair: open_cover X Tx W /\ locally_finite_family X Tx W.
  { exact (andEL (open_cover X Tx W /\ locally_finite_family X Tx W)
                 (refine_of W Cover)
                 HW). }
  claim HWref: refine_of W Cover.
  { exact (andER (open_cover X Tx W /\ locally_finite_family X Tx W)
                 (refine_of W Cover)
                 HW). }
  claim HWcover: open_cover X Tx W.
  { exact (andEL (open_cover X Tx W) (locally_finite_family X Tx W) HWpair). }
  claim HLFW: locally_finite_family X Tx W.
  { exact (andER (open_cover X Tx W) (locally_finite_family X Tx W) HWpair). }
  claim HWopen: forall w:set, w :e W -> w :e Tx.
  { exact (andEL (forall w:set, w :e W -> w :e Tx) (covers X W) HWcover). }
  claim HWcovers: covers X W.
  { exact (andER (forall w:set, w :e W -> w :e Tx) (covers X W) HWcover). }

  (** WF is a locally finite open family **)
  claim HWFsubW: WF c= W.
  { exact (Sep_Subq W (fun w:set => w :/\: F <> Empty)). }
  claim HLF_WF: locally_finite_family X Tx WF.
  { exact (locally_finite_subfamily X Tx W WF HLFW HWFsubW). }
  claim HWFsubTx: WF c= Tx.
  { let w. assume HwWF: w :e WF.
    claim HwW: w :e W.
    { exact (SepE1 W (fun w0:set => w0 :/\: F <> Empty) w HwWF). }
    exact (HWopen w HwW). }

  (** V is open and contains F **)
  claim HVTx: V :e Tx.
  { exact (topology_union_closed X Tx WF HTx HWFsubTx). }
  claim HVsubX: V c= X.
  { let z. assume HzV: z :e V.
    apply (UnionE_impred WF z HzV).
    let w. assume Hzw: z :e w.
    assume HwWF: w :e WF.
    claim HwTx: w :e Tx.
    { exact (HWFsubTx w HwWF). }
    claim HwsubX: w c= X.
    { exact (topology_elem_subset X Tx w HTx HwTx). }
    exact (HwsubX z Hzw). }
  claim HFsubV: F c= V.
  { let y. assume HyF: y :e F.
    prove y :e V.
    claim HyX: y :e X.
    { exact (HFsubX y HyF). }
    apply (HWcovers y HyX).
    let w. assume HwW: w :e W /\ y :e w.
    claim HwInW: w :e W.
    { exact (andEL (w :e W) (y :e w) HwW). }
    claim Hyw: y :e w.
    { exact (andER (w :e W) (y :e w) HwW). }
    claim HwFnon: w :/\: F <> Empty.
    { exact (elem_implies_nonempty (w :/\: F) y (binintersectI w F y Hyw HyF)). }
    claim HwWF: w :e WF.
    { exact (SepI W (fun w0:set => w0 :/\: F <> Empty) w HwInW HwFnon). }
    exact (UnionI WF y w Hyw HwWF). }

  (** build the closed set C := Union closures(WF) = closure(V) and take U = X\\C **)
  set ClWF := {closure_of X Tx w|w :e WF}.
  set C := Union ClWF.
  claim HWFsubX: forall w:set, w :e WF -> w c= X.
  { let w. assume HwWF: w :e WF.
    claim HwTx: w :e Tx.
    { exact (HWFsubTx w HwWF). }
    exact (topology_elem_subset X Tx w HTx HwTx). }
  claim HVdef: V = Union WF.
  { reflexivity. }
  claim HclVsubC': closure_of X Tx (Union WF) c= C.
  { exact (closure_Union_locally_finite_subset_Union_closures X Tx WF HWFsubX HLF_WF). }
  claim HclVsubC: closure_of X Tx V c= C.
  { rewrite HVdef.
    exact HclVsubC'. }

  claim HCsubclV: C c= closure_of X Tx V.
  { let z. assume HzC: z :e C.
    prove z :e closure_of X Tx V.
    apply (UnionE_impred ClWF z HzC).
    let clw. assume Hzclw: z :e clw.
    assume Hclw: clw :e ClWF.
    apply (ReplE_impred WF (fun w:set => closure_of X Tx w) clw Hclw).
    let w. assume HwWF: w :e WF.
    assume Hclweq: clw = closure_of X Tx w.
    claim Hzclw2: z :e closure_of X Tx w.
    { rewrite <- Hclweq.
      exact Hzclw. }
    (** w c= V and V c= X, hence closure(w) c= closure(V) **)
    claim HwsubV: w c= V.
    { let t. assume Htw: t :e w.
      exact (UnionI WF t w Htw HwWF). }
    claim Hclwsub: closure_of X Tx w c= closure_of X Tx V.
    { exact (closure_monotone X Tx w V HTx HwsubV HVsubX). }
    exact (Hclwsub z Hzclw2). }

  claim HCeq: closure_of X Tx V = C.
  { apply set_ext.
    - exact HclVsubC.
    - exact HCsubclV. }

  claim HCclosed: closed_in X Tx C.
  { rewrite <- HCeq.
    exact (closure_is_closed X Tx V HTx HVsubX). }
  set U := X :\: C.
  claim HUopen: open_in X Tx U.
  { exact (open_of_closed_complement X Tx C HCclosed). }
  claim HUTx: U :e Tx.
  { exact (open_in_elem X Tx U HUopen). }

  (** x belongs to U by showing x is in no closure(w) for w in WF **)
  claim HxNotC: x /:e C.
  { assume HxC: x :e C.
    apply (UnionE_impred ClWF x HxC).
    let clw. assume Hxclw: x :e clw.
    assume Hclw: clw :e ClWF.
    apply (ReplE_impred WF (fun w:set => closure_of X Tx w) clw Hclw).
    let w. assume HwWF: w :e WF.
    assume Hclweq: clw = closure_of X Tx w.
    claim Hxclw2: x :e closure_of X Tx w.
    { rewrite <- Hclweq.
      exact Hxclw. }
    (** get u in Cover with w c= u; since w meets F, u cannot be U0, hence u = sepV y for some y∈F **)
    claim HwW: w :e W.
    { exact (HWFsubW w HwWF). }
    claim Hexu: exists u:set, u :e Cover /\ w c= u.
    { exact (HWref w HwW). }
    apply Hexu.
    let u. assume Hu: u :e Cover /\ w c= u.
    claim HuCover: u :e Cover.
    { exact (andEL (u :e Cover) (w c= u) Hu). }
    claim Hwsubu: w c= u.
    { exact (andER (u :e Cover) (w c= u) Hu). }
    (** split u ∈ {U0} ∪ VFam **)
    claim HxNotclw: x /:e closure_of X Tx w.
    { apply (binunionE {U0} VFam u HuCover).
      - assume Hu0: u :e {U0}.
        claim Hueq: u = U0.
        { exact (SingE U0 u Hu0). }
        claim HwsubU0: w c= U0.
        { let t. assume Htw: t :e w.
          prove t :e U0.
          rewrite <- Hueq.
          exact (Hwsubu t Htw). }
        (** w ⊆ U0 implies w∩F = Empty, contradicting w∈WF **)
        claim HwFnon: w :/\: F <> Empty.
        { exact (SepE2 W (fun w0:set => w0 :/\: F <> Empty) w HwWF). }
        claim HwFsubEmpty: w :/\: F c= Empty.
        { let t. assume Ht: t :e w :/\: F.
          prove t :e Empty.
          claim Htpair: t :e w /\ t :e F.
          { exact (binintersectE w F t Ht). }
          claim Htw: t :e w.
          { exact (andEL (t :e w) (t :e F) Htpair). }
          claim HtF: t :e F.
          { exact (andER (t :e w) (t :e F) Htpair). }
          claim HtU0: t :e U0.
          { exact (HwsubU0 t Htw). }
          claim HtNotF: t /:e F.
          { exact (setminusE2 X F t HtU0). }
          apply FalseE.
          exact (HtNotF HtF). }
        claim HwFEmpty: w :/\: F = Empty.
        { exact (Empty_Subq_eq (w :/\: F) HwFsubEmpty). }
        apply FalseE.
        exact (HwFnon HwFEmpty).
      - assume HuV: u :e VFam.
        (** obtain y with u = sepV y **)
        apply (ReplE_impred F (fun y0:set => sepV y0) u HuV (x /:e closure_of X Tx w)).
        let y. assume HyF: y :e F.
        assume Hueq: u = sepV y.
        claim HwsubVy: w c= sepV y.
        { let t. assume Htw: t :e w.
          prove t :e sepV y.
          rewrite <- Hueq.
          exact (Hwsubu t Htw). }
        claim Hsep: (sepU y) :e Tx /\ (sepV y) :e Tx /\ x :e (sepU y) /\ y :e (sepV y) /\ (sepU y) :/\: (sepV y) = Empty.
        { exact (HsepVprop y HyF). }
        claim Hleft: (((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y) /\ y :e (sepV y)).
        { exact (andEL ((((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y) /\ y :e (sepV y)))
                       ((sepU y) :/\: (sepV y) = Empty)
                       Hsep). }
        claim Hdisj: (sepU y) :/\: (sepV y) = Empty.
        { exact (andER ((((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y) /\ y :e (sepV y)))
                       ((sepU y) :/\: (sepV y) = Empty)
                       Hsep). }
        claim Htmp: (((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y)).
        { exact (andEL ((((sepU y) :e Tx /\ (sepV y) :e Tx) /\ x :e (sepU y)))
                       (y :e (sepV y))
                       Hleft). }
        claim HUV: ((sepU y) :e Tx /\ (sepV y) :e Tx).
        { exact (andEL (((sepU y) :e Tx /\ (sepV y) :e Tx))
                       (x :e (sepU y))
                       Htmp). }
        claim HUyTx: (sepU y) :e Tx.
        { exact (andEL ((sepU y) :e Tx) ((sepV y) :e Tx) HUV). }
        claim HxUy: x :e sepU y.
        { exact (andER (((sepU y) :e Tx /\ (sepV y) :e Tx)) (x :e (sepU y)) Htmp). }
        (** sepU y is a neighborhood of x disjoint from w (since w ⊆ sepV y) **)
        claim HUywEmpty: (sepU y) :/\: w = Empty.
        { apply Empty_Subq_eq.
          let t. assume Ht: t :e (sepU y) :/\: w.
          prove t :e Empty.
          claim Htpair: t :e sepU y /\ t :e w.
          { exact (binintersectE (sepU y) w t Ht). }
          claim HtUy: t :e sepU y.
          { exact (andEL (t :e sepU y) (t :e w) Htpair). }
          claim Htw: t :e w.
          { exact (andER (t :e sepU y) (t :e w) Htpair). }
          claim HtVy: t :e sepV y.
          { exact (HwsubVy t Htw). }
          claim HtUyVy: t :e (sepU y) :/\: (sepV y).
          { exact (binintersectI (sepU y) (sepV y) t HtUy HtVy). }
          rewrite <- Hdisj.
          exact HtUyVy. }
        (** if x were in closure(w), then sepU y ∩ w would be nonempty, contradiction **)
        claim Hclprop: forall U:set, U :e Tx -> x :e U -> U :/\: w <> Empty.
        { exact (SepE2 X (fun x0:set => forall U:set, U :e Tx -> x0 :e U -> U :/\: w <> Empty) x Hxclw2). }
        claim Hnon: (sepU y) :/\: w <> Empty.
        { exact (Hclprop (sepU y) HUyTx HxUy). }
        apply FalseE.
        exact (Hnon HUywEmpty). }
    exact (HxNotclw Hxclw2).
  }

  claim HxU: x :e U.
  { exact (setminusI X C x HxX HxNotC). }

  (** U and V are disjoint since V ⊆ C **)
  claim HVsubC: V c= C.
  { let z. assume HzV: z :e V.
    prove z :e C.
    apply (UnionE_impred WF z HzV).
    let w. assume Hzw: z :e w.
    assume HwWF: w :e WF.
    claim HwsubX: w c= X.
    { exact (HWFsubX w HwWF). }
    claim Hzclw: z :e closure_of X Tx w.
    { exact (subset_of_closure X Tx w HTx HwsubX z Hzw). }
    exact (UnionI ClWF z (closure_of X Tx w) Hzclw (ReplI WF (fun w0:set => closure_of X Tx w0) w HwWF)). }
  claim HUdisjV: U :/\: V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e U :/\: V.
    prove z :e Empty.
    claim Hzpair: z :e U /\ z :e V.
    { exact (binintersectE U V z Hz). }
    claim HzU: z :e U.
    { exact (andEL (z :e U) (z :e V) Hzpair). }
    claim HzV: z :e V.
    { exact (andER (z :e U) (z :e V) Hzpair). }
    claim HzNotC: z /:e C.
    { exact (setminusE2 X C z HzU). }
    claim HzC: z :e C.
    { exact (HVsubC z HzV). }
    apply FalseE.
    exact (HzNotC HzC). }

  witness U.
  witness V.
  apply and5I.
  - exact HUTx.
  - exact HVTx.
  - exact HxU.
  - exact HFsubV.
  - exact HUdisjV.
Qed.

(** from §41 Theorem: paracompact Hausdorff implies normal **) 
(** LATEX VERSION: Paracompact Hausdorff spaces are normal. **)
Theorem paracompact_Hausdorff_normal : forall X Tx:set,
  paracompact_space X Tx -> Hausdorff_space X Tx -> normal_space X Tx.
let X Tx.
assume Hpara: paracompact_space X Tx.
assume HH: Hausdorff_space X Tx.
prove normal_space X Tx.
(** unpack topology_on from paracompactness **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                 exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
               Hpara). }

(** one-point sets are closed in Hausdorff spaces **)
claim HT1: one_point_sets_closed X Tx.
{ prove topology_on X Tx /\ forall x:set, x :e X -> closed_in X Tx {x}.
  apply andI.
  - exact HTx.
  - let x. assume HxX: x :e X.
    exact (Hausdorff_singletons_closed X Tx x HH HxX). }

prove one_point_sets_closed X Tx /\
  forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
apply andI.
- exact HT1.
- let A B.
  assume HAcl: closed_in X Tx A.
  assume HBcl: closed_in X Tx B.
  assume Hdisj: A :/\: B = Empty.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  (** reduce to the regular-space form, then use the standard paracompact argument **)
  claim Hreg: regular_space X Tx.
  { exact (paracompact_Hausdorff_regular X Tx Hpara HH). }
  (** Extract the separation clause from regularity **)
  claim HregSep: forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  { exact (andER (one_point_sets_closed X Tx)
                 (forall x:set, x :e X ->
                   forall F:set, closed_in X Tx F -> x /:e F ->
                     exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
                 Hreg). }

  claim HAsubX: A c= X.
  { exact (closed_in_subset X Tx A HAcl). }
  claim HBsubX: B c= X.
  { exact (closed_in_subset X Tx B HBcl). }

  (** Choose separating neighborhoods for each a in A from the closed set B **)
  set sepU := fun a:set =>
    Eps_i (fun U:set => exists V:set,
      U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty).
  set sepV := fun a:set =>
    Eps_i (fun V:set =>
      (sepU a) :e Tx /\ V :e Tx /\ a :e (sepU a) /\ B c= V /\ (sepU a) :/\: V = Empty).

  claim HsepProp: forall a:set, a :e A ->
    (sepU a) :e Tx /\ (sepV a) :e Tx /\ a :e (sepU a) /\ B c= (sepV a) /\ (sepU a) :/\: (sepV a) = Empty.
  { let a. assume HaA: a :e A.
    claim HaX: a :e X.
    { exact (HAsubX a HaA). }
    claim HaNotB: a /:e B.
    { assume HaB: a :e B.
      prove False.
      claim HaAB: a :e A :/\: B.
      { exact (binintersectI A B a HaA HaB). }
      claim HaEmpty: a :e Empty.
      { rewrite <- Hdisj.
        exact HaAB. }
      exact ((EmptyE a) HaEmpty). }
    claim HexSep: exists U V:set, U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty.
    { exact (HregSep a HaX B HBcl HaNotB). }
    claim HexU: exists U:set, exists V:set,
      U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty.
    { exact HexSep. }
    claim HsepUex: exists V:set,
      (sepU a) :e Tx /\ V :e Tx /\ a :e (sepU a) /\ B c= V /\ (sepU a) :/\: V = Empty.
    { exact (Eps_i_ex (fun U:set => exists V:set,
               U :e Tx /\ V :e Tx /\ a :e U /\ B c= V /\ U :/\: V = Empty) HexU). }
    claim HexV: exists V:set,
      (sepU a) :e Tx /\ V :e Tx /\ a :e (sepU a) /\ B c= V /\ (sepU a) :/\: V = Empty.
    { exact HsepUex. }
    exact (Eps_i_ex (fun V:set =>
             (sepU a) :e Tx /\ V :e Tx /\ a :e (sepU a) /\ B c= V /\ (sepU a) :/\: V = Empty) HexV). }

  (** Open cover: (X\\A) plus the separators sepU(a) **)
  set U0 := X :\: A.
  claim HU0Tx: U0 :e Tx.
  { claim HU0open: open_in X Tx U0.
    { exact (open_of_closed_complement X Tx A HAcl). }
    exact (open_in_elem X Tx U0 HU0open). }
  set UFam := {sepU a|a :e A}.
  set Cover := {U0} :\/: UFam.

  claim HCoverOpen: forall u:set, u :e Cover -> u :e Tx.
  { let u. assume Hu: u :e Cover.
    prove u :e Tx.
    apply (binunionE' {U0} UFam u (u :e Tx)).
    - assume Hu0: u :e {U0}.
      claim Hueq: u = U0.
      { exact (SingE U0 u Hu0). }
      rewrite Hueq.
      exact HU0Tx.
    - assume HuU: u :e UFam.
      apply (ReplE_impred A (fun a:set => sepU a) u HuU (u :e Tx)).
      let a. assume HaA: a :e A.
      assume Hueq: u = sepU a.
      claim Hsep: (sepU a) :e Tx /\ (sepV a) :e Tx /\ a :e (sepU a) /\ B c= (sepV a) /\ (sepU a) :/\: (sepV a) = Empty.
      { exact (HsepProp a HaA). }
      rewrite Hueq.
      (** destruct the left-associated conjunction to get (sepU a) :e Tx **)
      claim Hpqrs: (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a)) /\ B c= (sepV a).
      { exact (andEL ((((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a)) /\ B c= (sepV a))
                     ((sepU a) :/\: (sepV a) = Empty)
                     Hsep). }
      claim Hpqr: ((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a).
      { exact (andEL (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a))
                     (B c= (sepV a))
                     Hpqrs). }
      claim Hpq: (sepU a) :e Tx /\ (sepV a) :e Tx.
      { exact (andEL ((sepU a) :e Tx /\ (sepV a) :e Tx)
                     (a :e (sepU a))
                     Hpqr). }
      exact (andEL ((sepU a) :e Tx) ((sepV a) :e Tx) Hpq).
    - exact Hu. }

  claim HCoverCovers: covers X Cover.
  { let x. assume HxX: x :e X.
    apply (xm (x :e A)).
    - assume HxA: x :e A.
      witness (sepU x).
      apply andI.
      + exact (binunionI2 {U0} UFam (sepU x) (ReplI A (fun a:set => sepU a) x HxA)).
      + claim Hsep: (sepU x) :e Tx /\ (sepV x) :e Tx /\ x :e (sepU x) /\ B c= (sepV x) /\ (sepU x) :/\: (sepV x) = Empty.
        { exact (HsepProp x HxA). }
        claim Hpqrs: (((sepU x) :e Tx /\ (sepV x) :e Tx) /\ x :e (sepU x)) /\ B c= (sepV x).
        { exact (andEL ((((sepU x) :e Tx /\ (sepV x) :e Tx) /\ x :e (sepU x)) /\ B c= (sepV x))
                       ((sepU x) :/\: (sepV x) = Empty)
                       Hsep). }
        claim Hpqr: ((sepU x) :e Tx /\ (sepV x) :e Tx) /\ x :e (sepU x).
        { exact (andEL (((sepU x) :e Tx /\ (sepV x) :e Tx) /\ x :e (sepU x))
                       (B c= (sepV x))
                       Hpqrs). }
        exact (andER ((sepU x) :e Tx /\ (sepV x) :e Tx)
                     (x :e (sepU x))
                     Hpqr).
    - assume HxNotA: ~(x :e A).
      witness U0.
      apply andI.
      + exact (binunionI1 {U0} UFam U0 (SingI U0)).
      + exact (setminusI X A x HxX HxNotA). }

  claim Hcover: open_cover X Tx Cover.
  { exact (andI (forall u:set, u :e Cover -> u :e Tx)
                (covers X Cover)
                HCoverOpen
                HCoverCovers). }

  (** Apply paracompactness to obtain a locally finite open refinement W **)
  claim HparaFor: forall U:set, open_cover X Tx U ->
    exists W:set, open_cover X Tx W /\ locally_finite_family X Tx W /\ refine_of W U.
  { exact (andER (topology_on X Tx)
                 (forall U:set, open_cover X Tx U ->
                   exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
                 Hpara). }
  claim Href: exists W:set, open_cover X Tx W /\ locally_finite_family X Tx W /\ refine_of W Cover.
  { exact (HparaFor Cover Hcover). }
  apply Href.
  let W. assume HW: open_cover X Tx W /\ locally_finite_family X Tx W /\ refine_of W Cover.

  (** Subfamily meeting A and its union U **)
  set WF := {w :e W | w :/\: A <> Empty}.
  set U := Union WF.

  (** unpack refinement data **)
  claim HWpair: open_cover X Tx W /\ locally_finite_family X Tx W.
  { exact (andEL (open_cover X Tx W /\ locally_finite_family X Tx W)
                 (refine_of W Cover)
                 HW). }
  claim HWref: refine_of W Cover.
  { exact (andER (open_cover X Tx W /\ locally_finite_family X Tx W)
                 (refine_of W Cover)
                 HW). }
  claim HWcover: open_cover X Tx W.
  { exact (andEL (open_cover X Tx W) (locally_finite_family X Tx W) HWpair). }
  claim HLFW: locally_finite_family X Tx W.
  { exact (andER (open_cover X Tx W) (locally_finite_family X Tx W) HWpair). }
  claim HWopen: forall w:set, w :e W -> w :e Tx.
  { exact (andEL (forall w:set, w :e W -> w :e Tx) (covers X W) HWcover). }
  claim HWcovers: covers X W.
  { exact (andER (forall w:set, w :e W -> w :e Tx) (covers X W) HWcover). }

  (** WF is locally finite and its members are open **)
  claim HWFsubW: WF c= W.
  { exact (Sep_Subq W (fun w:set => w :/\: A <> Empty)). }
  claim HLF_WF: locally_finite_family X Tx WF.
  { exact (locally_finite_subfamily X Tx W WF HLFW HWFsubW). }
  claim HWFsubTx: WF c= Tx.
  { let w. assume HwWF: w :e WF.
    claim HwW: w :e W.
    { exact (SepE1 W (fun w0:set => w0 :/\: A <> Empty) w HwWF). }
    exact (HWopen w HwW). }

  (** U is open and contains A **)
  claim HUTx: U :e Tx.
  { exact (topology_union_closed X Tx WF HTx HWFsubTx). }
  claim HUsupX: U c= X.
  { let z. assume HzU: z :e U.
    apply (UnionE_impred WF z HzU).
    let w. assume Hzw: z :e w.
    assume HwWF: w :e WF.
    claim HwTx: w :e Tx.
    { exact (HWFsubTx w HwWF). }
    claim HwsubX: w c= X.
    { exact (topology_elem_subset X Tx w HTx HwTx). }
    exact (HwsubX z Hzw). }
  claim HAsubU: A c= U.
  { let a. assume HaA: a :e A.
    prove a :e U.
    claim HaX: a :e X.
    { exact (HAsubX a HaA). }
    apply (HWcovers a HaX).
    let w. assume Hw: w :e W /\ a :e w.
    claim HwW: w :e W.
    { exact (andEL (w :e W) (a :e w) Hw). }
    claim Haw: a :e w.
    { exact (andER (w :e W) (a :e w) Hw). }
    claim HwAne: w :/\: A <> Empty.
    { exact (elem_implies_nonempty (w :/\: A) a (binintersectI w A a Haw HaA)). }
    claim HwWF: w :e WF.
    { exact (SepI W (fun w0:set => w0 :/\: A <> Empty) w HwW HwAne). }
    exact (UnionI WF a w Haw HwWF). }

  (** Closed set C as union of closures of WF equals closure(U) **)
  set ClWF := {closure_of X Tx w|w :e WF}.
  set C := Union ClWF.
  claim HWFsubX: forall w:set, w :e WF -> w c= X.
  { let w. assume HwWF: w :e WF.
    claim HwTx: w :e Tx.
    { exact (HWFsubTx w HwWF). }
    exact (topology_elem_subset X Tx w HTx HwTx). }
  claim HUdef: U = Union WF.
  { reflexivity. }
  claim HclUsubC': closure_of X Tx (Union WF) c= C.
  { exact (closure_Union_locally_finite_subset_Union_closures X Tx WF HWFsubX HLF_WF). }
  claim HclUsubC: closure_of X Tx U c= C.
  { rewrite HUdef.
    exact HclUsubC'. }
  claim HCsubclU: C c= closure_of X Tx U.
  { let z. assume HzC: z :e C.
    prove z :e closure_of X Tx U.
    apply (UnionE_impred ClWF z HzC).
    let clw. assume Hzclw: z :e clw.
    assume Hclw: clw :e ClWF.
    apply (ReplE_impred WF (fun w:set => closure_of X Tx w) clw Hclw).
    let w. assume HwWF: w :e WF.
    assume Hclweq: clw = closure_of X Tx w.
    claim Hzclw2: z :e closure_of X Tx w.
    { rewrite <- Hclweq.
      exact Hzclw. }
    claim HwsubU: w c= U.
    { let t. assume Htw: t :e w.
      exact (UnionI WF t w Htw HwWF). }
    claim Hclwsub: closure_of X Tx w c= closure_of X Tx U.
    { exact (closure_monotone X Tx w U HTx HwsubU HUsupX). }
    exact (Hclwsub z Hzclw2). }
  claim HCeq: closure_of X Tx U = C.
  { apply set_ext.
    - exact HclUsubC.
    - exact HCsubclU. }
  claim HCclosed: closed_in X Tx C.
  { rewrite <- HCeq.
    exact (closure_is_closed X Tx U HTx HUsupX). }

  set V := X :\: C.
  claim HVopen: open_in X Tx V.
  { exact (open_of_closed_complement X Tx C HCclosed). }
  claim HVTx: V :e Tx.
  { exact (open_in_elem X Tx V HVopen). }

  (** U and V are disjoint **)
  claim HUsubC: U c= C.
  { rewrite <- HCeq.
    exact (subset_of_closure X Tx U HTx HUsupX). }
  claim HUdisjV: U :/\: V = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e U :/\: V.
    prove z :e Empty.
    claim Hzpair: z :e U /\ z :e V.
    { exact (binintersectE U V z Hz). }
    claim HzU: z :e U.
    { exact (andEL (z :e U) (z :e V) Hzpair). }
    claim HzV: z :e V.
    { exact (andER (z :e U) (z :e V) Hzpair). }
    claim HzC: z :e C.
    { exact (HUsubC z HzU). }
    claim HzNotC: z /:e C.
    { exact (setminusE2 X C z HzV). }
    apply FalseE.
    exact (HzNotC HzC). }

  (** B is contained in V since B is disjoint from each closure(w) with w meeting A **)
  claim HBsubV: B c= V.
  { let b. assume HbB: b :e B.
    prove b :e V.
    claim HbX: b :e X.
    { exact (HBsubX b HbB). }
    apply setminusI.
    - exact HbX.
    - assume HbC: b :e C.
      (** b in C gives b in closure(w) for some w in WF **)
      apply (UnionE_impred ClWF b HbC).
      let clw. assume Hbclw: b :e clw.
      assume Hclw: clw :e ClWF.
      apply (ReplE_impred WF (fun w:set => closure_of X Tx w) clw Hclw False).
      let w. assume HwWF: w :e WF.
      assume Hclweq: clw = closure_of X Tx w.
      claim Hbclw2: b :e closure_of X Tx w.
      { rewrite <- Hclweq.
        exact Hbclw. }
      (** pick u in Cover with w c= u; since w meets A, u is in UFam and equals sepU(a) for some a in A **)
      claim HwW: w :e W.
      { exact (HWFsubW w HwWF). }
      claim Hexu: exists u:set, u :e Cover /\ w c= u.
      { exact (HWref w HwW). }
      apply Hexu.
      let u. assume Hu: u :e Cover /\ w c= u.
      claim HuCover: u :e Cover.
      { exact (andEL (u :e Cover) (w c= u) Hu). }
      claim Hwsubu: w c= u.
      { exact (andER (u :e Cover) (w c= u) Hu). }
      apply (binunionE {U0} UFam u HuCover).
      - assume Hu0: u :e {U0}.
        claim Hueq: u = U0.
        { exact (SingE U0 u Hu0). }
        claim HwsubU0: w c= U0.
        { let t. assume Htw: t :e w.
          prove t :e U0.
          rewrite <- Hueq.
          exact (Hwsubu t Htw). }
        (** w ⊆ U0 implies w∩A = Empty, contradicting w∈WF **)
        claim HwAnon: w :/\: A <> Empty.
        { exact (SepE2 W (fun w0:set => w0 :/\: A <> Empty) w HwWF). }
        claim HwAsubEmpty: w :/\: A c= Empty.
        { let t. assume Ht: t :e w :/\: A.
          prove t :e Empty.
          claim Htpair: t :e w /\ t :e A.
          { exact (binintersectE w A t Ht). }
          claim Htw: t :e w.
          { exact (andEL (t :e w) (t :e A) Htpair). }
          claim HtA: t :e A.
          { exact (andER (t :e w) (t :e A) Htpair). }
          claim HtU0: t :e U0.
          { exact (HwsubU0 t Htw). }
          claim HtNotA: t /:e A.
          { exact (setminusE2 X A t HtU0). }
          apply FalseE.
          exact (HtNotA HtA). }
        claim HwAEmpty: w :/\: A = Empty.
        { exact (Empty_Subq_eq (w :/\: A) HwAsubEmpty). }
        apply FalseE.
        exact (HwAnon HwAEmpty).
      - assume HuU: u :e UFam.
        apply (ReplE_impred A (fun a0:set => sepU a0) u HuU False).
        let a. assume HaA: a :e A.
        assume Hueq: u = sepU a.
        claim HwsubSepU: w c= sepU a.
        { let t. assume Htw: t :e w.
          prove t :e sepU a.
          rewrite <- Hueq.
          exact (Hwsubu t Htw). }
        claim Hsep: (sepU a) :e Tx /\ (sepV a) :e Tx /\ a :e (sepU a) /\ B c= (sepV a) /\ (sepU a) :/\: (sepV a) = Empty.
        { exact (HsepProp a HaA). }
        (** Extract B c= sepV a and (sepU a) :/\: (sepV a) = Empty **)
        claim Hpqrs: (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a)) /\ B c= (sepV a).
        { exact (andEL ((((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a)) /\ B c= (sepV a))
                       ((sepU a) :/\: (sepV a) = Empty)
                       Hsep). }
        claim HdisjU: (sepU a) :/\: (sepV a) = Empty.
        { exact (andER ((((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a)) /\ B c= (sepV a))
                       ((sepU a) :/\: (sepV a) = Empty)
                       Hsep). }
        claim HBsubSepV: B c= sepV a.
        { exact (andER (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a))
                       (B c= (sepV a))
                       Hpqrs). }
        (** show closure(w) subset X\\(sepV a) **)
        claim HsepUinTx: sepU a :e Tx.
        { claim Hpqr: ((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a).
          { exact (andEL (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a))
                         (B c= (sepV a))
                         Hpqrs). }
          claim Hpq: (sepU a) :e Tx /\ (sepV a) :e Tx.
          { exact (andEL ((sepU a) :e Tx /\ (sepV a) :e Tx)
                         (a :e (sepU a))
                         Hpqr). }
          exact (andEL ((sepU a) :e Tx) ((sepV a) :e Tx) Hpq). }
        claim HsepVinTx: sepV a :e Tx.
        { claim Hpqr: ((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a).
          { exact (andEL (((sepU a) :e Tx /\ (sepV a) :e Tx) /\ a :e (sepU a))
                         (B c= (sepV a))
                         Hpqrs). }
          claim Hpq: (sepU a) :e Tx /\ (sepV a) :e Tx.
          { exact (andEL ((sepU a) :e Tx /\ (sepV a) :e Tx)
                         (a :e (sepU a))
                         Hpqr). }
          exact (andER ((sepU a) :e Tx) ((sepV a) :e Tx) Hpq). }
        claim HsepUsubX: sepU a c= X.
        { exact (topology_elem_subset X Tx (sepU a) HTx HsepUinTx). }
        claim HsepVsubX: sepV a c= X.
        { exact (topology_elem_subset X Tx (sepV a) HTx HsepVinTx). }
        claim HsepUsubComp: sepU a c= X :\: (sepV a).
        { let t. assume HtU: t :e sepU a.
          prove t :e X :\: (sepV a).
          claim HtX: t :e X.
          { exact (HsepUsubX t HtU). }
          apply setminusI.
          - exact HtX.
          - assume HtV: t :e sepV a.
            prove False.
            claim HtUV: t :e (sepU a) :/\: (sepV a).
            { exact (binintersectI (sepU a) (sepV a) t HtU HtV). }
            claim HtEmpty: t :e Empty.
            { rewrite <- HdisjU.
              exact HtUV. }
            exact ((EmptyE t) HtEmpty). }
        claim HcompClosed: closed_in X Tx (X :\: (sepV a)).
        { exact (closed_of_open_complement X Tx (sepV a) HTx HsepVinTx). }
        claim HclSepUsub: closure_of X Tx (sepU a) c= X :\: (sepV a).
        { exact (closure_subset_of_closed_superset X Tx (sepU a) (X :\: (sepV a)) HTx HsepUsubComp HcompClosed). }
        claim HclwsubclSepU: closure_of X Tx w c= closure_of X Tx (sepU a).
        { exact (closure_monotone X Tx w (sepU a) HTx HwsubSepU HsepUsubX). }
        claim HbNotSepV: b /:e sepV a.
        { assume HbV: b :e sepV a.
          prove False.
          claim HbclSepU: b :e closure_of X Tx (sepU a).
          { exact (HclwsubclSepU b Hbclw2). }
          claim HbComp: b :e X :\: (sepV a).
          { exact (HclSepUsub b HbclSepU). }
          claim HbNotV: b /:e sepV a.
          { exact (setminusE2 X (sepV a) b HbComp). }
          exact (HbNotV HbV). }
        claim HbSepV: b :e sepV a.
        { exact (HBsubSepV b HbB). }
        exact (HbNotSepV HbSepV).
  }

  witness U.
  witness V.
  apply and5I.
  - exact HUTx.
  - exact HVTx.
  - exact HAsubU.
  - exact HBsubV.
  - exact HUdisjV.
Qed.

(** from §41 Theorem 41.2: closed subspace of a paracompact space is paracompact **)
(** LATEX VERSION: Every closed subspace of a paracompact space is paracompact. **)
Theorem closed_subspace_paracompact : forall X Tx Y:set,
  paracompact_space X Tx ->
  closed_in X Tx Y ->
  paracompact_space Y (subspace_topology X Tx Y).
let X Tx Y.
assume Hpara: paracompact_space X Tx.
assume HYcl: closed_in X Tx Y.
prove paracompact_space Y (subspace_topology X Tx Y).
set Ty := subspace_topology X Tx Y.
prove topology_on Y Ty /\
  forall UY:set, open_cover Y Ty UY ->
    exists VY:set, open_cover Y Ty VY /\ locally_finite_family Y Ty VY /\ refine_of VY UY.
apply andI.
- (** topology on the closed subspace **)
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall U:set, open_cover X Tx U ->
                   exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
                 Hpara). }
  claim HYpkg: Y c= X /\ exists U :e Tx, Y = X :\: U.
  { exact (closed_in_package X Tx Y HYcl). }
  claim HYsub: Y c= X.
  { exact (andEL (Y c= X) (exists U :e Tx, Y = X :\: U) HYpkg). }
  exact (subspace_topology_is_topology X Tx Y HTx HYsub).
- (** every open cover of the subspace has a locally finite open refinement **)
  let UY.
  assume HUY: open_cover Y Ty UY.
  prove exists VY:set, open_cover Y Ty VY /\ locally_finite_family Y Ty VY /\ refine_of VY UY.
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall U:set, open_cover X Tx U ->
                   exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
                 Hpara). }
  claim HYpkg: Y c= X /\ exists U :e Tx, Y = X :\: U.
  { exact (closed_in_package X Tx Y HYcl). }
  claim HYsubX: Y c= X.
  { exact (andEL (Y c= X) (exists U :e Tx, Y = X :\: U) HYpkg). }
  claim HTy: topology_on Y Ty.
  { exact (subspace_topology_is_topology X Tx Y HTx HYsubX). }
  claim HUYop: forall u:set, u :e UY -> u :e Ty.
  { exact (andEL (forall u:set, u :e UY -> u :e Ty) (covers Y UY) HUY). }
  claim HUYcov: covers Y UY.
  { exact (andER (forall u:set, u :e UY -> u :e Ty) (covers Y UY) HUY). }

  (** lift the subspace cover to an open cover of X **)
  set U0 := {V :e Tx | exists u :e UY, u = V :/\: Y}.
  claim HXYopen: X :\: Y :e Tx.
  { claim Hop: open_in X Tx (X :\: Y).
    { exact (open_of_closed_complement X Tx Y HYcl). }
    exact (andER (topology_on X Tx) ((X :\: Y) :e Tx) Hop). }
  set UX := U0 :\/: {X :\: Y}.
  claim HUXopen: forall u:set, u :e UX -> u :e Tx.
  { let u. assume HuUX: u :e UX.
    apply (binunionE U0 {X :\: Y} u HuUX).
    - assume HuU0: u :e U0.
      exact (SepE1 Tx (fun V:set => exists u0 :e UY, u0 = V :/\: Y) u HuU0).
    - assume HuS: u :e {X :\: Y}.
      claim HuEq: u = X :\: Y.
      { exact (SingE (X :\: Y) u HuS). }
      rewrite HuEq.
      exact HXYopen. }
  claim HUXcov: covers X UX.
  { let x. assume HxX: x :e X.
    apply (xm (x :e Y)).
    - assume HxY: x :e Y.
      claim HcovYx: exists u:set, u :e UY /\ x :e u.
      { exact (HUYcov x HxY). }
      apply HcovYx.
      let u. assume Hu: u :e UY /\ x :e u.
      claim HuUY: u :e UY.
      { exact (andEL (u :e UY) (x :e u) Hu). }
      claim Hxu: x :e u.
      { exact (andER (u :e UY) (x :e u) Hu). }
      claim HuTy: u :e Ty.
      { exact (HUYop u HuUY). }
      claim HexV: exists V :e Tx, u = V :/\: Y.
      { exact (subspace_topologyE X Tx Y u HuTy). }
      apply HexV.
      let V. assume HV: V :e Tx /\ u = V :/\: Y.
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (u = V :/\: Y) HV). }
      claim HuEq: u = V :/\: Y.
      { exact (andER (V :e Tx) (u = V :/\: Y) HV). }
      witness V.
      apply andI.
      - claim HVU0: V :e U0.
        { apply (SepI Tx (fun W:set => exists u0 :e UY, u0 = W :/\: Y) V HVTx).
          witness u.
          apply andI.
          - exact HuUY.
          - exact HuEq. }
        exact (binunionI1 U0 {X :\: Y} V HVU0).
      - claim HxVY: x :e V :/\: Y.
        { rewrite <- HuEq.
          exact Hxu. }
        exact (binintersectE1 V Y x HxVY).
    - assume HxNotY: ~(x :e Y).
      witness (X :\: Y).
      apply andI.
      - exact (binunionI2 U0 {X :\: Y} (X :\: Y) (SingI (X :\: Y))).
      - exact (setminusI X Y x HxX HxNotY). }
  claim HUX: open_cover X Tx UX.
  { prove (forall u:set, u :e UX -> u :e Tx) /\ covers X UX.
    apply andI.
    - exact HUXopen.
    - exact HUXcov. }

  (** apply paracompactness in X **)
  claim HparaFor: forall U:set, open_cover X Tx U ->
    exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  { exact (andER (topology_on X Tx)
                 (forall U:set, open_cover X Tx U ->
                   exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U)
                 Hpara). }
  claim HexVX: exists VX:set, open_cover X Tx VX /\ locally_finite_family X Tx VX /\ refine_of VX UX.
  { exact (HparaFor UX HUX). }
  apply HexVX.
  let VX. assume HVX: open_cover X Tx VX /\ locally_finite_family X Tx VX /\ refine_of VX UX.
  claim HVXab: open_cover X Tx VX /\ locally_finite_family X Tx VX.
  { exact (andEL (open_cover X Tx VX /\ locally_finite_family X Tx VX) (refine_of VX UX) HVX). }
  claim HrefVX: refine_of VX UX.
  { exact (andER (open_cover X Tx VX /\ locally_finite_family X Tx VX) (refine_of VX UX) HVX). }
  claim HVXcover: open_cover X Tx VX.
  { exact (andEL (open_cover X Tx VX) (locally_finite_family X Tx VX) HVXab). }
  claim HLFVX: locally_finite_family X Tx VX.
  { exact (andER (open_cover X Tx VX) (locally_finite_family X Tx VX) HVXab). }
  claim HVXop: forall v:set, v :e VX -> v :e Tx.
  { exact (andEL (forall v:set, v :e VX -> v :e Tx) (covers X VX) HVXcover). }
  claim HVXcov: covers X VX.
  { exact (andER (forall v:set, v :e VX -> v :e Tx) (covers X VX) HVXcover). }

  (** restrict the refinement back to Y **)
  set VY := {v :/\: Y | v :e VX, v :/\: Y <> Empty}.

  claim HVYopen: forall w:set, w :e VY -> w :e Ty.
  { let w. assume Hw: w :e VY.
    apply (ReplSepE_impred VX (fun v:set => v :/\: Y <> Empty) (fun v:set => v :/\: Y) w Hw (w :e Ty)).
    let v. assume HvVX: v :e VX.
    assume HvNon: v :/\: Y <> Empty.
    assume HwEq: w = v :/\: Y.
    claim HvTx: v :e Tx.
    { exact (HVXop v HvVX). }
    claim Hsub: v :/\: Y :e Ty.
    { exact (subspace_topologyI X Tx Y v HvTx). }
    rewrite HwEq.
    exact Hsub. }

  claim HVYcov: covers Y VY.
  { let y. assume HyY: y :e Y.
    claim HyX: y :e X.
    { exact (HYsubX y HyY). }
    claim Hexv: exists v:set, v :e VX /\ y :e v.
    { exact (HVXcov y HyX). }
    apply Hexv.
    let v. assume Hv: v :e VX /\ y :e v.
    claim HvVX: v :e VX.
    { exact (andEL (v :e VX) (y :e v) Hv). }
    claim Hyv: y :e v.
    { exact (andER (v :e VX) (y :e v) Hv). }
    set w := v :/\: Y.
    witness w.
    apply andI.
    - exact (ReplSepI VX (fun t:set => t :/\: Y <> Empty) (fun t:set => t :/\: Y) v HvVX
                (elem_implies_nonempty (v :/\: Y) y (binintersectI v Y y Hyv HyY))).
    - exact (binintersectI v Y y Hyv HyY). }

  claim HVY: open_cover Y Ty VY.
  { prove (forall w:set, w :e VY -> w :e Ty) /\ covers Y VY.
    apply andI.
    - exact HVYopen.
    - exact HVYcov. }

  claim HrefVY: refine_of VY UY.
  { let w. assume Hw: w :e VY.
    apply (ReplSepE_impred VX (fun v:set => v :/\: Y <> Empty) (fun v:set => v :/\: Y) w Hw
              (exists u:set, u :e UY /\ w c= u)).
    let v. assume HvVX: v :e VX.
    assume HvNon: v :/\: Y <> Empty.
    assume HwEq: w = v :/\: Y.
    claim Hexu: exists u:set, u :e UX /\ v c= u.
    { exact (HrefVX v HvVX). }
    apply Hexu.
    let u. assume Hu: u :e UX /\ v c= u.
    claim HuUX: u :e UX.
    { exact (andEL (u :e UX) (v c= u) Hu). }
    claim HvSubu: v c= u.
    { exact (andER (u :e UX) (v c= u) Hu). }
    apply (binunionE U0 {X :\: Y} u HuUX).
    - assume HuU0: u :e U0.
      claim Hexu0: exists u0 :e UY, u0 = u :/\: Y.
      { exact (SepE2 Tx (fun V0:set => exists u0 :e UY, u0 = V0 :/\: Y) u HuU0). }
      apply Hexu0.
      let u0. assume Hu0: u0 :e UY /\ u0 = u :/\: Y.
      claim Hu0UY: u0 :e UY.
      { exact (andEL (u0 :e UY) (u0 = u :/\: Y) Hu0). }
      claim Hu0Eq: u0 = u :/\: Y.
      { exact (andER (u0 :e UY) (u0 = u :/\: Y) Hu0). }
      witness u0.
      apply andI.
      - exact Hu0UY.
      - let z. assume Hz: z :e w.
        prove z :e u0.
        claim HzvY: z :e v :/\: Y.
        { rewrite <- HwEq.
          exact Hz. }
        claim Hzv: z :e v.
        { exact (binintersectE1 v Y z HzvY). }
        claim HzY: z :e Y.
        { exact (binintersectE2 v Y z HzvY). }
        claim Hzu: z :e u.
        { exact (HvSubu z Hzv). }
        claim HzuY: z :e u :/\: Y.
        { exact (binintersectI u Y z Hzu HzY). }
        rewrite Hu0Eq.
        exact HzuY.
    - assume HuComp: u :e {X :\: Y}.
      (** impossible since w is nonempty but u is disjoint from Y **)
      claim HuEq: u = X :\: Y.
      { exact (SingE (X :\: Y) u HuComp). }
      apply FalseE.
      claim HwNon: w <> Empty.
      { rewrite HwEq.
        exact HvNon. }
      claim Hzex: exists z:set, z :e w.
      { exact (nonempty_has_element w HwNon). }
      apply Hzex.
      let z. assume Hz: z :e w.
      claim HzvY: z :e v :/\: Y.
      { rewrite <- HwEq.
        exact Hz. }
      claim Hzv: z :e v.
      { exact (binintersectE1 v Y z HzvY). }
      claim HzY: z :e Y.
      { exact (binintersectE2 v Y z HzvY). }
      claim Hzu: z :e u.
      { exact (HvSubu z Hzv). }
      claim HzuXY: z :e X :\: Y.
      { rewrite <- HuEq.
        exact Hzu. }
      claim HzNotY: z /:e Y.
      { exact (setminusE2 X Y z HzuXY). }
      exact (HzNotY HzY). }

  (** local finiteness survives restriction to a subspace **)
  claim HLFVY: locally_finite_family Y Ty VY.
  { prove topology_on Y Ty /\
      forall y:set, y :e Y ->
        exists N:set, N :e Ty /\ y :e N /\
          exists S:set, finite S /\ S c= VY /\
            forall A:set, A :e VY -> A :/\: N <> Empty -> A :e S.
    apply andI.
    - exact HTy.
    - let y. assume HyY: y :e Y.
      claim HyX: y :e X.
      { exact (HYsubX y HyY). }
      claim HLFpkg: forall x:set, x :e X ->
        exists N:set, N :e Tx /\ x :e N /\
          exists S:set, finite S /\ S c= VX /\
            forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
      { exact (andER (topology_on X Tx)
                     (forall x:set, x :e X ->
                       exists N:set, N :e Tx /\ x :e N /\
                         exists S:set, finite S /\ S c= VX /\
                           forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S)
                     HLFVX). }
      claim HexN: exists N:set, N :e Tx /\ y :e N /\
        exists S:set, finite S /\ S c= VX /\
          forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
      { exact (HLFpkg y HyX). }
      apply HexN.
      let N. assume HN: N :e Tx /\ y :e N /\
        exists S:set, finite S /\ S c= VX /\
          forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
      claim HexS: exists S:set, finite S /\ S c= VX /\ forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
      { exact (andER (N :e Tx /\ y :e N)
                     (exists S:set, finite S /\ S c= VX /\ forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S)
                     HN). }
      claim HNy: N :e Tx /\ y :e N.
      { exact (andEL (N :e Tx /\ y :e N)
                     (exists S:set, finite S /\ S c= VX /\ forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S)
                     HN). }
      claim HNTx: N :e Tx.
      { exact (andEL (N :e Tx) (y :e N) HNy). }
      claim HyN: y :e N.
      { exact (andER (N :e Tx) (y :e N) HNy). }
      set NY := N :/\: Y.
      claim HNYTy: NY :e Ty.
      { exact (subspace_topologyI X Tx Y N HNTx). }
      claim HyNY: y :e NY.
      { exact (binintersectI N Y y HyN HyY). }
      witness NY.
      apply andI.
      - prove NY :e Ty /\ y :e NY.
        apply andI.
        * exact HNYTy.
        * exact HyNY.
      - apply HexS.
        let S. assume HS: finite S /\ S c= VX /\ forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
          claim HS1: finite S /\ S c= VX.
          { exact (andEL (finite S /\ S c= VX)
                         (forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S)
                         HS). }
          claim HSprop: forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S.
          { exact (andER (finite S /\ S c= VX)
                         (forall A:set, A :e VX -> A :/\: N <> Empty -> A :e S)
                         HS). }
          claim HSfin: finite S.
          { exact (andEL (finite S) (S c= VX) HS1). }
          claim HSsubVX: S c= VX.
          { exact (andER (finite S) (S c= VX) HS1). }
          set SY := {v :/\: Y | v :e S, v :/\: Y <> Empty}.
          witness SY.
          apply andI.
          { apply andI.
            { (** SY finite **)
            claim HSimgfin: finite {t :/\: Y | t :e S}.
            { exact (Repl_finite (fun t:set => t :/\: Y) S HSfin). }
            claim HSYsub: SY c= {t :/\: Y | t :e S}.
            { let w. assume HwSY: w :e SY.
              apply (ReplSepE_impred S (fun t:set => t :/\: Y <> Empty) (fun t:set => t :/\: Y) w HwSY (w :e {t :/\: Y | t :e S})).
              let t. assume HtS: t :e S.
              assume HtNon: t :/\: Y <> Empty.
              assume HwEq: w = t :/\: Y.
              rewrite HwEq.
              exact (ReplI S (fun t0:set => t0 :/\: Y) t HtS). }
            exact (Subq_finite {t :/\: Y | t :e S} HSimgfin SY HSYsub). }
            { (** SY subset of VY **)
            let w. assume HwSY: w :e SY.
            apply (ReplSepE_impred S (fun t:set => t :/\: Y <> Empty) (fun t:set => t :/\: Y) w HwSY (w :e VY)).
            let t. assume HtS: t :e S.
            assume HtNon: t :/\: Y <> Empty.
            assume HwEq: w = t :/\: Y.
            claim HtVX: t :e VX.
            { exact (HSsubVX t HtS). }
            rewrite HwEq.
            exact (ReplSepI VX (fun v0:set => v0 :/\: Y <> Empty) (fun v0:set => v0 :/\: Y) t HtVX HtNon). } }
          { (** key property **)
            let A. assume HA: A :e VY.
            assume HAnN: A :/\: NY <> Empty.
            apply (ReplSepE_impred VX (fun v0:set => v0 :/\: Y <> Empty) (fun v0:set => v0 :/\: Y) A HA (A :e SY)).
            let v0. assume Hv0VX: v0 :e VX.
            assume Hv0Non: v0 :/\: Y <> Empty.
            assume HAeq: A = v0 :/\: Y.
            claim Hexz: exists z:set, z :e A :/\: NY.
            { exact (nonempty_has_element (A :/\: NY) HAnN). }
            apply Hexz.
            let z. assume Hz: z :e A :/\: NY.
            claim HzA: z :e A.
            { exact (binintersectE1 A NY z Hz). }
            claim HzNY: z :e NY.
            { exact (binintersectE2 A NY z Hz). }
            claim Hzv0Y: z :e v0 :/\: Y.
            { rewrite <- HAeq.
              exact HzA. }
            claim Hzv0: z :e v0.
            { exact (binintersectE1 v0 Y z Hzv0Y). }
            claim HzN: z :e N.
            { exact (binintersectE1 N Y z HzNY). }
            claim Hzv0N: z :e v0 :/\: N.
            { exact (binintersectI v0 N z Hzv0 HzN). }
            claim Hv0N: v0 :/\: N <> Empty.
            { exact (elem_implies_nonempty (v0 :/\: N) z Hzv0N). }
            claim Hv0S: v0 :e S.
            { exact (HSprop v0 Hv0VX Hv0N). }
            rewrite HAeq.
            exact (ReplSepI S (fun t1:set => t1 :/\: Y <> Empty) (fun t1:set => t1 :/\: Y) v0 Hv0S Hv0Non). } }

  witness VY.
  prove (open_cover Y Ty VY /\ locally_finite_family Y Ty VY) /\ refine_of VY UY.
  apply andI.
  - apply andI.
    + exact HVY.
    + exact HLFVY.
  - exact HrefVY.
Qed.

(** from §41 Lemma 41.3 (Michael): countably locally finite refinements and locally finite refinements **)
(** LATEX VERSION: In a regular space, the following are equivalent: open cover has (1) open countably locally finite refinement, (2) locally finite refinement, (3) locally finite closed refinement, (4) locally finite open refinement. **)
Definition sigma_locally_finite_family : set -> set -> set -> prop := fun X Tx F =>
  topology_on X Tx /\
  exists Fams:set,
    countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall G:set, G :e Fams -> locally_finite_family X Tx G) /\
    F = Union Fams.

(** helper: singleton family is locally finite **)
Theorem locally_finite_family_singleton : forall X Tx A:set,
  topology_on X Tx ->
  locally_finite_family X Tx {A}.
let X Tx A.
assume HTx: topology_on X Tx.
prove locally_finite_family X Tx {A}.
prove topology_on X Tx /\
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists S:set, finite S /\ S c= {A} /\
        forall B:set, B :e {A} -> B :/\: N <> Empty -> B :e S.
apply andI.
- exact HTx.
- let x. assume HxX: x :e X.
  witness X.
  prove X :e Tx /\ x :e X /\
    exists S:set, finite S /\ S c= {A} /\
      forall B:set, B :e {A} -> B :/\: X <> Empty -> B :e S.
  apply andI.
  - apply andI.
    + exact (topology_has_X X Tx HTx).
    + exact HxX.
  - witness {A}.
    apply andI.
    + apply andI.
      * exact (Sing_finite A).
      * exact (Subq_ref {A}).
    + let B. assume HB: B :e {A}.
      assume _ : B :/\: X <> Empty.
      prove B :e {A}.
      exact HB.
Qed.

(** helper: locally finite family is sigma-locally-finite (singleton decomposition) **)
Theorem locally_finite_family_imp_sigma_locally_finite_family : forall X Tx F:set,
  topology_on X Tx ->
  F c= Power X ->
  locally_finite_family X Tx F ->
  sigma_locally_finite_family X Tx F.
let X Tx F.
assume HTx: topology_on X Tx.
assume HFsub: F c= Power X.
assume Hlf: locally_finite_family X Tx F.
prove sigma_locally_finite_family X Tx F.
prove topology_on X Tx /\
  exists Fams:set,
    countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall G:set, G :e Fams -> locally_finite_family X Tx G) /\
    F = Union Fams.
apply andI.
- exact HTx.
- set Fams := Sing F.
  witness Fams.
  apply and4I.
  - (** countable_set Fams **)
    prove countable_set Fams.
    prove countable Fams.
    exact (finite_countable Fams (Sing_finite F)).
  - (** Fams c= Power (Power X) **)
    prove Fams c= Power (Power X).
    let G. assume HG: G :e Fams.
    prove G :e Power (Power X).
    claim HeqG: G = F.
    { exact (SingE F G HG). }
    rewrite HeqG.
    exact (PowerI (Power X) F HFsub).
  - (** each G in Fams is locally_finite_family **)
    let G. assume HG: G :e Fams.
    prove locally_finite_family X Tx G.
    claim HeqG: G = F.
    { exact (SingE F G HG). }
    rewrite HeqG.
    exact Hlf.
  - (** F = Union Fams **)
    prove F = Union Fams.
    apply set_ext.
    { let f. assume Hf: f :e F.
      prove f :e Union Fams.
      exact (UnionI Fams f F Hf (SingI F)). }
    { let f. assume Hf: f :e Union Fams.
      prove f :e F.
      apply (UnionE_impred Fams f Hf (f :e F)).
      let G. assume HfG: f :e G. assume HGF: G :e Fams.
      claim HeqG: G = F.
      { exact (SingE F G HGF). }
      rewrite <- HeqG.
      exact HfG. }
Qed.

(** helper: countable open cover is sigma-locally-finite **)
Theorem countable_open_cover_sigma_locally_finite_family : forall X Tx U:set,
  topology_on X Tx ->
  open_cover X Tx U ->
  countable_set U ->
  sigma_locally_finite_family X Tx U.
let X Tx U.
assume HTx: topology_on X Tx.
assume Hcover: open_cover X Tx U.
assume HUcount: countable_set U.
prove sigma_locally_finite_family X Tx U.
prove topology_on X Tx /\
  exists Fams:set,
    countable_set Fams /\
    Fams c= Power (Power X) /\
    (forall G:set, G :e Fams -> locally_finite_family X Tx G) /\
    U = Union Fams.
apply andI.
- exact HTx.
- set Fams := {{u}|u :e U}.
  witness Fams.
  apply and4I.
  - (** countable_set Fams **)
    exact (countable_image U HUcount (fun u:set => {u})).
  - (** Fams c= Power (Power X) **)
    prove Fams c= Power (Power X).
    let G. assume HG: G :e Fams.
    prove G :e Power (Power X).
    apply (ReplE_impred U (fun u:set => {u}) G HG).
    let u. assume HuU: u :e U.
    assume HeqG: G = {u}.
    rewrite HeqG.
    claim HsubPow: {u} c= Power X.
    { let z. assume Hz: z :e {u}.
      prove z :e Power X.
      claim Hzu: z = u.
      { exact (SingE u z Hz). }
      rewrite Hzu.
      claim HuTx: u :e Tx.
      { exact (andEL (forall u0:set, u0 :e U -> u0 :e Tx) (covers X U) Hcover u HuU). }
      exact (topology_subset_axiom X Tx HTx u HuTx). }
    exact (PowerI (Power X) {u} HsubPow).
  - (** each G in Fams is locally_finite_family **)
    let G. assume HG: G :e Fams.
    prove locally_finite_family X Tx G.
    apply (ReplE_impred U (fun u:set => {u}) G HG).
    let u. assume HuU: u :e U.
    assume HeqG: G = {u}.
    rewrite HeqG.
    exact (locally_finite_family_singleton X Tx u HTx).
  - (** U = Union Fams **)
    prove U = Union Fams.
    apply set_ext.
    { let u. assume HuU: u :e U.
      prove u :e Union Fams.
      claim HsingFam: {u} :e Fams.
      { exact (ReplI U (fun u0:set => {u0}) u HuU). }
      exact (UnionI Fams u {u} (SingI u) HsingFam). }
    { let u. assume Hu: u :e Union Fams.
      prove u :e U.
      apply (UnionE_impred Fams u Hu (u :e U)).
      let G. assume HuG: u :e G. assume HGF: G :e Fams.
      apply (ReplE_impred U (fun u0:set => {u0}) G HGF).
      let u0. assume Hu0U: u0 :e U.
      assume HeqG: G = {u0}.
      claim HuEq: u = u0.
      { claim HuG0: u :e {u0}.
        { rewrite <- HeqG.
          exact HuG. }
        exact (SingE u0 u HuG0). }
      rewrite HuEq.
      exact Hu0U. }
Qed.

(** helper: closed cover (collection of closed subsets covering X) **)
Definition closed_cover : set -> set -> set -> prop := fun X Tx C =>
  (forall c:set, c :e C -> closed_in X Tx c) /\ covers X C.

Definition Michael_cond41_3_1 : set -> set -> prop := fun X Tx =>
  forall U:set, open_cover X Tx U ->
    exists V:set, open_cover X Tx V /\ sigma_locally_finite_family X Tx V /\ refine_of V U.

Definition Michael_cond41_3_2 : set -> set -> prop := fun X Tx =>
  forall U:set, open_cover X Tx U ->
    exists V:set, covers X V /\ locally_finite_family X Tx V /\ refine_of V U.

Definition Michael_cond41_3_3 : set -> set -> prop := fun X Tx =>
  forall U:set, open_cover X Tx U ->
    exists V:set, closed_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.

Definition Michael_cond41_3_4 : set -> set -> prop := fun X Tx =>
  forall U:set, open_cover X Tx U ->
    exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.

Theorem Michael_lemma_41_3 : forall X Tx:set,
  regular_space X Tx ->
  (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
  (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx) /\
  (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx) /\
  (Michael_cond41_3_4 X Tx -> Michael_cond41_3_1 X Tx).
let X Tx.
assume Hreg: regular_space X Tx.
prove (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
  (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx) /\
  (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx) /\
  (Michael_cond41_3_4 X Tx -> Michael_cond41_3_1 X Tx).
apply and4I.
- assume H1: Michael_cond41_3_1 X Tx.
  prove Michael_cond41_3_2 X Tx.
  let U. assume HU: open_cover X Tx U.
  prove exists V:set, covers X V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim HexV: exists V:set, open_cover X Tx V /\ sigma_locally_finite_family X Tx V /\ refine_of V U.
  { exact (H1 U HU). }
  apply HexV.
  let V. assume HV: open_cover X Tx V /\ sigma_locally_finite_family X Tx V /\ refine_of V U.
  claim Hcovsigma: open_cover X Tx V /\ sigma_locally_finite_family X Tx V.
  { exact (andEL
      (open_cover X Tx V /\ sigma_locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  claim Hcov: open_cover X Tx V.
  { exact (andEL
      (open_cover X Tx V)
      (sigma_locally_finite_family X Tx V)
      Hcovsigma). }
  claim Hsigma: sigma_locally_finite_family X Tx V.
  { exact (andER
      (open_cover X Tx V)
      (sigma_locally_finite_family X Tx V)
      Hcovsigma). }
  claim Href: refine_of V U.
  { exact (andER
      (open_cover X Tx V /\ sigma_locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  witness V.
  apply andI.
  - apply andI.
    + exact (andER (forall u:set, u :e V -> u :e Tx) (covers X V) Hcov).
    + (** pending: upgrade sigma-locally-finite open refinement to a locally finite refinement **)
      admit. (** FAIL **)
  - exact Href.
- assume H2: Michael_cond41_3_2 X Tx.
  prove Michael_cond41_3_3 X Tx.
  let U. assume HU: open_cover X Tx U.
  prove exists V:set, closed_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim HexV: exists V:set, covers X V /\ locally_finite_family X Tx V /\ refine_of V U.
  { exact (H2 U HU). }
  apply HexV.
  let V. assume HV: covers X V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim Hcovlf: covers X V /\ locally_finite_family X Tx V.
  { exact (andEL
      (covers X V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  claim Hcov: covers X V.
  { exact (andEL (covers X V) (locally_finite_family X Tx V) Hcovlf). }
  claim Hlf: locally_finite_family X Tx V.
  { exact (andER (covers X V) (locally_finite_family X Tx V) Hcovlf). }
  claim Href: refine_of V U.
  { exact (andER
      (covers X V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  witness V.
  apply andI.
  - apply andI.
    + (** pending: build a closed cover refining U from a locally finite cover refining U **)
      admit. (** FAIL **)
    + exact Hlf.
  - exact Href.
- assume H3: Michael_cond41_3_3 X Tx.
  prove Michael_cond41_3_4 X Tx.
  let U. assume HU: open_cover X Tx U.
  prove exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim HexV: exists V:set, closed_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  { exact (H3 U HU). }
  apply HexV.
  let V. assume HV: closed_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim Hcllf: closed_cover X Tx V /\ locally_finite_family X Tx V.
  { exact (andEL
      (closed_cover X Tx V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  claim Hclcov: closed_cover X Tx V.
  { exact (andEL (closed_cover X Tx V) (locally_finite_family X Tx V) Hcllf). }
  claim Hlf: locally_finite_family X Tx V.
  { exact (andER (closed_cover X Tx V) (locally_finite_family X Tx V) Hcllf). }
  claim Href: refine_of V U.
  { exact (andER
      (closed_cover X Tx V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HV). }
  (** pending: expand a locally finite closed refinement to a locally finite open refinement **)
  admit. (** FAIL **)
- assume H4: Michael_cond41_3_4 X Tx.
  prove Michael_cond41_3_1 X Tx.
  let U. assume HU: open_cover X Tx U.
  prove exists V:set, open_cover X Tx V /\ sigma_locally_finite_family X Tx V /\ refine_of V U.
  claim HTx: topology_on X Tx.
  { exact (regular_space_topology_on X Tx Hreg). }
  claim HexV: exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  { exact (H4 U HU). }
  apply HexV.
  let V. assume HV: open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
  claim Hcovlf: open_cover X Tx V /\ locally_finite_family X Tx V.
  { exact (andEL (open_cover X Tx V /\ locally_finite_family X Tx V)
                 (refine_of V U)
                 HV). }
  claim Hcov: open_cover X Tx V.
  { exact (andEL (open_cover X Tx V)
                 (locally_finite_family X Tx V)
                 Hcovlf). }
  claim Hlf: locally_finite_family X Tx V.
  { exact (andER (open_cover X Tx V)
                 (locally_finite_family X Tx V)
                 Hcovlf). }
  claim Href: refine_of V U.
  { exact (andER (open_cover X Tx V /\ locally_finite_family X Tx V)
                 (refine_of V U)
                 HV). }
  claim HVsubPow: V c= Power X.
  { exact (open_cover_family_sub X Tx V HTx Hcov). }
  claim Hsigma: sigma_locally_finite_family X Tx V.
  { exact (locally_finite_family_imp_sigma_locally_finite_family X Tx V HTx HVsubPow Hlf). }
  witness V.
  apply andI.
  - (** open_cover X Tx V /\ sigma_locally_finite_family X Tx V **)
    apply andI.
    + exact Hcov.
    + (** sigma_locally_finite_family X Tx V **)
      exact Hsigma.
  - (** refine_of V U **)
    exact Href.
Qed.

(** from §41 Theorem 41.4: metrizable implies paracompact **)
(** LATEX VERSION: Every metrizable space is paracompact. **)
(** helper: metric spaces are paracompact (used to discharge the metrizable case) **)
(** LATEX VERSION: Every metric space is paracompact. **)
Theorem metric_paracompact : forall X d:set,
  metric_on X d ->
  paracompact_space X (metric_topology X d).
let X d.
assume Hm: metric_on X d.
prove paracompact_space X (metric_topology X d).
prove topology_on X (metric_topology X d) /\
  forall U:set, open_cover X (metric_topology X d) U ->
    exists V:set, open_cover X (metric_topology X d) V /\ locally_finite_family X (metric_topology X d) V /\ refine_of V U.
apply andI.
- exact (metric_topology_is_topology X d Hm).
- (** Standard theorem: metric spaces admit locally finite refinements of open covers. **)
  let U. assume Hcov: open_cover X (metric_topology X d) U.
  admit. (** FAIL **)
Qed.

Theorem metrizable_paracompact : forall X Tx:set,
  metrizable X Tx -> paracompact_space X Tx.
let X Tx.
assume Hmet: metrizable X Tx.
prove paracompact_space X Tx.
(** use the witnessing metric and reduce to the metric case **)
apply Hmet.
let d.
assume Hdpair: metric_on X d /\ metric_topology X d = Tx.
claim Hm: metric_on X d.
{ exact (andEL (metric_on X d) (metric_topology X d = Tx) Hdpair). }
claim Heq: metric_topology X d = Tx.
{ exact (andER (metric_on X d) (metric_topology X d = Tx) Hdpair). }
rewrite <- Heq.
exact (metric_paracompact X d Hm).
Qed.

(** from §41 Theorem 41.5: regular Lindelof implies paracompact **)
(** LATEX VERSION: Every regular Lindelof space is paracompact. **)
Theorem regular_Lindelof_paracompact : forall X Tx:set,
  regular_space X Tx -> Lindelof_space X Tx -> paracompact_space X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume HL: Lindelof_space X Tx.
prove paracompact_space X Tx.
prove topology_on X Tx /\
  forall U:set, open_cover X Tx U ->
    exists V:set, open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V U.
apply andI.
- exact (regular_space_topology_on X Tx Hreg).
- (** Use Lindelof to get countable subcover and Michael lemma to upgrade to locally finite refinement. **)
  claim HTx: topology_on X Tx.
  { exact (regular_space_topology_on X Tx Hreg). }
  claim Hmichael:
    (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
    (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx) /\
    (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx) /\
    (Michael_cond41_3_4 X Tx -> Michael_cond41_3_1 X Tx).
  { exact (Michael_lemma_41_3 X Tx Hreg). }
  claim H123:
    (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
    (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx) /\
    (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx).
  { exact (andEL
      ((Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
       (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx) /\
       (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx))
      (Michael_cond41_3_4 X Tx -> Michael_cond41_3_1 X Tx)
      Hmichael). }
  claim H12and23:
    (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
    (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx).
  { exact (andEL
      ((Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
       (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx))
      (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx)
      H123). }
  claim H34: Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx.
  { exact (andER
      ((Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx) /\
       (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx))
      (Michael_cond41_3_3 X Tx -> Michael_cond41_3_4 X Tx)
      H123). }
  claim H12: Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx.
  { exact (andEL
      (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx)
      (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx)
      H12and23). }
  claim H23: Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx.
  { exact (andER
      (Michael_cond41_3_1 X Tx -> Michael_cond41_3_2 X Tx)
      (Michael_cond41_3_2 X Tx -> Michael_cond41_3_3 X Tx)
      H12and23). }
  claim Hcond1: Michael_cond41_3_1 X Tx.
  { let U0. assume HU0: open_cover X Tx U0.
    prove exists V:set, open_cover X Tx V /\ sigma_locally_finite_family X Tx V /\ refine_of V U0.
    claim HLprop:
      forall U1:set, open_cover X Tx U1 ->
        exists V:set, countable_subcollection V U1 /\ covers X V.
    { exact (andER
        (topology_on X Tx)
        (forall U1:set, open_cover X Tx U1 ->
          exists V:set, countable_subcollection V U1 /\ covers X V)
        HL). }
    apply (HLprop U0 HU0).
    let V0. assume HV0: countable_subcollection V0 U0 /\ covers X V0.
    claim HV0subc: countable_subcollection V0 U0.
    { exact (andEL
        (countable_subcollection V0 U0)
        (covers X V0)
        HV0). }
    claim HV0cov: covers X V0.
    { exact (andER
        (countable_subcollection V0 U0)
        (covers X V0)
        HV0). }
    claim HV0sub: V0 c= U0.
    { exact (andEL
        (V0 c= U0)
        (countable_set V0)
        HV0subc). }
    claim HV0count: countable_set V0.
    { exact (andER
        (V0 c= U0)
        (countable_set V0)
        HV0subc). }
    claim HU0Tx: forall u:set, u :e U0 -> u :e Tx.
    { exact (andEL
        (forall u:set, u :e U0 -> u :e Tx)
        (covers X U0)
        HU0). }
    claim HopenV0: open_cover X Tx V0.
    { prove (forall v:set, v :e V0 -> v :e Tx) /\ covers X V0.
      apply andI.
      - let v. assume Hv: v :e V0.
        prove v :e Tx.
        claim HvU0: v :e U0.
        { exact (HV0sub v Hv). }
        exact (HU0Tx v HvU0).
      - exact HV0cov. }
    claim HsigmaV0: sigma_locally_finite_family X Tx V0.
    { exact (countable_open_cover_sigma_locally_finite_family X Tx V0 HTx HopenV0 HV0count). }
    claim HrefV0: refine_of V0 U0.
    { let v. assume Hv: v :e V0.
      witness v.
      apply andI.
      - exact (HV0sub v Hv).
      - exact (Subq_ref v). }
    witness V0.
    apply andI.
    - apply andI.
      + exact HopenV0.
      + exact HsigmaV0.
    - exact HrefV0. }
  claim Hcond2: Michael_cond41_3_2 X Tx.
  { exact (H12 Hcond1). }
  claim Hcond3: Michael_cond41_3_3 X Tx.
  { exact (H23 Hcond2). }
  claim Hcond4: Michael_cond41_3_4 X Tx.
  { exact (H34 Hcond3). }
  let U. assume HU: open_cover X Tx U.
  exact (Hcond4 U HU).
Qed.

(** from §41 Example 4: product of two paracompact spaces need not be paracompact **)
(** LATEX VERSION: R_lower_limit is paracompact, but R_lower_limit x R_lower_limit is not paracompact since it is Hausdorff but not normal. **)
Theorem Sorgenfrey_plane_not_paracompact :
  ~ paracompact_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove ~ paracompact_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
assume Hpara: paracompact_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
prove False.
claim HHline: Hausdorff_space Sorgenfrey_line Sorgenfrey_topology.
{ exact Sorgenfrey_line_Hausdorff. }
claim HHplane: Hausdorff_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
{ exact (ex17_11_product_Hausdorff Sorgenfrey_line Sorgenfrey_topology Sorgenfrey_line Sorgenfrey_topology HHline HHline). }
claim Hnorm: normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
{ exact (paracompact_Hausdorff_normal (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology Hpara HHplane). }
claim Hnotnorm: ~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology.
{ exact (andER (regular_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology)
               (~ normal_space (setprod Sorgenfrey_line Sorgenfrey_line) Sorgenfrey_plane_topology)
               Sorgenfrey_plane_not_normal). }
exact (Hnotnorm Hnorm).
Qed.

(** from §41 Example 5: R^omega is paracompact in product and uniform topologies **)
(** LATEX VERSION: R^omega is paracompact in the product and uniform topologies since it is metrizable; box topology case is unknown. **)
Theorem Romega_paracompact_product_topology :
  paracompact_space (product_space omega (const_space_family omega R R_standard_topology))
                    (product_topology_full omega (const_space_family omega R R_standard_topology)).
prove paracompact_space (product_space omega (const_space_family omega R R_standard_topology))
                        (product_topology_full omega (const_space_family omega R R_standard_topology)).
claim Hmetr: metrizable (product_space omega (const_space_family omega R R_standard_topology))
                        (product_topology_full omega (const_space_family omega R R_standard_topology)).
{ prove exists d:set,
    metric_on (product_space omega (const_space_family omega R R_standard_topology)) d /\
    metric_topology (product_space omega (const_space_family omega R R_standard_topology)) d =
      product_topology_full omega (const_space_family omega R R_standard_topology).
  witness Romega_D_metric.
  claim Hpair: metric_on R_omega_space Romega_D_metric /\ Romega_D_metric_topology = R_omega_product_topology.
  { exact Romega_D_metric_induces_product_topology. }
  claim Hm: metric_on R_omega_space Romega_D_metric.
  { exact (andEL (metric_on R_omega_space Romega_D_metric)
                 (Romega_D_metric_topology = R_omega_product_topology)
                 Hpair). }
  claim Heq: Romega_D_metric_topology = R_omega_product_topology.
  { exact (andER (metric_on R_omega_space Romega_D_metric)
                 (Romega_D_metric_topology = R_omega_product_topology)
                 Hpair). }
  apply andI.
  - exact Hm.
  - (** rewrite metric_topology via definition of Romega_D_metric_topology, then use the induced-topology equality **)
    claim Hdef: metric_topology R_omega_space Romega_D_metric = Romega_D_metric_topology.
    { reflexivity. }
    rewrite Hdef.
    rewrite Heq.
    reflexivity. }
exact (metrizable_paracompact (product_space omega (const_space_family omega R R_standard_topology))
                              (product_topology_full omega (const_space_family omega R R_standard_topology))
                              Hmetr).
Qed.

(** from §41 Example 5 (uniform topology): R^omega is paracompact in the uniform topology **)
(** LATEX VERSION: R^omega is paracompact in the uniform topology since it is metrizable. **)
Theorem Romega_paracompact_uniform_topology :
  paracompact_space real_sequences uniform_topology.
prove paracompact_space real_sequences uniform_topology.
claim Hmetr: metrizable real_sequences uniform_topology.
{ prove exists d:set, metric_on real_sequences d /\ metric_topology real_sequences d = uniform_topology.
  witness uniform_metric_Romega.
  apply andI.
  - (** metric_on part **)
    exact uniform_metric_Romega_is_metric.
  - (** topology equality is definitional **)
    claim Hdef: uniform_topology = metric_topology real_sequences uniform_metric_Romega.
    { reflexivity. }
    rewrite Hdef.
    reflexivity. }
exact (metrizable_paracompact real_sequences uniform_topology Hmetr).
Qed.

(** from §41 Example 6: uncountable product of R is not paracompact **)
(** LATEX VERSION: If J is uncountable then R^J is not paracompact since it is Hausdorff but not normal. **)
Theorem uncountable_product_R_not_paracompact : forall J:set,
  uncountable_set J ->
  ~ paracompact_space (product_space J (const_space_family J R R_standard_topology))
                      (product_topology_full J (const_space_family J R R_standard_topology)).
let J.
assume HJ: uncountable_set J.
prove ~ paracompact_space (product_space J (const_space_family J R R_standard_topology))
                          (product_topology_full J (const_space_family J R R_standard_topology)).
assume Hpara: paracompact_space (product_space J (const_space_family J R R_standard_topology))
                                (product_topology_full J (const_space_family J R R_standard_topology)).
prove False.
claim HHfam: Hausdorff_spaces_family J (const_space_family J R R_standard_topology).
{ let i. assume Hi: i :e J.
  prove Hausdorff_space (product_component (const_space_family J R R_standard_topology) i)
                       (product_component_topology (const_space_family J R R_standard_topology) i).
  rewrite (product_component_def (const_space_family J R R_standard_topology) i).
  rewrite (product_component_topology_def (const_space_family J R R_standard_topology) i).
  rewrite (const_space_family_apply J R R_standard_topology i Hi).
  rewrite (tuple_2_0_eq R R_standard_topology).
  rewrite (tuple_2_1_eq R R_standard_topology).
  exact R_standard_topology_Hausdorff. }
claim HHprod: Hausdorff_space (product_space J (const_space_family J R R_standard_topology))
                             (product_topology_full J (const_space_family J R R_standard_topology)).
{ exact (product_topology_full_Hausdorff_axiom J (const_space_family J R R_standard_topology) HHfam). }
claim Hnorm: normal_space (product_space J (const_space_family J R R_standard_topology))
                          (product_topology_full J (const_space_family J R R_standard_topology)).
{ exact (paracompact_Hausdorff_normal (product_space J (const_space_family J R R_standard_topology))
                                     (product_topology_full J (const_space_family J R R_standard_topology))
                                     Hpara HHprod). }
claim Hnotnorm:
  ~ normal_space (product_space J (const_space_family J R R_standard_topology))
                 (product_topology_full J (const_space_family J R R_standard_topology)).
{ exact (uncountable_product_R_not_normal J HJ). }
exact (Hnotnorm Hnorm).
Qed.

(** from §41 Lemma 41.6 (shrinking lemma): locally finite open shrinking of an open cover **)
(** LATEX VERSION: If X is paracompact Hausdorff and U is an indexed open cover, there exists a locally finite open cover V with closure(V) contained in U. **)
Theorem shrinking_lemma_41_6 : forall X Tx U:set,
  paracompact_space X Tx ->
  Hausdorff_space X Tx ->
  open_cover X Tx U ->
  exists V:set,
    open_cover X Tx V /\
    locally_finite_family X Tx V /\
    refine_of V U /\
    forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
let X Tx U.
assume Hpara: paracompact_space X Tx.
assume HH: Hausdorff_space X Tx.
assume Hcover: open_cover X Tx U.
prove exists V:set,
  open_cover X Tx V /\
  locally_finite_family X Tx V /\
  refine_of V U /\
  forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
(** Use regularity to first refine U by a cover with closure contained in U, then apply paracompactness. **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U0:set, open_cover X Tx U0 ->
                 exists V0:set, open_cover X Tx V0 /\ locally_finite_family X Tx V0 /\ refine_of V0 U0)
               Hpara). }
claim Hreg: regular_space X Tx.
{ exact (paracompact_Hausdorff_regular X Tx Hpara HH). }
claim HUTx: forall u:set, u :e U -> u :e Tx.
{ exact (andEL (forall u0:set, u0 :e U -> u0 :e Tx)
               (covers X U)
               Hcover). }
claim HUcov: covers X U.
{ exact (andER (forall u0:set, u0 :e U -> u0 :e Tx)
               (covers X U)
               Hcover). }

(** For each x in X, pick u(x) in U with x in u(x). **)
set pickU := fun x:set => Eps_i (fun u:set => u :e U /\ x :e u).
claim HpickU: forall x:set, x :e X -> pickU x :e U /\ x :e pickU x.
{ let x. assume HxX: x :e X.
  claim Hex: exists u:set, u :e U /\ x :e u.
  { exact (HUcov x HxX). }
  apply Hex.
  let u. assume Hu: u :e U /\ x :e u.
  exact (Eps_i_ax (fun u0:set => u0 :e U /\ x :e u0) u Hu). }
claim HpickUTx: forall x:set, x :e X -> pickU x :e Tx.
{ let x. assume HxX: x :e X.
  exact (HUTx (pickU x)
              (andEL (pickU x :e U) (x :e pickU x) (HpickU x HxX))). }

(** For each x in X, pick an open neighborhood V(x) with closure(V(x)) contained in u(x). **)
set pickV := fun x:set =>
  Eps_i (fun V:set => V :e Tx /\ x :e V /\ closure_of X Tx V c= pickU x).
claim HpickV: forall x:set, x :e X ->
  pickV x :e Tx /\ x :e pickV x /\ closure_of X Tx (pickV x) c= pickU x.
{ let x. assume HxX: x :e X.
  claim Hux: pickU x :e U /\ x :e pickU x.
  { exact (HpickU x HxX). }
  claim HuxTx: pickU x :e Tx.
  { exact (HpickUTx x HxX). }
  claim Hxux: x :e pickU x.
  { exact (andER (pickU x :e U) (x :e pickU x) Hux). }
  claim HexV: exists V:set, V :e Tx /\ x :e V /\ closure_of X Tx V c= pickU x.
  { exact (regular_space_shrink_neighborhood X Tx x (pickU x) Hreg HxX HuxTx Hxux). }
  apply HexV.
  let V. assume HV: V :e Tx /\ x :e V /\ closure_of X Tx V c= pickU x.
  exact (Eps_i_ax (fun V0:set => V0 :e Tx /\ x :e V0 /\ closure_of X Tx V0 c= pickU x) V HV). }

(** Form the induced cover W = {V(x) | x in X}. **)
set W := Repl X (fun x:set => pickV x).
claim HcoverW: open_cover X Tx W.
{ prove (forall w:set, w :e W -> w :e Tx) /\ covers X W.
  apply andI.
  - let w. assume Hw: w :e W.
    claim Hex: exists x:set, x :e X /\ w = pickV x.
    { exact (ReplE X (fun x0:set => pickV x0) w Hw). }
    apply Hex.
    let x. assume Hx: x :e X /\ w = pickV x.
    claim HxX: x :e X.
    { exact (andEL (x :e X) (w = pickV x) Hx). }
    claim Heq: w = pickV x.
    { exact (andER (x :e X) (w = pickV x) Hx). }
    rewrite Heq.
    claim Hpv: pickV x :e Tx /\ x :e pickV x /\ closure_of X Tx (pickV x) c= pickU x.
    { exact (HpickV x HxX). }
    claim Hpvpair: pickV x :e Tx /\ x :e pickV x.
    { exact (andEL (pickV x :e Tx /\ x :e pickV x)
                   (closure_of X Tx (pickV x) c= pickU x)
                   Hpv). }
    exact (andEL (pickV x :e Tx) (x :e pickV x) Hpvpair).
  - let x. assume HxX: x :e X.
    witness (pickV x).
    apply andI.
    + exact (ReplI X (fun x0:set => pickV x0) x HxX).
    + claim Hpv: pickV x :e Tx /\ x :e pickV x /\ closure_of X Tx (pickV x) c= pickU x.
      { exact (HpickV x HxX). }
      claim Hpvpair: pickV x :e Tx /\ x :e pickV x.
      { exact (andEL (pickV x :e Tx /\ x :e pickV x)
                     (closure_of X Tx (pickV x) c= pickU x)
                     Hpv). }
      exact (andER (pickV x :e Tx) (x :e pickV x) Hpvpair). }

(** Apply paracompactness to obtain a locally finite open refinement of W. **)
claim HparaFor: forall U0:set, open_cover X Tx U0 ->
  exists V0:set, open_cover X Tx V0 /\ locally_finite_family X Tx V0 /\ refine_of V0 U0.
{ exact (andER (topology_on X Tx)
               (forall U0:set, open_cover X Tx U0 ->
                 exists V0:set, open_cover X Tx V0 /\ locally_finite_family X Tx V0 /\ refine_of V0 U0)
               Hpara). }
claim HexV: exists V0:set, open_cover X Tx V0 /\ locally_finite_family X Tx V0 /\ refine_of V0 W.
{ exact (HparaFor W HcoverW). }
apply HexV.
let V. assume HV: open_cover X Tx V /\ locally_finite_family X Tx V /\ refine_of V W.
witness V.
claim HVpair: open_cover X Tx V /\ locally_finite_family X Tx V.
{ exact (andEL (open_cover X Tx V /\ locally_finite_family X Tx V)
               (refine_of V W)
               HV). }
claim HVrefW: refine_of V W.
{ exact (andER (open_cover X Tx V /\ locally_finite_family X Tx V)
               (refine_of V W)
               HV). }
claim HVcover: open_cover X Tx V.
{ exact (andEL (open_cover X Tx V) (locally_finite_family X Tx V) HVpair). }
claim HVlf: locally_finite_family X Tx V.
{ exact (andER (open_cover X Tx V) (locally_finite_family X Tx V) HVpair). }
claim HTsub: Tx c= Power X.
{ exact (topology_subset_axiom X Tx HTx). }
claim HVTx: forall v:set, v :e V -> v :e Tx.
{ exact (andEL (forall v0:set, v0 :e V -> v0 :e Tx)
               (covers X V)
               HVcover). }

(** Main closure domination statement for members of V. **)
claim Hcldom: forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
{ let v. assume HvV: v :e V.
  claim Hexw: exists w:set, w :e W /\ v c= w.
  { exact (HVrefW v HvV). }
  apply Hexw.
  let w. assume Hw: w :e W /\ v c= w.
  claim HwW: w :e W.
  { exact (andEL (w :e W) (v c= w) Hw). }
  claim Hvsubw: v c= w.
  { exact (andER (w :e W) (v c= w) Hw). }
  claim Hexx: exists x:set, x :e X /\ w = pickV x.
  { exact (ReplE X (fun x0:set => pickV x0) w HwW). }
  apply Hexx.
  let x. assume Hx: x :e X /\ w = pickV x.
  claim HxX: x :e X.
  { exact (andEL (x :e X) (w = pickV x) Hx). }
  claim Heqw: w = pickV x.
  { exact (andER (x :e X) (w = pickV x) Hx). }
  set u := pickU x.
  witness u.
  apply andI.
  - exact (andEL (u :e U) (x :e u) (HpickU x HxX)).
	  - prove closure_of X Tx v c= u.
	    claim HwTx: w :e Tx.
	    { rewrite Heqw.
	      claim Hpv: pickV x :e Tx /\ x :e pickV x /\ closure_of X Tx (pickV x) c= pickU x.
	      { exact (HpickV x HxX). }
	      claim Hpvpair: pickV x :e Tx /\ x :e pickV x.
	      { exact (andEL (pickV x :e Tx /\ x :e pickV x)
	                     (closure_of X Tx (pickV x) c= pickU x)
	                     Hpv). }
	      exact (andEL (pickV x :e Tx) (x :e pickV x) Hpvpair). }
	    claim HwPow: w :e Power X.
	    { exact (HTsub w HwTx). }
    claim HwsubX: w c= X.
    { exact (PowerE X w HwPow). }
    claim Hclvclw: closure_of X Tx v c= closure_of X Tx w.
    { exact (closure_monotone X Tx v w HTx Hvsubw HwsubX). }
	    claim Hclwsub: closure_of X Tx w c= u.
	    { rewrite Heqw.
	      claim Hpv: pickV x :e Tx /\ x :e pickV x /\ closure_of X Tx (pickV x) c= pickU x.
	      { exact (HpickV x HxX). }
	      exact (andER (pickV x :e Tx /\ x :e pickV x)
	                   (closure_of X Tx (pickV x) c= pickU x)
	                   Hpv). }
	    exact (Subq_tra (closure_of X Tx v) (closure_of X Tx w) u Hclvclw Hclwsub). }

apply and4I.
- exact HVcover.
- exact HVlf.
- (** refine_of V U via closure domination **)
  let v. assume HvV: v :e V.
  prove exists u:set, u :e U /\ v c= u.
  claim Hexu: exists u:set, u :e U /\ closure_of X Tx v c= u.
  { exact (Hcldom v HvV). }
  apply Hexu.
  let u. assume Hu: u :e U /\ closure_of X Tx v c= u.
  witness u.
  apply andI.
  - exact (andEL (u :e U) (closure_of X Tx v c= u) Hu).
  - (** v c= closure(v) c= u **)
    claim HvTx: v :e Tx.
    { exact (HVTx v HvV). }
    claim HvPow: v :e Power X.
    { exact (HTsub v HvTx). }
    claim HvsubX: v c= X.
    { exact (PowerE X v HvPow). }
    claim Hvsubcl: v c= closure_of X Tx v.
    { exact (subset_of_closure X Tx v HTx HvsubX). }
    exact (Subq_tra v (closure_of X Tx v) u Hvsubcl
                   (andER (u :e U) (closure_of X Tx v c= u) Hu)).
- exact Hcldom.
Qed.

(** from §41 Theorem 41.7: partition of unity dominated by an open cover **)
(** LATEX VERSION: For a paracompact Hausdorff space X and an indexed open cover U, there exists a partition of unity on X dominated by U. **)
Theorem paracompact_Hausdorff_partition_of_unity : forall X Tx U:set,
  paracompact_space X Tx ->
  Hausdorff_space X Tx ->
  open_cover X Tx U ->
  partition_of_unity_dominated X Tx U.
let X Tx U.
assume Hpara: paracompact_space X Tx.
assume HH: Hausdorff_space X Tx.
assume Hcover: open_cover X Tx U.
prove partition_of_unity_dominated X Tx U.
claim Hnorm: normal_space X Tx.
{ exact (paracompact_Hausdorff_normal X Tx Hpara HH). }
  claim Hshrink1: exists V:set,
    open_cover X Tx V /\
    locally_finite_family X Tx V /\
    refine_of V U /\
    forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
  { exact (shrinking_lemma_41_6 X Tx U Hpara HH Hcover). }
  claim Hshrink2: forall V:set,
    open_cover X Tx V ->
    exists W:set,
      open_cover X Tx W /\
      locally_finite_family X Tx W /\
      refine_of W V /\
      forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v.
  { let V0. assume HV0: open_cover X Tx V0.
    exact (shrinking_lemma_41_6 X Tx V0 Hpara HH HV0). }
  (** Extract the first shrinking refinement V and then shrink it again to W. **)
  apply Hshrink1.
  let V.
  assume HV: open_cover X Tx V /\
             locally_finite_family X Tx V /\
             refine_of V U /\
             forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
  claim HVleft: (open_cover X Tx V /\ locally_finite_family X Tx V) /\ refine_of V U.
  { exact (andEL
      ((open_cover X Tx V /\ locally_finite_family X Tx V) /\ refine_of V U)
      (forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u)
      HV). }
  claim HVcldom: forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u.
  { exact (andER
      ((open_cover X Tx V /\ locally_finite_family X Tx V) /\ refine_of V U)
      (forall v:set, v :e V -> exists u:set, u :e U /\ closure_of X Tx v c= u)
      HV). }
  claim HVcovlf: open_cover X Tx V /\ locally_finite_family X Tx V.
  { exact (andEL
      (open_cover X Tx V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HVleft). }
  claim HVref: refine_of V U.
  { exact (andER
      (open_cover X Tx V /\ locally_finite_family X Tx V)
      (refine_of V U)
      HVleft). }
  claim HVcover: open_cover X Tx V.
  { exact (andEL (open_cover X Tx V) (locally_finite_family X Tx V) HVcovlf). }
  claim HVlf: locally_finite_family X Tx V.
  { exact (andER (open_cover X Tx V) (locally_finite_family X Tx V) HVcovlf). }

  claim HexW: exists W:set,
    open_cover X Tx W /\
    locally_finite_family X Tx W /\
    refine_of W V /\
    forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v.
  { exact (Hshrink2 V HVcover). }
  apply HexW.
  let W.
  assume HW: open_cover X Tx W /\
             locally_finite_family X Tx W /\
             refine_of W V /\
             forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v.
  claim HWleft: (open_cover X Tx W /\ locally_finite_family X Tx W) /\ refine_of W V.
  { exact (andEL
      ((open_cover X Tx W /\ locally_finite_family X Tx W) /\ refine_of W V)
      (forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v)
      HW). }
  claim HWcldom: forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v.
  { exact (andER
      ((open_cover X Tx W /\ locally_finite_family X Tx W) /\ refine_of W V)
      (forall w:set, w :e W -> exists v:set, v :e V /\ closure_of X Tx w c= v)
      HW). }
  claim HWcovlf: open_cover X Tx W /\ locally_finite_family X Tx W.
  { exact (andEL
      (open_cover X Tx W /\ locally_finite_family X Tx W)
      (refine_of W V)
      HWleft). }
  claim HWref: refine_of W V.
  { exact (andER
      (open_cover X Tx W /\ locally_finite_family X Tx W)
      (refine_of W V)
      HWleft). }
  claim HWcover: open_cover X Tx W.
  { exact (andEL (open_cover X Tx W) (locally_finite_family X Tx W) HWcovlf). }
  claim HWlf: locally_finite_family X Tx W.
  { exact (andER (open_cover X Tx W) (locally_finite_family X Tx W) HWcovlf). }

  claim HrefWU: refine_of W U.
  { exact (refine_trans U V W HWref HVref). }
  exact (normal_locally_finite_refinement_partition_of_unity X Tx U W
           Hnorm Hcover HWcover HWlf HrefWU).
Qed.

(** from §41 Theorem 41.8: positive continuous function bounded on a locally finite collection **)
(** LATEX VERSION: If C is locally finite and eps assigns a positive number to each C, there is continuous f>0 with f(x) <= eps(C) for x in C. **)
Theorem paracompact_Hausdorff_locally_finite_bounded_function : forall X Tx C eps:set,
  paracompact_space X Tx ->
  Hausdorff_space X Tx ->
  locally_finite_family X Tx C ->
  (forall c:set, c :e C -> apply_fun eps c :e R /\ Rlt 0 (apply_fun eps c)) ->
  exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    (forall x:set, x :e X -> Rlt 0 (apply_fun f x)) /\
    (forall c x:set, c :e C -> x :e c -> Rle (apply_fun f x) (apply_fun eps c)).
let X Tx C eps.
assume Hpara: paracompact_space X Tx.
assume HH: Hausdorff_space X Tx.
assume Hloc: locally_finite_family X Tx C.
assume Heps: forall c:set, c :e C -> apply_fun eps c :e R /\ Rlt 0 (apply_fun eps c).
prove exists f:set,
  continuous_map X Tx R R_standard_topology f /\
  (forall x:set, x :e X -> Rlt 0 (apply_fun f x)) /\
  (forall c x:set, c :e C -> x :e c -> Rle (apply_fun f x) (apply_fun eps c)).
(** Pending: use paracompact Hausdorff -> normal, build bump functions on each c in the locally finite family, then sum them locally finitely and rescale by eps. **)
claim Hnorm: normal_space X Tx.
{ exact (paracompact_Hausdorff_normal X Tx Hpara HH). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X ->
                 exists N:set, N :e Tx /\ x :e N /\
                   exists S:set, finite S /\ S c= C /\
                     forall A:set, A :e C -> A :/\: N <> Empty -> A :e S)
               Hloc). }
admit. (** FAIL **)
Qed.

(** from §42 Smirnov metrization theorem **) 
(** LATEX VERSION: Smirnov metrization: regular spaces with a locally finite basis are metrizable. **)
Theorem Smirnov_metrization : forall X Tx:set,
  regular_space X Tx -> locally_finite_basis X Tx -> metrizable X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume Hbasis: locally_finite_basis X Tx.
prove metrizable X Tx.
claim Hsigma: sigma_locally_finite_basis X Tx.
{ exact (locally_finite_basis_imp_sigma_locally_finite_basis X Tx Hbasis). }
exact (Nagata_Smirnov_metrization X Tx Hreg Hsigma).
Qed.

(** NOTE: cauchy_sequence / complete_metric_space moved earlier (before §35) to avoid forward-reference issues. **)
(** FIXED: discrete_metric is defined as a graph on X×X with value 0 on the diagonal and 1 off the diagonal. **) 
(** from §20 Metric topology: auxiliary definition of the discrete metric **)
(** LATEX VERSION: The discrete metric satisfies d(x,y)=0 if x=y and d(x,y)=1 otherwise. **)
Definition discrete_metric : set -> set := fun X =>
  graph (setprod X X) (fun p:set => If_i (p 0 = p 1) 0 1).

(** helper: compute apply_fun of the discrete metric graph **)
Theorem discrete_metric_apply : forall X x y:set,
  x :e X -> y :e X ->
  apply_fun (discrete_metric X) (x,y) = If_i (x = y) 0 1.
let X x y.
assume Hx: x :e X.
assume Hy: y :e X.
claim Hxy: (x,y) :e setprod X X.
{ exact (tuple_2_setprod_by_pair_Sigma X X x y Hx Hy). }
claim Hdef: discrete_metric X = graph (setprod X X) (fun p:set => If_i (p 0 = p 1) 0 1).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph (setprod X X) (fun p:set => If_i (p 0 = p 1) 0 1) (x,y) Hxy).
rewrite (tuple_2_0_eq x y).
rewrite (tuple_2_1_eq x y).
reflexivity.
Qed.

(** helper: the discrete metric is a metric_on **)
Theorem discrete_metric_is_metric_on : forall X:set,
  metric_on X (discrete_metric X).
let X.
prove metric_on X (discrete_metric X).
prove function_on (discrete_metric X) (setprod X X) R /\
  (forall x y:set, x :e X -> y :e X ->
     apply_fun (discrete_metric X) (x,y) = apply_fun (discrete_metric X) (y,x)) /\
  (forall x:set, x :e X -> apply_fun (discrete_metric X) (x,x) = 0) /\
  (forall x y:set, x :e X -> y :e X ->
     ~(Rlt (apply_fun (discrete_metric X) (x,y)) 0)
     /\ (apply_fun (discrete_metric X) (x,y) = 0 -> x = y)) /\
  (forall x y z:set, x :e X -> y :e X -> z :e X ->
     ~(Rlt (add_SNo (apply_fun (discrete_metric X) (x,y)) (apply_fun (discrete_metric X) (y,z)))
           (apply_fun (discrete_metric X) (x,z)))).
apply andI.
- (** function_on + symmetry + reflexive + positive definite **)
  apply andI.
  + (** (function_on /\ symmetry) /\ reflexive (left-associated) **)
    apply andI.
    * (** function_on /\ symmetry **)
      apply andI.
      - (** function_on **)
        let p. assume Hp: p :e setprod X X.
        prove apply_fun (discrete_metric X) p :e R.
        set x := p 0.
        set y := p 1.
        claim Hx: x :e X.
        { exact (ap0_Sigma X (fun _ : set => X) p Hp). }
        claim Hy: y :e X.
        { exact (ap1_Sigma X (fun _ : set => X) p Hp). }
        claim Hpeta: p = (x,y).
        { exact (setprod_eta X X p Hp). }
        rewrite Hpeta.
        rewrite (discrete_metric_apply X x y Hx Hy).
        apply xm (x = y).
        + assume Heq: x = y.
          rewrite (If_i_1 (x = y) 0 1 Heq).
          exact real_0.
        + assume Hneq: ~(x = y).
          rewrite (If_i_0 (x = y) 0 1 Hneq).
          exact real_1.
      - (** symmetry **)
        let x y.
        assume Hx: x :e X.
        assume Hy: y :e X.
        rewrite (discrete_metric_apply X x y Hx Hy).
        rewrite (discrete_metric_apply X y x Hy Hx).
        apply xm (x = y).
        + assume Heq: x = y.
          rewrite (If_i_1 (x = y) 0 1 Heq).
          rewrite (If_i_1 (y = x) 0 1).
          * reflexivity.
          * rewrite Heq. reflexivity.
        + assume Hneq: ~(x = y).
          rewrite (If_i_0 (x = y) 0 1 Hneq).
          claim Hnyx: ~(y = x).
          { assume Hyx: y = x.
            apply Hneq.
            rewrite <- Hyx.
            reflexivity. }
          rewrite (If_i_0 (y = x) 0 1 Hnyx).
          reflexivity.
    * (** reflexive: d(x,x)=0 **)
      let x. assume Hx: x :e X.
      rewrite (discrete_metric_apply X x x Hx Hx).
      rewrite (If_i_1 (x = x) 0 1).
      - reflexivity.
      - reflexivity.
  + (** positive definite **)
    let x y.
    assume Hx: x :e X.
    assume Hy: y :e X.
    prove ~(Rlt (apply_fun (discrete_metric X) (x,y)) 0)
      /\ (apply_fun (discrete_metric X) (x,y) = 0 -> x = y).
    apply andI.
    * (** not Rlt d 0 **)
      rewrite (discrete_metric_apply X x y Hx Hy).
      apply xm (x = y).
      - assume Heq: x = y.
        rewrite (If_i_1 (x = y) 0 1 Heq).
        exact (not_Rlt_refl 0 real_0).
      - assume Hneq: ~(x = y).
        rewrite (If_i_0 (x = y) 0 1 Hneq).
        exact (not_Rlt_sym 0 1 Rlt_0_1).
    * (** d=0 -> x=y **)
      assume Hd0: apply_fun (discrete_metric X) (x,y) = 0.
      claim Hd0': If_i (x = y) 0 1 = 0.
      { rewrite <- (discrete_metric_apply X x y Hx Hy).
        exact Hd0. }
      apply xm (x = y).
      - assume Heq: x = y.
        exact Heq.
      - assume Hneq: ~(x = y).
        claim Hval: If_i (x = y) 0 1 = 1.
        { exact (If_i_0 (x = y) 0 1 Hneq). }
        apply FalseE.
        claim H10: 1 = 0.
        { rewrite <- Hval at 1.
          exact Hd0'. }
        exact (neq_1_0 H10).
- (** triangle inequality **)
  let x y z.
  assume Hx: x :e X.
  assume Hy: y :e X.
  assume Hz: z :e X.
  rewrite (discrete_metric_apply X x y Hx Hy).
  rewrite (discrete_metric_apply X y z Hy Hz).
  rewrite (discrete_metric_apply X x z Hx Hz).
  apply xm (x = z).
  * assume Hxz: x = z.
    rewrite (If_i_1 (x = z) 0 1 Hxz).
    (** show not (dx+dy < 0) by cases on dx,dy in {0,1} **)
    apply xm (x = y).
    + assume Hxy: x = y.
      rewrite (If_i_1 (x = y) 0 1 Hxy).
      apply xm (y = z).
      - assume Hyz: y = z.
        rewrite (If_i_1 (y = z) 0 1 Hyz).
        rewrite (add_SNo_0L 0 SNo_0).
        exact (not_Rlt_refl 0 real_0).
      - assume Hnyz: ~(y = z).
        rewrite (If_i_0 (y = z) 0 1 Hnyz).
        rewrite (add_SNo_0L 1 SNo_1).
        exact (not_Rlt_sym 0 1 Rlt_0_1).
    + assume Hnxy: ~(x = y).
      rewrite (If_i_0 (x = y) 0 1 Hnxy).
      apply xm (y = z).
      - assume Hyz: y = z.
        rewrite (If_i_1 (y = z) 0 1 Hyz).
        rewrite (add_SNo_0R 1 SNo_1).
        exact (not_Rlt_sym 0 1 Rlt_0_1).
      - assume Hnyz: ~(y = z).
        rewrite (If_i_0 (y = z) 0 1 Hnyz).
        rewrite add_SNo_1_1_2.
        claim H0lt2: Rlt 0 2.
        { exact (RltI 0 2 real_0 real_2 SNoLt_0_2). }
        exact (not_Rlt_sym 0 2 H0lt2).
  * assume Hnxz: ~(x = z).
    rewrite (If_i_0 (x = z) 0 1 Hnxz).
    (** show not (dx+dy < 1); exclude dx=0,dy=0 since that would force x=z **)
    apply xm (x = y).
    + assume Hxy: x = y.
      rewrite (If_i_1 (x = y) 0 1 Hxy).
      apply xm (y = z).
      - assume Hyz: y = z.
        rewrite (If_i_1 (y = z) 0 1 Hyz).
        rewrite (add_SNo_0L 0 SNo_0).
        apply FalseE.
        apply Hnxz.
        rewrite Hxy.
        exact Hyz.
      - assume Hnyz: ~(y = z).
        rewrite (If_i_0 (y = z) 0 1 Hnyz).
        rewrite (add_SNo_0L 1 SNo_1).
        exact (not_Rlt_refl 1 real_1).
    + assume Hnxy: ~(x = y).
      rewrite (If_i_0 (x = y) 0 1 Hnxy).
      apply xm (y = z).
      - assume Hyz: y = z.
        rewrite (If_i_1 (y = z) 0 1 Hyz).
        rewrite (add_SNo_0R 1 SNo_1).
        exact (not_Rlt_refl 1 real_1).
      - assume Hnyz: ~(y = z).
        rewrite (If_i_0 (y = z) 0 1 Hnyz).
        rewrite add_SNo_1_1_2.
        claim H12: Rlt 1 2.
        { exact (RltI 1 2 real_1 real_2 SNoLt_1_2). }
        exact (not_Rlt_sym 1 2 H12).
Qed.

(** helper: open ball of radius 1 in the discrete metric is the singleton **)
Theorem open_ball_discrete_radius1_eq_singleton : forall X x:set,
  x :e X ->
  open_ball X (discrete_metric X) x 1 = {x}.
let X x.
assume Hx: x :e X.
apply set_ext.
- let y. assume Hy: y :e open_ball X (discrete_metric X) x 1.
  prove y :e {x}.
  claim HyX: y :e X.
  { exact (open_ballE1 X (discrete_metric X) x 1 y Hy). }
  claim Hlt: Rlt (apply_fun (discrete_metric X) (x,y)) 1.
  { exact (open_ballE2 X (discrete_metric X) x 1 y Hy). }
  claim Hlt': Rlt (If_i (x = y) 0 1) 1.
  { prove Rlt (If_i (x = y) 0 1) 1.
    rewrite <- (discrete_metric_apply X x y Hx HyX) at 1.
    exact Hlt. }
  apply xm (x = y).
  * assume Heq: x = y.
    rewrite <- Heq.
    exact (SingI x).
  * assume Hneq: ~(x = y).
    claim Hval: If_i (x = y) 0 1 = 1.
    { exact (If_i_0 (x = y) 0 1 Hneq). }
    apply FalseE.
    claim Hbad: Rlt 1 1.
    { prove Rlt 1 1.
      rewrite <- Hval at 1.
      exact Hlt'. }
    exact ((not_Rlt_refl 1 real_1) Hbad).
- let y. assume Hy: y :e {x}.
  prove y :e open_ball X (discrete_metric X) x 1.
  claim HyEq: y = x.
  { exact (SingE x y Hy). }
  rewrite HyEq.
  apply open_ballI.
  * exact Hx.
  * rewrite (discrete_metric_apply X x x Hx Hx).
    rewrite (If_i_1 (x = x) 0 1).
    - exact Rlt_0_1.
    - reflexivity.
Qed.

(** helper: discrete metric spaces are complete **)
Theorem discrete_metric_complete : forall X:set,
  complete_metric_space X (discrete_metric X).
let X.
prove complete_metric_space X (discrete_metric X).
prove metric_on X (discrete_metric X) /\
  forall seq:set, sequence_on seq X -> cauchy_sequence X (discrete_metric X) seq ->
    exists x:set, converges_to X (metric_topology X (discrete_metric X)) seq x.
apply andI.
- exact (discrete_metric_is_metric_on X).
- let seq.
  assume Hseq: sequence_on seq X.
  assume Hcauchy: cauchy_sequence X (discrete_metric X) seq.
  (** extract Cauchy property at eps=1 to get eventual constancy **)
  claim Htail: forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) eps.
  { exact (andER (metric_on X (discrete_metric X) /\ sequence_on seq X)
                 (forall eps:set, eps :e R /\ Rlt 0 eps ->
                   exists N:set, N :e omega /\
                     forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                       Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) eps)
                 Hcauchy). }
  claim HexN: exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1.
  { exact (Htail 1 (andI (1 :e R) (Rlt 0 1) real_1 Rlt_0_1)). }
  set N := Eps_i (fun N0:set =>
    N0 :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
      Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1).
  claim HNprop: N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1.
  { exact (Eps_i_ex (fun N0:set =>
      N0 :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
        Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1)
      HexN). }
  claim HNomega: N :e omega.
  { exact (andEL (N :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                   Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1)
                 HNprop). }
  claim HNtail: forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1.
  { exact (andER (N :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                   Rlt (apply_fun (discrete_metric X) (apply_fun seq m, apply_fun seq n)) 1)
                 HNprop). }

  set x0 := apply_fun seq N.
  claim Hx0X: x0 :e X.
  { exact (Hseq N HNomega). }

  claim Heventually_const: forall n:set, n :e omega -> N c= n -> apply_fun seq n = x0.
  { let n. assume HnO: n :e omega. assume HNn: N c= n.
    claim HNN: N c= N.
    { exact (Subq_ref N). }
    claim Hlt: Rlt (apply_fun (discrete_metric X) (apply_fun seq N, apply_fun seq n)) 1.
    { exact (HNtail N n HNomega HnO HNN HNn). }
    set a := apply_fun seq N.
    set b := apply_fun seq n.
    claim HaX: a :e X.
    { exact (Hseq N HNomega). }
    claim HbX: b :e X.
    { exact (Hseq n HnO). }
    claim Hlt': Rlt (If_i (a = b) 0 1) 1.
    { prove Rlt (If_i (a = b) 0 1) 1.
      rewrite <- (discrete_metric_apply X a b HaX HbX) at 1.
      exact Hlt. }
    apply xm (a = b).
    - assume Heq: a = b.
      rewrite Heq.
      reflexivity.
    - assume Hneq: ~(a = b).
      claim Hval: If_i (a = b) 0 1 = 1.
      { exact (If_i_0 (a = b) 0 1 Hneq). }
      apply FalseE.
      claim Hbad: Rlt 1 1.
      { prove Rlt 1 1.
        rewrite <- Hval at 1.
        exact Hlt'. }
      exact ((not_Rlt_refl 1 real_1) Hbad). }

  (** prove convergence to x0 in the metric topology **)
  witness x0.
  prove converges_to X (metric_topology X (discrete_metric X)) seq x0.
  prove topology_on X (metric_topology X (discrete_metric X)) /\
        sequence_on seq X /\ x0 :e X /\
        forall U:set, U :e (metric_topology X (discrete_metric X)) -> x0 :e U ->
          exists N0:set, N0 :e omega /\
            forall n:set, n :e omega -> N0 c= n -> apply_fun seq n :e U.
  apply and4I.
  - exact (metric_topology_is_topology X (discrete_metric X) (discrete_metric_is_metric_on X)).
  - exact Hseq.
  - exact Hx0X.
  - let U. assume HU: U :e metric_topology X (discrete_metric X).
    assume Hx0U: x0 :e U.
      (** use generated_topology definition to get a basis element b with x0 ∈ b ⊆ U **)
      set B := famunion X (fun x:set => {open_ball X (discrete_metric X) x r|r :e R, Rlt 0 r}).
      claim HUsubX: U c= X.
      { exact (PowerE X U (SepE1 (Power X)
        (fun U0:set => forall y0 :e U0, exists b0 :e B, y0 :e b0 /\ b0 c= U0)
        U HU)). }
      claim HUref: forall y0 :e U, exists b0 :e B, y0 :e b0 /\ b0 c= U.
      { exact (SepE2 (Power X)
        (fun U0:set => forall y0 :e U0, exists b0 :e B, y0 :e b0 /\ b0 c= U0)
        U HU). }
      claim Hexb: exists b0 :e B, x0 :e b0 /\ b0 c= U.
      { exact (HUref x0 Hx0U). }
      apply Hexb.
      let b0. assume Hb0.
      claim Hb0B: b0 :e B.
      { exact (andEL (b0 :e B) (x0 :e b0 /\ b0 c= U) Hb0). }
      claim Hb0pack: x0 :e b0 /\ b0 c= U.
      { exact (andER (b0 :e B) (x0 :e b0 /\ b0 c= U) Hb0). }
      claim Hb0subU: b0 c= U.
      { exact (andER (x0 :e b0) (b0 c= U) Hb0pack). }
      witness N.
      apply andI.
      * exact HNomega.
      * let n. assume HnO: n :e omega. assume HNn: N c= n.
        prove apply_fun seq n :e U.
        claim Heqnx0: apply_fun seq n = x0.
        { exact (Heventually_const n HnO HNn). }
        rewrite Heqnx0.
        exact (Hb0subU x0 (andEL (x0 :e b0) (b0 c= U) Hb0pack)).
Qed.
(** helper: placeholder metric on euclidean_space n **) 
(** from §24 Euclidean space: auxiliary metric on euclidean_space n **)
(** LATEX VERSION: Euclidean space R^n is a metric space in its usual Euclidean metric. **)
(** SUSPICIOUS DEFINITION: The development does not currently have an explicit ℓ2 formula for R^n, so we use the standard bounded D metric on R^omega and embed R^n into R^omega by padding with 0 outside n. This induces the usual product topology on R^n (and hence the Euclidean topology for finite n). **)
(** helper: extend a point of R^n (a function on n) to a sequence on omega by padding with 0 outside n **)
Definition euclidean_space_extend_to_Romega : set -> set -> set := fun n f =>
  graph omega (fun i:set => If_i (i :e n) (apply_fun f i) 0).
(** from §24 Euclidean space: Euclidean metric on R^n (implemented via the D metric on R^omega) **)
(** LATEX VERSION: Euclidean distance on R^n is the metric inducing the Euclidean topology. **)
Definition euclidean_metric : set -> set := fun n =>
  graph (setprod (euclidean_space n) (euclidean_space n))
    (fun p:set =>
      Romega_D_metric_value
        (euclidean_space_extend_to_Romega n (p 0))
        (euclidean_space_extend_to_Romega n (p 1))).

(** helper: coordinates of a point in euclidean_space n are real numbers **)
(** LATEX VERSION: Each coordinate projection R^n -> R is well-defined on the product space. **)
Theorem euclidean_space_coord_in_R : forall n f i:set,
  f :e euclidean_space n ->
  i :e n ->
  apply_fun f i :e R.
let n f i.
assume Hf: f :e euclidean_space n.
assume Hi: i :e n.
prove apply_fun f i :e R.
set Xi := const_space_family n R R_standard_topology.
claim Hfprop: total_function_on f n (space_family_union n Xi) /\ functional_graph f /\
              forall j:set, j :e n -> apply_fun f j :e space_family_set Xi j.
{ exact (SepE2 (Power (setprod n (space_family_union n Xi)))
               (fun f0:set => total_function_on f0 n (space_family_union n Xi) /\ functional_graph f0 /\
                 forall j:set, j :e n -> apply_fun f0 j :e space_family_set Xi j)
               f
               Hf). }
claim Hcoords: forall j:set, j :e n -> apply_fun f j :e space_family_set Xi j.
{ exact (andER (total_function_on f n (space_family_union n Xi) /\ functional_graph f)
               (forall j:set, j :e n -> apply_fun f j :e space_family_set Xi j)
               Hfprop). }
claim Hfi: apply_fun f i :e space_family_set Xi i.
{ exact (Hcoords i Hi). }
claim HXi: apply_fun Xi i = (R, R_standard_topology).
{ exact (const_space_family_apply n R R_standard_topology i Hi). }
claim Hset: space_family_set Xi i = R.
{ claim Hdef: space_family_set Xi i = (apply_fun Xi i) 0.
  { reflexivity. }
  rewrite Hdef.
  rewrite HXi.
  exact (tuple_2_0_eq R R_standard_topology). }
rewrite <- Hset.
exact Hfi.
Qed.

(** helper: extension of a point of R^n to a sequence lies in R^omega **)
(** LATEX VERSION: Pad a point in R^n with zeros to obtain an element of R^omega. **)
Theorem euclidean_space_extend_to_Romega_in_Romega_space : forall n f:set,
  f :e euclidean_space n ->
  euclidean_space_extend_to_Romega n f :e R_omega_space.
let n f.
assume Hf: f :e euclidean_space n.
set h := (fun i:set => If_i (i :e n) (apply_fun f i) 0).
claim Hdef: euclidean_space_extend_to_Romega n f = graph omega h.
{ reflexivity. }
rewrite Hdef.
apply (graph_omega_in_Romega_space h).
let i. assume Hi: i :e omega.
apply xm (i :e n).
- assume Hin: i :e n.
  claim HfiR: apply_fun f i :e R.
  { exact (euclidean_space_coord_in_R n f i Hf Hin). }
  claim Hhi: h i = If_i (i :e n) (apply_fun f i) 0.
  { reflexivity. }
  rewrite Hhi.
  rewrite (If_i_1 (i :e n) (apply_fun f i) 0 Hin).
  exact HfiR.
- assume Hnin: ~(i :e n).
  claim Hhi: h i = If_i (i :e n) (apply_fun f i) 0.
  { reflexivity. }
  rewrite Hhi.
  rewrite (If_i_0 (i :e n) (apply_fun f i) 0 Hnin).
  exact real_0.
Qed.

(** helper: compute the padded extension on an index i **)
(** LATEX VERSION: The extension agrees with the original point on indices in n and is zero otherwise. **)
Theorem euclidean_space_extend_to_Romega_apply : forall n f i:set,
  i :e omega ->
  apply_fun (euclidean_space_extend_to_Romega n f) i =
    If_i (i :e n) (apply_fun f i) 0.
let n f i.
assume Hi: i :e omega.
claim Hdef: euclidean_space_extend_to_Romega n f =
  graph omega (fun j:set => If_i (j :e n) (apply_fun f j) 0).
{ reflexivity. }
rewrite Hdef.
exact (apply_fun_graph omega (fun j:set => If_i (j :e n) (apply_fun f j) 0) i Hi).
Qed.

(** helper: the padding extension is injective on R^n for n in omega **)
(** LATEX VERSION: A point of R^n is determined by its coordinates, hence by its padded sequence in R^omega. **)
Theorem euclidean_space_extend_to_Romega_injective : forall n f g:set,
  n :e omega ->
  f :e euclidean_space n ->
  g :e euclidean_space n ->
  euclidean_space_extend_to_Romega n f = euclidean_space_extend_to_Romega n g ->
  f = g.
let n f g.
assume HnO: n :e omega.
assume Hf: f :e euclidean_space n.
assume Hg: g :e euclidean_space n.
assume Hext: euclidean_space_extend_to_Romega n f = euclidean_space_extend_to_Romega n g.
apply xm (f = g).
- assume Heq. exact Heq.
- assume Hneq: ~(f = g).
  claim Hex: exists i:set, i :e n /\ apply_fun f i <> apply_fun g i.
  { exact (product_space_points_differ_coord n (const_space_family n R R_standard_topology) f g Hf Hg Hneq). }
  apply FalseE.
  apply Hex.
  let i. assume Hipair.
  claim Hin: i :e n.
  { exact (andEL (i :e n) (apply_fun f i <> apply_fun g i) Hipair). }
  claim Hdiff: apply_fun f i <> apply_fun g i.
  { exact (andER (i :e n) (apply_fun f i <> apply_fun g i) Hipair). }
  claim HnSub: n c= omega.
  { exact (omega_TransSet n HnO). }
  claim HiO: i :e omega.
  { exact (HnSub i Hin). }
  set ef := euclidean_space_extend_to_Romega n f.
  set eg := euclidean_space_extend_to_Romega n g.
  claim HappEq: apply_fun ef i = apply_fun eg i.
  { rewrite Hext. reflexivity. }
  claim Hapf: apply_fun ef i = If_i (i :e n) (apply_fun f i) 0.
  { exact (euclidean_space_extend_to_Romega_apply n f i HiO). }
  claim Hapg: apply_fun eg i = If_i (i :e n) (apply_fun g i) 0.
  { exact (euclidean_space_extend_to_Romega_apply n g i HiO). }
  claim Hapf': apply_fun ef i = apply_fun f i.
  { rewrite Hapf.
    rewrite (If_i_1 (i :e n) (apply_fun f i) 0 Hin).
    reflexivity. }
  claim Hapg': apply_fun eg i = apply_fun g i.
  { rewrite Hapg.
    rewrite (If_i_1 (i :e n) (apply_fun g i) 0 Hin).
    reflexivity. }
  claim Heqfg: apply_fun f i = apply_fun g i.
  { rewrite <- Hapf'.
    rewrite <- Hapg'.
    exact HappEq. }
  exact (Hdiff Heqfg).
Qed.

(** helper: evaluate euclidean_metric on a pair of points **)
(** LATEX VERSION: The metric on R^n is computed by applying D to the padded sequences. **)
Theorem euclidean_metric_apply : forall n x y:set,
  x :e euclidean_space n ->
  y :e euclidean_space n ->
  apply_fun (euclidean_metric n) (x,y) =
    Romega_D_metric_value
      (euclidean_space_extend_to_Romega n x)
      (euclidean_space_extend_to_Romega n y).
let n x y.
assume Hx: x :e euclidean_space n.
assume Hy: y :e euclidean_space n.
claim Hxy: (x,y) :e setprod (euclidean_space n) (euclidean_space n).
{ exact (tuple_2_setprod_by_pair_Sigma (euclidean_space n) (euclidean_space n) x y Hx Hy). }
claim Hdef: euclidean_metric n =
  graph (setprod (euclidean_space n) (euclidean_space n))
    (fun p:set =>
      Romega_D_metric_value
        (euclidean_space_extend_to_Romega n (p 0))
        (euclidean_space_extend_to_Romega n (p 1))).
{ reflexivity. }
rewrite Hdef.
rewrite (apply_fun_graph (setprod (euclidean_space n) (euclidean_space n))
         (fun p:set =>
           Romega_D_metric_value
             (euclidean_space_extend_to_Romega n (p 0))
             (euclidean_space_extend_to_Romega n (p 1)))
         (x,y) Hxy).
rewrite (tuple_2_0_eq x y).
rewrite (tuple_2_1_eq x y).
reflexivity.
Qed.

(** helper: euclidean_metric is a metric on R^n for n in omega **)
(** LATEX VERSION: For each natural n, R^n is a metric space. **)
Theorem euclidean_metric_is_metric_on : forall n:set,
  n :e omega ->
  metric_on (euclidean_space n) (euclidean_metric n).
let n.
assume HnO: n :e omega.
set X := euclidean_space n.
set d := euclidean_metric n.
prove metric_on X d.
prove function_on d (setprod X X) R /\
  (forall x y:set, x :e X -> y :e X -> apply_fun d (x,y) = apply_fun d (y,x)) /\
  (forall x:set, x :e X -> apply_fun d (x,x) = 0) /\
  (forall x y:set, x :e X -> y :e X ->
     ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y)) /\
  (forall x y z:set, x :e X -> y :e X -> z :e X ->
     ~(Rlt (add_SNo (apply_fun d (x,y)) (apply_fun d (y,z))) (apply_fun d (x,z)))).
apply and5I.
- (** function_on **)
  let p. assume Hp: p :e setprod X X.
  prove apply_fun d p :e R.
  claim Hp0: p 0 :e X.
  { exact (ap0_Sigma X (fun _ : set => X) p Hp). }
  claim Hp1: p 1 :e X.
  { exact (ap1_Sigma X (fun _ : set => X) p Hp). }
  claim Hval: apply_fun d p =
    Romega_D_metric_value
      (euclidean_space_extend_to_Romega n (p 0))
      (euclidean_space_extend_to_Romega n (p 1)).
  { claim Hdef: d =
      graph (setprod X X)
        (fun q:set =>
          Romega_D_metric_value
            (euclidean_space_extend_to_Romega n (q 0))
            (euclidean_space_extend_to_Romega n (q 1))).
    { reflexivity. }
    rewrite Hdef.
    exact (apply_fun_graph (setprod X X)
      (fun q:set =>
        Romega_D_metric_value
          (euclidean_space_extend_to_Romega n (q 0))
          (euclidean_space_extend_to_Romega n (q 1)))
      p Hp). }
  rewrite Hval.
  claim Hx0: euclidean_space_extend_to_Romega n (p 0) :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n (p 0) Hp0). }
  claim Hx1: euclidean_space_extend_to_Romega n (p 1) :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n (p 1) Hp1). }
  exact (Romega_D_metric_value_in_R
          (euclidean_space_extend_to_Romega n (p 0))
          (euclidean_space_extend_to_Romega n (p 1))
          Hx0 Hx1).
- (** symmetry **)
  let x y.
  assume Hx: x :e X.
  assume Hy: y :e X.
  prove apply_fun d (x,y) = apply_fun d (y,x).
  claim Hxy: apply_fun d (x,y) =
    Romega_D_metric_value
      (euclidean_space_extend_to_Romega n x)
      (euclidean_space_extend_to_Romega n y).
  { exact (euclidean_metric_apply n x y Hx Hy). }
  claim Hyx: apply_fun d (y,x) =
    Romega_D_metric_value
      (euclidean_space_extend_to_Romega n y)
      (euclidean_space_extend_to_Romega n x).
  { exact (euclidean_metric_apply n y x Hy Hx). }
  rewrite Hxy.
  rewrite Hyx.
  claim Hextx: euclidean_space_extend_to_Romega n x :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n x Hx). }
  claim Hexty: euclidean_space_extend_to_Romega n y :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n y Hy). }
  exact (Romega_D_metric_value_sym
          (euclidean_space_extend_to_Romega n x)
          (euclidean_space_extend_to_Romega n y)
          Hextx Hexty).
- (** diagonal zero **)
  let x. assume Hx: x :e X.
  prove apply_fun d (x,x) = 0.
  claim Hxx: apply_fun d (x,x) =
    Romega_D_metric_value
      (euclidean_space_extend_to_Romega n x)
      (euclidean_space_extend_to_Romega n x).
  { exact (euclidean_metric_apply n x x Hx Hx). }
  rewrite Hxx.
  claim Hextx: euclidean_space_extend_to_Romega n x :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n x Hx). }
  exact (Romega_D_metric_value_self_zero (euclidean_space_extend_to_Romega n x) Hextx).
- (** nonneg and zero implies equality **)
  let x y.
  assume Hx: x :e X.
  assume Hy: y :e X.
  prove ~(Rlt (apply_fun d (x,y)) 0) /\ (apply_fun d (x,y) = 0 -> x = y).
  apply andI.
  * (** nonneg from the D metric **)
    claim HmD: metric_on R_omega_space Romega_D_metric.
    { exact (andEL (metric_on R_omega_space Romega_D_metric)
                   (Romega_D_metric_topology = R_omega_product_topology)
                   Romega_D_metric_induces_product_topology). }
    claim Hextx: euclidean_space_extend_to_Romega n x :e R_omega_space.
    { exact (euclidean_space_extend_to_Romega_in_Romega_space n x Hx). }
    claim Hexty: euclidean_space_extend_to_Romega n y :e R_omega_space.
    { exact (euclidean_space_extend_to_Romega_in_Romega_space n y Hy). }
    claim Hdxy: apply_fun d (x,y) =
      apply_fun Romega_D_metric
        (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y).
    { claim Hxyprod: (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
        :e setprod R_omega_space R_omega_space.
      { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
              (euclidean_space_extend_to_Romega n x)
              (euclidean_space_extend_to_Romega n y)
              Hextx Hexty). }
      claim HappD: apply_fun Romega_D_metric
        (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
        = Romega_D_metric_value
            (euclidean_space_extend_to_Romega n x)
            (euclidean_space_extend_to_Romega n y).
      { claim HdefD: Romega_D_metric =
          graph (setprod R_omega_space R_omega_space)
            (fun p:set => Romega_D_metric_value (p 0) (p 1)).
        { reflexivity. }
        rewrite HdefD.
        rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                (fun p:set => Romega_D_metric_value (p 0) (p 1))
                (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
                Hxyprod).
        rewrite (tuple_2_0_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
        rewrite (tuple_2_1_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
        reflexivity. }
      rewrite (euclidean_metric_apply n x y Hx Hy).
      rewrite <- HappD.
      reflexivity. }
    rewrite Hdxy.
    exact (metric_on_nonneg R_omega_space Romega_D_metric
            (euclidean_space_extend_to_Romega n x)
            (euclidean_space_extend_to_Romega n y)
            HmD Hextx Hexty).
  * (** zero implies equality via injectivity of extension **)
    assume H0: apply_fun d (x,y) = 0.
    claim HmD: metric_on R_omega_space Romega_D_metric.
    { exact (andEL (metric_on R_omega_space Romega_D_metric)
                   (Romega_D_metric_topology = R_omega_product_topology)
                   Romega_D_metric_induces_product_topology). }
    claim Hextx: euclidean_space_extend_to_Romega n x :e R_omega_space.
    { exact (euclidean_space_extend_to_Romega_in_Romega_space n x Hx). }
    claim Hexty: euclidean_space_extend_to_Romega n y :e R_omega_space.
    { exact (euclidean_space_extend_to_Romega_in_Romega_space n y Hy). }
    claim Hdxy: apply_fun Romega_D_metric
      (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y) = 0.
    { claim Hxyprod: (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
        :e setprod R_omega_space R_omega_space.
      { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
              (euclidean_space_extend_to_Romega n x)
              (euclidean_space_extend_to_Romega n y)
              Hextx Hexty). }
      claim HappD: apply_fun Romega_D_metric
        (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
        = Romega_D_metric_value
            (euclidean_space_extend_to_Romega n x)
            (euclidean_space_extend_to_Romega n y).
      { claim HdefD: Romega_D_metric =
          graph (setprod R_omega_space R_omega_space)
            (fun p:set => Romega_D_metric_value (p 0) (p 1)).
        { reflexivity. }
        rewrite HdefD.
        rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                (fun p:set => Romega_D_metric_value (p 0) (p 1))
                (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
                Hxyprod).
        rewrite (tuple_2_0_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
        rewrite (tuple_2_1_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
        reflexivity. }
      rewrite HappD.
      rewrite <- (euclidean_metric_apply n x y Hx Hy) at 1.
      exact H0. }
    claim HextEq: euclidean_space_extend_to_Romega n x = euclidean_space_extend_to_Romega n y.
    { exact (metric_on_zero_eq R_omega_space Romega_D_metric
            (euclidean_space_extend_to_Romega n x)
            (euclidean_space_extend_to_Romega n y)
            HmD Hextx Hexty Hdxy). }
    exact (euclidean_space_extend_to_Romega_injective n x y HnO Hx Hy HextEq).
- (** triangle inequality from the D metric **)
  let x y z.
  assume Hx: x :e X.
  assume Hy: y :e X.
  assume Hz: z :e X.
  claim HmD: metric_on R_omega_space Romega_D_metric.
  { exact (andEL (metric_on R_omega_space Romega_D_metric)
                 (Romega_D_metric_topology = R_omega_product_topology)
                 Romega_D_metric_induces_product_topology). }
  claim Hextx: euclidean_space_extend_to_Romega n x :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n x Hx). }
  claim Hexty: euclidean_space_extend_to_Romega n y :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n y Hy). }
  claim Hextz: euclidean_space_extend_to_Romega n z :e R_omega_space.
  { exact (euclidean_space_extend_to_Romega_in_Romega_space n z Hz). }
  claim HtriD:
    ~(Rlt (add_SNo (apply_fun Romega_D_metric
                   (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y))
                  (apply_fun Romega_D_metric
                   (euclidean_space_extend_to_Romega n y, euclidean_space_extend_to_Romega n z)))
          (apply_fun Romega_D_metric
            (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n z))).
  { exact (metric_on_triangle R_omega_space Romega_D_metric
          (euclidean_space_extend_to_Romega n x)
          (euclidean_space_extend_to_Romega n y)
          (euclidean_space_extend_to_Romega n z)
          HmD Hextx Hexty Hextz). }
  (** rewrite D-metric applications into euclidean_metric applications **)
  claim Hxyprod: (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
      :e setprod R_omega_space R_omega_space.
  { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
          (euclidean_space_extend_to_Romega n x)
          (euclidean_space_extend_to_Romega n y)
          Hextx Hexty). }
  claim Hyzprod: (euclidean_space_extend_to_Romega n y, euclidean_space_extend_to_Romega n z)
      :e setprod R_omega_space R_omega_space.
  { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
          (euclidean_space_extend_to_Romega n y)
          (euclidean_space_extend_to_Romega n z)
          Hexty Hextz). }
  claim Hxzprod: (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n z)
      :e setprod R_omega_space R_omega_space.
  { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
          (euclidean_space_extend_to_Romega n x)
          (euclidean_space_extend_to_Romega n z)
          Hextx Hextz). }
  claim Happxy: apply_fun Romega_D_metric
      (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
    = Romega_D_metric_value
        (euclidean_space_extend_to_Romega n x)
        (euclidean_space_extend_to_Romega n y).
  { claim HdefD: Romega_D_metric =
      graph (setprod R_omega_space R_omega_space)
        (fun p:set => Romega_D_metric_value (p 0) (p 1)).
    { reflexivity. }
    rewrite HdefD.
    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
            (fun p:set => Romega_D_metric_value (p 0) (p 1))
            (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n y)
            Hxyprod).
    rewrite (tuple_2_0_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
    rewrite (tuple_2_1_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n y)).
    reflexivity. }
  claim Happyz: apply_fun Romega_D_metric
      (euclidean_space_extend_to_Romega n y, euclidean_space_extend_to_Romega n z)
    = Romega_D_metric_value
        (euclidean_space_extend_to_Romega n y)
        (euclidean_space_extend_to_Romega n z).
  { claim HdefD: Romega_D_metric =
      graph (setprod R_omega_space R_omega_space)
        (fun p:set => Romega_D_metric_value (p 0) (p 1)).
    { reflexivity. }
    rewrite HdefD.
    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
            (fun p:set => Romega_D_metric_value (p 0) (p 1))
            (euclidean_space_extend_to_Romega n y, euclidean_space_extend_to_Romega n z)
            Hyzprod).
    rewrite (tuple_2_0_eq (euclidean_space_extend_to_Romega n y) (euclidean_space_extend_to_Romega n z)).
    rewrite (tuple_2_1_eq (euclidean_space_extend_to_Romega n y) (euclidean_space_extend_to_Romega n z)).
    reflexivity. }
  claim Happxz: apply_fun Romega_D_metric
      (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n z)
    = Romega_D_metric_value
        (euclidean_space_extend_to_Romega n x)
        (euclidean_space_extend_to_Romega n z).
  { claim HdefD: Romega_D_metric =
      graph (setprod R_omega_space R_omega_space)
        (fun p:set => Romega_D_metric_value (p 0) (p 1)).
    { reflexivity. }
    rewrite HdefD.
    rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
            (fun p:set => Romega_D_metric_value (p 0) (p 1))
            (euclidean_space_extend_to_Romega n x, euclidean_space_extend_to_Romega n z)
            Hxzprod).
    rewrite (tuple_2_0_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n z)).
    rewrite (tuple_2_1_eq (euclidean_space_extend_to_Romega n x) (euclidean_space_extend_to_Romega n z)).
    reflexivity. }
  (** rewrite the goal into the D-metric triangle inequality statement **)
  rewrite (euclidean_metric_apply n x y Hx Hy) at 1.
  rewrite (euclidean_metric_apply n y z Hy Hz) at 1.
  rewrite (euclidean_metric_apply n x z Hx Hz) at 1.
  rewrite <- Happxy at 1.
  rewrite <- Happyz at 1.
  rewrite <- Happxz at 1.
  exact HtriD.
Qed.

(** helper: bounded product metric on R^omega **) 
(** LATEX VERSION: Bounded product metric on R^ω (placeholder). **)
(** LATEX VERSION: On R^ω, use the bounded product metric D (defined earlier as `Romega_D_metric`). **)
(** SUSPICIOUS DEFINITION: For J ≠ ω this currently falls back to the discrete metric; this is a placeholder rather than a faithful bounded-product metric on R^J. **)
Definition bounded_product_metric : set -> set := fun J =>
  If_i (J = omega) Romega_D_metric (discrete_metric (power_real J)).

(** helper: the bounded product metric at ω is Romega_D_metric **)
(** LATEX VERSION: Specializing the definition to ω yields the D-metric on ℝ^ω. **)
Theorem bounded_product_metric_omega_eq : bounded_product_metric omega = Romega_D_metric.
prove bounded_product_metric omega = Romega_D_metric.
claim Hdef: bounded_product_metric omega =
  If_i (omega = omega) Romega_D_metric (discrete_metric (power_real omega)).
{ reflexivity. }
rewrite Hdef.
claim Homega: omega = omega.
{ reflexivity. }
rewrite (If_i_1 (omega = omega) Romega_D_metric (discrete_metric (power_real omega)) Homega).
reflexivity.
Qed.

(** from §43 Lemma 43.1: Cauchy with convergent subsequence converges **) 
(** LATEX VERSION: In a metric space, a Cauchy sequence with a convergent subsequence converges to the same limit. **)
(** helper: strictly increasing index map on ω (used to model subsequences) **)
(** LATEX VERSION: A subsequence is obtained by composing with a strictly increasing map f:ω→ω. **)
Definition omega_strictly_increasing : set -> prop := fun f =>
  forall m n:set, m :e omega -> n :e omega -> m :e n -> apply_fun f m :e apply_fun f n.

(** helper: subsequence of a sequence seq:ω→X **)
(** LATEX VERSION: subseq is a subsequence of seq if subseq(n)=seq(f(n)) for some strictly increasing f:ω→ω. **)
Definition subsequence_of : set -> set -> prop := fun seq subseq =>
  exists f:set,
    total_function_on f omega omega /\ functional_graph f /\ graph_domain_subset f omega /\
    omega_strictly_increasing f /\
    subseq = compose_fun omega f seq.

(** helper: twofold-small epsilon for metric estimates **)
(** For any positive eps0, choose eps1 with eps1+eps1 < eps0, using dyadic eps_ N. **)
Theorem exists_twofold_small_eps : forall eps0:set,
  eps0 :e R -> Rlt 0 eps0 ->
  exists eps1:set,
    eps1 :e R /\ Rlt 0 eps1 /\
    Rlt (add_SNo eps1 eps1) eps0.
let eps0.
assume Heps0R: eps0 :e R.
assume Heps0Pos: Rlt 0 eps0.
claim HexN0: exists N0 :e omega, eps_ N0 < eps0.
{ exact (exists_eps_lt_pos eps0 Heps0R Heps0Pos). }
apply HexN0.
let N0. assume HN0pair.
claim HN0omega: N0 :e omega.
{ exact (andEL (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
claim HepsN0lt: eps_ N0 < eps0.
{ exact (andER (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
claim HN0nat: nat_p N0.
{ exact (omega_nat_p N0 HN0omega). }
claim Hsucc0: ordsucc N0 :e omega.
{ exact (omega_ordsucc N0 HN0omega). }
set eps1 := eps_ (ordsucc N0).
claim Heps1R: eps1 :e R.
{ exact (SNoS_omega_real eps1 (SNo_eps_SNoS_omega (ordsucc N0) Hsucc0)). }
claim H0lt_eps1: 0 < eps1.
{ exact (SNo_eps_pos (ordsucc N0) Hsucc0). }
claim Heps1Pos: Rlt 0 eps1.
{ exact (RltI 0 eps1 real_0 Heps1R H0lt_eps1). }
claim HsumEq: add_SNo eps1 eps1 = eps_ N0.
{ exact (eps_ordsucc_half_add N0 HN0nat). }
claim HsumR: add_SNo eps1 eps1 :e R.
{ exact (real_add_SNo eps1 Heps1R eps1 Heps1R). }
claim HsumSlt: add_SNo eps1 eps1 < eps0.
{ rewrite HsumEq.
  exact HepsN0lt. }
claim HsumRlt: Rlt (add_SNo eps1 eps1) eps0.
{ exact (RltI (add_SNo eps1 eps1) eps0 HsumR Heps0R HsumSlt). }
witness eps1.
apply andI.
- apply andI.
  + exact Heps1R.
  + exact Heps1Pos.
- exact HsumRlt.
Qed.

(** helper: a strictly increasing omega index map is unbounded **)
(** If f:omega->omega is strictly increasing, then for any N there is k with N c= f(k). **)
Theorem omega_strictly_increasing_unbounded : forall f N:set,
  total_function_on f omega omega ->
  functional_graph f ->
  graph_domain_subset f omega ->
  omega_strictly_increasing f ->
  N :e omega ->
  exists k:set, k :e omega /\ N c= apply_fun f k.
let f N.
assume Htot: total_function_on f omega omega.
assume Hfg: functional_graph f.
assume Hdom: graph_domain_subset f omega.
assume Hinc: omega_strictly_increasing f.
assume HNomega: N :e omega.
claim HNnat: nat_p N.
{ exact (omega_nat_p N HNomega). }
claim HsuccN: ordsucc N :e omega.
{ exact (omega_ordsucc N HNomega). }
claim HfFun: function_on f omega omega.
{ exact (total_function_on_function_on f omega omega Htot). }
claim Hexbad: exists i:set, i :e ordsucc N /\ ~(apply_fun f i :e N).
{ claim Hex1: exists i:set, ~(i :e ordsucc N -> apply_fun f i :e N).
  { apply (not_all_ex_demorgan_i (fun i:set => i :e ordsucc N -> apply_fun f i :e N)).
    assume Hall: forall i:set, i :e ordsucc N -> apply_fun f i :e N.
    claim Hrange: forall i :e ordsucc N, (apply_fun f i) :e N.
    { let i. assume Hi: i :e ordsucc N.
      exact (Hall i Hi). }
    claim Hinj: forall i j :e ordsucc N, apply_fun f i = apply_fun f j -> i = j.
    { let i. assume Hi: i :e ordsucc N.
      let j. assume Hj: j :e ordsucc N.
      assume Heq: apply_fun f i = apply_fun f j.
      claim HiO: i :e omega.
      { exact (omega_TransSet (ordsucc N) HsuccN i Hi). }
      claim HjO: j :e omega.
      { exact (omega_TransSet (ordsucc N) HsuccN j Hj). }
      claim Hord_i: ordinal i.
      { exact (ordinal_Hered omega omega_ordinal i HiO). }
      claim Hord_j: ordinal j.
      { exact (ordinal_Hered omega omega_ordinal j HjO). }
      apply (ordinal_trichotomy_or_impred i j Hord_i Hord_j (i = j)).
      - assume Hij: i :e j.
        claim HfiIn: apply_fun f i :e apply_fun f j.
        { exact (Hinc i j HiO HjO Hij). }
        claim Hneq: apply_fun f i <> apply_fun f j.
        { assume Heq'.
          claim Hsubst: forall S T:set, S = T -> apply_fun f i :e S -> apply_fun f i :e T.
          { let S T. assume HeqST. assume Hmem.
            rewrite <- HeqST.
            exact Hmem. }
          claim Hsym: apply_fun f j = apply_fun f i.
          { rewrite <- Heq'.
            reflexivity. }
          claim Hself: apply_fun f i :e apply_fun f i.
          { exact (Hsubst (apply_fun f j) (apply_fun f i) Hsym HfiIn). }
          exact (In_irref (apply_fun f i) Hself). }
        exact (FalseE (Hneq Heq) (i = j)).
      - assume Hij: i = j.
        exact Hij.
      - assume Hji: j :e i.
        claim HfjIn: apply_fun f j :e apply_fun f i.
        { exact (Hinc j i HjO HiO Hji). }
        claim Hneq: apply_fun f j <> apply_fun f i.
        { assume Heq'.
          claim Hsubst: forall S T:set, S = T -> apply_fun f j :e S -> apply_fun f j :e T.
          { let S T. assume HeqST. assume Hmem.
            rewrite <- HeqST.
            exact Hmem. }
          claim Hsym: apply_fun f i = apply_fun f j.
          { rewrite <- Heq'.
            reflexivity. }
          claim Hself: apply_fun f j :e apply_fun f j.
          { exact (Hsubst (apply_fun f i) (apply_fun f j) Hsym HfjIn). }
          exact (In_irref (apply_fun f j) Hself). }
        claim HsymHeq: apply_fun f j = apply_fun f i.
        { rewrite <- Heq.
          reflexivity. }
        exact (FalseE (Hneq HsymHeq) (i = j)).
    }
    claim Hbad: ~(forall i j :e ordsucc N, (fun t:set => apply_fun f t) i = (fun t:set => apply_fun f t) j -> i = j).
    { exact (PigeonHole_nat N HNnat (fun t:set => apply_fun f t) Hrange). }
    claim Hgood: forall i j :e ordsucc N, (fun t:set => apply_fun f t) i = (fun t:set => apply_fun f t) j -> i = j.
    { let i. assume Hi: i :e ordsucc N.
      let j. assume Hj: j :e ordsucc N.
      exact (Hinj i Hi j Hj). }
    exact (Hbad Hgood). }
  apply Hex1.
  let i. assume Hnimp.
  claim Hipair: i :e ordsucc N /\ ~(apply_fun f i :e N).
  { exact (not_imp (i :e ordsucc N) (apply_fun f i :e N) Hnimp). }
  witness i.
  exact Hipair. }
apply Hexbad.
let k. assume Hkpair.
claim HkInSucc: k :e ordsucc N.
{ exact (andEL (k :e ordsucc N) (~(apply_fun f k :e N)) Hkpair). }
claim HknotIn: ~(apply_fun f k :e N).
{ exact (andER (k :e ordsucc N) (~(apply_fun f k :e N)) Hkpair). }
claim HkOmega: k :e omega.
{ exact (omega_TransSet (ordsucc N) HsuccN k HkInSucc). }
claim HfkOmega: apply_fun f k :e omega.
{ exact (HfFun k HkOmega). }
claim HfkOrd: ordinal (apply_fun f k).
{ exact (ordinal_Hered omega omega_ordinal (apply_fun f k) HfkOmega). }
apply (ordinal_trichotomy_or_impred (apply_fun f k) N HfkOrd (ordinal_Hered omega omega_ordinal N HNomega)
       (exists k0:set, k0 :e omega /\ N c= apply_fun f k0)).
- assume Hlt: apply_fun f k :e N.
  exact (FalseE (HknotIn Hlt) (exists k0:set, k0 :e omega /\ N c= apply_fun f k0)).
- assume Heq: apply_fun f k = N.
  witness k.
  apply andI.
  + exact HkOmega.
  + rewrite Heq.
    exact (Subq_ref N).
- assume Hgt: N :e apply_fun f k.
  witness k.
  apply andI.
  + exact HkOmega.
  + claim Htrans: TransSet (apply_fun f k).
    { exact (andEL (TransSet (apply_fun f k)) (forall beta :e apply_fun f k, TransSet beta) HfkOrd). }
    exact (Htrans N Hgt).
Qed.

Theorem Cauchy_with_convergent_subsequence_converges : forall X d seq x:set,
  metric_on X d -> cauchy_sequence X d seq ->
  (exists subseq:set, subsequence_of seq subseq /\ converges_to X (metric_topology X d) subseq x) ->
  converges_to X (metric_topology X d) seq x.
let X d seq x.
assume Hd: metric_on X d.
assume Hc: cauchy_sequence X d seq.
assume Hex: exists subseq:set, subsequence_of seq subseq /\ converges_to X (metric_topology X d) subseq x.
claim Hc12: metric_on X d /\ sequence_on seq X.
{ exact (andEL (metric_on X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               Hc). }
claim Hseq: sequence_on seq X.
{ exact (andER (metric_on X d) (sequence_on seq X) Hc12). }
claim Hcauch: forall eps:set, eps :e R /\ Rlt 0 eps ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.
{ exact (andER (metric_on X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               Hc). }
apply Hex.
let subseq. assume Hpair.
claim Hsub: subsequence_of seq subseq.
{ exact (andEL (subsequence_of seq subseq)
               (converges_to X (metric_topology X d) subseq x)
               Hpair). }
claim Hconv: converges_to X (metric_topology X d) subseq x.
{ exact (andER (subsequence_of seq subseq)
               (converges_to X (metric_topology X d) subseq x)
               Hpair). }
claim HxX: x :e X.
{ exact (converges_to_point_in_X X (metric_topology X d) subseq x Hconv). }
prove topology_on X (metric_topology X d) /\ sequence_on seq X /\ x :e X /\
  forall U:set, U :e metric_topology X d -> x :e U ->
    exists N:set, N :e omega /\
      forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
apply and4I.
- exact (metric_topology_is_topology X d Hd).
- exact Hseq.
- exact HxX.
- let U. assume HU: U :e metric_topology X d.
  assume HxU: x :e U.
  set B := famunion X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r}).
  claim HTdef: metric_topology X d = generated_topology X B.
  { reflexivity. }
  claim HUgen: U :e generated_topology X B.
  { rewrite <- HTdef.
    exact HU. }
  claim HUlcl: forall y :e U, exists b :e B, y :e b /\ b c= U.
  { exact (SepE2 (Power X)
                (fun U0:set => forall y0 :e U0, exists b0 :e B, y0 :e b0 /\ b0 c= U0)
                U
                HUgen). }
  claim Hexb: exists b :e B, x :e b /\ b c= U.
  { exact (HUlcl x HxU). }
  apply Hexb.
  let b. assume Hbpack.
  claim HbB: b :e B.
  { exact (andEL (b :e B) (x :e b /\ b c= U) Hbpack). }
  claim Hbrest: x :e b /\ b c= U.
  { exact (andER (b :e B) (x :e b /\ b c= U) Hbpack). }
  claim Hxb: x :e b.
  { exact (andEL (x :e b) (b c= U) Hbrest). }
  claim HbsubU: b c= U.
  { exact (andER (x :e b) (b c= U) Hbrest). }
  apply (famunionE_impred X (fun c0:set => {open_ball X d c0 r|r :e R, Rlt 0 r}) b HbB
        (exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)).
  let c. assume HcX: c :e X.
  assume HbIn: b :e {open_ball X d c r|r :e R, Rlt 0 r}.
  apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0) b HbIn
        (exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U)).
  let r. assume HrR: r :e R.
  assume Hrpos: Rlt 0 r.
  assume Hbeq: b = open_ball X d c r.
  claim Hxball: x :e open_ball X d c r.
  { rewrite <- Hbeq.
    exact Hxb. }
  claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r.
  { exact (open_ball_refine_center X d c x r Hd HcX HxX HrR Hrpos Hxball). }
  apply Hexs.
  let s. assume Hspack.
  claim Hs12: s :e R /\ Rlt 0 s.
  { exact (andEL (s :e R /\ Rlt 0 s)
                 (open_ball X d x s c= open_ball X d c r)
                 Hspack). }
  claim HsR: s :e R.
  { exact (andEL (s :e R) (Rlt 0 s) Hs12). }
  claim Hspos: Rlt 0 s.
  { exact (andER (s :e R) (Rlt 0 s) Hs12). }
  claim Hsub_ball: open_ball X d x s c= open_ball X d c r.
  { exact (andER (s :e R /\ Rlt 0 s)
                 (open_ball X d x s c= open_ball X d c r)
                 Hspack). }
  claim HsubU: open_ball X d x s c= U.
  { claim HballsubU: open_ball X d c r c= U.
    { rewrite <- Hbeq.
      exact HbsubU. }
    exact (Subq_tra (open_ball X d x s) (open_ball X d c r) U Hsub_ball HballsubU). }
  claim Hexeps1: exists eps1:set, eps1 :e R /\ Rlt 0 eps1 /\ Rlt (add_SNo eps1 eps1) s.
  { exact (exists_twofold_small_eps s HsR Hspos). }
  apply Hexeps1.
  let eps1. assume Heps1pack.
  claim Heps1left: eps1 :e R /\ Rlt 0 eps1.
  { exact (andEL (eps1 :e R /\ Rlt 0 eps1)
                 (Rlt (add_SNo eps1 eps1) s)
                 Heps1pack). }
  claim Heps1R: eps1 :e R.
  { exact (andEL (eps1 :e R) (Rlt 0 eps1) Heps1left). }
  claim Heps1pos: Rlt 0 eps1.
  { exact (andER (eps1 :e R) (Rlt 0 eps1) Heps1left). }
  claim Heps2lt: Rlt (add_SNo eps1 eps1) s.
  { exact (andER (eps1 :e R /\ Rlt 0 eps1)
                 (Rlt (add_SNo eps1 eps1) s)
                 Heps1pack). }
  claim HexN1: exists N1:set, N1 :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N1 c= m -> N1 c= n ->
      Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1.
  { exact (Hcauch eps1 (andI (eps1 :e R) (Rlt 0 eps1) Heps1R Heps1pos)). }
  apply HexN1.
  let N1. assume HN1pack.
  claim HN1omega: N1 :e omega.
  { exact (andEL (N1 :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N1 c= m -> N1 c= n ->
                   Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1)
                 HN1pack). }
  claim HN1prop: forall m n:set, m :e omega -> n :e omega -> N1 c= m -> N1 c= n ->
    Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1.
  { exact (andER (N1 :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N1 c= m -> N1 c= n ->
                   Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1)
                 HN1pack). }
  apply Hsub.
  let f. assume Hfpack.
  claim Hfpre: (((total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega) /\ omega_strictly_increasing f).
  { exact (andEL (((total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega) /\ omega_strictly_increasing f)
                 (subseq = compose_fun omega f seq)
                 Hfpack). }
  claim Hsubeq: subseq = compose_fun omega f seq.
  { exact (andER (((total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega) /\ omega_strictly_increasing f)
                 (subseq = compose_fun omega f seq)
                 Hfpack). }
  claim Hfcore: (total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega.
  { exact (andEL ((total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega)
                 (omega_strictly_increasing f)
                 Hfpre). }
  claim Hfinc: omega_strictly_increasing f.
  { exact (andER ((total_function_on f omega omega /\ functional_graph f) /\ graph_domain_subset f omega)
                 (omega_strictly_increasing f)
                 Hfpre). }
  claim Hftotpair: total_function_on f omega omega /\ functional_graph f.
  { exact (andEL (total_function_on f omega omega /\ functional_graph f)
                 (graph_domain_subset f omega)
                 Hfcore). }
  claim Hfdom: graph_domain_subset f omega.
  { exact (andER (total_function_on f omega omega /\ functional_graph f)
                 (graph_domain_subset f omega)
                 Hfcore). }
  claim Hftot: total_function_on f omega omega.
  { exact (andEL (total_function_on f omega omega) (functional_graph f) Hftotpair). }
  claim Hffg: functional_graph f.
  { exact (andER (total_function_on f omega omega) (functional_graph f) Hftotpair). }
  claim HfFun: function_on f omega omega.
  { exact (total_function_on_function_on f omega omega Hftot). }
  claim Hexk1: exists k1:set, k1 :e omega /\ N1 c= apply_fun f k1.
  { exact (omega_strictly_increasing_unbounded f N1 Hftot Hffg Hfdom Hfinc HN1omega). }
  apply Hexk1.
  let k1. assume Hk1pack.
  claim Hk1omega: k1 :e omega.
  { exact (andEL (k1 :e omega) (N1 c= apply_fun f k1) Hk1pack). }
  claim HN1subfk1: N1 c= apply_fun f k1.
  { exact (andER (k1 :e omega) (N1 c= apply_fun f k1) Hk1pack). }
  claim HballInB: open_ball X d x eps1 :e {open_ball X d x r|r :e R, Rlt 0 r}.
  { exact (ReplSepI R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d x r0) eps1 Heps1R Heps1pos). }
  claim HballInFam: open_ball X d x eps1 :e B.
  { exact (famunionI X (fun c0:set => {open_ball X d c0 r|r :e R, Rlt 0 r}) x (open_ball X d x eps1) HxX HballInB). }
  claim HBasis: basis_on X B.
  { exact (open_balls_form_basis X d Hd). }
  claim HballOpen: open_ball X d x eps1 :e metric_topology X d.
  { rewrite HTdef.
    exact (generated_topology_contains_basis X B HBasis (open_ball X d x eps1) HballInFam). }
  claim HxInBall: x :e open_ball X d x eps1.
  { exact (center_in_open_ball X d x eps1 Hd HxX Heps1pos). }
  claim HexN2: exists N2:set, N2 :e omega /\
    forall n:set, n :e omega -> N2 c= n -> apply_fun subseq n :e open_ball X d x eps1.
  { exact (converges_to_neighborhoods X (metric_topology X d) subseq x Hconv
            (open_ball X d x eps1) HballOpen HxInBall). }
  apply HexN2.
  let N2. assume HN2pack.
  claim HN2omega: N2 :e omega.
  { exact (andEL (N2 :e omega)
                 (forall n:set, n :e omega -> N2 c= n -> apply_fun subseq n :e open_ball X d x eps1)
                 HN2pack). }
  claim HN2prop: forall n:set, n :e omega -> N2 c= n -> apply_fun subseq n :e open_ball X d x eps1.
  { exact (andER (N2 :e omega)
                 (forall n:set, n :e omega -> N2 c= n -> apply_fun subseq n :e open_ball X d x eps1)
                 HN2pack). }
  claim Hk1ord: ordinal k1.
  { exact (ordinal_Hered omega omega_ordinal k1 Hk1omega). }
  claim HN2ord: ordinal N2.
  { exact (ordinal_Hered omega omega_ordinal N2 HN2omega). }
  claim Hcase: k1 :e N2 \/ N2 c= k1.
  { exact (ordinal_In_Or_Subq k1 N2 Hk1ord HN2ord). }
  apply Hcase.
  - assume Hk1lt: k1 :e N2.
    set k := N2.
    claim Hkomega: k :e omega.
    { exact HN2omega. }
    claim HNk: N2 c= k.
    { exact (Subq_ref N2). }
    claim HfkOmega: apply_fun f k :e omega.
    { exact (HfFun k Hkomega). }
    claim HfkOrd: ordinal (apply_fun f k).
    { exact (ordinal_Hered omega omega_ordinal (apply_fun f k) HfkOmega). }
    claim Hfk1In: apply_fun f k1 :e apply_fun f k.
    { exact (Hfinc k1 k Hk1omega Hkomega Hk1lt). }
    claim Htrans_fk: TransSet (apply_fun f k).
    { exact (andEL (TransSet (apply_fun f k)) (forall beta :e apply_fun f k, TransSet beta) HfkOrd). }
    claim Hsub_fk1_fk: apply_fun f k1 c= apply_fun f k.
    { exact (Htrans_fk (apply_fun f k1) Hfk1In). }
    claim HN1subfk: N1 c= apply_fun f k.
    { exact (Subq_tra N1 (apply_fun f k1) (apply_fun f k) HN1subfk1 Hsub_fk1_fk). }
    claim Hsubseqk: apply_fun subseq k :e open_ball X d x eps1.
    { exact (HN2prop k Hkomega HNk). }
    witness N1.
    apply andI.
    * exact HN1omega.
    * let n. assume HnO: n :e omega. assume HNn: N1 c= n.
      prove apply_fun seq n :e U.
      claim Happ: apply_fun subseq k = apply_fun seq (apply_fun f k).
      { rewrite Hsubeq.
        exact (compose_fun_apply omega f seq k Hkomega). }
      claim HfkO: apply_fun f k :e omega.
      { exact (HfFun k Hkomega). }
      claim HseqfkX: apply_fun seq (apply_fun f k) :e X.
      { exact (Hseq (apply_fun f k) HfkO). }
      claim Hdx1: Rlt (apply_fun d (x, apply_fun seq (apply_fun f k))) eps1.
      { rewrite <- Happ.
        exact (open_ballE2 X d x eps1 (apply_fun subseq k) Hsubseqk). }
      claim Hsym: apply_fun d (x, apply_fun seq (apply_fun f k)) = apply_fun d (apply_fun seq (apply_fun f k), x).
      { exact (metric_on_symmetric X d x (apply_fun seq (apply_fun f k)) Hd HxX HseqfkX). }
      claim Hdx: Rlt (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1.
      { rewrite <- Hsym.
        exact Hdx1. }
      claim Hdnfk: Rlt (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1.
      { exact (HN1prop n (apply_fun f k) HnO HfkO HNn HN1subfk). }
      claim HseqnX: apply_fun seq n :e X.
      { exact (Hseq n HnO). }
      claim Htri: Rle (apply_fun d (apply_fun seq n, x))
                      (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                              (apply_fun d (apply_fun seq (apply_fun f k), x))).
      { exact (metric_triangle_Rle X d (apply_fun seq n) (apply_fun seq (apply_fun f k)) x Hd HseqnX HseqfkX HxX). }
      claim Hdfun: function_on d (setprod X X) R.
      { exact (metric_on_function_on X d Hd). }
      claim Hd1R: apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)) :e R.
      { exact (Hdfun (apply_fun seq n, apply_fun seq (apply_fun f k))
               (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq n) (apply_fun seq (apply_fun f k)) HseqnX HseqfkX)). }
      claim Hd2R: apply_fun d (apply_fun seq (apply_fun f k), x) :e R.
      { exact (Hdfun (apply_fun seq (apply_fun f k), x)
               (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq (apply_fun f k)) x HseqfkX HxX)). }
      claim Hd1le: Rle (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1.
      { exact (Rlt_implies_Rle (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1 Hdnfk). }
      claim Hd2le: Rle (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1.
      { exact (Rlt_implies_Rle (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1 Hdx). }
      claim HstepA: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                 (apply_fun d (apply_fun seq (apply_fun f k), x)))
                         (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1).
      { exact (Rle_add_SNo_2 (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                             (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1
                             Hd1R Hd2R Heps1R Hd2le). }
      claim HstepB: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1)
                         (add_SNo eps1 eps1).
      { claim Hd1S: SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))).
        { exact (real_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) Hd1R). }
        claim Heps1S: SNo eps1.
        { exact (real_SNo eps1 Heps1R). }
        rewrite (add_SNo_com (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1 Hd1S Heps1S).
        exact (Rle_add_SNo_2 eps1 (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1
                             Heps1R Hd1R Heps1R Hd1le). }
      claim HsumLe: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                 (apply_fun d (apply_fun seq (apply_fun f k), x)))
                         (add_SNo eps1 eps1).
      { exact (Rle_tra
                (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                        (apply_fun d (apply_fun seq (apply_fun f k), x)))
                (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1)
                (add_SNo eps1 eps1)
                HstepA HstepB). }
      claim HsumLtS: Rlt (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                  (apply_fun d (apply_fun seq (apply_fun f k), x))) s.
      { exact (Rle_Rlt_tra (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                   (apply_fun d (apply_fun seq (apply_fun f k), x)))
                           (add_SNo eps1 eps1) s HsumLe Heps2lt). }
      claim HdnxLt: Rlt (apply_fun d (apply_fun seq n, x)) s.
      { exact (Rle_Rlt_tra (apply_fun d (apply_fun seq n, x))
                           (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                   (apply_fun d (apply_fun seq (apply_fun f k), x)))
                           s Htri HsumLtS). }
      claim HdxnLt: Rlt (apply_fun d (x, apply_fun seq n)) s.
      { rewrite (metric_on_symmetric X d x (apply_fun seq n) Hd HxX HseqnX).
        exact HdnxLt. }
      claim HseqnBall: apply_fun seq n :e open_ball X d x s.
      { exact (open_ballI X d x s (apply_fun seq n) HseqnX HdxnLt). }
      exact (HsubU (apply_fun seq n) HseqnBall).
  - assume HN2sub: N2 c= k1.
    set k := k1.
    claim Hkomega: k :e omega.
    { exact Hk1omega. }
    claim HNk: N2 c= k.
    { exact HN2sub. }
    claim HN1subfk: N1 c= apply_fun f k.
    { exact HN1subfk1. }
    claim Hsubseqk: apply_fun subseq k :e open_ball X d x eps1.
    { exact (HN2prop k Hkomega HNk). }
    witness N1.
    apply andI.
    * exact HN1omega.
    * let n. assume HnO: n :e omega. assume HNn: N1 c= n.
      prove apply_fun seq n :e U.
      claim Happ: apply_fun subseq k = apply_fun seq (apply_fun f k).
      { rewrite Hsubeq.
        exact (compose_fun_apply omega f seq k Hkomega). }
      claim HfkO: apply_fun f k :e omega.
      { exact (HfFun k Hkomega). }
      claim HseqfkX: apply_fun seq (apply_fun f k) :e X.
      { exact (Hseq (apply_fun f k) HfkO). }
      claim Hdx1: Rlt (apply_fun d (x, apply_fun seq (apply_fun f k))) eps1.
      { rewrite <- Happ.
        exact (open_ballE2 X d x eps1 (apply_fun subseq k) Hsubseqk). }
      claim Hsym: apply_fun d (x, apply_fun seq (apply_fun f k)) = apply_fun d (apply_fun seq (apply_fun f k), x).
      { exact (metric_on_symmetric X d x (apply_fun seq (apply_fun f k)) Hd HxX HseqfkX). }
      claim Hdx: Rlt (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1.
      { rewrite <- Hsym.
        exact Hdx1. }
      claim Hdnfk: Rlt (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1.
      { exact (HN1prop n (apply_fun f k) HnO HfkO HNn HN1subfk). }
      claim HseqnX: apply_fun seq n :e X.
      { exact (Hseq n HnO). }
      claim Htri: Rle (apply_fun d (apply_fun seq n, x))
                      (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                              (apply_fun d (apply_fun seq (apply_fun f k), x))).
      { exact (metric_triangle_Rle X d (apply_fun seq n) (apply_fun seq (apply_fun f k)) x Hd HseqnX HseqfkX HxX). }
      claim Hdfun: function_on d (setprod X X) R.
      { exact (metric_on_function_on X d Hd). }
      claim Hd1R: apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)) :e R.
      { exact (Hdfun (apply_fun seq n, apply_fun seq (apply_fun f k))
               (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq n) (apply_fun seq (apply_fun f k)) HseqnX HseqfkX)). }
      claim Hd2R: apply_fun d (apply_fun seq (apply_fun f k), x) :e R.
      { exact (Hdfun (apply_fun seq (apply_fun f k), x)
               (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq (apply_fun f k)) x HseqfkX HxX)). }
      claim Hd1le: Rle (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1.
      { exact (Rlt_implies_Rle (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1 Hdnfk). }
      claim Hd2le: Rle (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1.
      { exact (Rlt_implies_Rle (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1 Hdx). }
      claim HstepA: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                 (apply_fun d (apply_fun seq (apply_fun f k), x)))
                         (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1).
      { exact (Rle_add_SNo_2 (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                             (apply_fun d (apply_fun seq (apply_fun f k), x)) eps1
                             Hd1R Hd2R Heps1R Hd2le). }
      claim HstepB: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1)
                         (add_SNo eps1 eps1).
      { claim Hd1S: SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))).
        { exact (real_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) Hd1R). }
        claim Heps1S: SNo eps1.
        { exact (real_SNo eps1 Heps1R). }
        rewrite (add_SNo_com (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1 Hd1S Heps1S).
        exact (Rle_add_SNo_2 eps1 (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1
                             Heps1R Hd1R Heps1R Hd1le). }
      claim HsumLe: Rle (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                 (apply_fun d (apply_fun seq (apply_fun f k), x)))
                         (add_SNo eps1 eps1).
      { exact (Rle_tra
                (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                        (apply_fun d (apply_fun seq (apply_fun f k), x)))
                (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k))) eps1)
                (add_SNo eps1 eps1)
                HstepA HstepB). }
      claim HsumLtS: Rlt (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                  (apply_fun d (apply_fun seq (apply_fun f k), x))) s.
      { exact (Rle_Rlt_tra (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                   (apply_fun d (apply_fun seq (apply_fun f k), x)))
                           (add_SNo eps1 eps1) s HsumLe Heps2lt). }
      claim HdnxLt: Rlt (apply_fun d (apply_fun seq n, x)) s.
      { exact (Rle_Rlt_tra (apply_fun d (apply_fun seq n, x))
                           (add_SNo (apply_fun d (apply_fun seq n, apply_fun seq (apply_fun f k)))
                                   (apply_fun d (apply_fun seq (apply_fun f k), x)))
                           s Htri HsumLtS). }
      claim HdxnLt: Rlt (apply_fun d (x, apply_fun seq n)) s.
      { rewrite (metric_on_symmetric X d x (apply_fun seq n) Hd HxX HseqnX).
        exact HdnxLt. }
      claim HseqnBall: apply_fun seq n :e open_ball X d x s.
      { exact (open_ballI X d x s (apply_fun seq n) HseqnX HdxnLt). }
      exact (HsubU (apply_fun seq n) HseqnBall).
Qed.

(** from §43 Theorem 43.2: Euclidean space is complete **) 
(** LATEX VERSION: Euclidean spaces are complete metric spaces. **)
Theorem Euclidean_space_complete : forall k :e omega,
  complete_metric_space (euclidean_space k) (euclidean_metric k).
let k.
assume HkO: k :e omega.
prove complete_metric_space (euclidean_space k) (euclidean_metric k).
prove metric_on (euclidean_space k) (euclidean_metric k) /\
  forall seq:set, sequence_on seq (euclidean_space k) -> cauchy_sequence (euclidean_space k) (euclidean_metric k) seq ->
    exists x:set, converges_to (euclidean_space k) (metric_topology (euclidean_space k) (euclidean_metric k)) seq x.
apply andI.
- exact (euclidean_metric_is_metric_on k HkO).
- let seq.
  assume Hseq: sequence_on seq (euclidean_space k).
  assume Hc: cauchy_sequence (euclidean_space k) (euclidean_metric k) seq.
  set extseq := graph omega (fun n:set => euclidean_space_extend_to_Romega k (apply_fun seq n)).
  claim Hextseq_on: sequence_on extseq R_omega_space.
  { let n. assume HnO: n :e omega.
    prove apply_fun extseq n :e R_omega_space.
    claim Hseqn: apply_fun seq n :e euclidean_space k.
    { exact (Hseq n HnO). }
    rewrite (apply_fun_graph omega (fun m:set => euclidean_space_extend_to_Romega k (apply_fun seq m)) n HnO).
    exact (euclidean_space_extend_to_Romega_in_Romega_space k (apply_fun seq n) Hseqn). }
  claim HmD: metric_on R_omega_space Romega_D_metric.
  { exact (andEL (metric_on R_omega_space Romega_D_metric)
                 (Romega_D_metric_topology = R_omega_product_topology)
                 Romega_D_metric_induces_product_topology). }
  claim Hcauch: forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n)) eps.
  { exact (andER (metric_on (euclidean_space k) (euclidean_metric k) /\ sequence_on seq (euclidean_space k))
                 (forall eps:set, eps :e R /\ Rlt 0 eps ->
                   exists N:set, N :e omega /\
                     forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                       Rlt (apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n)) eps)
                 Hc). }
  claim Hextseq_cauchy: cauchy_sequence R_omega_space Romega_D_metric extseq.
  { prove metric_on R_omega_space Romega_D_metric /\ sequence_on extseq R_omega_space /\
      forall eps:set, eps :e R /\ Rlt 0 eps ->
        exists N:set, N :e omega /\
          forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
            Rlt (apply_fun Romega_D_metric (apply_fun extseq m, apply_fun extseq n)) eps.
    apply andI.
    - apply andI.
      + exact HmD.
      + exact Hextseq_on.
    - let eps.
      assume Heps: eps :e R /\ Rlt 0 eps.
      claim HexN: exists N:set, N :e omega /\
        forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
          Rlt (apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n)) eps.
      { exact (Hcauch eps Heps). }
      apply HexN.
      let N. assume HNpack.
      witness N.
      apply andI.
      + exact (andEL (N :e omega)
                     (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                       Rlt (apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n)) eps)
                     HNpack).
      + let m n.
        assume HmO: m :e omega.
        assume HnO: n :e omega.
        assume HNm: N c= m.
        assume HNn: N c= n.
        claim Hlt: Rlt (apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n)) eps.
        { exact (andER (N :e omega)
                       (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                         Rlt (apply_fun (euclidean_metric k) (apply_fun seq m0, apply_fun seq n0)) eps)
                       HNpack
                       m n HmO HnO HNm HNn). }
        claim Hseqm: apply_fun seq m :e euclidean_space k.
        { exact (Hseq m HmO). }
        claim Hseqn: apply_fun seq n :e euclidean_space k.
        { exact (Hseq n HnO). }
        claim Hextm: apply_fun extseq m = euclidean_space_extend_to_Romega k (apply_fun seq m).
        { rewrite (apply_fun_graph omega (fun t:set => euclidean_space_extend_to_Romega k (apply_fun seq t)) m HmO).
          reflexivity. }
        claim Hextn: apply_fun extseq n = euclidean_space_extend_to_Romega k (apply_fun seq n).
        { rewrite (apply_fun_graph omega (fun t:set => euclidean_space_extend_to_Romega k (apply_fun seq t)) n HnO).
          reflexivity. }
        claim HmR: apply_fun extseq m :e R_omega_space.
        { exact (Hextseq_on m HmO). }
        claim HnR: apply_fun extseq n :e R_omega_space.
        { exact (Hextseq_on n HnO). }
        claim Hpair: (apply_fun extseq m, apply_fun extseq n) :e setprod R_omega_space R_omega_space.
        { exact (tuple_2_setprod_by_pair_Sigma R_omega_space R_omega_space
                (apply_fun extseq m) (apply_fun extseq n) HmR HnR). }
        claim HappD: apply_fun Romega_D_metric (apply_fun extseq m, apply_fun extseq n) =
          Romega_D_metric_value (apply_fun extseq m) (apply_fun extseq n).
        { rewrite (apply_fun_graph (setprod R_omega_space R_omega_space)
                  (fun p:set => Romega_D_metric_value (p 0) (p 1))
                  (apply_fun extseq m, apply_fun extseq n) Hpair).
          rewrite (tuple_2_0_eq (apply_fun extseq m) (apply_fun extseq n)).
          rewrite (tuple_2_1_eq (apply_fun extseq m) (apply_fun extseq n)).
          reflexivity. }
        claim Hdk: apply_fun (euclidean_metric k) (apply_fun seq m, apply_fun seq n) =
          Romega_D_metric_value (euclidean_space_extend_to_Romega k (apply_fun seq m))
                               (euclidean_space_extend_to_Romega k (apply_fun seq n)).
        { exact (euclidean_metric_apply k (apply_fun seq m) (apply_fun seq n) Hseqm Hseqn). }
        rewrite HappD.
        rewrite Hextm.
        rewrite Hextn.
        rewrite <- Hdk.
        exact Hlt. }
  claim Hexx: exists x:set, converges_to R_omega_space (metric_topology R_omega_space Romega_D_metric) extseq x.
  { (** TODO: use completeness of R_omega_space with the D metric (proved later as product_Romega_complete) **)
    admit. (** FAIL **)
  }
  apply Hexx.
  let x. assume Hxconv: converges_to R_omega_space (metric_topology R_omega_space Romega_D_metric) extseq x.
	  claim HxX: x :e R_omega_space.
	  { exact (converges_to_point_in_X R_omega_space (metric_topology R_omega_space Romega_D_metric) extseq x Hxconv). }
	  claim Hexy: exists y:set, y :e euclidean_space k /\ euclidean_space_extend_to_Romega k y = x.
	  { (** Build y by restricting x to coordinates in k, and show x has value 0 outside k by projecting extseq with Romega_coord_map. **)
	    set XiO := const_space_family omega R R_standard_topology.
	    set U0 := space_family_union omega XiO.
	    claim HtopEq0: Romega_D_metric_topology = R_omega_product_topology.
	    { exact (andER (metric_on R_omega_space Romega_D_metric) (Romega_D_metric_topology = R_omega_product_topology)
	                   Romega_D_metric_induces_product_topology). }
	    claim HtopDef0: Romega_D_metric_topology = metric_topology R_omega_space Romega_D_metric.
	    { reflexivity. }
	    claim HMTprod: metric_topology R_omega_space Romega_D_metric = R_omega_product_topology.
	    { rewrite <- HtopDef0 at 1.
	      exact HtopEq0. }
		    claim HconvProd: converges_to R_omega_space R_omega_product_topology extseq x.
		    { prove converges_to R_omega_space R_omega_product_topology extseq x.
		      rewrite <- HMTprod.
		      exact Hxconv. }
		    claim HxPR: x :e power_real omega.
		    { prove x :e power_real omega.
		      rewrite (power_real_omega_eq_Romega_space).
		      exact HxX. }
		    claim HxProp: total_function_on x omega U0 /\ functional_graph x /\
		                  forall j:set, j :e omega -> apply_fun x j :e space_family_set XiO j.
		    { exact (SepE2 (Power (setprod omega U0))
		                   (fun f0:set => total_function_on f0 omega U0 /\ functional_graph f0 /\
		                     forall j:set, j :e omega -> apply_fun f0 j :e space_family_set XiO j)
		                   x
		                   HxPR). }
		    claim HxAB: total_function_on x omega U0 /\ functional_graph x.
		    { exact (andEL (total_function_on x omega U0 /\ functional_graph x)
		                   (forall j:set, j :e omega -> apply_fun x j :e space_family_set XiO j)
		                   HxProp). }
		    claim HxTot: total_function_on x omega U0.
		    { exact (andEL (total_function_on x omega U0) (functional_graph x) HxAB). }
		    claim HxFG: functional_graph x.
		    { exact (andER (total_function_on x omega U0) (functional_graph x) HxAB). }
		    claim HxCoordSF: forall j:set, j :e omega -> apply_fun x j :e space_family_set XiO j.
		    { exact (andER (total_function_on x omega U0 /\ functional_graph x)
		                   (forall j:set, j :e omega -> apply_fun x j :e space_family_set XiO j)
		                   HxProp). }
		    claim HxcoordR: forall j:set, j :e omega -> apply_fun x j :e R.
		    { let j. assume HjO: j :e omega.
		      prove apply_fun x j :e R.
		      rewrite <- (space_family_set_const_Romega j HjO).
		      exact (HxCoordSF j HjO). }
	    claim HxOut0: forall i:set, i :e omega -> ~(i :e k) -> apply_fun x i = 0.
	    { let i. assume HiO: i :e omega. assume Hnin: ~(i :e k).
	      set pi := Romega_coord_map i.
	      claim Hcont: continuous_map R_omega_space R_omega_product_topology R R_standard_topology pi.
	      { exact (Romega_coord_map_continuous_in_Romega_product i HiO). }
	      claim HtopX: topology_on R_omega_space R_omega_product_topology.
	      { exact Romega_product_topology_is_topology. }
	      claim HtopR: topology_on R R_standard_topology.
	      { exact R_standard_topology_is_topology. }
	      claim Hseqon: sequence_on extseq R_omega_space.
	      { exact Hextseq_on. }
	      claim Hconvpi: converges_to R R_standard_topology (map_sequence pi extseq) (apply_fun pi x).
	      { exact ((first_countable_sequences_detect_continuity R_omega_space R_omega_product_topology R R_standard_topology pi
	               HtopX HtopR Hcont)
	               x extseq Hseqon HconvProd). }
	      claim Happx: apply_fun pi x = apply_fun x i.
	      { exact (Romega_coord_map_apply i x HiO HxX). }
	      claim Hconv1: converges_to R R_standard_topology (map_sequence pi extseq) (apply_fun x i).
	      { rewrite <- Happx.
	        exact Hconvpi. }
	      claim Hconv0: converges_to R R_standard_topology (map_sequence pi extseq) 0.
	      { (** map_sequence pi extseq is constantly 0 on i outside k **)
	        prove topology_on R R_standard_topology /\ sequence_on (map_sequence pi extseq) R /\ 0 :e R /\
	          forall U:set, U :e R_standard_topology -> 0 :e U ->
	            exists N:set, N :e omega /\
	              forall n:set, n :e omega -> N c= n -> apply_fun (map_sequence pi extseq) n :e U.
	        apply and4I.
	        - exact HtopR.
	        - (** sequence_on **)
	          prove sequence_on (map_sequence pi extseq) R.
	          let n. assume HnO: n :e omega.
	          prove apply_fun (map_sequence pi extseq) n :e R.
	          claim Hseqn: apply_fun extseq n :e R_omega_space.
	          { exact (Hextseq_on n HnO). }
	          claim Happ: apply_fun (map_sequence pi extseq) n = apply_fun pi (apply_fun extseq n).
	          { exact (compose_fun_apply omega extseq pi n HnO). }
	          rewrite Happ.
	          claim HpiFun: function_on pi R_omega_space R.
	          { exact (Romega_coord_map_function_on i HiO). }
	          exact (HpiFun (apply_fun extseq n) Hseqn).
		        - exact real_0.
	        - let U. assume HU: U :e R_standard_topology. assume H0U: 0 :e U.
	          witness 0.
	          apply andI.
	          + exact (nat_p_omega 0 nat_0).
	          + let n. assume HnO: n :e omega. assume H0n: 0 c= n.
	            prove apply_fun (map_sequence pi extseq) n :e U.
	            claim Happ: apply_fun (map_sequence pi extseq) n = apply_fun pi (apply_fun extseq n).
	            { exact (compose_fun_apply omega extseq pi n HnO). }
	            rewrite Happ.
	            claim Hextn: apply_fun extseq n = euclidean_space_extend_to_Romega k (apply_fun seq n).
	            { rewrite (apply_fun_graph omega (fun m:set => euclidean_space_extend_to_Romega k (apply_fun seq m)) n HnO).
	              reflexivity. }
	            rewrite Hextn.
	            claim Hseqn: apply_fun seq n :e euclidean_space k.
	            { exact (Hseq n HnO). }
	            claim HextnX: euclidean_space_extend_to_Romega k (apply_fun seq n) :e R_omega_space.
	            { exact (euclidean_space_extend_to_Romega_in_Romega_space k (apply_fun seq n) Hseqn). }
	            claim HappPi: apply_fun pi (euclidean_space_extend_to_Romega k (apply_fun seq n)) =
	                           apply_fun (euclidean_space_extend_to_Romega k (apply_fun seq n)) i.
	            { exact (Romega_coord_map_apply i (euclidean_space_extend_to_Romega k (apply_fun seq n)) HiO HextnX). }
		            rewrite HappPi.
		            rewrite (euclidean_space_extend_to_Romega_apply k (apply_fun seq n) i HiO).
		            rewrite (If_i_0 (i :e k) (apply_fun (apply_fun seq n) i) 0 Hnin).
		            exact H0U. }
		      apply xm (apply_fun x i = 0).
		      - assume Heq: apply_fun x i = 0.
		        exact Heq.
		      - assume Hneq: ~(apply_fun x i = 0).
		        apply FalseE.
	        apply (Hausdorff_unique_limits R R_standard_topology (map_sequence pi extseq) (apply_fun x i) 0
	               R_standard_topology_Hausdorff
	               (converges_to_point_in_X R R_standard_topology (map_sequence pi extseq) (apply_fun x i) Hconv1)
	               real_0
	               Hneq
	               (converges_to_sequence_on R R_standard_topology (map_sequence pi extseq) (apply_fun x i) Hconv1)
	               (converges_to_neighborhoods R R_standard_topology (map_sequence pi extseq) (apply_fun x i) Hconv1)
	               (converges_to_neighborhoods R R_standard_topology (map_sequence pi extseq) 0 Hconv0)). }
		    set y := graph k (fun j:set => apply_fun x j).
		    witness y.
	    apply andI.
	    - (** y in euclidean_space k **)
	      set XiK := const_space_family k R R_standard_topology.
	      set UK := space_family_union k XiK.
	      prove y :e product_space k XiK.
	      prove y :e {f :e Power (setprod k UK)|
	             total_function_on f k UK /\ functional_graph f /\
	             forall i:set, i :e k -> apply_fun f i :e space_family_set XiK i}.
	      apply SepI.
	      + (** y :e Power (setprod k UK) **)
	        apply PowerI.
	        let p. assume Hp: p :e y.
	        prove p :e setprod k UK.
	        apply (ReplE_impred k (fun j:set => (j, apply_fun x j)) p Hp (p :e setprod k UK)).
	        let j. assume Hj: j :e k.
	        assume Hpeq: p = (j, apply_fun x j).
	        claim HjO: j :e omega.
	        { claim Hsub: k c= omega.
	          { exact (omega_TransSet k HkO). }
	          exact (Hsub j Hj). }
	        claim HxjR: apply_fun x j :e R.
	        { exact (HxcoordR j HjO). }
	        claim Hset: space_family_set XiK j = R.
	        { rewrite (product_component_def XiK j) at 1.
	          claim HXi: apply_fun XiK j = (R, R_standard_topology).
	          { exact (const_space_family_apply k R R_standard_topology j Hj). }
	          rewrite HXi.
	          exact (tuple_2_0_eq R R_standard_topology). }
	        claim HxjU: apply_fun x j :e UK.
	        { (** show xj in the union by choosing the j-th component **)
	          set S := {space_family_set XiK i|i :e k}.
	          claim HUdef: UK = Union S.
	          { reflexivity. }
		          rewrite HUdef.
		          claim HSj: space_family_set XiK j :e S.
		          { exact (ReplI k (fun i:set => space_family_set XiK i) j Hj). }
		          claim HxjSF: apply_fun x j :e space_family_set XiK j.
		          { prove apply_fun x j :e space_family_set XiK j.
		            rewrite Hset.
		            exact HxjR. }
		          exact (UnionI S (apply_fun x j) (space_family_set XiK j) HxjSF HSj). }
	        rewrite Hpeq.
	        exact (tuple_2_setprod_by_pair_Sigma k UK j (apply_fun x j) Hj HxjU).
	      + (** total_function_on, functional_graph, and coordinates **)
	        prove total_function_on y k UK /\ functional_graph y /\
	             forall i:set, i :e k -> apply_fun y i :e space_family_set XiK i.
	        apply andI.
	        * (** total_function_on y k UK /\ functional_graph y **)
	          apply andI.
	          { apply (total_function_on_graph k UK (fun j:set => apply_fun x j)).
	            let j. assume Hj: j :e k.
	            claim HjO: j :e omega.
	            { claim Hsub: k c= omega.
	              { exact (omega_TransSet k HkO). }
	              exact (Hsub j Hj). }
		            claim HxjR: apply_fun x j :e R.
		            { exact (HxcoordR j HjO). }
		            set S := {space_family_set XiK i|i :e k}.
		            claim HUdef: UK = Union S.
		            { reflexivity. }
		            rewrite HUdef.
		            claim HSj: space_family_set XiK j :e S.
		            { exact (ReplI k (fun i:set => space_family_set XiK i) j Hj). }
		            claim Hset: space_family_set XiK j = R.
		            { claim Hsf: space_family_set XiK j = (apply_fun XiK j) 0.
		              { reflexivity. }
		              rewrite Hsf at 1.
		              rewrite (const_space_family_apply k R R_standard_topology j Hj).
		              exact (tuple_2_0_eq R R_standard_topology). }
		            claim HxjSF: apply_fun x j :e space_family_set XiK j.
		            { prove apply_fun x j :e space_family_set XiK j.
		              rewrite Hset.
		              exact HxjR. }
		            exact (UnionI S (apply_fun x j) (space_family_set XiK j) HxjSF HSj). }
	          { exact (functional_graph_graph k (fun j:set => apply_fun x j)). }
	        * (** coordinate membership **)
	          let i. assume Hi: i :e k.
	          prove apply_fun y i :e space_family_set XiK i.
	          claim HiO: i :e omega.
	          { claim Hsub: k c= omega.
	            { exact (omega_TransSet k HkO). }
	            exact (Hsub i Hi). }
	          claim Happ: apply_fun y i = apply_fun x i.
	          { rewrite (apply_fun_graph k (fun j:set => apply_fun x j) i Hi).
	            reflexivity. }
	          rewrite Happ.
		          claim HxiR: apply_fun x i :e R.
		          { exact (HxcoordR i HiO). }
		          claim Hset: space_family_set XiK i = R.
		          { claim Hsf: space_family_set XiK i = (apply_fun XiK i) 0.
		            { reflexivity. }
		            rewrite Hsf at 1.
		            rewrite (const_space_family_apply k R R_standard_topology i Hi).
		            exact (tuple_2_0_eq R R_standard_topology). }
		          rewrite Hset.
		          exact HxiR.
	    - (** extension equals x **)
	      prove euclidean_space_extend_to_Romega k y = x.
	      set h := (fun i:set => If_i (i :e k) (apply_fun y i) 0).
	      claim HdefExt: euclidean_space_extend_to_Romega k y = graph omega h.
	      { reflexivity. }
	      rewrite HdefExt.
	      apply set_ext.
	      + let p. assume Hp: p :e graph omega h.
	        prove p :e x.
	        apply (ReplE_impred omega (fun i:set => (i, h i)) p Hp (p :e x)).
	        let i. assume HiO: i :e omega.
	        assume Hpeq: p = (i, h i).
	        claim Hxpair: (i, apply_fun x i) :e x.
		        { exact (total_function_on_apply_fun_in_graph x omega U0 i HxTot HiO). }
		        claim Heqh: h i = apply_fun x i.
		        { apply xm (i :e k).
		          - assume Hik: i :e k.
		            claim Hdefhi: h i = If_i (i :e k) (apply_fun y i) 0.
		            { reflexivity. }
		            rewrite Hdefhi.
		            rewrite (If_i_1 (i :e k) (apply_fun y i) 0 Hik).
		            rewrite (apply_fun_graph k (fun j:set => apply_fun x j) i Hik).
		            reflexivity.
		          - assume Hnik: ~(i :e k).
		            claim Hdefhi: h i = If_i (i :e k) (apply_fun y i) 0.
		            { reflexivity. }
		            rewrite Hdefhi.
		            rewrite (If_i_0 (i :e k) (apply_fun y i) 0 Hnik).
		            rewrite (HxOut0 i HiO Hnik).
		            reflexivity. }
	        rewrite Hpeq.
	        rewrite Heqh.
	        exact Hxpair.
		      + let p. assume Hp: p :e x.
		        prove p :e graph omega h.
		        claim HxPow: x :e Power (setprod omega U0).
		        { exact (SepE1 (Power (setprod omega U0))
		                       (fun f0:set => total_function_on f0 omega U0 /\ functional_graph f0 /\
		                         forall j:set, j :e omega -> apply_fun f0 j :e space_family_set XiO j)
		                       x
		                       HxPR). }
		        claim HxSub: x c= setprod omega U0.
		        { exact (PowerE (setprod omega U0) x HxPow). }
	        claim HpProd: p :e setprod omega U0.
	        { exact (HxSub p Hp). }
		        claim HiO: (p 0) :e omega.
		        { exact (ap0_Sigma omega (fun _ : set => U0) p HpProd). }
			        claim Htupeq: (p 0, p 1) = p.
			        { apply (Sigma_E omega (fun _ : set => U0) p HpProd).
			          let n. assume Hn_pair. apply Hn_pair.
			          assume Hn: n :e omega. assume Hrest.
			          apply Hrest.
			          let y0. assume Hy_pair. apply Hy_pair.
			          assume Hy0: y0 :e U0.
			          assume Hpdef.
			          rewrite Hpdef.
			          rewrite (pair_ap_0 n y0).
			          rewrite (pair_ap_1 n y0).
			          rewrite (tuple_pair n y0).
			          reflexivity. }
		        claim Hpair: (p 0, p 1) :e x.
		        { prove (p 0, p 1) :e x.
		          rewrite Htupeq.
		          exact Hp. }
	        claim Happ: apply_fun x (p 0) = p 1.
	        { exact (functional_graph_apply_fun_eq x (p 0) (p 1) HxFG Hpair). }
	        claim Heqh: h (p 0) = p 1.
	        { rewrite <- Happ.
		          apply xm ((p 0) :e k).
		          - assume Hik: (p 0) :e k.
		            claim Hdefh0: h (p 0) = If_i ((p 0) :e k) (apply_fun y (p 0)) 0.
		            { reflexivity. }
		            rewrite Hdefh0.
		            rewrite (If_i_1 ((p 0) :e k) (apply_fun y (p 0)) 0 Hik).
		            rewrite (apply_fun_graph k (fun j:set => apply_fun x j) (p 0) Hik).
		            reflexivity.
		          - assume Hnik: ~((p 0) :e k).
		            claim Hdefh0: h (p 0) = If_i ((p 0) :e k) (apply_fun y (p 0)) 0.
		            { reflexivity. }
		            rewrite Hdefh0.
		            rewrite (If_i_0 ((p 0) :e k) (apply_fun y (p 0)) 0 Hnik).
		            rewrite (HxOut0 (p 0) HiO Hnik).
		            reflexivity. }
		        rewrite <- Htupeq at 1.
		        rewrite <- Heqh at 1.
		        exact (ReplI omega (fun i:set => (i, h i)) (p 0) HiO).
		  }
	  apply Hexy.
	  let y. assume Hypack.
	  witness y.
  claim HyE: y :e euclidean_space k.
  { exact (andEL (y :e euclidean_space k) (euclidean_space_extend_to_Romega k y = x) Hypack). }
  claim Hyext: euclidean_space_extend_to_Romega k y = x.
  { exact (andER (y :e euclidean_space k) (euclidean_space_extend_to_Romega k y = x) Hypack). }
  claim HmE: metric_on (euclidean_space k) (euclidean_metric k).
  { exact (euclidean_metric_is_metric_on k HkO). }
  claim Hseqconv: sequence_converges_metric (euclidean_space k) (euclidean_metric k) seq y.
  { prove metric_on (euclidean_space k) (euclidean_metric k) /\ sequence_on seq (euclidean_space k) /\ y :e euclidean_space k /\
      forall eps:set, eps :e R /\ Rlt 0 eps ->
        exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n ->
            Rlt (apply_fun (euclidean_metric k) (apply_fun seq n, y)) eps.
    apply and4I.
    - exact HmE.
    - exact Hseq.
    - exact HyE.
    - let eps. assume Heps: eps :e R /\ Rlt 0 eps.
      set X0 := R_omega_space.
      set d0 := Romega_D_metric.
      claim Hm0: metric_on X0 d0.
      { exact HmD. }
      claim HballOpen: open_ball X0 d0 x eps :e metric_topology X0 d0.
      { claim HepsR: eps :e R.
        { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
        claim Hepspos: Rlt 0 eps.
        { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
        exact (open_ball_in_metric_topology X0 d0 x eps Hm0 HxX Hepspos). }
      claim Hcenter: x :e open_ball X0 d0 x eps.
      { claim Hepspos: Rlt 0 eps.
        { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
        exact (center_in_open_ball X0 d0 x eps Hm0 HxX Hepspos). }
      claim HexN: exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n -> apply_fun extseq n :e open_ball X0 d0 x eps.
      { exact (converges_to_neighborhoods X0 (metric_topology X0 d0) extseq x Hxconv
                (open_ball X0 d0 x eps) HballOpen Hcenter). }
      apply HexN.
      let N. assume HNpack.
      witness N.
      apply andI.
      + exact (andEL (N :e omega)
                     (forall n:set, n :e omega -> N c= n -> apply_fun extseq n :e open_ball X0 d0 x eps)
                     HNpack).
      + let n. assume HnO: n :e omega. assume HNn: N c= n.
        claim HextnIn: apply_fun extseq n :e open_ball X0 d0 x eps.
        { exact (andER (N :e omega)
                       (forall n0:set, n0 :e omega -> N c= n0 -> apply_fun extseq n0 :e open_ball X0 d0 x eps)
                       HNpack
                       n HnO HNn). }
        claim HextnX: apply_fun extseq n :e X0.
        { exact (open_ballE1 X0 d0 x eps (apply_fun extseq n) HextnIn). }
        claim Hlt0: Rlt (apply_fun d0 (x, apply_fun extseq n)) eps.
        { exact (open_ballE2 X0 d0 x eps (apply_fun extseq n) HextnIn). }
        claim Hsym0: apply_fun d0 (apply_fun extseq n, x) = apply_fun d0 (x, apply_fun extseq n).
        { exact (metric_on_symmetric X0 d0 (apply_fun extseq n) x Hm0 HextnX HxX). }
        claim Hlt1: Rlt (apply_fun d0 (apply_fun extseq n, x)) eps.
        { rewrite Hsym0.
          exact Hlt0. }
        claim Hseqn: apply_fun seq n :e euclidean_space k.
        { exact (Hseq n HnO). }
        claim HextnEq: apply_fun extseq n = euclidean_space_extend_to_Romega k (apply_fun seq n).
        { rewrite (apply_fun_graph omega (fun t:set => euclidean_space_extend_to_Romega k (apply_fun seq t)) n HnO).
          reflexivity. }
        claim Hpair0: (apply_fun extseq n, x) :e setprod X0 X0.
        { exact (tuple_2_setprod_by_pair_Sigma X0 X0 (apply_fun extseq n) x HextnX HxX). }
        claim Happ0: apply_fun d0 (apply_fun extseq n, x) =
          Romega_D_metric_value (apply_fun extseq n) x.
        { rewrite (apply_fun_graph (setprod X0 X0)
                  (fun p:set => Romega_D_metric_value (p 0) (p 1))
                  (apply_fun extseq n, x) Hpair0).
          rewrite (tuple_2_0_eq (apply_fun extseq n) x).
          rewrite (tuple_2_1_eq (apply_fun extseq n) x).
          reflexivity. }
        claim Hdk: apply_fun (euclidean_metric k) (apply_fun seq n, y) =
          Romega_D_metric_value (euclidean_space_extend_to_Romega k (apply_fun seq n))
                               (euclidean_space_extend_to_Romega k y).
        { exact (euclidean_metric_apply k (apply_fun seq n) y Hseqn HyE). }
        rewrite Hdk.
        rewrite Hyext.
        rewrite <- HextnEq.
        rewrite <- Happ0.
        exact Hlt1.
  }
  claim Htop: converges_to (euclidean_space k) (metric_topology (euclidean_space k) (euclidean_metric k)) seq y.
  { exact (sequence_converges_metric_imp_converges_to_metric_topology
            (euclidean_space k) (euclidean_metric k) seq y Hseqconv). }
  exact Htop.
Qed.

(** from §43 Lemma 43.3: product convergence via projections **) 
(** LATEX VERSION: Convergence in a product metric topology iff coordinatewise convergence. **)
(** Helper: coordinate sequence of a product-valued sequence **)
Definition product_coordinate_sequence : set -> set -> set :=
  fun seq j => graph omega (fun n:set => apply_fun (apply_fun seq n) j).

Theorem product_sequence_convergence_iff_coordinates : forall X J:set,
  X = product_space J (const_space_family J R R_standard_topology) ->
  forall seq x:set,
    sequence_on seq X ->
    x :e X ->
    (converges_to X (product_topology_full J (const_space_family J R R_standard_topology)) seq x <->
     (forall j:set, j :e J ->
       converges_to (product_component (const_space_family J R R_standard_topology) j)
         (product_component_topology (const_space_family J R R_standard_topology) j)
         (product_coordinate_sequence seq j)
         (apply_fun x j))).
let X J.
assume HX: X = product_space J (const_space_family J R R_standard_topology).
set Xi := const_space_family J R R_standard_topology.
let seq x.
assume Hseq: sequence_on seq X.
assume HxX: x :e X.
apply iffI.
- assume Hconv: converges_to X (product_topology_full J Xi) seq x.
  let j. assume Hj: j :e J.
  set Xj := product_component Xi j.
  set Tj := product_component_topology Xi j.
  set seqj := product_coordinate_sequence seq j.
  prove converges_to Xj Tj seqj (apply_fun x j).
  (** unpack the component space and topology for the constant family, to reuse R infrastructure **)
  claim HTj: topology_on Xj Tj.
  { rewrite (product_component_def Xi j).
    rewrite (product_component_topology_def Xi j).
    rewrite (const_space_family_apply J R R_standard_topology j Hj).
    rewrite (tuple_2_0_eq R R_standard_topology).
    rewrite (tuple_2_1_eq R R_standard_topology).
    exact R_standard_topology_is_topology. }
  (** coordinate limit is in the component space **)
  claim Hxprod: x :e product_space J Xi.
  { rewrite <- HX. exact HxX. }
  claim Hxcoord: apply_fun x j :e Xj.
  { rewrite (product_component_def Xi j).
    claim HxProp: total_function_on x J (space_family_union J Xi) /\ functional_graph x /\
                  forall i:set, i :e J -> apply_fun x i :e space_family_set Xi i.
    { exact (SepE2 (Power (setprod J (space_family_union J Xi)))
                   (fun f0:set => total_function_on f0 J (space_family_union J Xi) /\ functional_graph f0 /\
                     forall i:set, i :e J -> apply_fun f0 i :e space_family_set Xi i)
                   x Hxprod). }
    claim HxCoord: forall i:set, i :e J -> apply_fun x i :e space_family_set Xi i.
    { exact (andER (total_function_on x J (space_family_union J Xi) /\ functional_graph x)
                   (forall i:set, i :e J -> apply_fun x i :e space_family_set Xi i)
                   HxProp). }
    exact (HxCoord j Hj). }
  (** coordinate sequence is a sequence in the component space **)
  claim Hseqj: sequence_on seqj Xj.
  { let n. assume HnO: n :e omega.
    prove apply_fun seqj n :e Xj.
    claim HseqnX: apply_fun seq n :e product_space J Xi.
    { rewrite <- HX.
      exact (Hseq n HnO). }
    claim HseqnProp: total_function_on (apply_fun seq n) J (space_family_union J Xi) /\ functional_graph (apply_fun seq n) /\
                     forall i:set, i :e J -> apply_fun (apply_fun seq n) i :e space_family_set Xi i.
    { exact (SepE2 (Power (setprod J (space_family_union J Xi)))
                   (fun f0:set => total_function_on f0 J (space_family_union J Xi) /\ functional_graph f0 /\
                     forall i:set, i :e J -> apply_fun f0 i :e space_family_set Xi i)
                   (apply_fun seq n) HseqnX). }
    claim HseqnCoord: forall i:set, i :e J -> apply_fun (apply_fun seq n) i :e space_family_set Xi i.
    { exact (andER (total_function_on (apply_fun seq n) J (space_family_union J Xi) /\ functional_graph (apply_fun seq n))
                   (forall i:set, i :e J -> apply_fun (apply_fun seq n) i :e space_family_set Xi i)
                   HseqnProp). }
    rewrite (product_component_def Xi j).
    claim Hseqjdef: seqj = graph omega (fun n0:set => apply_fun (apply_fun seq n0) j).
    { reflexivity. }
    rewrite Hseqjdef.
    rewrite (apply_fun_graph omega (fun n0:set => apply_fun (apply_fun seq n0) j) n HnO).
    exact (HseqnCoord j Hj). }
  (** neighborhood condition via cylinder sets in the product topology **)
  prove topology_on Xj Tj /\ sequence_on seqj Xj /\ apply_fun x j :e Xj /\
        forall U:set, U :e Tj -> apply_fun x j :e U ->
          exists N:set, N :e omega /\
            forall n:set, n :e omega -> N c= n -> apply_fun seqj n :e U.
  apply andI.
  - apply andI.
    + apply andI.
      * exact HTj.
      * exact Hseqj.
    + exact Hxcoord.
  - let U. assume HU: U :e Tj.
    assume HxU: apply_fun x j :e U.
    claim HUfam: U :e space_family_topology Xi j.
    { claim HTjEq: Tj = space_family_topology Xi j.
      { reflexivity. }
      rewrite <- HTjEq.
      exact HU. }
    set Cyl := product_cylinder J Xi j U.
    claim HCylDef: Cyl = {f :e product_space J Xi | j :e J /\ U :e space_family_topology Xi j /\ apply_fun f j :e U}.
    { reflexivity. }
    claim HjNe: J <> Empty.
    { assume HJeq: J = Empty.
      claim HjEmpty: j :e Empty.
      { rewrite <- HJeq. exact Hj. }
      prove False.
      exact (EmptyE j HjEmpty False). }
    claim HcompTop: forall i:set, i :e J -> topology_on (space_family_set Xi i) (space_family_topology Xi i).
    { let i. assume Hi: i :e J.
      claim Hseteq: space_family_set Xi i = product_component Xi i.
      { reflexivity. }
      claim Htopeq: space_family_topology Xi i = product_component_topology Xi i.
      { reflexivity. }
      rewrite Hseteq.
      rewrite Htopeq.
      rewrite (product_component_def Xi i).
      rewrite (product_component_topology_def Xi i).
      rewrite (const_space_family_apply J R R_standard_topology i Hi).
      rewrite (tuple_2_0_eq R R_standard_topology).
      rewrite (tuple_2_1_eq R R_standard_topology).
      exact R_standard_topology_is_topology. }
        claim HSsub: subbasis_on (product_space J Xi) (product_subbasis_full J Xi).
        { exact (product_subbasis_full_subbasis_on J Xi HjNe HcompTop). }
        claim HCylS: Cyl :e product_subbasis_full J Xi.
        { claim HCylRepl: Cyl :e {product_cylinder J Xi j V|V :e space_family_topology Xi j}.
          { exact (ReplI (space_family_topology Xi j) (fun V:set => product_cylinder J Xi j V) U HUfam). }
          exact (famunionI J (fun i0:set => {product_cylinder J Xi i0 V|V :e space_family_topology Xi i0})
                           j Cyl Hj HCylRepl). }
        claim HCylOpen: Cyl :e product_topology_full J Xi.
        { exact (subbasis_elem_open_in_generated_from_subbasis (product_space J Xi) (product_subbasis_full J Xi) Cyl HSsub HCylS). }
        claim HxCyl: x :e Cyl.
        { rewrite HCylDef.
          apply (SepI (product_space J Xi)
                      (fun f:set => j :e J /\ U :e space_family_topology Xi j /\ apply_fun f j :e U)
                      x Hxprod
                      (andI (j :e J /\ U :e space_family_topology Xi j) (apply_fun x j :e U)
                            (andI (j :e J) (U :e space_family_topology Xi j) Hj HUfam)
                            HxU)). }
        claim HN: exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e Cyl.
        { exact (converges_to_neighborhoods X (product_topology_full J Xi) seq x Hconv Cyl HCylOpen HxCyl). }
        apply HN.
        let N. assume HNpair.
        witness N.
        apply andI.
        { exact (andEL (N :e omega)
                       (forall n:set, n :e omega -> N c= n -> apply_fun seq n :e Cyl)
                       HNpair). }
        let n. assume HnO: n :e omega.
        assume HNn: N c= n.
        prove apply_fun seqj n :e U.
        claim HseqnCyl: apply_fun seq n :e Cyl.
        { exact (andER (N :e omega)
                       (forall n0:set, n0 :e omega -> N c= n0 -> apply_fun seq n0 :e Cyl)
                       HNpair n HnO HNn). }
        claim HseqnCylD: apply_fun seq n :e {f :e product_space J Xi | j :e J /\ U :e space_family_topology Xi j /\ apply_fun f j :e U}.
        { rewrite <- HCylDef. exact HseqnCyl. }
        claim HcylProp: j :e J /\ U :e space_family_topology Xi j /\ apply_fun (apply_fun seq n) j :e U.
        { exact (SepE2 (product_space J Xi)
                       (fun f:set => j :e J /\ U :e space_family_topology Xi j /\ apply_fun f j :e U)
                       (apply_fun seq n) HseqnCylD). }
        claim HcylLeft: j :e J /\ U :e space_family_topology Xi j.
        { exact (andEL (j :e J /\ U :e space_family_topology Xi j)
                       (apply_fun (apply_fun seq n) j :e U)
                       HcylProp). }
        claim HcoordIn: apply_fun (apply_fun seq n) j :e U.
        { exact (andER (j :e J /\ U :e space_family_topology Xi j)
                       (apply_fun (apply_fun seq n) j :e U)
                       HcylProp). }
        claim Hseqjdef2: seqj = graph omega (fun n0:set => apply_fun (apply_fun seq n0) j).
        { reflexivity. }
        rewrite Hseqjdef2.
        rewrite (apply_fun_graph omega (fun n0:set => apply_fun (apply_fun seq n0) j) n HnO).
        exact HcoordIn.
- assume Hcoord: forall j:set, j :e J ->
    converges_to (product_component Xi j) (product_component_topology Xi j)
      (product_coordinate_sequence seq j) (apply_fun x j).
  prove converges_to X (product_topology_full J Xi) seq x.
  prove topology_on X (product_topology_full J Xi) /\ sequence_on seq X /\ x :e X /\
        forall U:set, U :e product_topology_full J Xi -> x :e U ->
          exists N:set, N :e omega /\
            forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
  apply andI.
  - apply andI.
    + apply andI.
      * (** topology_on **)
        rewrite HX.
        claim HHfam: Hausdorff_spaces_family J Xi.
        { let i. assume Hi: i :e J.
          prove Hausdorff_space (product_component Xi i) (product_component_topology Xi i).
          rewrite (product_component_def Xi i).
          rewrite (product_component_topology_def Xi i).
          rewrite (const_space_family_apply J R R_standard_topology i Hi).
          rewrite (tuple_2_0_eq R R_standard_topology).
          rewrite (tuple_2_1_eq R R_standard_topology).
          exact R_standard_topology_Hausdorff. }
        claim HHprod: Hausdorff_space (product_space J Xi) (product_topology_full J Xi).
        { exact (product_topology_full_Hausdorff_axiom J Xi HHfam). }
        exact (Hausdorff_space_topology (product_space J Xi) (product_topology_full J Xi) HHprod).
      * exact Hseq.
    + exact HxX.
  - let U. assume HU: U :e product_topology_full J Xi.
    assume HxU: x :e U.
    (** reduce membership in open U to membership in a basis element b0 with b0 c= U **)
    set X0 := product_space J Xi.
    set S := product_subbasis_full J Xi.
    set B := basis_of_subbasis X0 S.
    claim HxX0: x :e X0.
    { rewrite <- HX. exact HxX. }
    claim HUgen: U :e generated_topology X0 B.
    { claim HTdef: product_topology_full J Xi = generated_topology X0 B.
      { reflexivity. }
      prove U :e generated_topology X0 B.
      rewrite <- HTdef.
      exact HU. }
    claim HUbasis: forall z :e U, exists b0 :e B, z :e b0 /\ b0 c= U.
    { exact (SepE2 (Power X0)
                   (fun U0:set => forall z :e U0, exists b0 :e B, z :e b0 /\ b0 c= U0)
                   U
                   HUgen). }
    apply (HUbasis x HxU).
    let b0. assume Hb0pair.
    claim Hb0B: b0 :e B.
    { exact (andEL (b0 :e B) (x :e b0 /\ b0 c= U) Hb0pair). }
    claim Hxb0sub: x :e b0 /\ b0 c= U.
    { exact (andER (b0 :e B) (x :e b0 /\ b0 c= U) Hb0pair). }
    claim Hxb0: x :e b0.
    { exact (andEL (x :e b0) (b0 c= U) Hxb0sub). }
    claim Hb0subU: b0 c= U.
    { exact (andER (x :e b0) (b0 c= U) Hxb0sub). }
    (** it suffices to show: seq is eventually in b0 **)
    claim HexN0: exists N0:set, N0 :e omega /\
      forall n:set, n :e omega -> N0 c= n -> apply_fun seq n :e b0.
    { (** unfold b0 as a finite intersection of subbasis cylinders **)
      claim Hb0fin: b0 :e finite_intersections_of X0 S.
      { exact (SepE1 (finite_intersections_of X0 S) (fun b:set => b <> Empty) b0 Hb0B). }
      claim HexF: exists F :e finite_subcollections S, b0 = intersection_of_family X0 F.
      { exact (ReplE (finite_subcollections S) (fun F0:set => intersection_of_family X0 F0) b0 Hb0fin). }
      apply HexF.
      let F. assume HFpair. apply HFpair.
      assume HF: F :e finite_subcollections S.
      assume Hb0eq: b0 = intersection_of_family X0 F.
      (** use x :e b0 to get x :e intersection_of_family X0 F **)
      claim HxIF: x :e intersection_of_family X0 F.
      { rewrite <- Hb0eq. exact Hxb0. }
      (** extract finiteness and subset of S **)
      claim HFpow: F :e Power S.
      { exact (SepE1 (Power S) (fun F0:set => finite F0) F HF). }
      claim HFsubS: F c= S.
      { exact (PowerE S F HFpow). }
      claim HFfin: finite F.
      { exact (SepE2 (Power S) (fun F0:set => finite F0) F HF). }
      (** helper: any subbasis cylinder containing x is hit eventually by seq using coordinate convergence **)
      claim HeventSub: forall s:set, s :e S -> x :e s ->
        exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e s.
      { let s. assume HsS: s :e S.
        assume Hxs: x :e s.
        prove exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e s.
        set Fam := (fun i:set => {product_cylinder J Xi i U|U :e space_family_topology Xi i}).
        claim HsFam: s :e (\/_ i :e J, Fam i).
        { exact HsS. }
        apply (famunionE_impred J Fam s HsFam
               (exists N:set, N :e omega /\
                 forall n:set, n :e omega -> N c= n -> apply_fun seq n :e s)).
        let i. assume HiJ: i :e J.
        assume HsFi: s :e Fam i.
        claim HexU: exists U :e space_family_topology Xi i, s = product_cylinder J Xi i U.
        { exact (ReplE (space_family_topology Xi i) (fun U0:set => product_cylinder J Xi i U0) s HsFi). }
        apply HexU.
        let U. assume HUand. apply HUand.
        assume HUtop: U :e space_family_topology Xi i.
        assume Hseqs: s = product_cylinder J Xi i U.
        claim HxCyl: x :e product_cylinder J Xi i U.
        { rewrite <- Hseqs. exact Hxs. }
        claim HxCylProp: i :e J /\ U :e space_family_topology Xi i /\ apply_fun x i :e U.
        { exact (SepE2 (product_space J Xi)
                       (fun f:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f i :e U)
                       x HxCyl). }
        claim HxCylLeft: i :e J /\ U :e space_family_topology Xi i.
        { exact (andEL (i :e J /\ U :e space_family_topology Xi i)
                       (apply_fun x i :e U)
                       HxCylProp). }
        claim HUtop2: U :e space_family_topology Xi i.
        { exact (andER (i :e J) (U :e space_family_topology Xi i) HxCylLeft). }
        claim HxUi: apply_fun x i :e U.
        { exact (andER (i :e J /\ U :e space_family_topology Xi i)
                       (apply_fun x i :e U)
                       HxCylProp). }
        claim Hconi: converges_to (product_component Xi i) (product_component_topology Xi i)
                         (product_coordinate_sequence seq i) (apply_fun x i).
        { exact (Hcoord i HiJ). }
        claim HUi: U :e product_component_topology Xi i.
        { claim Heq: product_component_topology Xi i = space_family_topology Xi i.
          { reflexivity. }
          rewrite Heq.
          exact HUtop2. }
        claim HexN: exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun (product_coordinate_sequence seq i) n :e U.
        { exact (converges_to_neighborhoods (product_component Xi i) (product_component_topology Xi i)
                   (product_coordinate_sequence seq i) (apply_fun x i) Hconi U HUi HxUi). }
        apply HexN.
        let N. assume HNpair.
        witness N.
        apply andI.
        - exact (andEL (N :e omega)
                       (forall n:set, n :e omega -> N c= n -> apply_fun (product_coordinate_sequence seq i) n :e U)
                       HNpair).
        - let n. assume HnO: n :e omega.
          assume HNn: N c= n.
          prove apply_fun seq n :e s.
          claim HseqnX0: apply_fun seq n :e product_space J Xi.
          { rewrite <- HX.
            exact (Hseq n HnO). }
          claim Hseqidef: product_coordinate_sequence seq i = graph omega (fun n0:set => apply_fun (apply_fun seq n0) i).
          { reflexivity. }
          claim HcoordIn: apply_fun (apply_fun seq n) i :e U.
          { claim Htmp: apply_fun (product_coordinate_sequence seq i) n :e U.
            { exact (andER (N :e omega)
                           (forall n0:set, n0 :e omega -> N c= n0 -> apply_fun (product_coordinate_sequence seq i) n0 :e U)
                           HNpair n HnO HNn). }
            claim Happ: apply_fun (product_coordinate_sequence seq i) n = apply_fun (apply_fun seq n) i.
            { rewrite Hseqidef.
              rewrite (apply_fun_graph omega (fun n0:set => apply_fun (apply_fun seq n0) i) n HnO).
              reflexivity. }
            rewrite <- Happ.
            exact Htmp. }
          rewrite Hseqs.
          claim HcylDef: product_cylinder J Xi i U =
            {f :e product_space J Xi | i :e J /\ U :e space_family_topology Xi i /\ apply_fun f i :e U}.
          { reflexivity. }
          rewrite HcylDef.
          exact (SepI (product_space J Xi)
                      (fun f:set => i :e J /\ U :e space_family_topology Xi i /\ apply_fun f i :e U)
                      (apply_fun seq n)
                      HseqnX0
                      (andI (i :e J /\ U :e space_family_topology Xi i) (apply_fun (apply_fun seq n) i :e U)
                            (andI (i :e J) (U :e space_family_topology Xi i) HiJ HUtop)
                            HcoordIn)). }
      (** show eventual membership in the finite intersection defining b0, using finite induction **)
      set p := (fun A:set =>
        A c= S -> x :e intersection_of_family X0 A ->
          exists N:set, N :e omega /\
            forall n:set, n :e omega -> N c= n -> apply_fun seq n :e intersection_of_family X0 A).
      claim HpEmpty: p Empty.
      { assume Hsub0: Empty c= S.
        assume HxI0: x :e intersection_of_family X0 Empty.
        prove exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e intersection_of_family X0 Empty.
        witness 0.
        apply andI.
        - exact (nat_p_omega 0 nat_0).
        - let n. assume HnO: n :e omega.
          assume H0n: 0 c= n.
          prove apply_fun seq n :e intersection_of_family X0 Empty.
          rewrite (intersection_of_family_empty_eq X0).
          claim HseqnX0: apply_fun seq n :e X0.
          { rewrite <- HX.
            exact (Hseq n HnO). }
          exact HseqnX0. }
      claim HpStep: forall A y:set, finite A -> y /:e A ->
        p A -> p (A :\/: {y}).
      { let A y.
        assume HAfin: finite A.
        assume HynA: y /:e A.
        assume HpA: p A.
        assume HsubAy: A :\/: {y} c= S.
        assume HxIay: x :e intersection_of_family X0 (A :\/: {y}).
        prove exists N:set, N :e omega /\
          forall n:set, n :e omega -> N c= n -> apply_fun seq n :e intersection_of_family X0 (A :\/: {y}).
        claim HsubA: A c= S.
        { exact (Subq_tra A (A :\/: {y}) S (binunion_Subq_1 A {y}) HsubAy). }
        claim HyIn: y :e A :\/: {y}.
        { exact (binunionI2 A {y} y (SingI y)). }
        claim HyS: y :e S.
        { exact (HsubAy y HyIn). }
        claim HxIay2: x :e (intersection_of_family X0 A) :/\: y.
        { rewrite <- (intersection_of_family_adjoin X0 A y).
          exact HxIay. }
        claim HxIA: x :e intersection_of_family X0 A.
        { exact (binintersectE1 (intersection_of_family X0 A) y x HxIay2). }
        claim Hxy: x :e y.
        { exact (binintersectE2 (intersection_of_family X0 A) y x HxIay2). }
        claim HexNA: exists NA:set, NA :e omega /\
          forall n:set, n :e omega -> NA c= n -> apply_fun seq n :e intersection_of_family X0 A.
        { exact (HpA HsubA HxIA). }
        claim HexNy: exists Ny:set, Ny :e omega /\
          forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e y.
        { exact (HeventSub y HyS Hxy). }
        apply HexNA.
        let NA. assume HNApair.
        apply HexNy.
        let Ny. assume HNypair.
        set N := NA :\/: Ny.
        claim HNAo: NA :e omega.
        { exact (andEL (NA :e omega)
                       (forall n:set, n :e omega -> NA c= n -> apply_fun seq n :e intersection_of_family X0 A)
                       HNApair). }
        claim HNyo: Ny :e omega.
        { exact (andEL (Ny :e omega)
                       (forall n:set, n :e omega -> Ny c= n -> apply_fun seq n :e y)
                       HNypair). }
        claim HNo: N :e omega.
        { exact (omega_binunion NA Ny HNAo HNyo). }
        witness N.
        apply andI.
        - exact HNo.
        - let n. assume HnO: n :e omega.
          assume HNn: N c= n.
          prove apply_fun seq n :e intersection_of_family X0 (A :\/: {y}).
          claim HNAsub: NA c= N.
          { exact (binunion_Subq_1 NA Ny). }
          claim HNysub: Ny c= N.
          { exact (binunion_Subq_2 NA Ny). }
          claim HNAn: NA c= n.
          { exact (Subq_tra NA N n HNAsub HNn). }
          claim HNyn: Ny c= n.
          { exact (Subq_tra Ny N n HNysub HNn). }
          claim HseqnA: apply_fun seq n :e intersection_of_family X0 A.
          { exact (andER (NA :e omega)
                         (forall n0:set, n0 :e omega -> NA c= n0 -> apply_fun seq n0 :e intersection_of_family X0 A)
                         HNApair n HnO HNAn). }
          claim Hseqny: apply_fun seq n :e y.
          { exact (andER (Ny :e omega)
                         (forall n0:set, n0 :e omega -> Ny c= n0 -> apply_fun seq n0 :e y)
                         HNypair n HnO HNyn). }
          rewrite (intersection_of_family_adjoin X0 A y).
          exact (binintersectI (intersection_of_family X0 A) y (apply_fun seq n) HseqnA Hseqny). }
      claim HpF: p F.
      { exact (finite_ind p HpEmpty HpStep F HFfin). }
      claim HexNF: exists N0:set, N0 :e omega /\
        forall n:set, n :e omega -> N0 c= n -> apply_fun seq n :e intersection_of_family X0 F.
      { exact (HpF HFsubS HxIF). }
      apply HexNF.
      let N0. assume HN0pair.
      witness N0.
      apply andI.
      - exact (andEL (N0 :e omega)
                     (forall n:set, n :e omega -> N0 c= n -> apply_fun seq n :e intersection_of_family X0 F)
                     HN0pair).
      - let n. assume HnO: n :e omega.
        assume HN0n: N0 c= n.
        prove apply_fun seq n :e b0.
        rewrite Hb0eq.
        exact (andER (N0 :e omega)
                     (forall n0:set, n0 :e omega -> N0 c= n0 -> apply_fun seq n0 :e intersection_of_family X0 F)
                     HN0pair n HnO HN0n). }
    apply HexN0.
    let N0. assume HN0pair.
    witness N0.
    apply andI.
    - exact (andEL (N0 :e omega)
                   (forall n:set, n :e omega -> N0 c= n -> apply_fun seq n :e b0)
                   HN0pair).
    - let n. assume HnO: n :e omega.
      assume HN0n: N0 c= n.
      prove apply_fun seq n :e U.
      claim Hnb0: apply_fun seq n :e b0.
      { exact (andER (N0 :e omega)
                     (forall n0:set, n0 :e omega -> N0 c= n0 -> apply_fun seq n0 :e b0)
                     HN0pair n HnO HN0n). }
      exact (Hb0subU (apply_fun seq n) Hnb0).
Qed.

(** NOTE: R_bounded_metric is defined earlier (near R_bounded_distance). **)

(** helper: compute apply_fun of the bounded metric graph **)
Theorem R_bounded_metric_apply : forall x y:set,
  x :e R -> y :e R ->
  apply_fun R_bounded_metric (x,y) = R_bounded_distance x y.
let x y.
assume Hx: x :e R.
assume Hy: y :e R.
claim Hxy: (x,y) :e setprod R R.
{ exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
rewrite (apply_fun_graph (setprod R R) (fun p:set => R_bounded_distance (p 0) (p 1)) (x,y) Hxy).
rewrite (tuple_2_0_eq x y).
rewrite (tuple_2_1_eq x y).
reflexivity.
Qed.

(** helper: bounded metric on R is a metric_on **)
Theorem R_bounded_metric_is_metric_on : metric_on R R_bounded_metric.
prove metric_on R R_bounded_metric.
prove ((((function_on R_bounded_metric (setprod R R) R /\
         (forall x y:set, x :e R -> y :e R ->
            apply_fun R_bounded_metric (x,y) = apply_fun R_bounded_metric (y,x))) /\
        (forall x:set, x :e R -> apply_fun R_bounded_metric (x,x) = 0)) /\
       (forall x y:set, x :e R -> y :e R ->
          ~(Rlt (apply_fun R_bounded_metric (x,y)) 0)
          /\ (apply_fun R_bounded_metric (x,y) = 0 -> x = y))) /\
      (forall x y z:set, x :e R -> y :e R -> z :e R ->
         ~(Rlt (add_SNo (apply_fun R_bounded_metric (x,y)) (apply_fun R_bounded_metric (y,z)))
               (apply_fun R_bounded_metric (x,z))))).
apply andI.
- apply andI.
  + apply andI.
    * apply andI.
      - let p. assume Hp: p :e setprod R R.
        prove apply_fun R_bounded_metric p :e R.
        claim Happ: apply_fun R_bounded_metric p =
          R_bounded_distance (p 0) (p 1).
        { exact (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 p
                                 Hp). }
        rewrite Happ.
        claim Hp0: p 0 :e R.
        { exact (ap0_Sigma R (fun _ : set => R) p Hp). }
        claim Hp1: p 1 :e R.
        { exact (ap1_Sigma R (fun _ : set => R) p Hp). }
        exact (R_bounded_distance_in_R (p 0) (p 1) Hp0 Hp1).
      - let x y.
        assume Hx: x :e R.
        assume Hy: y :e R.
        claim Hxyprod: (x,y) :e setprod R R.
        { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
        claim Hyxprod: (y,x) :e setprod R R.
        { exact (tuple_2_setprod_by_pair_Sigma R R y x Hy Hx). }
        rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (x,y)
                                 Hxyprod).
        rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (y,x)
                                 Hyxprod).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        rewrite (tuple_2_0_eq y x).
        rewrite (tuple_2_1_eq y x).
        exact (R_bounded_distance_sym x y Hx Hy).
    * let x. assume Hx: x :e R.
      claim Hxxprod: (x,x) :e setprod R R.
      { exact (tuple_2_setprod_by_pair_Sigma R R x x Hx Hx). }
      rewrite (apply_fun_graph (setprod R R)
                               (fun q:set => R_bounded_distance (q 0) (q 1))
                               (x,x)
                               Hxxprod).
      rewrite (tuple_2_0_eq x x).
      rewrite (tuple_2_1_eq x x).
      exact (R_bounded_distance_self_zero x Hx).
  + let x y.
    assume Hx: x :e R.
    assume Hy: y :e R.
    claim Hxyprod: (x,y) :e setprod R R.
    { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
    prove ~(Rlt (apply_fun R_bounded_metric (x,y)) 0)
         /\ (apply_fun R_bounded_metric (x,y) = 0 -> x = y).
    apply andI.
    * prove ~(Rlt (apply_fun R_bounded_metric (x,y)) 0).
      rewrite (apply_fun_graph (setprod R R)
                               (fun q:set => R_bounded_distance (q 0) (q 1))
                               (x,y)
                               Hxyprod).
      rewrite (tuple_2_0_eq x y).
      rewrite (tuple_2_1_eq x y).
      prove ~(Rlt (R_bounded_distance x y) 0).
      assume Hlt: Rlt (R_bounded_distance x y) 0.
      claim HdR: R_bounded_distance x y :e R.
      { exact (R_bounded_distance_in_R x y Hx Hy). }
      claim HdS: SNo (R_bounded_distance x y).
      { exact (real_SNo (R_bounded_distance x y) HdR). }
      claim H0S: SNo 0.
      { exact SNo_0. }
      claim Hnonneg: 0 <= R_bounded_distance x y.
      { exact (R_bounded_distance_nonneg x y Hx Hy). }
      claim Hcase: 0 < (R_bounded_distance x y) \/ 0 = (R_bounded_distance x y).
      { exact (SNoLeE 0 (R_bounded_distance x y) H0S HdS Hnonneg). }
      claim HltS: R_bounded_distance x y < 0.
      { exact (RltE_lt (R_bounded_distance x y) 0 Hlt). }
      apply (Hcase False).
      - assume H0ltd: 0 < (R_bounded_distance x y).
        claim H00: 0 < 0.
        { exact (SNoLt_tra 0 (R_bounded_distance x y) 0 H0S HdS H0S H0ltd HltS). }
        exact ((SNoLt_irref 0) H00).
      - assume H0eq: 0 = (R_bounded_distance x y).
        claim H00: 0 < 0.
        { rewrite H0eq at 1.
          exact HltS. }
        exact ((SNoLt_irref 0) H00).
    * assume H0: apply_fun R_bounded_metric (x,y) = 0.
      claim Happ: apply_fun R_bounded_metric (x,y) = R_bounded_distance x y.
      { rewrite (apply_fun_graph (setprod R R)
                                 (fun q:set => R_bounded_distance (q 0) (q 1))
                                 (x,y)
                                 Hxyprod).
        rewrite (tuple_2_0_eq x y).
        rewrite (tuple_2_1_eq x y).
        reflexivity. }
      claim Hbd0: R_bounded_distance x y = 0.
      { rewrite <- Happ.
        exact H0. }
      exact (R_bounded_distance_eq0 x y Hx Hy Hbd0).
- let x y z.
  assume Hx: x :e R.
  assume Hy: y :e R.
  assume Hz: z :e R.
  claim Hxyprod: (x,y) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R x y Hx Hy). }
  claim Hyzprod: (y,z) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R y z Hy Hz). }
  claim Hxzprod: (x,z) :e setprod R R.
  { exact (tuple_2_setprod_by_pair_Sigma R R x z Hx Hz). }
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (x,y)
                           Hxyprod).
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (y,z)
                           Hyzprod).
  rewrite (apply_fun_graph (setprod R R)
                           (fun q:set => R_bounded_distance (q 0) (q 1))
                           (x,z)
                           Hxzprod).
  rewrite (tuple_2_0_eq x y).
  rewrite (tuple_2_1_eq x y).
  rewrite (tuple_2_0_eq y z).
  rewrite (tuple_2_1_eq y z).
  rewrite (tuple_2_0_eq x z).
  rewrite (tuple_2_1_eq x z).
  claim Htri: R_bounded_distance x z <= add_SNo (R_bounded_distance x y) (R_bounded_distance y z).
  { exact (R_bounded_distance_triangle_Le x y z Hx Hy Hz). }
  prove ~(Rlt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
              (R_bounded_distance x z)).
  assume Hlt: Rlt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                  (R_bounded_distance x z).
  claim HxzR: R_bounded_distance x z :e R.
  { exact (R_bounded_distance_in_R x z Hx Hz). }
  claim HsumR: add_SNo (R_bounded_distance x y) (R_bounded_distance y z) :e R.
  { claim HxyR: R_bounded_distance x y :e R.
    { exact (R_bounded_distance_in_R x y Hx Hy). }
    claim HyzR: R_bounded_distance y z :e R.
    { exact (R_bounded_distance_in_R y z Hy Hz). }
    exact (real_add_SNo (R_bounded_distance x y) HxyR (R_bounded_distance y z) HyzR). }
  claim HxzS: SNo (R_bounded_distance x z).
  { exact (real_SNo (R_bounded_distance x z) HxzR). }
  claim HsumS: SNo (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
  { exact (real_SNo (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)) HsumR). }
  claim Hcase: (R_bounded_distance x z) < (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
               \/ (R_bounded_distance x z) = (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
  { exact (SNoLeE (R_bounded_distance x z)
                  (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                  HxzS HsumS Htri). }
  claim HltS: (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
              < (R_bounded_distance x z).
  { exact (RltE_lt (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                   (R_bounded_distance x z)
                   Hlt). }
  apply (Hcase False).
  - assume Hxzlts: (R_bounded_distance x z) < (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
    claim Hbad: (R_bounded_distance x z) < (R_bounded_distance x z).
    { exact (SNoLt_tra (R_bounded_distance x z)
                      (add_SNo (R_bounded_distance x y) (R_bounded_distance y z))
                      (R_bounded_distance x z)
                      HxzS HsumS HxzS
                      Hxzlts
                      HltS). }
    exact ((SNoLt_irref (R_bounded_distance x z)) Hbad).
  - assume Hxzeq: (R_bounded_distance x z) = (add_SNo (R_bounded_distance x y) (R_bounded_distance y z)).
    claim Hbad: (R_bounded_distance x z) < (R_bounded_distance x z).
    { rewrite Hxzeq at 1.
      exact HltS. }
    exact ((SNoLt_irref (R_bounded_distance x z)) Hbad).
Qed.

(** helper: bounded-metric Cauchy gives abs-tail estimates for eps<1 **)
Theorem cauchy_R_bounded_metric_abs_tail : forall seq eps:set,
  cauchy_sequence R R_bounded_metric seq ->
  eps :e R -> Rlt 0 eps -> Rlt eps 1 ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
let seq eps.
assume Hc: cauchy_sequence R R_bounded_metric seq.
assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
assume HepsLt1: Rlt eps 1.
claim Hleft: metric_on R R_bounded_metric /\ sequence_on seq R.
{ exact (andEL (metric_on R R_bounded_metric /\ sequence_on seq R)
               (forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0)
               Hc). }
claim Hseq: sequence_on seq R.
{ exact (andER (metric_on R R_bounded_metric) (sequence_on seq R) Hleft). }
claim Htail: forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0.
{ exact (andER (metric_on R R_bounded_metric /\ sequence_on seq R)
               (forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps0)
               Hc). }
claim HepsPair: eps :e R /\ Rlt 0 eps.
{ apply andI.
  - exact HepsR.
  - exact HepsPos. }
apply (Htail eps HepsPair).
let N. assume HNpair.
witness N.
apply andI.
- exact (andEL (N :e omega)
               (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                 Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps)
               HNpair).
- let m n.
  assume HmO: m :e omega.
  assume HnO: n :e omega.
  assume HNm: N c= m.
  assume HNn: N c= n.
  prove abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
  claim HmR: apply_fun seq m :e R.
  { exact (Hseq m HmO). }
  claim HnR: apply_fun seq n :e R.
  { exact (Hseq n HnO). }
  claim Hlt: Rlt (apply_fun R_bounded_metric (apply_fun seq m, apply_fun seq n)) eps.
  { exact (andER (N :e omega)
                 (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                   Rlt (apply_fun R_bounded_metric (apply_fun seq m0, apply_fun seq n0)) eps)
                 HNpair m n HmO HnO HNm HNn). }
  claim Hlt2: Rlt (R_bounded_distance (apply_fun seq m) (apply_fun seq n)) eps.
  { rewrite <- (R_bounded_metric_apply (apply_fun seq m) (apply_fun seq n) HmR HnR).
    exact Hlt. }
  exact (R_bounded_distance_lt_lt1_imp_abs_lt (apply_fun seq m) (apply_fun seq n) eps HmR HnR HepsR HepsLt1 Hlt2).
Qed.

(** helper: open balls for the bounded metric with radius < 1 are exactly abs-balls **)
Theorem open_ball_R_bounded_metric_abs : forall x r y:set,
  x :e R -> r :e R -> Rlt 0 r -> Rlt r 1 ->
  (y :e open_ball R R_bounded_metric x r <->
   (y :e R /\ Rlt (R_bounded_distance x y) r)).
let x r y.
assume Hx: x :e R.
assume Hr: r :e R.
assume Hrpos: Rlt 0 r.
assume Hrlt1: Rlt r 1.
apply iffI.
- assume HyB: y :e open_ball R R_bounded_metric x r.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric x r y HyB). }
  claim Hlt: Rlt (apply_fun R_bounded_metric (x,y)) r.
  { exact (open_ballE2 R R_bounded_metric x r y HyB). }
  apply andI.
  - exact HyR.
  - prove Rlt (R_bounded_distance x y) r.
    rewrite <- (R_bounded_metric_apply x y Hx HyR).
    exact Hlt.
- assume Hpair: y :e R /\ Rlt (R_bounded_distance x y) r.
  claim HyR: y :e R.
  { exact (andEL (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
  claim Hlt: Rlt (R_bounded_distance x y) r.
  { exact (andER (y :e R) (Rlt (R_bounded_distance x y) r) Hpair). }
  apply (open_ballI R R_bounded_metric x r y HyR).
  rewrite (R_bounded_metric_apply x y Hx HyR).
  exact Hlt.
Qed.

(** helper: bounded metric balls with radius < 1 are open intervals **)
(** LATEX VERSION: If 0<r<1 then B(c,r) = (c-r, c+r) for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_eq_open_interval : forall c r:set,
  c :e R -> r :e R -> Rlt 0 r -> Rlt r 1 ->
  open_ball R R_bounded_metric c r = open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume HrposR: Rlt 0 r.
assume Hrlt1R: Rlt r 1.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c r.
  prove y :e open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
  claim HdefI: open_interval (add_SNo c (minus_SNo r)) (add_SNo c r) =
    {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { reflexivity. }
  rewrite HdefI.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric c r y HyB). }
  claim Hdlt: Rlt (apply_fun R_bounded_metric (c,y)) r.
  { exact (open_ballE2 R R_bounded_metric c r y HyB). }
  claim Hbdlt: Rlt (R_bounded_distance c y) r.
  { rewrite <- (R_bounded_metric_apply c y HcR HyR).
    exact Hdlt. }
  claim Habslt: abs_SNo (add_SNo c (minus_SNo y)) < r.
  { exact (R_bounded_distance_lt_lt1_imp_abs_lt c y r HcR HyR HrR Hrlt1R Hbdlt). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim HrposS: 0 < r.
  { exact (RltE_lt 0 r HrposR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim Htlt: t < r.
  { exact (abs_SNo_lt_imp_lt t r HtS HrS HrposS Habslt). }
  claim Hmtlt: minus_SNo t < r.
  { exact (abs_SNo_lt_imp_neg_lt t r HtS HrS HrposS Habslt). }
  claim Hswap: add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
  { claim HmcS: SNo (minus_SNo c).
    { exact (SNo_minus_SNo c HcS). }
    claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
    { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
    claim Hinv : minus_SNo (minus_SNo y) = y.
    { exact (minus_SNo_invol y HyS). }
    claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
    { rewrite <- Hinv at 2.
      exact Hneg. }
    claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
    { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
    prove add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
    rewrite <- Hcom.
    rewrite <- Hneg2.
    reflexivity. }
  claim HycLt: add_SNo y (minus_SNo c) < r.
  { rewrite Hswap.
    exact Hmtlt. }
  claim HyLt: y < add_SNo c r.
  { claim Hlt1: y < add_SNo r c.
    { exact (add_SNo_minus_Lt1 y c r HyS HcS HrS HycLt). }
    claim Hcom: add_SNo r c = add_SNo c r.
    { exact (add_SNo_com r c HrS HcS). }
    rewrite <- Hcom.
    exact Hlt1. }
  claim HcmyLt: add_SNo c (minus_SNo r) < y.
  { claim Hlt1: c < add_SNo r y.
    { exact (add_SNo_minus_Lt1 c y r HcS HyS HrS Htlt). }
    claim Hcom1: add_SNo r y = add_SNo y r.
    { exact (add_SNo_com r y HrS HyS). }
    claim Hlt2: c < add_SNo y r.
    { rewrite <- Hcom1.
      exact Hlt1. }
    claim HmrS: SNo (minus_SNo r).
    { exact (SNo_minus_SNo r HrS). }
    claim HyrS: SNo (add_SNo y r).
    { exact (SNo_add_SNo y r HyS HrS). }
    exact (add_SNo_minus_Lt1b c r y HcS HrS HyS Hlt2). }
  claim HcrR: add_SNo c (minus_SNo r) :e R.
  { exact (real_add_SNo c HcR (minus_SNo r) (real_minus_SNo r HrR)). }
  claim HcrS: SNo (add_SNo c (minus_SNo r)).
  { exact (real_SNo (add_SNo c (minus_SNo r)) HcrR). }
  claim HcprR: add_SNo c r :e R.
  { exact (real_add_SNo c HcR r HrR). }
  claim HcprS: SNo (add_SNo c r).
  { exact (real_SNo (add_SNo c r) HcprR). }
  claim HleftRlt: Rlt (add_SNo c (minus_SNo r)) y.
  { exact (RltI (add_SNo c (minus_SNo r)) y HcrR HyR HcmyLt). }
  claim HrightRlt: Rlt y (add_SNo c r).
  { exact (RltI y (add_SNo c r) HyR HcprR HyLt). }
  exact (SepI R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r))
         y HyR (andI (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) HleftRlt HrightRlt)).
- let y. assume HyI: y :e open_interval (add_SNo c (minus_SNo r)) (add_SNo c r).
  prove y :e open_ball R R_bounded_metric c r.
  claim HdefI: open_interval (add_SNo c (minus_SNo r)) (add_SNo c r) =
    {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { reflexivity. }
  claim HyI': y :e {x :e R|Rlt (add_SNo c (minus_SNo r)) x /\ Rlt x (add_SNo c r)}.
  { rewrite <- HdefI.
    exact HyI. }
  claim HyR: y :e R.
  { exact (SepE1 R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r)) y HyI'). }
  claim Hconj: Rlt (add_SNo c (minus_SNo r)) y /\ Rlt y (add_SNo c r).
  { exact (SepE2 R (fun x0:set => Rlt (add_SNo c (minus_SNo r)) x0 /\ Rlt x0 (add_SNo c r)) y HyI'). }
  claim Hleft: Rlt (add_SNo c (minus_SNo r)) y.
  { exact (andEL (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) Hconj). }
  claim Hright: Rlt y (add_SNo c r).
  { exact (andER (Rlt (add_SNo c (minus_SNo r)) y) (Rlt y (add_SNo c r)) Hconj). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  claim HrS: SNo r.
  { exact (real_SNo r HrR). }
  claim H0lt: 0 < r.
  { exact (RltE_lt 0 r HrposR). }
  claim HltY: y < add_SNo c r.
  { exact (RltE_lt y (add_SNo c r) Hright). }
  claim Hcylt: add_SNo c (minus_SNo r) < y.
  { exact (RltE_lt (add_SNo c (minus_SNo r)) y Hleft). }
  claim HycLt: add_SNo y (minus_SNo c) < r.
  { claim HcprS: SNo (add_SNo c r).
    { exact (SNo_add_SNo c r HcS HrS). }
    claim Hcom: add_SNo c r = add_SNo r c.
    { exact (add_SNo_com c r HcS HrS). }
    claim Hlt2: y < add_SNo r c.
    { rewrite <- Hcom.
      exact HltY. }
    exact (add_SNo_minus_Lt1b y c r HyS HcS HrS Hlt2). }
  claim HcyLt: add_SNo c (minus_SNo y) < r.
  { claim HmrS: SNo (minus_SNo r).
    { exact (SNo_minus_SNo r HrS). }
    claim HmR: minus_SNo r :e R.
    { exact (real_minus_SNo r HrR). }
    claim HmS: SNo (minus_SNo r).
    { exact (real_SNo (minus_SNo r) HmR). }
    claim Hsum: add_SNo r (add_SNo c (minus_SNo r)) < add_SNo r y.
    { exact (add_SNo_Lt2 r (add_SNo c (minus_SNo r)) y HrS (SNo_add_SNo c (minus_SNo r) HcS (SNo_minus_SNo r HrS)) HyS Hcylt). }
    claim Hassoc1: add_SNo r (add_SNo c (minus_SNo r)) = add_SNo (add_SNo r c) (minus_SNo r).
    { exact (add_SNo_assoc r c (minus_SNo r) HrS HcS (SNo_minus_SNo r HrS)). }
    claim Hcom2: add_SNo r c = add_SNo c r.
    { exact (add_SNo_com r c HrS HcS). }
    claim Hassoc2: add_SNo (add_SNo r c) (minus_SNo r) = add_SNo c (add_SNo r (minus_SNo r)).
    { rewrite Hcom2.
      rewrite <- (add_SNo_assoc c r (minus_SNo r) HcS HrS (SNo_minus_SNo r HrS)).
      reflexivity. }
    claim Hrinv: add_SNo r (minus_SNo r) = 0.
    { exact (add_SNo_minus_SNo_rinv r HrS). }
    claim Heqleft: add_SNo r (add_SNo c (minus_SNo r)) = c.
    { rewrite Hassoc1.
      rewrite Hassoc2.
      rewrite Hrinv.
      rewrite (add_SNo_0R c HcS).
      reflexivity. }
    claim Hlt3: c < add_SNo r y.
    { rewrite <- Heqleft.
      exact Hsum. }
    exact (add_SNo_minus_Lt1b c y r HcS HyS HrS Hlt3). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim Hablt: abs_SNo t < r.
  { apply (xm (0 <= t)).
    - assume H0le: 0 <= t.
      rewrite (nonneg_abs_SNo t H0le).
      exact HcyLt.
    - assume Hn0le: ~(0 <= t).
      rewrite (not_nonneg_abs_SNo t Hn0le).
      claim Hswap: minus_SNo t = add_SNo y (minus_SNo c).
      { claim HmcS: SNo (minus_SNo c).
        { exact (SNo_minus_SNo c HcS). }
        claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
        { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
        claim Hinv : minus_SNo (minus_SNo y) = y.
        { exact (minus_SNo_invol y HyS). }
        claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
        { rewrite <- Hinv at 2.
          exact Hneg. }
        claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
        { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
        prove minus_SNo t = add_SNo y (minus_SNo c).
        claim Htdef: t = add_SNo c (minus_SNo y).
        { reflexivity. }
        rewrite Htdef.
        rewrite Hneg2.
        rewrite Hcom.
        reflexivity. }
      rewrite Hswap.
      exact HycLt. }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) r.
  { exact (RltI (abs_SNo t) r HabsR HrR Hablt). }
  claim HbdRlt: Rlt (R_bounded_distance c y) r.
  { set ab := abs_SNo t.
    claim Hablt1: Rlt ab 1.
    { exact (Rlt_tra ab r 1 HabRlt Hrlt1R). }
    claim Hbddef: R_bounded_distance c y = If_i (Rlt ab 1) ab 1.
    { reflexivity. }
    prove Rlt (R_bounded_distance c y) r.
    rewrite Hbddef.
    rewrite (If_i_1 (Rlt ab 1) ab 1 Hablt1).
    exact HabRlt. }
  apply (open_ballI R R_bounded_metric c r y HyR).
  rewrite (R_bounded_metric_apply c y HcR HyR).
  exact HbdRlt.
Qed.

(** helper: bounded metric ball of radius 1 is an open interval **)
(** LATEX VERSION: B(c,1) = (c-1, c+1) for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_r1_eq_open_interval : forall c:set,
  c :e R ->
  open_ball R R_bounded_metric c 1 = open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
let c.
assume HcR: c :e R.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c 1.
  prove y :e open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  claim HdefI: open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1) =
    {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { reflexivity. }
  rewrite HdefI.
  claim HyR: y :e R.
  { exact (open_ballE1 R R_bounded_metric c 1 y HyB). }
  claim Hdlt: Rlt (apply_fun R_bounded_metric (c,y)) 1.
  { exact (open_ballE2 R R_bounded_metric c 1 y HyB). }
  claim Hbdlt: Rlt (R_bounded_distance c y) 1.
  { rewrite <- (R_bounded_metric_apply c y HcR HyR).
    exact Hdlt. }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) 1.
  { claim Hbddef: R_bounded_distance c y = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
    { reflexivity. }
    claim HIfRlt: Rlt (If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1) 1.
    { rewrite <- Hbddef.
      exact Hbdlt. }
    apply (xm (Rlt (abs_SNo t) 1)).
    - assume Hablt1: Rlt (abs_SNo t) 1.
      rewrite <- (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hablt1).
      exact HIfRlt.
    - assume Hnablt1: ~(Rlt (abs_SNo t) 1).
      claim H1lt: Rlt 1 1.
      { rewrite <- (If_i_0 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 Hnablt1) at 1.
        exact HIfRlt. }
      exact (FalseE ((not_Rlt_refl 1 real_1) H1lt) (Rlt (abs_SNo t) 1)). }
  claim Hablt: abs_SNo t < 1.
  { exact (RltE_lt (abs_SNo t) 1 HabRlt). }
  claim H1S: SNo 1.
  { exact SNo_1. }
  claim Htlt: t < 1.
  { exact (abs_SNo_lt_imp_lt t 1 HtS H1S SNoLt_0_1 Hablt). }
  claim Hmtlt: minus_SNo t < 1.
  { exact (abs_SNo_lt_imp_neg_lt t 1 HtS H1S SNoLt_0_1 Hablt). }
  claim Hswap: add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
  { claim HmcS: SNo (minus_SNo c).
    { exact (SNo_minus_SNo c HcS). }
    claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
    { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
    claim Hinv : minus_SNo (minus_SNo y) = y.
    { exact (minus_SNo_invol y HyS). }
    claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
    { rewrite <- Hinv at 2.
      exact Hneg. }
    claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
    { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
    prove add_SNo y (minus_SNo c) = minus_SNo (add_SNo c (minus_SNo y)).
    rewrite <- Hcom.
    rewrite <- Hneg2.
    reflexivity. }
  claim HycLt: add_SNo y (minus_SNo c) < 1.
  { rewrite Hswap.
    exact Hmtlt. }
  claim HyLt: y < add_SNo c 1.
  { claim Hlt1: y < add_SNo 1 c.
    { exact (add_SNo_minus_Lt1 y c 1 HyS HcS SNo_1 HycLt). }
    claim Hcom: add_SNo 1 c = add_SNo c 1.
    { exact (add_SNo_com 1 c SNo_1 HcS). }
    rewrite <- Hcom.
    exact Hlt1. }
  claim HcmyLt: add_SNo c (minus_SNo 1) < y.
  { claim Hlt1: c < add_SNo 1 y.
    { exact (add_SNo_minus_Lt1 c y 1 HcS HyS SNo_1 Htlt). }
    claim Hcom1: add_SNo 1 y = add_SNo y 1.
    { exact (add_SNo_com 1 y SNo_1 HyS). }
    claim Hlt2: c < add_SNo y 1.
    { rewrite <- Hcom1.
      exact Hlt1. }
    exact (add_SNo_minus_Lt1b c 1 y HcS SNo_1 HyS Hlt2). }
  claim HclR: add_SNo c (minus_SNo 1) :e R.
  { exact (real_add_SNo c HcR (minus_SNo 1) (real_minus_SNo 1 real_1)). }
  claim HcrR: add_SNo c 1 :e R.
  { exact (real_add_SNo c HcR 1 real_1). }
  claim HleftRlt: Rlt (add_SNo c (minus_SNo 1)) y.
  { exact (RltI (add_SNo c (minus_SNo 1)) y HclR HyR HcmyLt). }
  claim HrightRlt: Rlt y (add_SNo c 1).
  { exact (RltI y (add_SNo c 1) HyR HcrR HyLt). }
  exact (SepI R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1))
         y HyR (andI (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) HleftRlt HrightRlt)).
- let y. assume HyI: y :e open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  prove y :e open_ball R R_bounded_metric c 1.
  claim HdefI: open_interval (add_SNo c (minus_SNo 1)) (add_SNo c 1) =
    {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { reflexivity. }
  claim HyI': y :e {x :e R|Rlt (add_SNo c (minus_SNo 1)) x /\ Rlt x (add_SNo c 1)}.
  { rewrite <- HdefI.
    exact HyI. }
  claim HyR: y :e R.
  { exact (SepE1 R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1)) y HyI'). }
  claim Hconj: Rlt (add_SNo c (minus_SNo 1)) y /\ Rlt y (add_SNo c 1).
  { exact (SepE2 R (fun x0:set => Rlt (add_SNo c (minus_SNo 1)) x0 /\ Rlt x0 (add_SNo c 1)) y HyI'). }
  claim Hleft: Rlt (add_SNo c (minus_SNo 1)) y.
  { exact (andEL (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) Hconj). }
  claim Hright: Rlt y (add_SNo c 1).
  { exact (andER (Rlt (add_SNo c (minus_SNo 1)) y) (Rlt y (add_SNo c 1)) Hconj). }
  claim HcS: SNo c.
  { exact (real_SNo c HcR). }
  claim HyS: SNo y.
  { exact (real_SNo y HyR). }
  set t := add_SNo c (minus_SNo y).
  claim HmyS: SNo (minus_SNo y).
  { exact (SNo_minus_SNo y HyS). }
  claim HtS: SNo t.
  { exact (SNo_add_SNo c (minus_SNo y) HcS HmyS). }
  claim HycLt: add_SNo y (minus_SNo c) < 1.
  { claim HltY: y < add_SNo c 1.
    { exact (RltE_lt y (add_SNo c 1) Hright). }
    claim Hcom: add_SNo c 1 = add_SNo 1 c.
    { exact (add_SNo_com c 1 HcS SNo_1). }
    claim Hlt2: y < add_SNo 1 c.
    { rewrite <- Hcom.
      exact HltY. }
    exact (add_SNo_minus_Lt1b y c 1 HyS HcS SNo_1 Hlt2). }
  claim HcyLt: add_SNo c (minus_SNo y) < 1.
  { claim Hcylt: add_SNo c (minus_SNo 1) < y.
    { exact (RltE_lt (add_SNo c (minus_SNo 1)) y Hleft). }
    claim Hsum: add_SNo 1 (add_SNo c (minus_SNo 1)) < add_SNo 1 y.
    { exact (add_SNo_Lt2 1 (add_SNo c (minus_SNo 1)) y SNo_1 (SNo_add_SNo c (minus_SNo 1) HcS (SNo_minus_SNo 1 SNo_1)) HyS Hcylt). }
    claim Heqleft: add_SNo 1 (add_SNo c (minus_SNo 1)) = c.
    { rewrite (add_SNo_assoc 1 c (minus_SNo 1) SNo_1 HcS (SNo_minus_SNo 1 SNo_1)).
      rewrite (add_SNo_com 1 c SNo_1 HcS).
      rewrite <- (add_SNo_assoc c 1 (minus_SNo 1) HcS SNo_1 (SNo_minus_SNo 1 SNo_1)).
      rewrite (add_SNo_minus_SNo_rinv 1 SNo_1).
      rewrite (add_SNo_0R c HcS).
      reflexivity. }
    claim Hlt3: c < add_SNo 1 y.
    { rewrite <- Heqleft.
      exact Hsum. }
    exact (add_SNo_minus_Lt1b c y 1 HcS HyS SNo_1 Hlt3). }
  claim Hablt: abs_SNo t < 1.
  { apply (xm (0 <= t)).
    - assume H0le: 0 <= t.
      rewrite (nonneg_abs_SNo t H0le).
      exact HcyLt.
    - assume Hn0le: ~(0 <= t).
      rewrite (not_nonneg_abs_SNo t Hn0le).
      claim Hswap: minus_SNo t = add_SNo y (minus_SNo c).
      { claim HmcS: SNo (minus_SNo c).
        { exact (SNo_minus_SNo c HcS). }
        claim Hneg : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) (minus_SNo (minus_SNo y)).
        { exact (minus_add_SNo_distr c (minus_SNo y) HcS HmyS). }
        claim Hinv : minus_SNo (minus_SNo y) = y.
        { exact (minus_SNo_invol y HyS). }
        claim Hneg2 : minus_SNo (add_SNo c (minus_SNo y)) = add_SNo (minus_SNo c) y.
        { rewrite <- Hinv at 2.
          exact Hneg. }
        claim Hcom : add_SNo (minus_SNo c) y = add_SNo y (minus_SNo c).
        { exact (add_SNo_com (minus_SNo c) y HmcS HyS). }
        claim Htdef: t = add_SNo c (minus_SNo y).
        { reflexivity. }
        prove minus_SNo t = add_SNo y (minus_SNo c).
        rewrite Htdef.
        rewrite Hneg2.
        rewrite Hcom.
        reflexivity. }
      rewrite Hswap.
      exact HycLt. }
  claim HabsR: abs_SNo t :e R.
  { claim HtR: t :e R.
    { exact (real_add_SNo c HcR (minus_SNo y) (real_minus_SNo y HyR)). }
    exact (abs_SNo_in_R t HtR). }
  claim HabRlt: Rlt (abs_SNo t) 1.
  { exact (RltI (abs_SNo t) 1 HabsR real_1 Hablt). }
  claim HbdRlt: Rlt (R_bounded_distance c y) 1.
  { claim Hbddef: R_bounded_distance c y = If_i (Rlt (abs_SNo t) 1) (abs_SNo t) 1.
    { reflexivity. }
    rewrite Hbddef.
    rewrite (If_i_1 (Rlt (abs_SNo t) 1) (abs_SNo t) 1 HabRlt).
    exact HabRlt. }
  apply (open_ballI R R_bounded_metric c 1 y HyR).
  rewrite (R_bounded_metric_apply c y HcR HyR).
  exact HbdRlt.
Qed.

(** helper: bounded metric balls of radius greater than 1 are all of R **)
(** LATEX VERSION: If 1<r then B(c,r)=R for the bounded metric on R. **)
Theorem open_ball_R_bounded_metric_eq_R_if_1_lt : forall c r:set,
  c :e R -> r :e R -> Rlt 1 r ->
  open_ball R R_bounded_metric c r = R.
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume Hrgt1: Rlt 1 r.
apply set_ext.
- let y. assume HyB: y :e open_ball R R_bounded_metric c r.
  prove y :e R.
  exact (open_ballE1 R R_bounded_metric c r y HyB).
- let y. assume HyR: y :e R.
  prove y :e open_ball R R_bounded_metric c r.
  apply (open_ballI R R_bounded_metric c r y HyR).
  rewrite (R_bounded_metric_apply c y HcR HyR).
  claim Hle: Rle (R_bounded_distance c y) 1.
  { exact (R_bounded_distance_le_1 c y HcR HyR). }
  exact (Rle_Rlt_tra (R_bounded_distance c y) 1 r Hle Hrgt1).
Qed.

(** helper: a D-Cauchy sequence in R^omega has bounded-metric Cauchy coordinate sequences **)
Theorem Romega_cauchy_imp_coord_cauchy_bounded : forall seq i:set,
  cauchy_sequence R_omega_space Romega_D_metric seq ->
  i :e omega ->
  cauchy_sequence R R_bounded_metric (product_coordinate_sequence seq i).
let seq i.
assume Hc: cauchy_sequence R_omega_space Romega_D_metric seq.
assume HiO: i :e omega.
set X := R_omega_space.
set d := Romega_D_metric.
set seqi := product_coordinate_sequence seq i.
claim Hleft: metric_on X d /\ sequence_on seq X.
{ exact (andEL (metric_on X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               Hc). }
claim Hm: metric_on X d.
{ exact (andEL (metric_on X d) (sequence_on seq X) Hleft). }
claim Hseq: sequence_on seq X.
{ exact (andER (metric_on X d) (sequence_on seq X) Hleft). }
claim Htail: forall eps:set, eps :e R /\ Rlt 0 eps ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps.
{ exact (andER (metric_on X d /\ sequence_on seq X)
               (forall eps:set, eps :e R /\ Rlt 0 eps ->
                 exists N:set, N :e omega /\
                   forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps)
               Hc). }
prove metric_on R R_bounded_metric /\ sequence_on seqi R /\
  forall eps:set, eps :e R /\ Rlt 0 eps ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        Rlt (apply_fun R_bounded_metric (apply_fun seqi m, apply_fun seqi n)) eps.
apply andI.
- apply andI.
  + exact R_bounded_metric_is_metric_on.
  + (** seqi is a sequence in R **)
    let n. assume HnO: n :e omega.
    prove apply_fun seqi n :e R.
    claim HseqnX: apply_fun seq n :e X.
    { exact (Hseq n HnO). }
    claim HseqiDef: seqi = graph omega (fun k:set => apply_fun (apply_fun seq k) i).
    { reflexivity. }
    rewrite HseqiDef.
    rewrite (apply_fun_graph omega (fun k:set => apply_fun (apply_fun seq k) i) n HnO).
    exact (Romega_coord_in_R (apply_fun seq n) i HseqnX HiO).
- (** Cauchy tail for seqi via D-Cauchy **)
  let eps.
  assume Heps: eps :e R /\ Rlt 0 eps.
  claim HepsR: eps :e R.
  { exact (andEL (eps :e R) (Rlt 0 eps) Heps). }
  claim HepsPos: Rlt 0 eps.
  { exact (andER (eps :e R) (Rlt 0 eps) Heps). }
  set inv := inv_nat (ordsucc i).
  set eps1 := mul_SNo eps inv.
  claim HsuccO: ordsucc i :e omega.
  { exact (omega_ordsucc i HiO). }
  claim HinvR: inv :e R.
  { exact (inv_nat_real (ordsucc i) HsuccO). }
  claim HinvS: SNo inv.
  { exact (real_SNo inv HinvR). }
  claim HinvNot0: ordsucc i /:e {0}.
  { assume Hin0: ordsucc i :e {0}.
    claim Heq0: ordsucc i = 0.
    { exact (SingE 0 (ordsucc i) Hin0). }
    exact (neq_ordsucc_0 i Heq0). }
  claim HinvIn: ordsucc i :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc i) HsuccO HinvNot0). }
  claim HinvPos: Rlt 0 inv.
  { exact (inv_nat_pos (ordsucc i) HinvIn). }
  claim Heps1R: eps1 :e R.
  { exact (real_mul_SNo eps HepsR inv HinvR). }
  claim HepsS: SNo eps.
  { exact (real_SNo eps HepsR). }
  claim HepsPosS: 0 < eps.
  { exact (RltE_lt 0 eps HepsPos). }
  claim HinvPosS: 0 < inv.
  { exact (RltE_lt 0 inv HinvPos). }
  claim Heps1PosS: 0 < eps1.
  { exact (mul_SNo_pos_pos eps inv HepsS HinvS HepsPosS HinvPosS). }
  claim Heps1Pos: Rlt 0 eps1.
  { exact (RltI 0 eps1 real_0 Heps1R Heps1PosS). }
  claim Heps1pair: eps1 :e R /\ Rlt 0 eps1.
  { apply andI.
    - exact Heps1R.
    - exact Heps1Pos. }
  claim HexN: exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1.
  { exact (Htail eps1 Heps1pair). }
  apply HexN.
  let N. assume HNpair.
  witness N.
  apply andI.
  - exact (andEL (N :e omega)
                 (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                   Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1)
                 HNpair).
  - let m n.
    assume HmO: m :e omega.
    assume HnO: n :e omega.
    assume HNm: N c= m.
    assume HNn: N c= n.
    prove Rlt (apply_fun R_bounded_metric (apply_fun seqi m, apply_fun seqi n)) eps.
    claim HltD: Rlt (apply_fun d (apply_fun seq m, apply_fun seq n)) eps1.
    { exact (andER (N :e omega)
                   (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                     Rlt (apply_fun d (apply_fun seq m0, apply_fun seq n0)) eps1)
                   HNpair m n HmO HnO HNm HNn). }
    claim HseqmX: apply_fun seq m :e X.
    { exact (Hseq m HmO). }
    claim HseqnX: apply_fun seq n :e X.
    { exact (Hseq n HnO). }
    claim Hmnprod: (apply_fun seq m, apply_fun seq n) :e setprod X X.
    { exact (tuple_2_setprod_by_pair_Sigma X X (apply_fun seq m) (apply_fun seq n) HseqmX HseqnX). }
    claim Hdapp: apply_fun d (apply_fun seq m, apply_fun seq n) =
      Romega_D_metric_value (apply_fun seq m) (apply_fun seq n).
    { rewrite (apply_fun_graph (setprod X X)
                               (fun p:set => Romega_D_metric_value (p 0) (p 1))
                               (apply_fun seq m, apply_fun seq n)
                               Hmnprod).
      rewrite (tuple_2_0_eq (apply_fun seq m) (apply_fun seq n)).
      rewrite (tuple_2_1_eq (apply_fun seq m) (apply_fun seq n)).
      reflexivity. }
    claim HltVal: Rlt (Romega_D_metric_value (apply_fun seq m) (apply_fun seq n)) eps1.
    { rewrite <- Hdapp.
      exact HltD. }
    claim Hscaled: Rlt (mul_SNo (R_bounded_distance (apply_fun (apply_fun seq m) i)
                                                   (apply_fun (apply_fun seq n) i)) inv)
                       eps1.
    { exact (Romega_D_metric_value_lt_implies_scaled_lt (apply_fun seq m) (apply_fun seq n) i eps1
                                                       HseqmX HseqnX HiO HltVal). }
    claim HscaledS: mul_SNo (R_bounded_distance (apply_fun (apply_fun seq m) i)
                                              (apply_fun (apply_fun seq n) i)) inv
                   < eps1.
    { exact (RltE_lt (mul_SNo (R_bounded_distance (apply_fun (apply_fun seq m) i)
                                                (apply_fun (apply_fun seq n) i)) inv)
                    eps1
                    Hscaled). }
    set bd := R_bounded_distance (apply_fun (apply_fun seq m) i) (apply_fun (apply_fun seq n) i).
    claim HbdR: bd :e R.
    { exact (R_bounded_distance_in_R (apply_fun (apply_fun seq m) i) (apply_fun (apply_fun seq n) i)
             (Romega_coord_in_R (apply_fun seq m) i HseqmX HiO)
             (Romega_coord_in_R (apply_fun seq n) i HseqnX HiO)). }
    claim HbdS: SNo bd.
    { exact (real_SNo bd HbdR). }
    claim HepsInvEq: eps1 = mul_SNo eps inv.
    { reflexivity. }
    claim Hbdlt: bd < eps.
    { apply (SNoLt_trichotomy_or_impred bd eps HbdS HepsS (bd < eps)).
      - assume Hc0: bd < eps.
        exact Hc0.
      - assume Hc0: bd = eps.
        claim Heqmul: mul_SNo bd inv = eps1.
        { rewrite Hc0.
          rewrite <- HepsInvEq.
          reflexivity. }
        claim Hbad: mul_SNo bd inv < mul_SNo bd inv.
        { rewrite Heqmul at 2.
          exact HscaledS. }
        exact (FalseE ((SNoLt_irref (mul_SNo bd inv)) Hbad) (bd < eps)).
      - assume Hc0: eps < bd.
        claim Hmul: mul_SNo eps inv < mul_SNo bd inv.
        { exact (pos_mul_SNo_Lt' eps bd inv HepsS HbdS HinvS HinvPosS Hc0). }
        claim Hmul2: eps1 < mul_SNo bd inv.
        { rewrite HepsInvEq.
          exact Hmul. }
        claim Hbad: mul_SNo eps inv < mul_SNo eps inv.
        { rewrite <- HepsInvEq at 1.
          rewrite <- HepsInvEq at 2.
          exact (SNoLt_tra eps1 (mul_SNo bd inv) eps1
                           (SNo_mul_SNo eps inv HepsS HinvS)
                           (SNo_mul_SNo bd inv HbdS HinvS)
                           (SNo_mul_SNo eps inv HepsS HinvS)
                           Hmul2
                           HscaledS). }
        exact (FalseE ((SNoLt_irref eps1) Hbad) (bd < eps)). }
    claim HbdltR: Rlt bd eps.
    { exact (RltI bd eps HbdR HepsR Hbdlt). }
    (** rewrite the goal to bounded_distance and use the bound **)
    claim HseqiDef: seqi = graph omega (fun k:set => apply_fun (apply_fun seq k) i).
    { reflexivity. }
    rewrite HseqiDef.
    rewrite (apply_fun_graph omega (fun k:set => apply_fun (apply_fun seq k) i) m HmO).
    rewrite (apply_fun_graph omega (fun k:set => apply_fun (apply_fun seq k) i) n HnO).
    rewrite (R_bounded_metric_apply (apply_fun (apply_fun seq m) i) (apply_fun (apply_fun seq n) i)
                                    (Romega_coord_in_R (apply_fun seq m) i HseqmX HiO)
                                    (Romega_coord_in_R (apply_fun seq n) i HseqnX HiO)).
    exact HbdltR.
Qed.

(** helper: a graph omega -> R is a point of R_omega_space **)
Theorem graph_omega_to_R_in_Romega_space : forall g:set->set,
  (forall i:set, i :e omega -> g i :e R) ->
  graph omega g :e R_omega_space.
let g.
assume Hg: forall i:set, i :e omega -> g i :e R.
set Xi := const_space_family omega R R_standard_topology.
prove graph omega g :e product_space omega Xi.
claim Hdef: product_space omega Xi =
  {f :e Power (setprod omega (space_family_union omega Xi))|
     total_function_on f omega (space_family_union omega Xi) /\ functional_graph f /\
     forall i0:set, i0 :e omega -> apply_fun f i0 :e space_family_set Xi i0}.
{ reflexivity. }
rewrite Hdef.
apply SepI.
- (** graph omega g is a subset of omega×(space_family_union ...) **)
  claim HUnion: space_family_union omega Xi = R.
  { exact space_family_union_const_Romega. }
  rewrite HUnion.
  apply (PowerI (setprod omega R) (graph omega g)).
  let p. assume Hp: p :e graph omega g.
  prove p :e setprod omega R.
  apply (ReplE_impred omega (fun i0:set => (i0, g i0)) p Hp (p :e setprod omega R)).
  let i. assume HiO: i :e omega.
  assume Hpeq: p = (i, g i).
  rewrite Hpeq.
  exact (tuple_2_setprod_by_pair_Sigma omega R i (g i) HiO (Hg i HiO)).
- (** total_function_on + functional_graph + coordinate-in-R **)
  prove total_function_on (graph omega g) omega (space_family_union omega Xi) /\ functional_graph (graph omega g) /\
        forall i0:set, i0 :e omega -> apply_fun (graph omega g) i0 :e space_family_set Xi i0.
  apply andI.
  - apply andI.
    + claim HUnion2: space_family_union omega Xi = R.
      { exact space_family_union_const_Romega. }
      rewrite HUnion2.
      exact (total_function_on_graph omega R g Hg).
    + exact (functional_graph_graph omega g).
  - let i. assume HiO: i :e omega.
    prove apply_fun (graph omega g) i :e space_family_set Xi i.
    rewrite (space_family_set_const_Romega i HiO).
    rewrite (apply_fun_graph omega g i HiO).
    exact (Hg i HiO).
Qed.

(** helper: bounded-metric open balls are standard-open in R **)
(** LATEX VERSION: Each bounded-metric open ball is open in the standard topology on R. **)
Theorem open_ball_R_bounded_metric_in_R_standard_topology : forall c r:set,
  c :e R -> r :e R -> Rlt 0 r ->
  open_ball R R_bounded_metric c r :e R_standard_topology.
let c r.
assume HcR: c :e R.
assume HrR: r :e R.
assume Hrpos: Rlt 0 r.
claim HcS: SNo c.
{ exact (real_SNo c HcR). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim HrposS: 0 < r.
{ exact (RltE_lt 0 r Hrpos). }
apply (SNoLt_trichotomy_or_impred r 1 HrS SNo_1 (open_ball R R_bounded_metric c r :e R_standard_topology)).
- assume Hrlt1S: r < 1.
  claim Hrlt1: Rlt r 1.
  { exact (RltI r 1 HrR real_1 Hrlt1S). }
  claim HmrcR: minus_SNo r :e R.
  { exact (real_minus_SNo r HrR). }
  claim HmrcS: SNo (minus_SNo r).
  { exact (real_SNo (minus_SNo r) HmrcR). }
  claim Hneglt0: minus_SNo r < 0.
  { rewrite <- minus_SNo_0.
    exact (minus_SNo_Lt_contra 0 r SNo_0 HrS HrposS). }
  claim Hneglt: minus_SNo r < r.
  { exact (SNoLt_tra (minus_SNo r) 0 r HmrcS SNo_0 HrS Hneglt0 HrposS). }
  claim HcprR: add_SNo c r :e R.
  { exact (real_add_SNo c HcR r HrR). }
  claim HcmrR: add_SNo c (minus_SNo r) :e R.
  { exact (real_add_SNo c HcR (minus_SNo r) HmrcR). }
  claim HcmrS: SNo (add_SNo c (minus_SNo r)).
  { exact (real_SNo (add_SNo c (minus_SNo r)) HcmrR). }
  claim HcprS: SNo (add_SNo c r).
  { exact (real_SNo (add_SNo c r) HcprR). }
  claim HltS: add_SNo c (minus_SNo r) < add_SNo c r.
  { exact (add_SNo_Lt2 c (minus_SNo r) r HcS HmrcS HrS Hneglt). }
  claim Hlt: Rlt (add_SNo c (minus_SNo r)) (add_SNo c r).
  { exact (RltI (add_SNo c (minus_SNo r)) (add_SNo c r) HcmrR HcprR HltS). }
  rewrite (open_ball_R_bounded_metric_eq_open_interval c r HcR HrR Hrpos Hrlt1).
  exact (open_interval_in_R_standard_topology (add_SNo c (minus_SNo r)) (add_SNo c r) Hlt).
- assume HrEq: r = 1.
  rewrite HrEq.
  rewrite (open_ball_R_bounded_metric_r1_eq_open_interval c HcR).
  claim Hm1R: minus_SNo 1 :e R.
  { exact (real_minus_SNo 1 real_1). }
  claim Hm1S: SNo (minus_SNo 1).
  { exact (real_SNo (minus_SNo 1) Hm1R). }
  claim Hm1lt0: minus_SNo 1 < 0.
  { exact minus_1_lt_0. }
  claim Hm1lt1: minus_SNo 1 < 1.
  { exact (SNoLt_tra (minus_SNo 1) 0 1 Hm1S SNo_0 SNo_1 Hm1lt0 SNoLt_0_1). }
  claim HcprR: add_SNo c 1 :e R.
  { exact (real_add_SNo c HcR 1 real_1). }
  claim HcmrR: add_SNo c (minus_SNo 1) :e R.
  { exact (real_add_SNo c HcR (minus_SNo 1) Hm1R). }
  claim HcmrS: SNo (add_SNo c (minus_SNo 1)).
  { exact (real_SNo (add_SNo c (minus_SNo 1)) HcmrR). }
  claim HcprS: SNo (add_SNo c 1).
  { exact (real_SNo (add_SNo c 1) HcprR). }
  claim HltS: add_SNo c (minus_SNo 1) < add_SNo c 1.
  { exact (add_SNo_Lt2 c (minus_SNo 1) 1 HcS Hm1S SNo_1 Hm1lt1). }
  claim Hlt: Rlt (add_SNo c (minus_SNo 1)) (add_SNo c 1).
  { exact (RltI (add_SNo c (minus_SNo 1)) (add_SNo c 1) HcmrR HcprR HltS). }
  exact (open_interval_in_R_standard_topology (add_SNo c (minus_SNo 1)) (add_SNo c 1) Hlt).
- assume H1ltrS: 1 < r.
  claim H1ltr: Rlt 1 r.
  { exact (RltI 1 r real_1 HrR H1ltrS). }
  rewrite (open_ball_R_bounded_metric_eq_R_if_1_lt c r HcR HrR H1ltr).
  exact (topology_has_X R R_standard_topology (R_standard_topology_is_topology_local)).
Qed.

(** helper: standard open intervals are open in the bounded metric topology **)
(** LATEX VERSION: Every open interval (a,b) is open in the bounded-metric topology on R. **)
Theorem open_interval_in_metric_topology_R_bounded_metric : forall a b:set,
  a :e R -> b :e R ->
  open_interval a b :e metric_topology R R_bounded_metric.
let a b.
assume HaR: a :e R.
assume HbR: b :e R.
set B := famunion R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}).
prove open_interval a b :e generated_topology R B.
claim HdefGT: generated_topology R B =
  {U :e Power R|forall x :e U, exists b0 :e B, x :e b0 /\ b0 c= U}.
{ reflexivity. }
rewrite HdefGT.
apply SepI.
- (** open_interval a b is a subset of R **)
  apply PowerI.
  let x. assume Hx: x :e open_interval a b.
  exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx).
- (** neighborhood property using bounded-metric balls **)
  let x. assume Hx: x :e open_interval a b.
  prove exists b0 :e B, x :e b0 /\ b0 c= open_interval a b.
  claim HxR: x :e R.
  { exact (SepE1 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hxab: Rlt a x /\ Rlt x b.
  { exact (SepE2 R (fun x0:set => Rlt a x0 /\ Rlt x0 b) x Hx). }
  claim Hax: Rlt a x.
  { exact (andEL (Rlt a x) (Rlt x b) Hxab). }
  claim Hxb: Rlt x b.
  { exact (andER (Rlt a x) (Rlt x b) Hxab). }
  claim HaS: SNo a.
  { exact (real_SNo a HaR). }
  claim HbS: SNo b.
  { exact (real_SNo b HbR). }
  claim HxS: SNo x.
  { exact (real_SNo x HxR). }
  claim HaxS: a < x.
  { exact (RltE_lt a x Hax). }
  claim HxbS: x < b.
  { exact (RltE_lt x b Hxb). }
  set dx := add_SNo x (minus_SNo a).
  set dy := add_SNo b (minus_SNo x).
  claim HmaR: minus_SNo a :e R.
  { exact (real_minus_SNo a HaR). }
  claim HmxR: minus_SNo x :e R.
  { exact (real_minus_SNo x HxR). }
  claim HdxR: dx :e R.
  { exact (real_add_SNo x HxR (minus_SNo a) HmaR). }
  claim HdyR: dy :e R.
  { exact (real_add_SNo b HbR (minus_SNo x) HmxR). }
  claim HmaS: SNo (minus_SNo a).
  { exact (real_SNo (minus_SNo a) HmaR). }
  claim HmxS: SNo (minus_SNo x).
  { exact (real_SNo (minus_SNo x) HmxR). }
  claim HdxS: SNo dx.
  { exact (real_SNo dx HdxR). }
  claim HdyS: SNo dy.
  { exact (real_SNo dy HdyR). }
  (** dx>0 and dy>0 **)
  claim H0ltdxS: 0 < dx.
  { claim H0aLt: add_SNo 0 a < x.
    { rewrite (add_SNo_0L a HaS).
      exact HaxS. }
    exact (add_SNo_minus_Lt2b x a 0 HxS HaS SNo_0 H0aLt). }
  claim H0ltdyS: 0 < dy.
  { claim H0xLt: add_SNo 0 x < b.
    { rewrite (add_SNo_0L x HxS).
      exact HxbS. }
    exact (add_SNo_minus_Lt2b b x 0 HbS HxS SNo_0 H0xLt). }
  claim H0ltdx: Rlt 0 dx.
  { exact (RltI 0 dx real_0 HdxR H0ltdxS). }
  claim H0ltdy: Rlt 0 dy.
  { exact (RltI 0 dy real_0 HdyR H0ltdyS). }
  (** choose r3 below dx, dy, 1, 1 **)
  claim Hexr: exists r3:set, r3 :e R /\ Rlt 0 r3 /\ Rlt r3 dx /\ Rlt r3 dy /\ Rlt r3 1 /\ Rlt r3 1.
  { exact (exists_eps_lt_four_pos_Euclid dx dy 1 1 HdxR HdyR real_1 real_1 H0ltdx H0ltdy Rlt_0_1 Rlt_0_1). }
  apply Hexr.
  let r3. assume Hr3: r3 :e R /\ Rlt 0 r3 /\ Rlt r3 dx /\ Rlt r3 dy /\ Rlt r3 1 /\ Rlt r3 1.
  (** Hr3 is left-associative: (((((A/\B)/\C)/\D)/\E)/\F) **)
  claim Hr3_ABCDE: ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) /\ Rlt r3 1).
  { exact (andEL ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) /\ Rlt r3 1) (Rlt r3 1) Hr3). }
  claim Hr3_F: Rlt r3 1.
  { exact (andER ((((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) /\ Rlt r3 1) (Rlt r3 1) Hr3). }
  claim Hr3_ABCD: (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy).
  { exact (andEL (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) (Rlt r3 1) Hr3_ABCDE). }
  claim Hr3_E: Rlt r3 1.
  { exact (andER (((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) /\ Rlt r3 dy) (Rlt r3 1) Hr3_ABCDE). }
  claim Hr3_ABC: ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx).
  { exact (andEL ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) (Rlt r3 dy) Hr3_ABCD). }
  claim Hr3_D: Rlt r3 dy.
  { exact (andER ((r3 :e R /\ Rlt 0 r3) /\ Rlt r3 dx) (Rlt r3 dy) Hr3_ABCD). }
  claim Hr3_AB: r3 :e R /\ Rlt 0 r3.
  { exact (andEL (r3 :e R /\ Rlt 0 r3) (Rlt r3 dx) Hr3_ABC). }
  claim Hr3_C: Rlt r3 dx.
  { exact (andER (r3 :e R /\ Rlt 0 r3) (Rlt r3 dx) Hr3_ABC). }
  claim Hr3R: r3 :e R.
  { exact (andEL (r3 :e R) (Rlt 0 r3) Hr3_AB). }
  claim Hr3pos: Rlt 0 r3.
  { exact (andER (r3 :e R) (Rlt 0 r3) Hr3_AB). }
  claim Hr3ltDx: Rlt r3 dx.
  { exact Hr3_C. }
  claim Hr3ltDy: Rlt r3 dy.
  { exact Hr3_D. }
  claim Hr3lt1: Rlt r3 1.
  { exact Hr3_E. }
  set ball := open_ball R R_bounded_metric x r3.
  witness ball.
  apply andI.
  - (** ball :e B **)
    claim HballIn: ball :e {open_ball R R_bounded_metric x rr|rr :e R, Rlt 0 rr}.
    { exact (ReplSepI R (fun rr:set => Rlt 0 rr) (fun rr:set => open_ball R R_bounded_metric x rr) r3 Hr3R Hr3pos). }
    exact (famunionI R (fun x0:set => {open_ball R R_bounded_metric x0 rr|rr :e R, Rlt 0 rr}) x ball HxR HballIn).
  - apply andI.
    + (** x :e ball **)
      exact (center_in_open_ball R R_bounded_metric x r3 R_bounded_metric_is_metric_on HxR Hr3pos).
    + (** ball c= open_interval a b **)
      rewrite (open_ball_R_bounded_metric_eq_open_interval x r3 HxR Hr3R Hr3pos Hr3lt1).
      let y. assume HyB: y :e open_interval (add_SNo x (minus_SNo r3)) (add_SNo x r3).
      prove y :e open_interval a b.
      claim HyR: y :e R.
      { exact (SepE1 R (fun y0:set => Rlt (add_SNo x (minus_SNo r3)) y0 /\ Rlt y0 (add_SNo x r3)) y HyB). }
      claim HyConj: Rlt (add_SNo x (minus_SNo r3)) y /\ Rlt y (add_SNo x r3).
      { exact (SepE2 R (fun y0:set => Rlt (add_SNo x (minus_SNo r3)) y0 /\ Rlt y0 (add_SNo x r3)) y HyB). }
      claim HyLeft: Rlt (add_SNo x (minus_SNo r3)) y.
      { exact (andEL (Rlt (add_SNo x (minus_SNo r3)) y) (Rlt y (add_SNo x r3)) HyConj). }
      claim HyRight: Rlt y (add_SNo x r3).
      { exact (andER (Rlt (add_SNo x (minus_SNo r3)) y) (Rlt y (add_SNo x r3)) HyConj). }
      claim Hr3S: SNo r3.
      { exact (real_SNo r3 Hr3R). }
      claim Hmxr3S: SNo (minus_SNo r3).
      { exact (SNo_minus_SNo r3 Hr3S). }
      claim Hxmr3R: add_SNo x (minus_SNo r3) :e R.
      { exact (real_add_SNo x HxR (minus_SNo r3) (real_minus_SNo r3 Hr3R)). }
      claim Hxpr3R: add_SNo x r3 :e R.
      { exact (real_add_SNo x HxR r3 Hr3R). }
      claim Haxmr3S: a < add_SNo x (minus_SNo r3).
      { claim Hr3dxS: r3 < dx.
	        { exact (RltE_lt r3 dx Hr3ltDx). }
	        claim Hr3plusA_lt_x: add_SNo r3 a < x.
	        { exact (add_SNo_minus_Lt2 x a r3 HxS HaS (real_SNo r3 Hr3R) Hr3dxS). }
	        claim Ha_plus_r3_lt_x: add_SNo a r3 < x.
	        { rewrite <- (add_SNo_com r3 a (real_SNo r3 Hr3R) HaS).
	          exact Hr3plusA_lt_x. }
        exact (add_SNo_minus_Lt2b x r3 a HxS (real_SNo r3 Hr3R) HaS Ha_plus_r3_lt_x). }
      claim Hxpr3ltbS: add_SNo x r3 < b.
      { claim Hr3dyS: r3 < dy.
	        { exact (RltE_lt r3 dy Hr3ltDy). }
	        claim Hr3plusX_lt_b: add_SNo r3 x < b.
	        { exact (add_SNo_minus_Lt2 b x r3 HbS HxS (real_SNo r3 Hr3R) Hr3dyS). }
	        rewrite <- (add_SNo_com r3 x (real_SNo r3 Hr3R) HxS) at 1.
	        exact Hr3plusX_lt_b. }
      claim Haxmr3: Rlt a (add_SNo x (minus_SNo r3)).
      { exact (RltI a (add_SNo x (minus_SNo r3)) HaR Hxmr3R Haxmr3S). }
      claim Hxpr3ltb: Rlt (add_SNo x r3) b.
      { exact (RltI (add_SNo x r3) b Hxpr3R HbR Hxpr3ltbS). }
      claim Hay: Rlt a y.
      { exact (Rlt_tra a (add_SNo x (minus_SNo r3)) y Haxmr3 HyLeft). }
      claim Hyb: Rlt y b.
      { exact (Rlt_tra y (add_SNo x r3) b HyRight Hxpr3ltb). }
      exact (SepI R (fun y0:set => Rlt a y0 /\ Rlt y0 b) y HyR (andI (Rlt a y) (Rlt y b) Hay Hyb)).
Qed.

(** helper: the bounded metric induces the standard topology on R **)
Theorem metric_topology_R_bounded_metric_eq_R_standard_topology :
  metric_topology R R_bounded_metric = R_standard_topology.
prove metric_topology R R_bounded_metric = R_standard_topology.
apply set_ext.
- let U. assume HU: U :e metric_topology R R_bounded_metric.
  prove U :e R_standard_topology.
  set B := famunion R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}).
  claim Htop: topology_on R R_standard_topology.
  { exact (R_standard_topology_is_topology_local). }
  claim HBsub: forall b0 :e B, b0 :e R_standard_topology.
  { let b0. assume Hb0: b0 :e B.
    apply (famunionE_impred R (fun x0:set => {open_ball R R_bounded_metric x0 r0|r0 :e R, Rlt 0 r0}) b0 Hb0
           (b0 :e R_standard_topology)).
    let c. assume HcR: c :e R.
    assume Hb0In: b0 :e {open_ball R R_bounded_metric c r0|r0 :e R, Rlt 0 r0}.
    apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball R R_bounded_metric c r0)
           b0 Hb0In (b0 :e R_standard_topology)).
    let r0. assume Hr0R: r0 :e R.
    assume Hr0pos: Rlt 0 r0.
    assume Hb0eq: b0 = open_ball R R_bounded_metric c r0.
    rewrite Hb0eq.
    exact (open_ball_R_bounded_metric_in_R_standard_topology c r0 HcR Hr0R Hr0pos). }
  claim Hsub: generated_topology R B c= R_standard_topology.
  { exact (generated_topology_finer_weak R B R_standard_topology Htop HBsub). }
  exact (Hsub U HU).
- let U. assume HU: U :e R_standard_topology.
  prove U :e metric_topology R R_bounded_metric.
  claim Htop: topology_on R (metric_topology R R_bounded_metric).
  { exact (metric_topology_is_topology R R_bounded_metric R_bounded_metric_is_metric_on). }
  claim HBsub: forall b0 :e R_standard_basis, b0 :e metric_topology R R_bounded_metric.
  { let b0. assume Hb0: b0 :e R_standard_basis.
    claim Hexa: exists a0 :e R, b0 :e {open_interval a0 bb|bb :e R}.
    { exact (famunionE R (fun a1:set => {open_interval a1 bb|bb :e R}) b0 Hb0). }
    apply Hexa.
    let a0. assume Hapair: a0 :e R /\ b0 :e {open_interval a0 bb|bb :e R}.
    claim Ha0R: a0 :e R.
    { exact (andEL (a0 :e R) (b0 :e {open_interval a0 bb|bb :e R}) Hapair). }
    claim Hb0Fam: b0 :e {open_interval a0 bb|bb :e R}.
    { exact (andER (a0 :e R) (b0 :e {open_interval a0 bb|bb :e R}) Hapair). }
    claim Hexb: exists bb :e R, b0 = open_interval a0 bb.
    { exact (ReplE R (fun bb0:set => open_interval a0 bb0) b0 Hb0Fam). }
    apply Hexb.
    let bb. assume Hbpair: bb :e R /\ b0 = open_interval a0 bb.
    claim HbbR: bb :e R.
    { exact (andEL (bb :e R) (b0 = open_interval a0 bb) Hbpair). }
    claim Hb0eq: b0 = open_interval a0 bb.
    { exact (andER (bb :e R) (b0 = open_interval a0 bb) Hbpair). }
    rewrite Hb0eq.
    exact (open_interval_in_metric_topology_R_bounded_metric a0 bb Ha0R HbbR). }
  claim Hsub: generated_topology R R_standard_basis c= metric_topology R R_bounded_metric.
  { exact (generated_topology_finer_weak R R_standard_basis (metric_topology R R_bounded_metric) Htop HBsub). }
  claim HUgen: U :e generated_topology R R_standard_basis.
  { rewrite <- (R_standard_topology_def_eq).
    exact HU. }
  exact (Hsub U HUgen).
Qed.

(** Helper: the real line is completely regular in the standard topology **)
(** LATEX VERSION: R is metrizable, hence completely regular. **)
Theorem R_standard_topology_completely_regular :
  completely_regular_space R R_standard_topology.
prove completely_regular_space R R_standard_topology.
rewrite <- metric_topology_R_bounded_metric_eq_R_standard_topology.
exact (metric_spaces_completely_regular R R_bounded_metric R_bounded_metric_is_metric_on).
Qed.

(** helper: abs-Cauchy sequences on R converge in the standard topology (completeness of R) **)
(** LATEX VERSION: Every Cauchy sequence in ℝ (with respect to |x-y|) converges in the standard topology. **)
Theorem abs_Cauchy_sequence_converges_R_standard_topology : forall seq:set,
  sequence_on seq R ->
  (forall eps:set, eps :e R /\ Rlt 0 eps ->
     exists N:set, N :e omega /\
       forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
         abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps) ->
  exists x:set, converges_to R R_standard_topology seq x.
let seq.
assume Hseq: sequence_on seq R.
	assume HabC: forall eps:set, eps :e R /\ Rlt 0 eps ->
	  exists N:set, N :e omega /\
	    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
	      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
	(** use R_lub_exists on a tail set to obtain a candidate limit **)
	claim H1pair: 1 :e R /\ Rlt 0 1.
	{ apply andI.
	  - exact real_1.
	  - exact Rlt_0_1. }
	apply (HabC 1 H1pair).
	let N0. assume HN0pair.
	claim HN0omega: N0 :e omega.
	{ exact (andEL (N0 :e omega)
	               (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
	                 abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1)
	               HN0pair). }
	claim Htail1: forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
	  abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1.
	{ exact (andER (N0 :e omega)
	               (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
	                 abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < 1)
	               HN0pair). }
	claim Hx0R: apply_fun seq N0 :e R.
	{ exact (Hseq N0 HN0omega). }
	set u := add_SNo 1 (apply_fun seq N0).
	claim HuR: u :e R.
	{ exact (real_add_SNo 1 real_1 (apply_fun seq N0) Hx0R). }
	(** Set A as the set of eventual lower bounds of the tail of seq. **)
	set A := {x :e R |
	  exists N:set, N :e omega /\
	    forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n)}.
	claim HAinR: forall x:set, x :e A -> x :e R.
	{ let x. assume HxA: x :e A.
	  exact (SepE1 R
	               (fun x0 : set => exists N:set, N :e omega /\
	                 forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
	               x
	               HxA). }
	claim HAnen: exists a0:set, a0 :e A.
	{ set a0 := add_SNo (minus_SNo 1) (apply_fun seq N0).
	  claim Ha0R: a0 :e R.
	  { exact (real_add_SNo (minus_SNo 1) (real_minus_SNo 1 real_1) (apply_fun seq N0) Hx0R). }
	  witness a0.
	  apply (SepI R
	               (fun x0 : set => exists N:set, N :e omega /\
	                 forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
	               a0
	               Ha0R).
	  witness N0.
	  apply andI.
	  - exact HN0omega.
	  - let n. assume HnO: n :e omega.
	    assume HN0subn: N0 c= n.
	    claim Habslt1: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0))) < 1.
	    { exact (Htail1 n N0 HnO HN0omega HN0subn (Subq_ref N0)). }
	    claim HnR: apply_fun seq n :e R.
	    { exact (Hseq n HnO). }
	    claim HnS: SNo (apply_fun seq n).
	    { exact (real_SNo (apply_fun seq n) HnR). }
	    claim Hx0S: SNo (apply_fun seq N0).
	    { exact (real_SNo (apply_fun seq N0) Hx0R). }
	    claim HmS: SNo (minus_SNo (apply_fun seq N0)).
	    { exact (SNo_minus_SNo (apply_fun seq N0) Hx0S). }
	    set t := add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)).
	    claim HtS: SNo t.
	    { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)) HnS HmS). }
	    claim Hneglt1: minus_SNo t < 1.
	    { exact (abs_SNo_lt_imp_neg_lt t 1 HtS SNo_1 SNoLt_0_1 Habslt1). }
	    claim Hm1lt: minus_SNo 1 < t.
	    { claim HmtS: SNo (minus_SNo t).
	      { exact (SNo_minus_SNo t HtS). }
	      claim HmmtS: SNo (minus_SNo (minus_SNo t)).
	      { exact (SNo_minus_SNo (minus_SNo t) HmtS). }
	      claim Hinv1: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = 0.
	      { exact (add_SNo_minus_SNo_linv (minus_SNo t) HmtS). }
	      claim Hinv2: add_SNo t (minus_SNo t) = 0.
	      { exact (add_SNo_minus_SNo_rinv t HtS). }
	      claim Hnegneg: minus_SNo (minus_SNo t) = t.
	      { claim Heq: add_SNo (minus_SNo (minus_SNo t)) (minus_SNo t) = add_SNo t (minus_SNo t).
	        { rewrite Hinv1. rewrite Hinv2. reflexivity. }
	        exact (add_SNo_cancel_R (minus_SNo (minus_SNo t)) (minus_SNo t) t HmmtS HmtS HtS Heq). }
	      claim Hm1lt2: minus_SNo 1 < minus_SNo (minus_SNo t).
	      { exact (minus_SNo_Lt_contra (minus_SNo t) 1 HmtS SNo_1 Hneglt1). }
	      rewrite <- Hnegneg.
	      exact Hm1lt2. }
	    claim Hm1S: SNo (minus_SNo 1).
	    { exact (SNo_minus_SNo 1 SNo_1). }
	    claim Htlt: add_SNo (minus_SNo 1) (apply_fun seq N0) < apply_fun seq n.
	    { exact (add_SNo_minus_Lt2 (apply_fun seq n) (apply_fun seq N0) (minus_SNo 1) HnS Hx0S Hm1S Hm1lt). }
	    exact (Rlt_implies_Rle a0 (apply_fun seq n)
	                           (RltI a0 (apply_fun seq n) Ha0R HnR Htlt)). }
	(** tail upper bound by u = seq(N0)+1 **)
	claim HtailLeU: forall n:set, n :e omega -> N0 c= n -> Rle (apply_fun seq n) u.
	{ let n. assume HnO: n :e omega. assume HN0subn: N0 c= n.
	  claim Habslt1: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0))) < 1.
	  { exact (Htail1 n N0 HnO HN0omega HN0subn (Subq_ref N0)). }
	  claim HnR: apply_fun seq n :e R.
	  { exact (Hseq n HnO). }
	  claim HnS: SNo (apply_fun seq n).
	  { exact (real_SNo (apply_fun seq n) HnR). }
	  claim Hx0S: SNo (apply_fun seq N0).
	  { exact (real_SNo (apply_fun seq N0) Hx0R). }
	  claim HmS: SNo (minus_SNo (apply_fun seq N0)).
	  { exact (SNo_minus_SNo (apply_fun seq N0) Hx0S). }
	  set t := add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)).
	  claim HtS: SNo t.
	  { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq N0)) HnS HmS). }
	  claim Htlt1: t < 1.
	  { exact (abs_SNo_lt_imp_lt t 1 HtS SNo_1 SNoLt_0_1 Habslt1). }
	  claim Htltu: apply_fun seq n < u.
	  { exact (add_SNo_minus_Lt1 (apply_fun seq n) (apply_fun seq N0) 1 HnS Hx0S SNo_1 Htlt1). }
	  claim HxRlt: Rlt (apply_fun seq n) u.
	  { exact (RltI (apply_fun seq n) u HnR HuR Htltu). }
	  exact (Rlt_implies_Rle (apply_fun seq n) u HxRlt). }
	(** show A is bounded above by u **)
	claim HubExists: exists u0:set, u0 :e R /\ forall x:set, x :e A -> x :e R -> Rle x u0.
	{ witness u.
	  apply andI.
	  - exact HuR.
	  - let x. assume HxA: x :e A. assume HxR: x :e R.
	    claim Hxprop: exists N:set, N :e omega /\
	      forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n).
	    { exact (SepE2 R
	                 (fun x0 : set => exists N:set, N :e omega /\
	                   forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
	                 x
	                 HxA). }
	    apply Hxprop.
	    let N. assume HNpair2.
	    claim HNomega: N :e omega.
	    { exact (andEL (N :e omega)
	                   (forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n))
	                   HNpair2). }
	    claim HNtail: forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n).
	    { exact (andER (N :e omega)
	                   (forall n:set, n :e omega -> N c= n -> Rle x (apply_fun seq n))
	                   HNpair2). }
	    set n0 := ordsucc (N :\/: N0).
	    claim HmaxO: N :\/: N0 :e omega.
	    { exact (omega_binunion N N0 HNomega HN0omega). }
	    claim Hn0O: n0 :e omega.
	    { exact (omega_ordsucc (N :\/: N0) HmaxO). }
	    claim HNsubn0: N c= n0.
	    { let t. assume Ht: t :e N.
	      claim Htmax: t :e (N :\/: N0).
	      { exact (binunionI1 N N0 t Ht). }
	      claim Htn0: t :e n0.
	      { exact (ordsuccI1 (N :\/: N0) t Htmax). }
	      exact Htn0. }
	    claim HN0subn0: N0 c= n0.
	    { let t. assume Ht: t :e N0.
	      claim Htmax: t :e (N :\/: N0).
	      { exact (binunionI2 N N0 t Ht). }
	      claim Htn0: t :e n0.
	      { exact (ordsuccI1 (N :\/: N0) t Htmax). }
	      exact Htn0. }
	    claim Hxlen0: Rle x (apply_fun seq n0).
	    { exact (HNtail n0 Hn0O HNsubn0). }
	    claim Hn0R: apply_fun seq n0 :e R.
	    { exact (Hseq n0 Hn0O). }
	    claim Hn0leu: Rle (apply_fun seq n0) u.
	    { exact (HtailLeU n0 Hn0O HN0subn0). }
	    exact (Rle_tra x (apply_fun seq n0) u Hxlen0 Hn0leu). }
		apply (R_lub_exists A HAnen HAinR HubExists).
		let l. assume Hlub: R_lub A l.
		witness l.
		claim HlR: l :e R.
		{ exact (R_lub_in_R A l Hlub). }
		prove converges_to R R_standard_topology seq l.
		prove topology_on R R_standard_topology /\ sequence_on seq R /\ l :e R /\
		  forall U:set, U :e R_standard_topology -> l :e U ->
		    exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> apply_fun seq n :e U.
		apply andI.
		- apply andI.
		  + apply andI.
		    * exact R_standard_topology_is_topology_local.
		    * exact Hseq.
		  + exact HlR.
		- let U. assume HU: U :e R_standard_topology.
		  assume HlU: l :e U.
		  (** obtain a basis element b with l∈b⊆U **)
		  claim HUprop: forall x :e U, exists b :e R_standard_basis, x :e b /\ b c= U.
		  { exact (SepE2 (Power R)
		               (fun U0 : set => forall x0 :e U0, exists b :e R_standard_basis, x0 :e b /\ b c= U0)
		               U
		               HU). }
		  apply (HUprop l HlU).
		  let b. assume Hbpair.
		  claim HbB: b :e R_standard_basis.
		  { exact (andEL (b :e R_standard_basis) (l :e b /\ b c= U) Hbpair). }
		  claim Hlbsub: l :e b /\ b c= U.
		  { exact (andER (b :e R_standard_basis) (l :e b /\ b c= U) Hbpair). }
		  claim Hlb: l :e b.
		  { exact (andEL (l :e b) (b c= U) Hlbsub). }
		  claim HbsubU: b c= U.
		  { exact (andER (l :e b) (b c= U) Hlbsub). }
		  (** destruct the basis element as an open interval **)
		  claim Hexa: exists a :e R, b :e {open_interval a c|c :e R}.
		  { exact (famunionE R (fun a0 : set => {open_interval a0 c|c :e R}) b HbB). }
		  apply Hexa.
		  let a. assume Hapair.
		  claim HaR: a :e R.
		  { exact (andEL (a :e R) (b :e {open_interval a c|c :e R}) Hapair). }
		  claim Hbfam: b :e {open_interval a c|c :e R}.
		  { exact (andER (a :e R) (b :e {open_interval a c|c :e R}) Hapair). }
		  claim Hexc: exists c :e R, b = open_interval a c.
		  { exact (ReplE R (fun c0 : set => open_interval a c0) b Hbfam). }
		  apply Hexc.
		  let c. assume Hcpair.
		  claim HcR: c :e R.
		  { exact (andEL (c :e R) (b = open_interval a c) Hcpair). }
		  claim Hbeq: b = open_interval a c.
		  { exact (andER (c :e R) (b = open_interval a c) Hcpair). }
		  (** reduce to eventual membership in the interval (a,c) **)
		  claim HlInt: l :e open_interval a c.
		  { rewrite <- Hbeq at 1.
		    exact Hlb. }
		  claim Hltac: Rlt a l /\ Rlt l c.
		  { exact (SepE2 R (fun x0 : set => Rlt a x0 /\ Rlt x0 c) l HlInt). }
		  claim Hlta: Rlt a l.
		  { exact (andEL (Rlt a l) (Rlt l c) Hltac). }
		  claim Hltlc: Rlt l c.
		  { exact (andER (Rlt a l) (Rlt l c) Hltac). }
		  (** get a tail lower bound from the lub of eventual lower bounds **)
		  claim Hlubcore: l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		  { exact (andEL (l :e R /\ forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l)
		                 (forall u0:set, u0 :e R ->
		                   (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 u0) ->
		                   Rle l u0)
		                 Hlub). }
		  claim HubA: forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l.
		  { exact (andER (l :e R) (forall a0:set, a0 :e A -> a0 :e R -> Rle a0 l) Hlubcore). }
			  (** eventual > a: pick x0 in A with a < x0, then use its tail witness **)
			  claim HexLower: exists N:set, N :e omega /\ forall n:set, n :e omega -> N c= n -> Rlt a (apply_fun seq n).
			  { claim HaR2: a :e R.
			    { exact HaR. }
			    claim HlR2: l :e R.
			    { exact HlR. }
			    claim HaS: SNo a.
			    { exact (real_SNo a HaR2). }
			    claim HlS: SNo l.
			    { exact (real_SNo l HlR2). }
			    claim HaltlS: a < l.
			    { exact (RltE_lt a l Hlta). }
			    claim HmaS: SNo (minus_SNo a).
			    { exact (SNo_minus_SNo a HaS). }
			    claim HdiffR: add_SNo l (minus_SNo a) :e R.
			    { exact (real_add_SNo l HlR2 (minus_SNo a) (real_minus_SNo a HaR2)). }
			    claim H0ltdS: 0 < add_SNo (minus_SNo a) l.
			    { claim H0lt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) l.
			      { exact (add_SNo_Lt2 (minus_SNo a) a l HmaS HaS HlS HaltlS). }
			      rewrite <- (add_SNo_minus_SNo_linv a HaS) at 1.
			      exact H0lt. }
			    claim H0ltdS2: 0 < add_SNo l (minus_SNo a).
			    { claim Hcom: add_SNo (minus_SNo a) l = add_SNo l (minus_SNo a).
			      { exact (add_SNo_com (minus_SNo a) l HmaS HlS). }
			      rewrite <- Hcom.
			      exact H0ltdS. }
			    claim Hdpos: Rlt 0 (add_SNo l (minus_SNo a)).
			    { exact (RltI 0 (add_SNo l (minus_SNo a)) real_0 HdiffR H0ltdS2). }
			    (** choose eps0 < l-a and pick x0 in A with l-eps0 < x0 **)
			    claim Hexeps: exists Neps :e omega, eps_ Neps < add_SNo l (minus_SNo a).
			    { exact (exists_eps_lt_pos_Euclid (add_SNo l (minus_SNo a)) HdiffR Hdpos). }
			    apply Hexeps.
			    let Neps. assume HNepspair.
			    claim HNepsO: Neps :e omega.
			    { exact (andEL (Neps :e omega) (eps_ Neps < add_SNo l (minus_SNo a)) HNepspair). }
			    claim Hepslt: eps_ Neps < add_SNo l (minus_SNo a).
			    { exact (andER (Neps :e omega) (eps_ Neps < add_SNo l (minus_SNo a)) HNepspair). }
			    claim HepsR: eps_ Neps :e R.
			    { exact (SNoS_omega_real (eps_ Neps) (SNo_eps_SNoS_omega Neps HNepsO)). }
			    claim HepsposS: 0 < eps_ Neps.
			    { exact (SNo_eps_pos Neps HNepsO). }
			    claim HepsposR: Rlt 0 (eps_ Neps).
			    { exact (RltI 0 (eps_ Neps) real_0 HepsR HepsposS). }
			    claim HepsS: SNo (eps_ Neps).
			    { exact (real_SNo (eps_ Neps) HepsR). }
			    claim Hu0R: add_SNo l (minus_SNo (eps_ Neps)) :e R.
			    { exact (real_add_SNo l HlR2 (minus_SNo (eps_ Neps)) (real_minus_SNo (eps_ Neps) HepsR)). }
			    (** from eps < l-a infer a < l-eps **)
			    claim Hsumlt1: add_SNo (eps_ Neps) a < l.
			    { exact (add_SNo_minus_Lt2 l a (eps_ Neps) HlS HaS HepsS Hepslt). }
			    claim Hsumlt2: add_SNo a (eps_ Neps) < l.
			    { rewrite (add_SNo_com a (eps_ Neps) HaS HepsS).
			      exact Hsumlt1. }
			    claim Haltu0S: a < add_SNo l (minus_SNo (eps_ Neps)).
			    { exact (add_SNo_minus_Lt2b l (eps_ Neps) a HlS HepsS HaS Hsumlt2). }
			    claim Haltu0R: Rlt a (add_SNo l (minus_SNo (eps_ Neps))).
			    { exact (RltI a (add_SNo l (minus_SNo (eps_ Neps))) HaR2 Hu0R Haltu0S). }
			    claim HexAbove: exists x0:set, x0 :e A /\ x0 :e R /\ Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0.
			    { exact (R_lub_approx_from_below A l (eps_ Neps) Hlub HepsR HepsposR). }
			    apply HexAbove.
			    let x0. assume Hx0pack.
			    claim Hx0pair: x0 :e A /\ x0 :e R.
			    { exact (andEL (x0 :e A /\ x0 :e R)
			                   (Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0)
			                   Hx0pack). }
			    claim Hltu0x0: Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0.
			    { exact (andER (x0 :e A /\ x0 :e R)
			                   (Rlt (add_SNo l (minus_SNo (eps_ Neps))) x0)
			                   Hx0pack). }
			    claim Hx0A: x0 :e A.
			    { exact (andEL (x0 :e A) (x0 :e R) Hx0pair). }
			    claim Hx0R: x0 :e R.
			    { exact (andER (x0 :e A) (x0 :e R) Hx0pair). }
			    claim Haltax0: Rlt a x0.
			    { exact (Rlt_tra a (add_SNo l (minus_SNo (eps_ Neps))) x0 Haltu0R Hltu0x0). }
			    (** unpack x0 ∈ A as an eventual lower bound **)
			    claim Hx0prop: exists N:set, N :e omega /\
			      forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n).
			    { exact (SepE2 R
			                 (fun x1 : set => exists N:set, N :e omega /\
			                   forall n:set, n :e omega -> N c= n -> Rle x1 (apply_fun seq n))
			                 x0
			                 Hx0A). }
			    apply Hx0prop.
			    let N. assume HNpair3.
			    witness N.
			    apply andI.
			    - exact (andEL (N :e omega)
			                   (forall n:set, n :e omega -> N c= n -> Rle x0 (apply_fun seq n))
			                   HNpair3).
			    - let n. assume HnO: n :e omega. assume HNsubn: N c= n.
			      claim Hx0len: Rle x0 (apply_fun seq n).
			      { exact (andER (N :e omega)
			                     (forall n0:set, n0 :e omega -> N c= n0 -> Rle x0 (apply_fun seq n0))
			                     HNpair3 n HnO HNsubn). }
			      exact (Rlt_Rle_tra a x0 (apply_fun seq n) Haltax0 Hx0len). }
		  apply HexLower.
		  let Nlow. assume HNlowpair.
		  claim HNlow: Nlow :e omega.
		  { exact (andEL (Nlow :e omega)
		                 (forall n:set, n :e omega -> Nlow c= n -> Rlt a (apply_fun seq n))
		                 HNlowpair). }
		  claim Hlowprop: forall n:set, n :e omega -> Nlow c= n -> Rlt a (apply_fun seq n).
		  { exact (andER (Nlow :e omega)
		                 (forall n:set, n :e omega -> Nlow c= n -> Rlt a (apply_fun seq n))
		                 HNlowpair). }
			  (** eventual < c: use Cauchy + lub of eventual lower bounds to rule out large tail spikes **)
			  claim HexUpper: exists Nhi:set, Nhi :e omega /\ forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c.
			  { (** choose a positive d with d < c-l **)
			    claim HlR2: l :e R.
			    { exact HlR. }
			    claim HcR2: c :e R.
			    { exact HcR. }
			    claim HlS: SNo l.
			    { exact (real_SNo l HlR2). }
			    claim HcS: SNo c.
			    { exact (real_SNo c HcR2). }
			    set gap := add_SNo c (minus_SNo l).
			    claim HgapR: gap :e R.
			    { exact (real_add_SNo c HcR2 (minus_SNo l) (real_minus_SNo l HlR2)). }
			    claim HmlS: SNo (minus_SNo l).
			    { exact (SNo_minus_SNo l HlS). }
			    claim H0lt_gapS: 0 < add_SNo (minus_SNo l) c.
			    { claim HltS: l < c.
			      { exact (RltE_lt l c Hltlc). }
			      claim H0lt: add_SNo (minus_SNo l) l < add_SNo (minus_SNo l) c.
			      { exact (add_SNo_Lt2 (minus_SNo l) l c HmlS HlS HcS HltS). }
			      rewrite <- (add_SNo_minus_SNo_linv l HlS) at 1.
			      exact H0lt. }
			    claim H0lt_gapS2: 0 < gap.
			    { rewrite <- (add_SNo_com (minus_SNo l) c HmlS HcS) at 1.
			      exact H0lt_gapS. }
			    claim HgapPos: Rlt 0 gap.
			    { exact (RltI 0 gap real_0 HgapR H0lt_gapS2). }
			    claim Hexd: exists Nd :e omega, eps_ Nd < gap.
			    { exact (exists_eps_lt_pos_Euclid gap HgapR HgapPos). }
			    apply Hexd.
			    let Nd. assume HNdPair.
			    claim HNdO: Nd :e omega.
			    { exact (andEL (Nd :e omega) (eps_ Nd < gap) HNdPair). }
			    claim HdltGapS: eps_ Nd < gap.
			    { exact (andER (Nd :e omega) (eps_ Nd < gap) HNdPair). }
			    set d := eps_ Nd.
			    claim HdR: d :e R.
			    { exact (SNoS_omega_real d (SNo_eps_SNoS_omega Nd HNdO)). }
			    claim HdposS: 0 < d.
			    { exact (SNo_eps_pos Nd HNdO). }
			    claim Hdpos: Rlt 0 d.
			    { exact (RltI 0 d real_0 HdR HdposS). }
			    claim HdS: SNo d.
			    { exact (real_SNo d HdR). }
			    claim HmdR: minus_SNo d :e R.
			    { exact (real_minus_SNo d HdR). }
			    claim HmdS: SNo (minus_SNo d).
			    { exact (SNo_minus_SNo d HdS). }
			    claim HcdR: add_SNo c (minus_SNo d) :e R.
			    { exact (real_add_SNo c HcR2 (minus_SNo d) HmdR). }
			    (** from d < c-l infer l < c-d **)
			    claim HdltGapR: Rlt d gap.
			    { exact (RltI d gap HdR HgapR HdltGapS). }
			    claim HdltGapS2: d < gap.
			    { exact (RltE_lt d gap HdltGapR). }
			    claim Hdl_lt_c: add_SNo d l < c.
			    { exact (add_SNo_minus_Lt2 c l d HcS HlS HdS HdltGapS2). }
				    claim Hld_lt_c: add_SNo l d < c.
				    { rewrite <- (add_SNo_com d l HdS HlS) at 1.
				      exact Hdl_lt_c. }
			    claim Hlt_l_cdS: l < add_SNo c (minus_SNo d).
			    { exact (add_SNo_minus_Lt2b c d l HcS HdS HlS Hld_lt_c). }
			    claim Hlt_l_cd: Rlt l (add_SNo c (minus_SNo d)).
			    { exact (RltI l (add_SNo c (minus_SNo d)) HlR2 HcdR Hlt_l_cdS). }
			    (** Cauchy tail at radius d **)
			    claim HexN0: exists N0:set, N0 :e omega /\
			      forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
			        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
			    { exact (HabC d (andI (d :e R) (Rlt 0 d) HdR Hdpos)). }
			    apply HexN0.
			    let N0. assume HN0pair.
			    witness N0.
			    apply andI.
			    - exact (andEL (N0 :e omega)
			                   (forall m n:set, m :e omega -> n :e omega -> N0 c= m -> N0 c= n ->
			                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
			                   HN0pair).
			    - let n. assume HnO: n :e omega. assume HN0subn: N0 c= n.
			      prove Rlt (apply_fun seq n) c.
			      apply (xm (Rlt (apply_fun seq n) c) (Rlt (apply_fun seq n) c)).
			      + assume Hlt: Rlt (apply_fun seq n) c.
			        exact Hlt.
			      + assume Hnlt: ~(Rlt (apply_fun seq n) c).
			        claim HnR: apply_fun seq n :e R.
			        { exact (Hseq n HnO). }
			        claim HcLeN: Rle c (apply_fun seq n).
			        { exact (RleI c (apply_fun seq n) HcR2 HnR Hnlt). }
			        (** show cd := c-d is in A as an eventual lower bound **)
			        claim HcdA: add_SNo c (minus_SNo d) :e A.
			        { apply (SepI R
			                       (fun x1 : set => exists N:set, N :e omega /\
			                         forall n0:set, n0 :e omega -> N c= n0 -> Rle x1 (apply_fun seq n0))
			                       (add_SNo c (minus_SNo d))
			                       HcdR).
			          witness N0.
			          apply andI.
			          - exact (andEL (N0 :e omega)
			                         (forall m n0:set, m :e omega -> n0 :e omega -> N0 c= m -> N0 c= n0 ->
			                           abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n0))) < d)
			                         HN0pair).
			          - let m. assume HmO: m :e omega. assume HN0subm: N0 c= m.
			            (** abs bound for (m,n), rewritten to (n,m) **)
			            claim Habmn: abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
			            { exact (andER (N0 :e omega)
			                           (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N0 c= m0 -> N0 c= n0 ->
			                             abs_SNo (add_SNo (apply_fun seq m0) (minus_SNo (apply_fun seq n0))) < d)
			                           HN0pair m n HmO HnO HN0subm HN0subn). }
			            claim HmR: apply_fun seq m :e R.
			            { exact (Hseq m HmO). }
			            claim HmS: SNo (apply_fun seq m).
			            { exact (real_SNo (apply_fun seq m) HmR). }
			            claim HnS: SNo (apply_fun seq n).
			            { exact (real_SNo (apply_fun seq n) HnR). }
			            claim HabsSwap: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) =
			              abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))).
			            { exact (abs_SNo_dist_swap (apply_fun seq n) (apply_fun seq m) HnS HmS). }
			            claim Habnm: abs_SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) < d.
			            { rewrite HabsSwap.
			              exact Habmn. }
			            (** seqn - d < seqm from abs bound **)
			            claim HtS: SNo (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))).
			            { exact (SNo_add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m)) HnS
			                      (SNo_minus_SNo (apply_fun seq m) HmS)). }
			            claim HdposS2: 0 < d.
			            { exact HdposS. }
			            claim Hnm_lt_d: add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m)) < d.
			            { exact (abs_SNo_lt_imp_lt (add_SNo (apply_fun seq n) (minus_SNo (apply_fun seq m))) d
			                      HtS HdS HdposS2 Habnm). }
			            claim Hn_lt_dm: apply_fun seq n < add_SNo d (apply_fun seq m).
			            { exact (add_SNo_minus_Lt1 (apply_fun seq n) (apply_fun seq m) d HnS HmS HdS Hnm_lt_d). }
				            claim Hn_lt_md: apply_fun seq n < add_SNo (apply_fun seq m) d.
				            { rewrite <- (add_SNo_com d (apply_fun seq m) HdS HmS) at 1.
				              exact Hn_lt_dm. }
			            claim Hnmd_lt_m: add_SNo (apply_fun seq n) (minus_SNo d) < apply_fun seq m.
			            { exact (add_SNo_minus_Lt1b (apply_fun seq n) d (apply_fun seq m) HnS HdS HmS Hn_lt_md). }
			            claim HnmdR: add_SNo (apply_fun seq n) (minus_SNo d) :e R.
			            { exact (real_add_SNo (apply_fun seq n) HnR (minus_SNo d) HmdR). }
			            claim Hnmd_lt_mR: Rlt (add_SNo (apply_fun seq n) (minus_SNo d)) (apply_fun seq m).
			            { exact (RltI (add_SNo (apply_fun seq n) (minus_SNo d)) (apply_fun seq m) HnmdR HmR Hnmd_lt_m). }
			            (** c-d <= seqn-d by Rle monotonicity (adding -d) **)
				            claim HcdLeNmd: Rle (add_SNo c (minus_SNo d)) (add_SNo (apply_fun seq n) (minus_SNo d)).
				            { claim Hleft: Rle (add_SNo (minus_SNo d) c) (add_SNo (minus_SNo d) (apply_fun seq n)).
				              { exact (Rle_add_SNo_2 (minus_SNo d) c (apply_fun seq n) HmdR HcR2 HnR HcLeN). }
				              rewrite <- (add_SNo_com (minus_SNo d) c HmdS HcS) at 1.
				              rewrite <- (add_SNo_com (minus_SNo d) (apply_fun seq n) HmdS HnS) at 1.
				              exact Hleft. }
			            claim Hcdltm: Rlt (add_SNo c (minus_SNo d)) (apply_fun seq m).
			            { exact (Rle_Rlt_tra (add_SNo c (minus_SNo d))
			                                 (add_SNo (apply_fun seq n) (minus_SNo d))
			                                 (apply_fun seq m)
			                                 HcdLeNmd
			                                 Hnmd_lt_mR). }
			            exact (Rlt_implies_Rle (add_SNo c (minus_SNo d)) (apply_fun seq m) Hcdltm). }
			        claim HcdLeL: Rle (add_SNo c (minus_SNo d)) l.
			        { exact (HubA (add_SNo c (minus_SNo d)) HcdA HcdR). }
			        claim Hnlt2: ~(Rlt l (add_SNo c (minus_SNo d))).
			        { exact (RleE_nlt (add_SNo c (minus_SNo d)) l HcdLeL). }
			        exact (FalseE (Hnlt2 Hlt_l_cd) (Rlt (apply_fun seq n) c)). }
		  apply HexUpper.
		  let Nhi. assume HNhipair.
		  claim HNhiO2: Nhi :e omega.
		  { exact (andEL (Nhi :e omega)
		                 (forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c)
		                 HNhipair). }
		  claim Hhiprop: forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c.
		  { exact (andER (Nhi :e omega)
		                 (forall n:set, n :e omega -> Nhi c= n -> Rlt (apply_fun seq n) c)
		                 HNhipair). }
		  (** take N beyond Nlow and Nhi **)
		  set N := ordsucc (Nlow :\/: Nhi).
		  witness N.
		  apply andI.
		  - claim Hmax: Nlow :\/: Nhi :e omega.
		    { exact (omega_binunion Nlow Nhi HNlow HNhiO2). }
		    exact (omega_ordsucc (Nlow :\/: Nhi) Hmax).
		  - let n. assume HnO: n :e omega. assume HNsub: N c= n.
		    prove apply_fun seq n :e U.
		    (** show n is beyond Nlow and Nhi **)
		    claim HNlowSubn: Nlow c= n.
		    { let t. assume Ht: t :e Nlow.
		      claim HtN: t :e N.
		      { claim Htmax: t :e (Nlow :\/: Nhi).
		        { exact (binunionI1 Nlow Nhi t Ht). }
		        exact (ordsuccI1 (Nlow :\/: Nhi) t Htmax). }
		      exact (HNsub t HtN). }
		    claim HNhiSubn: Nhi c= n.
		    { let t. assume Ht: t :e Nhi.
		      claim HtN: t :e N.
		      { claim Htmax: t :e (Nlow :\/: Nhi).
		        { exact (binunionI2 Nlow Nhi t Ht). }
		        exact (ordsuccI1 (Nlow :\/: Nhi) t Htmax). }
		      exact (HNsub t HtN). }
		    (** show seq n ∈ open_interval a c, hence in b, hence in U **)
		    claim HltA: Rlt a (apply_fun seq n).
		    { exact (Hlowprop n HnO HNlowSubn). }
		    claim HltC: Rlt (apply_fun seq n) c.
		    { exact (Hhiprop n HnO HNhiSubn). }
		    claim HnR: apply_fun seq n :e R.
		    { exact (Hseq n HnO). }
		    claim Hnb: apply_fun seq n :e open_interval a c.
		    { claim HdefInt: open_interval a c = {x :e R|Rlt a x /\ Rlt x c}.
		      { reflexivity. }
		      rewrite HdefInt.
		      apply (SepI R (fun x0 : set => Rlt a x0 /\ Rlt x0 c) (apply_fun seq n) HnR).
		      apply andI.
		      - exact HltA.
		      - exact HltC. }
		    claim Hnb2: apply_fun seq n :e b.
		    { rewrite Hbeq.
		      exact Hnb. }
		    exact (HbsubU (apply_fun seq n) Hnb2).
		Qed.

(** helper: abs-Cauchy sequences on R converge in the bounded metric topology **)
(** LATEX VERSION: A Cauchy sequence in ℝ with respect to |x-y| also converges in the bounded metric topology. **)
Theorem abs_Cauchy_sequence_converges_metric_topology_R_bounded_metric : forall seq:set,
  sequence_on seq R ->
  (forall eps:set, eps :e R /\ Rlt 0 eps ->
     exists N:set, N :e omega /\
       forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
         abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps) ->
  exists x:set, converges_to R (metric_topology R R_bounded_metric) seq x.
let seq.
assume Hseq: sequence_on seq R.
assume HabC: forall eps:set, eps :e R /\ Rlt 0 eps ->
  exists N:set, N :e omega /\
    forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
      abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps.
claim HexStd: exists x:set, converges_to R R_standard_topology seq x.
{ exact (abs_Cauchy_sequence_converges_R_standard_topology seq Hseq HabC). }
apply HexStd.
let x. assume HxStd: converges_to R R_standard_topology seq x.
witness x.
prove converges_to R (metric_topology R R_bounded_metric) seq x.
rewrite metric_topology_R_bounded_metric_eq_R_standard_topology.
exact HxStd.
Qed.

(** helper: completeness of the bounded metric on R **)
(** LATEX VERSION: The real line with the bounded metric dbar(x,y)=min(|x-y|,1) is complete. **)
Theorem R_bounded_metric_complete : complete_metric_space R R_bounded_metric.
prove metric_on R R_bounded_metric /\
  forall seq:set, sequence_on seq R -> cauchy_sequence R R_bounded_metric seq ->
    exists x:set, converges_to R (metric_topology R R_bounded_metric) seq x.
apply andI.
- exact R_bounded_metric_is_metric_on.
- let seq.
  assume Hseq: sequence_on seq R.
  assume Hc: cauchy_sequence R R_bounded_metric seq.
  (** helper: for eps<1, the Cauchy tail is an abs-tail **)
  claim HabsTail: forall eps0:set, eps0 :e R -> Rlt 0 eps0 -> Rlt eps0 1 ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
  { let eps0.
    assume Heps0R: eps0 :e R.
    assume Heps0Pos: Rlt 0 eps0.
    assume Heps0Lt1: Rlt eps0 1.
    exact (cauchy_R_bounded_metric_abs_tail seq eps0 Hc Heps0R Heps0Pos Heps0Lt1). }
  (** obtain abs-Cauchy for all eps>0 by shrinking below eps and below 1 **)
  claim HabC: forall eps0:set, eps0 :e R /\ Rlt 0 eps0 ->
    exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
  { let eps0.
    assume Heps0: eps0 :e R /\ Rlt 0 eps0.
    claim Heps0R: eps0 :e R.
    { exact (andEL (eps0 :e R) (Rlt 0 eps0) Heps0). }
    claim Heps0Pos: Rlt 0 eps0.
    { exact (andER (eps0 :e R) (Rlt 0 eps0) Heps0). }
    claim Hexd: exists d:set, d :e R /\ Rlt 0 d /\ Rlt d eps0 /\ Rlt d 1 /\ Rlt d 1 /\ Rlt d 1.
    { exact (exists_eps_lt_four_pos_Euclid eps0 1 1 1 Heps0R real_1 real_1 real_1 Heps0Pos Rlt_0_1 Rlt_0_1 Rlt_0_1). }
    apply Hexd.
    let d. assume Hd: d :e R /\ Rlt 0 d /\ Rlt d eps0 /\ Rlt d 1 /\ Rlt d 1 /\ Rlt d 1.
    claim HdABCDE: ((((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) /\ Rlt d 1).
    { exact (andEL ((((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) /\ Rlt d 1) (Rlt d 1) Hd). }
    claim HdABCD: (((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1).
    { exact (andEL (((d :e R /\ Rlt 0 d) /\ Rlt d eps0) /\ Rlt d 1) (Rlt d 1) HdABCDE). }
    claim HdABC: ((d :e R /\ Rlt 0 d) /\ Rlt d eps0).
    { exact (andEL ((d :e R /\ Rlt 0 d) /\ Rlt d eps0) (Rlt d 1) HdABCD). }
    claim HdD: Rlt d 1.
    { exact (andER ((d :e R /\ Rlt 0 d) /\ Rlt d eps0) (Rlt d 1) HdABCD). }
    claim HdAB: d :e R /\ Rlt 0 d.
    { exact (andEL (d :e R /\ Rlt 0 d) (Rlt d eps0) HdABC). }
    claim Hdeps0: Rlt d eps0.
    { exact (andER (d :e R /\ Rlt 0 d) (Rlt d eps0) HdABC). }
    claim HdR: d :e R.
    { exact (andEL (d :e R) (Rlt 0 d) HdAB). }
    claim HdPos: Rlt 0 d.
    { exact (andER (d :e R) (Rlt 0 d) HdAB). }
    claim Hddlt1: Rlt d 1.
    { exact HdD. }
    (** apply abs-tail at d **)
    claim HexN: exists N:set, N :e omega /\
      forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
        abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
    { exact (HabsTail d HdR HdPos Hddlt1). }
    apply HexN.
    let N. assume HNpair.
    witness N.
    apply andI.
    - exact (andEL (N :e omega)
                   (forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                     abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d)
                   HNpair).
    - let m n.
      assume HmO: m :e omega.
      assume HnO: n :e omega.
      assume HNm: N c= m.
      assume HNn: N c= n.
      prove abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < eps0.
      claim Habd: abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))) < d.
      { exact (andER (N :e omega)
                     (forall m0 n0:set, m0 :e omega -> n0 :e omega -> N c= m0 -> N c= n0 ->
                       abs_SNo (add_SNo (apply_fun seq m0) (minus_SNo (apply_fun seq n0))) < d)
                     HNpair m n HmO HnO HNm HNn). }
      claim HdS: SNo d.
      { exact (real_SNo d HdR). }
      claim Heps0S: SNo eps0.
      { exact (real_SNo eps0 Heps0R). }
      claim Hdeps0S: d < eps0.
      { exact (RltE_lt d eps0 Hdeps0). }
      set t := add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n)).
      claim HmR: apply_fun seq m :e R.
      { exact (Hseq m HmO). }
      claim HnR: apply_fun seq n :e R.
      { exact (Hseq n HnO). }
      claim HmnR: minus_SNo (apply_fun seq n) :e R.
      { exact (real_minus_SNo (apply_fun seq n) HnR). }
      claim HtR: t :e R.
      { exact (real_add_SNo (apply_fun seq m) HmR (minus_SNo (apply_fun seq n)) HmnR). }
      claim HabsR: abs_SNo t :e R.
      { exact (abs_SNo_in_R t HtR). }
      claim HabsS: SNo (abs_SNo t).
      { exact (real_SNo (abs_SNo t) HabsR). }
      exact (SNoLt_tra (abs_SNo (add_SNo (apply_fun seq m) (minus_SNo (apply_fun seq n))))
                       d
                       eps0
                       HabsS
                       HdS
                       Heps0S
                       Habd
                       Hdeps0S). }
  claim HexStd: exists x:set, converges_to R R_standard_topology seq x.
  { exact (abs_Cauchy_sequence_converges_R_standard_topology seq Hseq HabC). }
  apply HexStd.
  let x. assume HxStd: converges_to R R_standard_topology seq x.
  witness x.
  prove converges_to R (metric_topology R R_bounded_metric) seq x.
  rewrite metric_topology_R_bounded_metric_eq_R_standard_topology.
  exact HxStd.
Qed.

(** from §43 Theorem 43.4: complete metric on R^omega **) 
(** LATEX VERSION: The bounded product metric makes R^ω complete. **)
Theorem product_Romega_complete : complete_metric_space (power_real omega) (bounded_product_metric omega).
rewrite (power_real_omega_eq_Romega_space).
rewrite (bounded_product_metric_omega_eq).
prove metric_on R_omega_space Romega_D_metric /\
  forall seq:set, sequence_on seq R_omega_space -> cauchy_sequence R_omega_space Romega_D_metric seq ->
    exists x:set, converges_to R_omega_space (metric_topology R_omega_space Romega_D_metric) seq x.
apply andI.
- exact (andEL (metric_on R_omega_space Romega_D_metric)
               (Romega_D_metric_topology = R_omega_product_topology)
               Romega_D_metric_induces_product_topology).
- let seq.
  assume Hseq: sequence_on seq R_omega_space.
  assume Hc: cauchy_sequence R_omega_space Romega_D_metric seq.
  set g := fun j:set =>
    Eps_i (fun a:set => converges_to R (metric_topology R R_bounded_metric)
                               (product_coordinate_sequence seq j) a).
  set x := graph omega g.
  claim HxX: x :e R_omega_space.
  { apply (graph_omega_to_R_in_Romega_space g).
    let j. assume HjO: j :e omega.
    prove g j :e R.
    set seqj := product_coordinate_sequence seq j.
    claim Hcj: cauchy_sequence R R_bounded_metric seqj.
    { exact (Romega_cauchy_imp_coord_cauchy_bounded seq j Hc HjO). }
    claim Hseqj12: metric_on R R_bounded_metric /\ sequence_on seqj R.
    { exact (andEL (metric_on R R_bounded_metric /\ sequence_on seqj R)
                   (forall eps:set, eps :e R /\ Rlt 0 eps ->
                     exists N:set, N :e omega /\
                       forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                         Rlt (apply_fun R_bounded_metric (apply_fun seqj m, apply_fun seqj n)) eps)
                   Hcj). }
    claim Hseqjon: sequence_on seqj R.
    { exact (andER (metric_on R R_bounded_metric) (sequence_on seqj R) Hseqj12). }
    claim Hcomp2: forall s:set, sequence_on s R -> cauchy_sequence R R_bounded_metric s ->
      exists a:set, converges_to R (metric_topology R R_bounded_metric) s a.
    { exact (andER (metric_on R R_bounded_metric)
                   (forall s:set, sequence_on s R -> cauchy_sequence R R_bounded_metric s ->
                     exists a:set, converges_to R (metric_topology R R_bounded_metric) s a)
                   R_bounded_metric_complete). }
    claim Hexa: exists a:set, converges_to R (metric_topology R R_bounded_metric) seqj a.
    { exact (Hcomp2 seqj Hseqjon Hcj). }
    set a := g j.
    claim Ha: converges_to R (metric_topology R R_bounded_metric) seqj a.
    { exact (Eps_i_ex (fun u:set => converges_to R (metric_topology R R_bounded_metric) seqj u) Hexa). }
    exact (converges_to_point_in_X R (metric_topology R R_bounded_metric) seqj a Ha). }
  claim Hcoord: forall j:set, j :e omega ->
    converges_to (product_component (const_space_family omega R R_standard_topology) j)
      (product_component_topology (const_space_family omega R R_standard_topology) j)
      (product_coordinate_sequence seq j)
      (apply_fun x j).
  { let j. assume HjO: j :e omega.
    set Xi := const_space_family omega R R_standard_topology.
    set seqj := product_coordinate_sequence seq j.
    set a := g j.
    claim HcompX: product_component Xi j = R.
    { rewrite (product_component_def Xi j).
      rewrite (const_space_family_apply omega R R_standard_topology j HjO).
      rewrite (tuple_2_0_eq R R_standard_topology).
      reflexivity. }
    claim HcompT: product_component_topology Xi j = R_standard_topology.
    { rewrite (product_component_topology_def Xi j).
      rewrite (const_space_family_apply omega R R_standard_topology j HjO).
      rewrite (tuple_2_1_eq R R_standard_topology).
      reflexivity. }
    claim Happlyx: apply_fun x j = a.
    { rewrite (apply_fun_graph omega g j HjO).
      reflexivity. }
    claim Hexa: exists a0:set, converges_to R (metric_topology R R_bounded_metric) seqj a0.
    { claim Hcj: cauchy_sequence R R_bounded_metric seqj.
      { exact (Romega_cauchy_imp_coord_cauchy_bounded seq j Hc HjO). }
      claim Hseqj12: metric_on R R_bounded_metric /\ sequence_on seqj R.
      { exact (andEL (metric_on R R_bounded_metric /\ sequence_on seqj R)
                     (forall eps:set, eps :e R /\ Rlt 0 eps ->
                       exists N:set, N :e omega /\
                         forall m n:set, m :e omega -> n :e omega -> N c= m -> N c= n ->
                           Rlt (apply_fun R_bounded_metric (apply_fun seqj m, apply_fun seqj n)) eps)
                     Hcj). }
      claim Hseqjon: sequence_on seqj R.
      { exact (andER (metric_on R R_bounded_metric) (sequence_on seqj R) Hseqj12). }
      claim Hcomp2: forall s:set, sequence_on s R -> cauchy_sequence R R_bounded_metric s ->
        exists a1:set, converges_to R (metric_topology R R_bounded_metric) s a1.
      { exact (andER (metric_on R R_bounded_metric)
                     (forall s:set, sequence_on s R -> cauchy_sequence R R_bounded_metric s ->
                       exists a1:set, converges_to R (metric_topology R R_bounded_metric) s a1)
                     R_bounded_metric_complete). }
      exact (Hcomp2 seqj Hseqjon Hcj). }
    claim Ha: converges_to R (metric_topology R R_bounded_metric) seqj a.
    { exact (Eps_i_ex (fun u:set => converges_to R (metric_topology R R_bounded_metric) seqj u) Hexa). }
    claim HaStd: converges_to R R_standard_topology seqj a.
    { rewrite <- metric_topology_R_bounded_metric_eq_R_standard_topology.
      exact Ha. }
    rewrite HcompX.
    rewrite HcompT.
    rewrite Happlyx.
    exact HaStd. }
  claim HXdef: R_omega_space = product_space omega (const_space_family omega R R_standard_topology).
  { reflexivity. }
  claim HconvProd: converges_to R_omega_space (product_topology_full omega (const_space_family omega R R_standard_topology)) seq x.
  { exact (iffER (converges_to R_omega_space (product_topology_full omega (const_space_family omega R R_standard_topology)) seq x)
                 (forall j:set, j :e omega ->
                   converges_to (product_component (const_space_family omega R R_standard_topology) j)
                     (product_component_topology (const_space_family omega R R_standard_topology) j)
                     (product_coordinate_sequence seq j)
                     (apply_fun x j))
                 (product_sequence_convergence_iff_coordinates R_omega_space omega HXdef seq x Hseq HxX)
                 Hcoord). }
  claim HtopEq: metric_topology R_omega_space Romega_D_metric = R_omega_product_topology.
  { claim Heq: Romega_D_metric_topology = R_omega_product_topology.
    { exact (andER (metric_on R_omega_space Romega_D_metric)
                   (Romega_D_metric_topology = R_omega_product_topology)
                   Romega_D_metric_induces_product_topology). }
    claim HdefT: Romega_D_metric_topology = metric_topology R_omega_space Romega_D_metric.
    { reflexivity. }
    rewrite <- HdefT.
    exact Heq. }
  claim HconvMetric: converges_to R_omega_space (metric_topology R_omega_space Romega_D_metric) seq x.
  { rewrite HtopEq.
    claim HdefP: R_omega_product_topology = product_topology_full omega (const_space_family omega R R_standard_topology).
    { reflexivity. }
    rewrite HdefP.
    exact HconvProd. }
  witness x.
  exact HconvMetric.
Qed.

(** from §44 Theorem: space-filling curve existence **) 
(** LATEX VERSION: Existence of a continuous surjection from [0,1] onto the unit square (Peano curve). **)
Definition unit_square : set := setprod unit_interval unit_interval.
Definition unit_square_topology : set :=
  product_topology unit_interval unit_interval_topology unit_interval unit_interval_topology.
Theorem space_filling_curve : exists f:set, continuous_map unit_interval unit_interval_topology unit_square unit_square_topology f.
admit. (** FAIL **)
Qed.

(** from §45 Definition: sequential compactness **)
(** LATEX VERSION: Sequentially compact: every sequence has a convergent subsequence/limit in X. **)
(** FIXED: sequentially_compact requires existence of a convergent subsequence, not that every sequence converges. **) 
Definition sequentially_compact : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall seq:set, sequence_on seq X ->
    exists subseq:set, exists x:set, subsequence_of seq subseq /\ converges_to X Tx subseq x.

(** from §45 Theorem: compactness in metric spaces equivalences **) 
(** LATEX VERSION: In metric spaces, compact ⇔ sequentially compact. **)
Theorem compact_metric_equivalences : forall X d:set,
  metric_on X d ->
  (compact_space X (metric_topology X d) <-> sequentially_compact X (metric_topology X d)).
let X d.
assume Hd: metric_on X d.
prove (compact_space X (metric_topology X d) <-> sequentially_compact X (metric_topology X d)).
apply iffI.
- assume Hcomp: compact_space X (metric_topology X d).
  prove sequentially_compact X (metric_topology X d).
  prove topology_on X (metric_topology X d) /\
    forall seq:set, sequence_on seq X ->
      exists subseq:set, exists x:set, subsequence_of seq subseq /\ converges_to X (metric_topology X d) subseq x.
  apply andI.
  * (** topology_on **)
    exact (compact_space_topology X (metric_topology X d) Hcomp).
  * (** compact metric ⇒ every sequence has convergent subsequence (pending) **)
    let seq. assume Hseq: sequence_on seq X.
    admit. (** FAIL **)
- assume Hseqc: sequentially_compact X (metric_topology X d).
  prove compact_space X (metric_topology X d).
  (** sequentially compact metric ⇒ compact (pending) **)
  admit. (** FAIL **)
Qed.

(** from §46 Definition: pointwise and compact convergence topologies **) 
(** LATEX VERSION: The topology of pointwise convergence on Y^X is the product topology on ∏_{x∈X} Y (evaluations are continuous). **)
(** We implement pointwise convergence on the graph-based `function_space X Y` via the evaluation subbasis. **)
(** from §46 Definition: pointwise convergence subbasis via evaluations **) 
(** LATEX VERSION: A subbasis is given by sets {f ∈ Y^X | f(x) ∈ U} for x∈X and U open in Y. **)
Definition pointwise_subbasis : set -> set -> set -> set -> set :=
  fun X Tx Y Ty =>
    {S :e Power (function_space X Y) |
      exists x U:set,
        x :e X /\ U :e Ty /\
        S = {f :e function_space X Y | apply_fun f x :e U}}.

(** from §46 Definition: pointwise convergence topology **) 
(** LATEX VERSION: The topology of pointwise convergence is generated by the evaluation subbasis {f | f(x) ∈ U}. **)
Definition pointwise_convergence_topology : set -> set -> set -> set -> set :=
  fun X Tx Y Ty =>
    generated_topology_from_subbasis (function_space X Y) (pointwise_subbasis X Tx Y Ty).

(** from §46 Definition: compact-open topology (compact convergence) **) 
(** LATEX VERSION: The compact-open topology on a function space has subbasis sets [K,U] = {f | f(K) ⊆ U} for K compact in X and U open in Y. **)
(** SUSPICIOUS DEFINITION: Because `function_space` only assumes `function_on` (via `apply_fun`), we express f(K)⊆U as K ⊆ f^{-1}(U) using `preimage_of`, avoiding an explicit image operator. **)
Definition compact_open_subbasis : set -> set -> set -> set -> set :=
  fun X Tx Y Ty =>
    {S :e Power (function_space X Y) |
      exists K U:set,
        compact_space K (subspace_topology X Tx K) /\ K c= X /\
        U :e Ty /\
        S = {f :e function_space X Y | K c= preimage_of X f U}}.

(** from §46 Definition: compact convergence topology (compact-open topology) **) 
(** LATEX VERSION: The compact convergence topology is the topology generated by the compact-open subbasis. **)
Definition compact_convergence_topology : set -> set -> set -> set -> set :=
  fun X Tx Y Ty => generated_topology_from_subbasis (function_space X Y) (compact_open_subbasis X Tx Y Ty).
(** FIXED: equicontinuous_family uses the implication apply_fun f x :e V -> forall y:e U, apply_fun f y :e V, not a global condition forcing all f to map U into V. **) 
Definition equicontinuous_family : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty F =>
    topology_on X Tx /\ topology_on Y Ty /\ F c= function_space X Y /\
    forall x:set, x :e X ->
      forall V:set, V :e Ty ->
        exists U:set, U :e Tx /\ x :e U /\
          forall f:set, f :e F -> apply_fun f x :e V ->
            forall y:set, y :e U -> apply_fun f y :e V.
(** from §47 Ascoli theorem: relatively compact subsets in compact convergence topology **)
(** LATEX VERSION: A subset F of C(X,Y) has compact closure in the compact convergence topology. **)
Definition relatively_compact_in_compact_convergence : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty F =>
    topology_on X Tx /\ topology_on Y Ty /\ F c= function_space X Y /\
    compact_space F (compact_convergence_topology X Tx Y Ty).

(** from §47 Ascoli theorem **) 
(** LATEX VERSION: Ascoli–Arzelà theorem (placeholder statement) on compact convergence. **)
Theorem Ascoli_theorem : forall X Tx Y Ty F:set,
  compact_space X Tx -> Hausdorff_space Y Ty ->
  equicontinuous_family X Tx Y Ty F -> relatively_compact_in_compact_convergence X Tx Y Ty F.
let X Tx Y Ty F.
assume HcompX: compact_space X Tx.
assume HHY: Hausdorff_space Y Ty.
assume Hequi: equicontinuous_family X Tx Y Ty F.
prove relatively_compact_in_compact_convergence X Tx Y Ty F.
prove topology_on X Tx /\ topology_on Y Ty /\ F c= function_space X Y /\
  compact_space F (compact_convergence_topology X Tx Y Ty).
(** extract the core data from equicontinuity **)
claim Hcore: (topology_on X Tx /\ topology_on Y Ty) /\ F c= function_space X Y.
{ exact (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ F c= function_space X Y)
               (forall x:set, x :e X ->
                 forall V:set, V :e Ty ->
                   exists U:set, U :e Tx /\ x :e U /\
                     forall f:set, f :e F -> apply_fun f x :e V ->
                       forall y:set, y :e U -> apply_fun f y :e V)
               Hequi). }
claim HtopAB: topology_on X Tx /\ topology_on Y Ty.
{ exact (andEL (topology_on X Tx /\ topology_on Y Ty) (F c= function_space X Y) Hcore). }
claim HFsub: F c= function_space X Y.
{ exact (andER (topology_on X Tx /\ topology_on Y Ty) (F c= function_space X Y) Hcore). }
apply andI.
- (** topology_on X /\ topology_on Y /\ F c= function_space **)
  apply andI.
  * exact HtopAB.
  * exact HFsub.
- (** Ascoli compactness conclusion in compact-open topology (pending) **)
  admit. (** FAIL **)
Qed.

(** helper: intersection over a family within a universe X **) 
(** LATEX VERSION: Intersection_over_family X Fam collects points lying in every member of Fam. **)
Definition intersection_over_family : set -> set -> set :=
  fun X Fam => {x :e X|forall U:set, U :e Fam -> x :e U}.

(** from §48 Definition: Baire space **)
(** LATEX VERSION: A Baire space is one where countable intersections of dense open sets are dense. **)
Definition Baire_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall U:set,
    U c= Tx -> countable_set U ->
    (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
    dense_in (intersection_over_family X U) X Tx.

(** from §48 Definition (closed-set form): Baire space **)
(** LATEX VERSION: X is Baire if for any countable family of closed subsets with empty interior, the union has empty interior. **)
Definition Baire_space_closed : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall Fam:set,
    countable_set Fam ->
    (forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty) ->
    interior_of X Tx (Union Fam) = Empty.

(** helper: union of complements equals complement of intersection_over_family **)
Theorem union_of_complements_eq_complement_of_intersection_over_family : forall X U:set,
  (forall u:set, u :e U -> u c= X) ->
  Union {X :\: u | u :e U} = X :\: (intersection_over_family X U).
let X U.
assume HUsub: forall u:set, u :e U -> u c= X.
apply (set_ext (Union {X :\: u | u :e U}) (X :\: (intersection_over_family X U))).
- let x. assume Hx: x :e Union {X :\: u | u :e U}.
  prove x :e X :\: (intersection_over_family X U).
  apply (UnionE_impred {X :\: u | u :e U} x Hx (x :e X :\: (intersection_over_family X U))).
  let Y. assume HxY: x :e Y. assume HY: Y :e {X :\: u | u :e U}.
  claim Hexu: exists u:set, u :e U /\ Y = X :\: u.
  { exact (ReplE U (fun u0:set => X :\: u0) Y HY). }
  apply Hexu.
  let u. assume Hu: u :e U /\ Y = X :\: u.
  claim HuU: u :e U.
  { exact (andEL (u :e U) (Y = X :\: u) Hu). }
  claim HeqY: Y = X :\: u.
  { exact (andER (u :e U) (Y = X :\: u) Hu). }
  claim HxXu: x :e X :\: u.
  { rewrite <- HeqY.
    exact HxY. }
  claim HxX: x :e X.
  { exact (setminusE1 X u x HxXu). }
  claim Hxnotu: x /:e u.
  { exact (setminusE2 X u x HxXu). }
  apply setminusI.
  - exact HxX.
  - assume HxinInt: x :e intersection_over_family X U.
    claim Hall: forall u0:set, u0 :e U -> x :e u0.
    { exact (SepE2 X (fun x0:set => forall u0:set, u0 :e U -> x0 :e u0) x HxinInt). }
    exact (Hxnotu (Hall u HuU)).
- let x. assume Hx: x :e X :\: (intersection_over_family X U).
  prove x :e Union {X :\: u | u :e U}.
  claim HxX: x :e X.
  { exact (setminusE1 X (intersection_over_family X U) x Hx). }
  claim HxnotInt: x /:e intersection_over_family X U.
  { exact (setminusE2 X (intersection_over_family X U) x Hx). }
  claim HnotAll: ~ (forall u:set, u :e U -> x :e u).
  { assume Hall: forall u:set, u :e U -> x :e u.
    apply HxnotInt.
    claim HdefInt: intersection_over_family X U =
      {x0 :e X|forall u0:set, u0 :e U -> x0 :e u0}.
    { reflexivity. }
    rewrite HdefInt.
    apply (SepI X (fun x0:set => forall u0:set, u0 :e U -> x0 :e u0) x HxX).
    exact Hall. }
  claim Hexu: exists u:set, ~ (u :e U -> x :e u).
  { exact (not_all_ex_demorgan_i (fun u0:set => u0 :e U -> x :e u0) HnotAll). }
  apply Hexu.
  let u. assume Hnimp: ~ (u :e U -> x :e u).
  claim Hu: u :e U /\ x /:e u.
  { exact (not_imp (u :e U) (x :e u) Hnimp). }
  claim HuU: u :e U.
  { exact (andEL (u :e U) (x /:e u) Hu). }
  claim Hxnotu: x /:e u.
  { exact (andER (u :e U) (x /:e u) Hu). }
  claim HxXu: x :e X :\: u.
  { apply setminusI.
    - exact HxX.
    - exact Hxnotu. }
  claim Hmem: (X :\: u) :e {X :\: u0 | u0 :e U}.
  { exact (ReplI U (fun u0:set => X :\: u0) u HuU). }
  exact (UnionI {X :\: u0 | u0 :e U} x (X :\: u) HxXu Hmem).
Qed.

(** helper: intersection of complements equals complement of Union **)
Theorem intersection_of_complements_eq_complement_of_Union : forall X Fam:set,
  (forall A:set, A :e Fam -> A c= X) ->
  intersection_over_family X {X :\: A | A :e Fam} = X :\: Union Fam.
let X Fam.
assume Hsub: forall A:set, A :e Fam -> A c= X.
apply set_ext.
- let x. assume Hx: x :e intersection_over_family X {X :\: A | A :e Fam}.
  prove x :e X :\: Union Fam.
  claim HxX: x :e X.
  { exact (SepE1 X (fun x0:set => forall U0:set, U0 :e {X :\: A | A :e Fam} -> x0 :e U0) x Hx). }
  claim Hall: forall U0:set, U0 :e {X :\: A | A :e Fam} -> x :e U0.
  { exact (SepE2 X (fun x0:set => forall U0:set, U0 :e {X :\: A | A :e Fam} -> x0 :e U0) x Hx). }
  apply setminusI.
  - exact HxX.
  - assume HxUnion: x :e Union Fam.
    apply (UnionE_impred Fam x HxUnion (False)).
    let A. assume HxA: x :e A. assume HA: A :e Fam.
    claim HXminusA: (X :\: A) :e {X :\: A0 | A0 :e Fam}.
    { exact (ReplI Fam (fun A0:set => X :\: A0) A HA). }
    claim HxXminusA: x :e X :\: A.
    { exact (Hall (X :\: A) HXminusA). }
    exact (setminusE2 X A x HxXminusA HxA).
- let x. assume Hx: x :e X :\: Union Fam.
  prove x :e intersection_over_family X {X :\: A | A :e Fam}.
  claim HxX: x :e X.
  { exact (setminusE1 X (Union Fam) x Hx). }
  claim HdefInt: intersection_over_family X {X :\: A | A :e Fam} =
    {x0 :e X|forall U0:set, U0 :e {X :\: A | A :e Fam} -> x0 :e U0}.
  { reflexivity. }
  rewrite HdefInt.
  apply (SepI X (fun x0:set => forall U0:set, U0 :e {X :\: A | A :e Fam} -> x0 :e U0) x HxX).
  let U0. assume HU0: U0 :e {X :\: A | A :e Fam}.
  prove x :e U0.
  claim HexA: exists A:set, A :e Fam /\ U0 = X :\: A.
  { exact (ReplE Fam (fun A0:set => X :\: A0) U0 HU0). }
  apply HexA.
  let A. assume HA: A :e Fam /\ U0 = X :\: A.
  claim HAin: A :e Fam.
  { exact (andEL (A :e Fam) (U0 = X :\: A) HA). }
  claim HU0eq: U0 = X :\: A.
  { exact (andER (A :e Fam) (U0 = X :\: A) HA). }
  rewrite HU0eq.
  apply setminusI.
  - exact HxX.
  - assume HxA: x :e A.
    apply (setminusE2 X (Union Fam) x Hx).
    exact (UnionI Fam x A HxA HAin).
Qed.

(** from §48 Lemma 48.1 (direction): closed-set Baire implies open-set Baire **)
(** LATEX VERSION: Lemma 48.1: X is Baire iff countable intersections of dense open sets are dense. **)
Theorem Baire_space_closed_imp : forall X Tx:set,
  Baire_space_closed X Tx -> Baire_space X Tx.
let X Tx.
assume HBc: Baire_space_closed X Tx.
prove Baire_space X Tx.
prove topology_on X Tx /\
  forall U:set,
    U c= Tx -> countable_set U ->
    (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
    dense_in (intersection_over_family X U) X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall Fam:set, countable_set Fam ->
                 (forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty) ->
                 interior_of X Tx (Union Fam) = Empty)
               HBc). }
apply andI.
- exact HTx.
- let U.
  assume HUsub: U c= Tx.
  assume HUcount: countable_set U.
  assume HUdense: forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx.
  prove dense_in (intersection_over_family X U) X Tx.
  (** Consider the family of closed complements Fam = {X\\u | u in U}. **)
  set Fam := {X :\: u | u :e U}.
  claim HFamcount: countable_set Fam.
  { exact (countable_image U HUcount (fun u0:set => X :\: u0)). }
  claim HFamprop: forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty.
  { let A. assume HA: A :e Fam.
    claim Hexu: exists u:set, u :e U /\ A = X :\: u.
    { exact (ReplE U (fun u0:set => X :\: u0) A HA). }
    apply Hexu.
    let u. assume Hu: u :e U /\ A = X :\: u.
    claim HuU: u :e U.
    { exact (andEL (u :e U) (A = X :\: u) Hu). }
    claim HAeq: A = X :\: u.
    { exact (andER (u :e U) (A = X :\: u) Hu). }
    claim Hup: u :e Tx /\ dense_in u X Tx.
    { exact (HUdense u HuU). }
    claim HuTx: u :e Tx.
    { exact (andEL (u :e Tx) (dense_in u X Tx) Hup). }
	    claim Hclu: dense_in u X Tx.
	    { exact (andER (u :e Tx) (dense_in u X Tx) Hup). }
	    claim HTsub: Tx c= Power X.
	    { exact (topology_subset_axiom X Tx HTx). }
	    claim HuPow: u :e Power X.
	    { exact (HTsub u HuTx). }
	    claim HusubX: u c= X.
	    { exact (PowerE X u HuPow). }
    rewrite HAeq.
    apply andI.
    - (** closed complement **)
      exact (closed_of_open_complement X Tx u HTx HuTx).
	    - (** empty interior: int(X\\u) = X \\ cl(u) = Empty since cl(u)=X **)
	      claim Hdual: interior_of X Tx (X :\: u) = X :\: closure_of X Tx (X :\: (X :\: u)).
	      { exact (interior_closure_complement_duality X Tx (X :\: u) HTx (setminus_Subq X u)). }
	      rewrite Hdual.
	      rewrite (setminus_setminus_eq X u HusubX).
	      claim HcluEq: closure_of X Tx u = X.
	      { exact Hclu. }
	      rewrite HcluEq.
	      (** X \\ X = Empty **)
	      claim Hxx: X :\: X = Empty.
	      { apply Empty_Subq_eq.
	        let z. assume Hz: z :e X :\: X.
	        prove z :e Empty.
	        claim HzX: z :e X.
	        { exact (setminusE1 X X z Hz). }
	        claim HznotX: z /:e X.
	        { exact (setminusE2 X X z Hz). }
	        apply FalseE.
	        exact (HznotX HzX). }
	      exact Hxx. }
  claim HintUnion: interior_of X Tx (Union Fam) = Empty.
  { exact ((andER (topology_on X Tx)
                  (forall Fam0:set, countable_set Fam0 ->
                    (forall A:set, A :e Fam0 -> closed_in X Tx A /\ interior_of X Tx A = Empty) ->
                    interior_of X Tx (Union Fam0) = Empty)
                  HBc) Fam HFamcount HFamprop). }
  (** Union Fam = X \\ intersection(U) **)
  claim HsubU: forall u:set, u :e U -> u c= X.
  { let u. assume Hu: u :e U.
    claim HuTx: u :e Tx.
    { exact (HUsub u Hu). }
    exact (topology_elem_subset X Tx u HTx HuTx). }
  claim HUnionEq: Union Fam = X :\: (intersection_over_family X U).
  { exact (union_of_complements_eq_complement_of_intersection_over_family X U HsubU). }
  (** from HintUnion and duality: closure(intersection) = X **)
  claim HintUnion2: interior_of X Tx (X :\: (intersection_over_family X U)) = Empty.
  { rewrite <- HUnionEq.
    exact HintUnion. }
  claim Hdual: interior_of X Tx (X :\: (intersection_over_family X U)) =
               X :\: closure_of X Tx (X :\: (X :\: (intersection_over_family X U))).
  { exact (interior_closure_complement_duality X Tx (X :\: (intersection_over_family X U))
           HTx
           (setminus_Subq X (intersection_over_family X U))). }
  claim HintUnion3: X :\: closure_of X Tx (intersection_over_family X U) = Empty.
  { claim HintSub: intersection_over_family X U c= X.
    { let z. assume Hz: z :e intersection_over_family X U.
      exact (SepE1 X (fun z0:set => forall u0:set, u0 :e U -> z0 :e u0) z Hz). }
    rewrite <- (setminus_setminus_eq X (intersection_over_family X U) HintSub).
    rewrite <- Hdual.
    exact HintUnion2. }
  (** interior = Empty implies closure = X **)
  apply (set_ext (closure_of X Tx (intersection_over_family X U)) X).
  - exact (closure_in_space X Tx (intersection_over_family X U) HTx).
  - let x. assume HxX: x :e X.
    prove x :e closure_of X Tx (intersection_over_family X U).
    apply (xm (x :e closure_of X Tx (intersection_over_family X U))).
    + assume H. exact H.
    + assume Hnot: x /:e closure_of X Tx (intersection_over_family X U).
      apply FalseE.
      claim Hxminus: x :e X :\: closure_of X Tx (intersection_over_family X U).
      { apply setminusI.
        - exact HxX.
        - exact Hnot. }
      claim HxE: x :e Empty.
      { rewrite <- HintUnion3.
        exact Hxminus. }
      exact (EmptyE x HxE).
Qed.

(** from §48 Lemma 48.1 (direction): open-set Baire implies closed-set Baire **)
(** LATEX VERSION: Lemma 48.1: X is Baire iff countable intersections of dense open sets are dense. **)
Theorem Baire_space_imp_closed : forall X Tx:set,
  Baire_space X Tx -> Baire_space_closed X Tx.
let X Tx.
assume HB: Baire_space X Tx.
prove Baire_space_closed X Tx.
prove topology_on X Tx /\
  forall Fam:set,
    countable_set Fam ->
    (forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty) ->
    interior_of X Tx (Union Fam) = Empty.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, U c= Tx -> countable_set U ->
                 (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U) X Tx)
               HB). }
apply andI.
- exact HTx.
- let Fam.
  assume Hcount: countable_set Fam.
  assume Hclosed: forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty.
  prove interior_of X Tx (Union Fam) = Empty.
  (** Define U = {X\\A | A in Fam}; these are open and dense. **)
  set U := {X :\: A | A :e Fam}.
  claim HUcount: countable_set U.
  { exact (countable_image Fam Hcount (fun A0:set => X :\: A0)). }
  claim HUsub: U c= Tx.
  { let u. assume Hu: u :e U.
    claim HexA: exists A:set, A :e Fam /\ u = X :\: A.
    { exact (ReplE Fam (fun A0:set => X :\: A0) u Hu). }
    apply HexA.
    let A. assume HA: A :e Fam /\ u = X :\: A.
    claim HAin: A :e Fam.
    { exact (andEL (A :e Fam) (u = X :\: A) HA). }
    claim Heq: u = X :\: A.
    { exact (andER (A :e Fam) (u = X :\: A) HA). }
    claim HAcl: closed_in X Tx A.
    { exact (andEL (closed_in X Tx A) (interior_of X Tx A = Empty) (Hclosed A HAin)). }
    claim Hopen: open_in X Tx (X :\: A).
    { exact (open_of_closed_complement X Tx A HAcl). }
    claim HopenTx: (X :\: A) :e Tx.
    { exact (open_in_elem X Tx (X :\: A) Hopen). }
    rewrite Heq.
    exact HopenTx. }
  claim HUprop: forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx.
  { let u. assume Hu: u :e U.
    claim HuTx: u :e Tx.
    { exact (HUsub u Hu). }
    claim HexA: exists A:set, A :e Fam /\ u = X :\: A.
    { exact (ReplE Fam (fun A0:set => X :\: A0) u Hu). }
    apply HexA.
    let A. assume HA: A :e Fam /\ u = X :\: A.
    claim HAin: A :e Fam.
    { exact (andEL (A :e Fam) (u = X :\: A) HA). }
    claim Heq: u = X :\: A.
    { exact (andER (A :e Fam) (u = X :\: A) HA). }
    claim HintA: interior_of X Tx A = Empty.
    { exact (andER (closed_in X Tx A) (interior_of X Tx A = Empty) (Hclosed A HAin)). }
    (** int(A)=Empty implies closure(X\\A)=X by duality **)
    claim Hdual: interior_of X Tx A = X :\: closure_of X Tx (X :\: A).
    { exact (interior_closure_complement_duality X Tx A HTx (closed_in_subset X Tx A
             (andEL (closed_in X Tx A) (interior_of X Tx A = Empty) (Hclosed A HAin)))). }
    claim HcomplEmpty: X :\: closure_of X Tx (X :\: A) = Empty.
    { rewrite <- Hdual.
      exact HintA. }
    apply andI.
    - exact HuTx.
    - (** closure(u) = X **)
      claim HcomplEmptyU: X :\: closure_of X Tx u = Empty.
      { rewrite Heq.
        exact HcomplEmpty. }
      apply (set_ext (closure_of X Tx u) X).
      + exact (closure_in_space X Tx u HTx).
      + let x. assume HxX: x :e X.
        prove x :e closure_of X Tx u.
        apply (xm (x :e closure_of X Tx u)).
        * assume H. exact H.
        * assume Hnot: x /:e closure_of X Tx u.
          apply FalseE.
          claim Hxminus: x :e X :\: closure_of X Tx u.
          { apply setminusI. exact HxX. exact Hnot. }
          claim HxE: x :e Empty.
          { rewrite <- HcomplEmptyU.
            exact Hxminus. }
          exact (EmptyE x HxE). }
  (** Apply HB to U to get density of intersection; then deduce interior of Union Fam is Empty. **)
  claim HdenseInt: dense_in (intersection_over_family X U) X Tx.
  { exact ((andER (topology_on X Tx)
                  (forall U0:set, U0 c= Tx -> countable_set U0 ->
                    (forall u0:set, u0 :e U0 -> u0 :e Tx /\ dense_in u0 X Tx) ->
                    dense_in (intersection_over_family X U0) X Tx)
                  HB) U HUsub HUcount HUprop). }
  (** Union Fam = X \\ intersection(U) **)
  claim HsubFam: forall A:set, A :e Fam -> A c= X.
  { let A. assume HA: A :e Fam.
    exact (closed_in_subset X Tx A (andEL (closed_in X Tx A) (interior_of X Tx A = Empty) (Hclosed A HA))). }
  (** Here we need Union Fam; use De Morgan for complements **)
  claim HDeMorgan: X :\: (intersection_over_family X U) = Union Fam.
  { apply (set_ext (X :\: (intersection_over_family X U)) (Union Fam)).
    - let x. assume Hx: x :e X :\: (intersection_over_family X U).
      (** x not in intersection implies exists A in Fam with x in A **)
      claim HxX: x :e X.
      { exact (setminusE1 X (intersection_over_family X U) x Hx). }
      claim Hxnot: x /:e intersection_over_family X U.
      { exact (setminusE2 X (intersection_over_family X U) x Hx). }
      claim HnotAll: ~ (forall u0:set, u0 :e U -> x :e u0).
      { assume Hall.
        apply Hxnot.
        claim HdefInt: intersection_over_family X U =
          {x0 :e X|forall u1:set, u1 :e U -> x0 :e u1}.
        { reflexivity. }
        rewrite HdefInt.
        apply (SepI X (fun x0:set => forall u1:set, u1 :e U -> x0 :e u1) x HxX).
        exact Hall. }
      claim Hexu: exists u0:set, ~ (u0 :e U -> x :e u0).
      { exact (not_all_ex_demorgan_i (fun u0:set => u0 :e U -> x :e u0) HnotAll). }
      apply Hexu.
      let u0. assume Hnimp: ~ (u0 :e U -> x :e u0).
      claim Hu0: u0 :e U /\ x /:e u0.
      { exact (not_imp (u0 :e U) (x :e u0) Hnimp). }
      claim Hu0U: u0 :e U.
      { exact (andEL (u0 :e U) (x /:e u0) Hu0). }
      claim Hxnotu0: x /:e u0.
      { exact (andER (u0 :e U) (x /:e u0) Hu0). }
      claim HexA: exists A:set, A :e Fam /\ u0 = X :\: A.
      { exact (ReplE Fam (fun A0:set => X :\: A0) u0 Hu0U). }
      apply HexA.
      let A. assume HA: A :e Fam /\ u0 = X :\: A.
      claim HAin: A :e Fam.
      { exact (andEL (A :e Fam) (u0 = X :\: A) HA). }
      claim Hu0eq: u0 = X :\: A.
      { exact (andER (A :e Fam) (u0 = X :\: A) HA). }
      (** x notin X\\A implies x in A **)
      claim HxA: x :e A.
      { apply dneg.
        assume HxnotA: x /:e A.
        apply Hxnotu0.
        rewrite Hu0eq.
        apply setminusI.
        - exact HxX.
        - exact HxnotA. }
      exact (UnionI Fam x A HxA HAin).
    - let x. assume Hx: x :e Union Fam.
      prove x :e X :\: (intersection_over_family X U).
      apply (UnionE_impred Fam x Hx (x :e X :\: (intersection_over_family X U))).
      let A. assume HxA: x :e A. assume HAin: A :e Fam.
      claim HAsubX: A c= X.
      { exact (HsubFam A HAin). }
      claim HxX: x :e X.
      { exact (HAsubX x HxA). }
      apply setminusI.
      - exact HxX.
      - assume HxInt: x :e intersection_over_family X U.
        claim Hall: forall u0:set, u0 :e U -> x :e u0.
        { exact (SepE2 X (fun x0:set => forall u0:set, u0 :e U -> x0 :e u0) x HxInt). }
        set u0 := X :\: A.
        claim Hu0U: u0 :e U.
        { exact (ReplI Fam (fun A0:set => X :\: A0) A HAin). }
        claim Hxnu0: x /:e u0.
        { assume Hxu0: x :e u0.
          exact (setminusE2 X A x Hxu0 HxA). }
        exact (Hxnu0 (Hall u0 Hu0U)). }
  (** Now interior(Union Fam) = Empty follows from dense intersection and duality. **)
  claim HUnionU: Union Fam = X :\: (intersection_over_family X U).
  { symmetry. exact HDeMorgan. }
  rewrite HUnionU.
  set I := intersection_over_family X U.
  claim HIsub: I c= X.
  { let z. assume Hz: z :e I.
    exact (SepE1 X (fun z0:set => forall u0:set, u0 :e U -> z0 :e u0) z Hz). }
  claim Hdual: interior_of X Tx (X :\: I) = X :\: closure_of X Tx (X :\: (X :\: I)).
  { exact (interior_closure_complement_duality X Tx (X :\: I) HTx (setminus_Subq X I)). }
  rewrite Hdual.
  rewrite (setminus_setminus_eq X I HIsub).
  claim HclEq: closure_of X Tx I = X.
  { exact HdenseInt. }
  rewrite HclEq.
  claim Hxx: X :\: X = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e X :\: X.
    prove z :e Empty.
    claim HzX: z :e X.
    { exact (setminusE1 X X z Hz). }
    claim HznotX: z /:e X.
    { exact (setminusE2 X X z Hz). }
    apply FalseE.
    exact (HznotX HzX). }
  exact Hxx.
Qed.

(** from §48 Lemma 48.1: equivalence of closed and open formulations **)
(** LATEX VERSION: Lemma 48.1: X is Baire iff any countable intersection of dense open sets is dense. **)
Theorem Baire_space_closed_iff : forall X Tx:set,
  (Baire_space_closed X Tx <-> Baire_space X Tx).
let X Tx.
apply iffI.
- exact (Baire_space_closed_imp X Tx).
- exact (Baire_space_imp_closed X Tx).
Qed.

(** from §48 Lemma 48.1: dense G_delta characterization of Baire space **)
(** LATEX VERSION: Equivalent dense G_δ characterization of Baire spaces. **)
Theorem Baire_space_dense_Gdelta : forall X Tx:set,
  Baire_space X Tx ->
  forall U:set,
    U c= Tx -> countable_set U ->
    (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
    dense_in (intersection_over_family X U) X Tx.
let X Tx.
assume HB: Baire_space X Tx.
let U.
assume HUsub: U c= Tx.
assume HUcount: countable_set U.
assume HUdense: forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx.
prove dense_in (intersection_over_family X U) X Tx.
claim Hprop: forall U0:set,
  U0 c= Tx -> countable_set U0 ->
  (forall u:set, u :e U0 -> u :e Tx /\ dense_in u X Tx) ->
  dense_in (intersection_over_family X U0) X Tx.
{ exact (andER (topology_on X Tx)
               (forall U0:set,
                 U0 c= Tx -> countable_set U0 ->
                 (forall u:set, u :e U0 -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U0) X Tx)
               HB). }
exact (Hprop U HUsub HUcount HUdense).
Qed.

(** from §48 Theorem: Baire category theorem for complete metric spaces **)
(** LATEX VERSION: Complete metric spaces are Baire. **)
Theorem Baire_category_complete_metric_closed : forall X d:set,
  complete_metric_space X d -> Baire_space_closed X (metric_topology X d).
let X d.
assume Hc: complete_metric_space X d.
prove Baire_space_closed X (metric_topology X d).
prove topology_on X (metric_topology X d) /\
  forall Fam:set,
    countable_set Fam ->
    (forall A:set, A :e Fam -> closed_in X (metric_topology X d) A /\ interior_of X (metric_topology X d) A = Empty) ->
    interior_of X (metric_topology X d) (Union Fam) = Empty.
apply andI.
- (** topology_on **)
  claim Hm: metric_on X d.
  { exact (andEL (metric_on X d)
                 (forall seq:set, sequence_on seq X -> cauchy_sequence X d seq ->
                   exists x:set, converges_to X (metric_topology X d) seq x)
                 Hc). }
  exact (metric_topology_is_topology X d Hm).
- (** closed-set Baire category core for complete metrics (pending) **)
  let Fam.
  assume Hcount: countable_set Fam.
  assume Hclint: forall A:set, A :e Fam ->
    closed_in X (metric_topology X d) A /\ interior_of X (metric_topology X d) A = Empty.
  prove interior_of X (metric_topology X d) (Union Fam) = Empty.
  admit. (** FAIL **)
Qed.

Theorem Baire_category_complete_metric : forall X d:set,
  complete_metric_space X d -> Baire_space X (metric_topology X d).
let X d.
assume Hc: complete_metric_space X d.
prove Baire_space X (metric_topology X d).
claim HBc: Baire_space_closed X (metric_topology X d).
{ exact (Baire_category_complete_metric_closed X d Hc). }
exact (Baire_space_closed_imp X (metric_topology X d) HBc).
Qed.

(** from §48 Theorem: compact Hausdorff spaces are Baire spaces **)
(** LATEX VERSION: Compact Hausdorff spaces are Baire. **)
Theorem Baire_category_compact_Hausdorff_closed : forall X Tx:set,
  compact_space X Tx -> Hausdorff_space X Tx -> Baire_space_closed X Tx.
let X Tx.
assume Hcomp: compact_space X Tx.
assume HH: Hausdorff_space X Tx.
prove Baire_space_closed X Tx.
prove topology_on X Tx /\
  forall Fam:set,
    countable_set Fam ->
    (forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty) ->
    interior_of X Tx (Union Fam) = Empty.
apply andI.
- exact (compact_space_topology X Tx Hcomp).
- let Fam.
  assume Hcount: countable_set Fam.
  assume Hclint: forall A:set, A :e Fam -> closed_in X Tx A /\ interior_of X Tx A = Empty.
  prove interior_of X Tx (Union Fam) = Empty.
  admit. (** FAIL **)
Qed.

Theorem Baire_category_compact_Hausdorff : forall X Tx:set,
  compact_space X Tx -> Hausdorff_space X Tx -> Baire_space X Tx.
let X Tx.
assume Hcomp: compact_space X Tx.
assume HH: Hausdorff_space X Tx.
prove Baire_space X Tx.
claim HBc: Baire_space_closed X Tx.
{ exact (Baire_category_compact_Hausdorff_closed X Tx Hcomp HH). }
exact (Baire_space_closed_imp X Tx HBc).
Qed.

(** from §48 Theorem 48.2 (Baire category theorem): compact Hausdorff or complete metric implies Baire **)
(** LATEX VERSION: If X is compact Hausdorff or a complete metric space, then X is a Baire space. **)
Theorem Baire_category_theorem : forall X Tx:set,
  (compact_space X Tx /\ Hausdorff_space X Tx) \/
  (exists d:set, complete_metric_space X d /\ Tx = metric_topology X d) ->
  Baire_space X Tx.
let X Tx.
assume Hcase:
  (compact_space X Tx /\ Hausdorff_space X Tx) \/
  (exists d:set, complete_metric_space X d /\ Tx = metric_topology X d).
prove Baire_space X Tx.
apply Hcase.
- assume Hcomp: compact_space X Tx /\ Hausdorff_space X Tx.
  exact (Baire_category_compact_Hausdorff X Tx
           (andEL (compact_space X Tx) (Hausdorff_space X Tx) Hcomp)
           (andER (compact_space X Tx) (Hausdorff_space X Tx) Hcomp)).
- assume Hmet: exists d:set, complete_metric_space X d /\ Tx = metric_topology X d.
  apply Hmet.
  let d. assume Hd: complete_metric_space X d /\ Tx = metric_topology X d.
  claim Hcomp: complete_metric_space X d.
  { exact (andEL (complete_metric_space X d) (Tx = metric_topology X d) Hd). }
  claim HtopEq: Tx = metric_topology X d.
  { exact (andER (complete_metric_space X d) (Tx = metric_topology X d) Hd). }
  rewrite HtopEq.
  exact (Baire_category_complete_metric X d Hcomp).
Qed.

(** from §48 Lemma 48.4: open subspace of Baire is Baire **)
(** LATEX VERSION: Lemma 48.4: Any open subspace Y of a Baire space X is itself a Baire space. **)
Theorem Baire_open_subspace : forall X Tx Y:set,
  Baire_space X Tx ->
  open_in X Tx Y ->
  Baire_space Y (subspace_topology X Tx Y).
let X Tx Y.
assume HB: Baire_space X Tx.
assume HYopen: open_in X Tx Y.
prove Baire_space Y (subspace_topology X Tx Y).
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set,
                 U c= Tx -> countable_set U ->
                 (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U) X Tx)
               HB). }
claim HYsub: Y c= X.
{ exact (open_in_subset X Tx Y HYopen). }
claim HYinTx: Y :e Tx.
{ exact (open_in_elem X Tx Y HYopen). }
claim HTy: topology_on Y (subspace_topology X Tx Y).
{ exact (subspace_topology_is_topology X Tx Y HTx HYsub). }
claim HBcX: Baire_space_closed X Tx.
{ exact (Baire_space_imp_closed X Tx HB). }
claim HpropX:
  forall Fam0:set,
    countable_set Fam0 ->
    (forall A0:set, A0 :e Fam0 -> closed_in X Tx A0 /\ interior_of X Tx A0 = Empty) ->
    interior_of X Tx (Union Fam0) = Empty.
{ exact (andER (topology_on X Tx)
               (forall Fam0:set,
                 countable_set Fam0 ->
                 (forall A0:set, A0 :e Fam0 -> closed_in X Tx A0 /\ interior_of X Tx A0 = Empty) ->
                 interior_of X Tx (Union Fam0) = Empty)
               HBcX). }

claim HBcY: Baire_space_closed Y (subspace_topology X Tx Y).
{ prove topology_on Y (subspace_topology X Tx Y) /\
    forall Fam:set,
      countable_set Fam ->
      (forall A:set, A :e Fam ->
        closed_in Y (subspace_topology X Tx Y) A /\ interior_of Y (subspace_topology X Tx Y) A = Empty) ->
      interior_of Y (subspace_topology X Tx Y) (Union Fam) = Empty.
  apply andI.
  - exact HTy.
  - let Fam. assume Hcount: countable_set Fam.
    assume HFam: forall A:set, A :e Fam ->
      closed_in Y (subspace_topology X Tx Y) A /\ interior_of Y (subspace_topology X Tx Y) A = Empty.
    prove interior_of Y (subspace_topology X Tx Y) (Union Fam) = Empty.
    set FamX := {closure_of X Tx A | A :e Fam}.
    claim HcountX: countable_set FamX.
    { exact (countable_image Fam Hcount (fun A0:set => closure_of X Tx A0)). }
    claim HFamX: forall C:set, C :e FamX -> closed_in X Tx C /\ interior_of X Tx C = Empty.
    { let C. assume HC: C :e FamX.
      claim HexA: exists A:set, A :e Fam /\ C = closure_of X Tx A.
      { exact (ReplE Fam (fun A0:set => closure_of X Tx A0) C HC). }
      apply HexA.
      let A. assume HA: A :e Fam /\ C = closure_of X Tx A.
      claim HAin: A :e Fam.
      { exact (andEL (A :e Fam) (C = closure_of X Tx A) HA). }
      claim HeqC: C = closure_of X Tx A.
      { exact (andER (A :e Fam) (C = closure_of X Tx A) HA). }
      claim HApack: closed_in Y (subspace_topology X Tx Y) A /\ interior_of Y (subspace_topology X Tx Y) A = Empty.
      { exact (HFam A HAin). }
      claim HclosedY: closed_in Y (subspace_topology X Tx Y) A.
      { exact (andEL (closed_in Y (subspace_topology X Tx Y) A)
                     (interior_of Y (subspace_topology X Tx Y) A = Empty)
                     HApack). }
      claim HintY: interior_of Y (subspace_topology X Tx Y) A = Empty.
      { exact (andER (closed_in Y (subspace_topology X Tx Y) A)
                     (interior_of Y (subspace_topology X Tx Y) A = Empty)
                     HApack). }
      claim HAsubY: A c= Y.
      { exact (closed_in_subset Y (subspace_topology X Tx Y) A HclosedY). }
      claim HAsubX: A c= X.
      { let a. assume Ha: a :e A.
        exact (HYsub a (HAsubY a Ha)). }
      claim HclosedX: closed_in X Tx (closure_of X Tx A).
      { exact (closure_is_closed X Tx A HTx HAsubX). }
      claim HintX: interior_of X Tx (closure_of X Tx A) = Empty.
      { apply set_ext.
        - let x. assume Hx: x :e interior_of X Tx (closure_of X Tx A).
          prove x :e Empty.
          claim HexU: exists U:set, U :e Tx /\ x :e U /\ U c= closure_of X Tx A.
          { exact (SepE2 X (fun x0:set => exists U:set, U :e Tx /\ x0 :e U /\ U c= closure_of X Tx A) x Hx). }
          apply HexU.
          let U. assume HU: U :e Tx /\ x :e U /\ U c= closure_of X Tx A.
          claim HU12: U :e Tx /\ x :e U.
          { exact (andEL (U :e Tx /\ x :e U) (U c= closure_of X Tx A) HU). }
          claim HUinTx: U :e Tx.
          { exact (andEL (U :e Tx) (x :e U) HU12). }
          claim HxU: x :e U.
          { exact (andER (U :e Tx) (x :e U) HU12). }
          claim HUsub: U c= closure_of X Tx A.
          { exact (andER (U :e Tx /\ x :e U) (U c= closure_of X Tx A) HU). }
          claim HxclA: x :e closure_of X Tx A.
          { exact (HUsub x HxU). }
          claim Hclcond: forall V:set, V :e Tx -> x :e V -> V :/\: A <> Empty.
          { exact (SepE2 X (fun x0:set => forall V:set, V :e Tx -> x0 :e V -> V :/\: A <> Empty) x HxclA). }
          claim HUAne: U :/\: A <> Empty.
          { exact (Hclcond U HUinTx HxU). }
          claim Hexy: exists y:set, y :e U :/\: A.
          { exact (nonempty_has_element (U :/\: A) HUAne). }
          apply Hexy.
          let y. assume HyUA: y :e U :/\: A.
          claim HyU: y :e U.
          { exact (binintersectE1 U A y HyUA). }
          claim HyA: y :e A.
          { exact (binintersectE2 U A y HyUA). }
          claim HyY: y :e Y.
          { exact (HAsubY y HyA). }
          claim HUyOpenX: (U :/\: Y) :e Tx.
          { exact (lemma_intersection_two_open X Tx U Y HTx HUinTx HYinTx). }
          claim HUyOpenY: (U :/\: Y) :e subspace_topology X Tx Y.
          { exact (subspace_topologyI X Tx Y U HUinTx). }
          claim HclYeq: closure_of Y (subspace_topology X Tx Y) A = A.
          { exact (closed_closure_eq Y (subspace_topology X Tx Y) A HTy HclosedY). }
          claim HclSub: closure_of Y (subspace_topology X Tx Y) A = (closure_of X Tx A) :/\: Y.
          { exact (closure_in_subspace X Tx Y A HTx HYsub HAsubY). }
          claim HAeq: A = (closure_of X Tx A) :/\: Y.
          { rewrite <- HclYeq at 1.
            exact HclSub. }
          claim HUySubA: (U :/\: Y) c= A.
          { let z. assume Hz: z :e U :/\: Y.
            prove z :e A.
            rewrite HAeq.
            apply binintersectI.
            - exact (HUsub z (binintersectE1 U Y z Hz)).
            - exact (binintersectE2 U Y z Hz). }
          claim HyIntY: y :e interior_of Y (subspace_topology X Tx Y) A.
          { claim HdefInt: interior_of Y (subspace_topology X Tx Y) A =
              {y0 :e Y | exists W:set, W :e subspace_topology X Tx Y /\ y0 :e W /\ W c= A}.
            { reflexivity. }
            rewrite HdefInt.
            apply (SepI Y (fun y0:set => exists W:set, W :e subspace_topology X Tx Y /\ y0 :e W /\ W c= A) y).
            - exact HyY.
            - witness (U :/\: Y).
              apply and3I.
              + exact HUyOpenY.
              + exact (binintersectI U Y y HyU HyY).
              + exact HUySubA. }
          claim HyEmpty: y :e Empty.
          { rewrite <- HintY.
            exact HyIntY. }
          apply FalseE.
          exact (EmptyE y HyEmpty).
        - let x. assume HxE: x :e Empty.
          prove x :e interior_of X Tx (closure_of X Tx A).
          apply FalseE.
          exact (EmptyE x HxE). }
      apply andI.
      - prove closed_in X Tx C.
        rewrite HeqC.
        exact HclosedX.
      - prove interior_of X Tx C = Empty.
        rewrite HeqC.
        exact HintX. }
    claim HintUnionX: interior_of X Tx (Union FamX) = Empty.
    { exact (HpropX FamX HcountX HFamX). }
    claim HUnionSub: Union Fam c= Union FamX.
    { let z. assume Hz: z :e Union Fam.
      prove z :e Union FamX.
      apply (UnionE_impred Fam z Hz (z :e Union FamX)).
      let A. assume HzA: z :e A. assume HAin: A :e Fam.
      claim HAsubY: A c= Y.
      { exact (closed_in_subset Y (subspace_topology X Tx Y) A
               (andEL (closed_in Y (subspace_topology X Tx Y) A)
                      (interior_of Y (subspace_topology X Tx Y) A = Empty)
                      (HFam A HAin))). }
      claim HAsubX: A c= X.
      { let a. assume HaA: a :e A.
        exact (HYsub a (HAsubY a HaA)). }
      claim Hzcl: z :e closure_of X Tx A.
      { exact (subset_of_closure X Tx A HTx HAsubX z HzA). }
      claim Hmem: (closure_of X Tx A) :e FamX.
      { exact (ReplI Fam (fun A0:set => closure_of X Tx A0) A HAin). }
      exact (UnionI FamX z (closure_of X Tx A) Hzcl Hmem). }
    apply set_ext.
    - let y. assume Hy: y :e interior_of Y (subspace_topology X Tx Y) (Union Fam).
      prove y :e Empty.
      claim HexW: exists W:set, W :e subspace_topology X Tx Y /\ y :e W /\ W c= Union Fam.
      { exact (SepE2 Y (fun y0:set => exists W:set, W :e subspace_topology X Tx Y /\ y0 :e W /\ W c= Union Fam) y Hy). }
      apply HexW.
      let W. assume HW: W :e subspace_topology X Tx Y /\ y :e W /\ W c= Union Fam.
      claim HW12: W :e subspace_topology X Tx Y /\ y :e W.
      { exact (andEL (W :e subspace_topology X Tx Y /\ y :e W) (W c= Union Fam) HW). }
      claim HWTy: W :e subspace_topology X Tx Y.
      { exact (andEL (W :e subspace_topology X Tx Y) (y :e W) HW12). }
      claim HyW: y :e W.
      { exact (andER (W :e subspace_topology X Tx Y) (y :e W) HW12). }
      claim HWsubU: W c= Union Fam.
      { exact (andER (W :e subspace_topology X Tx Y /\ y :e W) (W c= Union Fam) HW). }
      claim HexV: exists V :e Tx, W = V :/\: Y.
      { exact (subspace_topologyE X Tx Y W HWTy). }
      apply HexV.
      let V. assume HV: V :e Tx /\ W = V :/\: Y.
      claim HVTx: V :e Tx.
      { exact (andEL (V :e Tx) (W = V :/\: Y) HV). }
      claim HWdef: W = V :/\: Y.
      { exact (andER (V :e Tx) (W = V :/\: Y) HV). }
      claim HWTx: W :e Tx.
      { rewrite HWdef.
        exact (lemma_intersection_two_open X Tx V Y HTx HVTx HYinTx). }
      claim HyY: y :e Y.
      { exact (SepE1 Y (fun y0:set => exists W0:set, W0 :e subspace_topology X Tx Y /\ y0 :e W0 /\ W0 c= Union Fam) y Hy). }
      claim HyX: y :e X.
      { exact (HYsub y HyY). }
      claim HyW_X: y :e W.
      { exact HyW. }
      claim HWsubUnionX: W c= Union FamX.
      { let z. assume HzW: z :e W.
        claim HzUnion: z :e Union Fam.
        { exact (HWsubU z HzW). }
        exact (HUnionSub z HzUnion). }
      claim HyIntX: y :e interior_of X Tx (Union FamX).
      { claim HdefIntX: interior_of X Tx (Union FamX) =
          {x0 :e X | exists U:set, U :e Tx /\ x0 :e U /\ U c= Union FamX}.
        { reflexivity. }
        rewrite HdefIntX.
        apply (SepI X (fun x0:set => exists U:set, U :e Tx /\ x0 :e U /\ U c= Union FamX) y HyX).
        witness W.
        apply and3I.
        - exact HWTx.
        - exact HyW_X.
        - exact HWsubUnionX. }
      claim HyEmpty: y :e Empty.
      { rewrite <- HintUnionX.
        exact HyIntX. }
      exact HyEmpty.
    - let y. assume HyE: y :e Empty.
      prove y :e interior_of Y (subspace_topology X Tx Y) (Union Fam).
      apply FalseE.
      exact (EmptyE y HyE). }
exact (Baire_space_closed_imp Y (subspace_topology X Tx Y) HBcY).
Qed.

(** helper block moved earlier: continuity at a point and uniform limit infrastructure are needed for §35 **)
(** see earlier placement just before §35 after the metric completeness primitives **)
(** helper: Cauchy tail set A_N(eps) for a sequence of maps into a metric space **)
(** LATEX VERSION: A_N(eps) is the set of x such that d(f_n(x),f_m(x)) ≤ eps for all n,m ≥ N. **)
Definition A_N_eps : set -> set -> set -> set -> set -> set -> set :=
  fun X Y d fn N eps =>
    {x :e X |
      forall n:set, n :e omega -> N c= n ->
        forall m:set, m :e omega -> N c= m ->
          Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps }.

(** helper: monotonicity of A_N_eps in eps **)
(** LATEX VERSION: If eps1 <= eps2 then A_N(eps1) is a subset of A_N(eps2). **)
Theorem A_N_eps_monotone : forall X Y d fn N eps1 eps2:set,
  eps1 :e R -> eps2 :e R -> Rle eps1 eps2 ->
  A_N_eps X Y d fn N eps1 c= A_N_eps X Y d fn N eps2.
let X Y d fn N eps1 eps2.
assume Heps1R: eps1 :e R.
assume Heps2R: eps2 :e R.
assume Heps12: Rle eps1 eps2.
prove A_N_eps X Y d fn N eps1 c= A_N_eps X Y d fn N eps2.
let x. assume Hx: x :e A_N_eps X Y d fn N eps1.
prove x :e A_N_eps X Y d fn N eps2.
claim HdefA2: A_N_eps X Y d fn N eps2 =
  {x0 :e X |
    forall n:set, n :e omega -> N c= n ->
      forall m:set, m :e omega -> N c= m ->
        Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps2 }.
{ reflexivity. }
rewrite HdefA2.
claim HxX: x :e X.
{ exact (SepE1 X
          (fun x0:set =>
            forall n:set, n :e omega -> N c= n ->
              forall m:set, m :e omega -> N c= m ->
                Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps1)
          x Hx). }
claim HxProp:
  forall n:set, n :e omega -> N c= n ->
    forall m:set, m :e omega -> N c= m ->
      Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps1.
{ exact (SepE2 X
          (fun x0:set =>
            forall n:set, n :e omega -> N c= n ->
              forall m:set, m :e omega -> N c= m ->
                Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps1)
          x Hx). }
apply (SepI X
  (fun x0:set =>
    forall n:set, n :e omega -> N c= n ->
      forall m:set, m :e omega -> N c= m ->
        Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps2)
  x
  HxX).
let n. assume HnO: n :e omega. assume HNn: N c= n.
let m. assume HmO: m :e omega. assume HNm: N c= m.
claim Hle1: Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps1.
{ exact (HxProp n HnO HNn m HmO HNm). }
exact (Rle_tra
  (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x))
  eps1
  eps2
  Hle1
  Heps12).
Qed.

(** helper: distance map is continuous in the product topology of a metric space **)
(** LATEX VERSION: The distance function d:Y×Y→R is continuous for the product of the metric topology on Y. **)
Theorem metric_distance_above_has_product_ball : forall Y d a p:set,
  metric_on_total Y d ->
  a :e R ->
  p :e preimage_of (setprod Y Y) d (open_ray_upper R a) ->
  exists r:set, r :e R /\ Rlt 0 r /\
    rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)
      c= preimage_of (setprod Y Y) d (open_ray_upper R a).
let Y d a p.
assume Hd: metric_on_total Y d.
assume HaR: a :e R.
assume Hp: p :e preimage_of (setprod Y Y) d (open_ray_upper R a).
claim HpDom: p :e setprod Y Y.
{ exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_upper R a) p Hp). }
set dp := apply_fun d p.
claim HdpRay: dp :e open_ray_upper R a.
{ exact (SepE2 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_upper R a) p Hp). }
claim HrayDef: open_ray_upper R a = {x :e R | order_rel R a x}.
{ reflexivity. }
claim HdpRay': dp :e {x :e R | order_rel R a x}.
{ rewrite <- HrayDef.
  exact HdpRay. }
claim HdpR: dp :e R.
{ exact (SepE1 R (fun x0:set => order_rel R a x0) dp HdpRay'). }
claim Hdprel: order_rel R a dp.
{ exact (SepE2 R (fun x0:set => order_rel R a x0) dp HdpRay'). }
claim Hlt: Rlt a dp.
{ exact (order_rel_R_implies_Rlt a dp Hdprel). }
claim Hp0Y: p 0 :e Y.
{ exact (ap0_Sigma Y (fun _ : set => Y) p HpDom). }
claim Hp1Y: p 1 :e Y.
{ exact (ap1_Sigma Y (fun _ : set => Y) p HpDom). }
claim HaS: SNo a.
{ exact (real_SNo a HaR). }
claim HdpS: SNo dp.
{ exact (real_SNo dp HdpR). }
claim HmaR: minus_SNo a :e R.
{ exact (real_minus_SNo a HaR). }
claim HmaS: SNo (minus_SNo a).
{ exact (real_SNo (minus_SNo a) HmaR). }
set dgap := add_SNo (minus_SNo a) dp.
claim HdgapR: dgap :e R.
{ exact (real_add_SNo (minus_SNo a) HmaR dp HdpR). }
claim HltS: a < dp.
{ exact (RltE_lt a dp Hlt). }
claim HsumLt: add_SNo (minus_SNo a) a < add_SNo (minus_SNo a) dp.
{ exact (add_SNo_Lt2 (minus_SNo a) a dp HmaS HaS HdpS HltS). }
claim HgapPosS: 0 < dgap.
{ rewrite <- (add_SNo_minus_SNo_linv a HaS) at 1.
  exact HsumLt. }
claim HgapPos: Rlt 0 dgap.
{ exact (RltI 0 dgap real_0 HdgapR HgapPosS). }

apply (exists_eps_lt_pos_Euclid dgap HdgapR HgapPos).
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (eps_ N < dgap) HNpair). }
claim HepsNlt: eps_ N < dgap.
{ exact (andER (N :e omega) (eps_ N < dgap) HNpair). }
set r := eps_ (ordsucc N).
claim HsuccO: ordsucc N :e omega.
{ exact (omega_ordsucc N HNomega). }
claim HrR: r :e R.
{ exact (SNoS_omega_real r (SNo_eps_SNoS_omega (ordsucc N) HsuccO)). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim H0ltr: 0 < r.
{ exact (SNo_eps_pos (ordsucc N) HsuccO). }
claim HrPos: Rlt 0 r.
{ exact (RltI 0 r real_0 HrR H0ltr). }
claim HrHalf: add_SNo r r = eps_ N.
{ exact (eps_ordsucc_half_add N (omega_nat_p N HNomega)). }
claim HepsS: SNo (eps_ N).
{ exact (SNo_eps_ N HNomega). }
claim HdgapS: SNo dgap.
{ exact (real_SNo dgap HdgapR). }
claim HtmpLt: add_SNo a (eps_ N) < add_SNo a dgap.
{ exact (add_SNo_Lt2 a (eps_ N) dgap HaS HepsS HdgapS HepsNlt). }
claim Haeq: add_SNo a dgap = dp.
{ claim HdgapDef: dgap = add_SNo (minus_SNo a) dp.
  { reflexivity. }
  rewrite HdgapDef.
  rewrite (add_SNo_assoc a (minus_SNo a) dp HaS HmaS HdpS).
  rewrite (add_SNo_minus_SNo_rinv a HaS).
  exact (add_SNo_0L dp HdpS). }
claim HaepsLt: add_SNo a (eps_ N) < dp.
{ rewrite <- Haeq.
  exact HtmpLt. }
claim HarLt: add_SNo a (add_SNo r r) < dp.
{ rewrite HrHalf.
  exact HaepsLt. }

witness r.
apply andI.
- apply andI.
  + exact HrR.
  + exact HrPos.
- (** Main metric-rectangle containment argument remains to be completed. **)
  (** It uses triangle inequality and HarLt to show any (u,v) in the rectangle has a < d(u,v). **)
  prove rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)
        c= preimage_of (setprod Y Y) d (open_ray_upper R a).
  let q.
  assume HqRect: q :e rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
  claim HqProd: q :e setprod (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
  { prove q :e setprod (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
    rewrite <- (rectangle_set_def (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)).
    exact HqRect. }
  claim HsubU: open_ball Y d (p 0) r c= Y.
  { exact (open_ball_subset_X Y d (p 0) r). }
  claim HsubV: open_ball Y d (p 1) r c= Y.
  { exact (open_ball_subset_X Y d (p 1) r). }
  claim HqDom: q :e setprod Y Y.
  { exact ((setprod_Subq (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) Y Y HsubU HsubV) q HqProd). }
  prove q :e preimage_of (setprod Y Y) d (open_ray_upper R a).
  claim HpreDef: preimage_of (setprod Y Y) d (open_ray_upper R a)
    = {x :e setprod Y Y | apply_fun d x :e open_ray_upper R a}.
  { reflexivity. }
  rewrite HpreDef.
  apply (SepI (setprod Y Y) (fun q0:set => apply_fun d q0 :e open_ray_upper R a) q HqDom).
  prove apply_fun d q :e open_ray_upper R a.
  set dq := apply_fun d q.
  claim Hm: metric_on Y d.
  { exact (metric_on_total_imp_metric_on Y d Hd). }
  claim Hfun: function_on d (setprod Y Y) R.
  { exact (metric_on_function_on Y d Hm). }
  claim HdqR: dq :e R.
  { exact (Hfun q HqDom). }
  claim HdpDef: dp = apply_fun d p.
  { reflexivity. }
  claim HdpEta: dp = apply_fun d (p 0, p 1).
  { rewrite HdpDef.
    rewrite (setprod_eta Y Y p HpDom) at 1.
    reflexivity. }
  claim HetaQ: q = (q 0, q 1).
  { exact (setprod_eta (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) q HqProd). }
  claim HdqEta: dq = apply_fun d (q 0, q 1).
  { claim HdqDef: dq = apply_fun d q.
    { reflexivity. }
    rewrite HdqDef.
    rewrite HetaQ at 1.
    reflexivity. }

  rewrite HrayDef.
  apply (SepI R (fun x0:set => order_rel R a x0) dq HdqR).
  prove order_rel R a dq.
  apply (Rlt_implies_order_rel_R a dq).
  apply (dneg (Rlt a dq)).
  assume Hn: ~(Rlt a dq).
  prove False.

  claim HdqLeA: Rle dq a.
  { exact (RleI dq a HdqR HaR Hn). }
  claim Hq0Ball: q 0 :e open_ball Y d (p 0) r.
  { exact (ap0_Sigma (open_ball Y d (p 0) r) (fun _ : set => open_ball Y d (p 1) r) q HqProd). }
  claim Hq1Ball: q 1 :e open_ball Y d (p 1) r.
  { exact (ap1_Sigma (open_ball Y d (p 0) r) (fun _ : set => open_ball Y d (p 1) r) q HqProd). }
  claim Hq0Y: q 0 :e Y.
  { exact (open_ballE1 Y d (p 0) r (q 0) Hq0Ball). }
  claim Hq1Y: q 1 :e Y.
  { exact (open_ballE1 Y d (p 1) r (q 1) Hq1Ball). }
  claim HxRlt: Rlt (apply_fun d (p 0, q 0)) r.
  { exact (open_ballE2 Y d (p 0) r (q 0) Hq0Ball). }
  claim HyRle: Rle (apply_fun d (q 0, q 1)) a.
  { rewrite <- HdqEta.
    exact HdqLeA. }
  claim HzRlt0: Rlt (apply_fun d (p 1, q 1)) r.
  { exact (open_ballE2 Y d (p 1) r (q 1) Hq1Ball). }
  claim HsymZ: apply_fun d (p 1, q 1) = apply_fun d (q 1, p 1).
  { exact (metric_on_symmetric Y d (p 1) (q 1) Hm Hp1Y Hq1Y). }
  claim HzRlt: Rlt (apply_fun d (q 1, p 1)) r.
  { rewrite <- HsymZ.
    exact HzRlt0. }

  claim HxR: apply_fun d (p 0, q 0) :e R.
  { exact (Hfun (p 0, q 0) (tuple_2_setprod_by_pair_Sigma Y Y (p 0) (q 0) Hp0Y Hq0Y)). }
  claim HyR: apply_fun d (q 0, q 1) :e R.
  { exact (Hfun (q 0, q 1) (tuple_2_setprod_by_pair_Sigma Y Y (q 0) (q 1) Hq0Y Hq1Y)). }
  claim HzR: apply_fun d (q 1, p 1) :e R.
  { exact (Hfun (q 1, p 1) (tuple_2_setprod_by_pair_Sigma Y Y (q 1) (p 1) Hq1Y Hp1Y)). }
  claim HyzR: add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)) :e R.
  { exact (real_add_SNo (apply_fun d (q 0, q 1)) HyR (apply_fun d (q 1, p 1)) HzR). }
  claim HxrR: r :e R.
  { exact HrR. }
  claim HxLeR: Rle (apply_fun d (p 0, q 0)) r.
  { exact (Rlt_implies_Rle (apply_fun d (p 0, q 0)) r HxRlt). }
  claim HzLeR: Rle (apply_fun d (q 1, p 1)) r.
  { exact (Rlt_implies_Rle (apply_fun d (q 1, p 1)) r HzRlt). }

  (** dp <= d(p0,q0) + (d(q0,q1) + d(q1,p1)) **)
  claim Htri1: Rle (apply_fun d (p 0, p 1))
                  (add_SNo (apply_fun d (p 0, q 0)) (apply_fun d (q 0, p 1))).
  { exact (metric_triangle_Rle Y d (p 0) (q 0) (p 1) Hm Hp0Y Hq0Y Hp1Y). }
  claim Htri1dp: Rle dp (add_SNo (apply_fun d (p 0, q 0)) (apply_fun d (q 0, p 1))).
  { rewrite HdpEta.
    exact Htri1. }
  claim Htri2: Rle (apply_fun d (q 0, p 1))
                  (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1))).
  { exact (metric_triangle_Rle Y d (q 0) (q 1) (p 1) Hm Hq0Y Hq1Y Hp1Y). }
  claim Hlift: Rle (add_SNo (apply_fun d (p 0, q 0)) (apply_fun d (q 0, p 1)))
                   (add_SNo (apply_fun d (p 0, q 0)) (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)))).
  { exact (Rle_add_SNo_2 (apply_fun d (p 0, q 0)) (apply_fun d (q 0, p 1))
                         (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)))
                         HxR
                         (Hfun (q 0, p 1) (tuple_2_setprod_by_pair_Sigma Y Y (q 0) (p 1) Hq0Y Hp1Y))
                         HyzR
                         Htri2). }
  claim HdpLeSum0: Rle dp
    (add_SNo (apply_fun d (p 0, q 0)) (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)))).
  { exact (Rle_tra dp (add_SNo (apply_fun d (p 0, q 0)) (apply_fun d (q 0, p 1)))
                 (add_SNo (apply_fun d (p 0, q 0)) (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1))))
                 Htri1dp Hlift). }

  (** replace d(q0,q1) by a using HyRle, then bound the two end terms by r **)
  claim HyzLe: Rle (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)))
                  (add_SNo a (apply_fun d (q 1, p 1))).
  { claim Hcom1: add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1))
               = add_SNo (apply_fun d (q 1, p 1)) (apply_fun d (q 0, q 1)).
    { exact (add_SNo_com (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)) (real_SNo (apply_fun d (q 0, q 1)) HyR) (real_SNo (apply_fun d (q 1, p 1)) HzR)). }
    claim Hcom2: add_SNo a (apply_fun d (q 1, p 1)) = add_SNo (apply_fun d (q 1, p 1)) a.
    { exact (add_SNo_com a (apply_fun d (q 1, p 1)) HaS (real_SNo (apply_fun d (q 1, p 1)) HzR)). }
    rewrite Hcom1.
    rewrite Hcom2.
    exact (Rle_add_SNo_2 (apply_fun d (q 1, p 1)) (apply_fun d (q 0, q 1)) a
                         HzR HyR HaR HyRle). }
  claim Hsum1: Rle (add_SNo (apply_fun d (p 0, q 0))
                            (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1))))
                   (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a (apply_fun d (q 1, p 1)))).
  { exact (Rle_add_SNo_2 (apply_fun d (p 0, q 0))
                         (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1)))
                         (add_SNo a (apply_fun d (q 1, p 1)))
                         HxR HyzR (real_add_SNo a HaR (apply_fun d (q 1, p 1)) HzR)
                         HyzLe). }
  claim HdpLeSum1: Rle dp (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a (apply_fun d (q 1, p 1)))).
  { exact (Rle_tra dp
                 (add_SNo (apply_fun d (p 0, q 0)) (add_SNo (apply_fun d (q 0, q 1)) (apply_fun d (q 1, p 1))))
                 (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a (apply_fun d (q 1, p 1))))
                 HdpLeSum0 Hsum1). }
  claim HazLe: Rle (add_SNo a (apply_fun d (q 1, p 1))) (add_SNo a r).
  { exact (Rle_add_SNo_2 a (apply_fun d (q 1, p 1)) r HaR HzR HrR HzLeR). }
  claim HdpLeSum2: Rle dp (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a r)).
  { exact (Rle_tra dp
                 (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a (apply_fun d (q 1, p 1))))
                 (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a r))
                 HdpLeSum1
                 (Rle_add_SNo_2 (apply_fun d (p 0, q 0)) (add_SNo a (apply_fun d (q 1, p 1))) (add_SNo a r)
                                HxR
                                (real_add_SNo a HaR (apply_fun d (q 1, p 1)) HzR)
                                (real_add_SNo a HaR r HrR)
                                HazLe)). }
  claim HcomX: add_SNo (apply_fun d (p 0, q 0)) (add_SNo a r)
             = add_SNo (add_SNo a r) (apply_fun d (p 0, q 0)).
  { exact (add_SNo_com (apply_fun d (p 0, q 0)) (add_SNo a r) (real_SNo (apply_fun d (p 0, q 0)) HxR)
                       (real_SNo (add_SNo a r) (real_add_SNo a HaR r HrR))). }
  claim HdpLeSum3: Rle dp (add_SNo (add_SNo a r) r).
  { claim HmidLe: Rle (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a r)) (add_SNo (add_SNo a r) r).
    { rewrite HcomX.
      exact (Rle_add_SNo_2 (add_SNo a r) (apply_fun d (p 0, q 0)) r
                           (real_add_SNo a HaR r HrR) HxR HrR HxLeR). }
    exact (Rle_tra dp (add_SNo (apply_fun d (p 0, q 0)) (add_SNo a r)) (add_SNo (add_SNo a r) r)
               HdpLeSum2 HmidLe). }
  claim Hassoc: add_SNo (add_SNo a r) r = add_SNo a (add_SNo r r).
  { rewrite <- (add_SNo_assoc a r r HaS HrS HrS).
    reflexivity. }
  claim HdpLeFinal: Rle dp (add_SNo a (add_SNo r r)).
  { rewrite <- Hassoc.
    exact HdpLeSum3. }

  claim HarR: add_SNo a (add_SNo r r) :e R.
  { exact (real_add_SNo a HaR (add_SNo r r) (real_add_SNo r HrR r HrR)). }
  claim HarRlt: Rlt (add_SNo a (add_SNo r r)) dp.
  { exact (RltI (add_SNo a (add_SNo r r)) dp HarR HdpR HarLt). }
  exact ((RleE_nlt dp (add_SNo a (add_SNo r r)) HdpLeFinal) HarRlt).
Qed.

Theorem metric_distance_preimage_open_ray_upper : forall Y d a:set,
  metric_on_total Y d ->
  a :e R ->
  preimage_of (setprod Y Y) d (open_ray_upper R a) :e
    (product_topology Y (metric_topology Y d) Y (metric_topology Y d)).
let Y d a.
assume Hd: metric_on_total Y d.
assume HaR: a :e R.
set Ty := metric_topology Y d.
set Tprod := product_topology Y Ty Y Ty.
set W := preimage_of (setprod Y Y) d (open_ray_upper R a).
prove W :e product_topology Y Ty Y Ty.
claim HdefT: product_topology Y Ty Y Ty =
  generated_topology (setprod Y Y) (product_subbasis Y Ty Y Ty).
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod Y Y) (product_subbasis Y Ty Y Ty) =
  {U :e Power (setprod Y Y) |
    forall p :e U, exists b :e product_subbasis Y Ty Y Ty, p :e b /\ b c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod Y Y))
  (fun U:set =>
    forall p :e U, exists b :e product_subbasis Y Ty Y Ty, p :e b /\ b c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_upper R a) p Hp).
- let p. assume Hp: p :e W.
  prove exists b :e product_subbasis Y Ty Y Ty, p :e b /\ b c= W.
  claim HpDom: p :e setprod Y Y.
  { exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_upper R a) p Hp). }
  claim Hp0Y: p 0 :e Y.
  { exact (ap0_Sigma Y (fun _ : set => Y) p HpDom). }
  claim Hp1Y: p 1 :e Y.
  { exact (ap1_Sigma Y (fun _ : set => Y) p HpDom). }
  claim Hm: metric_on Y d.
  { exact (metric_on_total_imp_metric_on Y d Hd). }
  claim Hexr: exists r:set, r :e R /\ Rlt 0 r /\
    rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact (metric_distance_above_has_product_ball Y d a p Hd HaR Hp). }
  apply Hexr.
  let r. assume Hr.
  claim HrPack: (r :e R /\ Rlt 0 r) /\ rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact Hr. }
  claim Hr1: r :e R /\ Rlt 0 r.
  { exact (andEL (r :e R /\ Rlt 0 r)
                 (rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W)
                 HrPack). }
  claim HrR: r :e R.
  { exact (andEL (r :e R) (Rlt 0 r) Hr1). }
  claim HrPos: Rlt 0 r.
  { exact (andER (r :e R) (Rlt 0 r) Hr1). }
  claim Hbsub: rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact (andER (r :e R /\ Rlt 0 r)
                 (rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W)
                 HrPack). }
  set U := open_ball Y d (p 0) r.
  set V := open_ball Y d (p 1) r.
  set b := rectangle_set U V.
  witness b.
  apply andI.
  - prove b :e product_subbasis Y Ty Y Ty.
    prove b :e \/_ U0 :e Ty, {rectangle_set U0 V0|V0 :e Ty}.
    claim HUinTy: U :e Ty.
    { exact (open_ball_in_metric_topology Y d (p 0) r Hm Hp0Y HrPos). }
    claim HVinTy: V :e Ty.
    { exact (open_ball_in_metric_topology Y d (p 1) r Hm Hp1Y HrPos). }
    claim HbInFam: b :e {rectangle_set U V0|V0 :e Ty}.
    { exact (ReplI Ty (fun V0:set => rectangle_set U V0) V HVinTy). }
    exact (famunionI Ty (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) U b HUinTy HbInFam).
  - apply andI.
	    + prove p :e b.
	      claim HbEq0: b = rectangle_set U V.
	      { reflexivity. }
	      rewrite HbEq0.
	      rewrite rectangle_set_def.
	      claim HpEta0: p = (p 0, p 1).
	      { exact (setprod_eta Y Y p HpDom). }
	      rewrite HpEta0 at 1.
	      claim Hp0In: p 0 :e U.
	      { exact (center_in_open_ball Y d (p 0) r Hm Hp0Y HrPos). }
	      claim Hp1In: p 1 :e V.
	      { exact (center_in_open_ball Y d (p 1) r Hm Hp1Y HrPos). }
	      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0In Hp1In).
    + prove b c= W.
      claim HbEq: b = rectangle_set U V.
      { reflexivity. }
      rewrite HbEq.
      exact Hbsub.
Qed.

Theorem metric_distance_below_has_product_ball : forall Y d b p:set,
  metric_on_total Y d ->
  b :e R ->
  p :e preimage_of (setprod Y Y) d (open_ray_lower R b) ->
  exists r:set, r :e R /\ Rlt 0 r /\
    rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)
      c= preimage_of (setprod Y Y) d (open_ray_lower R b).
let Y d b p.
assume Hd: metric_on_total Y d.
assume HbR: b :e R.
assume Hp: p :e preimage_of (setprod Y Y) d (open_ray_lower R b).
claim HpDom: p :e setprod Y Y.
{ exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_lower R b) p Hp). }
set dp := apply_fun d p.
claim HdpRay: dp :e open_ray_lower R b.
{ exact (SepE2 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_lower R b) p Hp). }
claim HrayDef: open_ray_lower R b = {x :e R | order_rel R x b}.
{ reflexivity. }
claim HdpRay': dp :e {x :e R | order_rel R x b}.
{ rewrite <- HrayDef.
  exact HdpRay. }
claim HdpR: dp :e R.
{ exact (SepE1 R (fun x0:set => order_rel R x0 b) dp HdpRay'). }
claim Hdprel: order_rel R dp b.
{ exact (SepE2 R (fun x0:set => order_rel R x0 b) dp HdpRay'). }
claim Hlt: Rlt dp b.
{ exact (order_rel_R_implies_Rlt dp b Hdprel). }
claim Hp0Y: p 0 :e Y.
{ exact (ap0_Sigma Y (fun _ : set => Y) p HpDom). }
claim Hp1Y: p 1 :e Y.
{ exact (ap1_Sigma Y (fun _ : set => Y) p HpDom). }
claim HbS: SNo b.
{ exact (real_SNo b HbR). }
claim HdpS: SNo dp.
{ exact (real_SNo dp HdpR). }
claim HmdpR: minus_SNo dp :e R.
{ exact (real_minus_SNo dp HdpR). }
claim HmdpS: SNo (minus_SNo dp).
{ exact (real_SNo (minus_SNo dp) HmdpR). }
set dgap := add_SNo (minus_SNo dp) b.
claim HdgapR: dgap :e R.
{ exact (real_add_SNo (minus_SNo dp) HmdpR b HbR). }
claim HltS: dp < b.
{ exact (RltE_lt dp b Hlt). }
claim HsumLt: add_SNo (minus_SNo dp) dp < add_SNo (minus_SNo dp) b.
{ exact (add_SNo_Lt2 (minus_SNo dp) dp b HmdpS HdpS HbS HltS). }
claim HgapPosS: 0 < dgap.
{ rewrite <- (add_SNo_minus_SNo_linv dp HdpS) at 1.
  exact HsumLt. }
claim HgapPos: Rlt 0 dgap.
{ exact (RltI 0 dgap real_0 HdgapR HgapPosS). }

apply (exists_eps_lt_pos_Euclid dgap HdgapR HgapPos).
let N. assume HNpair.
claim HNomega: N :e omega.
{ exact (andEL (N :e omega) (eps_ N < dgap) HNpair). }
claim HepsNlt: eps_ N < dgap.
{ exact (andER (N :e omega) (eps_ N < dgap) HNpair). }
set r := eps_ (ordsucc N).
claim HsuccO: ordsucc N :e omega.
{ exact (omega_ordsucc N HNomega). }
claim HrR: r :e R.
{ exact (SNoS_omega_real r (SNo_eps_SNoS_omega (ordsucc N) HsuccO)). }
claim HrS: SNo r.
{ exact (real_SNo r HrR). }
claim H0ltr: 0 < r.
{ exact (SNo_eps_pos (ordsucc N) HsuccO). }
claim HrPos: Rlt 0 r.
{ exact (RltI 0 r real_0 HrR H0ltr). }
claim HrHalf: add_SNo r r = eps_ N.
{ exact (eps_ordsucc_half_add N (omega_nat_p N HNomega)). }
claim HepsS: SNo (eps_ N).
{ exact (SNo_eps_ N HNomega). }
claim HdgapS: SNo dgap.
{ exact (real_SNo dgap HdgapR). }
claim HtmpLt: add_SNo dp (eps_ N) < add_SNo dp dgap.
{ exact (add_SNo_Lt2 dp (eps_ N) dgap HdpS HepsS HdgapS HepsNlt). }
claim Hdeq: add_SNo dp dgap = b.
{ claim HdgapDef: dgap = add_SNo (minus_SNo dp) b.
  { reflexivity. }
  rewrite HdgapDef.
  rewrite (add_SNo_assoc dp (minus_SNo dp) b HdpS HmdpS HbS).
  rewrite (add_SNo_minus_SNo_rinv dp HdpS).
  exact (add_SNo_0L b HbS). }
claim HdpepsLt: add_SNo dp (eps_ N) < b.
{ rewrite <- Hdeq.
  exact HtmpLt. }
claim HdrLt: add_SNo dp (add_SNo r r) < b.
{ rewrite HrHalf.
  exact HdpepsLt. }

witness r.
apply andI.
- apply andI.
  + exact HrR.
  + exact HrPos.
- (** Main metric-rectangle containment argument remains to be completed. **)
  (** It uses triangle inequality and HdrLt to show any (u,v) in the rectangle has d(u,v) < b. **)
  prove rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)
        c= preimage_of (setprod Y Y) d (open_ray_lower R b).
  let q.
  assume HqRect: q :e rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
  claim HqProd: q :e setprod (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
  { prove q :e setprod (open_ball Y d (p 0) r) (open_ball Y d (p 1) r).
    rewrite <- (rectangle_set_def (open_ball Y d (p 0) r) (open_ball Y d (p 1) r)).
    exact HqRect. }
  claim HsubU: open_ball Y d (p 0) r c= Y.
  { exact (open_ball_subset_X Y d (p 0) r). }
  claim HsubV: open_ball Y d (p 1) r c= Y.
  { exact (open_ball_subset_X Y d (p 1) r). }
  claim HqDom: q :e setprod Y Y.
  { exact ((setprod_Subq (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) Y Y HsubU HsubV) q HqProd). }
  prove q :e preimage_of (setprod Y Y) d (open_ray_lower R b).
  claim HpreDef: preimage_of (setprod Y Y) d (open_ray_lower R b)
    = {x :e setprod Y Y | apply_fun d x :e open_ray_lower R b}.
  { reflexivity. }
  rewrite HpreDef.
  apply (SepI (setprod Y Y) (fun q0:set => apply_fun d q0 :e open_ray_lower R b) q HqDom).
  prove apply_fun d q :e open_ray_lower R b.
  set dq := apply_fun d q.
  claim Hm: metric_on Y d.
  { exact (metric_on_total_imp_metric_on Y d Hd). }
  claim Hfun: function_on d (setprod Y Y) R.
  { exact (metric_on_function_on Y d Hm). }
  claim HdqR: dq :e R.
  { exact (Hfun q HqDom). }
  claim HdpDef: dp = apply_fun d p.
  { reflexivity. }
  claim HdpEta: dp = apply_fun d (p 0, p 1).
  { rewrite HdpDef.
    rewrite (setprod_eta Y Y p HpDom) at 1.
    reflexivity. }
  claim HetaQ: q = (q 0, q 1).
  { exact (setprod_eta (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) q HqProd). }
  claim HdqEta: dq = apply_fun d (q 0, q 1).
  { claim HdqDef: dq = apply_fun d q.
    { reflexivity. }
    rewrite HdqDef.
    rewrite HetaQ at 1.
    reflexivity. }

  rewrite HrayDef.
  apply (SepI R (fun x0:set => order_rel R x0 b) dq HdqR).
  prove order_rel R dq b.
  apply (Rlt_implies_order_rel_R dq b).

  claim Hq0Ball: q 0 :e open_ball Y d (p 0) r.
  { exact (ap0_Sigma (open_ball Y d (p 0) r) (fun _ : set => open_ball Y d (p 1) r) q HqProd). }
  claim Hq1Ball: q 1 :e open_ball Y d (p 1) r.
  { exact (ap1_Sigma (open_ball Y d (p 0) r) (fun _ : set => open_ball Y d (p 1) r) q HqProd). }
  claim Hq0Y: q 0 :e Y.
  { exact (open_ballE1 Y d (p 0) r (q 0) Hq0Ball). }
  claim Hq1Y: q 1 :e Y.
  { exact (open_ballE1 Y d (p 1) r (q 1) Hq1Ball). }
  claim HxRlt0: Rlt (apply_fun d (p 0, q 0)) r.
  { exact (open_ballE2 Y d (p 0) r (q 0) Hq0Ball). }
  claim HzRlt: Rlt (apply_fun d (p 1, q 1)) r.
  { exact (open_ballE2 Y d (p 1) r (q 1) Hq1Ball). }
  claim HsymX: apply_fun d (p 0, q 0) = apply_fun d (q 0, p 0).
  { exact (metric_on_symmetric Y d (p 0) (q 0) Hm Hp0Y Hq0Y). }
  claim HxRlt: Rlt (apply_fun d (q 0, p 0)) r.
  { rewrite <- HsymX.
    exact HxRlt0. }

  claim HxR: apply_fun d (q 0, p 0) :e R.
  { exact (Hfun (q 0, p 0) (tuple_2_setprod_by_pair_Sigma Y Y (q 0) (p 0) Hq0Y Hp0Y)). }
  claim HyR: apply_fun d (q 0, q 1) :e R.
  { exact (Hfun (q 0, q 1) (tuple_2_setprod_by_pair_Sigma Y Y (q 0) (q 1) Hq0Y Hq1Y)). }
  claim HzR: apply_fun d (p 1, q 1) :e R.
  { exact (Hfun (p 1, q 1) (tuple_2_setprod_by_pair_Sigma Y Y (p 1) (q 1) Hp1Y Hq1Y)). }
  claim HrLeX: Rle (apply_fun d (q 0, p 0)) r.
  { exact (Rlt_implies_Rle (apply_fun d (q 0, p 0)) r HxRlt). }
  claim HrLeZ: Rle (apply_fun d (p 1, q 1)) r.
  { exact (Rlt_implies_Rle (apply_fun d (p 1, q 1)) r HzRlt). }

  (** dq <= d(q0,p0) + (dp + d(p1,q1)) **)
  claim Htri1: Rle (apply_fun d (q 0, q 1))
                  (add_SNo (apply_fun d (q 0, p 0)) (apply_fun d (p 0, q 1))).
  { exact (metric_triangle_Rle Y d (q 0) (p 0) (q 1) Hm Hq0Y Hp0Y Hq1Y). }
  claim Htri2: Rle (apply_fun d (p 0, q 1))
                  (add_SNo (apply_fun d (p 0, p 1)) (apply_fun d (p 1, q 1))).
  { exact (metric_triangle_Rle Y d (p 0) (p 1) (q 1) Hm Hp0Y Hp1Y Hq1Y). }
  claim Htri2dp: Rle (apply_fun d (p 0, q 1)) (add_SNo dp (apply_fun d (p 1, q 1))).
  { rewrite HdpEta.
    exact Htri2. }
  claim Hlift: Rle (add_SNo (apply_fun d (q 0, p 0)) (apply_fun d (p 0, q 1)))
                   (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1)))).
  { exact (Rle_add_SNo_2 (apply_fun d (q 0, p 0)) (apply_fun d (p 0, q 1))
                         (add_SNo dp (apply_fun d (p 1, q 1)))
                         HxR
                         (Hfun (p 0, q 1) (tuple_2_setprod_by_pair_Sigma Y Y (p 0) (q 1) Hp0Y Hq1Y))
                         (real_add_SNo dp HdpR (apply_fun d (p 1, q 1)) HzR)
                         Htri2dp). }
  claim HdqLe0: Rle (apply_fun d (q 0, q 1))
                  (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1)))).
  { exact (Rle_tra (apply_fun d (q 0, q 1))
                 (add_SNo (apply_fun d (q 0, p 0)) (apply_fun d (p 0, q 1)))
                 (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1))))
                 Htri1 Hlift). }
  claim HdqLe0': Rle dq (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1)))).
  { rewrite HdqEta.
    exact HdqLe0. }

  (** bound both end terms by r, and use HdrLt to conclude dq < b **)
  claim HdpzLe: Rle (add_SNo dp (apply_fun d (p 1, q 1))) (add_SNo dp r).
  { exact (Rle_add_SNo_2 dp (apply_fun d (p 1, q 1)) r HdpR HzR HrR HrLeZ). }
  claim Hsum1: Rle (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1))))
                   (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r)).
  { exact (Rle_add_SNo_2 (apply_fun d (q 0, p 0))
                         (add_SNo dp (apply_fun d (p 1, q 1)))
                         (add_SNo dp r)
                         HxR
                         (real_add_SNo dp HdpR (apply_fun d (p 1, q 1)) HzR)
                         (real_add_SNo dp HdpR r HrR)
                         HdpzLe). }
  claim HdqLe1: Rle dq (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r)).
  { exact (Rle_tra dq
                 (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp (apply_fun d (p 1, q 1))))
                 (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r))
                 HdqLe0' Hsum1). }
  claim HcomX: add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r)
             = add_SNo (add_SNo dp r) (apply_fun d (q 0, p 0)).
  { exact (add_SNo_com (apply_fun d (q 0, p 0)) (add_SNo dp r) (real_SNo (apply_fun d (q 0, p 0)) HxR)
                       (real_SNo (add_SNo dp r) (real_add_SNo dp HdpR r HrR))). }
  claim HmidLe: Rle (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r)) (add_SNo (add_SNo dp r) r).
  { rewrite HcomX.
    exact (Rle_add_SNo_2 (add_SNo dp r) (apply_fun d (q 0, p 0)) r
                         (real_add_SNo dp HdpR r HrR) HxR HrR HrLeX). }
  claim HdqLe2: Rle dq (add_SNo (add_SNo dp r) r).
  { exact (Rle_tra dq (add_SNo (apply_fun d (q 0, p 0)) (add_SNo dp r)) (add_SNo (add_SNo dp r) r)
                 HdqLe1 HmidLe). }
  claim Hassoc: add_SNo (add_SNo dp r) r = add_SNo dp (add_SNo r r).
  { rewrite <- (add_SNo_assoc dp r r HdpS HrS HrS).
    reflexivity. }
  claim HdqLeFinal: Rle dq (add_SNo dp (add_SNo r r)).
  { rewrite <- Hassoc.
    exact HdqLe2. }
  claim HsumR: add_SNo dp (add_SNo r r) :e R.
  { exact (real_add_SNo dp HdpR (add_SNo r r) (real_add_SNo r HrR r HrR)). }
  claim HsumRlt: Rlt (add_SNo dp (add_SNo r r)) b.
  { exact (RltI (add_SNo dp (add_SNo r r)) b HsumR HbR HdrLt). }
  exact (Rle_Rlt_tra dq (add_SNo dp (add_SNo r r)) b HdqLeFinal HsumRlt).
Qed.

Theorem metric_distance_preimage_open_ray_lower : forall Y d b:set,
  metric_on_total Y d ->
  b :e R ->
  preimage_of (setprod Y Y) d (open_ray_lower R b) :e
    (product_topology Y (metric_topology Y d) Y (metric_topology Y d)).
let Y d b.
assume Hd: metric_on_total Y d.
assume HbR: b :e R.
set Ty := metric_topology Y d.
set Tprod := product_topology Y Ty Y Ty.
set W := preimage_of (setprod Y Y) d (open_ray_lower R b).
prove W :e product_topology Y Ty Y Ty.
claim HdefT: product_topology Y Ty Y Ty =
  generated_topology (setprod Y Y) (product_subbasis Y Ty Y Ty).
{ reflexivity. }
rewrite HdefT.
claim HdefGen: generated_topology (setprod Y Y) (product_subbasis Y Ty Y Ty) =
  {U :e Power (setprod Y Y) |
    forall p :e U, exists bb :e product_subbasis Y Ty Y Ty, p :e bb /\ bb c= U}.
{ reflexivity. }
rewrite HdefGen.
apply (SepI (Power (setprod Y Y))
  (fun U:set =>
    forall p :e U, exists bb :e product_subbasis Y Ty Y Ty, p :e bb /\ bb c= U)
  W).
- apply PowerI.
  let p. assume Hp: p :e W.
  exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_lower R b) p Hp).
- let p. assume Hp: p :e W.
  prove exists bb :e product_subbasis Y Ty Y Ty, p :e bb /\ bb c= W.
  claim HpDom: p :e setprod Y Y.
  { exact (SepE1 (setprod Y Y) (fun q:set => apply_fun d q :e open_ray_lower R b) p Hp). }
  claim Hp0Y: p 0 :e Y.
  { exact (ap0_Sigma Y (fun _ : set => Y) p HpDom). }
  claim Hp1Y: p 1 :e Y.
  { exact (ap1_Sigma Y (fun _ : set => Y) p HpDom). }
  claim Hm: metric_on Y d.
  { exact (metric_on_total_imp_metric_on Y d Hd). }
  claim Hexr: exists r:set, r :e R /\ Rlt 0 r /\
    rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact (metric_distance_below_has_product_ball Y d b p Hd HbR Hp). }
  apply Hexr.
  let r. assume Hr.
  claim HrPack: (r :e R /\ Rlt 0 r) /\ rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact Hr. }
  claim Hr1: r :e R /\ Rlt 0 r.
  { exact (andEL (r :e R /\ Rlt 0 r)
                 (rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W)
                 HrPack). }
  claim HrR: r :e R.
  { exact (andEL (r :e R) (Rlt 0 r) Hr1). }
  claim HrPos: Rlt 0 r.
  { exact (andER (r :e R) (Rlt 0 r) Hr1). }
  claim Hbsub: rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W.
  { exact (andER (r :e R /\ Rlt 0 r)
                 (rectangle_set (open_ball Y d (p 0) r) (open_ball Y d (p 1) r) c= W)
                 HrPack). }
  set U := open_ball Y d (p 0) r.
  set V := open_ball Y d (p 1) r.
  set bb := rectangle_set U V.
  witness bb.
  apply andI.
  - prove bb :e product_subbasis Y Ty Y Ty.
    prove bb :e \/_ U0 :e Ty, {rectangle_set U0 V0|V0 :e Ty}.
    claim HUinTy: U :e Ty.
    { exact (open_ball_in_metric_topology Y d (p 0) r Hm Hp0Y HrPos). }
    claim HVinTy: V :e Ty.
    { exact (open_ball_in_metric_topology Y d (p 1) r Hm Hp1Y HrPos). }
    claim HbInFam: bb :e {rectangle_set U V0|V0 :e Ty}.
    { exact (ReplI Ty (fun V0:set => rectangle_set U V0) V HVinTy). }
    exact (famunionI Ty (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) U bb HUinTy HbInFam).
  - apply andI.
	    + prove p :e bb.
	      claim HbEq0: bb = rectangle_set U V.
	      { reflexivity. }
	      rewrite HbEq0.
	      rewrite rectangle_set_def.
	      claim HpEta0: p = (p 0, p 1).
	      { exact (setprod_eta Y Y p HpDom). }
	      rewrite HpEta0 at 1.
	      claim Hp0In: p 0 :e U.
	      { exact (center_in_open_ball Y d (p 0) r Hm Hp0Y HrPos). }
	      claim Hp1In: p 1 :e V.
	      { exact (center_in_open_ball Y d (p 1) r Hm Hp1Y HrPos). }
	      exact (tuple_2_setprod_by_pair_Sigma U V (p 0) (p 1) Hp0In Hp1In).
    + prove bb c= W.
      claim HbEq: bb = rectangle_set U V.
      { reflexivity. }
      rewrite HbEq.
      exact Hbsub.
Qed.

Theorem metric_distance_continuous : forall Y d:set,
  metric_on_total Y d ->
  continuous_map (setprod Y Y)
    (product_topology Y (metric_topology Y d) Y (metric_topology Y d))
    R R_standard_topology d.
let Y d.
assume Hd: metric_on_total Y d.
set Ty := metric_topology Y d.
set Tprod := product_topology Y Ty Y Ty.
claim Hm: metric_on Y d.
{ exact (metric_on_total_imp_metric_on Y d Hd). }
claim HTy: topology_on Y Ty.
{ exact (metric_topology_is_topology Y d Hm). }
claim HTprod: topology_on (setprod Y Y) Tprod.
{ exact (product_topology_is_topology Y Ty Y Ty HTy HTy). }
claim Hfun: function_on d (setprod Y Y) R.
{ exact (metric_on_function_on Y d Hm). }
set S := open_rays_subbasis R.
claim HeqTop: generated_topology_from_subbasis R S = R_standard_topology.
{ rewrite open_rays_subbasis_for_order_topology_R.
  rewrite standard_topology_is_order_topology.
  reflexivity. }
rewrite <- HeqTop.
apply (continuous_map_from_subbasis (setprod Y Y) Tprod R S d).
- exact HTprod.
- exact Hfun.
- exact (open_rays_subbasis_is_subbasis R).
- let s. assume HsS: s :e S.
  prove preimage_of (setprod Y Y) d s :e Tprod.
  apply (binunionE'
          ({I :e Power R | exists a :e R, I = open_ray_upper R a}
           :\/:
           {I :e Power R | exists b :e R, I = open_ray_lower R b})
          {R}
          s
          (preimage_of (setprod Y Y) d s :e Tprod)).
  - assume Hs0: s :e
      ({I :e Power R | exists a :e R, I = open_ray_upper R a}
       :\/:
       {I :e Power R | exists b :e R, I = open_ray_lower R b}).
    apply (binunionE'
            {I :e Power R | exists a :e R, I = open_ray_upper R a}
            {I :e Power R | exists b :e R, I = open_ray_lower R b}
            s
            (preimage_of (setprod Y Y) d s :e Tprod)).
    + assume Hsu: s :e {I :e Power R | exists a :e R, I = open_ray_upper R a}.
      claim Hex: exists a :e R, s = open_ray_upper R a.
      { exact (SepE2 (Power R)
                (fun I0:set => exists a :e R, I0 = open_ray_upper R a)
                s Hsu). }
      apply Hex.
      let a. assume Hcore. apply Hcore.
      assume HaR: a :e R.
      assume Hseq: s = open_ray_upper R a.
      rewrite Hseq.
      exact (metric_distance_preimage_open_ray_upper Y d a Hd HaR).
    + assume Hsl: s :e {I :e Power R | exists b :e R, I = open_ray_lower R b}.
      claim Hex: exists b :e R, s = open_ray_lower R b.
      { exact (SepE2 (Power R)
                (fun I0:set => exists b :e R, I0 = open_ray_lower R b)
                s Hsl). }
      apply Hex.
      let b. assume Hcore. apply Hcore.
      assume HbR: b :e R.
      assume Hseq: s = open_ray_lower R b.
      rewrite Hseq.
      exact (metric_distance_preimage_open_ray_lower Y d b Hd HbR).
    + exact Hs0.
  - assume HsR: s :e {R}.
    claim Hseq: s = R.
    { exact (SingE R s HsR). }
    rewrite Hseq.
    rewrite (preimage_of_whole (setprod Y Y) R d Hfun).
    exact (topology_has_X (setprod Y Y) Tprod HTprod).
  - exact HsS.
Qed.

(** helper: A_N(eps) is closed under continuity hypotheses **)
(** LATEX VERSION: In Theorem 48.5, A_N(eps) is closed as an intersection of closed sets defined by d(f_n,f_m)≤eps. **)
Theorem A_N_eps_closed_stub : forall X Tx Y d fn N eps:set,
  topology_on X Tx ->
  metric_on_total Y d ->
  (forall n:set, n :e omega ->
    continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n)) ->
  N :e omega ->
  eps :e R ->
  closed_in X Tx (A_N_eps X Y d fn N eps).
let X Tx Y d fn N eps.
assume HTx: topology_on X Tx.
assume Hd: metric_on_total Y d.
assume Hcont: forall n:set, n :e omega ->
  continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n).
assume HN: N :e omega.
assume HepsR: eps :e R.
prove closed_in X Tx (A_N_eps X Y d fn N eps).
set Ubad :=
  {x :e X |
    exists n:set, n :e omega /\ N c= n /\
      exists m:set, m :e omega /\ N c= m /\
        Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) }.
claim HdefA: A_N_eps X Y d fn N eps =
  {x :e X |
    forall n:set, n :e omega -> N c= n ->
      forall m:set, m :e omega -> N c= m ->
        Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps }.
{ reflexivity. }
claim HeqComp: A_N_eps X Y d fn N eps = X :\: Ubad.
{ rewrite HdefA.
  apply set_ext.
  - let x. assume HxA: x :e
      {x0 :e X |
        forall n:set, n :e omega -> N c= n ->
          forall m:set, m :e omega -> N c= m ->
            Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps }.
    prove x :e X :\: Ubad.
    claim HxX: x :e X.
    { exact (SepE1 X
              (fun x0:set =>
                forall n:set, n :e omega -> N c= n ->
                  forall m:set, m :e omega -> N c= m ->
                    Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps)
              x HxA). }
    claim HxProp:
      forall n:set, n :e omega -> N c= n ->
        forall m:set, m :e omega -> N c= m ->
          Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps.
    { exact (SepE2 X
              (fun x0:set =>
                forall n:set, n :e omega -> N c= n ->
                  forall m:set, m :e omega -> N c= m ->
                    Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps)
              x HxA). }
    apply setminusI.
    + exact HxX.
    + assume HxU: x :e Ubad.
      claim Hexn: exists n:set, n :e omega /\ N c= n /\
        exists m:set, m :e omega /\ N c= m /\
          Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)).
      { exact (SepE2 X
                (fun x0:set =>
                  exists n0:set, n0 :e omega /\ N c= n0 /\
                    exists m0:set, m0 :e omega /\ N c= m0 /\
                      Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun (apply_fun fn m0) x0)))
                x HxU). }
      apply Hexn.
      let n. assume Hn.
      claim HnCore: (n :e omega /\ N c= n).
      { exact (andEL (n :e omega /\ N c= n)
                     (exists m0:set, m0 :e omega /\ N c= m0 /\
                       Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)))
                     Hn). }
      claim Hexm: exists m0:set, m0 :e omega /\ N c= m0 /\
        Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)).
      { exact (andER (n :e omega /\ N c= n)
                     (exists m0:set, m0 :e omega /\ N c= m0 /\
                       Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)))
                     Hn). }
      claim HnO: n :e omega.
      { exact (andEL (n :e omega) (N c= n) HnCore). }
      claim HNn: N c= n.
      { exact (andER (n :e omega) (N c= n) HnCore). }
      apply Hexm.
      let m0. assume Hm0.
      claim Hm0Core: (m0 :e omega /\ N c= m0).
      { exact (andEL (m0 :e omega /\ N c= m0)
                     (Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)))
                     Hm0). }
      claim Hlt: Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)).
      { exact (andER (m0 :e omega /\ N c= m0)
                     (Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)))
                     Hm0). }
      claim Hm0O: m0 :e omega.
      { exact (andEL (m0 :e omega) (N c= m0) Hm0Core). }
      claim HNm0: N c= m0.
      { exact (andER (m0 :e omega) (N c= m0) Hm0Core). }
      claim Hle: Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)) eps.
      { exact (HxProp n HnO HNn m0 Hm0O HNm0). }
      exact ((RleE_nlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m0) x)) eps Hle) Hlt).
  - let x. assume Hx: x :e X :\: Ubad.
    prove x :e
      {x0 :e X |
        forall n:set, n :e omega -> N c= n ->
          forall m:set, m :e omega -> N c= m ->
            Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps }.
    claim HxX: x :e X.
    { exact (setminusE1 X Ubad x Hx). }
    claim HxNotU: x /:e Ubad.
    { exact (setminusE2 X Ubad x Hx). }
    apply (SepI X
            (fun x0:set =>
              forall n:set, n :e omega -> N c= n ->
                forall m:set, m :e omega -> N c= m ->
                  Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps)
            x HxX).
    let n. assume HnO: n :e omega. assume HNn: N c= n.
    let m. assume HmO: m :e omega. assume HNm: N c= m.
    claim HfnOn: function_on (apply_fun fn n) X Y.
    { exact (continuous_map_function_on X Tx Y (metric_topology Y d) (apply_fun fn n) (Hcont n HnO)). }
    claim HfmOn: function_on (apply_fun fn m) X Y.
    { exact (continuous_map_function_on X Tx Y (metric_topology Y d) (apply_fun fn m) (Hcont m HmO)). }
    claim HnxY: apply_fun (apply_fun fn n) x :e Y.
    { exact (HfnOn x HxX). }
    claim HmxY: apply_fun (apply_fun fn m) x :e Y.
    { exact (HfmOn x HxX). }
    claim HdTot: total_function_on d (setprod Y Y) R.
    { exact (metric_on_total_total_function Y d Hd). }
    claim Hpair: (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x) :e setprod Y Y.
    { exact (tuple_2_setprod_by_pair_Sigma Y Y
              (apply_fun (apply_fun fn n) x)
              (apply_fun (apply_fun fn m) x)
              HnxY HmxY). }
    claim HdxR: apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x) :e R.
    { exact (total_function_on_apply_fun_in_Y d (setprod Y Y) R
              (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)
              HdTot
              Hpair). }
    apply (RleI (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps HdxR HepsR).
    assume Hlt: Rlt eps (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)).
    claim HxBad: x :e Ubad.
    { apply (SepI X
              (fun x0:set =>
                exists n0:set, n0 :e omega /\ N c= n0 /\
                  exists m0:set, m0 :e omega /\ N c= m0 /\
                    Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun (apply_fun fn m0) x0)))
              x HxX).
	      witness n.
	      apply andI.
	      - apply andI.
	        + exact HnO.
	        + exact HNn.
	      - witness m.
	        apply andI.
	        + apply andI.
	          * exact HmO.
	          * exact HNm.
	        + exact Hlt. }
	    exact (HxNotU HxBad). }
rewrite HeqComp.
claim HUbad: Ubad :e Tx.
{ set Veps := {r :e R | Rlt eps r}.
  claim HVeps: Veps :e R_standard_topology.
  { exact (open_ray_in_R_standard_topology eps HepsR). }
  set IndN := {k :e omega | N c= k}.
  set Iprod := setprod IndN IndN.
  set Fam := {preimage_of X
                (compose_fun X
                  (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
                  d)
                Veps
              | p :e Iprod}.
  claim HFamSub: Fam c= Tx.
  { let U. assume HU: U :e Fam.
    apply (ReplE_impred Iprod
            (fun p0:set =>
              preimage_of X
                (compose_fun X
                  (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1)))
                  d)
                Veps)
            U HU (U :e Tx)).
    let p. assume Hp: p :e Iprod.
    assume HeqU: U =
      preimage_of X
        (compose_fun X
          (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
          d)
        Veps.
    claim Hp0In: p 0 :e IndN.
    { exact (ap0_Sigma IndN (fun k:set => IndN) p Hp). }
    claim Hp1In: p 1 :e IndN.
    { exact (ap1_Sigma IndN (fun k:set => IndN) p Hp). }
    claim HnO: (p 0) :e omega.
    { exact (SepE1 omega (fun k:set => N c= k) (p 0) Hp0In). }
    claim HmO: (p 1) :e omega.
    { exact (SepE1 omega (fun k:set => N c= k) (p 1) Hp1In). }
    set n := p 0.
    set m := p 1.
    set h := compose_fun X (pair_map X (apply_fun fn n) (apply_fun fn m)) d.
    claim HpairCont:
      continuous_map X Tx (setprod Y Y)
        (product_topology Y (metric_topology Y d) Y (metric_topology Y d))
        (pair_map X (apply_fun fn n) (apply_fun fn m)).
    { exact (maps_into_products_axiom X Tx
              Y (metric_topology Y d)
              Y (metric_topology Y d)
              (apply_fun fn n) (apply_fun fn m)
              (Hcont n HnO) (Hcont m HmO)). }
    claim Hdcont:
      continuous_map (setprod Y Y)
        (product_topology Y (metric_topology Y d) Y (metric_topology Y d))
        R R_standard_topology d.
    { exact (metric_distance_continuous Y d Hd). }
    claim Hhcont: continuous_map X Tx R R_standard_topology h.
    { exact (composition_continuous X Tx (setprod Y Y)
              (product_topology Y (metric_topology Y d) Y (metric_topology Y d))
              R R_standard_topology
              (pair_map X (apply_fun fn n) (apply_fun fn m))
              d
              HpairCont Hdcont). }
    claim HpreIn: preimage_of X h Veps :e Tx.
    { exact (continuous_map_preimage X Tx R R_standard_topology h Hhcont Veps HVeps). }
    rewrite HeqU.
    exact HpreIn. }
  claim HUbadEq: Ubad = Union Fam.
  { apply set_ext.
    - let x. assume HxU: x :e Ubad.
      prove x :e Union Fam.
      claim Hexnm: exists n0:set, n0 :e omega /\ N c= n0 /\
        exists m0:set, m0 :e omega /\ N c= m0 /\
          Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)).
      { exact (SepE2 X
                (fun x0:set =>
                  exists n0:set, n0 :e omega /\ N c= n0 /\
                    exists m0:set, m0 :e omega /\ N c= m0 /\
                      Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun (apply_fun fn m0) x0)))
                x HxU). }
      apply Hexnm.
      let n0. assume Hn0.
      claim Hn0Core: (n0 :e omega /\ N c= n0).
      { exact (andEL (n0 :e omega /\ N c= n0)
                     (exists m0:set, m0 :e omega /\ N c= m0 /\
                       Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)))
                     Hn0). }
      claim Hexm0: exists m0:set, m0 :e omega /\ N c= m0 /\
        Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)).
      { exact (andER (n0 :e omega /\ N c= n0)
                     (exists m0:set, m0 :e omega /\ N c= m0 /\
                       Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)))
                     Hn0). }
      claim Hn0O: n0 :e omega.
      { exact (andEL (n0 :e omega) (N c= n0) Hn0Core). }
      claim HNn0: N c= n0.
      { exact (andER (n0 :e omega) (N c= n0) Hn0Core). }
      apply Hexm0.
      let m0. assume Hm0.
      claim Hm0Core: (m0 :e omega /\ N c= m0).
      { exact (andEL (m0 :e omega /\ N c= m0)
                     (Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)))
                     Hm0). }
      claim Hlt: Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)).
      { exact (andER (m0 :e omega /\ N c= m0)
                     (Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)))
                     Hm0). }
      claim Hm0O: m0 :e omega.
      { exact (andEL (m0 :e omega) (N c= m0) Hm0Core). }
      claim HNm0: N c= m0.
      { exact (andER (m0 :e omega) (N c= m0) Hm0Core). }
      claim HxX: x :e X.
      { exact (SepE1 X
                (fun x0:set =>
                  exists n1:set, n1 :e omega /\ N c= n1 /\
                    exists m1:set, m1 :e omega /\ N c= m1 /\
                      Rlt eps (apply_fun d (apply_fun (apply_fun fn n1) x0, apply_fun (apply_fun fn m1) x0)))
                x HxU). }
      claim Hn0In: n0 :e IndN.
      { exact (SepI omega (fun k:set => N c= k) n0 Hn0O HNn0). }
      claim Hm0In: m0 :e IndN.
      { exact (SepI omega (fun k:set => N c= k) m0 Hm0O HNm0). }
      set p0 := (n0,m0).
      claim Hp0: p0 :e Iprod.
      { exact (tuple_2_setprod_by_pair_Sigma IndN IndN n0 m0 Hn0In Hm0In). }
      set U0 := preimage_of X
        (compose_fun X (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) d) Veps.
      claim HU0Fam: U0 :e Fam.
      { exact (ReplI Iprod
              (fun p1:set =>
                preimage_of X
                  (compose_fun X
                    (pair_map X (apply_fun fn (p1 0)) (apply_fun fn (p1 1)))
                    d)
                  Veps)
              p0 Hp0). }
	      claim HxU0in: x :e U0.
	      { claim HxCond: apply_fun
	          (compose_fun X (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) d) x :e Veps.
	        { claim Hn0Fn: function_on (apply_fun fn n0) X Y.
	          { exact (continuous_map_function_on X Tx Y (metric_topology Y d) (apply_fun fn n0) (Hcont n0 Hn0O)). }
	          claim Hm0Fn: function_on (apply_fun fn m0) X Y.
	          { exact (continuous_map_function_on X Tx Y (metric_topology Y d) (apply_fun fn m0) (Hcont m0 Hm0O)). }
	          claim Hn0xY: apply_fun (apply_fun fn n0) x :e Y.
	          { exact (Hn0Fn x HxX). }
	          claim Hm0xY: apply_fun (apply_fun fn m0) x :e Y.
	          { exact (Hm0Fn x HxX). }
	          claim HdTot: total_function_on d (setprod Y Y) R.
	          { exact (metric_on_total_total_function Y d Hd). }
	          claim Hpair: (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x) :e setprod Y Y.
	          { exact (tuple_2_setprod_by_pair_Sigma Y Y
	                    (apply_fun (apply_fun fn n0) x)
	                    (apply_fun (apply_fun fn m0) x)
	                    Hn0xY Hm0xY). }
	          claim HdvalR: apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x) :e R.
	          { exact (total_function_on_apply_fun_in_Y d (setprod Y Y) R
	                    (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x)
	                    HdTot Hpair). }
	          (** unfold the compose and pair wrappers **)
	          claim Happ0: apply_fun (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) x =
	                      (apply_fun (apply_fun fn (p0 0)) x, apply_fun (apply_fun fn (p0 1)) x).
	          { exact (pair_map_apply X Y Y (apply_fun fn (p0 0)) (apply_fun fn (p0 1)) x HxX). }
	          claim Happ1: apply_fun (compose_fun X (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) d) x =
	                      apply_fun d (apply_fun (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) x).
	          { exact (compose_fun_apply X (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) d x HxX). }
	          rewrite Happ1.
	          rewrite Happ0.
	          rewrite (tuple_2_0_eq n0 m0).
	          rewrite (tuple_2_1_eq n0 m0).
	          exact (SepI R (fun r:set => Rlt eps r)
	                  (apply_fun d (apply_fun (apply_fun fn n0) x, apply_fun (apply_fun fn m0) x))
	                  HdvalR Hlt). }
	        exact (SepI X
	                (fun x0:set => apply_fun
	                  (compose_fun X (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1))) d) x0 :e Veps)
	                x HxX HxCond). }
	      exact (UnionI Fam x U0 HxU0in HU0Fam).
	    - let x. assume Hx: x :e Union Fam.
	      prove x :e Ubad.
	      apply (UnionE_impred Fam x Hx (x :e Ubad)).
	      let U. assume HxU: x :e U. assume HU: U :e Fam.
	      (** Remaining algebra: extract an index p in Iprod and then unpack x in the corresponding preimage into the required witness. **)
	      claim Hexp: exists p:set, p :e Iprod /\ U =
	        preimage_of X
	          (compose_fun X
	            (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	            d)
	          Veps.
	      { exact (ReplE Iprod
	              (fun p0:set =>
	                preimage_of X
	                  (compose_fun X
	                    (pair_map X (apply_fun fn (p0 0)) (apply_fun fn (p0 1)))
	                    d)
	                  Veps)
	              U HU). }
	      apply Hexp.
	      let p. assume Hp.
	      claim HpI: p :e Iprod.
	      { exact (andEL (p :e Iprod)
	                     (U =
	                      preimage_of X
	                        (compose_fun X
	                          (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	                          d)
	                        Veps)
	                     Hp). }
	      claim HUdef: U =
	        preimage_of X
	          (compose_fun X
	            (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	            d)
	          Veps.
	      { exact (andER (p :e Iprod)
	                     (U =
	                      preimage_of X
	                        (compose_fun X
	                          (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	                          d)
	                        Veps)
	                     Hp). }
	      claim Hp0In: p 0 :e IndN.
	      { exact (ap0_Sigma IndN (fun k:set => IndN) p HpI). }
	      claim Hp1In: p 1 :e IndN.
	      { exact (ap1_Sigma IndN (fun k:set => IndN) p HpI). }
	      claim HnO: (p 0) :e omega.
	      { exact (SepE1 omega (fun k:set => N c= k) (p 0) Hp0In). }
	      claim HmO: (p 1) :e omega.
	      { exact (SepE1 omega (fun k:set => N c= k) (p 1) Hp1In). }
	      claim HNn: N c= (p 0).
	      { exact (SepE2 omega (fun k:set => N c= k) (p 0) Hp0In). }
	      claim HNm: N c= (p 1).
	      { exact (SepE2 omega (fun k:set => N c= k) (p 1) Hp1In). }
	      claim HxPre: x :e preimage_of X
	        (compose_fun X
	          (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	          d)
	        Veps.
	      { prove x :e preimage_of X
	          (compose_fun X
	            (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	            d)
	          Veps.
	        rewrite <- HUdef.
	        exact HxU. }
	      claim HxX: x :e X.
	      { exact (SepE1 X
	          (fun x0:set => apply_fun
	            (compose_fun X
	              (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	              d) x0 :e Veps)
	          x HxPre). }
	      claim HxVal: apply_fun
	        (compose_fun X
	          (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	          d) x :e Veps.
	      { exact (SepE2 X
	          (fun x0:set => apply_fun
	            (compose_fun X
	              (pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)))
	              d) x0 :e Veps)
	          x HxPre). }
	      set fpair := pair_map X (apply_fun fn (p 0)) (apply_fun fn (p 1)).
	      claim HpairEq: apply_fun fpair x =
	                     (apply_fun (apply_fun fn (p 0)) x, apply_fun (apply_fun fn (p 1)) x).
	      { exact (pair_map_apply X Y Y (apply_fun fn (p 0)) (apply_fun fn (p 1)) x HxX). }
	      claim HcompEq: apply_fun (compose_fun X fpair d) x =
	                     apply_fun d (apply_fun fpair x).
	      { exact (compose_fun_apply X fpair d x HxX). }
	      claim HvalIn: apply_fun d (apply_fun (apply_fun fn (p 0)) x, apply_fun (apply_fun fn (p 1)) x) :e Veps.
	      { prove apply_fun d (apply_fun (apply_fun fn (p 0)) x, apply_fun (apply_fun fn (p 1)) x) :e Veps.
	        rewrite <- HpairEq.
	        rewrite <- HcompEq.
	        exact HxVal. }
	      claim Hlt: Rlt eps (apply_fun d (apply_fun (apply_fun fn (p 0)) x, apply_fun (apply_fun fn (p 1)) x)).
	      { exact (SepE2 R (fun r:set => Rlt eps r)
	                (apply_fun d (apply_fun (apply_fun fn (p 0)) x, apply_fun (apply_fun fn (p 1)) x))
	                HvalIn). }
	      apply (SepI X
	        (fun x0:set =>
	          exists n0:set, n0 :e omega /\ N c= n0 /\
	            exists m0:set, m0 :e omega /\ N c= m0 /\
	              Rlt eps (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun (apply_fun fn m0) x0)))
	        x HxX).
	      witness (p 0).
	      apply andI.
	      - apply andI.
	        + exact HnO.
	        + exact HNn.
	      - witness (p 1).
	        apply andI.
	        + apply andI.
	          * exact HmO.
	          * exact HNm.
	        + exact Hlt. }
  claim HUnionIn: Union Fam :e Tx.
  { claim HFamPow: Fam :e Power Tx.
    { exact (PowerI Tx Fam HFamSub). }
    exact (topology_union_axiom X Tx HTx Fam HFamPow). }
  rewrite HUbadEq.
  exact HUnionIn. }
exact (closed_of_open_complement X Tx Ubad HTx HUbad).
Qed.

(** helper: U(eps) as union of interiors of A_N(eps) **)
(** LATEX VERSION: U(eps) is the union over N of Int(A_N(eps)). **)
Definition U_eps : set -> set -> set -> set -> set -> set -> set :=
  fun X Tx Y d fn eps =>
    Union {interior_of X Tx (A_N_eps X Y d fn N eps) | N :e omega}.

(** helper: monotonicity of U_eps in eps **)
(** LATEX VERSION: If eps1 <= eps2 then U(eps1) is a subset of U(eps2). **)
Theorem U_eps_monotone : forall X Tx Y d fn eps1 eps2:set,
  topology_on X Tx ->
  eps1 :e R -> eps2 :e R -> Rle eps1 eps2 ->
  U_eps X Tx Y d fn eps1 c= U_eps X Tx Y d fn eps2.
let X Tx Y d fn eps1 eps2.
assume HTx: topology_on X Tx.
assume Heps1R: eps1 :e R.
assume Heps2R: eps2 :e R.
assume Heps12: Rle eps1 eps2.
prove U_eps X Tx Y d fn eps1 c= U_eps X Tx Y d fn eps2.
let x. assume Hx: x :e U_eps X Tx Y d fn eps1.
prove x :e U_eps X Tx Y d fn eps2.
set Fam1 := {interior_of X Tx (A_N_eps X Y d fn N eps1) | N :e omega}.
set Fam2 := {interior_of X Tx (A_N_eps X Y d fn N eps2) | N :e omega}.
claim HU1: U_eps X Tx Y d fn eps1 = Union Fam1.
{ reflexivity. }
claim HU2: U_eps X Tx Y d fn eps2 = Union Fam2.
{ reflexivity. }
claim HxU1: x :e Union Fam1.
{ rewrite <- HU1.
  exact Hx. }
rewrite HU2.
apply (UnionE_impred Fam1 x HxU1 (x :e Union Fam2)).
let W. assume HxW: x :e W. assume HW1: W :e Fam1.
apply (ReplE_impred omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps1))
        W HW1
        (x :e Union Fam2)).
let N. assume HN: N :e omega. assume HWdef: W = interior_of X Tx (A_N_eps X Y d fn N eps1).
claim HxInt1: x :e interior_of X Tx (A_N_eps X Y d fn N eps1).
{ rewrite <- HWdef.
  exact HxW. }
claim HAmon: A_N_eps X Y d fn N eps1 c= A_N_eps X Y d fn N eps2.
{ exact (A_N_eps_monotone X Y d fn N eps1 eps2 Heps1R Heps2R Heps12). }
claim HintMon: interior_of X Tx (A_N_eps X Y d fn N eps1) c=
               interior_of X Tx (A_N_eps X Y d fn N eps2).
{ exact (interior_monotone X Tx (A_N_eps X Y d fn N eps1) (A_N_eps X Y d fn N eps2) HTx HAmon). }
claim HxInt2: x :e interior_of X Tx (A_N_eps X Y d fn N eps2).
{ exact (HintMon x HxInt1). }
claim HWin2: interior_of X Tx (A_N_eps X Y d fn N eps2) :e Fam2.
{ exact (ReplI omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps2)) N HN). }
exact (UnionI Fam2 x (interior_of X Tx (A_N_eps X Y d fn N eps2)) HxInt2 HWin2).
Qed.

(** helper: unpack membership in U_eps into a concrete neighborhood inside A_N_eps **)
(** LATEX VERSION: If x ∈ U(eps)=⋃ Int(A_N(eps)), then x lies in some open set U ⊆ A_N(eps). **)
Theorem U_epsE_open_subset_A_N : forall X Tx Y d fn eps x:set,
  topology_on X Tx ->
  x :e U_eps X Tx Y d fn eps ->
  exists N:set, N :e omega /\
    exists U:set, U :e Tx /\ x :e U /\ U c= A_N_eps X Y d fn N eps.
let X Tx Y d fn eps x.
assume HTx: topology_on X Tx.
assume Hx: x :e U_eps X Tx Y d fn eps.
set UFam := {interior_of X Tx (A_N_eps X Y d fn N eps) | N :e omega}.
claim HUdef: U_eps X Tx Y d fn eps = Union UFam.
{ reflexivity. }
claim HxUnion: x :e Union UFam.
{ rewrite <- HUdef.
  exact Hx. }
apply (UnionE_impred UFam x HxUnion
  (exists N:set, N :e omega /\ exists U:set, U :e Tx /\ x :e U /\ U c= A_N_eps X Y d fn N eps)).
let W. assume HxW: x :e W. assume HWUFam: W :e UFam.
apply (ReplE_impred omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps)) W HWUFam
  (exists N:set, N :e omega /\ exists U:set, U :e Tx /\ x :e U /\ U c= A_N_eps X Y d fn N eps)).
let N.
assume HN: N :e omega.
assume HWdef: W = interior_of X Tx (A_N_eps X Y d fn N eps).
claim HxInt: x :e interior_of X Tx (A_N_eps X Y d fn N eps).
{ rewrite <- HWdef.
  exact HxW. }
claim HintDef: interior_of X Tx (A_N_eps X Y d fn N eps) =
  {x0 :e X | exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N eps)}.
{ reflexivity. }
claim HexU0: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 c= (A_N_eps X Y d fn N eps).
{ claim HxInt2: x :e
    {x0 :e X | exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N eps)}.
  { rewrite <- HintDef.
    exact HxInt. }
  exact (SepE2 X
    (fun x0:set => exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N eps))
    x
    HxInt2). }
apply HexU0.
let U. assume HU: U :e Tx /\ x :e U /\ U c= (A_N_eps X Y d fn N eps).
witness N.
apply andI.
- exact HN.
- witness U.
  exact HU.
Qed.

(** helper: pointwise limit implies eventual Cauchy, hence X is covered by A_N(eps) **)
(** LATEX VERSION: In Theorem 48.5, the union of A_N(eps) equals X because f_n(x) converges for each x. **)
Theorem pointwise_limit_metric_imp_cover_A_N_eps_stub : forall X Y d fn f eps:set,
  metric_on_total Y d ->
  (forall n:set, n :e omega -> function_on (apply_fun fn n) X Y) ->
  function_on f X Y ->
  pointwise_limit_metric X Y d fn f ->
  eps :e R -> Rlt 0 eps ->
  forall x:set, x :e X -> exists N:set, N :e omega /\ x :e A_N_eps X Y d fn N eps.
let X Y d fn f eps.
assume Hd: metric_on_total Y d.
assume Hfn: forall n:set, n :e omega -> function_on (apply_fun fn n) X Y.
assume Hf: function_on f X Y.
assume Hlim: pointwise_limit_metric X Y d fn f.
assume HepsR: eps :e R.
assume HepsPos: Rlt 0 eps.
let x. assume HxX: x :e X.
claim HexNsmall: exists Nsmall :e omega, eps_ Nsmall < eps.
{ exact (exists_eps_lt_pos_Euclid eps HepsR HepsPos). }
apply HexNsmall.
let Nsmall. assume HNsmallpair.
claim HNsmallO: Nsmall :e omega.
{ exact (andEL (Nsmall :e omega) (eps_ Nsmall < eps) HNsmallpair). }
claim HepsNlt: eps_ Nsmall < eps.
{ exact (andER (Nsmall :e omega) (eps_ Nsmall < eps) HNsmallpair). }
claim HNsmallNat: nat_p Nsmall.
{ exact (omega_nat_p Nsmall HNsmallO). }
claim HNsuccO: ordsucc Nsmall :e omega.
{ exact (omega_ordsucc Nsmall HNsmallO). }
set eps2 := eps_ (ordsucc Nsmall).
claim Heps2R: eps2 :e R.
{ exact (SNoS_omega_real eps2 (SNo_eps_SNoS_omega (ordsucc Nsmall) HNsuccO)). }
claim Heps2Pos: Rlt 0 eps2.
{ exact (RltI 0 eps2 real_0 Heps2R (SNo_eps_pos (ordsucc Nsmall) HNsuccO)). }
claim HepsHalf: add_SNo eps2 eps2 = eps_ Nsmall.
{ exact (eps_ordsucc_half_add Nsmall HNsmallNat). }
claim HepsNR: eps_ Nsmall :e R.
{ exact (SNoS_omega_real (eps_ Nsmall) (SNo_eps_SNoS_omega Nsmall HNsmallO)). }
claim HepsNS: SNo (eps_ Nsmall).
{ exact (real_SNo (eps_ Nsmall) HepsNR). }
claim HepsS: SNo eps.
{ exact (real_SNo eps HepsR). }
claim HepsNltR: Rlt (eps_ Nsmall) eps.
{ exact (RltI (eps_ Nsmall) eps HepsNR HepsR HepsNlt). }
claim HexN0: exists N0:set, N0 :e omega /\
  forall n:set, n :e omega -> N0 c= n ->
    Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2.
{ exact (Hlim x HxX eps2 Heps2R Heps2Pos). }
apply HexN0.
let N0. assume HN0pair.
claim HN0O: N0 :e omega.
{ exact (andEL (N0 :e omega)
               (forall n:set, n :e omega -> N0 c= n ->
                 Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2)
               HN0pair). }
claim Htail: forall n:set, n :e omega -> N0 c= n ->
  Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2.
{ exact (andER (N0 :e omega)
               (forall n:set, n :e omega -> N0 c= n ->
                 Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2)
               HN0pair). }
witness N0.
apply andI.
- exact HN0O.
- claim HdefA: A_N_eps X Y d fn N0 eps =
    {x0 :e X |
      forall n:set, n :e omega -> N0 c= n ->
        forall m:set, m :e omega -> N0 c= m ->
          Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps }.
  { reflexivity. }
  rewrite HdefA.
  apply (SepI X
            (fun x0:set =>
              forall n:set, n :e omega -> N0 c= n ->
                forall m:set, m :e omega -> N0 c= m ->
                  Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps)
            x
            HxX).
  let n. assume HnO: n :e omega. assume HN0n: N0 c= n.
  let m. assume HmO: m :e omega. assume HN0m: N0 c= m.
  claim HfxY: apply_fun f x :e Y.
  { exact (Hf x HxX). }
  claim HfnxY: apply_fun (apply_fun fn n) x :e Y.
  { exact ((Hfn n HnO) x HxX). }
  claim HfmxY: apply_fun (apply_fun fn m) x :e Y.
  { exact ((Hfn m HmO) x HxX). }
  claim HmY: metric_on Y d.
  { exact (metric_on_total_imp_metric_on Y d Hd). }
  claim Hsym: apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x) =
              apply_fun d (apply_fun (apply_fun fn m) x, apply_fun f x).
  { exact (metric_on_symmetric Y d (apply_fun f x) (apply_fun (apply_fun fn m) x) HmY HfxY HfmxY). }
  claim Hdn: Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2.
  { exact (Htail n HnO HN0n). }
  claim Hdm: Rlt (apply_fun d (apply_fun (apply_fun fn m) x, apply_fun f x)) eps2.
  { exact (Htail m HmO HN0m). }
  claim Hdm2: Rlt (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) eps2.
  { rewrite Hsym.
    exact Hdm. }
  claim HdR: metric_on Y d.
  { exact HmY. }
  claim Htri: Rle (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x))
                 (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                          (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))).
  { exact (metric_triangle_Rle Y d
           (apply_fun (apply_fun fn n) x)
           (apply_fun f x)
           (apply_fun (apply_fun fn m) x)
           HdR
           HfnxY
           HfxY
           HfmxY). }
  claim Hdnlt: (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) < eps2.
  { exact (RltE_lt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2 Hdn). }
  claim Hdmlt: (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) < eps2.
  { exact (RltE_lt (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) eps2 Hdm2). }
  claim HdnR: (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) :e R.
  { exact (RltE_left (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps2 Hdn). }
  claim HdmR: (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) :e R.
  { exact (RltE_left (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) eps2 Hdm2). }
  claim HdnS: SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)).
  { exact (real_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) HdnR). }
  claim HdmS: SNo (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)).
  { exact (real_SNo (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) HdmR). }
  claim Heps2S: SNo eps2.
  { exact (real_SNo eps2 Heps2R). }
  claim Hsumlt: add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                         (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))
               < add_SNo eps2 eps2.
  { exact (add_SNo_Lt3
           (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
           (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))
           eps2 eps2
           HdnS HdmS Heps2S Heps2S
           Hdnlt Hdmlt). }
  claim HsumR: add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                       (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) :e R.
  { exact (real_add_SNo
           (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) HdnR
           (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)) HdmR). }
  claim Hsumlt2: add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                          (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))
               < eps_ Nsmall.
  { rewrite <- HepsHalf.
    exact Hsumlt. }
  claim Hsumlt3: add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                          (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))
               < eps.
  { exact (SNoLt_tra
           (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                    (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)))
           (eps_ Nsmall)
           eps
           (SNo_add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                        (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x))
                        HdnS HdmS)
           HepsNS
           HepsS
           Hsumlt2
           HepsNlt). }
  claim HsumepsR: Rlt (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                               (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)))
                    eps.
  { exact (RltI
           (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                    (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)))
           eps
           HsumR
           HepsR
           Hsumlt3). }
  claim HdnmLt: Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x)) eps.
  { exact (Rle_Rlt_tra
           (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x))
           (add_SNo (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x))
                    (apply_fun d (apply_fun f x, apply_fun (apply_fun fn m) x)))
           eps
           Htri
           HsumepsR). }
  exact (Rlt_implies_Rle
         (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun (apply_fun fn m) x))
         eps
         HdnmLt).
Qed.

(** helper: U(eps) should be open and dense under hypotheses of Theorem 48.5 **)
(** LATEX VERSION: In the proof of Theorem 48.5, U(eps) is shown to be open and dense. **)
Theorem U_eps_open_dense_stub : forall X Tx Y d fn eps:set,
  Baire_space X Tx ->
  metric_on_total Y d ->
  (forall n:set, n :e omega ->
    continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n)) ->
  (forall N:set, N :e omega -> closed_in X Tx (A_N_eps X Y d fn N eps)) ->
  (forall x:set, x :e X -> exists N:set, N :e omega /\ x :e A_N_eps X Y d fn N eps) ->
  eps :e R -> Rlt 0 eps ->
  open_in X Tx (U_eps X Tx Y d fn eps) /\ dense_in (U_eps X Tx Y d fn eps) X Tx.
let X Tx Y d fn eps.
assume HB: Baire_space X Tx.
assume Hd: metric_on_total Y d.
assume Hcont: forall n:set, n :e omega ->
  continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n).
assume Hclosed: forall N:set, N :e omega -> closed_in X Tx (A_N_eps X Y d fn N eps).
assume Hcover: forall x:set, x :e X -> exists N:set, N :e omega /\ x :e A_N_eps X Y d fn N eps.
assume Heps: eps :e R.
assume HepsPos: Rlt 0 eps.
prove open_in X Tx (U_eps X Tx Y d fn eps) /\ dense_in (U_eps X Tx Y d fn eps) X Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set,
                 U c= Tx -> countable_set U ->
                 (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U) X Tx)
               HB). }
apply andI.
- (** U_eps is open **)
  prove open_in X Tx (U_eps X Tx Y d fn eps).
  set UFam := {interior_of X Tx (A_N_eps X Y d fn N eps) | N :e omega}.
  claim HdefU: U_eps X Tx Y d fn eps = Union UFam.
  { reflexivity. }
  claim HUFamPow: UFam :e Power Tx.
  { apply (PowerI Tx UFam).
    let U0. assume HU0: U0 :e UFam.
    prove U0 :e Tx.
    claim HexN: exists N:set, N :e omega /\ U0 = interior_of X Tx (A_N_eps X Y d fn N eps).
    { exact (ReplE omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps)) U0 HU0). }
    apply HexN.
    let N. assume HN: N :e omega /\ U0 = interior_of X Tx (A_N_eps X Y d fn N eps).
    claim HNeq: U0 = interior_of X Tx (A_N_eps X Y d fn N eps).
    { exact (andER (N :e omega) (U0 = interior_of X Tx (A_N_eps X Y d fn N eps)) HN). }
    rewrite HNeq.
    (** interior is open, and A_N_eps is a subset of X by definition **)
    claim HANsub: A_N_eps X Y d fn N eps c= X.
    { let x. assume Hx: x :e A_N_eps X Y d fn N eps.
      exact (SepE1 X
        (fun x0:set =>
          forall n:set, n :e omega -> N c= n ->
            forall m:set, m :e omega -> N c= m ->
              Rle (apply_fun d (apply_fun (apply_fun fn n) x0, apply_fun (apply_fun fn m) x0)) eps)
        x Hx). }
    exact (interior_is_open X Tx (A_N_eps X Y d fn N eps) HTx HANsub). }
  claim HUnionInTx: Union UFam :e Tx.
  { exact (topology_union_closed_pow X Tx UFam HTx HUFamPow). }
  claim HUepsInTx: U_eps X Tx Y d fn eps :e Tx.
  { rewrite HdefU.
    exact HUnionInTx. }
  rewrite HdefU.
  exact (open_inI X Tx (Union UFam) HTx HUnionInTx).
- (** U_eps is dense: proof uses Lemma 48.4 in the TeX argument **)
  prove dense_in (U_eps X Tx Y d fn eps) X Tx.
  prove closure_of X Tx (U_eps X Tx Y d fn eps) = X.
  apply set_ext.
  + (** closure(U_eps) ⊆ X **)
    exact (closure_in_space X Tx (U_eps X Tx Y d fn eps) HTx).
  + (** X ⊆ closure(U_eps) by neighborhood characterization **)
    let x. assume HxX: x :e X.
    prove x :e closure_of X Tx (U_eps X Tx Y d fn eps).
    claim Hcliff:
      x :e closure_of X Tx (U_eps X Tx Y d fn eps) <->
      (forall U :e Tx, x :e U -> U :/\: (U_eps X Tx Y d fn eps) <> Empty).
    { exact (closure_characterization X Tx (U_eps X Tx Y d fn eps) x HTx HxX). }
    apply (iffER (x :e closure_of X Tx (U_eps X Tx Y d fn eps))
                 (forall U :e Tx, x :e U -> U :/\: (U_eps X Tx Y d fn eps) <> Empty)
                 Hcliff).
    prove forall U :e Tx, x :e U -> U :/\: (U_eps X Tx Y d fn eps) <> Empty.
    let U. assume HU: U :e Tx. assume HxU: x :e U.
    claim HUne: U <> Empty.
    { exact (elem_implies_nonempty U x HxU). }
    (** Use Baire on the open subspace U to find N with Int_U (U∩A_N) nonempty. **)
    claim HUopen: open_in X Tx U.
    { exact (open_inI X Tx U HTx HU). }
    claim HBU: Baire_space U (subspace_topology X Tx U).
    { exact (Baire_open_subspace X Tx U HB HUopen). }
    claim HBcU: Baire_space_closed U (subspace_topology X Tx U).
    { exact (Baire_space_imp_closed U (subspace_topology X Tx U) HBU). }
    claim HTu: topology_on U (subspace_topology X Tx U).
    { exact (subspace_topology_is_topology X Tx U HTx (open_in_subset X Tx U HUopen)). }
    claim HBUprop:
      forall Fam:set,
        countable_set Fam ->
        (forall A:set, A :e Fam ->
          closed_in U (subspace_topology X Tx U) A /\ interior_of U (subspace_topology X Tx U) A = Empty) ->
        interior_of U (subspace_topology X Tx U) (Union Fam) = Empty.
    { exact (andER (topology_on U (subspace_topology X Tx U))
                   (forall Fam:set,
                     countable_set Fam ->
                     (forall A:set, A :e Fam ->
                       closed_in U (subspace_topology X Tx U) A /\ interior_of U (subspace_topology X Tx U) A = Empty) ->
                     interior_of U (subspace_topology X Tx U) (Union Fam) = Empty)
                   HBcU). }
    set Fam := {U :/\: (A_N_eps X Y d fn N eps) | N :e omega}.
    claim HomegaCount: countable_set omega.
    { prove countable_set omega.
      prove countable omega.
      exact (Subq_atleastp omega omega (Subq_ref omega)). }
    claim HcountFam: countable_set Fam.
    { exact (countable_image omega HomegaCount (fun N0:set => U :/\: (A_N_eps X Y d fn N0 eps))). }
    claim HFamClosed: forall B:set, B :e Fam ->
      closed_in U (subspace_topology X Tx U) B.
    { let B. assume HBmem: B :e Fam.
      claim HexN: exists N:set, N :e omega /\ B = U :/\: (A_N_eps X Y d fn N eps).
      { exact (ReplE omega (fun N0:set => U :/\: (A_N_eps X Y d fn N0 eps)) B HBmem). }
      apply HexN.
      let N. assume HN: N :e omega /\ B = U :/\: (A_N_eps X Y d fn N eps).
      claim HNin: N :e omega.
      { exact (andEL (N :e omega) (B = U :/\: (A_N_eps X Y d fn N eps)) HN). }
      claim HBdef: B = U :/\: (A_N_eps X Y d fn N eps).
      { exact (andER (N :e omega) (B = U :/\: (A_N_eps X Y d fn N eps)) HN). }
      (** B is intersection with U of a closed set in X **)
      claim HclX: closed_in X Tx (A_N_eps X Y d fn N eps).
      { exact (Hclosed N HNin). }
      claim HsubU: U c= X.
      { exact (topology_elem_subset X Tx U HTx HU). }
      claim HBclosedU: closed_in U (subspace_topology X Tx U) (A_N_eps X Y d fn N eps :/\: U).
      { apply (iffER (closed_in U (subspace_topology X Tx U) (A_N_eps X Y d fn N eps :/\: U))
                     (exists C:set, closed_in X Tx C /\ (A_N_eps X Y d fn N eps :/\: U) = C :/\: U)
                     (closed_in_subspace_iff_intersection X Tx U (A_N_eps X Y d fn N eps :/\: U) HTx HsubU)).
        witness (A_N_eps X Y d fn N eps).
        apply andI.
        - exact HclX.
        - apply set_ext.
          + let z. assume Hz: z :e (A_N_eps X Y d fn N eps :/\: U).
            exact Hz.
          + let z. assume Hz: z :e (A_N_eps X Y d fn N eps :/\: U).
            exact Hz. }
      rewrite HBdef.
      (** commute intersection **)
      claim Hcomm: U :/\: (A_N_eps X Y d fn N eps) = (A_N_eps X Y d fn N eps) :/\: U.
      { apply set_ext.
        - let z. assume Hz: z :e U :/\: (A_N_eps X Y d fn N eps).
          prove z :e (A_N_eps X Y d fn N eps) :/\: U.
          exact (binintersectI (A_N_eps X Y d fn N eps) U z
                 (binintersectE2 U (A_N_eps X Y d fn N eps) z Hz)
                 (binintersectE1 U (A_N_eps X Y d fn N eps) z Hz)).
        - let z. assume Hz: z :e (A_N_eps X Y d fn N eps) :/\: U.
          prove z :e U :/\: (A_N_eps X Y d fn N eps).
          exact (binintersectI U (A_N_eps X Y d fn N eps) z
                 (binintersectE2 (A_N_eps X Y d fn N eps) U z Hz)
                 (binintersectE1 (A_N_eps X Y d fn N eps) U z Hz)). }
      rewrite Hcomm.
      exact HBclosedU. }
    (** If all interiors are empty, then interior of Union Fam is empty, but Union Fam = U. **)
    claim HexNgood:
      exists N:set, N :e omega /\
        interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty.
    { apply (xm (exists N:set, N :e omega /\
        interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty)).
      - assume Hex. exact Hex.
      - assume Hno: ~ (exists N:set, N :e omega /\
          interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty).
        prove exists N:set, N :e omega /\
          interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty.
        apply FalseE.
        (** build the empty-interior hypothesis for Baire_space_closed on U **)
        claim HFamPack: forall B:set, B :e Fam ->
          closed_in U (subspace_topology X Tx U) B /\ interior_of U (subspace_topology X Tx U) B = Empty.
        { let B. assume HBmem: B :e Fam.
          claim HBcl: closed_in U (subspace_topology X Tx U) B.
          { exact (HFamClosed B HBmem). }
          claim HexN: exists N:set, N :e omega /\ B = U :/\: (A_N_eps X Y d fn N eps).
          { exact (ReplE omega (fun N0:set => U :/\: (A_N_eps X Y d fn N0 eps)) B HBmem). }
          apply HexN.
          let N. assume HN: N :e omega /\ B = U :/\: (A_N_eps X Y d fn N eps).
          claim HNin: N :e omega.
          { exact (andEL (N :e omega) (B = U :/\: (A_N_eps X Y d fn N eps)) HN). }
          claim HBdef: B = U :/\: (A_N_eps X Y d fn N eps).
          { exact (andER (N :e omega) (B = U :/\: (A_N_eps X Y d fn N eps)) HN). }
          claim Hempt: interior_of U (subspace_topology X Tx U) B = Empty.
          { rewrite HBdef.
            apply (xm (interior_of U (subspace_topology X Tx U)
                         (U :/\: (A_N_eps X Y d fn N eps)) = Empty)).
            - assume Heq. exact Heq.
            - assume Hneq: interior_of U (subspace_topology X Tx U)
                         (U :/\: (A_N_eps X Y d fn N eps)) <> Empty.
              apply FalseE.
              apply Hno.
              witness N.
              apply andI.
              + exact HNin.
              + exact Hneq. }
          apply andI.
          + exact HBcl.
          + exact Hempt. }
        claim HintUnion: interior_of U (subspace_topology X Tx U) (Union Fam) = Empty.
        { exact (HBUprop Fam HcountFam HFamPack). }
        (** show Union Fam = U **)
        claim HUnionEq: Union Fam = U.
        { apply set_ext.
          - let z. assume Hz: z :e Union Fam.
            apply (UnionE_impred Fam z Hz (z :e U)).
            let B. assume HzB: z :e B. assume HBmem: B :e Fam.
            claim HBsubU: B c= U.
            { apply (ReplE_impred omega (fun N0:set => U :/\: (A_N_eps X Y d fn N0 eps)) B HBmem (B c= U)).
              let N0. assume _. assume HBdef.
              rewrite HBdef.
              exact (binintersect_Subq_1 U (A_N_eps X Y d fn N0 eps)). }
            exact (HBsubU z HzB).
          - let z. assume HzU: z :e U.
            prove z :e Union Fam.
            claim HzX: z :e X.
            { exact (topology_elem_subset X Tx U HTx HU z HzU). }
            claim HexN: exists N:set, N :e omega /\ z :e A_N_eps X Y d fn N eps.
            { exact (Hcover z HzX). }
            apply HexN.
            let N. assume HN: N :e omega /\ z :e A_N_eps X Y d fn N eps.
            claim HNin: N :e omega.
            { exact (andEL (N :e omega) (z :e A_N_eps X Y d fn N eps) HN). }
            claim HzAN: z :e A_N_eps X Y d fn N eps.
            { exact (andER (N :e omega) (z :e A_N_eps X Y d fn N eps) HN). }
            claim HzB: z :e U :/\: (A_N_eps X Y d fn N eps).
            { exact (binintersectI U (A_N_eps X Y d fn N eps) z HzU HzAN). }
            claim HBmem: (U :/\: (A_N_eps X Y d fn N eps)) :e Fam.
            { exact (ReplI omega (fun N0:set => U :/\: (A_N_eps X Y d fn N0 eps)) N HNin). }
            exact (UnionI Fam z (U :/\: (A_N_eps X Y d fn N eps)) HzB HBmem). }
        claim HintU: interior_of U (subspace_topology X Tx U) U = U.
        { exact (interior_of_space U (subspace_topology X Tx U) HTu). }
        claim HintUEmpty: interior_of U (subspace_topology X Tx U) U = Empty.
        { rewrite <- HintUnion.
          rewrite HUnionEq.
          reflexivity. }
        claim HUeqEmpty: U = Empty.
        { rewrite <- HintU.
          exact HintUEmpty. }
        exact (HUne HUeqEmpty). }
    (** Use the nonempty interior point to get a point in U∩U_eps **)
    apply HexNgood.
    let N. assume HN: N :e omega /\
      interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty.
    claim HNin: N :e omega.
    { exact (andEL (N :e omega)
                   (interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty)
                   HN). }
    claim HintNe: interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty.
    { exact (andER (N :e omega)
                   (interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)) <> Empty)
                   HN). }
    claim Hexy: exists y:set, y :e interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)).
    { exact (nonempty_has_element (interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps))) HintNe). }
    apply Hexy.
    let y. assume HyInt: y :e interior_of U (subspace_topology X Tx U) (U :/\: (A_N_eps X Y d fn N eps)).
    claim HyU: y :e U.
    { exact (SepE1 U (fun y0:set => exists W:set,
        W :e subspace_topology X Tx U /\ y0 :e W /\ W c= (U :/\: (A_N_eps X Y d fn N eps))) y HyInt). }
    claim HexW: exists W:set, W :e subspace_topology X Tx U /\ y :e W /\ W c= (U :/\: (A_N_eps X Y d fn N eps)).
    { exact (SepE2 U (fun y0:set => exists W:set,
        W :e subspace_topology X Tx U /\ y0 :e W /\ W c= (U :/\: (A_N_eps X Y d fn N eps))) y HyInt). }
    apply HexW.
    let W. assume HW: W :e subspace_topology X Tx U /\ y :e W /\ W c= (U :/\: (A_N_eps X Y d fn N eps)).
    claim HWpack: (W :e subspace_topology X Tx U /\ y :e W) /\ W c= (U :/\: (A_N_eps X Y d fn N eps)).
    { exact HW. }
    claim HW1: W :e subspace_topology X Tx U /\ y :e W.
    { exact (andEL (W :e subspace_topology X Tx U /\ y :e W)
                   (W c= (U :/\: (A_N_eps X Y d fn N eps)))
                   HWpack). }
    claim HWsub: W c= (U :/\: (A_N_eps X Y d fn N eps)).
    { exact (andER (W :e subspace_topology X Tx U /\ y :e W)
                   (W c= (U :/\: (A_N_eps X Y d fn N eps)))
                   HWpack). }
    claim HyW: y :e W.
    { exact (andER (W :e subspace_topology X Tx U) (y :e W) HW1). }
    claim HWTy: W :e subspace_topology X Tx U.
    { exact (andEL (W :e subspace_topology X Tx U) (y :e W) HW1). }
    claim HexV: exists V :e Tx, W = V :/\: U.
    { exact (subspace_topologyE X Tx U W HWTy). }
    apply HexV.
    let V. assume HV: V :e Tx /\ W = V :/\: U.
    claim HVin: V :e Tx.
    { exact (andEL (V :e Tx) (W = V :/\: U) HV). }
    claim HWdef: W = V :/\: U.
    { exact (andER (V :e Tx) (W = V :/\: U) HV). }
    claim HWTx: W :e Tx.
    { rewrite HWdef.
      exact (lemma_intersection_two_open X Tx V U HTx HVin HU). }
    claim HWsubA: W c= (A_N_eps X Y d fn N eps).
    { let z. assume HzW: z :e W.
      claim HzUA: z :e U :/\: (A_N_eps X Y d fn N eps).
      { exact (HWsub z HzW). }
      exact (binintersectE2 U (A_N_eps X Y d fn N eps) z HzUA). }
    claim HyIntX: y :e interior_of X Tx (A_N_eps X Y d fn N eps).
    { claim HyX: y :e X.
      { exact (topology_elem_subset X Tx U HTx HU y HyU). }
      claim HdefInt: interior_of X Tx (A_N_eps X Y d fn N eps) =
        {x0 :e X | exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N eps)}.
      { reflexivity. }
      rewrite HdefInt.
      apply (SepI X (fun x0:set => exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N eps)) y HyX).
      witness W.
      apply and3I.
      - exact HWTx.
      - exact HyW.
      - exact HWsubA. }
    (** y belongs to the N-th interior hence to U_eps and also y∈U, so U∩U_eps nonempty **)
    claim HyInFam: interior_of X Tx (A_N_eps X Y d fn N eps) :e
      {interior_of X Tx (A_N_eps X Y d fn N0 eps) | N0 :e omega}.
    { exact (ReplI omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps)) N HNin). }
    claim HyUeps: y :e U_eps X Tx Y d fn eps.
    { exact (UnionI {interior_of X Tx (A_N_eps X Y d fn N0 eps) | N0 :e omega}
                    y
                    (interior_of X Tx (A_N_eps X Y d fn N eps))
                    HyIntX
                    HyInFam). }
    claim HyInter: y :e U :/\: (U_eps X Tx Y d fn eps).
    { exact (binintersectI U (U_eps X Tx Y d fn eps) y HyU HyUeps). }
    exact (elem_implies_nonempty (U :/\: (U_eps X Tx Y d fn eps)) y HyInter).
Qed.

(** helper: fourfold-small epsilon for metric continuity estimates **)
(** This is used in §48.5 to split a target radius eps0 into four smaller error terms. **)
Theorem exists_fourfold_small_eps : forall eps0:set,
  eps0 :e R -> Rlt 0 eps0 ->
  exists eps1:set,
    eps1 :e R /\ Rlt 0 eps1 /\
    Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0.
let eps0.
assume Heps0R: eps0 :e R.
assume Heps0Pos: Rlt 0 eps0.
claim HexN0: exists N0 :e omega, eps_ N0 < eps0.
{ exact (exists_eps_lt_pos eps0 Heps0R Heps0Pos). }
apply HexN0.
let N0. assume HN0pair.
claim HN0omega: N0 :e omega.
{ exact (andEL (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
claim HepsN0lt: eps_ N0 < eps0.
{ exact (andER (N0 :e omega) (eps_ N0 < eps0) HN0pair). }
claim HN0nat: nat_p N0.
{ exact (omega_nat_p N0 HN0omega). }
claim Hsucc0: ordsucc N0 :e omega.
{ exact (omega_ordsucc N0 HN0omega). }
claim Hsucc1: ordsucc (ordsucc N0) :e omega.
{ exact (omega_ordsucc (ordsucc N0) Hsucc0). }
set eps1 := eps_ (ordsucc (ordsucc N0)).
claim Heps1R: eps1 :e R.
{ exact (SNoS_omega_real eps1 (SNo_eps_SNoS_omega (ordsucc (ordsucc N0)) Hsucc1)). }
claim Heps1S: SNo eps1.
{ exact (real_SNo eps1 Heps1R). }
claim H0lt_eps1: 0 < eps1.
{ exact (SNo_eps_pos (ordsucc (ordsucc N0)) Hsucc1). }
claim Heps1Pos: Rlt 0 eps1.
{ exact (RltI 0 eps1 real_0 Heps1R H0lt_eps1). }
claim Heps2eq: add_SNo eps1 eps1 = eps_ (ordsucc N0).
{ exact (eps_ordsucc_half_add (ordsucc N0) (omega_nat_p (ordsucc N0) Hsucc0)). }
claim Heps4eq: add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1) = eps_ N0.
{ rewrite Heps2eq.
  exact (eps_ordsucc_half_add N0 HN0nat). }
claim Heps2R: add_SNo eps1 eps1 :e R.
{ exact (real_add_SNo eps1 Heps1R eps1 Heps1R). }
claim HsumR: add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1) :e R.
{ exact (real_add_SNo (add_SNo eps1 eps1) Heps2R (add_SNo eps1 eps1) Heps2R). }
claim HsumSlt: add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1) < eps0.
{ rewrite Heps4eq. exact HepsN0lt. }
claim HsumRlt: Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0.
{ exact (RltI (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0 HsumR Heps0R HsumSlt). }
witness eps1.
apply andI.
{ apply andI.
  { exact Heps1R. }
  { exact Heps1Pos. } }
{ exact HsumRlt. }
Qed.


(** from §48 Theorem 48.5: continuity points of pointwise limit are dense **)
(** LATEX VERSION: Theorem 48.5: If f_n:X→Y are continuous and f_n(x)→f(x) pointwise into metric space Y, then continuity points of f form a dense subset of X when X is Baire. **)
Theorem pointwise_limit_continuity_points_dense : forall X Tx Y d fn f:set,
  metric_on_total Y d ->
  (forall n:set, n :e omega ->
    continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n)) ->
  function_on f X Y ->
  pointwise_limit_metric X Y d fn f ->
  Baire_space X Tx ->
  dense_in {x :e X | continuous_at_map X Tx Y (metric_topology Y d) f x} X Tx.
let X Tx Y d fn f.
assume Hd: metric_on_total Y d.
assume Hcont: forall n:set, n :e omega ->
  continuous_map X Tx Y (metric_topology Y d) (apply_fun fn n).
assume Hf: function_on f X Y.
assume Hlim: pointwise_limit_metric X Y d fn f.
assume HB: Baire_space X Tx.
prove dense_in {x :e X | continuous_at_map X Tx Y (metric_topology Y d) f x} X Tx.
(** Outline of TeX proof: define U(eps)=⋃ Int(A_N(eps)), show each U(eps) open dense, use Baire to get C=⋂U(1/n) dense, show f continuous on C. **)
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set,
                 U c= Tx -> countable_set U ->
                 (forall u:set, u :e U -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U) X Tx)
               HB). }
claim HcoverAll: forall eps0:set, eps0 :e R -> Rlt 0 eps0 ->
  forall x:set, x :e X -> exists N:set, N :e omega /\ x :e A_N_eps X Y d fn N eps0.
{ let eps0.
  assume Heps0R: eps0 :e R.
  assume Heps0Pos: Rlt 0 eps0.
  claim HfnOn: forall n:set, n :e omega -> function_on (apply_fun fn n) X Y.
  { let n. assume Hn: n :e omega.
    exact (continuous_map_function_on X Tx Y (metric_topology Y d) (apply_fun fn n) (Hcont n Hn)). }
  let x.
  assume HxX: x :e X.
  exact (pointwise_limit_metric_imp_cover_A_N_eps_stub X Y d fn f eps0 Hd HfnOn Hf Hlim Heps0R Heps0Pos x HxX). }
claim HclosedAll: forall eps0:set, eps0 :e R ->
  forall N:set, N :e omega -> closed_in X Tx (A_N_eps X Y d fn N eps0).
{ let eps0.
  assume Heps0R: eps0 :e R.
  let N.
  assume HN: N :e omega.
  exact (A_N_eps_closed_stub X Tx Y d fn N eps0 HTx Hd Hcont HN Heps0R). }
set Ufam := {U_eps X Tx Y d fn (inv_nat (ordsucc n)) | n :e omega}.
claim HcountOmega: countable_set omega.
{ prove countable_set omega.
  prove countable omega.
  exact (Subq_atleastp omega omega (Subq_ref omega)). }
claim HcountUfam: countable_set Ufam.
{ exact (countable_image omega HcountOmega (fun n0:set => U_eps X Tx Y d fn (inv_nat (ordsucc n0)))). }
claim HUfamSub: Ufam c= Tx.
{ let U. assume HU: U :e Ufam.
  apply (ReplE_impred omega (fun n0:set => U_eps X Tx Y d fn (inv_nat (ordsucc n0))) U HU (U :e Tx)).
  let n0. assume Hn0: n0 :e omega.
  assume HeqU: U = U_eps X Tx Y d fn (inv_nat (ordsucc n0)).
  claim HsuccOmega: ordsucc n0 :e omega.
  { exact (omega_ordsucc n0 Hn0). }
  claim Hnot0: ordsucc n0 /:e {0}.
  { assume Hmem0: ordsucc n0 :e {0}.
    claim Heq0: ordsucc n0 = 0.
    { exact (SingE 0 (ordsucc n0) Hmem0). }
    exact ((neq_ordsucc_0 n0) Heq0). }
  claim HsuccIn: ordsucc n0 :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc n0) HsuccOmega Hnot0). }
  claim HepsR: inv_nat (ordsucc n0) :e R.
  { exact (inv_nat_real (ordsucc n0) HsuccOmega). }
  claim HepsPos: Rlt 0 (inv_nat (ordsucc n0)).
  { exact (inv_nat_pos (ordsucc n0) HsuccIn). }
  claim Htmp: open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) /\
              dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx.
  { exact (U_eps_open_dense_stub X Tx Y d fn (inv_nat (ordsucc n0))
           HB Hd Hcont
           (HclosedAll (inv_nat (ordsucc n0)) HepsR)
           (HcoverAll (inv_nat (ordsucc n0)) HepsR HepsPos)
           HepsR HepsPos). }
  claim Hop: open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))).
  { exact (andEL (open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))))
                 (dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx)
                 Htmp). }
  claim HUinTx: U_eps X Tx Y d fn (inv_nat (ordsucc n0)) :e Tx.
  { exact (open_in_elem X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) Hop). }
  rewrite HeqU.
  exact HUinTx. }
claim HUfamDense: forall u:set, u :e Ufam -> u :e Tx /\ dense_in u X Tx.
{ let u. assume Hu: u :e Ufam.
  apply (ReplE_impred omega (fun n0:set => U_eps X Tx Y d fn (inv_nat (ordsucc n0))) u Hu
        (u :e Tx /\ dense_in u X Tx)).
  let n0. assume Hn0: n0 :e omega.
  assume HeqU: u = U_eps X Tx Y d fn (inv_nat (ordsucc n0)).
  claim HsuccOmega: ordsucc n0 :e omega.
  { exact (omega_ordsucc n0 Hn0). }
  claim Hnot0: ordsucc n0 /:e {0}.
  { assume Hmem0: ordsucc n0 :e {0}.
    claim Heq0: ordsucc n0 = 0.
    { exact (SingE 0 (ordsucc n0) Hmem0). }
    exact ((neq_ordsucc_0 n0) Heq0). }
  claim HsuccIn: ordsucc n0 :e omega :\: {0}.
  { exact (setminusI omega {0} (ordsucc n0) HsuccOmega Hnot0). }
  claim HepsR: inv_nat (ordsucc n0) :e R.
  { exact (inv_nat_real (ordsucc n0) HsuccOmega). }
  claim HepsPos: Rlt 0 (inv_nat (ordsucc n0)).
  { exact (inv_nat_pos (ordsucc n0) HsuccIn). }
  claim Htmp: open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) /\
              dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx.
  { exact (U_eps_open_dense_stub X Tx Y d fn (inv_nat (ordsucc n0))
           HB Hd Hcont
           (HclosedAll (inv_nat (ordsucc n0)) HepsR)
           (HcoverAll (inv_nat (ordsucc n0)) HepsR HepsPos)
           HepsR HepsPos). }
  claim Hop: open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))).
  { exact (andEL (open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))))
                 (dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx)
                 Htmp). }
  claim Hdense: dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx.
  { exact (andER (open_in X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))))
                 (dense_in (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) X Tx)
                 Htmp). }
  claim HUinTx: u :e Tx.
  { rewrite HeqU.
    exact (open_in_elem X Tx (U_eps X Tx Y d fn (inv_nat (ordsucc n0))) Hop). }
  claim Hdenseu: dense_in u X Tx.
  { rewrite HeqU.
    exact Hdense. }
  apply andI.
  - exact HUinTx.
  - exact Hdenseu. }
claim HBprop: forall U0:set,
  U0 c= Tx -> countable_set U0 ->
  (forall u:set, u :e U0 -> u :e Tx /\ dense_in u X Tx) ->
  dense_in (intersection_over_family X U0) X Tx.
{ exact (andER (topology_on X Tx)
               (forall U0:set,
                 U0 c= Tx -> countable_set U0 ->
                 (forall u:set, u :e U0 -> u :e Tx /\ dense_in u X Tx) ->
                 dense_in (intersection_over_family X U0) X Tx)
               HB). }
claim HdenseC: dense_in (intersection_over_family X Ufam) X Tx.
{ exact (HBprop Ufam HUfamSub HcountUfam HUfamDense). }
claim HCsubCont:
  intersection_over_family X Ufam c=
    {x :e X | continuous_at_map X Tx Y (metric_topology Y d) f x}.
{ let x.
  assume HxC: x :e intersection_over_family X Ufam.
  claim HxX: x :e X.
  { exact (SepE1 X (fun z0:set => forall u0:set, u0 :e Ufam -> z0 :e u0) x HxC). }
  claim HxAll: forall u0:set, u0 :e Ufam -> x :e u0.
  { exact (SepE2 X (fun z0:set => forall u0:set, u0 :e Ufam -> z0 :e u0) x HxC). }
  apply (SepI X (fun x0:set => continuous_at_map X Tx Y (metric_topology Y d) f x0) x HxX).
  prove continuous_at_map X Tx Y (metric_topology Y d) f x.
  claim HdefCont: continuous_at_map X Tx Y (metric_topology Y d) f x =
    (function_on f X Y /\ x :e X /\
      forall V:set, V :e metric_topology Y d -> apply_fun f x :e V ->
        exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V).
  { reflexivity. }
  rewrite HdefCont.
  apply andI.
  - (** function and x in X **)
    apply andI.
    + exact Hf.
    + exact HxX.
  - (** neighborhood form continuity into the metric topology **)
    let V.
    assume HV: V :e metric_topology Y d.
    assume HfxV: apply_fun f x :e V.
    claim Hexn0: exists n0:set, n0 :e omega /\
      open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V.
    { claim HmY: metric_on Y d.
      { exact (metric_on_total_imp_metric_on Y d Hd). }
      set B := famunion Y (fun y0:set => {open_ball Y d y0 r|r :e R, Rlt 0 r}).
      claim HdefMT: metric_topology Y d = generated_topology Y B.
      { reflexivity. }
      claim HVgen: V :e generated_topology Y B.
      { rewrite <- HdefMT.
        exact HV. }
      claim HVloc: forall y0 :e V, exists b :e B, y0 :e b /\ b c= V.
      { exact (SepE2 (Power Y)
                     (fun U0:set => forall y0 :e U0, exists b :e B, y0 :e b /\ b c= U0)
                     V
                     HVgen). }
      claim HfxY: apply_fun f x :e Y.
      { exact (Hf x HxX). }
      apply (HVloc (apply_fun f x) HfxV).
      let b. assume Hbpair.
      claim HbB: b :e B.
      { exact (andEL (b :e B) (apply_fun f x :e b /\ b c= V) Hbpair). }
      claim Hbprop: apply_fun f x :e b /\ b c= V.
      { exact (andER (b :e B) (apply_fun f x :e b /\ b c= V) Hbpair). }
      claim Hfxb: apply_fun f x :e b.
      { exact (andEL (apply_fun f x :e b) (b c= V) Hbprop). }
      claim HbsubV: b c= V.
      { exact (andER (apply_fun f x :e b) (b c= V) Hbprop). }
      (** destruct b as an open ball around some center c with radius r>0 **)
      apply (famunionE_impred Y (fun y0:set => {open_ball Y d y0 r|r :e R, Rlt 0 r}) b HbB
             (exists n0:set, n0 :e omega /\ open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V)).
      let c. assume HcY: c :e Y.
      assume HbIn: b :e {open_ball Y d c r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball Y d c r0) b HbIn
             (exists n0:set, n0 :e omega /\ open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V)).
      let r. assume HrR: r :e R.
      assume Hrpos: Rlt 0 r.
      assume Hbeq: b = open_ball Y d c r.
      claim HfxInBall: apply_fun f x :e open_ball Y d c r.
      { rewrite <- Hbeq.
        exact Hfxb. }
      claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball Y d (apply_fun f x) s c= open_ball Y d c r.
      { exact (open_ball_refine_center Y d c (apply_fun f x) r HmY HcY HfxY HrR Hrpos HfxInBall). }
      apply Hexs.
      let s. assume Hs.
      claim Hs12: s :e R /\ Rlt 0 s.
      { exact (andEL (s :e R /\ Rlt 0 s)
                     (open_ball Y d (apply_fun f x) s c= open_ball Y d c r)
                     Hs). }
      claim HsR: s :e R.
      { exact (andEL (s :e R) (Rlt 0 s) Hs12). }
      claim Hspos: Rlt 0 s.
      { exact (andER (s :e R) (Rlt 0 s) Hs12). }
      claim HballSubCr: open_ball Y d (apply_fun f x) s c= open_ball Y d c r.
      { exact (andER (s :e R /\ Rlt 0 s)
                     (open_ball Y d (apply_fun f x) s c= open_ball Y d c r)
                     Hs). }
      claim HCrSubV: open_ball Y d c r c= V.
      { rewrite <- Hbeq.
        exact HbsubV. }
      claim HballSSubV: open_ball Y d (apply_fun f x) s c= V.
      { exact (Subq_tra (open_ball Y d (apply_fun f x) s) (open_ball Y d c r) V HballSubCr HCrSubV). }
      claim HexN: exists N:set, N :e omega /\ Rlt (inv_nat (ordsucc N)) s.
      { exact (exists_inv_nat_ordsucc_lt s HsR Hspos). }
      apply HexN.
      let N. assume HNpair.
      claim HNin: N :e omega.
      { exact (andEL (N :e omega) (Rlt (inv_nat (ordsucc N)) s) HNpair). }
      claim HinvLt: Rlt (inv_nat (ordsucc N)) s.
      { exact (andER (N :e omega) (Rlt (inv_nat (ordsucc N)) s) HNpair). }
      witness N.
      apply andI.
      - exact HNin.
      - claim HsubSmall: open_ball Y d (apply_fun f x) (inv_nat (ordsucc N)) c= open_ball Y d (apply_fun f x) s.
        { exact (open_ball_radius_mono Y d (apply_fun f x) (inv_nat (ordsucc N)) s HinvLt). }
        exact (Subq_tra (open_ball Y d (apply_fun f x) (inv_nat (ordsucc N)))
                        (open_ball Y d (apply_fun f x) s)
                        V
                        HsubSmall
                        HballSSubV). }
    apply Hexn0.
    let n0.
    assume Hn0: n0 :e omega /\ open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V.
    claim Hn0in: n0 :e omega.
    { exact (andEL (n0 :e omega)
                   (open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V)
                   Hn0). }
    claim HballSubV: open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V.
    { exact (andER (n0 :e omega)
                   (open_ball Y d (apply_fun f x) (inv_nat (ordsucc n0)) c= V)
                   Hn0). }
    claim HsuccOmega: ordsucc n0 :e omega.
    { exact (omega_ordsucc n0 Hn0in). }
    claim Hnot0: ordsucc n0 /:e {0}.
    { assume Hmem0: ordsucc n0 :e {0}.
      claim Heq0: ordsucc n0 = 0.
      { exact (SingE 0 (ordsucc n0) Hmem0). }
      exact ((neq_ordsucc_0 n0) Heq0). }
    claim HsuccIn: ordsucc n0 :e omega :\: {0}.
    { exact (setminusI omega {0} (ordsucc n0) HsuccOmega Hnot0). }
    set eps0 := inv_nat (ordsucc n0).
    claim Heps0R: eps0 :e R.
    { exact (inv_nat_real (ordsucc n0) HsuccOmega). }
    claim Heps0Pos: Rlt 0 eps0.
    { exact (inv_nat_pos (ordsucc n0) HsuccIn). }
    claim Hu0in: (U_eps X Tx Y d fn eps0) :e Ufam.
    { exact (ReplI omega (fun n1:set => U_eps X Tx Y d fn (inv_nat (ordsucc n1))) n0 Hn0in). }
    claim HxU0: x :e (U_eps X Tx Y d fn eps0).
    { exact (HxAll (U_eps X Tx Y d fn eps0) Hu0in). }
    set UFam := {interior_of X Tx (A_N_eps X Y d fn N eps0) | N :e omega}.
    claim HUepsDef: U_eps X Tx Y d fn eps0 = Union UFam.
    { reflexivity. }
    claim HxUnion: x :e Union UFam.
    { rewrite <- HUepsDef.
      exact HxU0. }
    apply (UnionE_impred UFam x HxUnion
      (exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V)).
    let W.
    assume HxW: x :e W.
    assume HWin: W :e UFam.
    apply (ReplE_impred omega (fun N0:set => interior_of X Tx (A_N_eps X Y d fn N0 eps0))
            W HWin
            (exists U:set, U :e Tx /\ x :e U /\ forall u:set, u :e U -> apply_fun f u :e V)).
    let N0.
    assume HN0: N0 :e omega.
    assume HWdef: W = interior_of X Tx (A_N_eps X Y d fn N0 eps0).
    claim HxInt: x :e interior_of X Tx (A_N_eps X Y d fn N0 eps0).
    { rewrite <- HWdef.
      exact HxW. }
    claim HxX2: x :e X.
    { exact HxX. }
    claim HintDef: interior_of X Tx (A_N_eps X Y d fn N0 eps0) =
      {x0 :e X | exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N0 eps0)}.
    { reflexivity. }
    claim HexU0: exists U0:set, U0 :e Tx /\ x :e U0 /\ U0 c= (A_N_eps X Y d fn N0 eps0).
    { claim HxInt2: x :e
        {x0 :e X | exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N0 eps0)}.
      { rewrite <- HintDef.
        exact HxInt. }
      exact (SepE2 X (fun x0:set => exists U0:set, U0 :e Tx /\ x0 :e U0 /\ U0 c= (A_N_eps X Y d fn N0 eps0)) x HxInt2). }
    apply HexU0.
    let U0.
    assume HU0: U0 :e Tx /\ x :e U0 /\ U0 c= (A_N_eps X Y d fn N0 eps0).
    claim HU0pair: U0 :e Tx /\ x :e U0.
    { exact (andEL (U0 :e Tx /\ x :e U0)
                   (U0 c= (A_N_eps X Y d fn N0 eps0))
                   HU0). }
    claim HU0subA: U0 c= (A_N_eps X Y d fn N0 eps0).
    { exact (andER (U0 :e Tx /\ x :e U0)
                   (U0 c= (A_N_eps X Y d fn N0 eps0))
                   HU0). }
	    claim HU0Tx: U0 :e Tx.
	    { exact (andEL (U0 :e Tx) (x :e U0) HU0pair). }
	    claim HxU0': x :e U0.
	    { exact (andER (U0 :e Tx) (x :e U0) HU0pair). }
	    (** We may shrink U0 further to a neighborhood where the triangle estimates work. **)
	    claim Hexeps1: exists eps1:set,
	      eps1 :e R /\ Rlt 0 eps1 /\
	      Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0.
	    { exact (exists_fourfold_small_eps eps0 Heps0R Heps0Pos). }
	    apply Hexeps1.
	    let eps1. assume Heps1.
	    claim Heps1core: eps1 :e R /\ Rlt 0 eps1.
	    { exact (andEL (eps1 :e R /\ Rlt 0 eps1)
	                   (Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0)
	                   Heps1). }
	    claim Heps1R: eps1 :e R.
	    { exact (andEL (eps1 :e R) (Rlt 0 eps1) Heps1core). }
	    claim Heps1Pos: Rlt 0 eps1.
	    { exact (andER (eps1 :e R) (Rlt 0 eps1) Heps1core). }
	    claim H4lt: Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0.
	    { exact (andER (eps1 :e R /\ Rlt 0 eps1)
	                   (Rlt (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)) eps0)
	                   Heps1). }
	    (** Find a rationalized radius epsS = inv_nat(ordsucc n1) below eps1, so x is in U_eps epsS by construction of C. **)
	    claim Hexn1: exists n1:set, n1 :e omega /\ Rlt (inv_nat (ordsucc n1)) eps1.
	    { exact (exists_inv_nat_ordsucc_lt eps1 Heps1R Heps1Pos). }
	    apply Hexn1.
	    let n1. assume Hn1pair.
	    claim Hn1O: n1 :e omega.
	    { exact (andEL (n1 :e omega) (Rlt (inv_nat (ordsucc n1)) eps1) Hn1pair). }
	    claim Hinv1Lt: Rlt (inv_nat (ordsucc n1)) eps1.
	    { exact (andER (n1 :e omega) (Rlt (inv_nat (ordsucc n1)) eps1) Hn1pair). }
	    set epsS := inv_nat (ordsucc n1).
	    claim HepsSR: epsS :e R.
	    { exact (inv_nat_real (ordsucc n1) (omega_ordsucc n1 Hn1O)). }
	    claim HepsSle: Rle epsS eps1.
	    { exact (Rlt_implies_Rle epsS eps1 Hinv1Lt). }
	    claim HUfamIn: (U_eps X Tx Y d fn epsS) :e Ufam.
	    { exact (ReplI omega (fun n2:set => U_eps X Tx Y d fn (inv_nat (ordsucc n2))) n1 Hn1O). }
	    claim HxInUepsS: x :e U_eps X Tx Y d fn epsS.
	    { exact (HxAll (U_eps X Tx Y d fn epsS) HUfamIn). }
	    claim HUmono: U_eps X Tx Y d fn epsS c= U_eps X Tx Y d fn eps1.
	    { exact (U_eps_monotone X Tx Y d fn epsS eps1 HTx HepsSR Heps1R HepsSle). }
	    claim HxInUeps1: x :e U_eps X Tx Y d fn eps1.
	    { exact (HUmono x HxInUepsS). }
	    (** Obtain a neighborhood U1 with x∈U1 ⊆ A_N_eps N1 eps1. **)
	    claim HexU1: exists N1:set, N1 :e omega /\
	      exists U1:set, U1 :e Tx /\ x :e U1 /\ U1 c= A_N_eps X Y d fn N1 eps1.
	    { exact (U_epsE_open_subset_A_N X Tx Y d fn eps1 x HTx HxInUeps1). }
	    apply HexU1.
	    let N1. assume HN1pair.
	    claim HN1O: N1 :e omega.
	    { exact (andEL (N1 :e omega)
	                   (exists U1:set, U1 :e Tx /\ x :e U1 /\ U1 c= A_N_eps X Y d fn N1 eps1)
	                   HN1pair). }
	    claim HexU1b: exists U1:set, U1 :e Tx /\ x :e U1 /\ U1 c= A_N_eps X Y d fn N1 eps1.
	    { exact (andER (N1 :e omega)
	                   (exists U1:set, U1 :e Tx /\ x :e U1 /\ U1 c= A_N_eps X Y d fn N1 eps1)
	                   HN1pair). }
	    apply HexU1b.
	    let U1. assume HU1: U1 :e Tx /\ x :e U1 /\ U1 c= A_N_eps X Y d fn N1 eps1.
	    claim HU1pair: U1 :e Tx /\ x :e U1.
	    { exact (andEL (U1 :e Tx /\ x :e U1)
	                   (U1 c= A_N_eps X Y d fn N1 eps1)
	                   HU1). }
	    claim HU1subA: U1 c= A_N_eps X Y d fn N1 eps1.
	    { exact (andER (U1 :e Tx /\ x :e U1)
	                   (U1 c= A_N_eps X Y d fn N1 eps1)
	                   HU1). }
	    claim HU1Tx: U1 :e Tx.
	    { exact (andEL (U1 :e Tx) (x :e U1) HU1pair). }
	    claim HxU1: x :e U1.
	    { exact (andER (U1 :e Tx) (x :e U1) HU1pair). }
	    (** Define the final neighborhood U = U0 ∩ U1 ∩ preimage(fn_n, ball) for a suitable n. **)
	    set U01 := U0 :/\: U1.
	    claim HU01Tx: U01 :e Tx.
	    { exact (lemma_intersection_two_open X Tx U0 U1 HTx HU0Tx HU1Tx). }
	    claim HxU01: x :e U01.
	    { exact (binintersectI U0 U1 x HxU0' HxU1). }
	    (** Pick an index n that is above N0 and N1 and such that d(fn_n(x),f(x))<eps1. **)
	    claim HexNx: exists Nx:set, Nx :e omega /\
	      forall n:set, n :e omega -> Nx c= n ->
	        Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps1.
	    { exact (Hlim x HxX eps1 Heps1R Heps1Pos). }
	    apply HexNx.
	    let Nx. assume HNxpair.
	    claim HNxO: Nx :e omega.
	    { exact (andEL (Nx :e omega)
	                   (forall n:set, n :e omega -> Nx c= n ->
	                     Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps1)
	                   HNxpair). }
	    claim HNxprop:
	      forall n:set, n :e omega -> Nx c= n ->
	        Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps1.
	    { exact (andER (Nx :e omega)
	                   (forall n:set, n :e omega -> Nx c= n ->
	                     Rlt (apply_fun d (apply_fun (apply_fun fn n) x, apply_fun f x)) eps1)
	                   HNxpair). }
	    set Nmax := (N0 :\/: N1) :\/: Nx.
	    claim HN01O: (N0 :\/: N1) :e omega.
	    { exact (omega_binunion N0 N1 HN0 HN1O). }
	    claim HNmaxO: Nmax :e omega.
	    { exact (omega_binunion (N0 :\/: N1) Nx HN01O HNxO). }
	    set n := ordsucc Nmax.
	    claim HnO: n :e omega.
	    { exact (omega_ordsucc Nmax HNmaxO). }
	    claim HN0n: N0 c= n.
	    { exact (Subq_tra N0 (N0 :\/: N1) n (binunion_Subq_1 N0 N1)
	            (Subq_tra (N0 :\/: N1) Nmax n (binunion_Subq_1 (N0 :\/: N1) Nx) (ordsuccI1 Nmax))). }
	    claim HN1n: N1 c= n.
	    { exact (Subq_tra N1 (N0 :\/: N1) n (binunion_Subq_2 N0 N1)
	            (Subq_tra (N0 :\/: N1) Nmax n (binunion_Subq_1 (N0 :\/: N1) Nx) (ordsuccI1 Nmax))). }
	    claim HNxn: Nx c= n.
	    { exact (Subq_tra Nx Nmax n (binunion_Subq_2 (N0 :\/: N1) Nx) (ordsuccI1 Nmax)). }
	    (** Continuity neighborhood for fn_n at x inside open_ball(f_n(x),eps1). **)
	    set fnn := apply_fun fn n.
	    claim Hncont: continuous_map X Tx Y (metric_topology Y d) fnn.
	    { exact (Hcont n HnO). }
	    claim Hfnn: function_on fnn X Y.
	    { exact (continuous_map_function_on X Tx Y (metric_topology Y d) fnn Hncont). }
	    claim HmY: metric_on Y d.
	    { exact (metric_on_total_imp_metric_on Y d Hd). }
	    claim HfnxY: apply_fun fnn x :e Y.
	    { exact (Hfnn x HxX). }
	    claim Hvball: open_ball Y d (apply_fun fnn x) eps1 :e metric_topology Y d.
	    { exact (open_ball_in_metric_topology Y d (apply_fun fnn x) eps1 HmY HfnxY Heps1Pos). }
	    set U2 := preimage_of X fnn (open_ball Y d (apply_fun fnn x) eps1).
	    claim HU2Tx: U2 :e Tx.
	    { exact (continuous_map_preimage X Tx Y (metric_topology Y d) fnn Hncont
	            (open_ball Y d (apply_fun fnn x) eps1) Hvball). }
	    claim HxU2: x :e U2.
	    { claim HU2def: U2 =
	        {x0 :e X | apply_fun fnn x0 :e open_ball Y d (apply_fun fnn x) eps1}.
	      { reflexivity. }
	      rewrite HU2def.
	      exact (SepI X
	            (fun x0:set => apply_fun fnn x0 :e open_ball Y d (apply_fun fnn x) eps1)
	            x
	            HxX
	            (center_in_open_ball Y d (apply_fun fnn x) eps1 HmY HfnxY Heps1Pos)). }
	    set U := U01 :/\: U2.
	    claim HUinTx: U :e Tx.
	    { exact (lemma_intersection_two_open X Tx U01 U2 HTx HU01Tx HU2Tx). }
	    claim HxU: x :e U.
	    { exact (binintersectI U01 U2 x HxU01 HxU2). }
	    witness U.
	    apply and3I.
	    - exact HUinTx.
	    - exact HxU.
	    - (** main continuity estimate on U **)
	      prove forall u:set, u :e U -> apply_fun f u :e V.
	      let u. assume HuU: u :e U.
	      claim HuU01: u :e U01.
	      { exact (binintersectE1 U01 U2 u HuU). }
	      claim HuU2: u :e U2.
	      { exact (binintersectE2 U01 U2 u HuU). }
	      claim HuU0: u :e U0.
	      { exact (binintersectE1 U0 U1 u HuU01). }
	      claim HuU1: u :e U1.
	      { exact (binintersectE2 U0 U1 u HuU01). }
	      claim HuX: u :e X.
	      { exact (topology_elem_subset X Tx U0 HTx HU0Tx u HuU0). }
	      claim HfuY: apply_fun f u :e Y.
	      { exact (Hf u HuX). }
	      claim HballGoal: apply_fun f u :e open_ball Y d (apply_fun f x) eps0.
	      { apply (open_ballI Y d (apply_fun f x) eps0 (apply_fun f u) HfuY).
	        (** basic facts from membership u :e U = U01 :/\: U2 **)
	        claim HfnnuY: apply_fun fnn u :e Y.
	        { exact (Hfnn u HuX). }
	        claim HU2def2: U2 =
	          {x0 :e X | apply_fun fnn x0 :e open_ball Y d (apply_fun fnn x) eps1}.
	        { reflexivity. }
	        claim HuBalln: apply_fun fnn u :e open_ball Y d (apply_fun fnn x) eps1.
	        { claim HuU2': u :e {x0 :e X | apply_fun fnn x0 :e open_ball Y d (apply_fun fnn x) eps1}.
	          { rewrite <- HU2def2.
	            exact HuU2. }
	          exact (SepE2 X
	            (fun x0:set => apply_fun fnn x0 :e open_ball Y d (apply_fun fnn x) eps1)
	            u
	            HuU2'). }
		        claim Hdfnn: Rlt (apply_fun d (apply_fun fnn x, apply_fun fnn u)) eps1.
		        { exact (open_ballE2 Y d (apply_fun fnn x) eps1 (apply_fun fnn u) HuBalln). }
		        claim HfxY: apply_fun f x :e Y.
		        { exact (Hf x HxX). }
		        claim Hdfnfx: Rlt (apply_fun d (apply_fun fnn x, apply_fun f x)) eps1.
		        { exact (HNxprop n HnO HNxn). }
		        claim Hsym_fnn_fx:
		          apply_fun d (apply_fun fnn x, apply_fun f x) =
		          apply_fun d (apply_fun f x, apply_fun fnn x).
		        { exact (metric_on_symmetric Y d (apply_fun fnn x) (apply_fun f x) HmY HfnxY HfxY). }
		        claim Hdfxfn: Rlt (apply_fun d (apply_fun f x, apply_fun fnn x)) eps1.
		        { rewrite <- Hsym_fnn_fx.
		          exact Hdfnfx. }
		        claim HuA1: u :e A_N_eps X Y d fn N1 eps1.
		        { exact (HU1subA u HuU1). }
		        claim Htailu:
		          forall n0:set, n0 :e omega -> N1 c= n0 ->
		            forall m0:set, m0 :e omega -> N1 c= m0 ->
		              Rle (apply_fun d (apply_fun (apply_fun fn n0) u, apply_fun (apply_fun fn m0) u)) eps1.
		        { exact (SepE2 X
		                  (fun x0:set =>
		                    forall n0:set, n0 :e omega -> N1 c= n0 ->
		                      forall m0:set, m0 :e omega -> N1 c= m0 ->
		                        Rle (apply_fun d (apply_fun (apply_fun fn n0) x0, apply_fun (apply_fun fn m0) x0)) eps1)
		                  u
		                  HuA1). }
		        (** pointwise convergence at u gives some m with d(f_m(u),f(u)) < eps1 **)
		        claim HexNu: exists Nu:set, Nu :e omega /\
		          forall k:set, k :e omega -> Nu c= k ->
		            Rlt (apply_fun d (apply_fun (apply_fun fn k) u, apply_fun f u)) eps1.
		        { exact (Hlim u HuX eps1 Heps1R Heps1Pos). }
		        apply HexNu.
		        let Nu. assume HNuPair.
		        claim HNuO: Nu :e omega.
		        { exact (andEL (Nu :e omega)
		                       (forall k:set, k :e omega -> Nu c= k ->
		                         Rlt (apply_fun d (apply_fun (apply_fun fn k) u, apply_fun f u)) eps1)
		                       HNuPair). }
		        claim HNuProp:
		          forall k:set, k :e omega -> Nu c= k ->
		            Rlt (apply_fun d (apply_fun (apply_fun fn k) u, apply_fun f u)) eps1.
		        { exact (andER (Nu :e omega)
		                       (forall k:set, k :e omega -> Nu c= k ->
		                         Rlt (apply_fun d (apply_fun (apply_fun fn k) u, apply_fun f u)) eps1)
		                       HNuPair). }
		        set Mmax2 := n :\/: Nu.
		        claim HMmax2O: Mmax2 :e omega.
		        { exact (omega_binunion n Nu HnO HNuO). }
		        set m := ordsucc Mmax2.
		        claim HmO: m :e omega.
		        { exact (omega_ordsucc Mmax2 HMmax2O). }
		        claim HnSubm: n c= m.
		        { exact (Subq_tra n Mmax2 m (binunion_Subq_1 n Nu) (ordsuccI1 Mmax2)). }
		        claim HNuSubm: Nu c= m.
		        { exact (Subq_tra Nu Mmax2 m (binunion_Subq_2 n Nu) (ordsuccI1 Mmax2)). }
		        claim HN1m: N1 c= m.
		        { exact (Subq_tra N1 n m HN1n HnSubm). }
		        set fnm := apply_fun fn m.
		        claim Hmcont: continuous_map X Tx Y (metric_topology Y d) fnm.
		        { exact (Hcont m HmO). }
		        claim Hfnm: function_on fnm X Y.
		        { exact (continuous_map_function_on X Tx Y (metric_topology Y d) fnm Hmcont). }
		        claim HfmuY: apply_fun fnm u :e Y.
		        { exact (Hfnm u HuX). }
		        claim Hd_fmu_fu: Rlt (apply_fun d (apply_fun fnm u, apply_fun f u)) eps1.
		        { exact (HNuProp m HmO HNuSubm). }
		        claim Hd_fmu_fu_le: Rle (apply_fun d (apply_fun fnm u, apply_fun f u)) eps1.
		        { exact (Rlt_implies_Rle (apply_fun d (apply_fun fnm u, apply_fun f u)) eps1 Hd_fmu_fu). }
		        claim Hd_fnu_fmu_le: Rle (apply_fun d (apply_fun fnn u, apply_fun fnm u)) eps1.
		        { exact (Htailu n HnO HN1n m HmO HN1m). }
		        claim Htri_n_u: Rle (apply_fun d (apply_fun fnn u, apply_fun f u))
		                           (add_SNo (apply_fun d (apply_fun fnn u, apply_fun fnm u))
		                                    (apply_fun d (apply_fun fnm u, apply_fun f u))).
		        { exact (metric_triangle_Rle Y d (apply_fun fnn u) (apply_fun fnm u) (apply_fun f u)
		                                     HmY HfnnuY HfmuY HfuY). }
		        (** combine bounds to get d(fn_n(u),f(u)) <= eps1 + eps1 **)
		        claim Hsum_le: Rle (add_SNo (apply_fun d (apply_fun fnn u, apply_fun fnm u))
		                                    (apply_fun d (apply_fun fnm u, apply_fun f u)))
		                           (add_SNo eps1 eps1).
		        { set d1 := apply_fun d (apply_fun fnn u, apply_fun fnm u).
		          set d2 := apply_fun d (apply_fun fnm u, apply_fun f u).
		          claim Hd1le: Rle d1 eps1.
		          { exact Hd_fnu_fmu_le. }
		          claim Hd2le: Rle d2 eps1.
		          { exact Hd_fmu_fu_le. }
		          claim Hd1R: d1 :e R.
		          { exact (RleE_left d1 eps1 Hd1le). }
		          claim Hd2R: d2 :e R.
		          { exact (RleE_left d2 eps1 Hd2le). }
		          claim Hd1S: SNo d1.
		          { exact (real_SNo d1 Hd1R). }
		          claim Hd2S: SNo d2.
		          { exact (real_SNo d2 Hd2R). }
		          claim Heps1S: SNo eps1.
		          { exact (real_SNo eps1 Heps1R). }
		          claim Hcomm12: add_SNo d1 d2 = add_SNo d2 d1.
		          { exact (add_SNo_com d1 d2 Hd1S Hd2S). }
		          rewrite Hcomm12.
		          claim HstepA: Rle (add_SNo d2 d1) (add_SNo d2 eps1).
		          { exact (Rle_add_SNo_2 d2 d1 eps1 Hd2R Hd1R Heps1R Hd1le). }
		          claim Hcomm2: add_SNo d2 eps1 = add_SNo eps1 d2.
		          { exact (add_SNo_com d2 eps1 Hd2S Heps1S). }
		          claim HstepA': Rle (add_SNo d2 d1) (add_SNo eps1 d2).
		          { rewrite <- Hcomm2.
		            exact HstepA. }
		          claim HstepB: Rle (add_SNo eps1 d2) (add_SNo eps1 eps1).
		          { exact (Rle_add_SNo_2 eps1 d2 eps1 Heps1R Hd2R Heps1R Hd2le). }
		          exact (Rle_tra (add_SNo d2 d1) (add_SNo eps1 d2) (add_SNo eps1 eps1) HstepA' HstepB). }
			        claim Hd_fnu_fu_le2: Rle (apply_fun d (apply_fun fnn u, apply_fun f u)) (add_SNo eps1 eps1).
			        { exact (Rle_tra
			                  (apply_fun d (apply_fun fnn u, apply_fun f u))
			                  (add_SNo (apply_fun d (apply_fun fnn u, apply_fun fnm u))
			                           (apply_fun d (apply_fun fnm u, apply_fun f u)))
			                  (add_SNo eps1 eps1)
			                  Htri_n_u
			                  Hsum_le). }
			        (** final combination to show d(f(x),f(u)) < eps0 **)
			        set a := apply_fun d (apply_fun f x, apply_fun fnn x).
			        set b := apply_fun d (apply_fun fnn x, apply_fun fnn u).
			        set c := apply_fun d (apply_fun fnn u, apply_fun f u).
			        claim Ha_le: Rle a eps1.
			        { exact (Rlt_implies_Rle a eps1 Hdfxfn). }
			        claim Hb_le: Rle b eps1.
			        { exact (Rlt_implies_Rle b eps1 Hdfnn). }
			        claim Hc_le: Rle c (add_SNo eps1 eps1).
			        { exact Hd_fnu_fu_le2. }
			        set y := apply_fun d (apply_fun fnn x, apply_fun f u).
			        claim Htri_y: Rle y (add_SNo b c).
			        { exact (metric_triangle_Rle Y d (apply_fun fnn x) (apply_fun fnn u) (apply_fun f u)
			                                 HmY HfnxY HfnnuY HfuY). }
			        claim Htri_x: Rle (apply_fun d (apply_fun f x, apply_fun f u)) (add_SNo a y).
			        { exact (metric_triangle_Rle Y d (apply_fun f x) (apply_fun fnn x) (apply_fun f u)
			                                 HmY HfxY HfnxY HfuY). }
			        claim HaR: a :e R.
			        { exact (RleE_left a eps1 Ha_le). }
			        claim HbR: b :e R.
			        { exact (RleE_left b eps1 Hb_le). }
			        claim HcR: c :e R.
			        { exact (RleE_left c (add_SNo eps1 eps1) Hc_le). }
			        claim HyR: y :e R.
			        { exact (RleE_left y (add_SNo b c) Htri_y). }
			        claim HbcR: add_SNo b c :e R.
			        { exact (RleE_right y (add_SNo b c) Htri_y). }
			        claim Hstep_xy: Rle (add_SNo a y) (add_SNo a (add_SNo b c)).
			        { exact (Rle_add_SNo_2 a y (add_SNo b c) HaR HyR HbcR Htri_y). }
			        claim Hd_le_abc: Rle (apply_fun d (apply_fun f x, apply_fun f u)) (add_SNo a (add_SNo b c)).
			        { exact (Rle_tra
			                  (apply_fun d (apply_fun f x, apply_fun f u))
			                  (add_SNo a y)
			                  (add_SNo a (add_SNo b c))
			                  Htri_x
			                  Hstep_xy). }
			        claim HbS: SNo b.
			        { exact (real_SNo b HbR). }
			        claim HcS: SNo c.
			        { exact (real_SNo c HcR). }
			        claim Heps1S: SNo eps1.
			        { exact (real_SNo eps1 Heps1R). }
			        claim Hcomm_bc: add_SNo b c = add_SNo c b.
			        { exact (add_SNo_com b c HbS HcS). }
			        set t := add_SNo eps1 (add_SNo eps1 eps1).
			        claim HtR: t :e R.
			        { exact (real_add_SNo eps1 Heps1R (add_SNo eps1 eps1) (real_add_SNo eps1 Heps1R eps1 Heps1R)). }
			        claim Hbc_le_t: Rle (add_SNo b c) t.
			        { rewrite Hcomm_bc.
			          claim Hstep1: Rle (add_SNo c b) (add_SNo c eps1).
			          { exact (Rle_add_SNo_2 c b eps1 HcR HbR Heps1R Hb_le). }
			          claim Hcomm_c: add_SNo c eps1 = add_SNo eps1 c.
			          { exact (add_SNo_com c eps1 HcS Heps1S). }
			          claim Hstep1': Rle (add_SNo c b) (add_SNo eps1 c).
			          { rewrite <- Hcomm_c.
			            exact Hstep1. }
			          claim HccR: add_SNo eps1 eps1 :e R.
			          { exact (real_add_SNo eps1 Heps1R eps1 Heps1R). }
			          claim Hstep2: Rle (add_SNo eps1 c) t.
			          { exact (Rle_add_SNo_2 eps1 c (add_SNo eps1 eps1) Heps1R HcR HccR Hc_le). }
			          exact (Rle_tra (add_SNo c b) (add_SNo eps1 c) t Hstep1' Hstep2). }
			        claim Habct: Rle (add_SNo a (add_SNo b c)) (add_SNo a t).
			        { exact (Rle_add_SNo_2 a (add_SNo b c) t HaR HbcR HtR Hbc_le_t). }
			        claim HaS: SNo a.
			        { exact (real_SNo a HaR). }
			        claim HtS: SNo t.
			        { exact (real_SNo t HtR). }
			        claim Hcomm_at: add_SNo a t = add_SNo t a.
			        { exact (add_SNo_com a t HaS HtS). }
			        claim HstepA: Rle (add_SNo t a) (add_SNo t eps1).
			        { exact (Rle_add_SNo_2 t a eps1 HtR HaR Heps1R Ha_le). }
			        claim Hcomm_te: add_SNo t eps1 = add_SNo eps1 t.
			        { exact (add_SNo_com t eps1 HtS Heps1S). }
			        claim Hat_le: Rle (add_SNo a t) (add_SNo eps1 t).
			        { rewrite Hcomm_at.
			          rewrite <- Hcomm_te.
			          exact HstepA. }
			        claim Hd_le_et: Rle (apply_fun d (apply_fun f x, apply_fun f u)) (add_SNo eps1 t).
			        { exact (Rle_tra
			                  (apply_fun d (apply_fun f x, apply_fun f u))
			                  (add_SNo a (add_SNo b c))
			                  (add_SNo eps1 t)
			                  Hd_le_abc
			                  (Rle_tra (add_SNo a (add_SNo b c)) (add_SNo a t) (add_SNo eps1 t) Habct Hat_le)). }
			        claim Heps11R: add_SNo eps1 eps1 :e R.
			        { exact (real_add_SNo eps1 Heps1R eps1 Heps1R). }
			        claim Heps11S: SNo (add_SNo eps1 eps1).
			        { exact (real_SNo (add_SNo eps1 eps1) Heps11R). }
			        claim Hassoc: add_SNo eps1 t = add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1).
			        { rewrite (add_SNo_assoc eps1 eps1 (add_SNo eps1 eps1) Heps1S Heps1S Heps11S).
			          reflexivity. }
			        claim Hd_le_s4: Rle (apply_fun d (apply_fun f x, apply_fun f u))
			                             (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1)).
			        { rewrite <- Hassoc.
			          exact Hd_le_et. }
			        exact (Rle_Rlt_tra
			          (apply_fun d (apply_fun f x, apply_fun f u))
			          (add_SNo (add_SNo eps1 eps1) (add_SNo eps1 eps1))
			          eps0
			          Hd_le_s4
			          H4lt). }
	      apply HballSubV.
	      exact HballGoal.
}
claim HContSubX:
  {x :e X | continuous_at_map X Tx Y (metric_topology Y d) f x} c= X.
{ let x. assume Hx: x :e {x0 :e X | continuous_at_map X Tx Y (metric_topology Y d) f x0}.
  exact (SepE1 X (fun x0:set => continuous_at_map X Tx Y (metric_topology Y d) f x0) x Hx). }
exact (dense_in_superset (intersection_over_family X Ufam)
        {x :e X | continuous_at_map X Tx Y (metric_topology Y d) f x}
        X Tx
        HTx
        HCsubCont
        HContSubX
        HdenseC).
Qed.

(** from §49 Definition: differentiability and nowhere-differentiable function **) 
(** LATEX VERSION: A function is differentiable at x if the difference quotient (f(x+h)-f(x))/h tends to a limit as h→0 (with x+h in the domain); nowhere differentiable means differentiable at no point. **)
Definition differentiable_at : set -> set -> prop := fun f x =>
  function_on f unit_interval R /\ x :e unit_interval /\
  exists L:set, L :e R /\
    forall eps:set, eps :e R -> Rlt 0 eps ->
      exists delta:set, delta :e R /\ Rlt 0 delta /\
        forall h:set, h :e R ->
          ~(h = 0) ->
          Rlt 0 (Abs h) ->
          Rlt (Abs h) delta ->
          (add_SNo x h) :e unit_interval ->
          Rlt (Abs (add_SNo
                      (div_SNo (add_SNo (apply_fun f (add_SNo x h)) (minus_SNo (apply_fun f x))) h)
                      (minus_SNo L))) eps.
(** from §49 Definition: nowhere differentiable function **)
(** LATEX VERSION: A function is nowhere differentiable if it is differentiable at no point of its domain. **)
Definition nowhere_differentiable : set -> prop := fun f =>
  function_on f unit_interval R /\ forall x:set, x :e unit_interval -> ~ differentiable_at f x.

(** from §49 Definition: the function space C(I,R) and the sets U_n **)
(** LATEX VERSION: Let C be the space of continuous maps f:I→R. For n≥2, define U_n as the set of f such that for some 0<h≤1/n one has Δ_h f > n. **)
(** note: the pointwise difference-quotient predicate is formalized, but deeper analytic facts are still handled via later axioms/theorems **)
Definition I_topology : set := unit_interval_topology.
Theorem I_topology_on : topology_on unit_interval I_topology.
prove topology_on unit_interval I_topology.
exact unit_interval_topology_on.
Qed.
(** from §49 Definition: continuous functions h:[0,1]→R **)
(** LATEX VERSION: Let h:[0,1]→R be a continuous function. **)
Definition continuous_real_on_I : set -> prop := fun f =>
  continuous_map unit_interval I_topology R R_standard_topology f.
(** from §49 Definition: C(I,R) as continuous functions on I=[0,1] **)
(** LATEX VERSION: Let C(I,R) denote the space of continuous maps f:I→R. **)
Definition C_I_R : set := {f :e function_space unit_interval R | continuous_real_on_I f}.

(** from §49 Theorem 49.1: approximation by nowhere-differentiable functions **)
(** LATEX VERSION: Given continuous h and epsilon>0, there exists continuous g with |h(x)-g(x)|<epsilon for all x, such that g is nowhere differentiable. **)
Theorem theorem_49_1_nowhere_differentiable_approx : forall h eps:set,
  continuous_map unit_interval I_topology R R_standard_topology h ->
  eps :e R ->
  Rlt 0 eps ->
  exists g:set,
    continuous_map unit_interval I_topology R R_standard_topology g /\
    nowhere_differentiable g /\
    forall x:set, x :e unit_interval ->
      Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g x)))) eps.
admit. (** FAIL **)
Qed.

(** from §49 Definition: forward difference quotient |(f(x+h)-f(x))/h| **)
(** LATEX VERSION: Consider the difference quotient (f(x+h)-f(x))/h. **)
Definition diffquot_forward_abs : set -> set -> set -> set := fun f x h =>
  Abs (div_SNo (add_SNo (apply_fun f (add_SNo x h)) (minus_SNo (apply_fun f x))) h).
(** from §49 Definition: backward difference quotient |(f(x)-f(x-h))/h| **)
(** LATEX VERSION: Consider the difference quotient (f(x)-f(x-h))/h. **)
Definition diffquot_backward_abs : set -> set -> set -> set := fun f x h =>
  Abs (div_SNo (add_SNo (apply_fun f (add_SNo x (minus_SNo h))) (minus_SNo (apply_fun f x))) (minus_SNo h)).

(** from §49 Definition: predicate Δ_h f > n using forward/backward difference quotients **)
(** LATEX VERSION: Define Δ_h f > n in terms of a large difference quotient for some 0<h≤1/n. **)
Definition Delta_gt : set -> set -> set -> set -> prop := fun f x h n =>
  (add_SNo x h :e unit_interval /\ Rlt n (diffquot_forward_abs f x h))
  \/
  (add_SNo x (minus_SNo h) :e unit_interval /\ Rlt n (diffquot_backward_abs f x h)).

(** from §49 Definition: the open sets U_n in C(I,R) (Baire category argument) **)
(** LATEX VERSION: For n≥2, define U_n ⊆ C(I,R) using existence of small h with Δ_h f > n. **)
Definition U_n : set -> set := fun n =>
  {f :e C_I_R | n :e omega /\ 2 c= n /\
    exists h:set, h :e R /\ Rlt 0 h /\ Rle h (div_SNo 1 n) /\
      forall x:set, x :e unit_interval -> Delta_gt f x h n}.

(** from §49 Existence: nowhere-differentiable function **) 
(** LATEX VERSION: Existence of a continuous nowhere-differentiable function. **)
Theorem nowhere_differentiable_function_exists :
  exists f:set,
    continuous_map unit_interval I_topology R R_standard_topology f /\
    nowhere_differentiable f.
set h := const_fun unit_interval 0.
claim Hh: continuous_map unit_interval I_topology R R_standard_topology h.
{ exact (const_fun_continuous unit_interval I_topology R R_standard_topology 0
         I_topology_on R_standard_topology_is_topology real_0). }
claim Hex: exists g:set,
  continuous_map unit_interval I_topology R R_standard_topology g /\
  nowhere_differentiable g /\
  forall x:set, x :e unit_interval ->
    Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g x)))) 1.
{ exact (theorem_49_1_nowhere_differentiable_approx h 1 Hh real_1 Rlt_0_1). }
set g := Eps_i (fun g0:set =>
  continuous_map unit_interval I_topology R R_standard_topology g0 /\
  nowhere_differentiable g0 /\
  forall x:set, x :e unit_interval ->
    Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g0 x)))) 1).
claim HgP:
  continuous_map unit_interval I_topology R R_standard_topology g /\
  nowhere_differentiable g /\
  forall x:set, x :e unit_interval ->
    Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g x)))) 1.
{ exact (Eps_i_ex (fun g0:set =>
    continuous_map unit_interval I_topology R R_standard_topology g0 /\
    nowhere_differentiable g0 /\
    forall x:set, x :e unit_interval ->
      Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g0 x)))) 1) Hex). }
claim HgCN: continuous_map unit_interval I_topology R R_standard_topology g /\ nowhere_differentiable g.
{ exact (andEL (continuous_map unit_interval I_topology R R_standard_topology g /\ nowhere_differentiable g)
               (forall x:set, x :e unit_interval ->
                 Rlt (Abs (add_SNo (apply_fun h x) (minus_SNo (apply_fun g x)))) 1)
               HgP). }
witness g.
exact HgCN.
Qed.

(** helper: finite cardinality via equip to an ordinal **) 
(** LATEX VERSION: Cardinality_exact/at_most helper predicates for dimension theory. **)
Definition cardinality_exact : set -> set -> prop := fun S n =>
  ordinal n /\ equip S n.
Definition cardinality_at_most : set -> set -> prop := fun S n =>
  ordinal n /\ exists k:set, ordinal k /\ k c= n /\ equip S k.

(** from §50 Definition: order of a collection of subsets **) 
(** LATEX VERSION: A collection A has order m+1 if some point lies in m+1 elements of A, and no point lies in more than m+1 elements of A. **)
Definition collection_has_order_at_m_plus_one : set -> set -> set -> prop :=
  fun X A m =>
    ordinal m /\
    (exists x:set, x :e X /\
      exists Fam:set, Fam c= A /\ finite Fam /\
        cardinality_exact Fam (ordsucc m) /\
        forall U:set, U :e Fam -> x :e U) /\
    forall x:set, x :e X ->
      cardinality_at_most {U :e A|x :e U} (ordsucc m).

(** from §50 Definition (derived): order at most m+1 **) 
(** LATEX VERSION: A collection A has order at most m+1 if no point lies in more than m+1 elements of A. **)
Definition collection_has_order_at_most_m_plus_one : set -> set -> set -> prop :=
  fun X A m =>
    ordinal m /\
    forall x:set, x :e X ->
      cardinality_at_most {U :e A|x :e U} (ordsucc m).

(** from §50 Definition: covering dimension and finite dimensionality **)
(** LATEX VERSION: For a topological space (X,Tx), we write dim(X) ≤ n if for every open cover A of X\n+   there exists an open cover B refining A that has order at most n+1. **)
(** Helper: refinement of covers (as families of subsets) **)
(** LATEX VERSION: B refines A if every element of B is contained in some element of A. **)
Definition refines_cover : set -> set -> prop := fun B A =>
  forall U:set, U :e B -> exists V:set, V :e A /\ U c= V.

(** helper: refinement is reflexive **)
Theorem refines_cover_ref : forall A:set, refines_cover A A.
let A.
prove refines_cover A A.
let U. assume HU: U :e A.
witness U.
apply andI.
- exact HU.
- exact (Subq_ref U).
Qed.

(** helper: refinement is transitive **)
Theorem refines_cover_tra : forall A B C:set,
  refines_cover C B -> refines_cover B A -> refines_cover C A.
let A B C.
assume HCB: refines_cover C B.
assume HBA: refines_cover B A.
prove refines_cover C A.
let U. assume HU: U :e C.
claim HexV: exists V:set, V :e B /\ U c= V.
{ exact (HCB U HU). }
apply HexV.
let V. assume HVpair.
claim HVB: V :e B.
{ exact (andEL (V :e B) (U c= V) HVpair). }
claim HUV: U c= V.
{ exact (andER (V :e B) (U c= V) HVpair). }
claim HexW: exists W:set, W :e A /\ V c= W.
{ exact (HBA V HVB). }
apply HexW.
let W. assume HWpair.
claim HWA: W :e A.
{ exact (andEL (W :e A) (V c= W) HWpair). }
claim HVW: V c= W.
{ exact (andER (W :e A) (V c= W) HWpair). }
witness W.
apply andI.
- exact HWA.
- exact (Subq_tra U V W HUV HVW).
Qed.

Definition covering_dimension : set -> set -> set -> prop := fun X Tx n =>
  topology_on X Tx /\ n :e omega /\
    forall A:set, open_cover_of X Tx A ->
      exists B:set,
        open_cover_of X Tx B /\
        refines_cover B A /\
        collection_has_order_at_most_m_plus_one X B n.

(** helper: projections from covering_dimension package **)
Theorem covering_dimension_topology_on : forall X Tx n:set,
  covering_dimension X Tx n -> topology_on X Tx.
let X Tx n.
assume Hdim: covering_dimension X Tx n.
apply Hdim.
assume Hcore Hrest.
apply Hcore.
assume HTx Hn.
exact HTx.
Qed.

Theorem covering_dimension_n_in_omega : forall X Tx n:set,
  covering_dimension X Tx n -> n :e omega.
let X Tx n.
assume Hdim: covering_dimension X Tx n.
apply Hdim.
assume Hcore Hrest.
apply Hcore.
assume HTx Hn.
exact Hn.
Qed.
(** LATEX VERSION: X is finite dimensional if dim(X) ≤ m for some m. **)
Definition finite_dimensional_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  exists m:set, m :e omega /\
    forall A:set, open_cover_of X Tx A ->
      exists B:set,
        open_cover_of X Tx B /\
        refines_cover B A /\
        collection_has_order_at_most_m_plus_one X B m.

(** helper: projections from finite_dimensional_space package **)
Theorem finite_dimensional_space_topology_on : forall X Tx:set,
  finite_dimensional_space X Tx -> topology_on X Tx.
let X Tx.
assume Hfd: finite_dimensional_space X Tx.
apply Hfd.
assume HTx Hexm.
exact HTx.
Qed.

Theorem finite_dimensional_space_exists_bound : forall X Tx:set,
  finite_dimensional_space X Tx ->
  exists m:set, m :e omega /\
    forall A:set, open_cover_of X Tx A ->
      exists B:set,
        open_cover_of X Tx B /\
        refines_cover B A /\
        collection_has_order_at_most_m_plus_one X B m.
let X Tx.
assume Hfd: finite_dimensional_space X Tx.
apply Hfd.
assume HTx Hexm.
exact Hexm.
Qed.

(** from §50 Theorem: compact subspace of R^n has dimension at most n **) 
(** LATEX VERSION: Compact subspace of ℝ^n has covering dimension ≤ n. **)
Theorem compact_subspace_Rn_dimension_le : forall N X:set,
  N :e omega ->
  X c= (euclidean_space N) ->
  compact_space X (subspace_topology (euclidean_space N) (euclidean_topology N) X) ->
  covering_dimension X (subspace_topology (euclidean_space N) (euclidean_topology N) X) N.
admit. (** FAIL **)
Qed.

(** from §50 Theorem: compact m-manifold has dimension at most m **) 
(** LATEX VERSION: Compact m-manifold has covering dimension ≤ m. **)
Theorem compact_manifold_dimension_le : forall X Tx m:set,
  m_manifold X Tx m -> compact_space X Tx -> covering_dimension X Tx m.
admit. (** FAIL **)
Qed.

(** from §50 Theorem (Menger-Nöbeling): compact metrizable space of dimension m embeds in R^{2m+1} **) 
(** LATEX VERSION: Menger–Nöbeling embedding theorem (placeholder). **)
Theorem Menger_Nobeling_embedding : forall X Tx m:set,
  compact_space X Tx -> metrizable X Tx -> covering_dimension X Tx m ->
  exists N:set, exists e:set,
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e.
admit. (** FAIL **)
Qed.

(** from §50 Theorem 50.1: dimension of closed subspace bounded by ambient **) 
(** LATEX VERSION: Dimension of a closed subspace does not exceed that of the ambient space. **)
Theorem dimension_closed_subspace_le : forall X Tx Y n:set,
  covering_dimension X Tx n -> closed_in X Tx Y ->
  covering_dimension Y (subspace_topology X Tx Y) n.
admit. (** FAIL **)
Qed.

(** from §50 Theorem 50.2: dimension of union of closed sets is max **)
(** LATEX VERSION: If X = Y ∪ Z where Y,Z are closed in X, then dim(X) ≤ max(dim(Y),dim(Z)) (and in fact equality holds for finite-dimensional spaces). **)
Theorem dimension_union_closed_max : forall X Tx Y Z n:set,
  topology_on X Tx ->
  Y c= X -> Z c= X ->
  closed_in X Tx Y -> closed_in X Tx Z ->
  covering_dimension Y (subspace_topology X Tx Y) n ->
  covering_dimension Z (subspace_topology X Tx Z) n ->
  covering_dimension (Y :\/: Z) (subspace_topology X Tx (Y :\/: Z)) n.
admit. (** FAIL **)
Qed.

(** from §50 Corollary 50.3: finite union of closed finite-dimensional sets **)
(** LATEX VERSION: If X is a finite union of closed subspaces each of dimension ≤ n, then X has dimension ≤ n. **)
Theorem dimension_finite_union_closed_max : forall X Tx Fam n:set,
  topology_on X Tx ->
  finite Fam ->
  (forall Y:set, Y :e Fam -> Y c= X /\ closed_in X Tx Y /\ covering_dimension Y (subspace_topology X Tx Y) n) ->
  covering_dimension (Union Fam) (subspace_topology X Tx (Union Fam)) n.
admit. (** FAIL **)
Qed.

(** from §50 Example 4: compact 1-manifold has dimension 1 **)
(** LATEX VERSION: Every compact 1-manifold X has topological dimension 1. **)
Theorem compact_1_manifold_dimension_1 : forall X Tx:set,
  compact_space X Tx -> m_manifold X Tx (Sing Empty) -> covering_dimension X Tx (Sing Empty).
admit. (**  aby  conj_myprob_67056_1_20251226_171004 compact_manifold_dimension_le b_eltÞf . **)
Qed.

(** from §50 Example 5: compact 2-manifold has dimension at most 2 **)
(** LATEX VERSION: Every compact 2-manifold X has topological dimension at most 2. **)
Definition two : set := Sing (Sing Empty).
Theorem compact_2_manifold_dimension_le_2 : forall X Tx:set,
  compact_space X Tx -> m_manifold X Tx two -> covering_dimension X Tx two.
admit. (**  aby  conj_myprob_67064_1_20251226_171016 compact_manifold_dimension_le . **)
Qed.

(** from §50 Example 6: arcs and linear graphs **)
(** LATEX VERSION: An arc is a space homeomorphic to [0,1]; a linear graph is a finite union of arcs meeting at most at common endpoints. **)
Definition arc : set -> set -> prop := fun X Tx =>
  exists f:set, homeomorphism unit_interval unit_interval_topology X Tx f.

(** Helper: arc is a topological space **)
Theorem arc_is_topological_space : forall X Tx:set,
  arc X Tx -> topology_on X Tx.
let X Tx.
assume Harc.
apply Harc.
let f.
assume Hhom.
claim Hcont: continuous_map unit_interval unit_interval_topology X Tx f.
{ exact (andEL (continuous_map unit_interval unit_interval_topology X Tx f)
               (exists g:set, continuous_map X Tx unit_interval unit_interval_topology g /\
                 (forall x:set, x :e unit_interval -> apply_fun g (apply_fun f x) = x) /\
                 (forall y:set, y :e X -> apply_fun f (apply_fun g y) = y))
               Hhom). }
claim Habc: (topology_on unit_interval unit_interval_topology /\ topology_on X Tx) /\ function_on f unit_interval X.
{ exact (andEL ((topology_on unit_interval unit_interval_topology /\ topology_on X Tx) /\ function_on f unit_interval X)
               (forall V:set, V :e Tx -> preimage_of unit_interval f V :e unit_interval_topology)
               Hcont). }
claim Hab: topology_on unit_interval unit_interval_topology /\ topology_on X Tx.
{ exact (andEL (topology_on unit_interval unit_interval_topology /\ topology_on X Tx)
               (function_on f unit_interval X)
               Habc). }
exact (andER (topology_on unit_interval unit_interval_topology) (topology_on X Tx) Hab).
Qed.

(** from §50 Example 6: end points of an arc **)
(** LATEX VERSION: The end points of an arc A are points p,q such that A-{p} and A-{q} are connected. **)
Definition end_points_of_arc : set -> set -> set -> set -> prop := fun X Tx p q =>
  arc X Tx /\
  p :e X /\ q :e X /\
  p <> q /\
  connected_space (X :\: (Sing p)) (subspace_topology X Tx (X :\: (Sing p))) /\
  connected_space (X :\: (Sing q)) (subspace_topology X Tx (X :\: (Sing q))).

(** from §50 Example 6: finite linear graph **)
(** LATEX VERSION: A finite linear graph G is Hausdorff and is the union of finitely many arcs; any two arcs meet in at most a common end point. **)
Definition linear_graph : set -> set -> prop := fun G Tg =>
  Hausdorff_space G Tg /\
  exists Arcs:set,
    finite Arcs /\
    (forall A:set, A :e Arcs ->
      A c= G /\ arc A (subspace_topology G Tg A)) /\
    G = Union Arcs /\
    (forall A B:set, A :e Arcs -> B :e Arcs -> A <> B ->
      exists p:set, (A :/\: B = Empty \/ A :/\: B = Sing p)).

(** from §50 Example 6: linear graphs have dimension 1 **)
(** LATEX VERSION: A linear graph G has topological dimension 1. **)
Theorem linear_graph_dimension_1 : forall G Tg:set,
  linear_graph G Tg -> covering_dimension G Tg (Sing Empty).
admit. (** FAIL **)
Qed.

(** from §50 Example 7: general position in R^3 (preliminary) **)
(** LATEX VERSION: In R^3, points are in general position if no three are collinear and no four are coplanar. **)
(** helper: coordinate selectors on points in euclidean_space 3 **)
Definition R3_xcoord : set -> set := fun p => p 0.
Definition R3_ycoord : set -> set := fun p => p 1.
Definition R3_zcoord : set -> set := fun p => p 2.

(** helper: differences of coordinates **)
(** from §50 Example 7: coordinate differences in R^3 **)
(** LATEX VERSION: Use differences of coordinates to form determinants testing collinearity and coplanarity. **)
Definition R3_dx : set -> set -> set := fun p q =>
  add_SNo (R3_xcoord q) (minus_SNo (R3_xcoord p)).
(** from §50 Example 7: coordinate differences in R^3 **)
(** LATEX VERSION: Use differences of coordinates to form determinants testing collinearity and coplanarity. **)
Definition R3_dy : set -> set -> set := fun p q =>
  add_SNo (R3_ycoord q) (minus_SNo (R3_ycoord p)).
(** from §50 Example 7: coordinate differences in R^3 **)
(** LATEX VERSION: Use differences of coordinates to form determinants testing collinearity and coplanarity. **)
Definition R3_dz : set -> set -> set := fun p q =>
  add_SNo (R3_zcoord q) (minus_SNo (R3_zcoord p)).

(** helper: 2 by 2 determinant a d minus b c **)
(** from §50 Example 7: determinant criteria for collinearity/coplanarity **)
(** LATEX VERSION: Determinants of coordinate differences vanish when points are collinear or coplanar. **)
Definition det2_SNo : set -> set -> set -> set -> set := fun a b c d =>
  add_SNo (mul_SNo a d) (minus_SNo (mul_SNo b c)).

(** helper: 3 by 3 determinant for rows (a1,a2,a3), (b1,b2,b3), (c1,c2,c3) **)
(** from §50 Example 7: determinant criteria for collinearity/coplanarity **)
(** LATEX VERSION: Determinants of coordinate differences vanish when points are collinear or coplanar. **)
Definition det3_SNo : set -> set -> set -> set -> set -> set -> set -> set -> set -> set :=
  fun a1 a2 a3 b1 b2 b3 c1 c2 c3 =>
    add_SNo
      (mul_SNo a1 (det2_SNo b2 b3 c2 c3))
      (add_SNo
        (minus_SNo (mul_SNo a2 (det2_SNo b1 b3 c1 c3)))
        (mul_SNo a3 (det2_SNo b1 b2 c1 c2))).

(** from §50 Example 7: definition of collinearity in R^3 **)
(** LATEX VERSION: No three of the points are collinear. **)
Definition collinear_in_R3 : set -> set -> set -> prop := fun p q r =>
  p :e (euclidean_space 3) /\ q :e (euclidean_space 3) /\ r :e (euclidean_space 3) /\
  det2_SNo (R3_dx p q) (R3_dy p q) (R3_dx p r) (R3_dy p r) = 0 /\
  det2_SNo (R3_dx p q) (R3_dz p q) (R3_dx p r) (R3_dz p r) = 0 /\
  det2_SNo (R3_dy p q) (R3_dz p q) (R3_dy p r) (R3_dz p r) = 0.

(** from §50 Example 7: definition of coplanarity in R^3 **)
(** LATEX VERSION: No four of the points are coplanar. **)
Definition coplanar_in_R3 : set -> set -> set -> set -> prop := fun p q r s =>
  p :e (euclidean_space 3) /\ q :e (euclidean_space 3) /\ r :e (euclidean_space 3) /\ s :e (euclidean_space 3) /\
  det3_SNo
    (R3_dx p q) (R3_dy p q) (R3_dz p q)
    (R3_dx p r) (R3_dy p r) (R3_dz p r)
    (R3_dx p s) (R3_dy p s) (R3_dz p s) = 0.

(** from §50: geometrically independent (affinely independent) points in R^N **)
(** LATEX VERSION: Points {x₀,...,xₖ} in R^N are geometrically independent if Σaᵢxᵢ=0 and Σaᵢ=0 imply all aᵢ=0. **)
(** stub: actual condition needs vector space operations on R^N; we only record that S lies in some euclidean_space N **)
Definition geometrically_independent : set -> prop := fun S =>
  exists N:set, N :e omega /\ S c= euclidean_space N.

(** from §50: plane determined by geometrically independent points **)
(** LATEX VERSION: The plane P determined by geometrically independent points {x₀,...,xₖ} is the set of all x = Σtᵢxᵢ where Σtᵢ=1. **)
(** stub: needs proper formulation of affine combination in euclidean_space N **)
Definition affine_plane : set -> set := fun S =>
  Eps_i (fun P:set =>
    exists N:set, N :e omega /\ S c= euclidean_space N /\ P c= euclidean_space N).

(** from §50: k-plane in R^N **)
(** LATEX VERSION: A k-plane in R^N is the affine plane determined by k+1 geometrically independent points. **)
Definition k_plane : set -> set -> prop := fun k P =>
  k :e omega /\
  exists S:set,
    geometrically_independent S /\
    finite S /\
    (exists kp1:set, kp1 = k :\/: (Sing k) /\ equip S kp1) /\
    P = affine_plane S.

(** from §50: general position in R^N **)
(** LATEX VERSION: A set A in R^N is in general position if every subset with ≤N+1 points is geometrically independent. **)
Definition general_position_RN : set -> set -> prop := fun N A =>
  N :e omega /\
  A c= euclidean_space N /\
  forall S:set, S c= A ->
    (forall Np1:set, Np1 = N :\/: (Sing N) ->
      (exists f:set -> set, inj S Np1 f) -> geometrically_independent S).

(** from §50 Lemma 50.4: approximation in general position **)
(** LATEX VERSION: Given finite {x₁,...,xₙ} in R^N and δ>0, there exists {y₁,...,yₙ} in general position with |xᵢ-yᵢ|<δ for all i. **)
(** stub: proper ordering and metric conditions need to be formulated **)
Theorem finite_set_approximation_general_position : forall N:set, forall pts:set, forall delta:set,
  N :e omega ->
  finite pts ->
  pts c= euclidean_space N ->
  delta :e R ->
  exists pts':set,
    general_position_RN N pts' /\
    finite pts' /\
    equip pts pts'.
admit. (** FAIL **)
Qed.

(** from §50 Theorem 50.5: Menger-Nöbeling embedding theorem **)
(** LATEX VERSION: Every compact metrizable space X of topological dimension m can be embedded in R^{2m+1}. **)
(** FIXED: Dimension parameter uses N = add_nat (mul_nat two m) (Sing Empty) to represent 2m+1, not m+1. **) 
Theorem Menger_Nobeling_embedding_full : forall X Tx m:set,
  compact_space X Tx ->
  metrizable X Tx ->
  covering_dimension X Tx m ->
  m :e omega ->
  exists N:set, exists e:set,
    N = add_nat (mul_nat two m) (Sing Empty) /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e.
admit. (** FAIL **)
Qed.

(** from §50 Theorem 50.6: compact subspace of R^N has dimension at most N **)
(** LATEX VERSION: Every compact subspace of R^N has topological dimension at most N. **)
Theorem compact_subspace_RN_dimension_le_N : forall X N:set,
  N :e omega ->
  X c= (euclidean_space N) ->
  compact_space X (subspace_topology (euclidean_space N) (euclidean_topology N) X) ->
  covering_dimension X (subspace_topology (euclidean_space N) (euclidean_topology N) X) N.
admit. (**  aby  euclidean_spacẽf conj_myprob_67230_1_20251226_171240 euclidean_topologỹf subspace_topologỹf compact_subspace_Rn_dimension_le prop_ext_2 . **)
Qed.

(** from §50 Corollary 50.7: compact m-manifold has dimension at most m **)
(** LATEX VERSION: Every compact m-manifold has topological dimension at most m. **)
Theorem compact_m_manifold_dimension_le_m : forall X Tx m:set,
  m :e omega ->
  compact_space X Tx ->
  m_manifold X Tx m ->
  covering_dimension X Tx m.
admit. (**  aby  conj_myprob_67240_1_20251226_171305 m_manifoldÞf compact_manifold_dimension_le prop_ext_2 . **)
Qed.

(** from §50 Corollary 50.8: compact m-manifold embeds in R^{2m+1} **)
(** LATEX VERSION: Every compact m-manifold can be embedded in R^{2m+1}. **)
(** FIXED: Same correction as above: N = add_nat (mul_nat two m) (Sing Empty) represents 2m+1. **) 
Theorem compact_m_manifold_embeds_R2mp1 : forall X Tx m:set,
  m :e omega ->
  compact_space X Tx ->
  m_manifold X Tx m ->
  exists N:set, exists e:set,
    N = add_nat (mul_nat two m) (Sing Empty) /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e.
admit. (** FAIL **)
Qed.

(** from §50 Corollary 50.9: compact metrizable embeds in R^N iff finite dimensional **)
(** LATEX VERSION: A compact metrizable space X can be embedded in R^N for some N iff X has finite topological dimension. **)
Theorem compact_metrizable_embeds_iff_finite_dim : forall X Tx:set,
  compact_space X Tx ->
  metrizable X Tx ->
  ((exists N:set, exists e:set,
    N :e omega /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e)
  <->
  finite_dimensional_space X Tx).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises: locally m-euclidean space **)
(** LATEX VERSION: A space X is locally m-euclidean if each point has a neighborhood homeomorphic to an open set of R^m. **)
Definition locally_m_euclidean : set -> set -> set -> prop := fun X Tx m =>
  m :e omega /\
  topology_on X Tx /\
  forall x:set, x :e X ->
    exists U:set, exists V:set, exists f:set,
      open_in X Tx U /\
      x :e U /\
      V c= (euclidean_space m) /\
      open_in (euclidean_space m) (euclidean_topology m) V /\
      homeomorphism U (subspace_topology X Tx U) V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f.

(** from Supplementary Exercises: Locally Euclidean Spaces: locally m-euclidean implies T1 **)
(** LATEX VERSION: Such a space X automatically satisfies the T1 axiom. **)
Theorem euclidean_space_Hausdorff : forall m:set,
  Hausdorff_space (euclidean_space m) (euclidean_topology m).
let m.
prove Hausdorff_space (euclidean_space m) (euclidean_topology m).
(** Obtain Hausdorffness of product_topology_full from §31 Theorem 31.2 (currently admitted). **)
claim HRtop: topology_on R R_standard_topology.
{ exact R_standard_topology_is_topology_local. }
claim Hall:
  (forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y)) /\
  (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi)) /\
  (forall Y:set, Y c= R -> regular_space R R_standard_topology -> regular_space Y (subspace_topology R R_standard_topology Y)) /\
  (forall I Xi:set, regular_spaces_family I Xi -> regular_space (product_space I Xi) (product_topology_full I Xi)).
{ exact (separation_axioms_subspace_product R R_standard_topology HRtop). }
claim H123: ((forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y)) /\
             (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi))) /\
            (forall Y:set, Y c= R -> regular_space R R_standard_topology -> regular_space Y (subspace_topology R R_standard_topology Y)).
{ exact (andEL (((forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y)) /\
                 (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi))) /\
                (forall Y:set, Y c= R -> regular_space R R_standard_topology -> regular_space Y (subspace_topology R R_standard_topology Y)))
               (forall I Xi:set, regular_spaces_family I Xi -> regular_space (product_space I Xi) (product_topology_full I Xi))
               Hall). }
claim H12:
  (forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y)) /\
  (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi)).
{ exact (andEL ((forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y)) /\
                (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi)))
               (forall Y:set, Y c= R -> regular_space R R_standard_topology -> regular_space Y (subspace_topology R R_standard_topology Y))
               H123). }
claim Hprod:
  forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi).
{ exact (andER (forall Y:set, Y c= R -> Hausdorff_space R R_standard_topology -> Hausdorff_space Y (subspace_topology R R_standard_topology Y))
               (forall I Xi:set, Hausdorff_spaces_family I Xi -> Hausdorff_space (product_space I Xi) (product_topology_full I Xi))
               H12). }
claim Hfam: Hausdorff_spaces_family m (const_space_family m R R_standard_topology).
{ let i. assume Hi: i :e m.
  prove Hausdorff_space (product_component (const_space_family m R R_standard_topology) i)
                       (product_component_topology (const_space_family m R R_standard_topology) i).
  rewrite (product_component_def (const_space_family m R R_standard_topology) i).
  rewrite (product_component_topology_def (const_space_family m R R_standard_topology) i).
  rewrite (const_space_family_apply m R R_standard_topology i Hi).
  (** reduce the components of the tuple (R, R_standard_topology) **)
  rewrite (tuple_2_0_eq R R_standard_topology).
  rewrite (tuple_2_1_eq R R_standard_topology).
  exact R_standard_topology_Hausdorff. }
exact (Hprod m (const_space_family m R R_standard_topology) Hfam).
Qed.

(** helper: m-manifold implies locally m-euclidean **)
(** LATEX VERSION: Every m-manifold is locally m-euclidean. **)
Theorem m_manifold_implies_locally_m_euclidean : forall X Tx m:set,
  m_manifold X Tx m -> locally_m_euclidean X Tx m.
let X Tx m.
assume Hman: m_manifold X Tx m.
prove locally_m_euclidean X Tx m.
claim Hparts: ((Hausdorff_space X Tx /\ second_countable_space X Tx) /\ m :e omega) /\
              (forall x:set, x :e X ->
                exists U:set, U :e Tx /\ x :e U /\
                  exists V:set, V :e (euclidean_topology m) /\
                    exists f:set,
                      homeomorphism U (subspace_topology X Tx U)
                                   V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f).
{ exact Hman. }
claim H123: (Hausdorff_space X Tx /\ second_countable_space X Tx) /\ m :e omega.
{ exact (andEL ((Hausdorff_space X Tx /\ second_countable_space X Tx) /\ m :e omega)
               (forall x:set, x :e X ->
                 exists U:set, U :e Tx /\ x :e U /\
                   exists V:set, V :e (euclidean_topology m) /\
                     exists f:set,
                       homeomorphism U (subspace_topology X Tx U)
                                    V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f)
               Hparts). }
claim Hlocal:
  forall x:set, x :e X ->
    exists U:set, U :e Tx /\ x :e U /\
      exists V:set, V :e (euclidean_topology m) /\
        exists f:set,
          homeomorphism U (subspace_topology X Tx U)
                       V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f.
{ exact (andER ((Hausdorff_space X Tx /\ second_countable_space X Tx) /\ m :e omega)
               (forall x:set, x :e X ->
                 exists U:set, U :e Tx /\ x :e U /\
                   exists V:set, V :e (euclidean_topology m) /\
                     exists f:set,
                       homeomorphism U (subspace_topology X Tx U)
                                    V (subspace_topology (euclidean_space m) (euclidean_topology m) V) f)
               Hparts). }
claim H12: Hausdorff_space X Tx /\ second_countable_space X Tx.
{ exact (andEL (Hausdorff_space X Tx /\ second_countable_space X Tx)
               (m :e omega)
               H123). }
claim HHaus: Hausdorff_space X Tx.
{ exact (andEL (Hausdorff_space X Tx) (second_countable_space X Tx) H12). }
claim Hmomega: m :e omega.
{ exact (andER (Hausdorff_space X Tx /\ second_countable_space X Tx)
               (m :e omega)
               H123). }
claim Htop: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HHaus). }
claim HeuTop: topology_on (euclidean_space m) (euclidean_topology m).
{ exact (Hausdorff_space_topology (euclidean_space m) (euclidean_topology m) (euclidean_space_Hausdorff m)). }
prove (m :e omega /\ topology_on X Tx) /\
      (forall x0:set, x0 :e X ->
        exists U0:set, exists V0:set, exists f0:set,
          open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
            open_in (euclidean_space m) (euclidean_topology m) V0 /\
            homeomorphism U0 (subspace_topology X Tx U0)
                         V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0).
apply andI.
- exact (andI (m :e omega) (topology_on X Tx) Hmomega Htop).
- let x0. assume Hx0X: x0 :e X.
  prove exists U0:set, exists V0:set, exists f0:set,
    open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
      open_in (euclidean_space m) (euclidean_topology m) V0 /\
      homeomorphism U0 (subspace_topology X Tx U0)
                   V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  claim Hex: exists U0:set, U0 :e Tx /\ x0 :e U0 /\
      exists V0:set, V0 :e (euclidean_topology m) /\
        exists f0:set,
          homeomorphism U0 (subspace_topology X Tx U0)
                       V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  { exact (Hlocal x0 Hx0X). }
  apply Hex.
  let U0. assume HU0: U0 :e Tx /\ x0 :e U0 /\
      exists V0:set, V0 :e (euclidean_topology m) /\
        exists f0:set,
          homeomorphism U0 (subspace_topology X Tx U0)
                       V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  claim HU0pair: U0 :e Tx /\ x0 :e U0.
  { exact (andEL (U0 :e Tx /\ x0 :e U0)
                 (exists V0:set, V0 :e (euclidean_topology m) /\
                   exists f0:set,
                     homeomorphism U0 (subspace_topology X Tx U0)
                                  V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
                 HU0). }
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (x0 :e U0) HU0pair). }
  claim Hx0U0: x0 :e U0.
  { exact (andER (U0 :e Tx) (x0 :e U0) HU0pair). }
  claim HexV: exists V0:set, V0 :e (euclidean_topology m) /\
              exists f0:set,
                homeomorphism U0 (subspace_topology X Tx U0)
                             V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  { exact (andER (U0 :e Tx /\ x0 :e U0)
                 (exists V0:set, V0 :e (euclidean_topology m) /\
                   exists f0:set,
                     homeomorphism U0 (subspace_topology X Tx U0)
                                  V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
                 HU0). }
  apply HexV.
  let V0. assume HV0: V0 :e (euclidean_topology m) /\
              exists f0:set,
                homeomorphism U0 (subspace_topology X Tx U0)
                             V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  claim HV0open: V0 :e (euclidean_topology m).
  { exact (andEL (V0 :e (euclidean_topology m))
                 (exists f0:set,
                   homeomorphism U0 (subspace_topology X Tx U0)
                                V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
                 HV0). }
  claim Hexf: exists f0:set,
                homeomorphism U0 (subspace_topology X Tx U0)
                             V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  { exact (andER (V0 :e (euclidean_topology m))
                 (exists f0:set,
                   homeomorphism U0 (subspace_topology X Tx U0)
                                V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
                 HV0). }
  apply Hexf.
  let f0. assume Hhomeo:
    homeomorphism U0 (subspace_topology X Tx U0)
                 V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  witness U0. witness V0. witness f0.
  claim HU0open: open_in X Tx U0.
  { exact (open_inI X Tx U0 Htop HU0Tx). }
  claim HV0open_in: open_in (euclidean_space m) (euclidean_topology m) V0.
  { exact (open_inI (euclidean_space m) (euclidean_topology m) V0 HeuTop HV0open). }
  claim HV0sub: V0 c= (euclidean_space m).
  { exact (open_in_subset (euclidean_space m) (euclidean_topology m) V0 HV0open_in). }
  prove open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
        open_in (euclidean_space m) (euclidean_topology m) V0 /\
        homeomorphism U0 (subspace_topology X Tx U0)
                     V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
  apply andI.
  + apply andI.
    * apply andI.
      { apply andI.
        - exact HU0open.
        - exact Hx0U0. }
      { exact HV0sub. }
    * exact HV0open_in.
  + exact Hhomeo.
Qed.

(** helper: Euclidean spaces are T1 **)
(** LATEX VERSION: Euclidean spaces satisfy the T1 axiom (finite sets are closed). **)
Theorem euclidean_space_T1 : forall m:set,
  T1_space (euclidean_space m) (euclidean_topology m).
let m.
prove T1_space (euclidean_space m) (euclidean_topology m).
claim HH: Hausdorff_space (euclidean_space m) (euclidean_topology m).
{ exact (euclidean_space_Hausdorff m). }
claim Htop: topology_on (euclidean_space m) (euclidean_topology m).
{ exact (andEL (topology_on (euclidean_space m) (euclidean_topology m))
               (forall x1 x2:set, x1 :e euclidean_space m -> x2 :e euclidean_space m -> x1 <> x2 ->
                 exists U V:set, U :e euclidean_topology m /\ V :e euclidean_topology m /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
               HH). }
prove topology_on (euclidean_space m) (euclidean_topology m) /\
      forall F:set, F c= euclidean_space m -> finite F -> closed_in (euclidean_space m) (euclidean_topology m) F.
apply andI.
- exact Htop.
- let F. assume HFsub: F c= euclidean_space m. assume HFfin: finite F.
  exact (finite_sets_closed_in_Hausdorff (euclidean_space m) (euclidean_topology m) HH F HFsub HFfin).
Qed.

Theorem locally_m_euclidean_implies_T1 : forall X Tx m:set,
  locally_m_euclidean X Tx m -> T1_space X Tx.
let X Tx m.
assume Hloc: locally_m_euclidean X Tx m.
prove T1_space X Tx.
(** Use lemma_T1_singletons_closed, reducing to showing that each singleton is closed. **)
claim Hloc_parts: (m :e omega /\ topology_on X Tx) /\ (forall x0:set, x0 :e X ->
  exists U0:set, exists V0:set, exists f0:set,
    open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
    open_in (euclidean_space m) (euclidean_topology m) V0 /\
    homeomorphism U0 (subspace_topology X Tx U0) V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0).
{ exact Hloc. }
claim Htop: topology_on X Tx.
{ claim HmTop: m :e omega /\ topology_on X Tx.
  { exact (andEL (m :e omega /\ topology_on X Tx)
                 (forall x0:set, x0 :e X ->
                   exists U0:set, exists V0:set, exists f0:set,
                     open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
                     open_in (euclidean_space m) (euclidean_topology m) V0 /\
                     homeomorphism U0 (subspace_topology X Tx U0) V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
                 Hloc_parts). }
  exact (andER (m :e omega) (topology_on X Tx) HmTop). }
claim Hcharts: forall x0:set, x0 :e X ->
  exists U0:set, exists V0:set, exists f0:set,
    open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
    open_in (euclidean_space m) (euclidean_topology m) V0 /\
    homeomorphism U0 (subspace_topology X Tx U0) V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0.
{ exact (andER (m :e omega /\ topology_on X Tx)
               (forall x0:set, x0 :e X ->
                 exists U0:set, exists V0:set, exists f0:set,
                   open_in X Tx U0 /\ x0 :e U0 /\ V0 c= (euclidean_space m) /\
                   open_in (euclidean_space m) (euclidean_topology m) V0 /\
                   homeomorphism U0 (subspace_topology X Tx U0) V0 (subspace_topology (euclidean_space m) (euclidean_topology m) V0) f0)
               Hloc_parts). }
apply (iffER (T1_space X Tx)
             (forall x0:set, x0 :e X -> closed_in X Tx {x0})
             (lemma_T1_singletons_closed X Tx Htop)).
prove forall x0:set, x0 :e X -> closed_in X Tx {x0}.
let x0. assume Hx0X: x0 :e X.
prove closed_in X Tx {x0}.
(** It is enough to show X\\{x0} is open, and then {x0} = X\\(X\\{x0}). **)
claim HsingSub: {x0} c= X.
{ let y. assume Hy: y :e {x0}.
  claim Hyeq: y = x0.
  { exact (SingE x0 y Hy). }
  rewrite Hyeq. exact Hx0X. }
claim Hsep_x0: forall y:set, y :e X -> y <> x0 -> exists W:set, W :e Tx /\ y :e W /\ x0 /:e W.
{ let y. assume HyX: y :e X. assume Hyneq: y <> x0.
  apply (Hcharts y HyX).
  let U. assume HexVf.
  apply HexVf.
  let V. assume Hexf.
  apply Hexf.
  let f. assume Hprops.
  (** split the chart properties **)
  claim Hleft: (((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m)) /\
               open_in (euclidean_space m) (euclidean_topology m) V).
  { exact (andEL ((((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m)) /\
                 open_in (euclidean_space m) (euclidean_topology m) V))
                (homeomorphism U (subspace_topology X Tx U) V
                  (subspace_topology (euclidean_space m) (euclidean_topology m) V) f)
                Hprops). }
  claim Hhomeo: homeomorphism U (subspace_topology X Tx U) V
    (subspace_topology (euclidean_space m) (euclidean_topology m) V) f.
  { exact (andER ((((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m)) /\
                 open_in (euclidean_space m) (euclidean_topology m) V))
                (homeomorphism U (subspace_topology X Tx U) V
                  (subspace_topology (euclidean_space m) (euclidean_topology m) V) f)
                Hprops). }
  claim Hmid: ((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m)).
  { exact (andEL ((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m))
                 (open_in (euclidean_space m) (euclidean_topology m) V)
                 Hleft). }
  claim HVopen: open_in (euclidean_space m) (euclidean_topology m) V.
  { exact (andER ((open_in X Tx U /\ y :e U) /\ V c= (euclidean_space m))
                 (open_in (euclidean_space m) (euclidean_topology m) V)
                 Hleft). }
  claim Hpair: open_in X Tx U /\ y :e U.
  { exact (andEL (open_in X Tx U /\ y :e U) (V c= (euclidean_space m)) Hmid). }
  claim HVsub: V c= (euclidean_space m).
  { exact (andER (open_in X Tx U /\ y :e U) (V c= (euclidean_space m)) Hmid). }
  claim HUopen: open_in X Tx U.
  { exact (andEL (open_in X Tx U) (y :e U) Hpair). }
  claim HyU: y :e U.
  { exact (andER (open_in X Tx U) (y :e U) Hpair). }
  (** If x0 not in U, take W=U. Otherwise refine inside U via the chart. **)
  apply (xm (x0 :e U)).
  - assume Hx0U: x0 :e U.
    (** Extract that U is open in X and belongs to Tx. **)
    claim HUinTx: U :e Tx.
    { exact (andER (topology_on X Tx) (U :e Tx) HUopen). }
    (** Subspace topology on U is a topology. **)
    claim HUsubX: U c= X.
    { exact (open_in_subset X Tx U HUopen). }
    claim HTU: topology_on U (subspace_topology X Tx U).
    { exact (subspace_topology_is_topology X Tx U Htop HUsubX). }
    (** f is continuous and hence a function on U -> V. **)
    claim Hcontf: continuous_map U (subspace_topology X Tx U) V
      (subspace_topology (euclidean_space m) (euclidean_topology m) V) f.
    { exact (andEL (continuous_map U (subspace_topology X Tx U) V
                    (subspace_topology (euclidean_space m) (euclidean_topology m) V) f)
                   (exists g:set,
                     continuous_map V (subspace_topology (euclidean_space m) (euclidean_topology m) V) U
                       (subspace_topology X Tx U) g /\
                     (forall u:set, u :e U -> apply_fun g (apply_fun f u) = u) /\
                     (forall v:set, v :e V -> apply_fun f (apply_fun g v) = v))
                   Hhomeo). }
    claim Hfunf: function_on f U V.
    { claim Htmp: (topology_on U (subspace_topology X Tx U) /\ topology_on V (subspace_topology (euclidean_space m) (euclidean_topology m) V)) /\ function_on f U V.
      { exact (andEL ((topology_on U (subspace_topology X Tx U) /\ topology_on V (subspace_topology (euclidean_space m) (euclidean_topology m) V)) /\ function_on f U V)
                     (forall V1:set, V1 :e subspace_topology (euclidean_space m) (euclidean_topology m) V ->
                       preimage_of U f V1 :e subspace_topology X Tx U)
                     Hcontf). }
      exact (andER (topology_on U (subspace_topology X Tx U) /\ topology_on V (subspace_topology (euclidean_space m) (euclidean_topology m) V))
                   (function_on f U V)
                   Htmp). }
    claim Hfx0V: apply_fun f x0 :e V.
    { exact (Hfunf x0 Hx0U). }
    claim HfyV: apply_fun f y :e V.
    { exact (Hfunf y HyU). }
    (** V is T1 (as an open subspace of Euclidean space). **)
    claim HT1E: T1_space (euclidean_space m) (euclidean_topology m).
    { exact (euclidean_space_T1 m). }
    claim HT1V: T1_space V (subspace_topology (euclidean_space m) (euclidean_topology m) V).
    { claim HtopE: topology_on (euclidean_space m) (euclidean_topology m).
      { exact (andEL (topology_on (euclidean_space m) (euclidean_topology m))
                     (forall F:set, F c= euclidean_space m -> finite F -> closed_in (euclidean_space m) (euclidean_topology m) F)
                     HT1E). }
      exact (subspace_T1 (euclidean_space m) (euclidean_topology m) V HtopE HVsub HT1E). }
    (** Use V \\ {f(x0)} as an open neighborhood of f(y) when f(y) != f(x0). **)
    claim Hinj: forall u1 u2:set, u1 :e U -> u2 :e U -> apply_fun f u1 = apply_fun f u2 -> u1 = u2.
    { let u1 u2. assume Hu1U: u1 :e U. assume Hu2U: u2 :e U. assume Heq: apply_fun f u1 = apply_fun f u2.
      exact (homeomorphism_injective U (subspace_topology X Tx U) V
               (subspace_topology (euclidean_space m) (euclidean_topology m) V) f
               Hhomeo u1 u2 Hu1U Hu2U Heq). }
	    claim Hneqf: apply_fun f y <> apply_fun f x0.
	    { assume Heqf: apply_fun f y = apply_fun f x0.
	      claim Hyx0: y = x0.
	      { exact (Hinj y x0 HyU Hx0U Heqf). }
	      exact (Hyneq Hyx0). }
    set O := V :\: {apply_fun f x0}.
    claim HOopen: O :e subspace_topology (euclidean_space m) (euclidean_topology m) V.
    { exact (T1_singleton_complement_open V
              (subspace_topology (euclidean_space m) (euclidean_topology m) V)
              (apply_fun f x0)
              HT1V Hfx0V). }
    claim HfyO: apply_fun f y :e O.
    { apply setminusI.
      - exact HfyV.
      - assume Hsing: apply_fun f y :e {apply_fun f x0}.
        claim Heqf: apply_fun f y = apply_fun f x0.
        { exact (SingE (apply_fun f x0) (apply_fun f y) Hsing). }
        exact (Hneqf Heqf). }
    (** Preimage of O is open in the subspace topology on U. **)
    claim Hpreimg_open: preimage_of U f O :e subspace_topology X Tx U.
    { claim Hpreimg_axiom: forall V1:set,
        V1 :e subspace_topology (euclidean_space m) (euclidean_topology m) V ->
        preimage_of U f V1 :e subspace_topology X Tx U.
      { exact (andER ((topology_on U (subspace_topology X Tx U) /\
                       topology_on V (subspace_topology (euclidean_space m) (euclidean_topology m) V)) /\
                      function_on f U V)
                     (forall V1:set, V1 :e subspace_topology (euclidean_space m) (euclidean_topology m) V ->
                       preimage_of U f V1 :e subspace_topology X Tx U)
                     Hcontf). }
      exact (Hpreimg_axiom O HOopen). }
    (** Turn this into an open set in X using open_in_subspace_iff and closure under intersections. **)
    claim Hpreimg_sub: preimage_of U f O c= U.
    { let z. assume Hz: z :e preimage_of U f O.
      exact (SepE1 U (fun u:set => apply_fun f u :e O) z Hz). }
    claim Hpreimg_open_in: open_in U (subspace_topology X Tx U) (preimage_of U f O).
    { prove topology_on U (subspace_topology X Tx U) /\ preimage_of U f O :e subspace_topology X Tx U.
      apply andI.
      - exact HTU.
      - exact Hpreimg_open. }
    (** Use open_in_subspace_iff to obtain a V0∈Tx with preimage = V0∩U. **)
    claim HexV0: exists V0 :e Tx, preimage_of U f O = V0 :/\: U.
    { exact (iffEL (open_in U (subspace_topology X Tx U) (preimage_of U f O))
                   (exists V0 :e Tx, preimage_of U f O = V0 :/\: U)
                   (open_in_subspace_iff X Tx U (preimage_of U f O) Htop HUsubX Hpreimg_sub)
                   Hpreimg_open_in). }
    apply HexV0.
    let V0. assume HV0conj: V0 :e Tx /\ preimage_of U f O = V0 :/\: U.
    claim HV0Tx: V0 :e Tx.
    { exact (andEL (V0 :e Tx) (preimage_of U f O = V0 :/\: U) HV0conj). }
    claim HeqW: preimage_of U f O = V0 :/\: U.
    { exact (andER (V0 :e Tx) (preimage_of U f O = V0 :/\: U) HV0conj). }
    (** V0 ∩ U is open in X and separates y from x0. **)
    witness (V0 :/\: U).
    apply andI.
	    - (** (V0 ∩ U) ∈ Tx and y ∈ (V0 ∩ U) **)
	      apply andI.
	      + (** (V0 ∩ U) ∈ Tx by closure under intersections **)
	        exact (topology_binintersect_closed X Tx V0 U Htop HV0Tx HUinTx).
	      + (** y ∈ (V0 ∩ U) **)
	        rewrite <- HeqW.
	        prove y :e preimage_of U f O.
	        prove y :e {u :e U | apply_fun f u :e O}.
	        apply (SepI U (fun u:set => apply_fun f u :e O) y HyU).
	        exact HfyO.
	    - (** x0 ∉ (V0 ∩ U) **)
	      assume Hx0W: x0 :e (V0 :/\: U).
	      claim Hx0Pre: x0 :e preimage_of U f O.
	      { rewrite HeqW. exact Hx0W. }
	      claim Hfx0O: apply_fun f x0 :e O.
	      { exact (SepE2 U (fun u:set => apply_fun f u :e O) x0 Hx0Pre). }
	      claim HnotSing: apply_fun f x0 /:e {apply_fun f x0}.
	      { exact (setminusE2 V {apply_fun f x0} (apply_fun f x0) Hfx0O). }
	      exact (HnotSing (SingI (apply_fun f x0))).
	  - assume Hx0notU: ~(x0 :e U).
	    witness U.
	    apply andI.
	    - apply andI.
	      + exact (andER (topology_on X Tx) (U :e Tx) HUopen).
	      + exact HyU.
	    - exact Hx0notU.
}
claim Hcomp_open: X :\: {x0} :e Tx.
{ set UFam := {W :e Power X |
    exists y:set, y :e X /\ y <> x0 /\ W :e Tx /\ y :e W /\ x0 /:e W}.
  claim HUFamSub: UFam c= Tx.
  { let W. assume HW: W :e UFam.
    claim HWpred: exists y:set, y :e X /\ y <> x0 /\ W :e Tx /\ y :e W /\ x0 /:e W.
    { exact (SepE2 (Power X)
                   (fun W0:set => exists y:set, y :e X /\ y <> x0 /\ W0 :e Tx /\ y :e W0 /\ x0 /:e W0)
                   W
                   HW). }
    apply HWpred.
    let y. assume Hy_conj: y :e X /\ y <> x0 /\ W :e Tx /\ y :e W /\ x0 /:e W.
    claim H0: (((y :e X /\ y <> x0) /\ W :e Tx) /\ y :e W).
    { exact (andEL ((((y :e X /\ y <> x0) /\ W :e Tx) /\ y :e W)) (x0 /:e W) Hy_conj). }
    claim H1: (y :e X /\ y <> x0) /\ W :e Tx.
    { exact (andEL ((y :e X /\ y <> x0) /\ W :e Tx) (y :e W) H0). }
    exact (andER (y :e X /\ y <> x0) (W :e Tx) H1). }
  claim HUnionOpen: Union UFam :e Tx.
  { exact (topology_union_closed X Tx UFam Htop HUFamSub). }
  claim HUnionEq: Union UFam = X :\: {x0}.
  { apply set_ext.
    - let z. assume Hz: z :e Union UFam.
      prove z :e X :\: {x0}.
      apply (UnionE_impred UFam z Hz (z :e X :\: {x0})).
      let W. assume HzW: z :e W. assume HW: W :e UFam.
      claim HWpow: W :e Power X.
      { exact (SepE1 (Power X)
                     (fun W0:set => exists y:set, y :e X /\ y <> x0 /\ W0 :e Tx /\ y :e W0 /\ x0 /:e W0)
                     W
                     HW). }
      claim HWsubX: W c= X.
      { exact (PowerE X W HWpow). }
      claim HzX: z :e X.
      { exact (HWsubX z HzW). }
      claim HWpred: exists y:set, y :e X /\ y <> x0 /\ W :e Tx /\ y :e W /\ x0 /:e W.
      { exact (SepE2 (Power X)
                     (fun W0:set => exists y:set, y :e X /\ y <> x0 /\ W0 :e Tx /\ y :e W0 /\ x0 /:e W0)
                     W
                     HW). }
      apply HWpred.
      let y. assume Hy_conj: y :e X /\ y <> x0 /\ W :e Tx /\ y :e W /\ x0 /:e W.
      claim Hx0NotW: x0 /:e W.
      { exact (andER ((((y :e X /\ y <> x0) /\ W :e Tx) /\ y :e W)) (x0 /:e W) Hy_conj). }
      claim HznotSing: z /:e {x0}.
      { assume HzSing: z :e {x0}.
        claim Hzeq: z = x0.
        { exact (SingE x0 z HzSing). }
        claim Hx0W: x0 :e W.
        { rewrite <- Hzeq. exact HzW. }
        exact (Hx0NotW Hx0W). }
      exact (setminusI X {x0} z HzX HznotSing).
    - let z. assume Hz: z :e X :\: {x0}.
      prove z :e Union UFam.
      claim HzX: z :e X.
      { exact (setminusE1 X {x0} z Hz). }
      claim HznotSing: z /:e {x0}.
      { exact (setminusE2 X {x0} z Hz). }
      claim Hzneq: z <> x0.
      { assume Hzeq: z = x0.
        claim HzSing: z :e {x0}.
        { rewrite Hzeq. exact (SingI x0). }
        exact (HznotSing HzSing). }
      claim HexW: exists W:set, W :e Tx /\ z :e W /\ x0 /:e W.
      { exact (Hsep_x0 z HzX Hzneq). }
      apply HexW.
      let W. assume HWconj: W :e Tx /\ z :e W /\ x0 /:e W.
      claim HW0: W :e Tx /\ z :e W.
      { exact (andEL (W :e Tx /\ z :e W) (x0 /:e W) HWconj). }
      claim HWTx: W :e Tx.
      { exact (andEL (W :e Tx) (z :e W) HW0). }
      claim HzW: z :e W.
      { exact (andER (W :e Tx) (z :e W) HW0). }
      claim Hx0notW: x0 /:e W.
      { exact (andER (W :e Tx /\ z :e W) (x0 /:e W) HWconj). }
      claim HTsub: Tx c= Power X.
      { exact (topology_subset_axiom X Tx Htop). }
      claim HWpow: W :e Power X.
      { exact (HTsub W HWTx). }
      claim HWUFam: W :e UFam.
      { apply (SepI (Power X)
                    (fun W0:set => exists y:set, y :e X /\ y <> x0 /\ W0 :e Tx /\ y :e W0 /\ x0 /:e W0)
                    W
                    HWpow).
	        witness z.
	        (** show z witnesses the predicate **)
	        apply andI.
	        - (** (((z :e X /\ z <> x0) /\ W :e Tx) /\ z :e W) **)
	          apply andI.
	          + (** (z :e X /\ z <> x0) /\ W :e Tx **)
	            apply andI.
	            * (** z :e X /\ z <> x0 **)
	              apply andI.
	              - exact HzX.
	              - exact Hzneq.
	            * exact HWTx.
	          + exact HzW.
	        - exact Hx0notW.
	      }
      exact (UnionI UFam z W HzW HWUFam).
  }
  rewrite <- HUnionEq.
  exact HUnionOpen. }
prove topology_on X Tx /\ ({x0} c= X /\ exists U :e Tx, {x0} = X :\: U).
apply andI.
- exact Htop.
- apply andI.
  + exact HsingSub.
  + witness (X :\: {x0}).
	    apply andI.
	    * exact Hcomp_open.
	    * rewrite (setminus_setminus_eq X {x0} HsingSub).
	      reflexivity.
Qed.

(** from §50 Exercise 1: discrete space has dimension 0 **)
(** LATEX VERSION: Every discrete space has topological dimension 0. **)
Theorem ex50_1_discrete_dimension_0 : forall X Tx:set,
  Tx = discrete_topology X ->
  topology_on X Tx ->
  covering_dimension X Tx Empty.
let X Tx.
assume HTxeq: Tx = discrete_topology X.
assume HTx: topology_on X Tx.
prove covering_dimension X Tx Empty.

set B := singleton_basis X.

(** covering_dimension unfolds to a left-associated conjunction **)
prove (topology_on X Tx /\ Empty :e omega) /\
  forall A:set, open_cover_of X Tx A ->
    exists B0:set,
      open_cover_of X Tx B0 /\
      refines_cover B0 A /\
      collection_has_order_at_most_m_plus_one X B0 Empty.
apply andI.
- (** topology_on X Tx /\ 0 :e omega **)
  apply andI.
  + exact HTx.
  + exact (nat_p_omega 0 nat_0).
- (** refinement to a singleton cover of order at most 1 **)
  let A.
  assume HA: open_cover_of X Tx A.
  witness B.
  prove open_cover_of X Tx B /\ refines_cover B A /\ collection_has_order_at_most_m_plus_one X B Empty.
  apply andI.
  - (** open_cover_of X Tx B /\ refines_cover B A **)
    apply andI.
    + (** open_cover_of X Tx B **)
      prove open_cover_of X Tx B.
      prove ((topology_on X Tx /\ B c= Power X) /\ X c= Union B) /\
            (forall U:set, U :e B -> U :e Tx).
      (** unpacked: ((topology_on /\ B c= Power X) /\ X c= Union B) /\ members-open **)
      apply andI.
      * (** (topology_on X Tx /\ B c= Power X) /\ X c= Union B **)
        apply andI.
        - (** topology_on X Tx /\ B c= Power X **)
           apply andI.
           - exact HTx.
           - exact (basis_on_sub_Power X B (singleton_basis_is_basis X)).
        - (** X c= Union B **)
           let x.
           assume HxX: x :e X.
           prove x :e Union B.
           claim Hexb: exists b :e B, x :e b.
           { exact (basis_on_cover X B (singleton_basis_is_basis X) x HxX). }
           apply Hexb.
           let b.
           assume Hbpair: b :e B /\ x :e b.
           claim HbB: b :e B.
           { exact (andEL (b :e B) (x :e b) Hbpair). }
           claim Hxb: x :e b.
           { exact (andER (b :e B) (x :e b) Hbpair). }
           exact (UnionI B x b Hxb HbB).
      * (** members-open: forall U:e B, U:e Tx **)
        let U.
        assume HU: U :e B.
        prove U :e Tx.
        (** Tx is discrete, so Tx = Power X and U is in Power X because B c= Power X **)
        claim HU0: U :e Power X.
        { exact ((basis_on_sub_Power X B (singleton_basis_is_basis X)) U HU). }
        rewrite HTxeq.
        exact HU0.
    + (** refines_cover B A **)
      prove refines_cover B A.
      let U.
      assume HU: U :e B.
      (** U is a singleton {u0} for some u0:e X **)
      apply (ReplE_impred X (fun x0:set => {x0}) U HU (exists V:set, V :e A /\ U c= V)).
      let u0.
      assume Hu0X: u0 :e X.
      assume HUeq: U = {u0}.
      (** use cover property of A to pick V with u0:e V **)
      claim Hcov: X c= Union A.
      { exact (open_cover_of_covers X Tx A HA). }
      claim Hu0Union: u0 :e Union A.
      { exact (Hcov u0 Hu0X). }
      apply (UnionE_impred A u0 Hu0Union (exists V:set, V :e A /\ U c= V)).
      let V.
      assume HV: u0 :e V.
      assume HVA: V :e A.
      witness V.
      apply andI.
      * exact HVA.
      * (** U c= V **)
        let y.
        assume HyU: y :e U.
        prove y :e V.
        claim HyU0: y :e {u0}.
        { prove y :e {u0}.
          rewrite <- HUeq.
          exact HyU. }
        claim Hyu0: y = u0.
        { exact (SingE u0 y HyU0). }
        rewrite Hyu0.
        exact HV.
  - (** collection_has_order_at_most_m_plus_one X B 0 **)
    prove collection_has_order_at_most_m_plus_one X B Empty.
    prove ordinal Empty /\
      forall x:set, x :e X -> cardinality_at_most {U :e B|x :e U} (ordsucc Empty).
    (** unpacked: ordinal 0 /\ forall x:e X, cardinality_at_most {...} (ordsucc 0) **)
    apply andI.
    + (** ordinal 0 **)
      exact (nat_p_ordinal 0 nat_0).
    + let x.
      assume HxX: x :e X.
      prove cardinality_at_most {U :e B|x :e U} (ordsucc Empty).
      set Sx := {U :e B|x :e U}.
      claim HSx: Sx = {{x}}.
      { apply set_ext.
        - let U.
          assume HU: U :e Sx.
          prove U :e {{x}}.
          claim HU0: U :e B.
          { exact (SepE1 B (fun U0:set => x :e U0) U HU). }
          claim HxU: x :e U.
          { exact (SepE2 B (fun U0:set => x :e U0) U HU). }
          (** U is some singleton {u0} and x∈U forces u0=x **)
          apply (ReplE_impred X (fun x0:set => {x0}) U HU0 (U :e {{x}})).
          let u0.
          assume Hu0X: u0 :e X.
          assume HUeq: U = {u0}.
          claim Hxu0: x = u0.
          { claim HxU0: x :e {u0}.
            { prove x :e {u0}.
              rewrite <- HUeq.
              exact HxU. }
            exact (SingE u0 x HxU0). }
          rewrite HUeq.
          rewrite <- Hxu0.
          exact (SingI {x}).
        - let U.
          assume HU: U :e {{x}}.
          prove U :e Sx.
          claim HUeq: U = {x}.
          { exact (SingE {x} U HU). }
          rewrite HUeq.
          (** {x} is in B and contains x **)
          apply (SepI B (fun U0:set => x :e U0) {x}).
          + exact (ReplI X (fun x0:set => {x0}) x HxX).
          + exact (SingI x). }
      prove cardinality_at_most Sx (ordsucc 0).
      (** cardinality_at_most S n := ordinal n /\ exists k, ordinal k /\ k c= n /\ equip S k **)
      prove ordinal (ordsucc 0) /\
        exists k:set, ordinal k /\ k c= ordsucc 0 /\ equip Sx k.
      apply andI.
      - exact (ordinal_ordsucc 0 (nat_p_ordinal 0 nat_0)).
      - witness (ordsucc 0).
        prove ordinal (ordsucc 0) /\ (ordsucc 0) c= ordsucc 0 /\ equip Sx (ordsucc 0).
        apply andI.
        + (** ordinal (ordsucc 0) /\ (ordsucc 0) c= ordsucc 0 **)
          apply andI.
          * exact (ordinal_ordsucc 0 (nat_p_ordinal 0 nat_0)).
          * exact (Subq_ref (ordsucc 0)).
        + (** equip Sx (ordsucc 0) **)
          rewrite HSx.
          exact (equip_Sing_1 {x}).
Qed.

(** from §50 Exercise 2: connected T1 space with >1 point has dimension ≥1 **)
(** LATEX VERSION: Any connected T₁ space with more than one point has dimension at least 1. **)
Theorem ex50_2_connected_T1_dimension_ge_1 : forall X Tx:set,
  connected_space X Tx ->
  T1_space X Tx ->
  (exists x y:set, x :e X /\ y :e X /\ x <> y) ->
  covering_dimension X Tx Empty -> False.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 3: topologist's sine curve has dimension 1 **)
(** LATEX VERSION: The topologist's sine curve has topological dimension 1. **)
(** from §50 Exercise 3: the topologist sine curve **)
(** LATEX VERSION: The topologist sine curve is a specific subspace of R2; we name it abstractly here. **)
(** stub: the actual geometric definition is not expanded in this file **)
Definition topologists_sine_curve : set := Eps_i (fun S:set => S c= EuclidPlane).
(** helper: topologist's sine curve lies in EuclidPlane **)
(** LATEX VERSION: By construction, the sine-curve subset is a subset of R^2. **)
Theorem topologists_sine_curve_subset_EuclidPlane : topologists_sine_curve c= EuclidPlane.
prove topologists_sine_curve c= EuclidPlane.
claim Hex: exists S:set, S c= EuclidPlane.
{ witness Empty.
  exact (Subq_Empty EuclidPlane). }
exact (Eps_i_ex (fun S:set => S c= EuclidPlane) Hex).
Qed.
(** from §24 Example 7: topologist's sine curve (subspace topology) **)
(** LATEX VERSION: The topologist's sine curve is the closure of {(x,sin(1/x)) | 0<x<=1} in R^2, i.e. that set together with the vertical interval 0×[-1,1]. **)
Definition topologists_sine_curve_topology : set :=
  subspace_topology EuclidPlane R2_standard_topology topologists_sine_curve.
(** helper: EuclidPlane with standard product topology is a topology **)
(** LATEX VERSION: The product of two topological spaces is a topological space. **)
Theorem EuclidPlane_R2_standard_topology_on : topology_on EuclidPlane R2_standard_topology.
prove topology_on EuclidPlane R2_standard_topology.
exact (product_topology_is_topology R R_standard_topology R R_standard_topology
         R_standard_topology_is_topology R_standard_topology_is_topology).
Qed.
(** helper: subspace topology on the sine curve is a topology **)
(** LATEX VERSION: Any subspace of a topological space is a topological space in the subspace topology. **)
Theorem topologists_sine_curve_topology_on :
  topology_on topologists_sine_curve topologists_sine_curve_topology.
prove topology_on topologists_sine_curve topologists_sine_curve_topology.
exact (subspace_topology_is_topology EuclidPlane R2_standard_topology topologists_sine_curve
         EuclidPlane_R2_standard_topology_on
         topologists_sine_curve_subset_EuclidPlane).
Qed.
Theorem ex50_3_sine_curve_dimension_1 :
  covering_dimension topologists_sine_curve topologists_sine_curve_topology (Sing Empty).
admit. (** FAIL **)
Qed.

(** from §50 Exercise 4: specific points in general position in R³ **)
(** LATEX VERSION: Show that 0, ε₁, ε₂, ε₃, and (1,1,1) are in general position in R³. **)
(** FIXED: Use explicit coordinate functions in the product description of euclidean_space 3. **)

(** helper: 2 is an element of 3 **)
Theorem In_2_3 : 2 :e 3.
prove 2 :e 3.
rewrite <- ordsucc_2_eq_3.
exact (ordsuccI2 2).
Qed.

(** helper: all reals lie in the space-family union for R³ **)
Theorem real_in_space_family_union_R3 : forall y:set,
  y :e R ->
  y :e space_family_union 3 (const_space_family 3 R R_standard_topology).
let y.
assume HyR: y :e R.
prove y :e space_family_union 3 (const_space_family 3 R R_standard_topology).
set Xi := const_space_family 3 R R_standard_topology.
set S := {space_family_set Xi i|i :e 3}.
prove y :e Union S.
claim H2in3: 2 :e 3.
{ exact In_2_3. }
claim HXi2: apply_fun Xi 2 = (R, R_standard_topology).
{ exact (const_space_family_apply 3 R R_standard_topology 2 H2in3). }
claim HSf2: space_family_set Xi 2 = R.
{ prove (apply_fun Xi 2) 0 = R.
  rewrite HXi2.
  exact (tuple_2_0_eq R R_standard_topology). }
 claim Helt: space_family_set Xi 2 :e S.
 { exact (ReplI 3 (fun i:set => space_family_set Xi i) 2 H2in3). }
 claim HySf2: y :e space_family_set Xi 2.
 { rewrite HSf2.
   exact HyR. }
 exact (UnionI S y (space_family_set Xi 2) HySf2 Helt).
Qed.

(** helper: each component set in the constant family is R **)
Theorem space_family_set_const_R3 : forall i:set,
  i :e 3 ->
  space_family_set (const_space_family 3 R R_standard_topology) i = R.
let i.
assume Hi3: i :e 3.
prove space_family_set (const_space_family 3 R R_standard_topology) i = R.
set Xi := const_space_family 3 R R_standard_topology.
claim HXi: apply_fun Xi i = (R, R_standard_topology).
{ exact (const_space_family_apply 3 R R_standard_topology i Hi3). }
prove (apply_fun Xi i) 0 = R.
rewrite HXi.
exact (tuple_2_0_eq R R_standard_topology).
Qed.

(** helper: a coordinate function into R yields a point of euclidean_space 3 **)
Theorem graph3_in_euclidean_space3 : forall g:set->set,
  (forall i:set, g i :e R) ->
  graph 3 g :e euclidean_space 3.
 let g.
 assume HgR: forall i:set, g i :e R.
	 set Xi := const_space_family 3 R R_standard_topology.
	 set U := space_family_union 3 Xi.
	 prove graph 3 g :e {f :e Power (setprod 3 U)|
	                      total_function_on f 3 U /\ functional_graph f /\
	                      (forall i:set, i :e 3 -> apply_fun f i :e space_family_set Xi i)}.
 claim Hsub: graph 3 g c= setprod 3 U.
 { let p. assume Hp: p :e graph 3 g.
   prove p :e setprod 3 U.
   apply (ReplE_impred 3 (fun i:set => (i, g i)) p Hp (p :e setprod 3 U)).
   let i. assume Hi3: i :e 3.
   assume HpEq: p = (i, g i).
   rewrite HpEq.
   claim HgiU: g i :e U.
   { exact (real_in_space_family_union_R3 (g i) (HgR i)). }
   exact (tuple_2_setprod_by_pair_Sigma 3 U i (g i) Hi3 HgiU). }
 claim Hpow: graph 3 g :e Power (setprod 3 U).
 { exact (PowerI (setprod 3 U) (graph 3 g) Hsub). }
	 claim Hfun: function_on (graph 3 g) 3 U.
	 { let i. assume Hi3: i :e 3.
	   prove apply_fun (graph 3 g) i :e U.
   claim Happ: apply_fun (graph 3 g) i = g i.
   { exact (apply_fun_graph 3 g i Hi3). }
   rewrite Happ.
   exact (real_in_space_family_union_R3 (g i) (HgR i)). }
 claim Hcoords: forall i:set, i :e 3 -> apply_fun (graph 3 g) i :e space_family_set Xi i.
 { let i. assume Hi3: i :e 3.
   prove apply_fun (graph 3 g) i :e space_family_set Xi i.
   claim Happ: apply_fun (graph 3 g) i = g i.
   { exact (apply_fun_graph 3 g i Hi3). }
   rewrite Happ.
   claim HSf: space_family_set Xi i = R.
   { exact (space_family_set_const_R3 i Hi3). }
	   rewrite HSf.
	   exact (HgR i). }
	 claim Htot: total_function_on (graph 3 g) 3 U.
	 { claim Htot': forall i:set, i :e 3 -> exists y:set, y :e U /\ (i,y) :e graph 3 g.
	   { let i. assume Hi3: i :e 3.
	     witness (g i).
	     apply andI.
	     - exact (real_in_space_family_union_R3 (g i) (HgR i)).
	     - exact (ReplI 3 (fun i0:set => (i0, g i0)) i Hi3). }
	   exact (andI (function_on (graph 3 g) 3 U)
	               (forall x:set, x :e 3 -> exists y:set, y :e U /\ (x,y) :e graph 3 g)
	               Hfun
	               Htot'). }
	 claim Hgraph: functional_graph (graph 3 g).
	 { exact (functional_graph_graph 3 g). }
	 claim Hprop: total_function_on (graph 3 g) 3 U /\ functional_graph (graph 3 g) /\
	              (forall i:set, i :e 3 -> apply_fun (graph 3 g) i :e space_family_set Xi i).
	 { apply andI.
	   - apply andI.
	     + exact Htot.
	     + exact Hgraph.
	   - exact Hcoords. }
	 exact (SepI (Power (setprod 3 U))
	            (fun f0:set => total_function_on f0 3 U /\ functional_graph f0 /\
	                           (forall i:set, i :e 3 -> apply_fun f0 i :e space_family_set Xi i))
	            (graph 3 g)
	            Hpow
	            Hprop).
Qed.

(** explicit points in R³ as coordinate functions **)
(** from §50 Exercise 4: specific points in general position in R³ **)
(** LATEX VERSION: Show that 0, e1, e2, e3, and (1,1,1) are in general position in R^3. **)
Definition ex50_R3_zero : set := graph 3 (fun _ : set => 0).
Definition ex50_R3_ones : set := graph 3 (fun _ : set => 1).
Definition ex50_R3_e1 : set := graph 3 (fun i:set => if i = 0 then 1 else 0).
Definition ex50_R3_e2 : set := graph 3 (fun i:set => if i = 1 then 1 else 0).
Definition ex50_R3_e3 : set := graph 3 (fun i:set => if i = 2 then 1 else 0).

(** membership facts for these points **)
Theorem ex50_R3_zero_in : ex50_R3_zero :e euclidean_space 3.
prove ex50_R3_zero :e euclidean_space 3.
apply (graph3_in_euclidean_space3 (fun _ : set => 0)).
let i.
exact real_0.
Qed.

Theorem ex50_R3_ones_in : ex50_R3_ones :e euclidean_space 3.
prove ex50_R3_ones :e euclidean_space 3.
apply (graph3_in_euclidean_space3 (fun _ : set => 1)).
let i.
exact real_1.
Qed.

Theorem ex50_R3_e1_in : ex50_R3_e1 :e euclidean_space 3.
prove ex50_R3_e1 :e euclidean_space 3.
claim Hdef: ex50_R3_e1 = graph 3 (fun i:set => if i = 0 then 1 else 0).
{ reflexivity. }
rewrite Hdef.
apply (graph3_in_euclidean_space3 (fun i:set => if i = 0 then 1 else 0)).
let i.
claim Happ: (fun i0:set => if i0 = 0 then 1 else 0) i = (if i = 0 then 1 else 0).
{ reflexivity. }
rewrite Happ.
apply (xm (i = 0)).
- assume Hi0: i = 0.
  claim Hif: (if i = 0 then 1 else 0) = 1.
  { exact (If_i_1 (i = 0) 1 0 Hi0). }
  rewrite Hif.
  exact real_1.
- assume Hni0: ~(i = 0).
  claim Hif: (if i = 0 then 1 else 0) = 0.
  { exact (If_i_0 (i = 0) 1 0 Hni0). }
  rewrite Hif.
  exact real_0.
Qed.

Theorem ex50_R3_e2_in : ex50_R3_e2 :e euclidean_space 3.
prove ex50_R3_e2 :e euclidean_space 3.
claim Hdef: ex50_R3_e2 = graph 3 (fun i:set => if i = 1 then 1 else 0).
{ reflexivity. }
rewrite Hdef.
apply (graph3_in_euclidean_space3 (fun i:set => if i = 1 then 1 else 0)).
let i.
claim Happ: (fun i0:set => if i0 = 1 then 1 else 0) i = (if i = 1 then 1 else 0).
{ reflexivity. }
rewrite Happ.
apply (xm (i = 1)).
- assume Hi1: i = 1.
  claim Hif: (if i = 1 then 1 else 0) = 1.
  { exact (If_i_1 (i = 1) 1 0 Hi1). }
  rewrite Hif.
  exact real_1.
- assume Hni1: ~(i = 1).
  claim Hif: (if i = 1 then 1 else 0) = 0.
  { exact (If_i_0 (i = 1) 1 0 Hni1). }
  rewrite Hif.
  exact real_0.
Qed.

Theorem ex50_R3_e3_in : ex50_R3_e3 :e euclidean_space 3.
prove ex50_R3_e3 :e euclidean_space 3.
claim Hdef: ex50_R3_e3 = graph 3 (fun i:set => if i = 2 then 1 else 0).
{ reflexivity. }
rewrite Hdef.
apply (graph3_in_euclidean_space3 (fun i:set => if i = 2 then 1 else 0)).
let i.
claim Happ: (fun i0:set => if i0 = 2 then 1 else 0) i = (if i = 2 then 1 else 0).
{ reflexivity. }
rewrite Happ.
apply (xm (i = 2)).
- assume Hi2: i = 2.
  claim Hif: (if i = 2 then 1 else 0) = 1.
  { exact (If_i_1 (i = 2) 1 0 Hi2). }
  rewrite Hif.
  exact real_1.
- assume Hni2: ~(i = 2).
  claim Hif: (if i = 2 then 1 else 0) = 0.
  { exact (If_i_0 (i = 2) 1 0 Hni2). }
  rewrite Hif.
  exact real_0.
Qed.
Theorem ex50_4_points_general_position_R3 :
  general_position_RN 3 {ex50_R3_zero, ex50_R3_e1, ex50_R3_e2, ex50_R3_e3, ex50_R3_ones}.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 5: embedding theorem for m=1 maps to linear graph **)
(** LATEX VERSION: For m=1, the map g in the embedding theorem proof maps X onto a linear graph in R³. **)
Theorem ex50_5_embedding_m1_linear_graph : forall X Tx:set,
  covering_dimension X Tx (Sing Empty) ->
  compact_space X Tx ->
  metrizable X Tx ->
  exists g:set,
    (forall x:set, x :e X -> apply_fun g x :e (euclidean_space 3)) /\
    linear_graph (apply_fun g X) R_standard_topology.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 6: locally compact Hausdorff with countable basis embeds in R^{2m+1} **)
(** LATEX VERSION: A locally compact Hausdorff space with countable basis whose compact subspaces have dimension ≤m is homeomorphic to a closed subspace of R^{2m+1}. **)
(** FIXED: Dimension error - should be 2m+1, not m+1. **)
Theorem ex50_6_locally_compact_embeds : forall X Tx m:set,
  m :e omega ->
  locally_compact X Tx ->
  Hausdorff_space X Tx ->
  second_countable_space X Tx ->
  (forall C:set, C c= X -> compact_space C (subspace_topology X Tx C) -> covering_dimension C (subspace_topology X Tx C) m) ->
  exists N:set, exists e:set,
    N = add_nat (mul_nat two m) (Sing Empty) /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e /\
    closed_in (euclidean_space N) (euclidean_topology N) (apply_fun e X).
admit. (** FAIL **)
Qed.

(** from §50 Exercise 7: every m-manifold embeds in R^{2m+1} as closed subspace **)
(** LATEX VERSION: Every m-manifold can be embedded in R^{2m+1} as a closed subspace. **)
(** FIXED: Dimension error - should be 2m+1, not m+1. **)
Theorem ex50_7_manifold_closed_embedding : forall X Tx m:set,
  m :e omega ->
  m_manifold X Tx m ->
  exists N:set, exists e:set,
    N = add_nat (mul_nat two m) (Sing Empty) /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e /\
    closed_in (euclidean_space N) (euclidean_topology N) (apply_fun e X).
admit. (** FAIL **)
Qed.

(** from §50 Exercise 8: sigma-compact Hausdorff with compact subspaces of dimension ≤m has dimension ≤m **)
(** LATEX VERSION: A σ-compact Hausdorff space whose compact subspaces have dimension ≤m has dimension ≤m. **)
(** FIXED: sigma_compact uses X = Union Fam, not a filtered union; sigma-compact means a countable union of compact subspaces. **) 
Definition sigma_compact : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  exists Fam:set,
    countable Fam /\
    (forall C:set, C :e Fam -> C c= X /\ compact_space C (subspace_topology X Tx C)) /\
    X = Union Fam.

Theorem ex50_8_sigma_compact_dimension : forall X Tx m:set,
  m :e omega ->
  sigma_compact X Tx ->
  Hausdorff_space X Tx ->
  (forall C:set, C c= X -> compact_space C (subspace_topology X Tx C) -> covering_dimension C (subspace_topology X Tx C) m) ->
  covering_dimension X Tx m.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 9: every m-manifold has dimension ≤m **)
(** LATEX VERSION: Every m-manifold has topological dimension at most m. **)
Theorem ex50_9_manifold_dimension_le_m : forall X Tx m:set,
  m :e omega ->
  m_manifold X Tx m ->
  covering_dimension X Tx m.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 10: closed subspace of R^N has dimension ≤N **)
(** LATEX VERSION: Every closed subspace of R^N has topological dimension at most N. **)
Theorem ex50_10_closed_subspace_RN_dimension : forall X N:set,
  N :e omega ->
  X c= (euclidean_space N) ->
  closed_in (euclidean_space N) (euclidean_topology N) X ->
  covering_dimension X (subspace_topology (euclidean_space N) (euclidean_topology N) X) N.
admit. (** FAIL **)
Qed.

(** from §50 Exercise 11: embedding in R^N characterization **)
(** LATEX VERSION: A space X can be embedded as a closed subspace of R^N for some N iff X is locally compact Hausdorff with countable basis and finite dimension. **)
Theorem ex50_11_embedding_characterization : forall X Tx:set,
  (exists N:set, exists e:set,
    N :e omega /\
    embedding_of X Tx (euclidean_space N) (euclidean_topology N) e /\
    closed_in (euclidean_space N) (euclidean_topology N) (apply_fun e X))
<->
(locally_compact X Tx /\ Hausdorff_space X Tx /\ second_countable_space X Tx /\ finite_dimensional_space X Tx).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 1: locally m-euclidean implies locally compact and locally metrizable **)
(** LATEX VERSION: If X is locally m-euclidean, then X is locally compact and locally metrizable. **)
(** helper: local metrizability **)
(** LATEX VERSION: A space is locally metrizable if each point has a neighborhood whose subspace topology is induced by some metric. **)
Definition locally_metrizable_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  forall x:set, x :e X ->
    exists N:set, N :e Tx /\ x :e N /\
      exists d:set, metric_on N d /\ subspace_topology X Tx N = metric_topology N d.

Theorem supp_ex_locally_euclidean_1 : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  locally_compact X Tx /\ locally_metrizable_space X Tx.
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 2: implications among conditions **)
(** LATEX VERSION: For locally m-euclidean X: (i) compact Hausdorff ⇒ (ii) m-manifold ⇒ (iii) metrizable ⇒ (iv) normal ⇒ (v) Hausdorff. **)
Theorem supp_ex_locally_euclidean_2_i_implies_ii : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  compact_space X Tx ->
  Hausdorff_space X Tx ->
  m_manifold X Tx m.
admit. (** FAIL **)
Qed.

Theorem supp_ex_locally_euclidean_2_ii_implies_iii : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  m_manifold X Tx m ->
  metrizable X Tx.
admit. (** FAIL **)
Qed.

Theorem supp_ex_locally_euclidean_2_iii_implies_iv : forall X Tx:set,
  metrizable X Tx ->
  normal_space X Tx.
let X Tx.
assume Hmet.
prove normal_space X Tx.
(** Unpack metrizability: Tx = metric_topology X d for some metric d. **)
apply Hmet.
let d. assume HdPair.
claim Hd: metric_on X d.
{ exact (andEL (metric_on X d) (metric_topology X d = Tx) HdPair). }
claim Heq: metric_topology X d = Tx.
{ exact (andER (metric_on X d) (metric_topology X d = Tx) HdPair). }
claim Hnorm: normal_space X (metric_topology X d).
{ exact (metrizable_spaces_normal X d Hd). }
rewrite <- Heq.
exact Hnorm.
Qed.

(** helper: normal + T1 implies Hausdorff **)
Theorem normal_T1_implies_Hausdorff : forall X Tx:set,
  normal_space X Tx -> T1_space X Tx -> Hausdorff_space X Tx.
let X Tx.
  assume Hnorm: normal_space X Tx.
  assume HT1: T1_space X Tx.
  prove Hausdorff_space X Tx.
  claim HT1part: one_point_sets_closed X Tx.
  { exact (andEL (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm). }
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall x:set, x :e X -> closed_in X Tx {x})
                 HT1part). }
  claim Hsing:
  forall x:set, x :e X -> closed_in X Tx {x}.
  { exact (iffEL (T1_space X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               (lemma_T1_singletons_closed X Tx HTx) HT1). }
prove topology_on X Tx /\
      forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
        exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
apply andI.
- exact HTx.
- let x1 x2.
  assume Hx1X: x1 :e X.
  assume Hx2X: x2 :e X.
  assume Hneq: x1 <> x2.
  prove exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  claim Hcl1: closed_in X Tx {x1}.
  { exact (Hsing x1 Hx1X). }
  claim Hcl2: closed_in X Tx {x2}.
  { exact (Hsing x2 Hx2X). }
  claim Hdisj: {x1} :/\: {x2} = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e {x1} :/\: {x2}.
    prove z :e Empty.
    claim Hz1: z :e {x1}.
    { exact (binintersectE1 {x1} {x2} z Hz). }
    claim Hz2: z :e {x2}.
    { exact (binintersectE2 {x1} {x2} z Hz). }
    claim Hzx1: z = x1.
    { exact (SingE x1 z Hz1). }
    claim Hzx2: z = x2.
    { exact (SingE x2 z Hz2). }
    claim Hx1x2: x1 = x2.
    { rewrite <- Hzx1. rewrite Hzx2. reflexivity. }
    apply FalseE.
    exact (Hneq Hx1x2). }
  claim Hsep:
    forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
      exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  { exact (andER (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm). }
  claim HexUV:
    exists U V:set, U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty.
  { exact (Hsep {x1} {x2} Hcl1 Hcl2 Hdisj). }
  set U0 := Eps_i (fun U:set => exists V:set,
    U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty).
  claim HU0ex: exists V:set,
    U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty.
  { exact (Eps_i_ex (fun U:set => exists V:set,
      U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty)
      HexUV). }
  set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty).
  claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ {x1} c= U0 /\ {x2} c= V0 /\ U0 :/\: V0 = Empty.
  { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty)
      HU0ex). }
  (** Unpack the left-associative 5-way conjunction HV0prop into its components. **)
  claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0).
  { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim HdisjUV: U0 :/\: V0 = Empty.
  { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0))
                 (U0 :/\: V0 = Empty)
                 HV0prop). }
  claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0).
  { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0)
                 ({x2} c= V0)
                 H1234). }
  claim Hs2: {x2} c= V0.
  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0)
                 ({x2} c= V0)
                 H1234). }
  claim Hab: U0 :e Tx /\ V0 :e Tx.
  { exact (andEL (U0 :e Tx /\ V0 :e Tx)
                 ({x1} c= U0)
                 H123). }
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (V0 :e Tx) Hab). }
  claim HV0Tx: V0 :e Tx.
  { exact (andER (U0 :e Tx) (V0 :e Tx) Hab). }
  claim Hs1: {x1} c= U0.
  { exact (andER (U0 :e Tx /\ V0 :e Tx)
                 ({x1} c= U0)
                 H123). }
  claim Hx1U0: x1 :e U0.
  { exact (Hs1 x1 (SingI x1)). }
  claim Hx2V0: x2 :e V0.
  { exact (Hs2 x2 (SingI x2)). }
  witness U0.
  witness V0.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        { exact HU0Tx. }
        { exact HV0Tx. }
      * exact Hx1U0.
    + exact Hx2V0.
  - exact HdisjUV.
Qed.

(** from Supplementary Exercises Exercise 2: (iv) normal ⇒ (v) Hausdorff, for locally m-euclidean X **)
(** LATEX VERSION: For locally m-euclidean X, normality implies Hausdorff. **)
Theorem supp_ex_locally_euclidean_2_iv_implies_v : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  normal_space X Tx ->
  Hausdorff_space X Tx.
let X Tx m.
assume Hloc: locally_m_euclidean X Tx m.
assume Hnorm: normal_space X Tx.
prove Hausdorff_space X Tx.
claim HT1: T1_space X Tx.
{ exact (locally_m_euclidean_implies_T1 X Tx m Hloc). }
exact (normal_T1_implies_Hausdorff X Tx Hnorm HT1).
Qed.

(** from Supplementary Exercises Exercise 3: R is locally 1-euclidean satisfies (ii) not (i) **)
(** LATEX VERSION: R is locally 1-euclidean and satisfies (ii) but not (i). **)
Theorem supp_ex_locally_euclidean_3 :
  locally_m_euclidean R R_standard_topology (Sing Empty) /\
  m_manifold R R_standard_topology (Sing Empty) /\
  ~ (compact_space R R_standard_topology /\ Hausdorff_space R R_standard_topology).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 4: R×R dictionary order is locally 1-euclidean satisfies (iii) not (ii) **)
(** LATEX VERSION: R×R in dictionary order topology is locally 1-euclidean and satisfies (iii) but not (ii). **)
Theorem supp_ex_locally_euclidean_4 :
  locally_m_euclidean EuclidPlane (order_topology EuclidPlane) (Sing Empty) /\
  metrizable EuclidPlane (order_topology EuclidPlane) /\
  ~ m_manifold EuclidPlane (order_topology EuclidPlane) (Sing Empty).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 5: long line is locally 1-euclidean satisfies (iv) not (iii) **)
(** LATEX VERSION: The long line is locally 1-euclidean and satisfies (iv) but not (iii). **)
(** from Supplementary Exercises Exercise 5: long line carrier and topology **)
(** LATEX VERSION: The long line and its topology (see exercises of §24). **)
(** note: the long line is not constructed in this file; we name its carrier abstractly but ensure it is infinite **)
Definition long_line : set := Eps_i (fun L:set => infinite L).
Theorem infinite_omega : infinite omega.
prove infinite omega.
claim Hatleast: atleastp omega omega.
{ exact (Subq_atleastp omega omega (Subq_ref omega)). }
exact (atleastp_omega_infinite omega Hatleast).
Qed.
Theorem long_line_infinite : infinite long_line.
prove infinite long_line.
claim Hex: exists L:set, infinite L.
{ witness omega.
  exact infinite_omega. }
exact (Eps_i_ex (fun L:set => infinite L) Hex).
Qed.
(** from §24 Theorem/Exercise: topology on the long line **)
(** LATEX VERSION: The long line is the ordered set S_Omega×[0,1) in the dictionary order with its smallest element deleted, with the order topology. **)
Definition long_line_topology : set := Eps_i (fun T:set => topology_on long_line T).
Theorem long_line_topology_on : topology_on long_line long_line_topology.
prove topology_on long_line long_line_topology.
claim Hex: exists T:set, topology_on long_line T.
{ witness (discrete_topology long_line).
  exact (discrete_topology_on long_line). }
exact (Eps_i_ex (fun T:set => topology_on long_line T) Hex).
Qed.
Theorem supp_ex_locally_euclidean_5 :
  locally_m_euclidean long_line long_line_topology (Sing Empty) /\
  normal_space long_line long_line_topology /\
  ~ metrizable long_line long_line_topology.
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 7: Hausdorff iff completely regular **)
(** LATEX VERSION: For locally m-euclidean X: X is Hausdorff iff X is completely regular. **)
Theorem supp_ex_locally_euclidean_7 : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  (Hausdorff_space X Tx <-> completely_regular_space X Tx).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 8: metrizable iff paracompact Hausdorff **)
(** LATEX VERSION: For locally m-euclidean X: X is metrizable iff X is paracompact Hausdorff. **)
Theorem supp_ex_locally_euclidean_8 : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  (metrizable X Tx <-> (paracompact_space X Tx /\ Hausdorff_space X Tx)).
admit. (** FAIL **)
Qed.

(** from Supplementary Exercises Exercise 9: metrizable implies components are m-manifolds **)
(** LATEX VERSION: If locally m-euclidean X is metrizable, then each component of X is an m-manifold. **)
Theorem supp_ex_locally_euclidean_9 : forall X Tx m:set,
  locally_m_euclidean X Tx m ->
  metrizable X Tx ->
  forall x:set, x :e X ->
    m_manifold (component_of X Tx x) (subspace_topology X Tx (component_of X Tx x)) m.
admit. (** FAIL **)
Qed.

(** helper: G_delta subset coded via countable intersection of open sets **)
(** from §30 and §48: G_delta sets **)
(** LATEX VERSION: A G_delta set is a countable intersection of open sets. **)
Definition Gdelta_in : set -> set -> set -> prop := fun X Tx A =>
  exists Fam:set, countable_set Fam /\
    (forall U :e Fam, open_in X Tx U) /\
    intersection_over_family X Fam = A.

(** helper: open map - images of open sets are open **)
(** FIXED: open_map uses image_of f U for set images; apply_fun is only for elements. **) 
(** from Supplementary Exercises: topological groups and open maps **)
(** LATEX VERSION: A map is open if it carries open sets to open sets. **)
Definition open_map : set -> set -> set -> set -> set -> prop :=
  fun X Tx Y Ty f =>
    topology_on X Tx /\ topology_on Y Ty /\ function_on f X Y /\
    forall U:set, U :e Tx -> image_of f U :e Ty.

(** helper: simple topological group structure **)
(** from Supplementary Exercises: Topological Groups **)
(** LATEX VERSION: A topological group is a group that is T1, such that multiplication G×G→G and inversion G→G are continuous. **)
Definition topological_group : set -> set -> prop := fun G Tg =>
  T1_space G Tg /\
  exists mult inv e:set,
    function_on mult (setprod G G) G /\
    function_on inv G G /\
    e :e G /\
    (forall x y z:set,
      x :e G -> y :e G -> z :e G ->
      apply_fun mult (apply_fun mult (x,y), z) = apply_fun mult (x, apply_fun mult (y,z))) /\
    (forall x:set, x :e G -> apply_fun mult (e,x) = x /\ apply_fun mult (x,e) = x) /\
    (forall x:set, x :e G ->
      apply_fun mult (x, apply_fun inv x) = e /\ apply_fun mult (apply_fun inv x, x) = e) /\
    continuous_map (setprod G G) (product_topology G Tg G Tg) G Tg mult /\
    continuous_map G Tg G Tg inv.

(** helper: extract T1_space from topological_group **)
Theorem topological_group_T1 : forall G Tg:set, topological_group G Tg -> T1_space G Tg.
let G Tg.
assume H: topological_group G Tg.
exact (andEL (T1_space G Tg)
             (exists mult inv e:set,
               function_on mult (setprod G G) G /\
               function_on inv G G /\
               e :e G /\
               (forall x y z:set,
                 x :e G -> y :e G -> z :e G ->
                 apply_fun mult (apply_fun mult (x,y), z) = apply_fun mult (x, apply_fun mult (y,z))) /\
               (forall x:set, x :e G -> apply_fun mult (e,x) = x /\ apply_fun mult (x,e) = x) /\
               (forall x:set, x :e G ->
                 apply_fun mult (x, apply_fun inv x) = e /\ apply_fun mult (apply_fun inv x, x) = e) /\
               continuous_map (setprod G G) (product_topology G Tg G Tg) G Tg mult /\
               continuous_map G Tg G Tg inv)
             H).
Qed.

(** helper: topological groups are topological spaces **)
Theorem topological_group_is_topology : forall G Tg:set, topological_group G Tg -> topology_on G Tg.
let G Tg.
assume H: topological_group G Tg.
exact (T1_space_topology G Tg (topological_group_T1 G Tg H)).
Qed.

(** helper: separated subsets predicate **)
(** from §31 and §32: separated subsets (complete normality context) **)
(** LATEX VERSION: Two sets A,B are separated if cl(A)∩B=∅ and A∩cl(B)=∅. **)
Definition separated_subsets : set -> set -> set -> set -> prop := fun X Tx A B =>
  A c= X /\ B c= X /\
  closure_of X Tx A :/\: B = Empty /\ A :/\: closure_of X Tx B = Empty.

(** helper: completely normal predicate **)
(** from §32 Definition: completely normal spaces **)
(** LATEX VERSION: X is completely normal if every subspace of X is normal. **)
Definition completely_normal_space : set -> set -> prop := fun X Tx =>
  topology_on X Tx /\
  (forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y)).

(** helper: linear continuum predicate (order topology with least upper bound property) **)
(** from §24 Definition: linear continuum **)
(** LATEX VERSION: A simply ordered set with more than one element is a linear continuum if it has the least upper bound property and between any x<y there is z with x<z<y. **)
Definition linear_continuum : set -> set -> prop := fun X Tx =>
  (** FIXED: Use `order_rel X` (the order relation used by `order_topology X`), not an unrelated existential relation. **)
  simply_ordered_set X /\
  Tx = order_topology X /\
  (exists x y:set, x :e X /\ y :e X /\ x <> y) /\
  (forall x y:set, x :e X -> y :e X -> order_rel X x y ->
    exists z:set, z :e X /\ order_rel X x z /\ order_rel X z y) /\
  (forall A:set, A c= X -> A <> Empty ->
    (exists upper:set, upper :e X /\ forall a:set, a :e A -> order_rel X a upper \/ a = upper) ->
    exists lub:set, lub :e X /\
      (forall a:set, a :e A -> order_rel X a lub \/ a = lub) /\
      (forall bound:set, bound :e X ->
        (forall a:set, a :e A -> order_rel X a bound \/ a = bound) ->
        order_rel X lub bound \/ lub = bound)).

(** from §30 Exercise 1a: one-point sets are G_delta in first-countable T1 **)
(** LATEX VERSION: In a first-countable T₁ space, every one-point set is a G_δ set. **)
Theorem ex30_1a_onepoint_Gdelta_firstcountable_T1 : forall X Tx x:set,
  first_countable_space X Tx ->
  T1_space X Tx ->
  x :e X ->
  Gdelta_in X Tx (Sing x).
let X Tx x.
assume Hfc: first_countable_space X Tx.
assume HT1: T1_space X Tx.
assume HxX: x :e X.
prove Gdelta_in X Tx (Sing x).
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x0:set, x0 :e X -> countable_basis_at X Tx x0)
               Hfc). }
claim Hcountbas: forall x0:set, x0 :e X -> countable_basis_at X Tx x0.
{ exact (andER (topology_on X Tx)
               (forall x0:set, x0 :e X -> countable_basis_at X Tx x0)
               Hfc). }
claim Hcbx: countable_basis_at X Tx x.
{ exact (Hcountbas x HxX). }
claim HexB: exists B:set,
  B c= Tx /\ countable_set B /\
  (forall b:set, b :e B -> x :e b) /\
  (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
{ exact (andER (topology_on X Tx /\ x :e X)
               (exists B:set,
                 B c= Tx /\ countable_set B /\
                 (forall b:set, b :e B -> x :e b) /\
                 (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U))
               Hcbx). }
set B := Eps_i (fun B0:set =>
  B0 c= Tx /\ countable_set B0 /\
  (forall b:set, b :e B0 -> x :e b) /\
  (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B0 /\ b c= U)).
claim HBprop:
  B c= Tx /\ countable_set B /\
  (forall b:set, b :e B -> x :e b) /\
  (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U).
{ exact (Eps_i_ex (fun B0:set =>
           B0 c= Tx /\ countable_set B0 /\
           (forall b:set, b :e B0 -> x :e b) /\
           (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B0 /\ b c= U))
         HexB). }
claim HB123: ((B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b)).
{ exact (andEL ((B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b))
               (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U)
               HBprop). }
claim HBrefine: forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U.
{ exact (andER ((B c= Tx /\ countable_set B) /\ (forall b:set, b :e B -> x :e b))
               (forall U:set, U :e Tx -> x :e U -> exists b:set, b :e B /\ b c= U)
               HBprop). }
claim HB12: (B c= Tx /\ countable_set B).
{ exact (andEL (B c= Tx /\ countable_set B)
               (forall b:set, b :e B -> x :e b)
               HB123). }
claim HBx: forall b:set, b :e B -> x :e b.
{ exact (andER (B c= Tx /\ countable_set B)
               (forall b:set, b :e B -> x :e b)
               HB123). }
claim HBsub: B c= Tx.
{ exact (andEL (B c= Tx) (countable_set B) HB12). }
claim HBcount: countable_set B.
{ exact (andER (B c= Tx) (countable_set B) HB12). }

prove exists Fam:set, countable_set Fam /\ (forall U :e Fam, open_in X Tx U) /\ intersection_over_family X Fam = Sing x.
witness B.
apply andI.
- prove countable_set B /\ (forall U :e B, open_in X Tx U).
  apply andI.
  - exact HBcount.
  - let U. assume HU: U :e B.
    prove topology_on X Tx /\ U :e Tx.
    apply andI.
    + exact HTx.
    + apply HBsub. exact HU.
- apply set_ext.
    + let z. assume Hz: z :e intersection_over_family X B.
      prove z :e Sing x.
      claim HzX: z :e X.
      { exact (SepE1 X (fun z0:set => forall U:set, U :e B -> z0 :e U) z Hz). }
      claim Hzall: forall U:set, U :e B -> z :e U.
      { exact (SepE2 X (fun z0:set => forall U:set, U :e B -> z0 :e U) z Hz). }
      apply xm (z = x).
      - assume Hzx: z = x.
        rewrite Hzx.
        exact (SingI x).
      - assume Hzneq: z <> x.
        apply FalseE.
        claim HsubZ: {z} c= X.
        { exact (singleton_subset z X HzX). }
        claim Hzfin: finite {z}.
        { exact (Sing_finite z). }
        claim Hzclosed: closed_in X Tx {z}.
        { exact (T1_space_finite_closed X Tx {z} HT1 HsubZ Hzfin). }
        set Uc := X :\: {z}.
        claim HUcopen: open_in X Tx Uc.
        { exact (open_of_closed_complement X Tx {z} Hzclosed). }
        claim HUcTx: Uc :e Tx.
        { exact (open_in_elem X Tx Uc HUcopen). }
        claim Hxnotz: x /:e {z}.
        { assume Hxz: x :e {z}.
          claim HxzEq: x = z.
          { exact (SingE z x Hxz). }
          claim HzxEq: z = x.
          { rewrite HxzEq. reflexivity. }
          exact (Hzneq HzxEq). }
        claim HxUc: x :e Uc.
        { exact (setminusI X {z} x HxX Hxnotz). }
        claim Hexb: exists b:set, b :e B /\ b c= Uc.
        { exact (HBrefine Uc HUcTx HxUc). }
        set b0 := Eps_i (fun b:set => b :e B /\ b c= Uc).
        claim Hb0prop: b0 :e B /\ b0 c= Uc.
        { exact (Eps_i_ex (fun b:set => b :e B /\ b c= Uc) Hexb). }
        claim Hb0B: b0 :e B.
        { exact (andEL (b0 :e B) (b0 c= Uc) Hb0prop). }
        claim Hb0sub: b0 c= Uc.
        { exact (andER (b0 :e B) (b0 c= Uc) Hb0prop). }
        claim Hzz: z :e {z}.
        { exact (SingI z). }
        claim HznotUc: z /:e Uc.
        { assume HzUc: z :e Uc.
          claim HznotZ: z /:e {z}.
          { exact (setminusE2 X {z} z HzUc). }
          exact (HznotZ Hzz). }
        claim Hznotb0: z /:e b0.
        { assume Hzb: z :e b0.
          claim HzUc: z :e Uc.
          { apply Hb0sub. exact Hzb. }
          exact (HznotUc HzUc). }
        claim Hzb0: z :e b0.
        { exact (Hzall b0 Hb0B). }
        exact (Hznotb0 Hzb0).
    + let z. assume Hz: z :e Sing x.
      prove z :e intersection_over_family X B.
      claim HzEq: z = x.
      { exact (SingE x z Hz). }
      claim HdefInt: intersection_over_family X B =
        {z0 :e X|forall U:set, U :e B -> z0 :e U}.
      { reflexivity. }
      rewrite HdefInt.
      apply (SepI X (fun z0:set => forall U:set, U :e B -> z0 :e U) z).
      - rewrite HzEq. exact HxX.
      - let U. assume HU: U :e B.
        rewrite HzEq.
        exact (HBx U HU).
Qed.

(** from §30 Exercise 1b: space with G_delta points but not first-countable **)
(** LATEX VERSION: There exists a space where every one-point set is G_δ but which doesn't satisfy the first countability axiom. **)
Theorem ex30_1b_Gdelta_not_firstcountable_exists :
  exists X:set, exists Tx:set,
    topology_on X Tx /\
    (forall x:set, x :e X -> Gdelta_in X Tx (Sing x)) /\
    ~ first_countable_space X Tx.
admit. (** FAIL **)
Qed.
(** from §30 Exercise 2: every basis contains countable basis when space has one **)
(** LATEX VERSION: If X has a countable basis, then every basis for X contains a countable basis. **)
Theorem ex30_2_basis_contains_countable : forall X Tx:set, forall Basis:set,
  second_countable_space X Tx ->
  basis_generates X Basis Tx ->
  exists CountableSub:set,
    CountableSub c= Basis /\
    countable CountableSub /\
    basis_generates X CountableSub Tx.
let X Tx Basis.
assume Hsc: second_countable_space X Tx.
assume HBg: basis_generates X Basis Tx.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
claim HBasisOn: basis_on X Basis.
{ exact (andEL (basis_on X Basis) (generated_topology X Basis = Tx) HBg). }
claim HBasisEq: generated_topology X Basis = Tx.
{ exact (andER (basis_on X Basis) (generated_topology X Basis = Tx) HBg). }
apply HexB.
let Bx. assume HBxAll: basis_on X Bx /\ countable_set Bx /\ basis_generates X Bx Tx.
claim HBxMid: (basis_on X Bx /\ countable_set Bx) /\ basis_generates X Bx Tx.
{ exact HBxAll. }
claim HBxPair: basis_on X Bx /\ countable_set Bx.
{ exact (andEL (basis_on X Bx /\ countable_set Bx) (basis_generates X Bx Tx) HBxMid). }
claim HBxBasis: basis_on X Bx.
{ exact (andEL (basis_on X Bx) (countable_set Bx) HBxPair). }
claim HBxCount: countable_set Bx.
{ exact (andER (basis_on X Bx) (countable_set Bx) HBxPair). }
claim HBxGener: basis_generates X Bx Tx.
{ exact (andER (basis_on X Bx /\ countable_set Bx) (basis_generates X Bx Tx) HBxMid). }
claim HBxEq: generated_topology X Bx = Tx.
{ exact (andER (basis_on X Bx) (generated_topology X Bx = Tx) HBxGener). }

(** Pairs (b1,b2) of countable-basis elements with an interpolating Basis element. **)
set PairB := Sigma_ b1 :e Bx, Bx.
set P := {z :e PairB | exists c:set, c :e Basis /\ z 0 c= c /\ c c= z 1}.
set choose : set -> set := fun z:set =>
  Eps_i (fun c:set => c :e Basis /\ z 0 c= c /\ c c= z 1).
set CountableSub := {choose z | z :e P}.

claim HPairBcount: countable PairB.
{ set Y : set -> set := fun _ : set => Bx.
  claim HY: forall b1:set, b1 :e Bx -> countable (Y b1).
  { let b1. assume _.
    exact HBxCount. }
  exact (Sigma_countable Bx HBxCount Y HY). }
claim HPsub: P c= PairB.
{ let z. assume HzP: z :e P.
  exact (SepE1 PairB (fun z0:set => exists c:set, c :e Basis /\ z0 0 c= c /\ c c= z0 1) z HzP). }
claim HPcount: countable P.
{ exact (Subq_countable P PairB HPairBcount HPsub). }
claim HCountSubCount: countable CountableSub.
{ exact (countable_image P HPcount choose). }
claim HCountSubSubBasis: CountableSub c= Basis.
{ let c. assume Hc: c :e CountableSub.
  apply (ReplE_impred P choose c Hc).
  let z. assume HzP: z :e P.
  assume Hceq: c = choose z.
  claim HzPprop: exists c0:set, c0 :e Basis /\ z 0 c= c0 /\ c0 c= z 1.
  { exact (SepE2 PairB (fun z0:set => exists c0:set, c0 :e Basis /\ z0 0 c= c0 /\ c0 c= z0 1) z HzP). }
  claim HchooseProp: choose z :e Basis /\ z 0 c= (choose z) /\ (choose z) c= z 1.
  { exact (Eps_i_ex (fun c0:set => c0 :e Basis /\ z 0 c= c0 /\ c0 c= z 1) HzPprop). }
  rewrite Hceq.
  claim Htmp: choose z :e Basis /\ z 0 c= choose z.
  { exact (andEL (choose z :e Basis /\ z 0 c= choose z) (choose z c= z 1) HchooseProp). }
  exact (andEL (choose z :e Basis) (z 0 c= choose z) Htmp). }

(** Each element of CountableSub is open in Tx since Basis generates Tx. **)
claim HCountSubOpen: forall c :e CountableSub, c :e Tx.
{ let c. assume Hc: c :e CountableSub.
  claim HcBasis: c :e Basis.
  { exact (HCountSubSubBasis c Hc). }
  claim HcGen: c :e generated_topology X Basis.
  { exact (generated_topology_contains_basis X Basis HBasisOn c HcBasis). }
  prove c :e Tx.
  rewrite <- HBasisEq.
  exact HcGen. }

(** Refinement: for any open U and x∈U, find Cx∈CountableSub with x∈Cx⊆U. **)
claim HCountSubRefines: forall U :e Tx, forall x :e U, exists Cx :e CountableSub, x :e Cx /\ Cx c= U.
{ let U. assume HU: U :e Tx.
  let x. assume HxU: x :e U.
  claim HUGenB: U :e generated_topology X Bx.
  { prove U :e generated_topology X Bx.
    rewrite HBxEq.
    exact HU. }
  claim HUpropB: forall x0 :e U, exists b :e Bx, x0 :e b /\ b c= U.
  { exact (SepE2 (Power X)
                 (fun U0:set => forall x0 :e U0, exists b :e Bx, x0 :e b /\ b c= U0)
                 U
                 HUGenB). }
  claim Hexb2: exists b2 :e Bx, x :e b2 /\ b2 c= U.
  { exact (HUpropB x HxU). }
  apply Hexb2.
  let b2. assume Hb2pair.
  claim Hb2Bx: b2 :e Bx.
  { exact (andEL (b2 :e Bx) (x :e b2 /\ b2 c= U) Hb2pair). }
  claim Hb2prop: x :e b2 /\ b2 c= U.
  { exact (andER (b2 :e Bx) (x :e b2 /\ b2 c= U) Hb2pair). }
  claim Hxb2: x :e b2.
  { exact (andEL (x :e b2) (b2 c= U) Hb2prop). }
  claim Hb2subU: b2 c= U.
  { exact (andER (x :e b2) (b2 c= U) Hb2prop). }
  claim Hb2GenB: b2 :e generated_topology X Bx.
  { exact (generated_topology_contains_basis X Bx HBxBasis b2 Hb2Bx). }
  claim Hb2Tx: b2 :e Tx.
  { prove b2 :e Tx.
    rewrite <- HBxEq.
    exact Hb2GenB. }
  claim Hb2GenC: b2 :e generated_topology X Basis.
  { prove b2 :e generated_topology X Basis.
    rewrite HBasisEq.
    exact Hb2Tx. }
  claim Hb2propC: forall x0 :e b2, exists c0 :e Basis, x0 :e c0 /\ c0 c= b2.
  { exact (SepE2 (Power X)
                 (fun U0:set => forall x0 :e U0, exists c0 :e Basis, x0 :e c0 /\ c0 c= U0)
                 b2
                 Hb2GenC). }
  claim Hexc0: exists c0 :e Basis, x :e c0 /\ c0 c= b2.
  { exact (Hb2propC x Hxb2). }
  apply Hexc0.
  let c0. assume Hc0pair.
  claim Hc0Basis: c0 :e Basis.
  { exact (andEL (c0 :e Basis) (x :e c0 /\ c0 c= b2) Hc0pair). }
  claim Hc0prop: x :e c0 /\ c0 c= b2.
  { exact (andER (c0 :e Basis) (x :e c0 /\ c0 c= b2) Hc0pair). }
  claim Hxc0: x :e c0.
  { exact (andEL (x :e c0) (c0 c= b2) Hc0prop). }
  claim Hc0subb2: c0 c= b2.
  { exact (andER (x :e c0) (c0 c= b2) Hc0prop). }
  claim Hc0GenC: c0 :e generated_topology X Basis.
  { exact (generated_topology_contains_basis X Basis HBasisOn c0 Hc0Basis). }
  claim Hc0Tx: c0 :e Tx.
  { prove c0 :e Tx.
    rewrite <- HBasisEq.
    exact Hc0GenC. }
  claim Hc0GenB: c0 :e generated_topology X Bx.
  { prove c0 :e generated_topology X Bx.
    rewrite HBxEq.
    exact Hc0Tx. }
  claim Hc0propB: forall x0 :e c0, exists b :e Bx, x0 :e b /\ b c= c0.
  { exact (SepE2 (Power X)
                 (fun U0:set => forall x0 :e U0, exists b :e Bx, x0 :e b /\ b c= U0)
                 c0
                 Hc0GenB). }
  claim Hexb1: exists b1 :e Bx, x :e b1 /\ b1 c= c0.
  { exact (Hc0propB x Hxc0). }
  apply Hexb1.
  let b1. assume Hb1pair.
  claim Hb1Bx: b1 :e Bx.
  { exact (andEL (b1 :e Bx) (x :e b1 /\ b1 c= c0) Hb1pair). }
  claim Hb1prop: x :e b1 /\ b1 c= c0.
  { exact (andER (b1 :e Bx) (x :e b1 /\ b1 c= c0) Hb1pair). }
  claim Hxb1: x :e b1.
  { exact (andEL (x :e b1) (b1 c= c0) Hb1prop). }
  claim Hb1subc0: b1 c= c0.
  { exact (andER (x :e b1) (b1 c= c0) Hb1prop). }
  set z := (b1,b2).
  claim HzPairB: z :e PairB.
  { exact (tuple_2_Sigma Bx (fun _ : set => Bx) b1 Hb1Bx b2 Hb2Bx). }
	  claim HzP: z :e P.
	  { claim Hexc: exists c:set, c :e Basis /\ z 0 c= c /\ c c= z 1.
	    { witness c0.
	      apply andI.
	      - prove c0 :e Basis /\ z 0 c= c0.
	        apply andI.
	        + exact Hc0Basis.
	        + rewrite (tuple_2_0_eq b1 b2).
	          exact Hb1subc0.
	      - rewrite (tuple_2_1_eq b1 b2).
	        exact Hc0subb2. }
	    apply (SepI PairB (fun z0:set => exists c:set, c :e Basis /\ z0 0 c= c /\ c c= z0 1) z HzPairB Hexc). }
  set Cx := choose z.
  witness Cx.
  apply andI.
  - prove Cx :e CountableSub.
    exact (ReplI P choose z HzP).
  - apply andI.
    + (** x :e Cx **)
      claim HzPprop: exists c:set, c :e Basis /\ z 0 c= c /\ c c= z 1.
      { exact (SepE2 PairB (fun z0:set => exists c:set, c :e Basis /\ z0 0 c= c /\ c c= z0 1) z HzP). }
      claim HchooseProp: choose z :e Basis /\ z 0 c= choose z /\ choose z c= z 1.
      { exact (Eps_i_ex (fun c:set => c :e Basis /\ z 0 c= c /\ c c= z 1) HzPprop). }
      claim Hb1subCx: z 0 c= Cx.
      { claim Htmp: choose z :e Basis /\ z 0 c= choose z.
        { exact (andEL (choose z :e Basis /\ z 0 c= choose z) (choose z c= z 1) HchooseProp). }
        claim Hz0sub: z 0 c= choose z.
        { exact (andER (choose z :e Basis) (z 0 c= choose z) Htmp). }
        claim HCxDef: Cx = choose z.
        { reflexivity. }
        rewrite HCxDef.
        exact Hz0sub. }
      claim Hz0eq: z 0 = b1.
      { exact (tuple_2_0_eq b1 b2). }
      claim Hxz0: x :e z 0.
      { rewrite Hz0eq.
        exact Hxb1. }
      exact (Hb1subCx x Hxz0).
    + (** Cx c= U **)
      claim HzPprop: exists c:set, c :e Basis /\ z 0 c= c /\ c c= z 1.
      { exact (SepE2 PairB (fun z0:set => exists c:set, c :e Basis /\ z0 0 c= c /\ c c= z0 1) z HzP). }
      claim HchooseProp: choose z :e Basis /\ z 0 c= choose z /\ choose z c= z 1.
      { exact (Eps_i_ex (fun c:set => c :e Basis /\ z 0 c= c /\ c c= z 1) HzPprop). }
      claim HCxsubb2: Cx c= z 1.
      { claim HCxDef: Cx = choose z.
        { reflexivity. }
        rewrite HCxDef.
        exact (andER (choose z :e Basis /\ z 0 c= choose z) (choose z c= z 1) HchooseProp). }
      claim HCxsubb2': Cx c= b2.
      { claim Hz1eq: z 1 = b2.
        { exact (tuple_2_1_eq b1 b2). }
        let y. assume Hy: y :e Cx.
        prove y :e b2.
        claim Hyz1: y :e z 1.
        { exact (HCxsubb2 y Hy). }
        rewrite <- Hz1eq.
        exact Hyz1. }
      exact (Subq_tra Cx b2 U HCxsubb2' Hb2subU). }

claim HCountSubBasisEq: basis_on X CountableSub /\ generated_topology X CountableSub = Tx.
{ exact (basis_refines_topology X Tx CountableSub HTx HCountSubOpen HCountSubRefines). }
claim HCountSubGener: basis_generates X CountableSub Tx.
{ prove basis_on X CountableSub /\ generated_topology X CountableSub = Tx.
  exact HCountSubBasisEq. }

witness CountableSub.
prove CountableSub c= Basis /\ countable CountableSub /\ basis_generates X CountableSub Tx.
apply andI.
- apply andI.
  + exact HCountSubSubBasis.
  + exact HCountSubCount.
- exact HCountSubGener.
Qed.
(** from §30 Exercise 3: uncountable subset has uncountably many limit points **)
(** LATEX VERSION: If X has countable basis and A is uncountable subset, then uncountably many points of A are limit points. **)
(** FIXED: Use limit_point_of X Tx A x (space, topology, set, point), not a permuted argument order. **) 
Theorem ex30_3_uncountably_many_limit_points : forall X Tx A:set,
  second_countable_space X Tx ->
  A c= X ->
  ~ countable A ->
  ~ countable {x :e A | limit_point_of X Tx A x}.
let X Tx A.
assume Hsc: second_countable_space X Tx.
assume HA: A c= X.
assume HuncA: ~ countable A.
prove ~ countable {x :e A | limit_point_of X Tx A x}.
set L := {x :e A | limit_point_of X Tx A x}.
assume HcountL: countable L.
prove False.

claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
set B := Eps_i (fun B0:set => basis_on X B0 /\ countable_set B0 /\ basis_generates X B0 Tx).
claim HBspec: basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (Eps_i_ex (fun B0:set => basis_on X B0 /\ countable_set B0 /\ basis_generates X B0 Tx) HexB). }
claim HBleft: basis_on X B /\ countable_set B.
{ exact (andEL (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBspec). }
claim HBasis: basis_on X B.
{ exact (andEL (basis_on X B) (countable_set B) HBleft). }
claim HBcountset: countable_set B.
{ exact (andER (basis_on X B) (countable_set B) HBleft). }
claim HBgen: basis_generates X B Tx.
{ exact (andER (basis_on X B /\ countable_set B) (basis_generates X B Tx) HBspec). }
claim HGenEq: generated_topology X B = Tx.
{ exact (andER (basis_on X B) (generated_topology X B = Tx) HBgen). }

set I := {x :e A | ~ limit_point_of X Tx A x}.
set pick_iso : set -> set := fun x0:set =>
  Eps_i (fun b0:set => b0 :e B /\ x0 :e b0 /\ b0 :/\: A = {x0}).

claim HexIso: forall x:set, x :e I -> exists b0:set, b0 :e B /\ x :e b0 /\ b0 :/\: A = {x}.
{ let x. assume HxI: x :e I.
  prove exists b0:set, b0 :e B /\ x :e b0 /\ b0 :/\: A = {x}.
  claim HxA: x :e A.
  { exact (SepE1 A (fun x0:set => ~ limit_point_of X Tx A x0) x HxI). }
  claim HxnotLP: ~ limit_point_of X Tx A x.
  { exact (SepE2 A (fun x0:set => ~ limit_point_of X Tx A x0) x HxI). }
  claim HxX: x :e X.
  { exact (HA x HxA). }

  (** reduce ~limit_point_of to failure of the neighborhood property, using HTx and HxX **)
  claim HnotP:
    ~ (forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
  { assume HP: forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
    apply HxnotLP.
    prove (topology_on X Tx /\ x :e X) /\
          (forall U:set, U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
    apply andI.
    - apply andI.
      + exact HTx.
      + exact HxX.
    - exact HP. }

  (** classical: not forall implies exists not **)
  claim HexU: exists U:set, ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
  { apply (xm (exists U:set, ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U))).
    - assume Hex: exists U:set, ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
      exact Hex.
    - assume Hno: ~ (exists U:set, ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U)).
      apply FalseE.
      prove False.
      apply HnotP.
      let U.
      prove U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
      apply (xm (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U)).
      + assume HUimp: U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U.
        exact HUimp.
      + assume HnotHUimp: ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).
        apply FalseE.
        prove False.
        apply Hno.
        witness U.
        exact HnotHUimp. }

  apply HexU.
  let U. assume HnotImp: ~ (U :e Tx -> x :e U -> exists y:set, y :e A /\ y <> x /\ y :e U).

  claim HU: U :e Tx.
  { apply (xm (U :e Tx)).
    - assume HU0: U :e Tx. exact HU0.
    - assume HnotHU: U /:e Tx.
      apply FalseE.
      prove False.
      apply HnotImp.
      assume HU1: U :e Tx.
      apply FalseE.
      exact (HnotHU HU1). }

  claim HxU: x :e U.
  { apply (xm (x :e U)).
    - assume HxU0: x :e U. exact HxU0.
    - assume HnotHxU: x /:e U.
      apply FalseE.
      prove False.
      apply HnotImp.
      assume HU1: U :e Tx.
      assume HxU1: x :e U.
      apply FalseE.
      exact (HnotHxU HxU1). }

  claim HnoY: ~ (exists y:set, y :e A /\ y <> x /\ y :e U).
  { assume Hexy: exists y:set, y :e A /\ y <> x /\ y :e U.
    apply HnotImp.
    assume HU1: U :e Tx.
    assume HxU1: x :e U.
    exact Hexy. }

  claim HUcapAeq: U :/\: A = {x}.
  { apply set_ext.
    - let y. assume Hy: y :e U :/\: A.
      prove y :e {x}.
      claim HyU: y :e U.
      { exact (binintersectE1 U A y Hy). }
      claim HyA: y :e A.
      { exact (binintersectE2 U A y Hy). }
      apply (xm (y = x)).
      + assume Heq: y = x.
        rewrite Heq.
        exact (SingI x).
      + assume Hneq: y <> x.
        apply FalseE.
        prove False.
        apply HnoY.
        witness y.
        prove y :e A /\ y <> x /\ y :e U.
        apply andI.
        * apply andI.
          + exact HyA.
          + exact Hneq.
        * exact HyU.
    - let y. assume Hy: y :e {x}.
      prove y :e U :/\: A.
      claim Heq: y = x.
      { exact (SingE x y Hy). }
      rewrite Heq.
      exact (binintersectI U A x HxU HxA). }

  (** pick a basis element b0 with x ∈ b0 ⊂ U and hence b0 ∩ A = {x} **)
  claim HUgen: U :e generated_topology X B.
  { rewrite HGenEq.
    exact HU. }
  claim HUprop: forall y :e U, exists b0 :e B, y :e b0 /\ b0 c= U.
  { exact (SepE2 (Power X)
                 (fun U0:set => forall y0:set, y0 :e U0 -> exists b0 :e B, y0 :e b0 /\ b0 c= U0)
                 U
                 HUgen). }
  claim Hexb: exists b0 :e B, x :e b0 /\ b0 c= U.
  { exact (HUprop x HxU). }
  set b0 := Eps_i (fun b:set => b :e B /\ (x :e b /\ b c= U)).
  claim Hb0spec: b0 :e B /\ (x :e b0 /\ b0 c= U).
  { exact (Eps_i_ex (fun b:set => b :e B /\ (x :e b /\ b c= U)) Hexb). }
  claim Hb0B: b0 :e B.
  { exact (andEL (b0 :e B) (x :e b0 /\ b0 c= U) Hb0spec). }
  claim Hb0prop: x :e b0 /\ b0 c= U.
  { exact (andER (b0 :e B) (x :e b0 /\ b0 c= U) Hb0spec). }
  claim Hxb0: x :e b0.
  { exact (andEL (x :e b0) (b0 c= U) Hb0prop). }
  claim Hb0subU: b0 c= U.
  { exact (andER (x :e b0) (b0 c= U) Hb0prop). }

  witness b0.
  prove b0 :e B /\ x :e b0 /\ b0 :/\: A = {x}.
  claim Hb0pair2: b0 :e B /\ x :e b0.
  { exact (andI (b0 :e B) (x :e b0) Hb0B Hxb0). }
  claim Hb0cap: b0 :/\: A = {x}.
  { apply set_ext.
    - let y. assume Hy: y :e b0 :/\: A.
      prove y :e {x}.
      claim HyA: y :e A.
      { exact (binintersectE2 b0 A y Hy). }
      claim Hyb0: y :e b0.
      { exact (binintersectE1 b0 A y Hy). }
      claim HyU: y :e U.
      { exact (Hb0subU y Hyb0). }
      claim HyUA: y :e U :/\: A.
      { exact (binintersectI U A y HyU HyA). }
      rewrite <- HUcapAeq.
      exact HyUA.
    - let y. assume Hy: y :e {x}.
      prove y :e b0 :/\: A.
      claim Heq: y = x.
      { exact (SingE x y Hy). }
      rewrite Heq.
      exact (binintersectI b0 A x Hxb0 HxA). }
  exact (andI (b0 :e B /\ x :e b0) (b0 :/\: A = {x}) Hb0pair2 Hb0cap).
}

claim HinjIB: inj I B pick_iso.
{ prove (forall u :e I, pick_iso u :e B) /\
        (forall u :e I, forall v :e I, pick_iso u = pick_iso v -> u = v).
  apply andI.
  - let u. assume HuI: u :e I.
    prove pick_iso u :e B.
    claim Hexb: exists b0:set, b0 :e B /\ u :e b0 /\ b0 :/\: A = {u}.
    { exact (HexIso u HuI). }
	    claim Hpick: pick_iso u :e B /\ u :e pick_iso u /\ pick_iso u :/\: A = {u}.
	    { exact (Eps_i_ex (fun b0:set => b0 :e B /\ u :e b0 /\ b0 :/\: A = {u}) Hexb). }
	    claim HpickL: pick_iso u :e B /\ u :e pick_iso u.
	    { exact (andEL (pick_iso u :e B /\ u :e pick_iso u) (pick_iso u :/\: A = {u}) Hpick). }
	    exact (andEL (pick_iso u :e B) (u :e pick_iso u) HpickL).
  - let u. assume HuI: u :e I.
    let v. assume HvI: v :e I.
    assume Heq: pick_iso u = pick_iso v.
    prove u = v.
    claim Hexu: exists b0:set, b0 :e B /\ u :e b0 /\ b0 :/\: A = {u}.
    { exact (HexIso u HuI). }
    claim Hexv: exists b0:set, b0 :e B /\ v :e b0 /\ b0 :/\: A = {v}.
    { exact (HexIso v HvI). }
    claim Hpu: pick_iso u :/\: A = {u}.
    { claim Hpick: pick_iso u :e B /\ u :e pick_iso u /\ pick_iso u :/\: A = {u}.
      { exact (Eps_i_ex (fun b0:set => b0 :e B /\ u :e b0 /\ b0 :/\: A = {u}) Hexu). }
      exact (andER (pick_iso u :e B /\ u :e pick_iso u) (pick_iso u :/\: A = {u}) Hpick). }
    claim Hpv: pick_iso v :/\: A = {v}.
    { claim Hpick: pick_iso v :e B /\ v :e pick_iso v /\ pick_iso v :/\: A = {v}.
      { exact (Eps_i_ex (fun b0:set => b0 :e B /\ v :e b0 /\ b0 :/\: A = {v}) Hexv). }
      exact (andER (pick_iso v :e B /\ v :e pick_iso v) (pick_iso v :/\: A = {v}) Hpick). }
    claim HsingEq: {u} = {v}.
    { rewrite <- Hpu.
      rewrite Heq.
      rewrite Hpv.
      reflexivity. }
    claim HuIn: u :e {u}.
    { exact (SingI u). }
    claim HuInV: u :e {v}.
    { rewrite <- HsingEq.
      exact HuIn. }
    exact (SingE v u HuInV).
}

claim HcountI: countable I.
{ prove countable I.
  prove atleastp I omega.
 claim HIB: atleastp I B.
  { prove exists f : set -> set, inj I B f.
    witness pick_iso.
    exact HinjIB. }
  claim HBO: atleastp B omega.
  { exact HBcountset. }
  exact (atleastp_tra I B omega HIB HBO). }

claim HAeq: A = I :\/: L.
{ apply set_ext.
  - let x. assume HxA: x :e A.
    prove x :e I :\/: L.
    apply (xm (limit_point_of X Tx A x)).
    + assume Hlp: limit_point_of X Tx A x.
      apply binunionI2.
      exact (SepI A (fun x0:set => limit_point_of X Tx A x0) x HxA Hlp).
    + assume Hnotlp: ~ limit_point_of X Tx A x.
      apply binunionI1.
      exact (SepI A (fun x0:set => ~ limit_point_of X Tx A x0) x HxA Hnotlp).
  - let x. assume HxUL: x :e I :\/: L.
    prove x :e A.
    apply (binunionE' I L x (x :e A)).
    + assume HxI: x :e I.
      exact (SepE1 A (fun x0:set => ~ limit_point_of X Tx A x0) x HxI).
    + assume HxL: x :e L.
      exact (SepE1 A (fun x0:set => limit_point_of X Tx A x0) x HxL).
    + exact HxUL. }

claim HcountUnion: countable (I :\/: L).
{ exact (binunion_countable I L HcountI HcountL). }
claim HcountA: countable A.
{ rewrite HAeq.
  exact HcountUnion. }
exact (HuncA HcountA).
Qed.
(** from §30 Exercise 4: compact metrizable implies second countable **)
(** LATEX VERSION: Every compact metrizable space has a countable basis. **)
Theorem ex30_4_compact_metrizable_second_countable : forall X Tx d:set,
  compact_space X Tx ->
  metrizable X Tx ->
  metric_on X d ->
  Tx = metric_topology X d ->
  second_countable_space X Tx.
let X Tx d.
assume Hcomp: compact_space X Tx.
assume Hmet: metrizable X Tx.
assume Hd: metric_on X d.
assume HTdef: Tx = metric_topology X d.
prove second_countable_space X Tx.

(** helper: compact implies Lindelof **)
claim HL: Lindelof_space X Tx.
{ prove topology_on X Tx /\
    forall U:set, open_cover X Tx U ->
      exists V:set, countable_subcollection V U /\ covers X V.
  apply andI.
  - exact (compact_space_topology X Tx Hcomp).
  - let U. assume Hcover: open_cover X Tx U.
    prove exists V:set, countable_subcollection V U /\ covers X V.
    claim HTx: topology_on X Tx.
    { exact (compact_space_topology X Tx Hcomp). }
    claim HUpow: U c= Power X.
    { exact (open_cover_family_sub X Tx U HTx Hcover). }
    claim HcovOf: open_cover_of X Tx U.
    { prove topology_on X Tx /\ U c= Power X /\ X c= Union U /\ (forall W:set, W :e U -> W :e Tx).
      apply andI.
      - apply andI.
        + apply andI.
          * exact HTx.
          * exact HUpow.
        + let x. assume HxX: x :e X.
          prove x :e Union U.
          claim Hcov: covers X U.
          { exact (andER (forall u0:set, u0 :e U -> u0 :e Tx) (covers X U) Hcover). }
          claim Hexu: exists u:set, u :e U /\ x :e u.
          { exact (Hcov x HxX). }
          apply Hexu.
          let u. assume Hupair: u :e U /\ x :e u.
          exact (UnionI U x u
                  (andER (u :e U) (x :e u) Hupair)
                  (andEL (u :e U) (x :e u) Hupair)).
      - exact (andEL (forall u0:set, u0 :e U -> u0 :e Tx) (covers X U) Hcover). }
    claim Hfin: has_finite_subcover X Tx U.
    { exact (compact_space_subcover_property X Tx Hcomp U HcovOf). }
    apply Hfin.
    let G. assume HG: G c= U /\ finite G /\ X c= Union G.
    witness G.
    prove countable_subcollection G U /\ covers X G.
    apply andI.
    - prove G c= U /\ countable_set G.
      apply andI.
      + claim HGleft: G c= U /\ finite G.
        { exact (andEL (G c= U /\ finite G) (X c= Union G) HG). }
        exact (andEL (G c= U) (finite G) HGleft).
      + claim HGleft: G c= U /\ finite G.
        { exact (andEL (G c= U /\ finite G) (X c= Union G) HG). }
        claim HGfin: finite G.
        { exact (andER (G c= U) (finite G) HGleft). }
        exact (finite_countable G HGfin).
    - let x. assume HxX: x :e X.
      prove exists u:set, u :e G /\ x :e u.
      claim HXsub: X c= Union G.
      { exact (andER (G c= U /\ finite G) (X c= Union G) HG). }
      claim HxUnion: x :e Union G.
      { exact (HXsub x HxX). }
      apply (UnionE G x HxUnion).
      let u. assume Hux: x :e u /\ u :e G.
      witness u.
      apply andI.
      + exact (andER (x :e u) (u :e G) Hux).
      + exact (andEL (x :e u) (u :e G) Hux). }
prove topology_on X Tx /\
  exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
apply andI.
- exact (compact_space_topology X Tx Hcomp).
- (** build a countable basis from finite ball subcovers at radii eps_(n+1) **)
  claim HTx: topology_on X Tx.
  { exact (compact_space_topology X Tx Hcomp). }

  set BallCover : set -> set := fun N:set => {open_ball X d x (eps_ N)|x :e X}.
  set Vsel : set -> set :=
    fun N:set => Eps_i (fun V:set => V c= BallCover N /\ finite V /\ X c= Union V).

  claim HVsel_spec: forall N:set, N :e omega ->
    Vsel N c= BallCover N /\ finite (Vsel N) /\ X c= Union (Vsel N).
  { let N. assume HNomega: N :e omega.
    prove Vsel N c= BallCover N /\ finite (Vsel N) /\ X c= Union (Vsel N).
    claim HepsR: eps_ N :e R.
    { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
    claim HepsPosS: 0 < eps_ N.
    { exact (SNo_eps_pos N HNomega). }
    claim HepsPos: Rlt 0 (eps_ N).
    { exact (RltI 0 (eps_ N) real_0 HepsR HepsPosS). }

    claim HcovOf: open_cover_of X Tx (BallCover N).
    { prove topology_on X Tx /\ BallCover N c= Power X /\ X c= Union (BallCover N) /\
        (forall U:set, U :e BallCover N -> U :e Tx).
      apply andI.
      - apply andI.
        + apply andI.
          * exact HTx.
          * let b. assume Hb: b :e BallCover N.
            prove b :e Power X.
            apply (ReplE_impred X (fun x0:set => open_ball X d x0 (eps_ N)) b Hb).
            let x0. assume Hx0X: x0 :e X.
            assume HbEq: b = open_ball X d x0 (eps_ N).
            rewrite HbEq.
            apply PowerI.
            exact (open_ball_subset_X X d x0 (eps_ N)).
        + let x0. assume Hx0X: x0 :e X.
          prove x0 :e Union (BallCover N).
          set b0 := open_ball X d x0 (eps_ N).
          claim Hb0In: b0 :e BallCover N.
          { exact (ReplI X (fun x1:set => open_ball X d x1 (eps_ N)) x0 Hx0X). }
          claim Hx0b0: x0 :e b0.
          { exact (center_in_open_ball X d x0 (eps_ N) Hd Hx0X HepsPos). }
          exact (UnionI (BallCover N) x0 b0 Hx0b0 Hb0In).
      - let b. assume Hb: b :e BallCover N.
        prove b :e Tx.
        apply (ReplE_impred X (fun x0:set => open_ball X d x0 (eps_ N)) b Hb).
        let x0. assume Hx0X: x0 :e X.
        assume HbEq: b = open_ball X d x0 (eps_ N).
        rewrite HbEq.
        claim HbIn: open_ball X d x0 (eps_ N) :e metric_topology X d.
        { exact (open_ball_in_metric_topology X d x0 (eps_ N) Hd Hx0X HepsPos). }
        rewrite HTdef.
        exact HbIn. }

    claim Hfin: has_finite_subcover X Tx (BallCover N).
    { exact (compact_space_subcover_property X Tx Hcomp (BallCover N) HcovOf). }
    exact (Eps_i_ex (fun V:set => V c= BallCover N /\ finite V /\ X c= Union V) Hfin). }

  (** B is the union of the finite subcovers Vsel(eps_(n+1)) packaged as a countable image **)
  set Pair := Sigma_ n :e omega, Vsel (ordsucc n).
  set B := {p 1|p :e Pair}.

  claim HBcount: countable_set B.
  { claim HomegaCount: countable_set omega.
    { prove countable_set omega.
      prove countable omega.
      exact (Subq_atleastp omega omega (Subq_ref omega)). }
    claim HPairCount: countable_set Pair.
    { set Y : set -> set := fun n:set => Vsel (ordsucc n).
      claim HY: forall n:set, n :e omega -> countable (Y n).
      { let n. assume Hn: n :e omega.
        claim Hsucc: ordsucc n :e omega.
        { exact (omega_ordsucc n Hn). }
        claim Hspec: Vsel (ordsucc n) c= BallCover (ordsucc n) /\ finite (Vsel (ordsucc n)) /\ X c= Union (Vsel (ordsucc n)).
        { exact (HVsel_spec (ordsucc n) Hsucc). }
        claim Hleft: Vsel (ordsucc n) c= BallCover (ordsucc n) /\ finite (Vsel (ordsucc n)).
        { exact (andEL (Vsel (ordsucc n) c= BallCover (ordsucc n) /\ finite (Vsel (ordsucc n)))
                       (X c= Union (Vsel (ordsucc n))) Hspec). }
        claim HfinV: finite (Vsel (ordsucc n)).
        { exact (andER (Vsel (ordsucc n) c= BallCover (ordsucc n))
                       (finite (Vsel (ordsucc n))) Hleft). }
        exact (finite_countable (Vsel (ordsucc n)) HfinV). }
      exact (Sigma_countable omega HomegaCount Y HY). }
    exact (countable_image Pair HPairCount (fun p:set => p 1)). }

  claim HBsub: B c= Power X.
  { let b. assume Hb: b :e B.
    prove b :e Power X.
    apply (ReplE_impred Pair (fun p:set => p 1) b Hb).
    let p. assume Hp: p :e Pair.
    assume HbEq: b = p 1.
    claim HnOmega: (p 0) :e omega.
    { exact (ap0_Sigma omega (fun n0:set => Vsel (ordsucc n0)) p Hp). }
    claim HbInV: (p 1) :e Vsel (ordsucc (p 0)).
    { exact (ap1_Sigma omega (fun n0:set => Vsel (ordsucc n0)) p Hp). }
    claim Hsucc: ordsucc (p 0) :e omega.
    { exact (omega_ordsucc (p 0) HnOmega). }
    claim Hspec: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))) /\ X c= Union (Vsel (ordsucc (p 0))).
    { exact (HVsel_spec (ordsucc (p 0)) Hsucc). }
    claim Hleft: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))).
    { exact (andEL (Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))))
                   (X c= Union (Vsel (ordsucc (p 0)))) Hspec). }
    claim HVsub: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)).
    { exact (andEL (Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)))
                   (finite (Vsel (ordsucc (p 0)))) Hleft). }
    claim HbCover: (p 1) :e BallCover (ordsucc (p 0)).
    { exact (HVsub (p 1) HbInV). }
    apply (ReplE X (fun x0:set => open_ball X d x0 (eps_ (ordsucc (p 0)))) (p 1) HbCover).
    let x0. assume Hx0pair: x0 :e X /\ (p 1) = open_ball X d x0 (eps_ (ordsucc (p 0))).
    claim Hbeq: (p 1) = open_ball X d x0 (eps_ (ordsucc (p 0))).
    { exact (andER (x0 :e X) ((p 1) = open_ball X d x0 (eps_ (ordsucc (p 0)))) Hx0pair). }
    rewrite HbEq.
    rewrite Hbeq.
    apply PowerI.
    exact (open_ball_subset_X X d x0 (eps_ (ordsucc (p 0)))). }

  claim HBrefines: basis_refines X B Tx.
  { prove topology_on X Tx /\
      (forall U :e Tx, forall x :e U, exists b :e B, x :e b /\ b c= U).
    apply andI.
    - exact HTx.
    - let U. assume HU: U :e Tx.
      prove forall x:set, x :e U -> exists b :e B, x :e b /\ b c= U.
      let x. assume HxU: x :e U.
      prove exists b :e B, x :e b /\ b c= U.
      claim HUPow: U :e Power X.
      { exact (topology_subset_axiom X Tx HTx U HU). }
      claim HxX: x :e X.
      { exact ((PowerE X U HUPow) x HxU). }
      claim HUmt: U :e metric_topology X d.
      { rewrite <- HTdef.
        exact HU. }
      claim HexBall: exists r:set, r :e R /\ (Rlt 0 r /\ open_ball X d x r c= U).
      { exact (metric_topology_neighborhood_contains_ball X d x U Hd HxX HUmt HxU). }
      apply HexBall.
      let r. assume Hrpack.
      claim HrR: r :e R.
      { exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
      claim Hrprop: Rlt 0 r /\ open_ball X d x r c= U.
      { exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
      claim Hrpos: Rlt 0 r.
      { exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
      claim Hballsub: open_ball X d x r c= U.
      { exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }

      (** pick N with eps_N < r and set s = eps_(N+1) so that s+s = eps_N < r **)
      claim HexN: exists N :e omega, eps_ N < r.
      { exact (exists_eps_lt_pos r HrR Hrpos). }
      apply HexN.
      let N. assume HNpair.
      claim HNomega: N :e omega.
      { exact (andEL (N :e omega) (eps_ N < r) HNpair). }
      claim HepsLt: eps_ N < r.
      { exact (andER (N :e omega) (eps_ N < r) HNpair). }
      set s := eps_ (ordsucc N).
      claim HsDef: s = eps_ (ordsucc N).
      { reflexivity. }
      claim HsuccOmega: ordsucc N :e omega.
      { exact (omega_ordsucc N HNomega). }
      claim HsR: s :e R.
      { rewrite HsDef.
        exact (SNoS_omega_real (eps_ (ordsucc N)) (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
      claim HsposS: 0 < s.
      { rewrite HsDef.
        exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
      claim Hspos: Rlt 0 s.
      { exact (RltI 0 s real_0 HsR HsposS). }
      claim HepsR: eps_ N :e R.
      { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
      claim HepsRlt: Rlt (eps_ N) r.
      { exact (RltI (eps_ N) r HepsR HrR HepsLt). }
      claim HsSumLt: Rlt (add_SNo s s) r.
      { claim HNnat: nat_p N.
        { exact (omega_nat_p N HNomega). }
        claim HsumEq: add_SNo s s = eps_ N.
        { rewrite HsDef.
          rewrite HsDef at 2.
          exact (eps_ordsucc_half_add N HNnat). }
        rewrite HsumEq.
        exact HepsRlt. }

      (** choose b in Vsel (N+1) with x ∈ b **)
      claim Hspec: Vsel (ordsucc N) c= BallCover (ordsucc N) /\ finite (Vsel (ordsucc N)) /\ X c= Union (Vsel (ordsucc N)).
      { exact (HVsel_spec (ordsucc N) HsuccOmega). }
      claim HXsub: X c= Union (Vsel (ordsucc N)).
      { exact (andER (Vsel (ordsucc N) c= BallCover (ordsucc N) /\ finite (Vsel (ordsucc N)))
                     (X c= Union (Vsel (ordsucc N))) Hspec). }
      claim HxUnion: x :e Union (Vsel (ordsucc N)).
      { exact (HXsub x HxX). }
      apply (UnionE (Vsel (ordsucc N)) x HxUnion).
      let b. assume Hbx: x :e b /\ b :e Vsel (ordsucc N).
      witness b.
      prove b :e B /\ (x :e b /\ b c= U).
      apply andI.
      * (** b :e B **)
        claim HbInV: b :e Vsel (ordsucc N).
        { exact (andER (x :e b) (b :e Vsel (ordsucc N)) Hbx). }
        claim HpSig: (N,b) :e Pair.
        { exact (tuple_2_Sigma omega (fun n0:set => Vsel (ordsucc n0)) N HNomega b HbInV). }
        claim HbEq1: (N,b) 1 = b.
        { exact (tuple_2_1_eq N b). }
        rewrite <- HbEq1 at 1.
        exact (ReplI Pair (fun p:set => p 1) (N,b) HpSig).
      * (** x :e b /\ b c= U **)
        apply andI.
        + exact (andEL (x :e b) (b :e Vsel (ordsucc N)) Hbx).
        + (** show b c= U using triangle inequality and s+s < r **)
          claim Hleft: Vsel (ordsucc N) c= BallCover (ordsucc N) /\ finite (Vsel (ordsucc N)).
          { exact (andEL (Vsel (ordsucc N) c= BallCover (ordsucc N) /\ finite (Vsel (ordsucc N)))
                         (X c= Union (Vsel (ordsucc N))) Hspec). }
          claim HVsub: Vsel (ordsucc N) c= BallCover (ordsucc N).
          { exact (andEL (Vsel (ordsucc N) c= BallCover (ordsucc N))
                         (finite (Vsel (ordsucc N))) Hleft). }
          claim HbCover: b :e BallCover (ordsucc N).
          { exact (HVsub b (andER (x :e b) (b :e Vsel (ordsucc N)) Hbx)). }
          apply (ReplE X (fun c0:set => open_ball X d c0 (eps_ (ordsucc N))) b HbCover).
          let c0. assume Hc0pair: c0 :e X /\ b = open_ball X d c0 (eps_ (ordsucc N)).
          claim Hc0X: c0 :e X.
          { exact (andEL (c0 :e X) (b = open_ball X d c0 (eps_ (ordsucc N))) Hc0pair). }
          claim HbDef: b = open_ball X d c0 (eps_ (ordsucc N)).
          { exact (andER (c0 :e X) (b = open_ball X d c0 (eps_ (ordsucc N))) Hc0pair). }
          claim HsubBall: b c= open_ball X d x r.
          { let y. assume Hy: y :e b.
            prove y :e open_ball X d x r.
            claim HyBall: y :e open_ball X d c0 (eps_ (ordsucc N)).
            { rewrite <- HbDef.
              exact Hy. }
            claim HyX: y :e X.
            { exact (open_ballE1 X d c0 (eps_ (ordsucc N)) y HyBall). }
            claim Hdy: Rlt (apply_fun d (c0,y)) (eps_ (ordsucc N)).
            { exact (open_ballE2 X d c0 (eps_ (ordsucc N)) y HyBall). }
            claim Hxinb: x :e open_ball X d c0 (eps_ (ordsucc N)).
            { rewrite <- HbDef.
              exact (andEL (x :e b) (b :e Vsel (ordsucc N)) Hbx). }
            claim Hdx0: Rlt (apply_fun d (c0,x)) (eps_ (ordsucc N)).
            { exact (open_ballE2 X d c0 (eps_ (ordsucc N)) x Hxinb). }
            claim Hsymxc: apply_fun d (x,c0) = apply_fun d (c0,x).
            { exact (metric_on_symmetric X d x c0 Hd HxX Hc0X). }
            claim Hdx: Rlt (apply_fun d (x,c0)) (eps_ (ordsucc N)).
            { rewrite Hsymxc.
              exact Hdx0. }
            set dx := apply_fun d (x,c0).
            set dy := apply_fun d (c0,y).
            claim HdFun: function_on d (setprod X X) R.
            { exact (metric_on_function_on X d Hd). }
            claim HdxR: dx :e R.
            { exact (HdFun (x,c0) (tuple_2_setprod_by_pair_Sigma X X x c0 HxX Hc0X)). }
            claim HdyR: dy :e R.
            { exact (HdFun (c0,y) (tuple_2_setprod_by_pair_Sigma X X c0 y Hc0X HyX)). }
            claim HdxS: SNo dx.
            { exact (real_SNo dx HdxR). }
            claim HdyS: SNo dy.
            { exact (real_SNo dy HdyR). }
            claim HsS: SNo s.
            { exact (real_SNo s HsR). }
            claim HdxLtS: dx < s.
            { rewrite HsDef.
              exact (RltE_lt dx (eps_ (ordsucc N)) Hdx). }
            claim HdyLtS: dy < s.
            { rewrite HsDef.
              exact (RltE_lt dy (eps_ (ordsucc N)) Hdy). }
            claim HsumLt: add_SNo dx dy < add_SNo s s.
            { exact (add_SNo_Lt3 dx dy s s HdxS HdyS HsS HsS HdxLtS HdyLtS). }
            claim HsumR: add_SNo dx dy :e R.
            { exact (real_add_SNo dx HdxR dy HdyR). }
            claim HsumRltR: Rlt (add_SNo dx dy) r.
            { claim HssumR: add_SNo s s :e R.
              { exact (real_add_SNo s HsR s HsR). }
              claim HsumRlt_ss: Rlt (add_SNo dx dy) (add_SNo s s).
              { exact (RltI (add_SNo dx dy) (add_SNo s s) HsumR HssumR HsumLt). }
              exact (Rlt_tra (add_SNo dx dy) (add_SNo s s) r HsumRlt_ss HsSumLt). }
            claim Htri: Rle (apply_fun d (x,y)) (add_SNo dx dy).
            { claim Htri0: Rle (apply_fun d (x,y))
                               (add_SNo (apply_fun d (x,c0)) (apply_fun d (c0,y))).
              { exact (metric_triangle_Rle X d x c0 y Hd HxX Hc0X HyX). }
              set tmp2 := add_SNo (apply_fun d (x,c0)) (apply_fun d (c0,y)).
              claim Htmp2Def: tmp2 = add_SNo dx dy.
              { reflexivity. }
              rewrite Htmp2Def.
              exact Htri0. }
            claim HdistRlt: Rlt (apply_fun d (x,y)) r.
            { exact (Rle_Rlt_tra (apply_fun d (x,y)) (add_SNo dx dy) r Htri HsumRltR). }
            exact (open_ballI X d x r y HyX HdistRlt). }
          exact (Subq_tra b (open_ball X d x r) U HsubBall Hballsub).
  }

  claim HBref: forall U :e Tx, forall x :e U, exists b :e B, x :e b /\ b c= U.
  { exact (andER (topology_on X Tx)
                 (forall U :e Tx, forall x :e U, exists b :e B, x :e b /\ b c= U)
                 HBrefines). }

  claim HBopen: forall b :e B, b :e Tx.
  { let b. assume Hb: b :e B.
    prove b :e Tx.
    apply (ReplE_impred Pair (fun p:set => p 1) b Hb).
    let p. assume Hp: p :e Pair.
    assume HbEq: b = p 1.
    claim HnOmega: (p 0) :e omega.
    { exact (ap0_Sigma omega (fun n0:set => Vsel (ordsucc n0)) p Hp). }
    claim HbInV: (p 1) :e Vsel (ordsucc (p 0)).
    { exact (ap1_Sigma omega (fun n0:set => Vsel (ordsucc n0)) p Hp). }
    claim Hsucc: ordsucc (p 0) :e omega.
    { exact (omega_ordsucc (p 0) HnOmega). }
    claim Hspec: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))) /\ X c= Union (Vsel (ordsucc (p 0))).
    { exact (HVsel_spec (ordsucc (p 0)) Hsucc). }
    claim Hleft: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))).
    { exact (andEL (Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)) /\ finite (Vsel (ordsucc (p 0))))
                   (X c= Union (Vsel (ordsucc (p 0)))) Hspec). }
    claim HVsub: Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)).
    { exact (andEL (Vsel (ordsucc (p 0)) c= BallCover (ordsucc (p 0)))
                   (finite (Vsel (ordsucc (p 0)))) Hleft). }
    claim HbCover: (p 1) :e BallCover (ordsucc (p 0)).
    { exact (HVsub (p 1) HbInV). }
    apply (ReplE X (fun x0:set => open_ball X d x0 (eps_ (ordsucc (p 0)))) (p 1) HbCover).
    let x0. assume Hx0pair: x0 :e X /\ (p 1) = open_ball X d x0 (eps_ (ordsucc (p 0))).
    claim Hx0X: x0 :e X.
    { exact (andEL (x0 :e X) ((p 1) = open_ball X d x0 (eps_ (ordsucc (p 0)))) Hx0pair). }
    claim HbBall: (p 1) = open_ball X d x0 (eps_ (ordsucc (p 0))).
    { exact (andER (x0 :e X) ((p 1) = open_ball X d x0 (eps_ (ordsucc (p 0)))) Hx0pair). }
    claim HepsR: eps_ (ordsucc (p 0)) :e R.
    { exact (SNoS_omega_real (eps_ (ordsucc (p 0))) (SNo_eps_SNoS_omega (ordsucc (p 0)) Hsucc)). }
    claim HepsPosS: 0 < eps_ (ordsucc (p 0)).
    { exact (SNo_eps_pos (ordsucc (p 0)) Hsucc). }
    claim HepsPos: Rlt 0 (eps_ (ordsucc (p 0))).
    { exact (RltI 0 (eps_ (ordsucc (p 0))) real_0 HepsR HepsPosS). }
    claim HbInMT: open_ball X d x0 (eps_ (ordsucc (p 0))) :e metric_topology X d.
    { exact (open_ball_in_metric_topology X d x0 (eps_ (ordsucc (p 0))) Hd Hx0X HepsPos). }
    rewrite HbEq.
    rewrite HbBall.
    rewrite HTdef.
    exact HbInMT. }

  claim HBasisEq: basis_on X B /\ generated_topology X B = Tx.
  { exact (basis_refines_topology X Tx B HTx HBopen HBref). }

  claim HBgenerates: basis_generates X B Tx.
  { exact HBasisEq. }

  witness B.
  prove basis_on X B /\ countable_set B /\ basis_generates X B Tx.
  apply andI.
  - apply andI.
    + exact (andEL (basis_on X B) (generated_topology X B = Tx) HBgenerates).
    + exact HBcount.
  - exact HBgenerates.
Qed.
(** from §30 Exercise 5a: metrizable with countable dense has countable basis **)
(** LATEX VERSION: Every metrizable space with a countable dense subset has a countable basis. **)
Theorem ex30_5a_metrizable_countable_dense_second_countable : forall X Tx:set,
  metrizable X Tx ->
  (exists D:set, D c= X /\ countable D /\ dense_in D X Tx) ->
  second_countable_space X Tx.
let X Tx.
assume Hmet: metrizable X Tx.
assume HexD: exists D:set, D c= X /\ countable D /\ dense_in D X Tx.
apply Hmet.
let d. assume Hdpair: metric_on X d /\ metric_topology X d = Tx.
claim Hm: metric_on X d.
{ exact (andEL (metric_on X d) (metric_topology X d = Tx) Hdpair). }
claim HTdef: metric_topology X d = Tx.
{ exact (andER (metric_on X d) (metric_topology X d = Tx) Hdpair). }
apply HexD.
let D. assume HDall: D c= X /\ countable D /\ dense_in D X Tx.
claim HDmid: (D c= X /\ countable D) /\ dense_in D X Tx.
{ exact HDall. }
claim HDleft: D c= X /\ countable D.
{ exact (andEL (D c= X /\ countable D) (dense_in D X Tx) HDmid). }
claim Hdense: dense_in D X Tx.
{ exact (andER (D c= X /\ countable D) (dense_in D X Tx) HDmid). }
claim HDsubX: D c= X.
{ exact (andEL (D c= X) (countable D) HDleft). }
claim HDcount: countable D.
{ exact (andER (D c= X) (countable D) HDleft). }

prove second_countable_space X Tx.
prove topology_on X Tx /\ exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
apply andI.
- (** topology_on X Tx **)
  prove topology_on X Tx.
  rewrite <- HTdef.
  exact (metric_topology_is_topology X d Hm).
- (** build a countable basis from a countable dense subset in a metric topology **)
  set Y : set -> set := fun _ : set => omega.
  set Pair := Sigma_ x0 :e D, Y x0.
  set F : set -> set := fun z:set => open_ball X d (z 0) (eps_ (ordsucc (z 1))).
  set B := {F z|z :e Pair}.

  (** countable_set B **)
  claim HomegaCount: countable_set omega.
  { prove countable_set omega.
    prove countable omega.
    exact (Subq_atleastp omega omega (Subq_ref omega)). }
  claim HDcountset: countable_set D.
  { exact HDcount. }
  claim HPairCount: countable_set Pair.
  { set Y0 : set -> set := fun _ : set => omega.
    claim HY0: forall x0:set, x0 :e D -> countable (Y0 x0).
    { let x0. assume _.
      exact HomegaCount. }
    exact (Sigma_countable D HDcountset Y0 HY0). }
  claim HBcount: countable_set B.
  { exact (countable_image Pair HPairCount F). }

  (** topology_on X Tx **)
  claim HTx: topology_on X Tx.
  { prove topology_on X Tx.
    rewrite <- HTdef.
    exact (metric_topology_is_topology X d Hm). }

  (** B refines Tx and consists of open sets **)
  claim HBsub: forall c :e B, c :e Tx.
  { let c. assume HcB: c :e B.
    prove c :e Tx.
    apply (ReplE_impred Pair F c HcB).
    let z. assume HzPair: z :e Pair.
    assume HcEq: c = F z.
    rewrite HcEq.
    set c0 := z 0.
    set n0 := z 1.
    claim Hc0D: c0 :e D.
    { exact (ap0_Sigma D Y z HzPair). }
    claim Hc0X: c0 :e X.
    { exact (HDsubX c0 Hc0D). }
    claim Hn0Omega: n0 :e omega.
    { exact (ap1_Sigma D Y z HzPair). }
    claim HsuccOmega: ordsucc n0 :e omega.
    { exact (omega_ordsucc n0 Hn0Omega). }
    claim HradR: eps_ (ordsucc n0) :e R.
    { exact (SNoS_omega_real (eps_ (ordsucc n0)) (SNo_eps_SNoS_omega (ordsucc n0) HsuccOmega)). }
    claim HradposS: 0 < eps_ (ordsucc n0).
    { exact (SNo_eps_pos (ordsucc n0) HsuccOmega). }
    claim Hradpos: Rlt 0 (eps_ (ordsucc n0)).
    { exact (RltI 0 (eps_ (ordsucc n0)) real_0 HradR HradposS). }
    claim HballIn: open_ball X d c0 (eps_ (ordsucc n0)) :e metric_topology X d.
    { exact (open_ball_in_metric_topology X d c0 (eps_ (ordsucc n0)) Hm Hc0X Hradpos). }
    rewrite <- HTdef.
    exact HballIn. }

  claim HBrefines: forall U :e Tx, forall x :e U, exists Cx :e B, x :e Cx /\ Cx c= U.
  { let U. assume HU: U :e Tx.
    let x. assume HxU: x :e U.
    prove exists Cx :e B, x :e Cx /\ Cx c= U.

    (** x :e X **)
    claim HTsub: Tx c= Power X.
    { exact (topology_subset_axiom X Tx HTx). }
    claim HUpow: U :e Power X.
    { exact (HTsub U HU). }
    claim HxX: x :e X.
    { exact (PowerE X U HUpow x HxU). }

    (** get a ball around x contained in U **)
    claim HexBall: exists r :e R, Rlt 0 r /\ open_ball X d x r c= U.
    { set B0 := famunion X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r}).
      claim Hdef: metric_topology X d = generated_topology X B0.
      { reflexivity. }
      claim HUgen: U :e generated_topology X B0.
      { prove U :e generated_topology X B0.
        rewrite <- Hdef.
        rewrite HTdef.
        exact HU. }
      claim HUcond: forall y :e U, exists b0 :e B0, y :e b0 /\ b0 c= U.
      { exact (SepE2 (Power X)
                     (fun U0:set => forall y:set, y :e U0 -> exists b0 :e B0, y :e b0 /\ b0 c= U0)
                     U HUgen). }
      claim Hexb0: exists b0 :e B0, x :e b0 /\ b0 c= U.
      { exact (HUcond x HxU). }
      apply Hexb0.
      let b0. assume Hb0pair.
      claim Hb0B0: b0 :e B0.
      { exact (andEL (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair). }
      claim Hxinb0: x :e b0.
      { exact (andEL (x :e b0) (b0 c= U)
                     (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
      claim Hb0sub: b0 c= U.
      { exact (andER (x :e b0) (b0 c= U)
                     (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
      apply (famunionE_impred X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r})
                              b0 Hb0B0
                              (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
      let c. assume HcX: c :e X.
      assume Hb0In: b0 :e {open_ball X d c r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0)
                              b0 Hb0In
                              (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
      let r0. assume Hr0R: r0 :e R.
      assume Hr0pos: Rlt 0 r0.
      assume Hb0eq: b0 = open_ball X d c r0.
      claim HxinBall: x :e open_ball X d c r0.
      { rewrite <- Hb0eq.
        exact Hxinb0. }
      claim HballsubU: open_ball X d c r0 c= U.
      { prove open_ball X d c r0 c= U.
        rewrite <- Hb0eq.
        exact Hb0sub. }
      claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r0.
      { exact (open_ball_refine_center X d c x r0 Hm HcX HxX Hr0R Hr0pos HxinBall). }
      apply Hexs.
      let s. assume Hs.
      claim HsRpos: s :e R /\ Rlt 0 s.
      { exact (andEL (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
      claim HsR: s :e R.
      { exact (andEL (s :e R) (Rlt 0 s) HsRpos). }
      claim Hspos: Rlt 0 s.
      { exact (andER (s :e R) (Rlt 0 s) HsRpos). }
      claim HsubBall: open_ball X d x s c= open_ball X d c r0.
      { exact (andER (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
      claim HsubU: open_ball X d x s c= U.
      { exact (Subq_tra (open_ball X d x s) (open_ball X d c r0) U HsubBall HballsubU). }
      witness s.
      apply andI.
      - exact HsR.
      - apply andI.
        + exact Hspos.
        + exact HsubU. }

    apply HexBall.
    let r. assume Hrpack.
    claim HrR: r :e R.
    { exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
    claim Hrprop: Rlt 0 r /\ open_ball X d x r c= U.
    { exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
    claim Hrpos: Rlt 0 r.
    { exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
    claim Hballsub: open_ball X d x r c= U.
    { exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }

    (** pick N with eps_N < r and set s = eps_(N+1) so that s+s = eps_N < r **)
    claim HexN: exists N :e omega, eps_ N < r.
    { exact (exists_eps_lt_pos r HrR Hrpos). }
    apply HexN.
    let N. assume HNpair.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega) (eps_ N < r) HNpair). }
    claim HepsLt: eps_ N < r.
    { exact (andER (N :e omega) (eps_ N < r) HNpair). }
    set s := eps_ (ordsucc N).
    claim HsDef: s = eps_ (ordsucc N).
    { reflexivity. }
    claim HsuccOmega: ordsucc N :e omega.
    { exact (omega_ordsucc N HNomega). }
    claim HsR: s :e R.
    { rewrite HsDef.
      exact (SNoS_omega_real (eps_ (ordsucc N)) (SNo_eps_SNoS_omega (ordsucc N) HsuccOmega)). }
    claim HsposS: 0 < s.
    { rewrite HsDef.
      exact (SNo_eps_pos (ordsucc N) HsuccOmega). }
    claim Hspos: Rlt 0 s.
    { exact (RltI 0 s real_0 HsR HsposS). }
    claim HepsR: eps_ N :e R.
    { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
    claim HepsRlt: Rlt (eps_ N) r.
    { exact (RltI (eps_ N) r HepsR HrR HepsLt). }
    claim HsSumLt: Rlt (add_SNo s s) r.
    { claim HNnat: nat_p N.
      { exact (omega_nat_p N HNomega). }
      claim HsumEq: add_SNo s s = eps_ N.
      { rewrite HsDef.
        rewrite HsDef at 2.
        exact (eps_ordsucc_half_add N HNnat). }
      rewrite HsumEq.
      exact HepsRlt. }

    (** dense set meets the s-ball around x **)
    set Ux := open_ball X d x s.
    claim HUxInTx: Ux :e Tx.
    { prove Ux :e Tx.
      rewrite <- HTdef.
      exact (open_ball_in_metric_topology X d x s Hm HxX Hspos). }
    claim HUxNe: Ux <> Empty.
    { exact (open_ball_nonempty X d x s Hm HxX Hspos). }
    claim HmeetNe: Ux :/\: D <> Empty.
    { exact (dense_in_meets_nonempty_open D X Tx Ux HTx Hdense HUxInTx HUxNe). }
    claim Hexd0: exists d0:set, d0 :e Ux :/\: D.
    { exact (nonempty_has_element (Ux :/\: D) HmeetNe). }
    apply Hexd0.
    let d0. assume Hd0cap: d0 :e Ux :/\: D.
    claim Hd0Ux: d0 :e Ux.
    { exact (binintersectE1 Ux D d0 Hd0cap). }
    claim Hd0D: d0 :e D.
    { exact (binintersectE2 Ux D d0 Hd0cap). }
    claim Hd0X: d0 :e X.
    { exact (HDsubX d0 Hd0D). }

    (** define Cx = open_ball around d0 with radius s, and show x ∈ Cx ⊆ U **)
    set Cx := open_ball X d d0 s.
    witness Cx.
    prove Cx :e B /\ (x :e Cx /\ Cx c= U).
    apply andI.
    - (** Cx :e B **)
      claim HNinY: N :e Y d0.
      { exact HNomega. }
      claim HpSig: (d0,N) :e Pair.
      { exact (tuple_2_Sigma D Y d0 Hd0D N HNinY). }
      claim HF: F (d0,N) = Cx.
      { prove F (d0,N) = Cx.
        claim HCxDef: Cx = open_ball X d d0 s.
        { reflexivity. }
        rewrite HCxDef.
        rewrite HsDef.
        claim HFdef: F (d0,N) = open_ball X d ((d0,N) 0) (eps_ (ordsucc ((d0,N) 1))).
        { reflexivity. }
        rewrite HFdef.
        rewrite (tuple_2_0_eq d0 N).
        rewrite (tuple_2_1_eq d0 N).
        reflexivity. }
      rewrite <- HF.
      exact (ReplI Pair F (d0,N) HpSig).
    - (** x :e Cx and Cx c= U **)
      apply andI.
      + (** x :e Cx **)
        claim Hd0inBall: d0 :e open_ball X d x s.
        { rewrite <- HsDef.
          exact Hd0Ux. }
        claim Hdxd0: Rlt (apply_fun d (x,d0)) s.
        { exact (open_ballE2 X d x s d0 Hd0inBall). }
        claim Hsym: apply_fun d (d0,x) = apply_fun d (x,d0).
        { exact (metric_on_symmetric X d d0 x Hm Hd0X HxX). }
        claim Hdx0: Rlt (apply_fun d (d0,x)) s.
        { rewrite Hsym.
          exact Hdxd0. }
        exact (open_ballI X d d0 s x HxX Hdx0).
      + (** Cx c= U **)
        claim HsubBall: Cx c= open_ball X d x r.
        { let y. assume Hy: y :e Cx.
          prove y :e open_ball X d x r.
          claim HyX: y :e X.
          { exact (open_ballE1 X d d0 s y Hy). }
          claim Hdy: Rlt (apply_fun d (d0,y)) s.
          { exact (open_ballE2 X d d0 s y Hy). }
          claim Hd0inBall: d0 :e open_ball X d x s.
          { rewrite <- HsDef.
            exact Hd0Ux. }
          claim Hdx: Rlt (apply_fun d (x,d0)) s.
          { exact (open_ballE2 X d x s d0 Hd0inBall). }
          set dx := apply_fun d (x,d0).
          set dy := apply_fun d (d0,y).
          claim HdFun: function_on d (setprod X X) R.
          { exact (metric_on_function_on X d Hm). }
          claim HdxR: dx :e R.
          { exact (HdFun (x,d0) (tuple_2_setprod_by_pair_Sigma X X x d0 HxX Hd0X)). }
          claim HdyR: dy :e R.
          { exact (HdFun (d0,y) (tuple_2_setprod_by_pair_Sigma X X d0 y Hd0X HyX)). }
          claim HdxS: SNo dx.
          { exact (real_SNo dx HdxR). }
          claim HdyS: SNo dy.
          { exact (real_SNo dy HdyR). }
          claim HsS: SNo s.
          { exact (real_SNo s HsR). }
          claim HdxLtS: dx < s.
          { exact (RltE_lt dx s Hdx). }
          claim HdyLtS: dy < s.
          { exact (RltE_lt dy s Hdy). }
          claim HsumLt: add_SNo dx dy < add_SNo s s.
          { exact (add_SNo_Lt3 dx dy s s HdxS HdyS HsS HsS HdxLtS HdyLtS). }
          claim HsumR: add_SNo dx dy :e R.
          { exact (real_add_SNo dx HdxR dy HdyR). }
          claim HsumRltR: Rlt (add_SNo dx dy) r.
          { claim HssumR: add_SNo s s :e R.
            { exact (real_add_SNo s HsR s HsR). }
            claim HsumRlt_ss: Rlt (add_SNo dx dy) (add_SNo s s).
            { exact (RltI (add_SNo dx dy) (add_SNo s s) HsumR HssumR HsumLt). }
            exact (Rlt_tra (add_SNo dx dy) (add_SNo s s) r HsumRlt_ss HsSumLt). }
          claim Htri: Rle (apply_fun d (x,y)) (add_SNo dx dy).
          { prove Rle (apply_fun d (x,y)) (add_SNo dx dy).
            claim Htri0: Rle (apply_fun d (x,y)) (add_SNo (apply_fun d (x,d0)) (apply_fun d (d0,y))).
            { exact (metric_triangle_Rle X d x d0 y Hm HxX Hd0X HyX). }
            set tmp2 := add_SNo (apply_fun d (x,d0)) (apply_fun d (d0,y)).
            claim Htmp2Def: tmp2 = add_SNo dx dy.
            { reflexivity. }
            rewrite Htmp2Def.
            exact Htri0. }
          claim HdistRlt: Rlt (apply_fun d (x,y)) r.
          { exact (Rle_Rlt_tra (apply_fun d (x,y)) (add_SNo dx dy) r Htri HsumRltR). }
          exact (open_ballI X d x r y HyX HdistRlt). }
        exact (Subq_tra Cx (open_ball X d x r) U HsubBall Hballsub). 
  }

  (** basis_on and equality with Tx **)
  claim HBasisEq: basis_on X B /\ generated_topology X B = Tx.
  { exact (basis_refines_topology X Tx B HTx HBsub HBrefines). }
  claim HBgenerates: basis_generates X B Tx.
  { prove basis_on X B /\ generated_topology X B = Tx.
    exact HBasisEq. }
  claim HBasis: basis_on X B.
  { exact (andEL (basis_on X B) (generated_topology X B = Tx) HBasisEq). }

  witness B.
  prove basis_on X B /\ countable_set B /\ basis_generates X B Tx.
  apply andI.
  - exact (andI (basis_on X B) (countable_set B) HBasis HBcount).
  - exact HBgenerates.
Qed.

(** from §30 Exercise 5b: metrizable Lindelof has countable basis **)
(** LATEX VERSION: Every metrizable Lindelöf space has a countable basis. **)
Theorem ex30_5b_metrizable_Lindelof_second_countable : forall X Tx:set,
  metrizable X Tx ->
  Lindelof_space X Tx ->
  second_countable_space X Tx.
let X Tx.
assume Hmet: metrizable X Tx.
assume HL: Lindelof_space X Tx.

(** extract metric presentation **)
apply Hmet.
let d. assume Hdpair: metric_on X d /\ metric_topology X d = Tx.
claim Hm: metric_on X d.
{ exact (andEL (metric_on X d) (metric_topology X d = Tx) Hdpair). }
claim HTdef: metric_topology X d = Tx.
{ exact (andER (metric_on X d) (metric_topology X d = Tx) Hdpair). }

(** Lindelof in metric topology (by rewriting Tx) **)
claim HLtop: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V)
               HL). }
claim HLprop: forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
{ exact (andER (topology_on X Tx)
               (forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V)
               HL). }

(** Build a countable dense subset using Lindelof for the ball covers of radii eps_N **)
set BallCover : set -> set := fun N:set => {open_ball X d x (eps_ N)|x :e X}.
set Vsel : set -> set := fun N:set =>
  Eps_i (fun V:set => countable_subcollection V (BallCover N) /\ covers X V).

claim HVsel_spec: forall N:set, N :e omega -> countable_subcollection (Vsel N) (BallCover N) /\ covers X (Vsel N).
{ let N. assume HNomega: N :e omega.
  prove countable_subcollection (Vsel N) (BallCover N) /\ covers X (Vsel N).
  claim HepsR: eps_ N :e R.
  { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
  claim HepsPosS: 0 < eps_ N.
  { exact (SNo_eps_pos N HNomega). }
  claim HepsPos: Rlt 0 (eps_ N).
  { exact (RltI 0 (eps_ N) real_0 HepsR HepsPosS). }

  claim HTx: topology_on X Tx.
  { exact HLtop. }
  claim HTm: topology_on X (metric_topology X d).
  { exact (metric_topology_is_topology X d Hm). }

  (** BallCover N is an open cover of X in Tx **)
  claim Hcover: open_cover X Tx (BallCover N).
  { prove (forall u:set, u :e BallCover N -> u :e Tx) /\ covers X (BallCover N).
    apply andI.
    - let u. assume Hu: u :e BallCover N.
      prove u :e Tx.
      apply (ReplE_impred X (fun x0:set => open_ball X d x0 (eps_ N)) u Hu).
      let x0. assume Hx0X: x0 :e X.
      assume HuEq: u = open_ball X d x0 (eps_ N).
      rewrite HuEq.
      claim HuIn: open_ball X d x0 (eps_ N) :e metric_topology X d.
      { exact (open_ball_in_metric_topology X d x0 (eps_ N) Hm Hx0X HepsPos). }
      rewrite <- HTdef.
      exact HuIn.
    - let x0. assume Hx0X: x0 :e X.
      prove exists u:set, u :e BallCover N /\ x0 :e u.
      witness (open_ball X d x0 (eps_ N)).
      apply andI.
      + exact (ReplI X (fun x1:set => open_ball X d x1 (eps_ N)) x0 Hx0X).
      + exact (center_in_open_ball X d x0 (eps_ N) Hm Hx0X HepsPos). }

  claim HexV: exists V:set, countable_subcollection V (BallCover N) /\ covers X V.
  { exact (HLprop (BallCover N) Hcover). }
  exact (Eps_i_ex (fun V:set => countable_subcollection V (BallCover N) /\ covers X V) HexV). }

set Pair := Sigma_ n :e omega, Vsel n.
set choose_center : set -> set := fun p:set =>
  Eps_i (fun c:set => c :e X /\ (p 1) = open_ball X d c (eps_ (p 0))).
set D0 := {choose_center p|p :e Pair}.

claim HD0count: countable_set D0.
{ (** Pair is countable; then D0 is countable image **)
  claim HomegaCount: countable_set omega.
  { prove countable_set omega.
    prove countable omega.
    exact (Subq_atleastp omega omega (Subq_ref omega)). }
  claim HPairCount: countable_set Pair.
  { set Y : set -> set := fun n:set => Vsel n.
    claim HY: forall n:set, n :e omega -> countable (Y n).
    { let n. assume Hn: n :e omega.
      claim Hspec: countable_subcollection (Vsel n) (BallCover n) /\ covers X (Vsel n).
      { exact (HVsel_spec n Hn). }
      claim Hsubcount: countable_subcollection (Vsel n) (BallCover n).
      { exact (andEL (countable_subcollection (Vsel n) (BallCover n))
                     (covers X (Vsel n)) Hspec). }
      exact (andER ((Vsel n) c= BallCover n) (countable_set (Vsel n)) Hsubcount). }
    exact (Sigma_countable omega HomegaCount Y HY). }
  exact (countable_image Pair HPairCount choose_center). }

claim HD0subX: D0 c= X.
{ let c. assume Hc: c :e D0.
  apply (ReplE_impred Pair choose_center c Hc).
  let p. assume Hp: p :e Pair.
  assume Hceq: c = choose_center p.
  claim HnOmega: (p 0) :e omega.
  { exact (ap0_Sigma omega (fun n:set => Vsel n) p Hp). }
  claim HbIn: (p 1) :e Vsel (p 0).
  { exact (ap1_Sigma omega (fun n:set => Vsel n) p Hp). }
  claim Hspec: countable_subcollection (Vsel (p 0)) (BallCover (p 0)) /\ covers X (Vsel (p 0)).
  { exact (HVsel_spec (p 0) HnOmega). }
  claim HVsub: (Vsel (p 0)) c= BallCover (p 0).
  { exact (andEL ((Vsel (p 0)) c= BallCover (p 0)) (countable_set (Vsel (p 0)))
                 (andEL (countable_subcollection (Vsel (p 0)) (BallCover (p 0)))
                        (covers X (Vsel (p 0))) Hspec)). }
  claim HbCover: (p 1) :e BallCover (p 0).
  { exact (HVsub (p 1) HbIn). }
  claim HexC: exists x0 :e X, (p 1) = open_ball X d x0 (eps_ (p 0)).
  { apply (ReplE X (fun x0:set => open_ball X d x0 (eps_ (p 0))) (p 1) HbCover). }
  apply HexC.
  let x0. assume Hx0pair.
  claim Hx0X: x0 :e X.
  { exact (andEL (x0 :e X) ((p 1) = open_ball X d x0 (eps_ (p 0))) Hx0pair). }
  claim HbEq: (p 1) = open_ball X d x0 (eps_ (p 0)).
  { exact (andER (x0 :e X) ((p 1) = open_ball X d x0 (eps_ (p 0))) Hx0pair). }
  claim HchooseSpec: choose_center p :e X /\ (p 1) = open_ball X d (choose_center p) (eps_ (p 0)).
  { claim HexC2: exists c0:set, c0 :e X /\ (p 1) = open_ball X d c0 (eps_ (p 0)).
    { witness x0.
      apply andI.
      - exact Hx0X.
      - exact HbEq. }
    exact (Eps_i_ex (fun c0:set => c0 :e X /\ (p 1) = open_ball X d c0 (eps_ (p 0))) HexC2). }
  rewrite Hceq.
  exact (andEL (choose_center p :e X) ((p 1) = open_ball X d (choose_center p) (eps_ (p 0))) HchooseSpec). }

claim HD0dense: dense_in D0 X Tx.
{ (** show closure_of X Tx D0 = X using neighborhood characterization **)
  prove closure_of X Tx D0 = X.
  apply set_ext.
  - exact (closure_in_space X Tx D0 HLtop).
 - let x. assume HxX: x :e X.
    prove x :e closure_of X Tx D0.
    claim Hcliff: x :e closure_of X Tx D0 <-> (forall U :e Tx, x :e U -> U :/\: D0 <> Empty).
    { exact (closure_characterization X Tx D0 x HLtop HxX). }
    claim Hneigh: forall U :e Tx, x :e U -> U :/\: D0 <> Empty.
    { let U. assume HU: U :e Tx.
      assume HxU: x :e U.

    (** get a ball around x contained in U **)
    claim HexBall: exists r :e R, Rlt 0 r /\ open_ball X d x r c= U.
    { set B0 := famunion X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r}).
      claim Hdef: metric_topology X d = generated_topology X B0.
      { reflexivity. }
      claim HUgen: U :e generated_topology X B0.
      { prove U :e generated_topology X B0.
        rewrite <- Hdef.
        rewrite HTdef.
        exact HU. }
      claim HUcond: forall y :e U, exists b0 :e B0, y :e b0 /\ b0 c= U.
      { exact (SepE2 (Power X)
                     (fun U0:set => forall y:set, y :e U0 -> exists b0 :e B0, y :e b0 /\ b0 c= U0)
                     U HUgen). }
      claim Hexb0: exists b0 :e B0, x :e b0 /\ b0 c= U.
      { exact (HUcond x HxU). }
      apply Hexb0.
      let b0. assume Hb0pair.
      claim Hb0B0: b0 :e B0.
      { exact (andEL (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair). }
      claim Hxinb0: x :e b0.
      { exact (andEL (x :e b0) (b0 c= U)
                     (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
      claim Hb0sub: b0 c= U.
      { exact (andER (x :e b0) (b0 c= U)
                     (andER (b0 :e B0) (x :e b0 /\ b0 c= U) Hb0pair)). }
      apply (famunionE_impred X (fun c:set => {open_ball X d c r|r :e R, Rlt 0 r})
                              b0 Hb0B0
                              (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
      let c. assume HcX: c :e X.
      assume Hb0In: b0 :e {open_ball X d c r|r :e R, Rlt 0 r}.
      apply (ReplSepE_impred R (fun r0:set => Rlt 0 r0) (fun r0:set => open_ball X d c r0)
                              b0 Hb0In
                              (exists r :e R, Rlt 0 r /\ open_ball X d x r c= U)).
      let r0. assume Hr0R: r0 :e R.
      assume Hr0pos: Rlt 0 r0.
      assume Hb0eq: b0 = open_ball X d c r0.
      claim HxinBall: x :e open_ball X d c r0.
      { rewrite <- Hb0eq.
        exact Hxinb0. }
      claim HballsubU: open_ball X d c r0 c= U.
      { prove open_ball X d c r0 c= U.
        rewrite <- Hb0eq.
        exact Hb0sub. }
      claim Hexs: exists s:set, s :e R /\ Rlt 0 s /\ open_ball X d x s c= open_ball X d c r0.
      { exact (open_ball_refine_center X d c x r0 Hm HcX HxX Hr0R Hr0pos HxinBall). }
      apply Hexs.
      let s. assume Hs.
      claim HsRpos: s :e R /\ Rlt 0 s.
      { exact (andEL (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
      claim HsR: s :e R.
      { exact (andEL (s :e R) (Rlt 0 s) HsRpos). }
      claim Hspos: Rlt 0 s.
      { exact (andER (s :e R) (Rlt 0 s) HsRpos). }
      claim HsubBall: open_ball X d x s c= open_ball X d c r0.
      { exact (andER (s :e R /\ Rlt 0 s) (open_ball X d x s c= open_ball X d c r0) Hs). }
      claim HsubU: open_ball X d x s c= U.
      { exact (Subq_tra (open_ball X d x s) (open_ball X d c r0) U HsubBall HballsubU). }
      witness s.
      apply andI.
      - exact HsR.
      - apply andI.
        + exact Hspos.
        + exact HsubU. }

    apply HexBall.
    let r. assume Hrpack.
    claim HrR: r :e R.
    { exact (andEL (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
    claim Hrprop: Rlt 0 r /\ open_ball X d x r c= U.
    { exact (andER (r :e R) (Rlt 0 r /\ open_ball X d x r c= U) Hrpack). }
    claim Hrpos: Rlt 0 r.
    { exact (andEL (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }
    claim Hballsub: open_ball X d x r c= U.
    { exact (andER (Rlt 0 r) (open_ball X d x r c= U) Hrprop). }

    (** choose N with eps_N < r **)
    claim HexN: exists N :e omega, eps_ N < r.
    { exact (exists_eps_lt_pos r HrR Hrpos). }
    apply HexN.
    let N. assume HNpair.
    claim HNomega: N :e omega.
    { exact (andEL (N :e omega) (eps_ N < r) HNpair). }
    claim HepsLt: eps_ N < r.
    { exact (andER (N :e omega) (eps_ N < r) HNpair). }
    claim HepsR: eps_ N :e R.
    { exact (SNoS_omega_real (eps_ N) (SNo_eps_SNoS_omega N HNomega)). }
    claim HepsRlt: Rlt (eps_ N) r.
    { exact (RltI (eps_ N) r HepsR HrR HepsLt). }

    (** pick b in the countable subcover Vsel N with x ∈ b **)
    claim Hspec: countable_subcollection (Vsel N) (BallCover N) /\ covers X (Vsel N).
    { exact (HVsel_spec N HNomega). }
    claim Hcov: covers X (Vsel N).
    { exact (andER (countable_subcollection (Vsel N) (BallCover N)) (covers X (Vsel N)) Hspec). }
    claim Hexb: exists b:set, b :e Vsel N /\ x :e b.
    { exact (Hcov x HxX). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbIn: b :e Vsel N.
    { exact (andEL (b :e Vsel N) (x :e b) Hbpair). }
    claim Hxb: x :e b.
    { exact (andER (b :e Vsel N) (x :e b) Hbpair). }
    (** b is a ball of radius eps_N **)
    claim Hsubcov: (Vsel N) c= BallCover N.
    { exact (andEL ((Vsel N) c= BallCover N) (countable_set (Vsel N))
                   (andEL (countable_subcollection (Vsel N) (BallCover N))
                          (covers X (Vsel N)) Hspec)). }
    claim HbCover: b :e BallCover N.
    { exact (Hsubcov b HbIn). }
    claim HexC: exists c0 :e X, b = open_ball X d c0 (eps_ N).
    { apply (ReplE X (fun x0:set => open_ball X d x0 (eps_ N)) b HbCover). }
    apply HexC.
    let c0. assume Hc0pair.
    claim Hc0X: c0 :e X.
    { exact (andEL (c0 :e X) (b = open_ball X d c0 (eps_ N)) Hc0pair). }
    claim HbEq: b = open_ball X d c0 (eps_ N).
    { exact (andER (c0 :e X) (b = open_ball X d c0 (eps_ N)) Hc0pair). }

    (** the chosen center is in D0 and lies in U **)
    claim HpSig: (N,b) :e Pair.
    { exact (tuple_2_Sigma omega (fun n0:set => Vsel n0) N HNomega b HbIn). }
    set c := choose_center (N,b).
    claim HcInD0: c :e D0.
    { exact (ReplI Pair choose_center (N,b) HpSig). }
    claim HchooseRaw: c :e X /\ ((N,b) 1) = open_ball X d c (eps_ ((N,b) 0)).
    { claim HexC2: exists c1:set, c1 :e X /\ ((N,b) 1) = open_ball X d c1 (eps_ ((N,b) 0)).
      { witness c0.
        apply andI.
        - exact Hc0X.
        - rewrite (tuple_2_1_eq N b).
          rewrite (tuple_2_0_eq N b).
          exact HbEq. }
      exact (Eps_i_ex (fun c1:set => c1 :e X /\ ((N,b) 1) = open_ball X d c1 (eps_ ((N,b) 0))) HexC2). }
    claim HcX: c :e X.
    { exact (andEL (c :e X) (((N,b) 1) = open_ball X d c (eps_ ((N,b) 0))) HchooseRaw). }
    claim HxInBall: x :e open_ball X d c (eps_ N).
    { prove x :e open_ball X d c (eps_ N).
      claim Htmp: ((N,b) 1) = open_ball X d c (eps_ ((N,b) 0)).
      { exact (andER (c :e X) (((N,b) 1) = open_ball X d c (eps_ ((N,b) 0))) HchooseRaw). }
      claim HxInb1: x :e ((N,b) 1).
      { prove x :e ((N,b) 1).
        rewrite (tuple_2_1_eq N b).
        exact Hxb. }
      claim HxInBall0: x :e open_ball X d c (eps_ ((N,b) 0)).
      { prove x :e open_ball X d c (eps_ ((N,b) 0)).
        rewrite <- Htmp.
        exact HxInb1. }
      claim HepsEq: eps_ ((N,b) 0) = eps_ N.
      { rewrite (tuple_2_0_eq N b).
        reflexivity. }
      rewrite <- HepsEq.
      exact HxInBall0. }
    claim Hdxc: Rlt (apply_fun d (c,x)) (eps_ N).
    { exact (open_ballE2 X d c (eps_ N) x HxInBall). }
    claim Hsym: apply_fun d (x,c) = apply_fun d (c,x).
    { exact (metric_on_symmetric X d x c Hm HxX HcX). }
    claim Hdxc2: Rlt (apply_fun d (x,c)) (eps_ N).
    { rewrite Hsym.
      exact Hdxc. }
    claim Hdxc3: Rlt (apply_fun d (x,c)) r.
    { exact (Rlt_tra (apply_fun d (x,c)) (eps_ N) r Hdxc2 HepsRlt). }
    claim HcInBallxr: c :e open_ball X d x r.
    { exact (open_ballI X d x r c HcX Hdxc3). }
    claim HcInU: c :e U.
    { exact (Hballsub c HcInBallxr). }
    prove U :/\: D0 <> Empty.
    claim Hwd: c :e U :/\: D0.
    { exact (binintersectI U D0 c HcInU HcInD0). }
    exact (elem_implies_nonempty (U :/\: D0) c Hwd). }
    exact (iffER (x :e closure_of X Tx D0) (forall U :e Tx, x :e U -> U :/\: D0 <> Empty) Hcliff Hneigh). }

(** now apply ex30_5a with the countable dense subset D0 **)
apply (ex30_5a_metrizable_countable_dense_second_countable X Tx).
- exact Hmet.
- witness D0.
  apply andI.
  * apply andI.
    + exact HD0subX.
    + exact HD0count.
  * exact HD0dense.
Qed.
(** from §30 Exercise 6a: R_l not metrizable **)
(** LATEX VERSION: The Sorgenfrey line ℝ_ℓ is not metrizable. **)
Theorem ex30_6a_Rl_not_metrizable :
  ~ metrizable R R_lower_limit_topology.
prove ~ metrizable R R_lower_limit_topology.
assume Hmet: metrizable R R_lower_limit_topology.
prove False.
claim HL: Lindelof_space R R_lower_limit_topology.
{ prove Lindelof_space R R_lower_limit_topology.
  claim Hline: Sorgenfrey_line = R.
  { reflexivity. }
  claim Htop: Sorgenfrey_topology = R_lower_limit_topology.
  { reflexivity. }
  rewrite <- Hline.
  rewrite <- Htop.
  exact Sorgenfrey_line_Lindelof. }
claim Hsc: second_countable_space R R_lower_limit_topology.
{ exact (ex30_5b_metrizable_Lindelof_second_countable R R_lower_limit_topology Hmet HL). }
claim HscS: second_countable_space Sorgenfrey_line Sorgenfrey_topology.
{ claim Hline: Sorgenfrey_line = R.
  { reflexivity. }
  claim Htop: Sorgenfrey_topology = R_lower_limit_topology.
  { reflexivity. }
  rewrite Hline.
  rewrite Htop.
  exact Hsc. }
exact (Sorgenfrey_line_not_second_countable HscS).
Qed.

(** from §30 Exercise 6b: ordered square not metrizable **)
(** LATEX VERSION: The ordered square is not metrizable. **)
Theorem ex30_6b_ordered_square_not_metrizable :
  ~ metrizable ordered_square ordered_square_topology.
admit. (** FAIL **)
Qed.
(** from §30 Exercise 7: countability axioms for S_Omega and Sbar_Omega **)
(** LATEX VERSION: Determine which countability axioms S_Ω and S̄_Ω satisfy. **)
(** Uses the existing SOmega_topology and SbarOmega_topology defined earlier in this section. **)
Theorem ex30_7_SOmega_Sbar_Omega_countability :
  (first_countable_space S_Omega SOmega_topology /\
   second_countable_space S_Omega SOmega_topology /\
   Lindelof_space S_Omega SOmega_topology /\
   (exists D:set, D c= S_Omega /\ countable D /\ dense_in D S_Omega SOmega_topology)) /\
  (first_countable_space Sbar_Omega SbarOmega_topology /\
   ~ second_countable_space Sbar_Omega SbarOmega_topology /\
   ~ Lindelof_space Sbar_Omega SbarOmega_topology /\
   ~ (exists D:set, D c= Sbar_Omega /\ countable D /\ dense_in D Sbar_Omega SbarOmega_topology)).
admit. (** FAIL **)
Qed.
(** from §30 Exercise 8: countability axioms for R^omega uniform topology **)
(** LATEX VERSION: Determine which countability axioms R^ω satisfies in the uniform topology. **)
Theorem ex30_8_Romega_uniform_countability :
  first_countable_space real_sequences uniform_topology /\
  ~ second_countable_space real_sequences uniform_topology /\
  ~ Lindelof_space real_sequences uniform_topology /\
  ~ (exists D:set, D c= real_sequences /\ countable D /\ dense_in D real_sequences uniform_topology).
admit. (** FAIL **)
Qed.
(** from §30 Exercise 9a: closed subspace of Lindelof is Lindelof **)
(** LATEX VERSION: If A is closed in Lindelöf space X, then A is Lindelöf. **)
Theorem ex30_9a_closed_Lindelof : forall X Tx A:set,
  Lindelof_space X Tx ->
  closed_in X Tx A ->
  Lindelof_space A (subspace_topology X Tx A).
let X Tx A.
assume HL: Lindelof_space X Tx.
assume Hclosed: closed_in X Tx A.
prove Lindelof_space A (subspace_topology X Tx A).
prove topology_on A (subspace_topology X Tx A) /\
  forall U:set, open_cover A (subspace_topology X Tx A) U ->
    exists V:set, countable_subcollection V U /\ covers A V.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                  exists V:set, countable_subcollection V U /\ covers X V)
               HL). }
claim HLprop: forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
{ exact (andER (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                  exists V:set, countable_subcollection V U /\ covers X V)
               HL). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A Hclosed). }
claim HexUc: exists Uc:set, Uc :e Tx /\ A = X :\: Uc.
{ exact (closed_in_exists_open_complement X Tx A Hclosed). }
set Uc := Eps_i (fun U0:set => U0 :e Tx /\ A = X :\: U0).
claim HUc: Uc :e Tx /\ A = X :\: Uc.
{ exact (Eps_i_ex (fun U0:set => U0 :e Tx /\ A = X :\: U0) HexUc). }
claim HUcTx: Uc :e Tx.
{ exact (andEL (Uc :e Tx) (A = X :\: Uc) HUc). }
claim HAeq: A = X :\: Uc.
{ exact (andER (Uc :e Tx) (A = X :\: Uc) HUc). }
claim HUcsubX: Uc c= X.
{ claim HUcPow: Uc :e Power X.
  { exact (topology_subset_axiom X Tx HTx Uc HUcTx). }
  exact (PowerE X Uc HUcPow). }
claim HXminusAeq: X :\: A = Uc.
{ rewrite HAeq at 1.
  exact (setminus_setminus_eq X Uc HUcsubX). }
claim HXminusAinTx: X :\: A :e Tx.
{ rewrite HXminusAeq.
  exact HUcTx. }
apply andI.
- exact (subspace_topology_is_topology X Tx A HTx HAsubX).
- let U.
  assume HcoverA: open_cover A (subspace_topology X Tx A) U.
  prove exists V:set, countable_subcollection V U /\ covers A V.
  claim HUmem: forall u:set, u :e U -> u :e subspace_topology X Tx A.
  { exact (andEL (forall u:set, u :e U -> u :e subspace_topology X Tx A)
                 (covers A U)
                 HcoverA). }
  claim HUAcover: covers A U.
  { exact (andER (forall u:set, u :e U -> u :e subspace_topology X Tx A)
                 (covers A U)
                 HcoverA). }
  set Wfam := {V :e Tx | V :/\: A :e U}.
  set Uext := Wfam :\/: {X :\: A}.
  claim HUext: open_cover X Tx Uext.
  { prove (forall u:set, u :e Uext -> u :e Tx) /\ covers X Uext.
    apply andI.
    - let u. assume Hu: u :e Uext.
      prove u :e Tx.
      apply (binunionE Wfam {X :\: A} u Hu).
      + assume HuW: u :e Wfam.
        exact (SepE1 Tx (fun V0:set => V0 :/\: A :e U) u HuW).
      + assume HuSing: u :e {X :\: A}.
        claim Hueq: u = X :\: A.
        { exact (SingE (X :\: A) u HuSing). }
        rewrite Hueq.
        exact HXminusAinTx.
    - prove covers X Uext.
      let x. assume HxX: x :e X.
      prove exists u:set, u :e Uext /\ x :e u.
      apply (xm (x :e A)).
      + assume HxA: x :e A.
        claim Hexu: exists u:set, u :e U /\ x :e u.
        { exact (HUAcover x HxA). }
        apply Hexu.
        let u. assume Hupair: u :e U /\ x :e u.
        claim HuU: u :e U.
        { exact (andEL (u :e U) (x :e u) Hupair). }
        claim Hxu: x :e u.
        { exact (andER (u :e U) (x :e u) Hupair). }
        claim HuSub: u :e subspace_topology X Tx A.
        { exact (HUmem u HuU). }
        claim HexV: exists V :e Tx, u = V :/\: A.
        { exact (subspace_topologyE X Tx A u HuSub). }
        apply HexV.
        let V. assume HVpair: V :e Tx /\ u = V :/\: A.
        claim HVTx: V :e Tx.
        { exact (andEL (V :e Tx) (u = V :/\: A) HVpair). }
        claim Hueq: u = V :/\: A.
        { exact (andER (V :e Tx) (u = V :/\: A) HVpair). }
        witness V.
        prove V :e Uext /\ x :e V.
        apply andI.
        * prove V :e Uext.
	          apply binunionI1.
	          prove V :e Wfam.
		          apply SepI.
		          - exact HVTx.
		          - claim HsubstU: forall S T:set, S = T -> S :e U -> T :e U.
		            { let S T.
		              assume HeqST: S = T.
		              assume HS: S :e U.
		              prove T :e U.
		              rewrite <- HeqST at 1.
		              exact HS. }
		            exact (HsubstU u (V :/\: A) Hueq HuU).
		        * claim HxVA: x :e V :/\: A.
		          { claim Hsubstx: forall S T:set, S = T -> x :e S -> x :e T.
		            { let S T.
		              assume HeqST: S = T.
		              assume HxS: x :e S.
		              prove x :e T.
		              rewrite <- HeqST at 1.
		              exact HxS. }
		            exact (Hsubstx u (V :/\: A) Hueq Hxu). }
		          exact (binintersectE1 V A x HxVA).
      + assume HxnotA: ~(x :e A).
        witness (X :\: A).
        apply andI.
        * apply binunionI2.
          exact (SingI (X :\: A)).
        * exact (setminusI X A x HxX HxnotA). }
  claim HexV0: exists V0:set, countable_subcollection V0 Uext /\ covers X V0.
  { exact (HLprop Uext HUext). }
  apply HexV0.
  let V0. assume HV0: countable_subcollection V0 Uext /\ covers X V0.
  claim HV0subcoll: countable_subcollection V0 Uext.
  { exact (andEL (countable_subcollection V0 Uext) (covers X V0) HV0). }
  claim HV0coversX: covers X V0.
  { exact (andER (countable_subcollection V0 Uext) (covers X V0) HV0). }
  claim HV0sub: V0 c= Uext.
  { exact (andEL (V0 c= Uext) (countable_set V0) HV0subcoll). }
  claim HV0count: countable_set V0.
  { exact (andER (V0 c= Uext) (countable_set V0) HV0subcoll). }
  set V1 := {V :e V0 | V <> X :\: A}.
  claim HV1subV0: V1 c= V0.
  { let V. assume HV: V :e V1.
    exact (SepE1 V0 (fun V0:set => V0 <> X :\: A) V HV). }
  claim HV1count: countable_set V1.
  { prove countable_set V1.
    exact (Subq_countable V1 V0 HV0count HV1subV0). }
  set V := {(W :/\: A) | W :e V1}.
  witness V.
  prove countable_subcollection V U /\ covers A V.
  apply andI.
  - prove countable_subcollection V U.
    prove V c= U /\ countable_set V.
    apply andI.
    + prove V c= U.
      let u. assume Hu: u :e V.
      prove u :e U.
      apply (ReplE V1 (fun W:set => W :/\: A) u Hu).
      let W. assume HWpair: W :e V1 /\ u = W :/\: A.
      claim HW: W :e V1.
      { exact (andEL (W :e V1) (u = W :/\: A) HWpair). }
      claim Hueq: u = W :/\: A.
      { exact (andER (W :e V1) (u = W :/\: A) HWpair). }
      claim HWV0: W :e V0.
      { exact (HV1subV0 W HW). }
      claim HWUext: W :e Uext.
      { exact (HV0sub W HWV0). }
      claim HWneq: W <> X :\: A.
      { exact (SepE2 V0 (fun V0:set => V0 <> X :\: A) W HW). }
      claim HWWfam: W :e Wfam.
      { prove W :e Wfam.
        apply (binunionE' Wfam {X :\: A} W (W :e Wfam)).
        - assume HWf: W :e Wfam.
          exact HWf.
        - assume HWsing: W :e {X :\: A}.
          claim HWa: W = X :\: A.
          { exact (SingE (X :\: A) W HWsing). }
          exact (FalseE (HWneq HWa) (W :e Wfam)).
        - exact HWUext. }
      claim HWintU: W :/\: A :e U.
      { exact (SepE2 Tx (fun V0:set => V0 :/\: A :e U) W HWWfam). }
      rewrite Hueq.
      exact HWintU.
    + exact (countable_image V1 HV1count (fun W:set => W :/\: A)).
  - prove covers A V.
    let x. assume HxA: x :e A.
    prove exists u:set, u :e V /\ x :e u.
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    claim HexW: exists W:set, W :e V0 /\ x :e W.
    { exact (HV0coversX x HxX). }
    apply HexW.
    let W. assume HWpair: W :e V0 /\ x :e W.
    claim HWV0: W :e V0.
    { exact (andEL (W :e V0) (x :e W) HWpair). }
    claim HxW: x :e W.
    { exact (andER (W :e V0) (x :e W) HWpair). }
    claim HWneq: W <> X :\: A.
    { assume HWa: W = X :\: A.
      claim Hxminus: x :e X :\: A.
      { rewrite <- HWa.
        exact HxW. }
      claim HxnotA: ~(x :e A).
      { exact (setminusE2 X A x Hxminus). }
      exact (HxnotA HxA). }
    claim HWV1: W :e V1.
    { apply SepI.
      - exact HWV0.
      - exact HWneq. }
    witness (W :/\: A).
    apply andI.
    + exact (ReplI V1 (fun W0:set => W0 :/\: A) W HWV1).
    + exact (binintersectI W A x HxW HxA).
Qed.

(** from §30 Exercise 9b: dense subspace need not have countable dense subset **)
(** LATEX VERSION: If X has countable dense subset, dense subspace A need not have one. **)
Theorem ex30_9b_dense_not_countable_dense :
  exists X:set, exists Tx:set, exists A:set,
    (exists D:set, D c= X /\ countable D /\ dense_in D X Tx) /\
    dense_in A X Tx /\
    ~ (exists DA:set, DA c= A /\ countable DA /\ dense_in DA A (subspace_topology X Tx A)).
admit. (** FAIL **)
Qed.

(** from §30 Exercise 10: countable product has countable dense if factors do **)
(** LATEX VERSION: If X is countable product of spaces with countable dense subsets, then X has one. **)
Theorem ex30_10_product_countable_dense : forall Idx:set, forall Fam:set,
  countable Idx ->
  (forall i:set, i :e Idx ->
    exists Xi:set, exists Txi:set, exists Di:set,
      apply_fun Fam i = (Xi, Txi) /\
      Di c= Xi /\ countable Di /\ dense_in Di Xi Txi) ->
  exists D:set,
    D c= product_space Idx Fam /\
    countable D /\
    dense_in D (product_space Idx Fam) (product_topology_full Idx Fam).
admit. (** FAIL **)
Qed.

(** from §30 Exercise 11a: continuous image of Lindelof is Lindelof **)
(** LATEX VERSION: If f:X→Y continuous and X Lindelöf, then f(X) is Lindelöf. **)
(** FIXED: Use image_of f X for the image set; apply_fun is for elements. **) 
Theorem ex30_11a_image_Lindelof : forall X Tx Y Ty f:set,
  Lindelof_space X Tx ->
  continuous_map X Tx Y Ty f ->
  Lindelof_space (image_of f X) (subspace_topology Y Ty (image_of f X)).
let X Tx Y Ty f.
assume HLX: Lindelof_space X Tx.
assume Hcont: continuous_map X Tx Y Ty f.
set Im := image_of f X.
prove Lindelof_space Im (subspace_topology Y Ty Im).
prove topology_on Im (subspace_topology Y Ty Im) /\
  forall U:set, open_cover Im (subspace_topology Y Ty Im) U ->
    exists V:set, countable_subcollection V U /\ covers Im V.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                  exists V:set, countable_subcollection V U /\ covers X V)
               HLX). }
claim HLXprop: forall U:set, open_cover X Tx U ->
  exists V:set, countable_subcollection V U /\ covers X V.
{ exact (andER (topology_on X Tx)
               (forall U:set, open_cover X Tx U ->
                  exists V:set, countable_subcollection V U /\ covers X V)
               HLX). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
apply andI.
- (** topology_on Im (subspace_topology Y Ty Im) **)
  claim HImsubY: Im c= Y.
  { exact (image_of_sub_codomain f X Y X Hfun (Subq_ref X)). }
  exact (subspace_topology_is_topology Y Ty Im HTy HImsubY).
- let U.
  assume HcoverIm: open_cover Im (subspace_topology Y Ty Im) U.
  prove exists V:set, countable_subcollection V U /\ covers Im V.
  claim HUmem: forall u:set, u :e U -> u :e subspace_topology Y Ty Im.
  { exact (andEL (forall u:set, u :e U -> u :e subspace_topology Y Ty Im)
                 (covers Im U)
                 HcoverIm). }
  claim HUcov: covers Im U.
  { exact (andER (forall u:set, u :e U -> u :e subspace_topology Y Ty Im)
                 (covers Im U)
                 HcoverIm). }
  set Wfam := {V :e Ty | V :/\: Im :e U}.
  set P := {preimage_of X f V | V :e Wfam}.
  claim HPcover: open_cover X Tx P.
  { prove (forall p:set, p :e P -> p :e Tx) /\ covers X P.
    apply andI.
    - let p. assume Hp: p :e P.
      prove p :e Tx.
      apply (ReplE_impred Wfam (fun V0:set => preimage_of X f V0) p Hp (p :e Tx)).
      let V0. assume HV0W: V0 :e Wfam.
      assume Hpeq: p = preimage_of X f V0.
      claim HV0Ty: V0 :e Ty.
      { exact (SepE1 Ty (fun V1:set => V1 :/\: Im :e U) V0 HV0W). }
      claim Hpre: preimage_of X f V0 :e Tx.
      { exact (continuous_map_preimage X Tx Y Ty f Hcont V0 HV0Ty). }
      rewrite Hpeq.
      exact Hpre.
    - prove covers X P.
      let x. assume HxX: x :e X.
      prove exists p:set, p :e P /\ x :e p.
      claim HfxIm: apply_fun f x :e Im.
      { exact (ReplI X (fun x0:set => apply_fun f x0) x HxX). }
      claim Hexu: exists u:set, u :e U /\ apply_fun f x :e u.
      { exact (HUcov (apply_fun f x) HfxIm). }
      apply Hexu.
      let u. assume Hupair: u :e U /\ apply_fun f x :e u.
      claim HuU: u :e U.
      { exact (andEL (u :e U) (apply_fun f x :e u) Hupair). }
      claim Hfxu: apply_fun f x :e u.
      { exact (andER (u :e U) (apply_fun f x :e u) Hupair). }
      claim HuSub: u :e subspace_topology Y Ty Im.
      { exact (HUmem u HuU). }
      claim HexV: exists V :e Ty, u = V :/\: Im.
      { exact (subspace_topologyE Y Ty Im u HuSub). }
      apply HexV.
      let V. assume HVpair: V :e Ty /\ u = V :/\: Im.
      claim HVTy: V :e Ty.
      { exact (andEL (V :e Ty) (u = V :/\: Im) HVpair). }
      claim Hueq: u = V :/\: Im.
      { exact (andER (V :e Ty) (u = V :/\: Im) HVpair). }
      claim HfxVIm: apply_fun f x :e V :/\: Im.
      { claim HsubstMem: forall S T:set, S = T -> apply_fun f x :e S -> apply_fun f x :e T.
        { let S T.
          assume HeqST: S = T.
          assume HyS: apply_fun f x :e S.
          prove apply_fun f x :e T.
          rewrite <- HeqST at 1.
          exact HyS. }
        exact (HsubstMem u (V :/\: Im) Hueq Hfxu). }
      claim HfxV: apply_fun f x :e V.
      { exact (binintersectE1 V Im (apply_fun f x) HfxVIm). }
      claim HxPre: x :e preimage_of X f V.
      { prove x :e {x0 :e X | apply_fun f x0 :e V}.
        apply SepI.
        - exact HxX.
        - exact HfxV. }
      claim HVWfam: V :e Wfam.
      { apply SepI.
        - exact HVTy.
        - claim HsubstU: forall S T:set, S = T -> S :e U -> T :e U.
          { let S T.
            assume HeqST: S = T.
            assume HS: S :e U.
            prove T :e U.
            rewrite <- HeqST at 1.
            exact HS. }
          exact (HsubstU u (V :/\: Im) Hueq HuU). }
      witness (preimage_of X f V).
      apply andI.
      + exact (ReplI Wfam (fun V0:set => preimage_of X f V0) V HVWfam).
      + exact HxPre. }
  claim HexP0: exists P0:set, countable_subcollection P0 P /\ covers X P0.
  { exact (HLXprop P HPcover). }
  apply HexP0.
  let P0. assume HP0: countable_subcollection P0 P /\ covers X P0.
  claim HP0subcoll: countable_subcollection P0 P.
  { exact (andEL (countable_subcollection P0 P) (covers X P0) HP0). }
  claim HP0covers: covers X P0.
  { exact (andER (countable_subcollection P0 P) (covers X P0) HP0). }
  claim HP0sub: P0 c= P.
  { exact (andEL (P0 c= P) (countable_set P0) HP0subcoll). }
  claim HP0count: countable_set P0.
  { exact (andER (P0 c= P) (countable_set P0) HP0subcoll). }
  set preV := (fun p:set => Eps_i (fun V:set => V :e Wfam /\ p = preimage_of X f V)).
  set W0 := {preV p|p :e P0}.
  claim HW0count: countable_set W0.
  { exact (countable_image P0 HP0count preV). }
  set V := {(W :/\: Im)|W :e W0}.
  witness V.
  prove countable_subcollection V U /\ covers Im V.
  apply andI.
  - prove countable_subcollection V U.
    prove V c= U /\ countable_set V.
    apply andI.
    + prove V c= U.
      let u. assume Hu: u :e V.
      prove u :e U.
      apply (ReplE_impred W0 (fun W:set => W :/\: Im) u Hu (u :e U)).
      let W. assume HW0: W :e W0.
      assume Hueq: u = W :/\: Im.
      apply (ReplE_impred P0 preV W HW0 (u :e U)).
      let p. assume Hp0: p :e P0.
      assume HWdef: W = preV p.
      claim Hueq2: u = preV p :/\: Im.
      { prove u = preV p :/\: Im.
        claim Hrhs: W :/\: Im = preV p :/\: Im.
        { rewrite HWdef.
          reflexivity. }
        rewrite <- Hrhs at 1.
        exact Hueq. }
      claim HpP: p :e P.
      { exact (HP0sub p Hp0). }
      claim HexWV: exists V0:set, V0 :e Wfam /\ p = preimage_of X f V0.
      { apply (ReplE_impred Wfam (fun V0:set => preimage_of X f V0) p HpP
               (exists V0:set, V0 :e Wfam /\ p = preimage_of X f V0)).
        let V0. assume HV0W: V0 :e Wfam.
        assume Hpeq: p = preimage_of X f V0.
        witness V0.
        exact (andI (V0 :e Wfam) (p = preimage_of X f V0) HV0W Hpeq). }
      claim HpreVprop: preV p :e Wfam /\ p = preimage_of X f (preV p).
      { exact (Eps_i_ex (fun V0:set => V0 :e Wfam /\ p = preimage_of X f V0) HexWV). }
      claim HWfam: preV p :e Wfam.
      { exact (andEL (preV p :e Wfam) (p = preimage_of X f (preV p)) HpreVprop). }
      claim HWinU: preV p :/\: Im :e U.
      { exact (SepE2 Ty (fun V0:set => V0 :/\: Im :e U) (preV p) HWfam). }
      claim HsubstEq: forall S T:set, S = T -> T :e U -> S :e U.
      { let S T.
        assume HeqST: S = T.
        assume HTU: T :e U.
        prove S :e U.
        rewrite HeqST at 1.
        exact HTU. }
      exact (HsubstEq u (preV p :/\: Im) Hueq2 HWinU).
    + claim HW0count2: countable_set W0.
      { exact HW0count. }
      exact (countable_image W0 HW0count2 (fun W:set => W :/\: Im)).
  - prove covers Im V.
    let y. assume HyIm: y :e Im.
    prove exists u:set, u :e V /\ y :e u.
    apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm
             (exists u:set, u :e V /\ y :e u)).
    let x. assume HxX: x :e X.
    assume Hyfx: y = apply_fun f x.
    claim Hexp: exists p:set, p :e P0 /\ x :e p.
    { exact (HP0covers x HxX). }
    apply Hexp.
    let p. assume Hppair: p :e P0 /\ x :e p.
    claim Hp0: p :e P0.
    { exact (andEL (p :e P0) (x :e p) Hppair). }
    claim Hxp: x :e p.
    { exact (andER (p :e P0) (x :e p) Hppair). }
    claim HpP: p :e P.
    { exact (HP0sub p Hp0). }
    claim HexWV: exists V0:set, V0 :e Wfam /\ p = preimage_of X f V0.
    { apply (ReplE_impred Wfam (fun V0:set => preimage_of X f V0) p HpP
             (exists V0:set, V0 :e Wfam /\ p = preimage_of X f V0)).
      let V0. assume HV0W: V0 :e Wfam.
      assume Hpeq: p = preimage_of X f V0.
      witness V0.
      exact (andI (V0 :e Wfam) (p = preimage_of X f V0) HV0W Hpeq). }
    claim HpreVprop: preV p :e Wfam /\ p = preimage_of X f (preV p).
    { exact (Eps_i_ex (fun V0:set => V0 :e Wfam /\ p = preimage_of X f V0) HexWV). }
    claim Hpeq: p = preimage_of X f (preV p).
    { exact (andER (preV p :e Wfam) (p = preimage_of X f (preV p)) HpreVprop). }
    claim HxPre: x :e preimage_of X f (preV p).
    { claim HsubstMem: forall S T:set, S = T -> x :e S -> x :e T.
      { let S T.
        assume HeqST: S = T.
        assume HxS: x :e S.
        prove x :e T.
        rewrite <- HeqST at 1.
        exact HxS. }
      exact (HsubstMem p (preimage_of X f (preV p)) Hpeq Hxp). }
    claim Hfyin: apply_fun f x :e preV p.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 :e preV p) x HxPre). }
    witness (preV p :/\: Im).
    apply andI.
    + exact (ReplI W0 (fun W:set => W :/\: Im) (preV p)
              (ReplI P0 preV p Hp0)).
	    + claim HyIm2: apply_fun f x :e Im.
	      { exact (ReplI X (fun x0:set => apply_fun f x0) x HxX). }
	      claim HyIn: apply_fun f x :e preV p :/\: Im.
	      { exact (binintersectI (preV p) Im (apply_fun f x) Hfyin HyIm2). }
	      claim HsubstEq2: forall S T:set, S = T -> T :e (preV p :/\: Im) -> S :e (preV p :/\: Im).
	      { let S T.
	        assume HeqST: S = T.
	        assume HT: T :e (preV p :/\: Im).
	        prove S :e (preV p :/\: Im).
	        rewrite HeqST at 1.
	        exact HT. }
	      exact (HsubstEq2 y (apply_fun f x) Hyfx HyIn).
Qed.

(** from §30 Exercise 11b: continuous image of separable is separable **)
(** LATEX VERSION: If f:X→Y continuous and X has countable dense subset, then f(X) does too. **)
(** FIXED: apply_fun f X should be image_of f X (same error pattern). **)
Theorem ex30_11b_image_countable_dense : forall X Tx Y Ty f:set,
  (exists D:set, D c= X /\ countable D /\ dense_in D X Tx) ->
  continuous_map X Tx Y Ty f ->
  exists Df:set,
    Df c= (image_of f X) /\
    countable Df /\
    dense_in Df (image_of f X) (subspace_topology Y Ty (image_of f X)).
let X Tx Y Ty f.
assume HexD: exists D:set, D c= X /\ countable D /\ dense_in D X Tx.
assume Hcont: continuous_map X Tx Y Ty f.
set Im := image_of f X.
apply HexD.
let D. assume HD: D c= X /\ countable D /\ dense_in D X Tx.
claim HDpair: D c= X /\ countable D.
{ exact (andEL (D c= X /\ countable D) (dense_in D X Tx) HD). }
claim HDsubX: D c= X.
{ exact (andEL (D c= X) (countable D) HDpair). }
claim HDcount: countable D.
{ exact (andER (D c= X) (countable D) HDpair). }
claim Hdense: dense_in D X Tx.
{ exact (andER (D c= X /\ countable D) (dense_in D X Tx) HD). }
set Df := image_of f D.
claim HTx: topology_on X Tx.
{ exact (continuous_map_topology_dom X Tx Y Ty f Hcont). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
claim HImsubY: Im c= Y.
{ exact (image_of_sub_codomain f X Y X Hfun (Subq_ref X)). }
witness Df.
prove Df c= Im /\ countable Df /\ dense_in Df Im (subspace_topology Y Ty Im).
apply andI.
- (** Df c= Im /\ countable Df **)
  apply andI.
  + (** Df c= Im **)
    exact (image_of_mono f D X HDsubX).
  + (** countable Df **)
    prove countable Df.
    claim HDcountset: countable_set D.
    { exact HDcount. }
    claim HcountDf: countable_set { (fun x:set => apply_fun f x) x | x :e D }.
    { exact (countable_image D HDcountset (fun x:set => apply_fun f x)). }
    exact HcountDf.
- (** dense_in Df Im (subspace_topology Y Ty Im) **)
  prove dense_in Df Im (subspace_topology Y Ty Im).
  prove closure_of Im (subspace_topology Y Ty Im) Df = Im.
  apply set_ext.
  + exact (closure_in_space Im (subspace_topology Y Ty Im) Df
            (subspace_topology_is_topology Y Ty Im HTy HImsubY)).
  + let y. assume HyIm: y :e Im.
    prove y :e closure_of Im (subspace_topology Y Ty Im) Df.
    claim HtopIm: topology_on Im (subspace_topology Y Ty Im).
    { exact (subspace_topology_is_topology Y Ty Im HTy HImsubY). }
    claim Hcliff: y :e closure_of Im (subspace_topology Y Ty Im) Df <->
      (forall V :e subspace_topology Y Ty Im, y :e V -> V :/\: Df <> Empty).
    { exact (closure_characterization Im (subspace_topology Y Ty Im) Df y HtopIm HyIm). }
    claim Hneigh: forall V :e subspace_topology Y Ty Im, y :e V -> V :/\: Df <> Empty.
    { let V. assume HV: V :e subspace_topology Y Ty Im.
      assume HyV: y :e V.
      prove V :/\: Df <> Empty.
      claim HexO: exists O :e Ty, V = O :/\: Im.
      { exact (subspace_topologyE Y Ty Im V HV). }
      apply HexO.
      let O. assume HOpair: O :e Ty /\ V = O :/\: Im.
      claim HOTy: O :e Ty.
      { exact (andEL (O :e Ty) (V = O :/\: Im) HOpair). }
      claim HVe: V = O :/\: Im.
      { exact (andER (O :e Ty) (V = O :/\: Im) HOpair). }
      claim HyOIm: y :e O :/\: Im.
      { claim HsubstMem: forall S T:set, S = T -> y :e S -> y :e T.
        { let S T.
          assume HeqST: S = T.
          assume HyS: y :e S.
          prove y :e T.
          rewrite <- HeqST at 1.
          exact HyS. }
        exact (HsubstMem V (O :/\: Im) HVe HyV). }
      claim HyO: y :e O.
      { exact (binintersectE1 O Im y HyOIm). }
      apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm (V :/\: Df <> Empty)).
      let x. assume HxX: x :e X.
      assume Hyfx: y = apply_fun f x.
      claim HfO: apply_fun f x :e O.
      { claim HsubstEq2: forall S T:set, S = T -> S :e O -> T :e O.
        { let S T.
          assume HeqST: S = T.
          assume HS: S :e O.
          prove T :e O.
          rewrite <- HeqST at 1.
          exact HS. }
        exact (HsubstEq2 y (apply_fun f x) Hyfx HyO). }
      set Upre := preimage_of X f O.
      claim HUpreTx: Upre :e Tx.
      { exact (continuous_map_preimage X Tx Y Ty f Hcont O HOTy). }
      claim HxUpre: x :e Upre.
      { prove x :e {x0 :e X | apply_fun f x0 :e O}.
        apply SepI.
        - exact HxX.
        - exact HfO. }
      claim HUprene: Upre <> Empty.
      { assume HUpreE: Upre = Empty.
        apply (EmptyE x).
        rewrite <- HUpreE at 1.
        exact HxUpre. }
      claim HUpreMeet: Upre :/\: D <> Empty.
      { exact (dense_in_meets_nonempty_open D X Tx Upre HTx Hdense HUpreTx HUprene). }
      claim Hexd: exists d:set, d :e Upre :/\: D.
      { exact (nonempty_has_element (Upre :/\: D) HUpreMeet). }
      apply Hexd.
      let d. assume HdUD: d :e Upre :/\: D.
      claim HdUpre: d :e Upre.
      { exact (binintersectE1 Upre D d HdUD). }
      claim HdD: d :e D.
      { exact (binintersectE2 Upre D d HdUD). }
      claim HdX: d :e X.
      { exact (HDsubX d HdD). }
      claim HfdO: apply_fun f d :e O.
      { exact (SepE2 X (fun x0:set => apply_fun f x0 :e O) d HdUpre). }
      claim HfdIm: apply_fun f d :e Im.
      { exact (ReplI X (fun x0:set => apply_fun f x0) d HdX). }
      claim HfdV: apply_fun f d :e V.
      { prove apply_fun f d :e V.
        claim HfdOIm: apply_fun f d :e O :/\: Im.
        { exact (binintersectI O Im (apply_fun f d) HfdO HfdIm). }
        claim HsubstMem2: forall S T:set, S = T -> apply_fun f d :e T -> apply_fun f d :e S.
        { let S T.
          assume HeqST: S = T.
          assume HT: apply_fun f d :e T.
          prove apply_fun f d :e S.
          rewrite HeqST at 1.
          exact HT. }
        exact (HsubstMem2 V (O :/\: Im) HVe HfdOIm). }
      claim HfdDf: apply_fun f d :e Df.
      { exact (ReplI D (fun x0:set => apply_fun f x0) d HdD). }
      claim HfdVDf: apply_fun f d :e V :/\: Df.
      { exact (binintersectI V Df (apply_fun f d) HfdV HfdDf). }
      assume HVE: V :/\: Df = Empty.
      claim Hcontra: apply_fun f d :e Empty.
      { rewrite <- HVE.
        exact HfdVDf. }
      exact ((EmptyE (apply_fun f d)) Hcontra). }
    exact (iffER (y :e closure_of Im (subspace_topology Y Ty Im) Df)
                 (forall V :e subspace_topology Y Ty Im, y :e V -> V :/\: Df <> Empty)
                 Hcliff
                 Hneigh).
Qed.

(** from §30 Exercise 12a: open continuous map preserves first countability **)
(** LATEX VERSION: If f:X→Y is continuous open and X first-countable, then f(X) is too. **)
(** FIXED: apply_fun f X should be image_of f X (same error pattern). **)
Theorem ex30_12a_open_map_first_countable : forall X Tx Y Ty f:set,
  first_countable_space X Tx ->
  continuous_map X Tx Y Ty f ->
  open_map X Tx Y Ty f ->
  first_countable_space (image_of f X) (subspace_topology Y Ty (image_of f X)).
let X Tx Y Ty f.
assume HX1: first_countable_space X Tx.
assume Hcont: continuous_map X Tx Y Ty f.
assume Hopenmap: open_map X Tx Y Ty f.
set Im := image_of f X.
prove first_countable_space Im (subspace_topology Y Ty Im).
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X -> countable_basis_at X Tx x)
               HX1). }
claim HX1prop: forall x:set, x :e X -> countable_basis_at X Tx x.
{ exact (andER (topology_on X Tx)
               (forall x:set, x :e X -> countable_basis_at X Tx x)
               HX1). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
claim HImsubY: Im c= Y.
{ exact (image_of_sub_codomain f X Y X Hfun (Subq_ref X)). }
claim HImTop: topology_on Im (subspace_topology Y Ty Im).
{ exact (subspace_topology_is_topology Y Ty Im HTy HImsubY). }
prove topology_on Im (subspace_topology Y Ty Im) /\
  forall y:set, y :e Im -> countable_basis_at Im (subspace_topology Y Ty Im) y.
apply andI.
- exact HImTop.
- let y. assume Hy: y :e Im.
  prove countable_basis_at Im (subspace_topology Y Ty Im) y.
  apply (ReplE_impred X (fun x0:set => apply_fun f x0) y Hy).
  let x0. assume Hx0X: x0 :e X.
  assume Hyeq: y = apply_fun f x0.
  claim Hbasis0: countable_basis_at X Tx x0.
  { exact (HX1prop x0 Hx0X). }
  claim HexBx: exists Bx:set,
    Bx c= Tx /\ countable_set Bx /\
      (forall b:set, b :e Bx -> x0 :e b) /\
      (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U).
  { exact (andER (topology_on X Tx /\ x0 :e X)
                 (exists Bx:set,
                   Bx c= Tx /\ countable_set Bx /\
                     (forall b:set, b :e Bx -> x0 :e b) /\
                     (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U))
                 Hbasis0). }
  apply HexBx.
  let Bx. assume HBx: Bx c= Tx /\ countable_set Bx /\
    (forall b:set, b :e Bx -> x0 :e b) /\
    (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U).
  claim HBxsubTx: Bx c= Tx.
  { apply (and4E (Bx c= Tx) (countable_set Bx)
                 (forall b:set, b :e Bx -> x0 :e b)
                 (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U)
                 HBx
                 (Bx c= Tx)).
    assume H1 H2 H3 H4.
    exact H1. }
  claim HBxcount: countable_set Bx.
  { apply (and4E (Bx c= Tx) (countable_set Bx)
                 (forall b:set, b :e Bx -> x0 :e b)
                 (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U)
                 HBx
                 (countable_set Bx)).
    assume H1 H2 H3 H4.
    exact H2. }
  claim HBxmem: forall b:set, b :e Bx -> x0 :e b.
  { apply (and4E (Bx c= Tx) (countable_set Bx)
                 (forall b:set, b :e Bx -> x0 :e b)
                 (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U)
                 HBx
                 (forall b:set, b :e Bx -> x0 :e b)).
    assume H1 H2 H3 H4.
    exact H3. }
  claim HBxrefine: forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U.
  { apply (and4E (Bx c= Tx) (countable_set Bx)
                 (forall b:set, b :e Bx -> x0 :e b)
                 (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U)
                 HBx
                 (forall U:set, U :e Tx -> x0 :e U -> exists b:set, b :e Bx /\ b c= U)).
    assume H1 H2 H3 H4.
    exact H4. }

  set B := {image_of f b :/\: Im|b :e Bx}.
  prove topology_on Im (subspace_topology Y Ty Im) /\ y :e Im /\
    exists B0:set, B0 c= subspace_topology Y Ty Im /\ countable_set B0 /\
      (forall b0:set, b0 :e B0 -> y :e b0) /\
      (forall U:set, U :e subspace_topology Y Ty Im -> y :e U -> exists b0:set, b0 :e B0 /\ b0 c= U).
  apply and3I.
  * exact HImTop.
  * exact Hy.
  * witness B.
    apply and4I.
    + (** B c= subspace_topology Y Ty Im **)
      let b0. assume Hb0: b0 :e B.
      prove b0 :e subspace_topology Y Ty Im.
      apply (ReplE_impred Bx (fun b:set => image_of f b :/\: Im) b0 Hb0).
      let b. assume HbBx: b :e Bx.
      assume Hb0eq: b0 = image_of f b :/\: Im.
      claim HbTx: b :e Tx.
      { exact (HBxsubTx b HbBx). }
      claim HimgOpen: forall U:set, U :e Tx -> image_of f U :e Ty.
      { exact (andER ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
                     (forall U:set, U :e Tx -> image_of f U :e Ty)
                     Hopenmap). }
      claim HVTy: image_of f b :e Ty.
      { exact (HimgOpen b HbTx). }
      rewrite Hb0eq.
      exact (subspace_topologyI Y Ty Im (image_of f b) HVTy).
    + (** countable_set B **)
      exact (countable_image Bx HBxcount (fun b:set => image_of f b :/\: Im)).
    + (** every b in B contains y **)
      let b0. assume Hb0: b0 :e B.
      prove y :e b0.
      apply (ReplE_impred Bx (fun b:set => image_of f b :/\: Im) b0 Hb0).
      let b. assume HbBx: b :e Bx.
      assume Hb0eq: b0 = image_of f b :/\: Im.
      claim Hx0b: x0 :e b.
      { exact (HBxmem b HbBx). }
      claim Hyimg: y :e image_of f b.
      { rewrite Hyeq.
        exact (ReplI b (fun x:set => apply_fun f x) x0 Hx0b). }
      rewrite Hb0eq.
      exact (binintersectI (image_of f b) Im y Hyimg Hy).
    + (** refinement property **)
      let U. assume HU: U :e subspace_topology Y Ty Im.
      assume HyU: y :e U.
      prove exists b0:set, b0 :e B /\ b0 c= U.
      claim HexV: exists V :e Ty, U = V :/\: Im.
      { exact (subspace_topologyE Y Ty Im U HU). }
      apply HexV.
      let V. assume HVpair: V :e Ty /\ U = V :/\: Im.
      claim HV: V :e Ty.
      { exact (andEL (V :e Ty) (U = V :/\: Im) HVpair). }
      claim HUeq: U = V :/\: Im.
      { exact (andER (V :e Ty) (U = V :/\: Im) HVpair). }
      claim HyVIm: y :e V :/\: Im.
      { rewrite <- HUeq at 1.
        exact HyU. }
      claim HyV: y :e V.
      { exact (binintersectE1 V Im y HyVIm). }
      claim Hfx0V: apply_fun f x0 :e V.
      { rewrite <- Hyeq at 1.
        exact HyV. }
      claim Hx0pre: x0 :e preimage_of X f V.
      { exact (SepI X (fun x:set => apply_fun f x :e V) x0 Hx0X Hfx0V). }
      claim HpreTx: preimage_of X f V :e Tx.
      { exact (continuous_map_preimage X Tx Y Ty f Hcont V HV). }
      apply (HBxrefine (preimage_of X f V) HpreTx Hx0pre).
      let b. assume Hbpair: b :e Bx /\ b c= preimage_of X f V.
      claim HbBx: b :e Bx.
      { exact (andEL (b :e Bx) (b c= preimage_of X f V) Hbpair). }
      claim Hbsub: b c= preimage_of X f V.
      { exact (andER (b :e Bx) (b c= preimage_of X f V) Hbpair). }
      set b0 := image_of f b :/\: Im.
      witness b0.
      apply andI.
      - (** b0 :e B **)
        exact (ReplI Bx (fun b1:set => image_of f b1 :/\: Im) b HbBx).
      - (** b0 c= U **)
        prove b0 c= U.
        rewrite HUeq.
        apply (binintersect_Subq_max V Im b0).
        + (** b0 c= V **)
          claim Hb0subImg: b0 c= image_of f b.
          { exact (binintersect_Subq_1 (image_of f b) Im). }
          claim HimgsubV: image_of f b c= V.
          { let z. assume Hz: z :e image_of f b.
            prove z :e V.
            apply (ReplE_impred b (fun x1:set => apply_fun f x1) z Hz).
            let x1. assume Hx1b: x1 :e b.
            assume Hzeq: z = apply_fun f x1.
            claim Hx1pre: x1 :e preimage_of X f V.
            { exact (Hbsub x1 Hx1b). }
            claim Hfx1V: apply_fun f x1 :e V.
            { exact (SepE2 X (fun u:set => apply_fun f u :e V) x1 Hx1pre). }
            rewrite Hzeq.
            exact Hfx1V. }
          exact (Subq_tra b0 (image_of f b) V Hb0subImg HimgsubV).
        + exact (binintersect_Subq_2 (image_of f b) Im).
Qed.

(** from §30 Exercise 12b: open continuous map preserves second countability **)
(** LATEX VERSION: If f:X→Y is continuous open and X second-countable, then f(X) is too. **)
(** FIXED: apply_fun f X should be image_of f X (same error pattern). **)
Theorem ex30_12b_open_map_second_countable : forall X Tx Y Ty f:set,
  second_countable_space X Tx ->
  continuous_map X Tx Y Ty f ->
  open_map X Tx Y Ty f ->
  second_countable_space (image_of f X) (subspace_topology Y Ty (image_of f X)).
let X Tx Y Ty f.
assume Hsc: second_countable_space X Tx.
assume Hcont: continuous_map X Tx Y Ty f.
assume Hop: open_map X Tx Y Ty f.
set Im := image_of f X.
set TIm := subspace_topology Y Ty Im.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
claim HexB: exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx.
{ exact (andER (topology_on X Tx)
               (exists B:set, basis_on X B /\ countable_set B /\ basis_generates X B Tx)
               Hsc). }
claim HTy: topology_on Y Ty.
{ exact (continuous_map_topology_cod X Tx Y Ty f Hcont). }
claim Hfun: function_on f X Y.
{ exact (continuous_map_function_on X Tx Y Ty f Hcont). }
claim HImsubY: Im c= Y.
{ exact (image_of_sub_codomain f X Y X Hfun (Subq_ref X)). }
claim HTIm: topology_on Im TIm.
{ exact (subspace_topology_is_topology Y Ty Im HTy HImsubY). }
prove second_countable_space Im TIm.
prove topology_on Im TIm /\ exists B:set, basis_on Im B /\ countable_set B /\ basis_generates Im B TIm.
apply andI.
- exact HTIm.
- apply HexB.
  let Bx. assume HBxAll: basis_on X Bx /\ countable_set Bx /\ basis_generates X Bx Tx.
  claim HBxMid: (basis_on X Bx /\ countable_set Bx) /\ basis_generates X Bx Tx.
  { exact HBxAll. }
  claim HBxPair: basis_on X Bx /\ countable_set Bx.
  { exact (andEL (basis_on X Bx /\ countable_set Bx) (basis_generates X Bx Tx) HBxMid). }
  claim HBxBasis: basis_on X Bx.
  { exact (andEL (basis_on X Bx) (countable_set Bx) HBxPair). }
  claim HBxCount: countable_set Bx.
  { exact (andER (basis_on X Bx) (countable_set Bx) HBxPair). }
  claim HBxGener: basis_generates X Bx Tx.
  { exact (andER (basis_on X Bx /\ countable_set Bx) (basis_generates X Bx Tx) HBxMid). }
  claim HTxEq: generated_topology X Bx = Tx.
  { exact (andER (basis_on X Bx) (generated_topology X Bx = Tx) HBxGener). }
  set F : set -> set := fun b:set => image_of f b :/\: Im.
  set C := {F b | b :e Bx}.
  claim HCcount: countable_set C.
  { exact (countable_image Bx HBxCount F). }
  claim HopImg: forall U:set, U :e Tx -> image_of f U :e Ty.
  { apply (and4E (topology_on X Tx) (topology_on Y Ty) (function_on f X Y)
                 (forall U:set, U :e Tx -> image_of f U :e Ty)
                 Hop
                 (forall U:set, U :e Tx -> image_of f U :e Ty)).
    assume _ _ _ Himg.
    exact Himg. }
  claim HCsub: forall c :e C, c :e TIm.
  { let c. assume HcC: c :e C.
    apply (ReplE_impred Bx F c HcC).
    let b. assume HbBx: b :e Bx.
    assume Hceq: c = F b.
    prove c :e TIm.
    rewrite Hceq.
    claim HbGen: b :e generated_topology X Bx.
    { exact (generated_topology_contains_basis X Bx HBxBasis b HbBx). }
    claim HbTx: b :e Tx.
    { prove b :e Tx.
      rewrite <- HTxEq.
      exact HbGen. }
    claim HimgbTy: image_of f b :e Ty.
    { exact (HopImg b HbTx). }
    exact (subspace_topologyI Y Ty Im (image_of f b) HimgbTy). }
  claim HCref: forall U :e TIm, forall y :e U, exists Cx :e C, y :e Cx /\ Cx c= U.
  { let U. assume HU: U :e TIm.
    let y. assume HyU: y :e U.
    claim HexV: exists V :e Ty, U = V :/\: Im.
    { exact (subspace_topologyE Y Ty Im U HU). }
    apply HexV.
    let V. assume HVpair.
    claim HVTy: V :e Ty.
    { exact (andEL (V :e Ty) (U = V :/\: Im) HVpair). }
    claim HUDef: U = V :/\: Im.
    { exact (andER (V :e Ty) (U = V :/\: Im) HVpair). }
    claim HyCap: y :e V :/\: Im.
    { prove y :e V :/\: Im.
      rewrite <- HUDef.
      exact HyU. }
    claim HyV: y :e V.
    { exact (binintersectE1 V Im y HyCap). }
    claim HyIm: y :e Im.
    { exact (binintersectE2 V Im y HyCap). }
    apply (ReplE_impred X (fun x0:set => apply_fun f x0) y HyIm).
    let x0. assume Hx0X: x0 :e X.
    assume HyEq: y = apply_fun f x0.
    set W := preimage_of X f V.
    claim HWDef: W = preimage_of X f V.
    { reflexivity. }
    claim Hfx0V: apply_fun f x0 :e V.
    { rewrite <- HyEq. exact HyV. }
    claim Hx0W: x0 :e W.
    { rewrite HWDef.
      exact (SepI X (fun u:set => apply_fun f u :e V) x0 Hx0X Hfx0V). }
    claim HWTx: W :e Tx.
    { exact (continuous_map_preimage X Tx Y Ty f Hcont V HVTy). }
    claim HWGen: W :e generated_topology X Bx.
    { prove W :e generated_topology X Bx.
      rewrite HTxEq.
      exact HWTx. }
    claim HWprop: forall x1 :e W, exists b :e Bx, x1 :e b /\ b c= W.
    { exact (SepE2 (Power X)
                  (fun U0:set => forall x1 :e U0, exists b :e Bx, x1 :e b /\ b c= U0)
                  W
                  HWGen). }
    claim Hexb: exists b :e Bx, x0 :e b /\ b c= W.
    { exact (HWprop x0 Hx0W). }
    apply Hexb.
    let b. assume Hbpair.
    claim HbBx: b :e Bx.
    { exact (andEL (b :e Bx) (x0 :e b /\ b c= W) Hbpair). }
    claim Hbprop: x0 :e b /\ b c= W.
    { exact (andER (b :e Bx) (x0 :e b /\ b c= W) Hbpair). }
    claim Hx0b: x0 :e b.
    { exact (andEL (x0 :e b) (b c= W) Hbprop). }
    claim HbsubW: b c= W.
    { exact (andER (x0 :e b) (b c= W) Hbprop). }
    set Cx := F b.
    witness Cx.
    apply andI.
    - prove Cx :e C.
      exact (ReplI Bx F b HbBx).
    - apply andI.
      + prove y :e Cx.
        prove y :e image_of f b :/\: Im.
        apply binintersectI (image_of f b) Im y.
        * prove y :e image_of f b.
          rewrite HyEq.
          exact (ReplI b (fun u:set => apply_fun f u) x0 Hx0b).
        * exact HyIm.
      + prove Cx c= U.
        rewrite HUDef.
        prove Cx c= V :/\: Im.
        let z. assume Hz: z :e Cx.
        prove z :e V :/\: Im.
        claim HzImg: z :e image_of f b.
        { exact (binintersectE1 (image_of f b) Im z Hz). }
        claim HzIm: z :e Im.
        { exact (binintersectE2 (image_of f b) Im z Hz). }
        claim HimgsubV: image_of f b c= V.
        { let z0. assume Hz0: z0 :e image_of f b.
          prove z0 :e V.
          apply (ReplE_impred b (fun u:set => apply_fun f u) z0 Hz0).
          let x1. assume Hx1b: x1 :e b.
          assume Hz0eq: z0 = apply_fun f x1.
          claim Hx1W: x1 :e W.
          { exact (HbsubW x1 Hx1b). }
          claim Hfx1V: apply_fun f x1 :e V.
          { exact (SepE2 X (fun u:set => apply_fun f u :e V) x1 Hx1W). }
          rewrite Hz0eq.
          exact Hfx1V. }
        apply binintersectI V Im z.
        * exact (HimgsubV z HzImg).
        * exact HzIm. }
  claim HCBasisEq: basis_on Im C /\ generated_topology Im C = TIm.
  { exact (basis_refines_topology Im TIm C HTIm HCsub HCref). }
  claim HCBasis: basis_on Im C.
  { exact (andEL (basis_on Im C) (generated_topology Im C = TIm) HCBasisEq). }
  claim HCEq: generated_topology Im C = TIm.
  { exact (andER (basis_on Im C) (generated_topology Im C = TIm) HCBasisEq). }
  witness C.
  prove basis_on Im C /\ countable_set C /\ basis_generates Im C TIm.
  (** left-associative conjunction: (basis_on /\ countable_set) /\ basis_generates **)
  apply andI.
  * apply andI.
    + exact HCBasis.
    + exact HCcount.
  * prove basis_generates Im C TIm.
    prove basis_on Im C /\ generated_topology Im C = TIm.
    apply andI.
    + exact HCBasis.
    + exact HCEq.
Qed.
(** from §30 Exercise 13: disjoint open sets countable when dense countable **)
(** LATEX VERSION: If X has countable dense subset, every collection of disjoint open sets in X is countable. **)
Theorem ex30_13_disjoint_open_sets_countable : forall X Tx:set,
  (exists D:set, D c= X /\ countable D /\ dense_in D X Tx) ->
  forall Fam:set,
    (forall U:set, U :e Fam -> open_in X Tx U) ->
    (forall U V:set, U :e Fam -> V :e Fam -> U <> V -> U :/\: V = Empty) ->
    countable Fam.
let X Tx.
assume HexD: exists D:set, D c= X /\ countable D /\ dense_in D X Tx.
let Fam.
assume Hopen: forall U:set, U :e Fam -> open_in X Tx U.
assume Hdisj: forall U V:set, U :e Fam -> V :e Fam -> U <> V -> U :/\: V = Empty.
apply HexD.
let D. assume HD: D c= X /\ countable D /\ dense_in D X Tx.
claim HDpair: D c= X /\ countable D.
{ exact (andEL (D c= X /\ countable D) (dense_in D X Tx) HD). }
claim Hdense: dense_in D X Tx.
{ exact (andER (D c= X /\ countable D) (dense_in D X Tx) HD). }
claim HDsubX: D c= X.
{ exact (andEL (D c= X) (countable D) HDpair). }
claim HDcount: countable D.
{ exact (andER (D c= X) (countable D) HDpair). }
set Fam0 := {U :e Fam | U <> Empty}.
set choose : set -> set := fun U:set => Eps_i (fun d:set => d :e D /\ d :e U).
claim HAtleast: atleastp Fam0 D.
{ prove exists f : set -> set, inj Fam0 D f.
  witness choose.
  apply (injI Fam0 D choose).
  - let U. assume HU0: U :e Fam0.
    prove choose U :e D.
    claim HUFam: U :e Fam.
    { exact (SepE1 Fam (fun U0:set => U0 <> Empty) U HU0). }
    claim HUne: U <> Empty.
    { exact (SepE2 Fam (fun U0:set => U0 <> Empty) U HU0). }
    claim HopenU: open_in X Tx U.
    { exact (Hopen U HUFam). }
    claim HTx: topology_on X Tx.
    { exact (andEL (topology_on X Tx) (U :e Tx) HopenU). }
    claim HUinTx: U :e Tx.
    { exact (andER (topology_on X Tx) (U :e Tx) HopenU). }
    claim HUmeet: U :/\: D <> Empty.
    { exact (dense_in_meets_nonempty_open D X Tx U HTx Hdense HUinTx HUne). }
    claim Hexd: exists d:set, d :e U :/\: D.
    { exact (nonempty_has_element (U :/\: D) HUmeet). }
    claim Hexd2: exists d:set, d :e D /\ d :e U.
    { apply Hexd.
      let d. assume HdUD: d :e U :/\: D.
      witness d.
      apply andI.
      - exact (binintersectE2 U D d HdUD).
      - exact (binintersectE1 U D d HdUD). }
    claim Hchooseprop: choose U :e D /\ choose U :e U.
    { exact (Eps_i_ex (fun d:set => d :e D /\ d :e U) Hexd2). }
    exact (andEL (choose U :e D) (choose U :e U) Hchooseprop).
  - let U. assume HU0: U :e Fam0.
	    let V. assume HV0: V :e Fam0.
	    assume Heq: choose U = choose V.
	    prove U = V.
	    apply dneg.
	    assume HUVneq: ~(U = V).
	    prove False.
	      claim HUFam: U :e Fam.
	      { exact (SepE1 Fam (fun U0:set => U0 <> Empty) U HU0). }
	      claim HVFam: V :e Fam.
	      { exact (SepE1 Fam (fun U0:set => U0 <> Empty) V HV0). }
	      claim HdisjUV: U :/\: V = Empty.
	      { exact (Hdisj U V HUFam HVFam HUVneq). }
	      claim HUne: U <> Empty.
	      { exact (SepE2 Fam (fun U0:set => U0 <> Empty) U HU0). }
	      claim HVne: V <> Empty.
	      { exact (SepE2 Fam (fun U0:set => U0 <> Empty) V HV0). }
      claim HopenU: open_in X Tx U.
      { exact (Hopen U HUFam). }
      claim HopenV: open_in X Tx V.
      { exact (Hopen V HVFam). }
      claim HTx: topology_on X Tx.
      { exact (andEL (topology_on X Tx) (U :e Tx) HopenU). }
      claim HUVin: choose U :e U /\ choose V :e V.
      { claim HUinTx: U :e Tx.
        { exact (andER (topology_on X Tx) (U :e Tx) HopenU). }
        claim HVinTx: V :e Tx.
        { exact (andER (topology_on X Tx) (V :e Tx) HopenV). }
	        claim HUmeet: U :/\: D <> Empty.
	        { exact (dense_in_meets_nonempty_open D X Tx U HTx Hdense HUinTx HUne). }
	        claim HVmeet: V :/\: D <> Empty.
	        { exact (dense_in_meets_nonempty_open D X Tx V HTx Hdense HVinTx HVne). }
	        claim HexUD: exists d:set, d :e U :/\: D.
	        { exact (nonempty_has_element (U :/\: D) HUmeet). }
	        claim HexdU: exists d:set, d :e D /\ d :e U.
	        { apply HexUD.
	          let d. assume HdUD: d :e U :/\: D.
	          witness d.
	          apply andI.
	          - exact (binintersectE2 U D d HdUD).
	          - exact (binintersectE1 U D d HdUD). }
	        claim HexVD: exists d:set, d :e V :/\: D.
	        { exact (nonempty_has_element (V :/\: D) HVmeet). }
	        claim HexdV: exists d:set, d :e D /\ d :e V.
	        { apply HexVD.
	          let d. assume HdVD: d :e V :/\: D.
	          witness d.
	          apply andI.
	          - exact (binintersectE2 V D d HdVD).
	          - exact (binintersectE1 V D d HdVD). }
        claim HchooseU: choose U :e D /\ choose U :e U.
        { exact (Eps_i_ex (fun d:set => d :e D /\ d :e U) HexdU). }
        claim HchooseV: choose V :e D /\ choose V :e V.
        { exact (Eps_i_ex (fun d:set => d :e D /\ d :e V) HexdV). }
        apply andI.
        - exact (andER (choose U :e D) (choose U :e U) HchooseU).
        - exact (andER (choose V :e D) (choose V :e V) HchooseV). }
      claim HcU: choose U :e U.
      { exact (andEL (choose U :e U) (choose V :e V) HUVin). }
      claim HcV: choose V :e V.
      { exact (andER (choose U :e U) (choose V :e V) HUVin). }
      claim HcV2: choose U :e V.
      { claim Hsubst: forall S T:set, S = T -> T :e V -> S :e V.
        { let S T.
          assume HeqST: S = T.
          assume HT: T :e V.
          prove S :e V.
          rewrite HeqST at 1.
          exact HT. }
        exact (Hsubst (choose U) (choose V) Heq HcV). }
      claim HcUV: choose U :e U :/\: V.
      { exact (binintersectI U V (choose U) HcU HcV2). }
	      claim Hcontra: choose U :e Empty.
	      { rewrite <- HdisjUV.
	        exact HcUV. }
	      exact (EmptyE (choose U) Hcontra).
}
claim HcountFam0: countable Fam0.
{ exact (atleastp_tra Fam0 D omega HAtleast HDcount). }
claim HcountSing: countable {Empty}.
{ exact (finite_countable (Sing Empty) (Sing_finite Empty)). }
claim HcountUnion: countable (Fam0 :\/: {Empty}).
{ exact (binunion_countable Fam0 {Empty} HcountFam0 HcountSing). }
claim HFsub: Fam c= Fam0 :\/: {Empty}.
{ let U. assume HU: U :e Fam.
  prove U :e Fam0 :\/: {Empty}.
  apply (xm (U = Empty)).
  - assume HUe: U = Empty.
    apply binunionI2.
    rewrite HUe.
    exact (SingI Empty).
  - assume HUne: ~(U = Empty).
    apply binunionI1.
    apply SepI.
    + exact HU.
    + assume HE: U = Empty.
      exact (HUne HE). }
exact (Subq_countable Fam (Fam0 :\/: {Empty}) HcountUnion HFsub).
Qed.
(** from §30 Exercise 14: product of Lindelof with compact is Lindelof **)
(** LATEX VERSION: If X is Lindelöf and Y is compact, then X × Y is Lindelöf. **)
Theorem ex30_14_product_Lindelof_compact : forall X Tx Y Ty:set,
  Lindelof_space X Tx ->
  compact_space Y Ty ->
  Lindelof_space (setprod X Y) (product_topology X Tx Y Ty).
let X Tx Y Ty.
assume HX: Lindelof_space X Tx.
assume HY: compact_space Y Ty.
prove Lindelof_space (setprod X Y) (product_topology X Tx Y Ty).
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V)
               HX). }
claim HXprop: forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V.
{ exact (andER (topology_on X Tx)
               (forall U:set, open_cover X Tx U -> exists V:set, countable_subcollection V U /\ covers X V)
               HX). }
claim HTy: topology_on Y Ty.
{ exact (compact_space_topology Y Ty HY). }
prove topology_on (setprod X Y) (product_topology X Tx Y Ty) /\
  forall Cover:set,
    open_cover (setprod X Y) (product_topology X Tx Y Ty) Cover ->
    exists V:set, countable_subcollection V Cover /\ covers (setprod X Y) V.
apply andI.
- exact (product_topology_is_topology X Tx Y Ty HTx HTy).
- let Cover. assume HCover: open_cover (setprod X Y) (product_topology X Tx Y Ty) Cover.
  prove exists V:set, countable_subcollection V Cover /\ covers (setprod X Y) V.
  claim HCoverOpen: forall N0:set, N0 :e Cover -> N0 :e product_topology X Tx Y Ty.
  { exact (andEL (forall u:set, u :e Cover -> u :e product_topology X Tx Y Ty)
                 (covers (setprod X Y) Cover)
                 HCover). }
  claim HCoverCovers: covers (setprod X Y) Cover.
  { exact (andER (forall u:set, u :e Cover -> u :e product_topology X Tx Y Ty)
                 (covers (setprod X Y) Cover)
                 HCover). }

  set UFam := {U :e Tx|exists H:set, H c= Cover /\ finite H /\ setprod U Y c= Union H}.
  claim HUFamSubTx: UFam c= Tx.
  { let U. assume HU: U :e UFam.
    exact (SepE1 Tx (fun U0:set => exists H:set, H c= Cover /\ finite H /\ setprod U0 Y c= Union H) U HU). }
  claim HUFamCover: open_cover X Tx UFam.
  { prove (forall U:set, U :e UFam -> U :e Tx) /\ covers X UFam.
    apply andI.
    - let U. assume HU: U :e UFam.
      exact (HUFamSubTx U HU).
    - prove covers X UFam.
      let x. assume Hx: x :e X.
      prove exists U:set, U :e UFam /\ x :e U.
      (** Slice compactness argument: cover {x}×Y by finitely many members of Cover, then apply tube_lemma. **)
      claim HexSlice: exists H:set, H c= Cover /\ finite H /\ setprod {x} Y c= Union H.
      { (** Build an open cover of Y by second-coordinate slices coming from rectangles inside members of Cover. **)
        set B := product_subbasis X Tx Y Ty.
        claim HBasis: basis_on (setprod X Y) B.
        { exact (product_subbasis_is_basis X Tx Y Ty HTx HTy). }
        set VFam := {V :e Ty|exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V c= N0}.
        claim HVFamSubTy: VFam c= Ty.
        { let V. assume HV: V :e VFam.
          exact (SepE1 Ty (fun V0:set => exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V0 c= N0) V HV). }
        claim HTyPow: Ty c= Power Y.
        { exact (topology_subset_axiom Y Ty HTy). }
        claim HVFamPow: VFam c= Power Y.
        { let V. assume HV: V :e VFam.
          claim HVTy: V :e Ty.
          { exact (HVFamSubTy V HV). }
          exact (HTyPow V HVTy). }
        claim HYcovV: Y c= Union VFam.
        { let y. assume Hy: y :e Y.
          prove y :e Union VFam.
          set p := (x,y).
          claim HpXY: p :e setprod X Y.
          { exact (tuple_2_setprod_by_pair_Sigma X Y x y Hx Hy). }
          apply (HCoverCovers p HpXY).
          let N0. assume HN0pair: N0 :e Cover /\ p :e N0.
          claim HN0Cover: N0 :e Cover.
          { exact (andEL (N0 :e Cover) (p :e N0) HN0pair). }
          claim HpN0: p :e N0.
          { exact (andER (N0 :e Cover) (p :e N0) HN0pair). }
          claim HN0Top: N0 :e generated_topology (setprod X Y) B.
          { exact (HCoverOpen N0 HN0Cover). }
          claim HN0refine: forall q :e N0, exists b :e B, q :e b /\ b c= N0.
          { exact (SepE2 (Power (setprod X Y))
                         (fun U0:set => forall q :e U0, exists b :e B, q :e b /\ b c= U0)
                         N0 HN0Top). }
          claim Hexb: exists b :e B, p :e b /\ b c= N0.
          { exact (HN0refine p HpN0). }
          apply Hexb.
          let b. assume Hbpair.
          claim HbB: b :e B.
          { exact (andEL (b :e B) (p :e b /\ b c= N0) Hbpair). }
          claim Hbprop: p :e b /\ b c= N0.
          { exact (andER (b :e B) (p :e b /\ b c= N0) Hbpair). }
          claim Hpb: p :e b.
          { exact (andEL (p :e b) (b c= N0) Hbprop). }
          claim HbsubN0: b c= N0.
          { exact (andER (p :e b) (b c= N0) Hbprop). }
          apply (famunionE_impred Tx (fun U0:set => {rectangle_set U0 V0|V0 :e Ty}) b HbB).
          let U0. assume HU0Tx: U0 :e Tx.
          assume HbIn: b :e {rectangle_set U0 V0|V0 :e Ty}.
          apply (ReplE_impred Ty (fun V0:set => rectangle_set U0 V0) b HbIn).
          let V0. assume HV0Ty: V0 :e Ty.
          assume HbEq: b = rectangle_set U0 V0.
          claim HpUV: p :e setprod U0 V0.
          { prove p :e rectangle_set U0 V0.
            rewrite <- HbEq at 1.
            exact Hpb. }
          claim HpXY0: p :e setprod {x} {y}.
          { exact (tuple_2_setprod_by_pair_Sigma {x} {y} x y (SingI x) (SingI y)). }
          claim Hcoords: x :e U0 /\ y :e V0.
          { exact (setprod_coords_in x y U0 V0 p HpXY0 HpUV). }
          claim HxU0: x :e U0.
          { exact (andEL (x :e U0) (y :e V0) Hcoords). }
          claim HyV0: y :e V0.
          { exact (andER (x :e U0) (y :e V0) Hcoords). }
          claim HrectSub: setprod U0 V0 c= N0.
          { rewrite <- HbEq at 1.
            exact HbsubN0. }
          claim HV0Fam: V0 :e VFam.
          { apply (SepI Ty (fun V1:set => exists U1:set, U1 :e Tx /\ x :e U1 /\ exists N1:set, N1 :e Cover /\ setprod U1 V1 c= N1) V0 HV0Ty).
            witness U0.
            prove U0 :e Tx /\ x :e U0 /\ exists N1:set, N1 :e Cover /\ setprod U0 V0 c= N1.
            apply andI.
            - exact (andI (U0 :e Tx) (x :e U0) HU0Tx HxU0).
            - witness N0.
              exact (andI (N0 :e Cover) (setprod U0 V0 c= N0) HN0Cover HrectSub). }
          exact (UnionI VFam y V0 HyV0 HV0Fam). }
        claim HVFamCover: open_cover_of Y Ty VFam.
        { prove topology_on Y Ty /\ VFam c= Power Y /\ Y c= Union VFam /\ (forall U0:set, U0 :e VFam -> U0 :e Ty).
          apply andI.
          - apply andI.
            + apply andI.
              * exact HTy.
              * exact HVFamPow.
            + exact HYcovV.
          - let V. assume HV: V :e VFam.
            exact (HVFamSubTy V HV). }
        claim HfinV: has_finite_subcover Y Ty VFam.
        { exact (Heine_Borel_subcover Y Ty VFam HY HVFamCover). }
        apply HfinV.
        let G. assume HG: G c= VFam /\ finite G /\ Y c= Union G.
        claim HGsub: G c= VFam.
        { exact (andEL (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HG)). }
        claim HGfin: finite G.
        { exact (andER (G c= VFam) (finite G) (andEL (G c= VFam /\ finite G) (Y c= Union G) HG)). }
        claim HYcovG: Y c= Union G.
        { exact (andER (G c= VFam /\ finite G) (Y c= Union G) HG). }
        set pickU := fun V:set => Eps_i (fun U0:set => U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V c= N0).
        claim HpickU: forall V:set, V :e VFam -> pickU V :e Tx /\ x :e pickU V /\ exists N0:set, N0 :e Cover /\ setprod (pickU V) V c= N0.
        { let V. assume HV: V :e VFam.
          claim Hex: exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V c= N0.
          { exact (SepE2 Ty (fun V0:set => exists U0:set, U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V0 c= N0) V HV). }
          apply Hex.
          let U0. assume HU0: U0 :e Tx /\ x :e U0 /\ exists N0:set, N0 :e Cover /\ setprod U0 V c= N0.
          exact (Eps_i_ax (fun U1:set => U1 :e Tx /\ x :e U1 /\ exists N0:set, N0 :e Cover /\ setprod U1 V c= N0) U0 HU0). }
        set pickN := fun V:set => Eps_i (fun N0:set => N0 :e Cover /\ setprod (pickU V) V c= N0).
        claim HpickN: forall V:set, V :e VFam -> pickN V :e Cover /\ setprod (pickU V) V c= pickN V.
        { let V. assume HV: V :e VFam.
          claim Hprop: pickU V :e Tx /\ x :e pickU V /\ exists N0:set, N0 :e Cover /\ setprod (pickU V) V c= N0.
          { exact (HpickU V HV). }
          claim HexN: exists N0:set, N0 :e Cover /\ setprod (pickU V) V c= N0.
          { exact (andER (pickU V :e Tx /\ x :e pickU V) (exists N0:set, N0 :e Cover /\ setprod (pickU V) V c= N0) Hprop). }
          apply HexN.
          let N0. assume HN0: N0 :e Cover /\ setprod (pickU V) V c= N0.
          exact (Eps_i_ax (fun N1:set => N1 :e Cover /\ setprod (pickU V) V c= N1) N0 HN0). }
        set H := {pickN V|V :e G}.
        witness H.
        apply andI.
        - apply andI.
          + prove H c= Cover.
            let N0. assume HN0: N0 :e H.
            apply (ReplE_impred G (fun V0:set => pickN V0) N0 HN0).
            let V0. assume HV0G: V0 :e G.
            assume HN0Eq: N0 = pickN V0.
            claim HV0Fam: V0 :e VFam.
            { exact (HGsub V0 HV0G). }
            claim HNprop: pickN V0 :e Cover /\ setprod (pickU V0) V0 c= pickN V0.
            { exact (HpickN V0 HV0Fam). }
            claim HN0Cover: pickN V0 :e Cover.
            { exact (andEL (pickN V0 :e Cover) (setprod (pickU V0) V0 c= pickN V0) HNprop). }
            rewrite HN0Eq.
            exact HN0Cover.
          + exact (Repl_finite (fun V0:set => pickN V0) G HGfin).
        - prove setprod {x} Y c= Union H.
          let p. assume Hp: p :e setprod {x} Y.
          prove p :e Union H.
          claim Hp0: p 0 :e {x}.
          { exact (ap0_Sigma {x} (fun _:set => Y) p Hp). }
          claim Hp1: p 1 :e Y.
          { exact (ap1_Sigma {x} (fun _:set => Y) p Hp). }
          claim Hp0eq: p 0 = x.
          { exact (SingE x (p 0) Hp0). }
          claim HpEta: p = (p 0, p 1).
          { exact (setprod_eta {x} Y p Hp). }
          claim Hp1InUnion: p 1 :e Union G.
          { exact (HYcovG (p 1) Hp1). }
          apply (UnionE_impred G (p 1) Hp1InUnion).
          let V0. assume Hp1V0: p 1 :e V0.
          assume HV0G: V0 :e G.
          claim HV0Fam: V0 :e VFam.
          { exact (HGsub V0 HV0G). }
          claim HUN: pickU V0 :e Tx /\ x :e pickU V0 /\ exists N0:set, N0 :e Cover /\ setprod (pickU V0) V0 c= N0.
          { exact (HpickU V0 HV0Fam). }
          claim HUNAB: pickU V0 :e Tx /\ x :e pickU V0.
          { exact (andEL (pickU V0 :e Tx /\ x :e pickU V0)
                         (exists N0:set, N0 :e Cover /\ setprod (pickU V0) V0 c= N0)
                         HUN). }
          claim HxU: x :e pickU V0.
          { exact (andER (pickU V0 :e Tx) (x :e pickU V0) HUNAB). }
          claim HpInRect: (x, p 1) :e setprod (pickU V0) V0.
          { exact (tuple_2_setprod_by_pair_Sigma (pickU V0) V0 x (p 1) HxU Hp1V0). }
          claim HrectSub: setprod (pickU V0) V0 c= pickN V0.
          { exact (andER (pickN V0 :e Cover) (setprod (pickU V0) V0 c= pickN V0) (HpickN V0 HV0Fam)). }
          claim HpInN: (x, p 1) :e pickN V0.
          { exact (HrectSub (x, p 1) HpInRect). }
          claim HNinH: pickN V0 :e H.
          { exact (ReplI G (fun V1:set => pickN V1) V0 HV0G). }
          rewrite HpEta.
          rewrite Hp0eq at 1.
          exact (UnionI H (x, p 1) (pickN V0) HpInN HNinH). }
      apply HexSlice.
      let H. assume HH: H c= Cover /\ finite H /\ setprod {x} Y c= Union H.
      claim HHsub: H c= Cover.
      { exact (andEL (H c= Cover) (finite H) (andEL (H c= Cover /\ finite H) (setprod {x} Y c= Union H) HH)). }
      claim HHfin: finite H.
      { exact (andER (H c= Cover) (finite H) (andEL (H c= Cover /\ finite H) (setprod {x} Y c= Union H) HH)). }
      claim HHcov: setprod {x} Y c= Union H.
      { exact (andER (H c= Cover /\ finite H) (setprod {x} Y c= Union H) HH). }
      claim HHsubTop: H c= product_topology X Tx Y Ty.
      { let N0. assume HN0: N0 :e H.
        claim HN0Cover: N0 :e Cover.
        { exact (HHsub N0 HN0). }
        exact (HCoverOpen N0 HN0Cover). }
      claim HtopProd: topology_on (setprod X Y) (product_topology X Tx Y Ty).
      { exact (product_topology_is_topology X Tx Y Ty HTx HTy). }
      claim HNtop: Union H :e product_topology X Tx Y Ty.
      { exact (topology_union_closed (setprod X Y) (product_topology X Tx Y Ty) H HtopProd HHsubTop). }
      claim Htube: exists U:set, U :e Tx /\ x :e U /\ setprod U Y c= Union H.
      { exact (tube_lemma X Tx Y Ty HTx HTy HY x Hx (Union H)
                 (andI ((Union H) :e product_topology X Tx Y Ty) (setprod {x} Y c= Union H) HNtop HHcov)). }
      apply Htube.
      let U. assume HU: U :e Tx /\ x :e U /\ setprod U Y c= Union H.
      claim HUAB: U :e Tx /\ x :e U.
      { exact (andEL (U :e Tx /\ x :e U) (setprod U Y c= Union H) HU). }
      claim HUtx: U :e Tx.
      { exact (andEL (U :e Tx) (x :e U) HUAB). }
      claim HxU: x :e U.
      { exact (andER (U :e Tx) (x :e U) HUAB). }
      claim HUcov: setprod U Y c= Union H.
      { exact (andER (U :e Tx /\ x :e U) (setprod U Y c= Union H) HU). }
      witness U.
      apply andI.
      - apply (SepI Tx (fun U0:set => exists H0:set, H0 c= Cover /\ finite H0 /\ setprod U0 Y c= Union H0) U HUtx).
        witness H.
        exact (andI (H c= Cover /\ finite H) (setprod U Y c= Union H)
                    (andI (H c= Cover) (finite H) HHsub HHfin)
                    HUcov).
      - exact HxU. }

  claim HW: exists W:set, countable_subcollection W UFam /\ covers X W.
  { exact (HXprop UFam HUFamCover). }
  apply HW.
  let W. assume HWpair: countable_subcollection W UFam /\ covers X W.
  claim HWsub: W c= UFam.
  { exact (andEL (W c= UFam) (countable_set W)
                 (andEL (W c= UFam /\ countable_set W) (covers X W) HWpair)). }
  claim HWcount: countable_set W.
  { exact (andER (W c= UFam) (countable_set W)
                 (andEL (W c= UFam /\ countable_set W) (covers X W) HWpair)). }
  claim HWcov: covers X W.
  { exact (andER (W c= UFam /\ countable_set W) (covers X W) HWpair). }

  set pickH := fun U:set => Eps_i (fun H:set => H c= Cover /\ finite H /\ setprod U Y c= Union H).
  claim HpickH: forall U:set, U :e W -> pickH U c= Cover /\ finite (pickH U) /\ setprod U Y c= Union (pickH U).
  { let U. assume HU: U :e W.
    claim HUFam: U :e UFam.
    { exact (HWsub U HU). }
    claim Hex: exists H:set, H c= Cover /\ finite H /\ setprod U Y c= Union H.
    { exact (SepE2 Tx (fun U0:set => exists H:set, H c= Cover /\ finite H /\ setprod U0 Y c= Union H) U HUFam). }
    apply Hex.
    let H0. assume HH0: H0 c= Cover /\ finite H0 /\ setprod U Y c= Union H0.
    exact (Eps_i_ax (fun H:set => H c= Cover /\ finite H /\ setprod U Y c= Union H) H0 HH0). }

  set P := Sigma_ U :e W, pickH U.
  set V := {z 1|z :e P}.
  witness V.
  apply andI.
  - prove countable_subcollection V Cover.
    prove V c= Cover /\ countable_set V.
    apply andI.
    + (** V c= Cover **)
      let N. assume HN: N :e V.
      prove N :e Cover.
      apply (ReplE_impred P (fun z:set => z 1) N HN).
      let z. assume HzP: z :e P.
      assume HNeq: N = z 1.
      claim Hz0W: z 0 :e W.
      { exact (ap0_Sigma W (fun U0:set => pickH U0) z HzP). }
      claim Hz1In: z 1 :e pickH (z 0).
      { exact (ap1_Sigma W (fun U0:set => pickH U0) z HzP). }
      claim Hpick: pickH (z 0) c= Cover.
      { exact (andEL (pickH (z 0) c= Cover)
                     (finite (pickH (z 0)))
                     (andEL (pickH (z 0) c= Cover /\ finite (pickH (z 0)))
                            (setprod (z 0) Y c= Union (pickH (z 0)))
                            (HpickH (z 0) Hz0W))). }
      rewrite HNeq.
      exact (Hpick (z 1) Hz1In).
    + (** countable_set V **)
      claim HcountPick: forall U:set, U :e W -> countable (pickH U).
      { let U. assume HU: U :e W.
        claim Hfin: finite (pickH U).
        { exact (andER (pickH U c= Cover) (finite (pickH U))
                       (andEL (pickH U c= Cover /\ finite (pickH U))
                              (setprod U Y c= Union (pickH U))
                              (HpickH U HU))). }
        exact (finite_countable (pickH U) Hfin). }
      claim HPcount: countable_set P.
      { exact (Sigma_countable W HWcount (fun U0:set => pickH U0) HcountPick). }
      exact (countable_image P HPcount (fun z:set => z 1)).
  - (** covers (setprod X Y) V **)
    prove covers (setprod X Y) V.
    let p. assume Hp: p :e setprod X Y.
    prove exists N:set, N :e V /\ p :e N.
    claim Hp0: p 0 :e X.
    { exact (ap0_Sigma X (fun _:set => Y) p Hp). }
    claim Hp1: p 1 :e Y.
    { exact (ap1_Sigma X (fun _:set => Y) p Hp). }
    apply (HWcov (p 0) Hp0).
    let U. assume HUWpair: U :e W /\ p 0 :e U.
    claim HUW: U :e W.
    { exact (andEL (U :e W) (p 0 :e U) HUWpair). }
    claim Hp0U: p 0 :e U.
    { exact (andER (U :e W) (p 0 :e U) HUWpair). }
    claim HUpow: U :e Power X.
    { exact (topology_subset_axiom X Tx HTx U (HUFamSubTx U (HWsub U HUW))). }
    claim HUsubX: U c= X.
    { exact (PowerE X U HUpow). }
    claim HpUY: p :e setprod U Y.
    { claim HpEta: p = (p 0, p 1).
      { exact (setprod_eta X Y p Hp). }
      rewrite HpEta.
      exact (tuple_2_setprod_by_pair_Sigma U Y (p 0) (p 1) Hp0U Hp1). }
    claim HcovUY: setprod U Y c= Union (pickH U).
    { exact (andER (pickH U c= Cover /\ finite (pickH U))
                   (setprod U Y c= Union (pickH U))
                   (HpickH U HUW)). }
    claim HpInUnion: p :e Union (pickH U).
    { exact (HcovUY p HpUY). }
    apply (UnionE_impred (pickH U) p HpInUnion).
    let N. assume HpN: p :e N.
    assume HNin: N :e pickH U.
    witness N.
    apply andI.
    + (** N :e V **)
      claim HzP: (U,N) :e P.
      { exact (tuple_2_Sigma W (fun U0:set => pickH U0) U HUW N HNin). }
      claim Htup1: (U,N) 1 = N.
      { exact (tuple_2_1_eq U N). }
      rewrite <- Htup1.
      exact (ReplI P (fun z:set => z 1) (U,N) HzP).
    + exact HpN.
Qed.
(** from §30 Exercise 15: C(I,R) uniform topology countable dense subset **)
(** LATEX VERSION: C(I,ℝ) with uniform metric has countable dense subset and countable basis. **)
(** stub: this metric is meant to be the sup metric on C(I,R) **)
Definition uniform_metric_C_I_R : set := Eps_i (fun d:set => metric_on C_I_R d).
Definition uniform_topology_C_I_R : set := metric_topology C_I_R uniform_metric_C_I_R.
Theorem ex30_15_CI_has_countable_dense_uniform :
  exists D:set,
    D c= C_I_R /\ countable D /\ dense_in D C_I_R uniform_topology_C_I_R /\
    second_countable_space C_I_R uniform_topology_C_I_R.
admit. (** FAIL **)
Qed.
(** from §30 Exercise 16a: product R^I where I=[0,1] has countable dense subset **)
(** LATEX VERSION: The product space ℝ^I, where I=[0,1], has a countable dense subset. **)
Theorem ex30_16a_product_RI_countable_dense :
  exists D:set,
    D c= product_space unit_interval (const_space_family unit_interval R R_standard_topology) /\
    countable D /\
    dense_in D
      (product_space unit_interval (const_space_family unit_interval R R_standard_topology))
      (product_topology_full unit_interval (const_space_family unit_interval R R_standard_topology)).
admit. (** FAIL **)
Qed.

(** from §30 Exercise 16b: large product does not have countable dense subset **)
(** LATEX VERSION: If J has cardinality > 𝒫(ℤ₊), then ℝ^J does not have countable dense subset. **)
Theorem ex30_16b_large_product_no_countable_dense : forall J:set,
  atleastp (Power omega) J ->
  ~ equip J (Power omega) ->
  ~ (exists D:set,
      D c= product_space J (const_space_family J R R_standard_topology) /\
      countable D /\
      dense_in D
        (product_space J (const_space_family J R R_standard_topology))
        (product_topology_full J (const_space_family J R R_standard_topology))).
admit. (** FAIL **)
Qed.
(** from §30 Exercise 17: Romega box topology countability axioms **)
(** LATEX VERSION: ℝ^ω with box topology, subspace ℚ^∞ (rationals ending in infinite 0s): which countability axioms? **)
(** Define Q_infty as rational sequences eventually equal to 0. **)
Definition Q_infty : set :=
  {f :e R_omega_space |
    (forall n:set, n :e omega -> apply_fun f n :e rational_numbers) /\
    (exists n0:set, n0 :e omega /\
      forall m:set, m :e omega -> ~(m :e n0) -> apply_fun f m = 0)}.
(** from §30 Exercise 17: subspace topology on Q^infty inside R^omega (box topology) **)
(** LATEX VERSION: Consider Q^infty as a subspace of R^omega in the box topology. **)
Definition Q_infty_topology : set :=
  subspace_topology R_omega_space R_omega_box_topology Q_infty.
Theorem ex30_17_Romega_box_countability :
  (first_countable_space Q_infty Q_infty_topology \/ ~ first_countable_space Q_infty Q_infty_topology) /\
  (second_countable_space Q_infty Q_infty_topology \/ ~ second_countable_space Q_infty Q_infty_topology) /\
  (Lindelof_space Q_infty Q_infty_topology \/ ~ Lindelof_space Q_infty Q_infty_topology) /\
  ((exists D:set, D c= Q_infty /\ countable D /\ dense_in D Q_infty Q_infty_topology) \/
   ~ (exists D:set, D c= Q_infty /\ countable D /\ dense_in D Q_infty Q_infty_topology)).
apply andI.
- prove ((first_countable_space Q_infty Q_infty_topology \/ ~ first_countable_space Q_infty Q_infty_topology) /\
        (second_countable_space Q_infty Q_infty_topology \/ ~ second_countable_space Q_infty Q_infty_topology))
       /\ (Lindelof_space Q_infty Q_infty_topology \/ ~ Lindelof_space Q_infty Q_infty_topology).
  apply andI.
  - prove (first_countable_space Q_infty Q_infty_topology \/ ~ first_countable_space Q_infty Q_infty_topology) /\
          (second_countable_space Q_infty Q_infty_topology \/ ~ second_countable_space Q_infty Q_infty_topology).
    apply andI.
    + exact (xm (first_countable_space Q_infty Q_infty_topology)).
    + exact (xm (second_countable_space Q_infty Q_infty_topology)).
  - exact (xm (Lindelof_space Q_infty Q_infty_topology)).
- exact (xm (exists D:set, D c= Q_infty /\ countable D /\ dense_in D Q_infty Q_infty_topology)).
Qed.
(** from §30 Exercise 18: first-countable topological group with dense/Lindelof implies countable basis **)
(** LATEX VERSION: If G is first-countable topological group with countable dense subset or Lindelöf, then G has countable basis. **)
Theorem ex30_18_first_countable_group_countable_basis : forall G Tg:set,
  topological_group G Tg ->
  first_countable_space G Tg ->
  ((exists D:set, D c= G /\ countable D /\ dense_in D G Tg) \/ Lindelof_space G Tg) ->
  second_countable_space G Tg.
admit. (** FAIL **)
Qed.

(** from §31 Exercise 1: regular implies disjoint closures of neighborhoods **)
(** LATEX VERSION: If X is regular, every pair of points have neighborhoods whose closures are disjoint. **)
Theorem ex31_1_regular_disjoint_closure_neighborhoods : forall X Tx x y:set,
  regular_space X Tx ->
  x :e X ->
  y :e X ->
  x <> y ->
  exists U V:set,
    open_in X Tx U /\ open_in X Tx V /\
    x :e U /\ y :e V /\
    closure_of X Tx U :/\: closure_of X Tx V = Empty.
let X Tx x y.
assume Hreg: regular_space X Tx.
assume Hx: x :e X.
assume Hy: y :e X.
assume Hneq: x <> y.
prove exists U V:set, open_in X Tx U /\ open_in X Tx V /\ x :e U /\ y :e V /\ closure_of X Tx U :/\: closure_of X Tx V = Empty.
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim Hsing: forall t:set, t :e X -> closed_in X Tx {t}.
{ exact (andER (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim HSepReg:
  forall t:set, t :e X ->
    forall F:set, closed_in X Tx F -> t /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ t :e U /\ F c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed X Tx)
               (forall x:set, x :e X ->
                 forall F:set, closed_in X Tx F -> x /:e F ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
               Hreg). }

(** Step 1: separate x from the closed singleton {y}. **)
claim Hcly: closed_in X Tx {y}.
{ exact (Hsing y Hy). }
claim Hxnoty: x /:e {y}.
{ assume Hxy: x :e {y}.
  claim Heq: x = y.
  { exact (SingE y x Hxy). }
  exact (Hneq Heq). }
claim Hex1: exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ {y} c= V /\ U :/\: V = Empty.
{ exact (HSepReg x Hx {y} Hcly Hxnoty). }
set U0 := Eps_i (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ x :e U /\ {y} c= V /\ U :/\: V = Empty).
claim HU0ex: exists V:set, U0 :e Tx /\ V :e Tx /\ x :e U0 /\ {y} c= V /\ U0 :/\: V = Empty.
{ exact (Eps_i_ex (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ x :e U /\ {y} c= V /\ U :/\: V = Empty) Hex1). }
set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ x :e U0 /\ {y} c= V /\ U0 :/\: V = Empty).
claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ x :e U0 /\ {y} c= V0 /\ U0 :/\: V0 = Empty.
{ exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ x :e U0 /\ {y} c= V /\ U0 :/\: V = Empty) HU0ex). }
claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ x :e U0) /\ {y} c= V0).
{ exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ x :e U0) /\ {y} c= V0))
               (U0 :/\: V0 = Empty)
               HV0prop). }
claim Hdisj0: U0 :/\: V0 = Empty.
{ exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ x :e U0) /\ {y} c= V0))
               (U0 :/\: V0 = Empty)
               HV0prop). }
claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ x :e U0).
{ exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ x :e U0)
               ({y} c= V0)
               H1234). }
claim H12: (U0 :e Tx /\ V0 :e Tx).
{ exact (andEL (U0 :e Tx /\ V0 :e Tx) (x :e U0) H123). }
claim HU0Tx: U0 :e Tx.
{ exact (andEL (U0 :e Tx) (V0 :e Tx) H12). }
claim HV0Tx: V0 :e Tx.
{ exact (andER (U0 :e Tx) (V0 :e Tx) H12). }
claim HxU0: x :e U0.
{ exact (andER (U0 :e Tx /\ V0 :e Tx) (x :e U0) H123). }
claim HysubV0: {y} c= V0.
{ exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ x :e U0) ({y} c= V0) H1234). }
claim HyV0: y :e V0.
{ apply HysubV0. exact (SingI y). }

(** Step 2: show y is not in closure(U0). **)
claim Hcliffy: y :e closure_of X Tx U0 <-> (forall W :e Tx, y :e W -> W :/\: U0 <> Empty).
{ exact (closure_characterization X Tx U0 y HTx Hy). }
claim HyNotClU0: y /:e closure_of X Tx U0.
  { assume HyCl: y :e closure_of X Tx U0.
    claim Hneigh: forall W :e Tx, y :e W -> W :/\: U0 <> Empty.
  { exact (iffEL (y :e closure_of X Tx U0)
                 (forall W :e Tx, y :e W -> W :/\: U0 <> Empty)
                 Hcliffy HyCl). }
  claim Hempty: V0 :/\: U0 = Empty.
  { apply Empty_Subq_eq.
    let z. assume Hz: z :e V0 :/\: U0.
    prove z :e Empty.
    claim HzV: z :e V0.
    { exact (binintersectE1 V0 U0 z Hz). }
    claim HzU: z :e U0.
    { exact (binintersectE2 V0 U0 z Hz). }
    claim HzUV: z :e U0 :/\: V0.
    { exact (binintersectI U0 V0 z HzU HzV). }
    claim HzE: z :e Empty.
    { rewrite <- Hdisj0. exact HzUV. }
    exact HzE. }
  claim Hcontr: V0 :/\: U0 <> Empty.
  { exact (Hneigh V0 HV0Tx HyV0). }
  apply FalseE.
  apply FalseE.
  apply FalseE.
  exact (Hcontr Hempty). }

(** Step 3: separate y from the closed set closure(U0). **)
claim HTsub: Tx c= Power X.
{ exact (topology_subset_axiom X Tx HTx). }
claim HU0sub: U0 c= X.
{ exact (PowerE X U0 (HTsub U0 HU0Tx)). }
claim HclU0: closed_in X Tx (closure_of X Tx U0).
{ exact (closure_is_closed X Tx U0 HTx HU0sub). }
claim Hex2: exists U V:set,
  U :e Tx /\ V :e Tx /\ y :e U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty.
{ exact (HSepReg y Hy (closure_of X Tx U0) HclU0 HyNotClU0). }
set U1 := Eps_i (fun U:set => exists V:set,
  U :e Tx /\ V :e Tx /\ y :e U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty).
claim HU1ex: exists V:set,
  U1 :e Tx /\ V :e Tx /\ y :e U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty.
{ exact (Eps_i_ex (fun U:set => exists V:set,
    U :e Tx /\ V :e Tx /\ y :e U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty) Hex2). }
set V1 := Eps_i (fun V:set => U1 :e Tx /\ V :e Tx /\ y :e U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty).
claim HV1prop: U1 :e Tx /\ V1 :e Tx /\ y :e U1 /\ closure_of X Tx U0 c= V1 /\ U1 :/\: V1 = Empty.
{ exact (Eps_i_ex (fun V:set => U1 :e Tx /\ V :e Tx /\ y :e U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty)
                  HU1ex). }
claim H1234b: (((U1 :e Tx /\ V1 :e Tx) /\ y :e U1) /\ closure_of X Tx U0 c= V1).
{ exact (andEL ((((U1 :e Tx /\ V1 :e Tx) /\ y :e U1) /\ closure_of X Tx U0 c= V1))
               (U1 :/\: V1 = Empty)
               HV1prop). }
claim Hdisj1: U1 :/\: V1 = Empty.
{ exact (andER ((((U1 :e Tx /\ V1 :e Tx) /\ y :e U1) /\ closure_of X Tx U0 c= V1))
               (U1 :/\: V1 = Empty)
               HV1prop). }
claim H123b: ((U1 :e Tx /\ V1 :e Tx) /\ y :e U1).
{ exact (andEL ((U1 :e Tx /\ V1 :e Tx) /\ y :e U1)
               (closure_of X Tx U0 c= V1)
               H1234b). }
claim H12b: (U1 :e Tx /\ V1 :e Tx).
{ exact (andEL (U1 :e Tx /\ V1 :e Tx) (y :e U1) H123b). }
claim HU1Tx: U1 :e Tx.
{ exact (andEL (U1 :e Tx) (V1 :e Tx) H12b). }
claim HV1Tx: V1 :e Tx.
{ exact (andER (U1 :e Tx) (V1 :e Tx) H12b). }
claim HyU1: y :e U1.
{ exact (andER (U1 :e Tx /\ V1 :e Tx) (y :e U1) H123b). }
claim HclU0subV1: closure_of X Tx U0 c= V1.
{ exact (andER ((U1 :e Tx /\ V1 :e Tx) /\ y :e U1) (closure_of X Tx U0 c= V1) H1234b). }

(** Step 4: closures of U0 and U1 are disjoint. **)
claim Hcliff: forall z:set, z :e X ->
  (z :e closure_of X Tx U1 <-> (forall W :e Tx, z :e W -> W :/\: U1 <> Empty)).
{ let z. assume HzX: z :e X.
  exact (closure_characterization X Tx U1 z HTx HzX). }
claim Hcldisj: closure_of X Tx U0 :/\: closure_of X Tx U1 = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e closure_of X Tx U0 :/\: closure_of X Tx U1.
  prove z :e Empty.
  claim Hzcl0: z :e closure_of X Tx U0.
  { exact (binintersectE1 (closure_of X Tx U0) (closure_of X Tx U1) z Hz). }
  claim Hzcl1: z :e closure_of X Tx U1.
  { exact (binintersectE2 (closure_of X Tx U0) (closure_of X Tx U1) z Hz). }
  claim HzX: z :e X.
  { exact (SepE1 X (fun z0:set => forall W:set, W :e Tx -> z0 :e W -> W :/\: U0 <> Empty) z Hzcl0). }
  claim HzV1: z :e V1.
  { apply HclU0subV1. exact Hzcl0. }
  claim Hneigh: forall W :e Tx, z :e W -> W :/\: U1 <> Empty.
  { exact (iffEL (z :e closure_of X Tx U1)
                 (forall W :e Tx, z :e W -> W :/\: U1 <> Empty)
                 (Hcliff z HzX) Hzcl1). }
  claim Hcontr: V1 :/\: U1 <> Empty.
  { exact (Hneigh V1 HV1Tx HzV1). }
  claim Hempty: V1 :/\: U1 = Empty.
  { apply Empty_Subq_eq.
    let w. assume Hw: w :e V1 :/\: U1.
    prove w :e Empty.
    claim HwV: w :e V1.
    { exact (binintersectE1 V1 U1 w Hw). }
    claim HwU: w :e U1.
    { exact (binintersectE2 V1 U1 w Hw). }
    claim HwUV: w :e U1 :/\: V1.
    { exact (binintersectI U1 V1 w HwU HwV). }
	    claim HwE: w :e Empty.
	    { rewrite <- Hdisj1. exact HwUV. }
	    exact HwE. }
	  apply FalseE.
	  exact (Hcontr Hempty). }

witness U0.
witness U1.
apply and5I.
- exact (andI (topology_on X Tx) (U0 :e Tx) HTx HU0Tx).
- exact (andI (topology_on X Tx) (U1 :e Tx) HTx HU1Tx).
- exact HxU0.
- exact HyU1.
- exact Hcldisj.
Qed.
(** from §31 Exercise 2: normal implies disjoint closures for closed sets **)
(** LATEX VERSION: If X is normal, every pair of disjoint closed sets have neighborhoods whose closures are disjoint. **)
Theorem ex31_2_normal_disjoint_closure_neighborhoods : forall X Tx A B:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  closed_in X Tx B ->
  A :/\: B = Empty ->
  exists U V:set,
    open_in X Tx U /\ open_in X Tx V /\
    A c= U /\ B c= V /\
    closure_of X Tx U :/\: closure_of X Tx V = Empty.
let X Tx A B.
assume Hnorm: normal_space X Tx.
assume HA: closed_in X Tx A.
assume HB: closed_in X Tx B.
assume Hdisj: A :/\: B = Empty.
prove exists U V:set, open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V /\ closure_of X Tx U :/\: closure_of X Tx V = Empty.
claim HT1: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
               Hnorm). }
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx)
               (forall x:set, x :e X -> closed_in X Tx {x})
               HT1). }
claim HSepNorm:
  forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
    exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed X Tx)
               (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
               Hnorm). }

(** Step 1: separate A and B by disjoint open sets U0 and V0. **)
claim Hex1: exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
{ exact (HSepNorm A B HA HB Hdisj). }
set U0 := Eps_i (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty).
claim HU0ex: exists V:set, U0 :e Tx /\ V :e Tx /\ A c= U0 /\ B c= V /\ U0 :/\: V = Empty.
{ exact (Eps_i_ex (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty) Hex1). }
set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ A c= U0 /\ B c= V /\ U0 :/\: V = Empty).
claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ A c= U0 /\ B c= V0 /\ U0 :/\: V0 = Empty.
{ exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ A c= U0 /\ B c= V /\ U0 :/\: V = Empty) HU0ex). }
claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0).
{ exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0))
               (U0 :/\: V0 = Empty)
               HV0prop). }
claim Hdisj0: U0 :/\: V0 = Empty.
{ exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) /\ B c= V0))
               (U0 :/\: V0 = Empty)
               HV0prop). }
claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0).
{ exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0)
               (B c= V0)
               H1234). }
claim H12: (U0 :e Tx /\ V0 :e Tx).
{ exact (andEL (U0 :e Tx /\ V0 :e Tx) (A c= U0) H123). }
claim HU0Tx: U0 :e Tx.
{ exact (andEL (U0 :e Tx) (V0 :e Tx) H12). }
claim HV0Tx: V0 :e Tx.
{ exact (andER (U0 :e Tx) (V0 :e Tx) H12). }
claim HAsub: A c= U0.
{ exact (andER (U0 :e Tx /\ V0 :e Tx) (A c= U0) H123). }
claim HBsub: B c= V0.
{ exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ A c= U0) (B c= V0) H1234). }

(** Step 2: show B is disjoint from closure(U0). **)
claim HTsub: Tx c= Power X.
{ exact (topology_subset_axiom X Tx HTx). }
claim HU0subX: U0 c= X.
{ exact (PowerE X U0 (HTsub U0 HU0Tx)). }
claim HclU0: closed_in X Tx (closure_of X Tx U0).
{ exact (closure_is_closed X Tx U0 HTx HU0subX). }
claim Hcliff0: forall z:set, z :e X ->
  (z :e closure_of X Tx U0 <-> (forall W :e Tx, z :e W -> W :/\: U0 <> Empty)).
{ let z. assume HzX: z :e X.
  exact (closure_characterization X Tx U0 z HTx HzX). }
claim HclU0_disj_V0: closure_of X Tx U0 :/\: V0 = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e closure_of X Tx U0 :/\: V0.
  prove z :e Empty.
  claim Hzcl: z :e closure_of X Tx U0.
  { exact (binintersectE1 (closure_of X Tx U0) V0 z Hz). }
  claim HzV: z :e V0.
  { exact (binintersectE2 (closure_of X Tx U0) V0 z Hz). }
  claim HzX: z :e X.
  { exact (SepE1 X (fun z0:set => forall W:set, W :e Tx -> z0 :e W -> W :/\: U0 <> Empty) z Hzcl). }
  claim Hneigh: forall W :e Tx, z :e W -> W :/\: U0 <> Empty.
  { exact (iffEL (z :e closure_of X Tx U0)
                 (forall W :e Tx, z :e W -> W :/\: U0 <> Empty)
                 (Hcliff0 z HzX) Hzcl). }
  claim Hcontr: V0 :/\: U0 <> Empty.
  { exact (Hneigh V0 HV0Tx HzV). }
  claim Hempty: V0 :/\: U0 = Empty.
  { apply Empty_Subq_eq.
    let w. assume Hw: w :e V0 :/\: U0.
    prove w :e Empty.
    claim HwV: w :e V0.
    { exact (binintersectE1 V0 U0 w Hw). }
    claim HwU: w :e U0.
    { exact (binintersectE2 V0 U0 w Hw). }
    claim HwUV: w :e U0 :/\: V0.
    { exact (binintersectI U0 V0 w HwU HwV). }
    claim HwE: w :e Empty.
    { rewrite <- Hdisj0. exact HwUV. }
    exact HwE. }
  apply FalseE.
  exact (Hcontr Hempty). }
claim HBcldisj: B :/\: closure_of X Tx U0 = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e B :/\: closure_of X Tx U0.
  prove z :e Empty.
  claim HzB: z :e B.
  { exact (binintersectE1 B (closure_of X Tx U0) z Hz). }
  claim Hzcl: z :e closure_of X Tx U0.
  { exact (binintersectE2 B (closure_of X Tx U0) z Hz). }
  claim HzV0: z :e V0.
  { apply HBsub. exact HzB. }
  claim HzclV0: z :e closure_of X Tx U0 :/\: V0.
  { exact (binintersectI (closure_of X Tx U0) V0 z Hzcl HzV0). }
  claim HzE: z :e Empty.
  { rewrite <- HclU0_disj_V0. exact HzclV0. }
  exact HzE. }

(** Step 3: separate B from closure(U0), then conclude closures are disjoint. **)
claim Hex2: exists U V:set,
  U :e Tx /\ V :e Tx /\ B c= U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty.
{ exact (HSepNorm B (closure_of X Tx U0) HB HclU0 HBcldisj). }
set U1 := Eps_i (fun U:set => exists V:set,
  U :e Tx /\ V :e Tx /\ B c= U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty).
claim HU1ex: exists V:set,
  U1 :e Tx /\ V :e Tx /\ B c= U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty.
{ exact (Eps_i_ex (fun U:set => exists V:set,
    U :e Tx /\ V :e Tx /\ B c= U /\ closure_of X Tx U0 c= V /\ U :/\: V = Empty) Hex2). }
set V1 := Eps_i (fun V:set => U1 :e Tx /\ V :e Tx /\ B c= U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty).
claim HV1prop: U1 :e Tx /\ V1 :e Tx /\ B c= U1 /\ closure_of X Tx U0 c= V1 /\ U1 :/\: V1 = Empty.
{ exact (Eps_i_ex (fun V:set => U1 :e Tx /\ V :e Tx /\ B c= U1 /\ closure_of X Tx U0 c= V /\ U1 :/\: V = Empty)
                  HU1ex). }
claim H1234b: (((U1 :e Tx /\ V1 :e Tx) /\ B c= U1) /\ closure_of X Tx U0 c= V1).
{ exact (andEL ((((U1 :e Tx /\ V1 :e Tx) /\ B c= U1) /\ closure_of X Tx U0 c= V1))
               (U1 :/\: V1 = Empty)
               HV1prop). }
claim Hdisj1: U1 :/\: V1 = Empty.
{ exact (andER ((((U1 :e Tx /\ V1 :e Tx) /\ B c= U1) /\ closure_of X Tx U0 c= V1))
               (U1 :/\: V1 = Empty)
               HV1prop). }
claim H123b: ((U1 :e Tx /\ V1 :e Tx) /\ B c= U1).
{ exact (andEL ((U1 :e Tx /\ V1 :e Tx) /\ B c= U1)
               (closure_of X Tx U0 c= V1)
               H1234b). }
claim H12b: (U1 :e Tx /\ V1 :e Tx).
{ exact (andEL (U1 :e Tx /\ V1 :e Tx) (B c= U1) H123b). }
claim HU1Tx: U1 :e Tx.
{ exact (andEL (U1 :e Tx) (V1 :e Tx) H12b). }
claim HV1Tx: V1 :e Tx.
{ exact (andER (U1 :e Tx) (V1 :e Tx) H12b). }
claim HBsubU1: B c= U1.
{ exact (andER (U1 :e Tx /\ V1 :e Tx) (B c= U1) H123b). }
claim HclU0subV1: closure_of X Tx U0 c= V1.
{ exact (andER ((U1 :e Tx /\ V1 :e Tx) /\ B c= U1) (closure_of X Tx U0 c= V1) H1234b). }

claim Hcliff1: forall z:set, z :e X ->
  (z :e closure_of X Tx U1 <-> (forall W :e Tx, z :e W -> W :/\: U1 <> Empty)).
{ let z. assume HzX: z :e X.
  exact (closure_characterization X Tx U1 z HTx HzX). }
claim Hcldisj: closure_of X Tx U0 :/\: closure_of X Tx U1 = Empty.
{ apply Empty_Subq_eq.
  let z. assume Hz: z :e closure_of X Tx U0 :/\: closure_of X Tx U1.
  prove z :e Empty.
  claim Hzcl0: z :e closure_of X Tx U0.
  { exact (binintersectE1 (closure_of X Tx U0) (closure_of X Tx U1) z Hz). }
  claim Hzcl1: z :e closure_of X Tx U1.
  { exact (binintersectE2 (closure_of X Tx U0) (closure_of X Tx U1) z Hz). }
  claim HzX: z :e X.
  { exact (SepE1 X (fun z0:set => forall W:set, W :e Tx -> z0 :e W -> W :/\: U0 <> Empty) z Hzcl0). }
  claim HzV1: z :e V1.
  { apply HclU0subV1. exact Hzcl0. }
  claim Hneigh: forall W :e Tx, z :e W -> W :/\: U1 <> Empty.
  { exact (iffEL (z :e closure_of X Tx U1)
                 (forall W :e Tx, z :e W -> W :/\: U1 <> Empty)
                 (Hcliff1 z HzX) Hzcl1). }
  claim Hcontr: V1 :/\: U1 <> Empty.
  { exact (Hneigh V1 HV1Tx HzV1). }
  claim Hempty: V1 :/\: U1 = Empty.
  { apply Empty_Subq_eq.
    let w. assume Hw: w :e V1 :/\: U1.
    prove w :e Empty.
    claim HwV: w :e V1.
    { exact (binintersectE1 V1 U1 w Hw). }
    claim HwU: w :e U1.
    { exact (binintersectE2 V1 U1 w Hw). }
    claim HwUV: w :e U1 :/\: V1.
    { exact (binintersectI U1 V1 w HwU HwV). }
    claim HwE: w :e Empty.
    { rewrite <- Hdisj1. exact HwUV. }
    exact HwE. }
  apply FalseE.
  exact (Hcontr Hempty). }

witness U0.
witness U1.
apply and5I.
- exact (andI (topology_on X Tx) (U0 :e Tx) HTx HU0Tx).
- exact (andI (topology_on X Tx) (U1 :e Tx) HTx HU1Tx).
- exact HAsub.
- exact HBsubU1.
- exact Hcldisj.
Qed.
(** from §31 Exercise 3: every order topology regular **)
(** LATEX VERSION: Every order topology is regular. **)
Theorem ex31_3_order_topology_regular : forall X:set,
  simply_ordered_set X ->
  regular_space X (order_topology X).
let X.
assume Hso: simply_ordered_set X.
prove regular_space X (order_topology X).
prove one_point_sets_closed X (order_topology X) /\
  forall x:set, x :e X ->
    forall F:set, closed_in X (order_topology X) F -> x /:e F ->
      exists U V:set, U :e order_topology X /\ V :e order_topology X /\ x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- claim HH: Hausdorff_space X (order_topology X).
  { exact (ex17_10_order_topology_Hausdorff X Hso). }
  prove one_point_sets_closed X (order_topology X).
  prove topology_on X (order_topology X) /\ forall x:set, x :e X -> closed_in X (order_topology X) {x}.
  apply andI.
  * exact (Hausdorff_space_topology X (order_topology X) HH).
  * let x. assume HxX: x :e X.
    exact (Hausdorff_singletons_closed X (order_topology X) x HH HxX).
- let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X (order_topology X) F.
  assume HxnotF: x /:e F.
  admit. (** FAIL **)
Qed.
(** from §31 Exercise 4: comparing finer/coarser separation axioms **)
(** LATEX VERSION: Let X have two topologies T and T', with T' ⊃ T. Compare separation properties. **)
Theorem ex31_4_comparison_topologies_separation : forall X Tx Tx':set,
  topology_on X Tx ->
  topology_on X Tx' ->
  Tx c= Tx' ->
  ((Hausdorff_space X Tx -> Hausdorff_space X Tx') /\
   (regular_space X Tx -> Hausdorff_space X Tx') /\
   (normal_space X Tx -> Hausdorff_space X Tx')).
let X Tx Tx'.
assume HTx: topology_on X Tx.
assume HTx': topology_on X Tx'.
assume Hfiner: Tx c= Tx'.
claim Hhaus_finer: Hausdorff_space X Tx -> Hausdorff_space X Tx'.
{ assume HH: Hausdorff_space X Tx.
  prove Hausdorff_space X Tx'.
  claim HSep: forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
    exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  { exact (andER (topology_on X Tx)
                 (forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty)
                 HH). }
  prove topology_on X Tx' /\
        forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
          exists U V:set, U :e Tx' /\ V :e Tx' /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
  apply andI.
  - exact HTx'.
  - let x1 x2.
    assume Hx1X: x1 :e X.
    assume Hx2X: x2 :e X.
    assume Hneq: x1 <> x2.
    prove exists U V:set, U :e Tx' /\ V :e Tx' /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
    claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
    { exact (HSep x1 x2 Hx1X Hx2X Hneq). }
    set U0 := Eps_i (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty).
    claim HU0ex: exists V:set, U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ x2 :e V /\ U0 :/\: V = Empty.
    { exact (Eps_i_ex (fun U:set => exists V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty) Hex). }
    set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ x2 :e V /\ U0 :/\: V = Empty).
    claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ x1 :e U0 /\ x2 :e V0 /\ U0 :/\: V0 = Empty.
    { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ x2 :e V /\ U0 :/\: V = Empty) HU0ex). }
    claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ x2 :e V0).
    { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ x2 :e V0))
                   (U0 :/\: V0 = Empty)
                   HV0prop). }
    claim HdisjUV: U0 :/\: V0 = Empty.
    { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ x2 :e V0))
                   (U0 :/\: V0 = Empty)
                   HV0prop). }
    claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0).
    { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0)
                   (x2 :e V0)
                   H1234). }
    claim H12: (U0 :e Tx /\ V0 :e Tx).
    { exact (andEL (U0 :e Tx /\ V0 :e Tx)
                   (x1 :e U0)
                   H123). }
    claim HUx1: x1 :e U0.
    { exact (andER (U0 :e Tx /\ V0 :e Tx)
                   (x1 :e U0)
                   H123). }
    claim HVx2: x2 :e V0.
    { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0)
                   (x2 :e V0)
                   H1234). }
    claim HU0Tx': U0 :e Tx'.
    { apply Hfiner. exact (andEL (U0 :e Tx) (V0 :e Tx) H12). }
    claim HV0Tx': V0 :e Tx'.
    { apply Hfiner. exact (andER (U0 :e Tx) (V0 :e Tx) H12). }
    witness U0.
    witness V0.
    apply and5I.
    - exact HU0Tx'.
    - exact HV0Tx'.
    - exact HUx1.
    - exact HVx2.
    - exact HdisjUV. }
apply and3I.
- exact Hhaus_finer.
- prove regular_space X Tx -> Hausdorff_space X Tx'.
  assume Hreg: regular_space X Tx.
  claim HT1: one_point_sets_closed X Tx.
  { exact (andEL (one_point_sets_closed X Tx)
                 (forall x:set, x :e X ->
                   forall F:set, closed_in X Tx F -> x /:e F ->
                     exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
                 Hreg). }
  claim Hsing: forall x:set, x :e X -> closed_in X Tx {x}.
  { exact (andER (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1). }
  claim HSepReg:
    forall x:set, x :e X ->
      forall F:set, closed_in X Tx F -> x /:e F ->
        exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  { exact (andER (one_point_sets_closed X Tx)
                 (forall x:set, x :e X ->
                   forall F:set, closed_in X Tx F -> x /:e F ->
                     exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty)
                 Hreg). }
  claim HHcoarse: Hausdorff_space X Tx.
  { prove topology_on X Tx /\
          forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
            exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
    apply andI.
    - exact (andEL (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1).
    - let x1 x2.
      assume Hx1X: x1 :e X.
      assume Hx2X: x2 :e X.
      assume Hneq: x1 <> x2.
      prove exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
      claim Hcl: closed_in X Tx {x2}.
      { exact (Hsing x2 Hx2X). }
      claim Hx1not: x1 /:e {x2}.
      { assume Hx1in: x1 :e {x2}.
        claim Heq: x1 = x2.
        { exact (SingE x2 x1 Hx1in). }
        exact (Hneq Heq). }
      claim Hex: exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty.
      { exact (HSepReg x1 Hx1X {x2} Hcl Hx1not). }
      set U0 := Eps_i (fun U:set => exists V:set,
        U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty).
      claim HU0ex: exists V:set,
        U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty.
      { exact (Eps_i_ex (fun U:set => exists V:set,
          U :e Tx /\ V :e Tx /\ x1 :e U /\ {x2} c= V /\ U :/\: V = Empty) Hex). }
      set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty).
      claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ x1 :e U0 /\ {x2} c= V0 /\ U0 :/\: V0 = Empty.
      { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ x1 :e U0 /\ {x2} c= V /\ U0 :/\: V = Empty)
                        HU0ex). }
      claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0).
      { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0))
                     (U0 :/\: V0 = Empty)
                     HV0prop). }
      claim HdisjUV: U0 :/\: V0 = Empty.
      { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) /\ {x2} c= V0))
                     (U0 :/\: V0 = Empty)
                     HV0prop). }
      claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0).
      { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0)
                     ({x2} c= V0)
                     H1234). }
      claim H12: (U0 :e Tx /\ V0 :e Tx).
      { exact (andEL (U0 :e Tx /\ V0 :e Tx) (x1 :e U0) H123). }
      claim HUx1: x1 :e U0.
      { exact (andER (U0 :e Tx /\ V0 :e Tx) (x1 :e U0) H123). }
      claim HVsub: {x2} c= V0.
      { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ x1 :e U0) ({x2} c= V0) H1234). }
      claim Hx2V0: x2 :e V0.
      { apply HVsub. exact (SingI x2). }
      witness U0.
      witness V0.
      apply and5I.
      - exact (andEL (U0 :e Tx) (V0 :e Tx) H12).
      - exact (andER (U0 :e Tx) (V0 :e Tx) H12).
      - exact HUx1.
      - exact Hx2V0.
      - exact HdisjUV. }
  exact (Hhaus_finer HHcoarse).
- prove normal_space X Tx -> Hausdorff_space X Tx'.
  assume Hnorm: normal_space X Tx.
  claim HT1: one_point_sets_closed X Tx.
  { exact (andEL (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm). }
  claim Hsing: forall x:set, x :e X -> closed_in X Tx {x}.
  { exact (andER (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1). }
  claim HSepNorm:
    forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
      exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  { exact (andER (one_point_sets_closed X Tx)
                 (forall A B:set, closed_in X Tx A -> closed_in X Tx B -> A :/\: B = Empty ->
                   exists U V:set, U :e Tx /\ V :e Tx /\ A c= U /\ B c= V /\ U :/\: V = Empty)
                 Hnorm). }
  claim HHcoarse: Hausdorff_space X Tx.
  { prove topology_on X Tx /\
          forall x1 x2:set, x1 :e X -> x2 :e X -> x1 <> x2 ->
            exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
    apply andI.
    - exact (andEL (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HT1).
    - let x1 x2.
      assume Hx1X: x1 :e X.
      assume Hx2X: x2 :e X.
      assume Hneq: x1 <> x2.
      prove exists U V:set, U :e Tx /\ V :e Tx /\ x1 :e U /\ x2 :e V /\ U :/\: V = Empty.
      claim Hcl1: closed_in X Tx {x1}.
      { exact (Hsing x1 Hx1X). }
      claim Hcl2: closed_in X Tx {x2}.
      { exact (Hsing x2 Hx2X). }
      claim Hdisj: {x1} :/\: {x2} = Empty.
      { apply Empty_Subq_eq.
        let z. assume Hz: z :e {x1} :/\: {x2}.
        prove z :e Empty.
        claim Hz1: z :e {x1}.
        { exact (binintersectE1 {x1} {x2} z Hz). }
        claim Hz2: z :e {x2}.
        { exact (binintersectE2 {x1} {x2} z Hz). }
        claim Hzx1: z = x1.
        { exact (SingE x1 z Hz1). }
        claim Hzx2: z = x2.
        { exact (SingE x2 z Hz2). }
        claim Hx1x2: x1 = x2.
        { rewrite <- Hzx1. rewrite Hzx2. reflexivity. }
        apply FalseE.
        exact (Hneq Hx1x2). }
      claim Hex: exists U V:set,
        U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty.
      { exact (HSepNorm {x1} {x2} Hcl1 Hcl2 Hdisj). }
      set U0 := Eps_i (fun U:set => exists V:set,
        U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty).
      claim HU0ex: exists V:set,
        U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty.
      { exact (Eps_i_ex (fun U:set => exists V:set,
          U :e Tx /\ V :e Tx /\ {x1} c= U /\ {x2} c= V /\ U :/\: V = Empty) Hex). }
      set V0 := Eps_i (fun V:set => U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty).
      claim HV0prop: U0 :e Tx /\ V0 :e Tx /\ {x1} c= U0 /\ {x2} c= V0 /\ U0 :/\: V0 = Empty.
      { exact (Eps_i_ex (fun V:set => U0 :e Tx /\ V :e Tx /\ {x1} c= U0 /\ {x2} c= V /\ U0 :/\: V = Empty)
                        HU0ex). }
      claim H1234: (((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0).
      { exact (andEL ((((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0))
                     (U0 :/\: V0 = Empty)
                     HV0prop). }
      claim HdisjUV: U0 :/\: V0 = Empty.
      { exact (andER ((((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) /\ {x2} c= V0))
                     (U0 :/\: V0 = Empty)
                     HV0prop). }
      claim H123: ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0).
      { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0)
                     ({x2} c= V0)
                     H1234). }
      claim H12: (U0 :e Tx /\ V0 :e Tx).
      { exact (andEL (U0 :e Tx /\ V0 :e Tx) ({x1} c= U0) H123). }
      claim Hsub1: {x1} c= U0.
      { exact (andER (U0 :e Tx /\ V0 :e Tx) ({x1} c= U0) H123). }
      claim Hsub2: {x2} c= V0.
      { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ {x1} c= U0) ({x2} c= V0) H1234). }
      claim Hx1U0: x1 :e U0.
      { apply Hsub1. exact (SingI x1). }
      claim Hx2V0: x2 :e V0.
      { apply Hsub2. exact (SingI x2). }
      witness U0.
      witness V0.
      apply and5I.
      - exact (andEL (U0 :e Tx) (V0 :e Tx) H12).
      - exact (andER (U0 :e Tx) (V0 :e Tx) H12).
      - exact Hx1U0.
      - exact Hx2V0.
      - exact HdisjUV. }
  exact (Hhaus_finer HHcoarse).
Qed.
(** from §31 Exercise 5: equalizer of continuous maps into Hausdorff is closed **)
(** LATEX VERSION: Let f,g: X → Y be continuous, Y Hausdorff. Then {x | f(x) = g(x)} is closed in X. **)
Theorem ex31_5_equalizer_closed_in_Hausdorff : forall X Tx Y Ty f g:set,
  continuous_map X Tx Y Ty f ->
  continuous_map X Tx Y Ty g ->
  Hausdorff_space Y Ty ->
  closed_in X Tx {x :e X | apply_fun f x = apply_fun g x}.
let X Tx Y Ty f g.
assume Hf: continuous_map X Tx Y Ty f.
assume Hg: continuous_map X Tx Y Ty g.
assume HHaus: Hausdorff_space Y Ty.
prove closed_in X Tx {x :e X | apply_fun f x = apply_fun g x}.
claim HTx: topology_on X Tx.
{ exact (andEL (topology_on X Tx) (topology_on Y Ty)
               (andEL (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
                      (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
                             (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hf))). }
claim HTy: topology_on Y Ty.
{ exact (andEL (topology_on Y Ty)
               (forall y1 y2:set, y1 :e Y -> y2 :e Y -> y1 <> y2 ->
                 exists U V:set, U :e Ty /\ V :e Ty /\ y1 :e U /\ y2 :e V /\ U :/\: V = Empty)
               HHaus). }
set h := pair_map X f g.
claim Hhcont: continuous_map X Tx (setprod Y Y) (product_topology Y Ty Y Ty) h.
{ exact (maps_into_products_axiom X Tx Y Ty Y Ty f g Hf Hg). }
set D := {(y,y)|y :e Y}.
claim HclosedD: closed_in (setprod Y Y) (product_topology Y Ty Y Ty) D.
{ exact (iffEL (Hausdorff_space Y Ty)
               (closed_in (setprod Y Y) (product_topology Y Ty Y Ty) {(y,y)|y :e Y})
               (ex17_13_diagonal_closed_iff_Hausdorff Y Ty HTy) HHaus). }
claim Hpre_closed: closed_in X Tx (preimage_of X h D).
{ exact (continuous_preserves_closed X Tx (setprod Y Y) (product_topology Y Ty Y Ty) h Hhcont D HclosedD). }
claim Heq:
  preimage_of X h D = {x :e X | apply_fun f x = apply_fun g x}.
{ apply set_ext.
  - let x. assume Hx: x :e preimage_of X h D.
    prove x :e {x :e X | apply_fun f x = apply_fun g x}.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun h x0 :e D) x Hx). }
    claim HhDx: apply_fun h x :e D.
    { exact (SepE2 X (fun x0:set => apply_fun h x0 :e D) x Hx). }
    apply (ReplE Y (fun y:set => (y,y)) (apply_fun h x) HhDx).
    let y. assume HyPair.
    claim HyY: y :e Y.
    { exact (andEL (y :e Y) (apply_fun h x = (y,y)) HyPair). }
    claim HeqPair: apply_fun h x = (y,y).
    { exact (andER (y :e Y) (apply_fun h x = (y,y)) HyPair). }
    claim Happ: apply_fun h x = (apply_fun f x, apply_fun g x).
    { exact (pair_map_apply X Y Y f g x HxX). }
    claim HfgEq: (apply_fun f x, apply_fun g x) = (y,y).
    { rewrite <- Happ. exact HeqPair. }
    claim H0: (apply_fun f x, apply_fun g x) 0 = apply_fun f x.
    { exact (tuple_2_0_eq (apply_fun f x) (apply_fun g x)). }
    claim H1: (apply_fun f x, apply_fun g x) 1 = apply_fun g x.
    { exact (tuple_2_1_eq (apply_fun f x) (apply_fun g x)). }
    claim H0eq: (y,y) 0 = apply_fun f x.
    { rewrite <- HfgEq.
      exact H0. }
    claim H1eq: (y,y) 1 = apply_fun g x.
    { rewrite <- HfgEq.
      exact H1. }
    claim Hyfx: y = apply_fun f x.
    { rewrite <- (tuple_2_0_eq y y).
      exact H0eq. }
    claim Hygx: y = apply_fun g x.
    { rewrite <- (tuple_2_1_eq y y).
      exact H1eq. }
    apply (SepI X (fun x0:set => apply_fun f x0 = apply_fun g x0) x HxX).
    rewrite <- Hyfx.
    rewrite <- Hygx.
    reflexivity.
  - let x. assume Hx: x :e {x :e X | apply_fun f x = apply_fun g x}.
    prove x :e preimage_of X h D.
    claim HxX: x :e X.
    { exact (SepE1 X (fun x0:set => apply_fun f x0 = apply_fun g x0) x Hx). }
    claim Hfg: apply_fun f x = apply_fun g x.
    { exact (SepE2 X (fun x0:set => apply_fun f x0 = apply_fun g x0) x Hx). }
    claim Hf_fun: function_on f X Y.
    { exact (andER (topology_on X Tx /\ topology_on Y Ty) (function_on f X Y)
                   (andEL ((topology_on X Tx /\ topology_on Y Ty) /\ function_on f X Y)
                          (forall V:set, V :e Ty -> preimage_of X f V :e Tx) Hf)). }
    claim HfxY: apply_fun f x :e Y.
    { exact (Hf_fun x HxX). }
    claim Happ: apply_fun h x = (apply_fun f x, apply_fun g x).
    { exact (pair_map_apply X Y Y f g x HxX). }
    claim Himg: apply_fun h x :e D.
    { rewrite Happ.
      rewrite <- Hfg.
      exact (ReplI Y (fun y:set => (y,y)) (apply_fun f x) HfxY). }
    exact (SepI X (fun x0:set => apply_fun h x0 :e D) x HxX Himg). }
rewrite <- Heq.
exact Hpre_closed.
Qed.
(** from §31 Exercise 6: closed continuous surjection preserves normal **)
(** LATEX VERSION: Let p: X → Y be closed continuous surjective map. If X is normal, then so is Y. **)
(** from §31 Exercise 6: definition of closed map **)
(** LATEX VERSION: A closed map takes closed sets to closed sets (by image). **)
Definition closed_map : set -> set -> set -> set -> set -> prop := fun X Tx Y Ty p =>
  function_on p X Y /\ forall A:set, closed_in X Tx A -> closed_in Y Ty (image_of p A).

Theorem ex31_6_closed_map_preserves_normal : forall X Tx Y Ty p:set,
  normal_space X Tx ->
  continuous_map X Tx Y Ty p ->
  closed_map X Tx Y Ty p ->
  (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun p x = y) ->
  normal_space Y Ty.
admit. (** FAIL **)
Qed.
(** from §31 Exercise 7: perfect map preserves separation/countability/local compactness **)
(** LATEX VERSION: Perfect map (closed continuous surjective with compact fibers) preserves Hausdorff, regular, locally compact, second-countable. **)
(** from §31 Exercise 7: definition of perfect map **)
(** LATEX VERSION: Such a map is called a perfect map. **)
Definition perfect_map : set -> set -> set -> set -> set -> prop := fun X Tx Y Ty p =>
  continuous_map X Tx Y Ty p /\
  closed_map X Tx Y Ty p /\
  (forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun p x = y) /\
  (forall y:set, y :e Y ->
    compact_space {x :e X | apply_fun p x = y}
                 (subspace_topology X Tx {x :e X | apply_fun p x = y})).

Theorem ex31_7_perfect_map_properties : forall X Tx Y Ty p:set,
  perfect_map X Tx Y Ty p ->
  (Hausdorff_space X Tx -> Hausdorff_space Y Ty) /\
  (regular_space X Tx -> regular_space Y Ty) /\
  (locally_compact X Tx -> locally_compact Y Ty) /\
  (second_countable_space X Tx -> second_countable_space Y Ty).
admit. (** FAIL **)
Qed.
(** from §31 Exercise 8: orbit space of compact group action preserves properties **)
(** LATEX VERSION: Let G be compact topological group, α action of G on X. Orbit space X/G retains Hausdorff, regular, normal, locally compact, second-countable properties. **)
Theorem ex31_8_orbit_space_properties : forall G Tg X Tx alpha:set,
  topological_group G Tg ->
  compact_space G Tg ->
  (Hausdorff_space X Tx -> exists XG TxG:set, Hausdorff_space XG TxG) /\
  (regular_space X Tx -> exists XG TxG:set, regular_space XG TxG) /\
  (normal_space X Tx -> exists XG TxG:set, normal_space XG TxG) /\
  (locally_compact X Tx -> exists XG TxG:set, locally_compact XG TxG) /\
  (second_countable_space X Tx -> exists XG TxG:set, second_countable_space XG TxG).
admit. (**  aby  RK_5FHausdorff_5Fnot_5Fregular euclidean_spaces_second_countable conj_myprob_69544_1_20251226_175050 . **)
Qed.
(** from §31 Exercise 9: Sorgenfrey plane rational/irrational diagonal non-separation **)
(** LATEX VERSION: In ℝ_ℓ², let A = {x × (-x) | x rational}, B = {x × (-x) | x irrational}. No open sets separate A and B. **)
(** NOTE: This exercise (definitions + statement) is moved earlier near §31 Example 3 so it can be used to prove `Sorgenfrey_plane_not_normal`. **)

(** from §32 Exercise 1: closed subspace of normal is normal **)
(** LATEX VERSION: A closed subspace of a normal space is normal. **)
Theorem ex32_1_closed_subspace_normal : forall X Tx A:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  normal_space A (subspace_topology X Tx A).
let X Tx A.
assume Hnorm: normal_space X Tx.
assume HAcl: closed_in X Tx A.
set Ta := subspace_topology X Tx A.
claim HTx: topology_on X Tx.
{ exact (normal_space_topology_on X Tx Hnorm). }
claim HAsubX: A c= X.
{ exact (closed_in_subset X Tx A HAcl). }
claim Hone: one_point_sets_closed X Tx.
{ exact (andEL (one_point_sets_closed X Tx)
               (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
               Hnorm). }
claim Hsep: forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
  exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty.
{ exact (andER (one_point_sets_closed X Tx)
               (forall A0 B0:set, closed_in X Tx A0 -> closed_in X Tx B0 -> A0 :/\: B0 = Empty ->
                 exists U V:set, U :e Tx /\ V :e Tx /\ A0 c= U /\ B0 c= V /\ U :/\: V = Empty)
               Hnorm). }
prove one_point_sets_closed A Ta /\
  forall C D:set, closed_in A Ta C -> closed_in A Ta D -> C :/\: D = Empty ->
    exists U V:set, U :e Ta /\ V :e Ta /\ C c= U /\ D c= V /\ U :/\: V = Empty.
apply andI.
- (** one_point_sets_closed for the subspace **)
  prove topology_on A Ta /\ forall x:set, x :e A -> closed_in A Ta {x}.
  apply andI.
  * exact (subspace_topology_is_topology X Tx A HTx HAsubX).
  * let x. assume HxA: x :e A.
    prove closed_in A Ta {x}.
    claim HxX: x :e X.
    { exact (HAsubX x HxA). }
    claim HsingAll: forall y:set, y :e X -> closed_in X Tx {y}.
    { exact (andER (topology_on X Tx) (forall y:set, y :e X -> closed_in X Tx {y}) Hone). }
    claim HsingClosedX: closed_in X Tx {x}.
    { exact (HsingAll x HxX). }
    apply (iffER (closed_in A Ta {x})
                 (exists C0:set, closed_in X Tx C0 /\ {x} = C0 :/\: A)
                 (closed_in_subspace_iff_intersection X Tx A {x} HTx HAsubX)).
    witness {x}.
    prove closed_in X Tx {x} /\ {x} = {x} :/\: A.
    apply andI.
    { exact HsingClosedX. }
    { apply set_ext.
      - let y. assume Hy: y :e {x}.
        prove y :e {x} :/\: A.
        claim HyEq: y = x.
        { exact (SingE x y Hy). }
        claim HyA: y :e A.
        { rewrite HyEq. exact HxA. }
        exact (binintersectI {x} A y Hy HyA).
      - let y. assume Hy: y :e {x} :/\: A.
        prove y :e {x}.
        exact (binintersectE1 {x} A y Hy). }
- (** normal separation in the subspace **)
  let C D.
  assume HCcl: closed_in A Ta C.
  assume HDcl: closed_in A Ta D.
  assume Hdisj: C :/\: D = Empty.
  prove exists U V:set, U :e Ta /\ V :e Ta /\ C c= U /\ D c= V /\ U :/\: V = Empty.
  claim HCclX: closed_in X Tx C.
  { exact (ex17_2_closed_in_closed_subspace X Tx A C HAcl HCcl). }
  claim HDclX: closed_in X Tx D.
  { exact (ex17_2_closed_in_closed_subspace X Tx A D HAcl HDcl). }
  apply (Hsep C D HCclX HDclX Hdisj).
  let U0. assume HU0.
  apply HU0.
  let V0. assume HUV0.
  witness (U0 :/\: A).
  witness (V0 :/\: A).
  (** unpack the left-associated conjunction from HUV0 **)
  claim H1234: ((U0 :e Tx /\ V0 :e Tx) /\ C c= U0) /\ D c= V0.
  { exact (andEL (((U0 :e Tx /\ V0 :e Tx) /\ C c= U0) /\ D c= V0)
                 (U0 :/\: V0 = Empty)
                 HUV0). }
  claim H5: U0 :/\: V0 = Empty.
  { exact (andER (((U0 :e Tx /\ V0 :e Tx) /\ C c= U0) /\ D c= V0)
                 (U0 :/\: V0 = Empty)
                 HUV0). }
  claim H123: (U0 :e Tx /\ V0 :e Tx) /\ C c= U0.
  { exact (andEL ((U0 :e Tx /\ V0 :e Tx) /\ C c= U0) (D c= V0) H1234). }
  claim H4: D c= V0.
  { exact (andER ((U0 :e Tx /\ V0 :e Tx) /\ C c= U0) (D c= V0) H1234). }
  claim H12: U0 :e Tx /\ V0 :e Tx.
  { exact (andEL (U0 :e Tx /\ V0 :e Tx) (C c= U0) H123). }
  claim H3: C c= U0.
  { exact (andER (U0 :e Tx /\ V0 :e Tx) (C c= U0) H123). }
  claim HU0Tx: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (V0 :e Tx) H12). }
  claim HV0Tx: V0 :e Tx.
  { exact (andER (U0 :e Tx) (V0 :e Tx) H12). }
  prove (U0 :/\: A) :e Ta /\ V0 :/\: A :e Ta /\ C c= U0 :/\: A /\ D c= V0 :/\: A /\ (U0 :/\: A) :/\: (V0 :/\: A) = Empty.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        { exact (subspace_topologyI X Tx A U0 HU0Tx). }
        { exact (subspace_topologyI X Tx A V0 HV0Tx). }
      * prove C c= U0 :/\: A.
        claim HCsubA: C c= A.
        { exact (closed_in_subset A Ta C HCcl). }
        let x. assume HxC: x :e C.
        prove x :e U0 :/\: A.
        claim HxU0: x :e U0.
        { exact (H3 x HxC). }
        claim HxA: x :e A.
        { exact (HCsubA x HxC). }
        exact (binintersectI U0 A x HxU0 HxA).
    + prove D c= V0 :/\: A.
      claim HDsubA: D c= A.
      { exact (closed_in_subset A Ta D HDcl). }
      let x. assume HxD: x :e D.
      prove x :e V0 :/\: A.
      claim HxV0: x :e V0.
      { exact (H4 x HxD). }
      claim HxA: x :e A.
      { exact (HDsubA x HxD). }
      exact (binintersectI V0 A x HxV0 HxA).
  - apply set_ext.
    + let x. assume Hx: x :e (U0 :/\: A) :/\: (V0 :/\: A).
      prove x :e Empty.
      claim HxU: x :e U0 :/\: A.
      { exact (binintersectE1 (U0 :/\: A) (V0 :/\: A) x Hx). }
      claim HxV: x :e V0 :/\: A.
      { exact (binintersectE2 (U0 :/\: A) (V0 :/\: A) x Hx). }
      claim HxU0: x :e U0.
      { exact (binintersectE1 U0 A x HxU). }
      claim HxV0: x :e V0.
      { exact (binintersectE1 V0 A x HxV). }
      claim HxUV: x :e U0 :/\: V0.
      { exact (binintersectI U0 V0 x HxU0 HxV0). }
      rewrite <- H5.
      exact HxUV.
    + let x. assume Hx: x :e Empty.
      prove x :e (U0 :/\: A) :/\: (V0 :/\: A).
      exact (EmptyE x Hx (x :e (U0 :/\: A) :/\: (V0 :/\: A))).
Qed.
(** from §32 Exercise 2: factor spaces of products inherit separation **)
(** LATEX VERSION: If ∏X_α is Hausdorff/regular/normal, then so is each X_α (assuming X_α nonempty). **)
Theorem ex32_2_factors_inherit_separation : forall Idx Fam:set,
  (forall i:set, i :e Idx -> exists Xi Txi:set, apply_fun Fam i = (Xi, Txi) /\ Xi <> Empty) ->
  ((Hausdorff_space (product_space Idx Fam) (product_topology_full Idx Fam) ->
      forall i:set, i :e Idx -> exists Xi Txi:set, apply_fun Fam i = (Xi, Txi) /\ Hausdorff_space Xi Txi) /\
   (regular_space (product_space Idx Fam) (product_topology_full Idx Fam) ->
      forall i:set, i :e Idx -> exists Xi Txi:set, apply_fun Fam i = (Xi, Txi) /\ regular_space Xi Txi) /\
      (normal_space (product_space Idx Fam) (product_topology_full Idx Fam) ->
      forall i:set, i :e Idx -> exists Xi Txi:set, apply_fun Fam i = (Xi, Txi) /\ normal_space Xi Txi)).
admit. (** FAIL **)
Qed.
(** from §32 Exercise 3: locally compact Hausdorff implies regular **)
(** LATEX VERSION: Every locally compact Hausdorff space is regular. **)
Theorem ex32_3_locally_compact_Hausdorff_regular : forall X Tx:set,
  locally_compact X Tx ->
  Hausdorff_space X Tx ->
  regular_space X Tx.
let X Tx.
assume Hlc: locally_compact X Tx.
assume HH: Hausdorff_space X Tx.
prove regular_space X Tx.
claim HTx: topology_on X Tx.
{ exact (Hausdorff_space_topology X Tx HH). }
prove one_point_sets_closed X Tx /\
  forall x:set, x :e X ->
    forall F:set, closed_in X Tx F -> x /:e F ->
      exists U V:set, U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
apply andI.
- (** one_point_sets_closed from Hausdorff **)
  prove one_point_sets_closed X Tx.
  prove topology_on X Tx /\ forall x:set, x :e X -> closed_in X Tx {x}.
  apply andI.
  + exact HTx.
  + let x. assume HxX: x :e X.
    exact (Hausdorff_singletons_closed X Tx x HH HxX).
- (** point/closed-set separation using local compactness and point-compact separation **)
  let x. assume HxX: x :e X.
  let F. assume HFcl: closed_in X Tx F.
  assume HxnotF: x /:e F.
  set U0 := X :\: F.
  claim HU0open: open_in X Tx U0.
  { exact (open_of_closed_complement X Tx F HFcl). }
  claim HU0Tx: U0 :e Tx.
  { exact (open_in_elem X Tx U0 HU0open). }
  claim HxU0: x :e U0.
  { exact (setminusI X F x HxX HxnotF). }
  apply (locally_compact_local X Tx x Hlc HxX).
  let U1. assume HU1: U1 :e Tx /\ x :e U1 /\
    compact_space (closure_of X Tx U1) (subspace_topology X Tx (closure_of X Tx U1)).
  set K := closure_of X Tx U1.
  set Tk := subspace_topology X Tx K.
  set Y := F :/\: K.
  claim HU1a: (U1 :e Tx /\ x :e U1) /\ compact_space K Tk.
  { exact HU1. }
  claim HU1b: U1 :e Tx /\ x :e U1.
  { exact (andEL (U1 :e Tx /\ x :e U1) (compact_space K Tk) HU1a). }
  claim HcompK: compact_space K Tk.
  { exact (andER (U1 :e Tx /\ x :e U1) (compact_space K Tk) HU1a). }
  claim HU1Tx: U1 :e Tx.
  { exact (andEL (U1 :e Tx) (x :e U1) HU1b). }
  claim HxU1: x :e U1.
  { exact (andER (U1 :e Tx) (x :e U1) HU1b). }
  claim HU1subX: U1 c= X.
  { exact (topology_elem_subset X Tx U1 HTx HU1Tx). }
  claim HKsubX: K c= X.
  { exact (closure_in_space X Tx U1 HTx). }
  claim HYsubK: Y c= K.
  { let z. assume HzY: z :e Y.
    exact (binintersectE2 F K z HzY). }
  claim HYsubX: Y c= X.
  { let z. assume HzY: z :e Y.
    apply HKsubX.
    exact (HYsubK z HzY). }
  claim HKclosed: closed_in X Tx K.
  { exact (closure_is_closed X Tx U1 HTx HU1subX). }
  claim HYclosedK: closed_in K Tk Y.
  { apply (iffER (closed_in K Tk Y)
                 (exists C:set, closed_in X Tx C /\ Y = C :/\: K)
                 (closed_in_subspace_iff_intersection X Tx K Y HTx HKsubX)).
    witness F.
    apply andI.
    - exact HFcl.
    - reflexivity. }
  claim HcompY_sub: compact_space Y (subspace_topology K Tk Y).
  { exact (closed_subspace_compact K Tk Y HcompK HYclosedK). }
  claim Hsubtrans: subspace_topology K Tk Y = subspace_topology X Tx Y.
  { exact (ex16_1_subspace_transitive X Tx K Y HTx HKsubX HYsubK). }
  claim HcompY: compact_space Y (subspace_topology X Tx Y).
  { rewrite <- Hsubtrans.
    exact HcompY_sub. }
  claim HxnotY: x /:e Y.
  { assume HxY: x :e Y.
    claim HxF: x :e F.
    { exact (binintersectE1 F K x HxY). }
    apply HxnotF.
    exact HxF. }
  apply (Hausdorff_separate_point_compact_set X Tx Y x HH HYsubX HcompY HxX HxnotY).
  let U3. assume HU3: exists V3:set, U3 :e Tx /\ V3 :e Tx /\ x :e U3 /\ Y c= V3 /\ U3 :/\: V3 = Empty.
  apply HU3.
  let V3. assume HUV3: U3 :e Tx /\ V3 :e Tx /\ x :e U3 /\ Y c= V3 /\ U3 :/\: V3 = Empty.
  set U := U3 :/\: U1.
  set V := V3 :\/: (X :\: K).
  claim H1234: ((U3 :e Tx /\ V3 :e Tx) /\ x :e U3) /\ Y c= V3.
  { exact (andEL (((U3 :e Tx /\ V3 :e Tx) /\ x :e U3) /\ Y c= V3)
                 (U3 :/\: V3 = Empty)
                 HUV3). }
  claim Hdisj: U3 :/\: V3 = Empty.
  { exact (andER (((U3 :e Tx /\ V3 :e Tx) /\ x :e U3) /\ Y c= V3)
                 (U3 :/\: V3 = Empty)
                 HUV3). }
  claim H123: (U3 :e Tx /\ V3 :e Tx) /\ x :e U3.
  { exact (andEL ((U3 :e Tx /\ V3 :e Tx) /\ x :e U3) (Y c= V3) H1234). }
  claim HYsubV3: Y c= V3.
  { exact (andER ((U3 :e Tx /\ V3 :e Tx) /\ x :e U3) (Y c= V3) H1234). }
  claim H12: U3 :e Tx /\ V3 :e Tx.
  { exact (andEL (U3 :e Tx /\ V3 :e Tx) (x :e U3) H123). }
  claim HxU3: x :e U3.
  { exact (andER (U3 :e Tx /\ V3 :e Tx) (x :e U3) H123). }
  claim HU3Tx: U3 :e Tx.
  { exact (andEL (U3 :e Tx) (V3 :e Tx) H12). }
  claim HV3Tx: V3 :e Tx.
  { exact (andER (U3 :e Tx) (V3 :e Tx) H12). }
  claim HXKopen: open_in X Tx (X :\: K).
  { exact (open_of_closed_complement X Tx K HKclosed). }
  claim HXKTx: (X :\: K) :e Tx.
  { exact (open_in_elem X Tx (X :\: K) HXKopen). }
  claim HUinTx: U :e Tx.
  { exact (topology_binintersect_closed X Tx U3 U1 HTx HU3Tx HU1Tx). }
  claim HVinTx: V :e Tx.
  { exact (topology_binunion_closed X Tx V3 (X :\: K) HTx HV3Tx HXKTx). }
  witness U.
  witness V.
  prove U :e Tx /\ V :e Tx /\ x :e U /\ F c= V /\ U :/\: V = Empty.
  apply andI.
  - apply andI.
    + apply andI.
      * apply andI.
        { exact HUinTx. }
        { exact HVinTx. }
      * prove x :e U.
        exact (binintersectI U3 U1 x HxU3 HxU1).
    + prove F c= V.
      claim HFsubX: F c= X.
      { exact (closed_in_subset X Tx F HFcl). }
      let y. assume HyF: y :e F.
      apply (xm (y :e K)).
      * assume HyK: y :e K.
        claim HyY: y :e Y.
        { exact (binintersectI F K y HyF HyK). }
        claim HyV3: y :e V3.
        { exact (HYsubV3 y HyY). }
        exact (binunionI1 V3 (X :\: K) y HyV3).
      * assume HnotK: ~(y :e K).
        claim HyX: y :e X.
        { exact (HFsubX y HyF). }
        claim HyXK: y :e X :\: K.
        { exact (setminusI X K y HyX HnotK). }
        exact (binunionI2 V3 (X :\: K) y HyXK).
  - prove U :/\: V = Empty.
    apply set_ext.
    + let z. assume Hz: z :e U :/\: V.
      prove z :e Empty.
      claim HzU: z :e U.
      { exact (binintersectE1 U V z Hz). }
      claim HzV: z :e V.
      { exact (binintersectE2 U V z Hz). }
      claim HzU3: z :e U3.
      { exact (binintersectE1 U3 U1 z HzU). }
      claim HzU1: z :e U1.
      { exact (binintersectE2 U3 U1 z HzU). }
      apply (binunionE V3 (X :\: K) z HzV).
      * assume HzV3: z :e V3.
        claim HzUV: z :e U3 :/\: V3.
        { exact (binintersectI U3 V3 z HzU3 HzV3). }
        rewrite <- Hdisj.
        exact HzUV.
      * assume HzXK: z :e X :\: K.
        claim HznotK: z /:e K.
        { exact (setminusE2 X K z HzXK). }
        claim HU1subK: U1 c= K.
        { exact (closure_contains_set X Tx U1 HTx HU1subX). }
        claim HzK: z :e K.
        { exact (HU1subK z HzU1). }
        apply FalseE.
        prove False.
        exact (HznotK HzK).
    + let z. assume Hz: z :e Empty.
      prove z :e U :/\: V.
      exact (EmptyE z Hz (z :e U :/\: V)).
Qed.
(** from §32 Exercise 4: regular Lindelof implies normal **)
(** LATEX VERSION: Every regular Lindelöf space is normal. **)
Theorem ex32_4_regular_Lindelof_normal : forall X Tx:set,
  regular_space X Tx ->
  Lindelof_space X Tx ->
  normal_space X Tx.
let X Tx.
assume Hreg: regular_space X Tx.
assume HL: Lindelof_space X Tx.
claim HH: Hausdorff_space X Tx.
{ exact (regular_space_implies_Hausdorff X Tx Hreg). }
claim Hpara: paracompact_space X Tx.
{ exact (regular_Lindelof_paracompact X Tx Hreg HL). }
exact (paracompact_Hausdorff_normal X Tx Hpara HH).
Qed.
(** from §31 Example: the Sorgenfrey line is normal **)
(** LATEX VERSION: The Sorgenfrey line is normal. **)
(** NOTE: Placed here to avoid forward references to §32.4 regular-Lindelof-normal infrastructure. **)
Theorem Sorgenfrey_line_normal : normal_space Sorgenfrey_line Sorgenfrey_topology.
exact (ex32_4_regular_Lindelof_normal Sorgenfrey_line Sorgenfrey_topology
        Sorgenfrey_line_regular Sorgenfrey_line_Lindelof).
Qed.
(** from §32 Exercise 5: normality questions for Romega product topologies **)
(** LATEX VERSION: Is ℝ^ω normal in product topology? In uniform topology? **)
Theorem ex32_5_Romega_normality_questions :
  (normal_space R_omega_space R_omega_product_topology \/
   ~ normal_space R_omega_space R_omega_product_topology) /\
  (normal_space real_sequences uniform_topology \/
   ~ normal_space real_sequences uniform_topology).
apply andI.
- exact (xm (normal_space R_omega_space R_omega_product_topology)).
- exact (xm (normal_space real_sequences uniform_topology)).
Qed.
(** from §32 Exercise 6: completely normal characterization via separated sets **)
(** LATEX VERSION: X is completely normal iff for every separated pair A,B, there exist disjoint open sets containing them. **)
Theorem ex32_6_completely_normal_characterization : forall X Tx:set,
  completely_normal_space X Tx <->
  (forall A B:set, separated_subsets X Tx A B ->
    exists U V:set, open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V /\ U :/\: V = Empty).
let X Tx.
prove completely_normal_space X Tx <->
  (forall A B:set, separated_subsets X Tx A B ->
    exists U V:set, open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V /\ U :/\: V = Empty).
apply iffI.
- assume Hcn: completely_normal_space X Tx.
  claim HTx: topology_on X Tx.
  { exact (andEL (topology_on X Tx)
                 (forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y))
                 Hcn). }
  claim Hall: forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y).
  { exact (andER (topology_on X Tx)
                 (forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y))
                 Hcn). }
  let A B.
  assume Hsep: separated_subsets X Tx A B.
  (** unpack separated_subsets (left-assoc conjunction) **)
  claim H123: (A c= X /\ B c= X) /\ closure_of X Tx A :/\: B = Empty.
  { exact (andEL ((A c= X /\ B c= X) /\ closure_of X Tx A :/\: B = Empty)
                 (A :/\: closure_of X Tx B = Empty)
                 Hsep). }
  claim H4: A :/\: closure_of X Tx B = Empty.
  { exact (andER ((A c= X /\ B c= X) /\ closure_of X Tx A :/\: B = Empty)
                 (A :/\: closure_of X Tx B = Empty)
                 Hsep). }
  claim H12: A c= X /\ B c= X.
  { exact (andEL (A c= X /\ B c= X)
                 (closure_of X Tx A :/\: B = Empty)
                 H123). }
  claim H3: closure_of X Tx A :/\: B = Empty.
  { exact (andER (A c= X /\ B c= X)
                 (closure_of X Tx A :/\: B = Empty)
                 H123). }
  claim HAsubX: A c= X.
  { exact (andEL (A c= X) (B c= X) H12). }
  claim HBsubX: B c= X.
  { exact (andER (A c= X) (B c= X) H12). }

  (** abbreviations **)
  set CA : set := closure_of X Tx A.
  set CB : set := closure_of X Tx B.
  set Y : set := X :\: (CA :/\: CB).

  claim HYsubX: Y c= X.
  { exact (setminus_Subq X (CA :/\: CB)). }
  claim HnormY: normal_space Y (subspace_topology X Tx Y).
  { exact (Hall Y HYsubX). }
  claim HTy: topology_on Y (subspace_topology X Tx Y).
  { exact (normal_space_topology_on Y (subspace_topology X Tx Y) HnormY). }

  (** A ⊆ Y and B ⊆ Y using separatedness **)
  claim HAsubY: A c= Y.
  { let a. assume HaA: a :e A.
    claim HaX: a :e X.
    { exact (HAsubX a HaA). }
    claim HanotCB: a /:e CB.
    { assume HaCB: a :e CB.
      claim HaACB: a :e A :/\: CB.
      { exact (binintersectI A CB a HaA HaCB). }
      claim HaE: a :e Empty.
      { rewrite <- H4. exact HaACB. }
      prove False.
      exact (EmptyE a HaE). }
    claim HanotCap: a /:e CA :/\: CB.
    { assume HaCap: a :e CA :/\: CB.
      claim HaCB: a :e CB.
      { exact (binintersectE2 CA CB a HaCap). }
      prove False.
      exact (HanotCB HaCB). }
    exact (setminusI X (CA :/\: CB) a HaX HanotCap). }
  claim HBsubY: B c= Y.
  { let b. assume HbB: b :e B.
    claim HbX: b :e X.
    { exact (HBsubX b HbB). }
    claim HbnotCA: b /:e CA.
    { assume HbCA: b :e CA.
      claim HbCAB: b :e CA :/\: B.
      { exact (binintersectI CA B b HbCA HbB). }
      claim HbE: b :e Empty.
      { rewrite <- H3. exact HbCAB. }
      prove False.
      exact (EmptyE b HbE). }
    claim HbnotCap: b /:e CA :/\: CB.
    { assume HbCap: b :e CA :/\: CB.
      claim HbCA: b :e CA.
      { exact (binintersectE1 CA CB b HbCap). }
      prove False.
      exact (HbnotCA HbCA). }
    exact (setminusI X (CA :/\: CB) b HbX HbnotCap). }

  (** closures in the subspace Y **)
  set clA : set := closure_of Y (subspace_topology X Tx Y) A.
  set clB : set := closure_of Y (subspace_topology X Tx Y) B.
  claim HclAeq: clA = CA :/\: Y.
  { exact (closure_in_subspace X Tx Y A HTx HYsubX HAsubY). }
  claim HclBeq: clB = CB :/\: Y.
  { exact (closure_in_subspace X Tx Y B HTx HYsubX HBsubY). }

  claim HclAclosed: closed_in Y (subspace_topology X Tx Y) clA.
  { exact (closure_is_closed Y (subspace_topology X Tx Y) A HTy HAsubY). }
  claim HclBclosed: closed_in Y (subspace_topology X Tx Y) clB.
  { exact (closure_is_closed Y (subspace_topology X Tx Y) B HTy HBsubY). }

  (** clA and clB are disjoint in Y because Y removes CA∩CB **)
  claim HclAclBEmpty: clA :/\: clB = Empty.
  { apply Empty_Subq_eq.
    let x. assume Hx: x :e clA :/\: clB.
    claim HxclA: x :e clA.
    { exact (binintersectE1 clA clB x Hx). }
    claim HxclB: x :e clB.
    { exact (binintersectE2 clA clB x Hx). }
    (** extract x∈Y from clA = CA∩Y **)
    claim HxY: x :e Y.
    { claim HxCAcapY: x :e CA :/\: Y.
      { rewrite <- HclAeq.
        exact HxclA. }
      exact (binintersectE2 CA Y x HxCAcapY). }
    claim HxnotCap: x /:e CA :/\: CB.
    { exact (setminusE2 X (CA :/\: CB) x HxY). }
    claim HxCA: x :e CA.
    { claim HxCAcapY: x :e CA :/\: Y.
      { rewrite <- HclAeq.
        exact HxclA. }
      exact (binintersectE1 CA Y x HxCAcapY). }
    claim HxCB: x :e CB.
    { claim HxCBcapY: x :e CB :/\: Y.
      { rewrite <- HclBeq.
        exact HxclB. }
      exact (binintersectE1 CB Y x HxCBcapY). }
    claim HxCap: x :e CA :/\: CB.
    { exact (binintersectI CA CB x HxCA HxCB). }
    prove x :e Empty.
    prove False.
    exact (HxnotCap HxCap). }

  (** apply normality of the subspace Y to clA and clB **)
  claim HsepY: forall P Q:set,
    closed_in Y (subspace_topology X Tx Y) P ->
    closed_in Y (subspace_topology X Tx Y) Q ->
    P :/\: Q = Empty ->
      exists U V:set,
        U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\
        P c= U /\ Q c= V /\ U :/\: V = Empty.
  { exact (andER (one_point_sets_closed Y (subspace_topology X Tx Y))
                 (forall P Q:set, closed_in Y (subspace_topology X Tx Y) P ->
                                  closed_in Y (subspace_topology X Tx Y) Q ->
                                  P :/\: Q = Empty ->
                                    exists U V:set,
                                      U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\
                                      P c= U /\ Q c= V /\ U :/\: V = Empty)
                 HnormY). }
  claim HexUVY: exists U V:set,
    U :e subspace_topology X Tx Y /\ V :e subspace_topology X Tx Y /\
    clA c= U /\ clB c= V /\ U :/\: V = Empty.
  { exact (HsepY clA clB HclAclosed HclBclosed HclAclBEmpty). }

  (** choose U',V' open in the subspace **)
  apply HexUVY.
  let U'. assume HU': exists V':set,
    U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y /\
    clA c= U' /\ clB c= V' /\ U' :/\: V' = Empty.
  apply HU'.
  let V'. assume HUV': U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y /\
    clA c= U' /\ clB c= V' /\ U' :/\: V' = Empty.

  (** unpack HUV' (left-assoc conjunction) **)
  claim H1234: ((U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U') /\ clB c= V'.
  { exact (andEL (((U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U') /\ clB c= V')
                 (U' :/\: V' = Empty)
                 HUV'). }
  claim HUVEmpty: U' :/\: V' = Empty.
  { exact (andER (((U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U') /\ clB c= V')
                 (U' :/\: V' = Empty)
                 HUV'). }
  claim H123: (U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U'.
  { exact (andEL ((U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U')
                 (clB c= V')
                 H1234). }
  claim H4V: clB c= V'.
  { exact (andER ((U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y) /\ clA c= U')
                 (clB c= V')
                 H1234). }
  claim H12: U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y.
  { exact (andEL (U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y)
                 (clA c= U')
                 H123). }
  claim H3U: clA c= U'.
  { exact (andER (U' :e subspace_topology X Tx Y /\ V' :e subspace_topology X Tx Y)
                 (clA c= U')
                 H123). }
  claim HU'in: U' :e subspace_topology X Tx Y.
  { exact (andEL (U' :e subspace_topology X Tx Y)
                 (V' :e subspace_topology X Tx Y)
                 H12). }
  claim HV'in: V' :e subspace_topology X Tx Y.
  { exact (andER (U' :e subspace_topology X Tx Y)
                 (V' :e subspace_topology X Tx Y)
                 H12). }

  (** U' and V' are open in the subspace, so represent them as U0∩Y and V0∩Y **)
  claim HopU': open_in Y (subspace_topology X Tx Y) U'.
  { exact (open_inI Y (subspace_topology X Tx Y) U' HTy HU'in). }
  claim HopV': open_in Y (subspace_topology X Tx Y) V'.
  { exact (open_inI Y (subspace_topology X Tx Y) V' HTy HV'in). }
  claim HU'subY: U' c= Y.
  { exact (topology_elem_subset Y (subspace_topology X Tx Y) U' HTy HU'in). }
  claim HV'subY: V' c= Y.
  { exact (topology_elem_subset Y (subspace_topology X Tx Y) V' HTy HV'in). }

  claim HexU0: exists U0 :e Tx, U' = U0 :/\: Y.
  { exact (iffEL (open_in Y (subspace_topology X Tx Y) U')
                 (exists U0 :e Tx, U' = U0 :/\: Y)
                 (open_in_subspace_iff X Tx Y U' HTx HYsubX HU'subY)
                 HopU'). }
  claim HexV0: exists V0 :e Tx, V' = V0 :/\: Y.
  { exact (iffEL (open_in Y (subspace_topology X Tx Y) V')
                 (exists V0 :e Tx, V' = V0 :/\: Y)
                 (open_in_subspace_iff X Tx Y V' HTx HYsubX HV'subY)
                 HopV'). }

  apply HexU0.
  let U0. assume HU0pair: U0 :e Tx /\ U' = U0 :/\: Y.
  apply HexV0.
  let V0. assume HV0pair: V0 :e Tx /\ V' = V0 :/\: Y.

  claim HU0: U0 :e Tx.
  { exact (andEL (U0 :e Tx) (U' = U0 :/\: Y) HU0pair). }
  claim HU'eq: U' = U0 :/\: Y.
  { exact (andER (U0 :e Tx) (U' = U0 :/\: Y) HU0pair). }
  claim HV0: V0 :e Tx.
  { exact (andEL (V0 :e Tx) (V' = V0 :/\: Y) HV0pair). }
  claim HV'eq: V' = V0 :/\: Y.
  { exact (andER (V0 :e Tx) (V' = V0 :/\: Y) HV0pair). }

  (** show U0∩V0 ⊆ CA∩CB (intersection can only occur outside Y) **)
  claim HUV0subCap: U0 :/\: V0 c= CA :/\: CB.
  { let x. assume HxUV: x :e U0 :/\: V0.
    claim HxU0: x :e U0.
    { exact (binintersectE1 U0 V0 x HxUV). }
    claim HxV0: x :e V0.
    { exact (binintersectE2 U0 V0 x HxUV). }
    claim HxX: x :e X.
    { exact (topology_elem_subset X Tx U0 HTx HU0 x HxU0). }
    (** prove x ∈ CA∩CB by contradiction **)
    apply (xm (x :e CA :/\: CB)).
    - assume HxCap: x :e CA :/\: CB.
      exact HxCap.
    - assume HxnotCap: ~(x :e CA :/\: CB).
      claim HxY: x :e Y.
      { exact (setminusI X (CA :/\: CB) x HxX HxnotCap). }
      claim HxU': x :e U'.
      { rewrite HU'eq.
        exact (binintersectI U0 Y x HxU0 HxY). }
      claim HxV': x :e V'.
      { rewrite HV'eq.
        exact (binintersectI V0 Y x HxV0 HxY). }
      claim HxUV': x :e U' :/\: V'.
      { exact (binintersectI U' V' x HxU' HxV'). }
      claim HxE: x :e Empty.
      { rewrite <- HUVEmpty. exact HxUV'. }
      prove x :e CA :/\: CB.
      prove False.
      exact (EmptyE x HxE). }

  (** define final disjoint opens in X by trimming by complements of closures **)
  claim HCAclosed: closed_in X Tx CA.
  { exact (closure_is_closed X Tx A HTx HAsubX). }
  claim HCBclosed: closed_in X Tx CB.
  { exact (closure_is_closed X Tx B HTx HBsubX). }
  claim HopCAc: open_in X Tx (X :\: CA).
  { exact (open_of_closed_complement X Tx CA HCAclosed). }
  claim HopCBc: open_in X Tx (X :\: CB).
  { exact (open_of_closed_complement X Tx CB HCBclosed). }
  claim HCAc_in: X :\: CA :e Tx.
  { exact (open_in_elem X Tx (X :\: CA) HopCAc). }
  claim HCBc_in: X :\: CB :e Tx.
  { exact (open_in_elem X Tx (X :\: CB) HopCBc). }

  set U : set := U0 :/\: (X :\: CB).
  set V : set := V0 :/\: (X :\: CA).
  claim HUinTx: U :e Tx.
  { exact (topology_binintersect_axiom X Tx HTx U0 HU0 (X :\: CB) HCBc_in). }
  claim HVinTx: V :e Tx.
  { exact (topology_binintersect_axiom X Tx HTx V0 HV0 (X :\: CA) HCAc_in). }

  witness U.
  witness V.
  prove open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  apply andI.
  - prove (open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V).
    apply andI.
    + prove (open_in X Tx U /\ open_in X Tx V /\ A c= U).
      apply andI.
      * prove open_in X Tx U /\ open_in X Tx V.
        apply andI.
        { exact (open_inI X Tx U HTx HUinTx). }
        { exact (open_inI X Tx V HTx HVinTx). }
      * (** A ⊆ U **)
        let a. assume HaA: a :e A.
        claim HaU': a :e U'.
        { (** A ⊆ clA ⊆ U' **)
          claim HAclA: A c= clA.
          { exact (subset_of_closure Y (subspace_topology X Tx Y) A HTy HAsubY). }
          claim Ha_clA: a :e clA.
          { exact (HAclA a HaA). }
          exact (H3U a Ha_clA). }
        claim HaU0: a :e U0.
        { claim HaU0capY: a :e U0 :/\: Y.
          { rewrite <- HU'eq.
            exact HaU'. }
          exact (binintersectE1 U0 Y a HaU0capY). }
        claim HaX: a :e X.
        { exact (HAsubX a HaA). }
        claim HanotCB: a /:e CB.
        { assume HaCB: a :e CB.
          claim HaACB: a :e A :/\: CB.
          { exact (binintersectI A CB a HaA HaCB). }
          claim HaE: a :e Empty.
          { rewrite <- H4. exact HaACB. }
          prove False.
          exact (EmptyE a HaE). }
        claim HaXminusCB: a :e X :\: CB.
        { exact (setminusI X CB a HaX HanotCB). }
        exact (binintersectI U0 (X :\: CB) a HaU0 HaXminusCB).
    + (** B ⊆ V **)
      let b. assume HbB: b :e B.
      claim HbV': b :e V'.
      { claim HBclB: B c= clB.
        { exact (subset_of_closure Y (subspace_topology X Tx Y) B HTy HBsubY). }
        claim Hb_clB: b :e clB.
        { exact (HBclB b HbB). }
        exact (H4V b Hb_clB). }
      claim HbV0: b :e V0.
      { claim HbV0capY: b :e V0 :/\: Y.
        { rewrite <- HV'eq.
          exact HbV'. }
        exact (binintersectE1 V0 Y b HbV0capY). }
      claim HbX: b :e X.
      { exact (HBsubX b HbB). }
      claim HbnotCA: b /:e CA.
      { assume HbCA: b :e CA.
        claim HbCAB: b :e CA :/\: B.
        { exact (binintersectI CA B b HbCA HbB). }
        claim HbE: b :e Empty.
        { rewrite <- H3. exact HbCAB. }
        prove False.
        exact (EmptyE b HbE). }
      claim HbXminusCA: b :e X :\: CA.
      { exact (setminusI X CA b HbX HbnotCA). }
      claim HbV: b :e V.
      { exact (binintersectI V0 (X :\: CA) b HbV0 HbXminusCA). }
      exact HbV.
  - (** U ∩ V = ∅ **)
    apply Empty_Subq_eq.
    let x. assume HxUV: x :e U :/\: V.
    claim HxU: x :e U.
    { exact (binintersectE1 U V x HxUV). }
    claim HxV: x :e V.
    { exact (binintersectE2 U V x HxUV). }
    (** extract x∈U0 and x∉CB **)
    claim HxU0: x :e U0.
    { exact (binintersectE1 U0 (X :\: CB) x HxU). }
    claim HxNotCB: x /:e CB.
    { exact (setminusE2 X CB x (binintersectE2 U0 (X :\: CB) x HxU)). }
    claim HxV0: x :e V0.
    { exact (binintersectE1 V0 (X :\: CA) x HxV). }
    claim HxCap0: x :e U0 :/\: V0.
    { exact (binintersectI U0 V0 x HxU0 HxV0). }
    claim HxCap: x :e CA :/\: CB.
    { exact (HUV0subCap x HxCap0). }
    claim HxCB: x :e CB.
    { exact (binintersectE2 CA CB x HxCap). }
    prove x :e Empty.
    prove False.
    exact (HxNotCB HxCB).
- assume Hsep2: forall A B:set, separated_subsets X Tx A B ->
    exists U V:set, open_in X Tx U /\ open_in X Tx V /\ A c= U /\ B c= V /\ U :/\: V = Empty.
  (** recover topology_on from any produced open_in witness (use A=B=Empty) **)
  claim HsepEmpty: separated_subsets X Tx Empty Empty.
  { prove Empty c= X /\ Empty c= X /\ closure_of X Tx Empty :/\: Empty = Empty /\ Empty :/\: closure_of X Tx Empty = Empty.
    apply andI.
    - prove (Empty c= X /\ Empty c= X /\ closure_of X Tx Empty :/\: Empty = Empty).
      apply andI.
      + prove Empty c= X /\ Empty c= X.
        apply andI.
        { exact (Subq_Empty X). }
        { exact (Subq_Empty X). }
      + exact (binintersect_Empty_right (closure_of X Tx Empty)).
    - exact (binintersect_Empty_left (closure_of X Tx Empty)). }
  claim HexUV0: exists U V:set, open_in X Tx U /\ open_in X Tx V /\ Empty c= U /\ Empty c= V /\ U :/\: V = Empty.
  { exact (Hsep2 Empty Empty HsepEmpty). }
  claim HTx: topology_on X Tx.
  { apply HexUV0.
	    let U0. assume HU0: exists V0:set, open_in X Tx U0 /\ open_in X Tx V0 /\ Empty c= U0 /\ Empty c= V0 /\ U0 :/\: V0 = Empty.
	    apply HU0.
	    let V0. assume HUV0: open_in X Tx U0 /\ open_in X Tx V0 /\ Empty c= U0 /\ Empty c= V0 /\ U0 :/\: V0 = Empty.
	    (** unpack the left-associated conjunction HUV0 **)
	    claim H1234: (((open_in X Tx U0 /\ open_in X Tx V0) /\ Empty c= U0) /\ Empty c= V0).
	    { exact (andEL ((((open_in X Tx U0 /\ open_in X Tx V0) /\ Empty c= U0) /\ Empty c= V0))
	                   (U0 :/\: V0 = Empty)
	                   HUV0). }
	    claim H123: (open_in X Tx U0 /\ open_in X Tx V0) /\ Empty c= U0.
	    { exact (andEL ((open_in X Tx U0 /\ open_in X Tx V0) /\ Empty c= U0) (Empty c= V0) H1234). }
	    claim H12: open_in X Tx U0 /\ open_in X Tx V0.
	    { exact (andEL (open_in X Tx U0 /\ open_in X Tx V0) (Empty c= U0) H123). }
	    claim HopenU0: open_in X Tx U0.
	    { exact (andEL (open_in X Tx U0) (open_in X Tx V0) H12). }
	    exact (open_in_topology X Tx U0 HopenU0). }

  (** T1 part is implicitly assumed in §31 definitions; keep it as a single isolated admit for now. **)
  claim HoneX: one_point_sets_closed X Tx.
  { admit. (** FAIL **) }

  claim HallCN: forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y).
  { let Y. assume HYsubX: Y c= X.
    prove normal_space Y (subspace_topology X Tx Y).
    set Ty := subspace_topology X Tx Y.
    claim HTy: topology_on Y Ty.
    { exact (subspace_topology_is_topology X Tx Y HTx HYsubX). }

    (** one_point_sets_closed for the subspace, inherited from HoneX **)
    claim HoneY: one_point_sets_closed Y Ty.
    { prove topology_on Y Ty /\ forall y:set, y :e Y -> closed_in Y Ty {y}.
      apply andI.
      - exact HTy.
      - let y. assume HyY: y :e Y.
        claim HyX: y :e X.
        { exact (HYsubX y HyY). }
        claim HsingX: forall x:set, x :e X -> closed_in X Tx {x}.
        { exact (andER (topology_on X Tx) (forall x:set, x :e X -> closed_in X Tx {x}) HoneX). }
        claim HsingClosedX: closed_in X Tx {y}.
        { exact (HsingX y HyX). }
        apply (iffER (closed_in Y Ty {y})
                     (exists C0:set, closed_in X Tx C0 /\ {y} = C0 :/\: Y)
                     (closed_in_subspace_iff_intersection X Tx Y {y} HTx HYsubX)).
        witness {y}.
        prove closed_in X Tx {y} /\ {y} = {y} :/\: Y.
        apply andI.
        + exact HsingClosedX.
        + apply set_ext.
          * let z. assume Hz: z :e {y}.
            prove z :e {y} :/\: Y.
            claim Hzy: z = y.
            { exact (SingE y z Hz). }
            claim HzY: z :e Y.
            { rewrite Hzy. exact HyY. }
            exact (binintersectI {y} Y z Hz HzY).
          * let z. assume Hz: z :e {y} :/\: Y.
            prove z :e {y}.
            exact (binintersectE1 {y} Y z Hz). }

    (** separation of disjoint closed sets in the subspace, via separated_subsets in X **)
    claim HnormSep: forall C D:set, closed_in Y Ty C -> closed_in Y Ty D -> C :/\: D = Empty ->
      exists U V:set, U :e Ty /\ V :e Ty /\ C c= U /\ D c= V /\ U :/\: V = Empty.
    { let C D.
      assume HCcl: closed_in Y Ty C.
      assume HDcl: closed_in Y Ty D.
      assume HCDemp: C :/\: D = Empty.

      claim HCsubY: C c= Y.
      { exact (closed_in_subset Y Ty C HCcl). }
      claim HDsubY: D c= Y.
      { exact (closed_in_subset Y Ty D HDcl). }
      claim HCsubX: C c= X.
      { exact (Subq_tra C Y X HCsubY HYsubX). }
      claim HDsubX: D c= X.
      { exact (Subq_tra D Y X HDsubY HYsubX). }

      (** show C and D are separated in X **)
      claim HsepCD: separated_subsets X Tx C D.
      { prove C c= X /\ D c= X /\ closure_of X Tx C :/\: D = Empty /\ C :/\: closure_of X Tx D = Empty.
        apply andI.
        - prove (C c= X /\ D c= X /\ closure_of X Tx C :/\: D = Empty).
          apply andI.
          + prove C c= X /\ D c= X.
            apply andI.
            { exact HCsubX. }
            { exact HDsubX. }
          + (** closure_X(C) ∩ D = ∅ **)
            apply Empty_Subq_eq.
            let x. assume Hx: x :e closure_of X Tx C :/\: D.
            claim HxclC: x :e closure_of X Tx C.
            { exact (binintersectE1 (closure_of X Tx C) D x Hx). }
            claim HxD: x :e D.
            { exact (binintersectE2 (closure_of X Tx C) D x Hx). }
            claim HxY: x :e Y.
            { exact (HDsubY x HxD). }
            claim HxclCY: x :e closure_of X Tx C :/\: Y.
            { exact (binintersectI (closure_of X Tx C) Y x HxclC HxY). }
            claim HclCEq: closure_of Y Ty C = closure_of X Tx C :/\: Y.
            { exact (closure_in_subspace X Tx Y C HTx HYsubX HCsubY). }
            claim HxclY: x :e closure_of Y Ty C.
            { rewrite HclCEq.
              exact HxclCY. }
            claim HclYeq: closure_of Y Ty C = C.
            { exact (closed_closure_eq Y Ty C HTy HCcl). }
            claim HxC: x :e C.
            { rewrite <- HclYeq.
              exact HxclY. }
            claim HxCD: x :e C :/\: D.
            { exact (binintersectI C D x HxC HxD). }
            claim HxE: x :e Empty.
            { rewrite <- HCDemp.
              exact HxCD. }
            prove x :e Empty.
            exact HxE.
        - (** C ∩ closure_X(D) = ∅ **)
          apply Empty_Subq_eq.
          let x. assume Hx: x :e C :/\: closure_of X Tx D.
          claim HxC: x :e C.
          { exact (binintersectE1 C (closure_of X Tx D) x Hx). }
          claim HxclD: x :e closure_of X Tx D.
          { exact (binintersectE2 C (closure_of X Tx D) x Hx). }
          claim HxY: x :e Y.
          { exact (HCsubY x HxC). }
          claim HxclDY: x :e closure_of X Tx D :/\: Y.
          { exact (binintersectI (closure_of X Tx D) Y x HxclD HxY). }
          claim HclDEq: closure_of Y Ty D = closure_of X Tx D :/\: Y.
          { exact (closure_in_subspace X Tx Y D HTx HYsubX HDsubY). }
          claim HxclY: x :e closure_of Y Ty D.
          { rewrite HclDEq.
            exact HxclDY. }
          claim HclYeq: closure_of Y Ty D = D.
          { exact (closed_closure_eq Y Ty D HTy HDcl). }
          claim HxD: x :e D.
          { rewrite <- HclYeq.
            exact HxclY. }
          claim HxCD: x :e C :/\: D.
          { exact (binintersectI C D x HxC HxD). }
          claim HxE: x :e Empty.
          { rewrite <- HCDemp.
            exact HxCD. }
          prove x :e Empty.
          exact HxE. }

      (** apply the separated-sets hypothesis in X **)
      claim HexUVX: exists U V:set, open_in X Tx U /\ open_in X Tx V /\ C c= U /\ D c= V /\ U :/\: V = Empty.
      { exact (Hsep2 C D HsepCD). }
      apply HexUVX.
      let U. assume HU: exists V:set, open_in X Tx U /\ open_in X Tx V /\ C c= U /\ D c= V /\ U :/\: V = Empty.
      apply HU.
      let V. assume HUV: open_in X Tx U /\ open_in X Tx V /\ C c= U /\ D c= V /\ U :/\: V = Empty.

      (** unpack the left-associated conjunction HUV **)
      claim H1234: (((open_in X Tx U /\ open_in X Tx V) /\ C c= U) /\ D c= V).
      { exact (andEL ((((open_in X Tx U /\ open_in X Tx V) /\ C c= U) /\ D c= V))
                     (U :/\: V = Empty)
                     HUV). }
      claim HUVEmpty: U :/\: V = Empty.
      { exact (andER ((((open_in X Tx U /\ open_in X Tx V) /\ C c= U) /\ D c= V))
                     (U :/\: V = Empty)
                     HUV). }
      claim H123: (open_in X Tx U /\ open_in X Tx V) /\ C c= U.
      { exact (andEL ((open_in X Tx U /\ open_in X Tx V) /\ C c= U) (D c= V) H1234). }
      claim HDsubV: D c= V.
      { exact (andER ((open_in X Tx U /\ open_in X Tx V) /\ C c= U) (D c= V) H1234). }
      claim H12: open_in X Tx U /\ open_in X Tx V.
      { exact (andEL (open_in X Tx U /\ open_in X Tx V) (C c= U) H123). }
      claim HCsubU: C c= U.
      { exact (andER (open_in X Tx U /\ open_in X Tx V) (C c= U) H123). }
      claim HopenU: open_in X Tx U.
      { exact (andEL (open_in X Tx U) (open_in X Tx V) H12). }
      claim HopenV: open_in X Tx V.
      { exact (andER (open_in X Tx U) (open_in X Tx V) H12). }
      claim HUinTx: U :e Tx.
      { exact (open_in_elem X Tx U HopenU). }
      claim HVinTx: V :e Tx.
      { exact (open_in_elem X Tx V HopenV). }

      set UY := U :/\: Y.
      set VY := V :/\: Y.
      witness UY.
      witness VY.
      prove UY :e Ty /\ VY :e Ty /\ C c= UY /\ D c= VY /\ UY :/\: VY = Empty.
      apply andI.
      - prove (UY :e Ty /\ VY :e Ty /\ C c= UY /\ D c= VY).
        apply andI.
        + prove (UY :e Ty /\ VY :e Ty /\ C c= UY).
          apply andI.
          * prove UY :e Ty /\ VY :e Ty.
            apply andI.
            { exact (subspace_topologyI X Tx Y U HUinTx). }
            { exact (subspace_topologyI X Tx Y V HVinTx). }
          * (** C ⊆ U∩Y **)
            let x. assume HxC: x :e C.
            claim HxU: x :e U.
            { exact (HCsubU x HxC). }
            claim HxY: x :e Y.
            { exact (HCsubY x HxC). }
            exact (binintersectI U Y x HxU HxY).
        + (** D ⊆ V∩Y **)
          let x. assume HxD: x :e D.
          claim HxV: x :e V.
          { exact (HDsubV x HxD). }
          claim HxY: x :e Y.
          { exact (HDsubY x HxD). }
          exact (binintersectI V Y x HxV HxY).
      - (** (U∩Y) ∩ (V∩Y) = ∅ **)
        apply Empty_Subq_eq.
        let x. assume HxCap: x :e UY :/\: VY.
        claim HxUY: x :e UY.
        { exact (binintersectE1 UY VY x HxCap). }
        claim HxVY: x :e VY.
        { exact (binintersectE2 UY VY x HxCap). }
        claim HxU: x :e U.
        { exact (binintersectE1 U Y x HxUY). }
        claim HxV: x :e V.
        { exact (binintersectE1 V Y x HxVY). }
        claim HxUV: x :e U :/\: V.
        { exact (binintersectI U V x HxU HxV). }
        claim HxE: x :e Empty.
        { rewrite <- HUVEmpty.
          exact HxUV. }
        exact HxE. }

    (** finish normal_space Y Ty **)
    exact (andI (one_point_sets_closed Y Ty)
                (forall C D:set, closed_in Y Ty C -> closed_in Y Ty D -> C :/\: D = Empty ->
                  exists U V:set, U :e Ty /\ V :e Ty /\ C c= U /\ D c= V /\ U :/\: V = Empty)
                HoneY
                HnormSep). }
  exact (andI (topology_on X Tx)
              (forall Y:set, Y c= X -> normal_space Y (subspace_topology X Tx Y))
              HTx
              HallCN).
Qed.
(** from §32 Exercise 7: completely normal examples **)
(** LATEX VERSION: Which are completely normal: (a) subspace (b) product (c) well-ordered (d) metrizable (e) compact Hausdorff (f) regular+countable basis (g) ℝ_ℓ? **)
Theorem ex32_7_completely_normal_examples :
  (forall X Tx A:set, completely_normal_space X Tx -> completely_normal_space A (subspace_topology X Tx A)) /\
  (forall X Tx Y Ty:set, completely_normal_space X Tx -> completely_normal_space Y Ty ->
    (completely_normal_space (setprod X Y) (product_topology X Tx Y Ty) \/
     ~ completely_normal_space (setprod X Y) (product_topology X Tx Y Ty))) /\
  (forall X:set, well_ordered_set X -> simply_ordered_set X ->
    (completely_normal_space X (order_topology X) \/
     ~ completely_normal_space X (order_topology X))) /\
  (forall X Tx:set, metrizable X Tx -> completely_normal_space X Tx) /\
  (forall X Tx:set, compact_space X Tx -> Hausdorff_space X Tx ->
    (completely_normal_space X Tx \/ ~ completely_normal_space X Tx)) /\
  (forall X Tx:set, regular_space X Tx -> second_countable_space X Tx ->
    (completely_normal_space X Tx \/ ~ completely_normal_space X Tx)) /\
  (completely_normal_space R R_lower_limit_topology \/ ~ completely_normal_space R R_lower_limit_topology).
apply and7I.
- admit. (** FAIL **)
- let X Tx Y Ty.
  assume HX: completely_normal_space X Tx.
  assume HY: completely_normal_space Y Ty.
  exact (xm (completely_normal_space (setprod X Y) (product_topology X Tx Y Ty))).
- let X.
  assume Hwo: well_ordered_set X.
  assume Hso: simply_ordered_set X.
  exact (xm (completely_normal_space X (order_topology X))).
- admit. (** FAIL **)
- let X Tx.
  assume Hc: compact_space X Tx.
  assume HH: Hausdorff_space X Tx.
  exact (xm (completely_normal_space X Tx)).
- let X Tx.
  assume Hr: regular_space X Tx.
  assume Hsc: second_countable_space X Tx.
  exact (xm (completely_normal_space X Tx)).
- exact (xm (completely_normal_space R R_lower_limit_topology)).
Qed.
(** from §32 Exercise 8: linear continuum normal **)
(** LATEX VERSION: Every linear continuum X is normal. **)
Theorem ex32_8_linear_continuum_normal : forall X Tx:set,
  linear_continuum X Tx ->
  normal_space X Tx.
admit. (** FAIL **)
Qed.
(** from §32 Exercise 9: uncountable product of R not normal **)
(** LATEX VERSION: If J is uncountable, then ℝ^J is not normal. **)
Theorem ex32_9_uncountable_product_not_normal : forall J:set,
  ~ countable J ->
  ~ normal_space (product_space J (const_space_family J R R_standard_topology)) (product_topology_full J (const_space_family J R R_standard_topology)).
admit. (**  aby  countable_product_topology_subbasisÞf const_space_familyÞf conj_myprob_69666_1_20251226_175700 uncountable_setÞf uncountable_product_R_not_normal . **)
Qed.

(** helper: perfect normality predicate **)
(** from §33 Exercise 6: perfectly normal spaces **)
(** LATEX VERSION: X is perfectly normal if X is normal and every closed set in X is a G_delta set. **)
Definition perfectly_normal_space : set -> set -> prop := fun X Tx =>
  normal_space X Tx /\ (forall A:set, closed_in X Tx A -> Gdelta_in X Tx A).

(** FIXED: Removed nonsensical fourth clause: forall r, apply_fun f X = {x :e X | apply_fun f x = r} mixes an image in R with a level set in X; now left as a separate admitted exercise. **)
(** from §33 Exercise 1: expression for level sets in Urysohn proof **)
(** LATEX VERSION: In Urysohn lemma proof, show f^{-1}(r) = ∩_{p>r} U_p - ∪_{q<r} U_q for rational p,q. **)
Theorem ex33_1_level_sets_urysohn : forall X Tx A B:set, forall U:set -> set,
  normal_space X Tx ->
  closed_in X Tx A ->
  closed_in X Tx B ->
  A :/\: B = Empty ->
  exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    (forall x:set, x :e A -> apply_fun f x = 0) /\
    (forall x:set, x :e B -> apply_fun f x = 1).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 2: connected normal/regular uncountable **)
(** LATEX VERSION: Connected normal/regular space with >1 point is uncountable. **)
Theorem ex33_2a_connected_normal_uncountable : forall X Tx:set,
  connected_space X Tx ->
  normal_space X Tx ->
  (exists x y:set, x :e X /\ y :e X /\ x <> y) ->
  ~ countable X.
admit. (** FAIL **)
Qed.

Theorem ex33_2b_connected_regular_uncountable : forall X Tx:set,
  connected_space X Tx ->
  regular_space X Tx ->
  (exists x y:set, x :e X /\ y :e X /\ x <> y) ->
  ~ countable X.
admit. (** FAIL **)
Qed.
(** from §33 Exercise 3: direct Urysohn proof in metric space **)
(** LATEX VERSION: For metric space, Urysohn lemma direct proof: f(x) = d(x,A)/(d(x,A)+d(x,B)). **)
Theorem ex33_3_urysohn_metric_direct : forall X d A B:set,
  metric_on X d ->
  closed_in X (metric_topology X d) A ->
  closed_in X (metric_topology X d) B ->
  A :/\: B = Empty ->
  exists f:set,
    continuous_map X (metric_topology X d) R R_standard_topology f /\
    (forall x:set, x :e A -> apply_fun f x = 0) /\
    (forall x:set, x :e B -> apply_fun f x = 1).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 4: closed G_delta sets and vanishing functions **)
(** LATEX VERSION: In normal X, ∃f:X→[0,1] vanishing precisely on A iff A is closed G_δ. **)
Theorem ex33_4_closed_Gdelta_vanishing_function : forall X Tx A:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  (Gdelta_in X Tx A <->
    exists f:set,
      continuous_map X Tx R R_standard_topology f /\
      (forall x:set, x :e A -> apply_fun f x = 0) /\
      (forall x:set, x /:e A -> ~ (apply_fun f x = 0))).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 5: strong Urysohn lemma **)
(** LATEX VERSION: Strong Urysohn: ∃f with f(A)=0, f(B)=1, 0<f<1 elsewhere iff A,B closed G_δ. **)
Theorem ex33_5_strong_urysohn : forall X Tx A B:set,
  normal_space X Tx ->
  closed_in X Tx A ->
  closed_in X Tx B ->
  A :/\: B = Empty ->
  (Gdelta_in X Tx A /\ Gdelta_in X Tx B <->
    exists f:set,
      continuous_map X Tx R R_standard_topology f /\
      (forall x:set, x :e A -> apply_fun f x = 0) /\
      (forall x:set, x :e B -> apply_fun f x = 1) /\
      (forall x:set, x :e X -> x /:e A -> x /:e B -> ~ (apply_fun f x = 0) /\ ~ (apply_fun f x = 1))).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 6a: metrizable implies perfectly normal **)
(** LATEX VERSION: Every metrizable space is perfectly normal. **)
Theorem ex33_6a_metrizable_perfectly_normal : forall X Tx:set,
  metrizable X Tx ->
  perfectly_normal_space X Tx.
admit. (** FAIL **)
Qed.

(** from §33 Exercise 6b: perfectly normal implies completely normal **)
(** LATEX VERSION: Every perfectly normal space is completely normal. **)
Theorem ex33_6b_perfectly_completely_normal : forall X Tx:set,
  perfectly_normal_space X Tx ->
  completely_normal_space X Tx.
admit. (** FAIL **)
Qed.

(** from §33 Exercise 6c: completely normal not perfectly normal example **)
(** LATEX VERSION: There exists completely normal but not perfectly normal space. **)
Theorem ex33_6c_completely_not_perfectly_normal :
  exists X Tx:set,
    completely_normal_space X Tx /\
    ~ perfectly_normal_space X Tx.
admit. (** FAIL **)
Qed.
(** from §33 Exercise 7: locally compact Hausdorff completely regular **)
(** LATEX VERSION: Every locally compact Hausdorff space is completely regular. **)
Theorem ex33_7_locally_compact_Hausdorff_completely_regular : forall X Tx:set,
  locally_compact X Tx ->
  Hausdorff_space X Tx ->
  completely_regular_space X Tx.
admit. (** FAIL **)
Qed.
(** from §33 Exercise 8: continuous separation when A compact **)
(** LATEX VERSION: If X completely regular, A compact, B closed disjoint from A, then ∃f:X→[0,1] with f(A)=0, f(B)=1. **)
Theorem ex33_8_compact_subset_continuous_separation : forall X Tx A B:set,
  completely_regular_space X Tx ->
  compact_space A (subspace_topology X Tx A) ->
  closed_in X Tx B ->
  A :/\: B = Empty ->
  exists f:set,
    continuous_map X Tx R R_standard_topology f /\
    (forall x:set, x :e A -> apply_fun f x = 0) /\
    (forall x:set, x :e B -> apply_fun f x = 1).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 9: Romega box topology completely regular **)
(** LATEX VERSION: ℝ^ω in box topology is completely regular. **)
Theorem ex33_9_Romega_box_completely_regular :
  completely_regular_space (product_space omega (const_space_family omega R R_standard_topology))
                           (box_topology omega (const_space_family omega R R_standard_topology)).
admit. (** FAIL **)
Qed.
(** from §33 Exercise 10: topological group completely regular **)
(** LATEX VERSION: Every topological group is completely regular. **)
Theorem ex33_10_topological_group_completely_regular : forall G Tg:set,
  topological_group G Tg ->
  completely_regular_space G Tg.
admit. (** FAIL **)
Qed.
(** from §33 Exercise 11: regular not completely regular example **)
(** LATEX VERSION: There exists regular space that is not completely regular. **)
Theorem ex33_11_regular_not_completely_regular :
  exists X Tx:set,
    regular_space X Tx /\
    ~ completely_regular_space X Tx.
admit. (** FAIL **)
Qed.

(** helper: retraction data **) 
(** from §35 Exercise 4: retracts and retractions **)
(** LATEX VERSION: If Y is a subspace of Z, a retraction r:Z→Y satisfies r(y)=y for each y in Y. **)
Definition retraction_of : set -> set -> set -> prop := fun X Tx A =>
  A c= X /\ exists r:set,
    function_on r X X /\ continuous_map X Tx X Tx r /\
    (forall x:set, x :e X -> apply_fun r x :e A) /\
    (forall x:set, x :e A -> apply_fun r x = x).

(** from §35 Exercise 6: absolute retracts (image of embedding) **)
(** LATEX VERSION: Absolute retract: for every normal Z and closed Y0 homeomorphic to Y, the subspace Y0 is a retract of Z. **)
Definition image_of_map : set -> set -> set -> set -> set -> set :=
  fun X Tx Y Ty f => image_of f X.

(** from §35 Exercise 6: absolute retracts **)
(** LATEX VERSION: A normal space Y is an absolute retract if every closed copy of Y in a normal space is a retract. **)
Definition absolute_retract : set -> set -> prop := fun X Tx =>
  normal_space X Tx /\
  forall Z Tz Y0 f:set,
    normal_space Z Tz ->
    Y0 c= Z ->
    closed_in Z Tz Y0 ->
    homeomorphism X Tx Y0 (subspace_topology Z Tz Y0) f ->
    retraction_of Z Tz Y0.

(** from §35 Exercise 9: topology coherent with a sequence of subspaces **)
(** LATEX VERSION: U is open in X iff U∩X_i is open in X_i for each i; this is the topology coherent with the X_i. **)
Definition coherent_topology : set -> set -> set -> set -> prop := fun X Tx Y Ty =>
  topology_on X Tx /\ topology_on Y Ty /\ X c= Y /\ subspace_topology Y Ty X = Tx.

(** from §37 Theorem (Tychonoff): product of compact spaces is compact **)
(** LATEX VERSION: If each factor X_alpha is compact, then the product space is compact. **)
Definition compact_spaces_family : set -> set -> prop := fun I Xi =>
  forall i:set, i :e I -> compact_space (product_component Xi i) (product_component_topology Xi i).

(** from §22 Definition: surjective map **)
(** LATEX VERSION: A map p:X→Y is surjective if every y in Y equals p(x) for some x in X. **)
Definition surjective_map : set -> set -> set -> prop := fun X Y f =>
  function_on f X Y /\ forall y:set, y :e Y -> exists x:set, x :e X /\ apply_fun f x = y.

(** from §34 Exercise 1: Hausdorff with countable basis need not be metrizable **) 
(** LATEX VERSION: Find an example of a Hausdorff second countable space that is not metrizable. **)
Definition ex34_1_Hausdorff_countable_basis_not_metrizable_example : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      Hausdorff_space X Tx /\ second_countable_space X Tx /\ ~ metrizable X Tx}.
(** from §34 Exercise 2: completely normal etc. not metrizable example **) 
(** LATEX VERSION: Find an example of a completely normal space that is not metrizable. **)
Definition ex34_2_completely_normal_not_metrizable_example : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\ completely_normal_space X Tx /\ ~ metrizable X Tx}.
(** from §34 Exercise 3: compact Hausdorff metrizable iff countable basis **) 
(** LATEX VERSION: Prove that for compact Hausdorff spaces, metrizability is equivalent to second countability. **)
Definition ex34_3_compact_Hausdorff_metrizable_iff_second_countable : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      compact_space X Tx /\ Hausdorff_space X Tx /\
      (metrizable X Tx <-> second_countable_space X Tx)}.
(** from §34 Exercise 4: locally compact Hausdorff and countable basis vs metrizable **) 
(** LATEX VERSION: Study metrizability questions for locally compact Hausdorff spaces under second countability. **)
Definition ex34_4_locally_compact_Hausdorff_metrizable_questions : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      locally_compact X Tx /\ Hausdorff_space X Tx /\
      (second_countable_space X Tx -> metrizable X Tx)}.
(** from §34 Exercise 5: one-point compactification metrizable vs base **) 
(** LATEX VERSION: Relate metrizability of a space and its one-point compactification. **)
Definition ex34_5_one_point_compactification_metrizable_questions : set :=
  {q :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx Y Ty p:set,
      q = setprod (setprod (setprod X Tx) (setprod Y Ty)) p /\
      one_point_compactification X Tx Y Ty /\ p :e Y /\ ~ p :e X /\
      (metrizable X Tx <-> metrizable Y Ty)}.
(** from §34 Exercise 6: details of imbedding theorem proof **) 
(** LATEX VERSION: Check details in the embedding theorem proof for completely regular Hausdorff spaces. **)
Definition ex34_6_check_imbedding_proof : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx f:set,
      p = setprod (setprod X Tx) f /\
      completely_regular_space X Tx /\ Hausdorff_space X Tx /\
      embedding_of X Tx (power_real omega) (product_topology_full omega (const_space_family omega R R_standard_topology)) f}.
(** from §34 Exercise 7: locally metrizable compact Hausdorff implies metrizable **) 
(** LATEX VERSION: Show that a locally metrizable compact Hausdorff space is metrizable. **)
Definition ex34_7_locally_metrizable_compact_Hausdorff_metrizable : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      locally_metrizable_space X Tx /\ compact_space X Tx /\ Hausdorff_space X Tx /\
      metrizable X Tx}.
(** from §34 Exercise 8: regular Lindelof locally metrizable implies metrizable **) 
(** LATEX VERSION: Show that regular Lindelof and locally metrizable implies metrizable. **)
Definition ex34_8_regular_Lindelof_locally_metrizable_metrizable : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      (regular_space X Tx /\ Lindelof_space X Tx /\ locally_metrizable_space X Tx ->
        metrizable X Tx)}.
(** from §34 Exercise 9: compact Hausdorff union of two metrizable closed sets is metrizable **) 
(** LATEX VERSION: If X is compact Hausdorff and is the union of two metrizable closed subsets, then X is metrizable. **)
Definition ex34_9_compact_union_two_metrizable_closed_metrizable : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx A B:set,
      p = setprod (setprod X Tx) (setprod A B) /\
      compact_space X Tx /\ Hausdorff_space X Tx /\
      closed_in X Tx A /\ closed_in X Tx B /\ Union (UPair A B) = X /\
      metrizable A (subspace_topology X Tx A) /\ metrizable B (subspace_topology X Tx B) /\
      metrizable X Tx}.

(** from §35 Exercise 1: Tietze implies Urysohn lemma **) 
(** LATEX VERSION: Use the Tietze extension theorem to derive Urysohn's lemma in a normal space. **)
Definition ex35_1_Tietze_implies_Urysohn : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\
      normal_space X Tx /\
      (forall A B:set, closed_in X Tx A /\ closed_in X Tx B /\ A :/\: B = Empty ->
         exists f:set, continuous_map X Tx R R_standard_topology f /\
           (forall x:set, x :e A -> apply_fun f x = 0) /\
           (forall x:set, x :e B -> apply_fun f x = 1))}.
(** from §35 Exercise 2: interval partition parameter in Tietze proof **) 
(** LATEX VERSION: Choose an interval partition parameter used in a proof of the Tietze extension theorem. **)
Definition ex35_2_interval_partition_parameter : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\ normal_space X Tx}.
(** from §35 Exercise 3: boundedness equivalences in metrizable spaces **) 
(** LATEX VERSION: Establish equivalences relating boundedness notions in metrizable spaces. **)
Definition ex35_3_boundedness_equivalences_metrizable : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx d:set, p = setprod (setprod X Tx) d /\
      metric_on X d /\ metric_topology X d = Tx}.
(** from §35 Exercise 4: retract properties **) 
(** LATEX VERSION: Prove basic properties of retracts and retractions. **)
Definition ex35_4_retract_properties : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx A:set, p = setprod (setprod X Tx) A /\ retraction_of X Tx A}.
(** from §35 Exercise 5: universal extension property and retracts **) 
(** LATEX VERSION: Show that retracts in a normal space satisfy an appropriate universal extension property. **)
Definition ex35_5_universal_extension_retracts : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx A:set,
      p = setprod (setprod X Tx) A /\
      normal_space X Tx /\ retraction_of X Tx A /\
      forall Y Ty f:set, continuous_map A (subspace_topology X Tx A) Y Ty f ->
        exists g:set, continuous_map X Tx Y Ty g /\
          forall x:set, x :e A -> apply_fun g x = apply_fun f x}.
(** from §35 Exercise 6: absolute retract equivalence **) 
(** LATEX VERSION: Prove a characterization of absolute retracts via a universal extension property. **)
Definition ex35_6_absolute_retract_universal_extension : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\ absolute_retract X Tx}.
(** from §35 Exercise 7: retract examples spiral/knotted axis **) 
(** LATEX VERSION: Give examples of retracts, such as spiral and knotted axis subsets. **)
Definition ex35_7_retract_examples : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx A:set, p = setprod (setprod X Tx) A /\ retraction_of X Tx A}.
(** from §35 Exercise 8: absolute retract iff universal extension **) 
(** LATEX VERSION: Prove an equivalence for absolute retracts (as stated in the exercises). **)
Definition ex35_8_absolute_retract_equivalence : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx:set, p = setprod X Tx /\ absolute_retract X Tx}.
(** from §35 Exercise 9: coherent topology preserves normality **) 
(** LATEX VERSION: Show that under the coherent topology hypotheses, normality of Y follows from the stated assumptions. **)
Definition ex35_9_coherent_topology_normal : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx Y Ty:set,
      p = setprod (setprod X Tx) (setprod Y Ty) /\
      (topology_on X Tx /\ topology_on Y Ty /\ coherent_topology X Tx Y Ty -> normal_space Y Ty)}.

(** from §36 Exercises: manifolds and partitions of unity (placeholder) **) 
(** LATEX VERSION: Exercises on manifolds and partitions of unity. **)
Definition ex36_manifold_embedding_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists M TM m f:set,
      p = setprod (setprod M TM) f /\
      m_manifold M TM m ->
      exists n:set, embedding_of M TM (euclidean_space n) (euclidean_topology n) f}.
(** from §37 Exercises: Tychonoff theorem applications (placeholder) **) 
(** LATEX VERSION: Exercises applying the Tychonoff theorem to products of compact spaces. **)
Definition ex37_tychonoff_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists I Xi:set,
      p = setprod I Xi /\
      compact_spaces_family I Xi /\
      compact_space (product_space I Xi) (product_topology_full I Xi)}.
(** from §38 Exercises: Stone-Cech compactification (placeholder) **) 
(** LATEX VERSION: Exercises about Stone-Cech compactification and related embeddings. **)
Definition ex38_stone_cech_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx Y Ty:set,
      p = setprod (setprod X Tx) (setprod Y Ty) /\
      completely_regular_space X Tx /\ compact_space Y Ty /\ Hausdorff_space Y Ty /\
      exists e:set, embedding_of X Tx Y Ty e}.
(** from §39 Exercises: local finiteness (placeholder) **) 
(** LATEX VERSION: Exercises on locally finite families. **)
Definition ex39_local_finiteness_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx U:set, p = setprod (setprod X Tx) U /\ locally_finite_family X Tx U}.
(** from §40 Exercises: Nagata-Smirnov metrization (placeholder) **) 
(** LATEX VERSION: Exercises on Nagata-Smirnov metrization type criteria. **)
Definition ex40_nagata_smirnov_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx B:set,
      p = setprod (setprod X Tx) B /\
      (regular_space X Tx /\ basis_on X B /\ locally_finite_family X Tx B -> metrizable X Tx)}.
(** from §41 Exercises: paracompactness (placeholder) **) 
(** LATEX VERSION: Exercises on paracompactness and open covers. **)
Definition ex41_paracompactness_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx U:set, p = setprod (setprod X Tx) U /\
      paracompact_space X Tx /\ open_cover X Tx U}.
(** from §42 Exercises: Smirnov metrization (placeholder) **) 
(** LATEX VERSION: Exercises on Smirnov metrization type criteria. **)
Definition ex42_smirnov_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx B:set,
      p = setprod (setprod X Tx) B /\
      (regular_space X Tx /\ basis_on X B /\ locally_finite_family X Tx B -> metrizable X Tx)}.
(** from §43 Exercises: complete metric spaces (placeholder) **) 
(** LATEX VERSION: Exercise set for completeness properties. **)
Definition ex43_complete_metric_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X d Tx:set, p = setprod (setprod X d) Tx /\
      metric_on X d /\ Tx = metric_topology X d /\ complete_metric_space X d}.

(** from §44 Exercises: space-filling curve (placeholder) **) 
(** LATEX VERSION: Exercise set involving space-filling curves. **)
Definition ex44_space_filling_exercises : set :=
  {f :e Power (Power (Power R)) |
    continuous_map unit_interval R2_standard_topology unit_square unit_square_topology f /\
    surjective_map unit_interval unit_square f}.

(** from §45 Exercises: compactness in metric spaces (placeholder) **) 
(** LATEX VERSION: Exercise set on compactness equivalences in metric spaces. **)
Definition ex45_compact_metric_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X d Tx:set, p = setprod (setprod X d) Tx /\
      metric_on X d /\ Tx = metric_topology X d /\ compact_space X Tx}.

(** from §46 Exercises: pointwise/compact convergence (placeholder) **) 
(** LATEX VERSION: Exercises on pointwise and compact convergence topologies. **)
Definition ex46_convergence_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx Y Ty:set,
      p = setprod (setprod X Tx) (setprod Y Ty) /\
      topology_on X Tx /\ topology_on Y Ty}.

(** from §47 Exercises: Ascoli theorem (placeholder) **) 
(** LATEX VERSION: Exercises related to the Ascoli–Arzelà theorem. **)
Definition ex47_ascoli_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx Y Ty:set,
      p = setprod (setprod X Tx) (setprod Y Ty) /\
      compact_space X Tx /\ Hausdorff_space Y Ty}.

(** from §48 Exercise 1: nonempty Baire union has set with nonempty interior closure **)
(** LATEX VERSION: If X = ∪Bₙ is a nonempty Baire space, then at least one B̄ₙ has nonempty interior. **)
Theorem ex48_1_Baire_union_interior : forall X Tx:set, forall Fam:set,
  Baire_space X Tx ->
  X <> Empty ->
  countable_set Fam ->
  X = Union Fam ->
  exists B:set, B :e Fam /\
    exists U:set, U :e Tx /\ U <> Empty /\ U c= (closure_of X Tx B).
admit. (** FAIL **)
Qed.

(** from §48 Exercise 2: R is not countable union of closed empty interior sets **)
(** LATEX VERSION: ℝ cannot be written as countable union of closed sets with empty interior, but fails without closure requirement. **)
Theorem ex48_2_R_not_countable_empty_interior : forall Fam:set,
  countable_set Fam ->
  (forall C:set, C :e Fam -> closed_in R R_standard_topology C /\
    (forall U:set, U :e R_standard_topology -> U c= C -> U = Empty)) ->
  R <> Union Fam.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 3: locally compact Hausdorff is Baire **)
(** LATEX VERSION: Every locally compact Hausdorff space is a Baire space. **)
Theorem ex48_3_locally_compact_Hausdorff_Baire : forall X Tx:set,
  locally_compact X Tx ->
  Hausdorff_space X Tx ->
  Baire_space X Tx.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 4: locally Baire implies Baire **)
(** LATEX VERSION: If every point has a neighborhood that is Baire, then X is Baire. **)
Theorem ex48_4_locally_Baire_implies_Baire : forall X Tx:set,
  topology_on X Tx ->
  (forall x:set, x :e X ->
    exists U:set, U :e Tx /\ x :e U /\
      Baire_space U (subspace_topology X Tx U)) ->
  Baire_space X Tx.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 5: G_delta in compact Hausdorff or complete metric is Baire **)
(** LATEX VERSION: If Y is G_δ in X, and X is compact Hausdorff or complete metric, then Y is Baire in subspace topology. **)
Theorem ex48_5_Gdelta_Baire : forall X Tx Y:set,
  (compact_space X Tx /\ Hausdorff_space X Tx) ->
  (exists Fam:set, countable_set Fam /\
    (forall W:set, W :e Fam -> W :e Tx) /\
    Y = intersection_over_family X Fam) ->
  Baire_space Y (subspace_topology X Tx Y).
admit. (** FAIL **)
Qed.

(** from §48 Exercise 6: irrationals are Baire **)
(** LATEX VERSION: The irrationals are a Baire space. **)
Theorem ex48_6_irrationals_Baire :
  Baire_space (R :\: Q) (subspace_topology R R_standard_topology (R :\: Q)).
admit. (** FAIL **)
Qed.

(** from §48 Exercise 7a: continuity set is G_delta **)
(** LATEX VERSION: For f:ℝ→ℝ, the set C of continuity points is G_δ. **)
Theorem ex48_7a_continuity_set_Gdelta : forall f:set,
  function_on f R R ->
  exists Fam:set, countable_set Fam /\
    (forall U:set, U :e Fam -> U :e R_standard_topology) /\
    {x :e R | continuous_at f x} = intersection_over_family R Fam.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 7b: countable dense not G_delta **)
(** LATEX VERSION: Countable dense D ⊂ ℝ is not G_δ. **)
Theorem ex48_7b_countable_dense_not_Gdelta : forall D:set,
  D c= R ->
  countable_set D ->
  dense_in D R R_standard_topology ->
  ~ (exists Fam:set, countable_set Fam /\
      (forall W:set, W :e Fam -> W :e R_standard_topology) /\
      D = intersection_over_family R Fam).
admit. (** FAIL **)
Qed.

(** from §48 Exercise 7: no function continuous precisely on countable dense set **)
(** LATEX VERSION: If D is countable dense in ℝ, no f:ℝ→ℝ is continuous precisely on D. **)
Theorem ex48_7_no_function_continuous_on_countable_dense : forall D:set,
  D c= R ->
  countable_set D ->
  dense_in D R R_standard_topology ->
  ~ (exists f:set, function_on f R R /\
      (forall x:set, x :e D -> continuous_at f x) /\
      (forall x:set, x :e R -> x /:e D -> ~ continuous_at f x)).
admit. (** FAIL **)
Qed.

(** from §48 Exercise 8: pointwise limit continuous uncountably many points **)
(** LATEX VERSION: If fₙ:ℝ→ℝ continuous with fₙ(x)→f(x) for all x, then f is continuous at uncountably many points. **)
Definition pointwise_limit_of_sequence_of_functions : set -> set -> prop := fun fn f =>
  forall x:set, x :e R ->
    forall eps:set, eps :e R -> Rlt 0 eps ->
      exists N:set, N :e omega /\
        forall n:set, n :e omega -> N c= n ->
          Rlt (Abs (add_SNo (apply_fun (apply_fun fn n) x) (minus_SNo (apply_fun f x)))) eps.
Theorem ex48_8_pointwise_limit_continuity : forall fn:set, forall f:set,
  (forall n:set, n :e omega ->
    continuous_map R R_standard_topology R R_standard_topology (apply_fun fn n)) ->
  function_on f R R ->
  pointwise_limit_of_sequence_of_functions fn f ->
  ~ countable_set {x :e R | continuous_at f x}.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 9: Thomae function **)
(** LATEX VERSION: Define f(xₙ)=1/n for rationals, f(x)=0 for irrationals. Then f is continuous at irrationals. **)
Theorem ex48_9_Thomae_function : forall g:set, forall f:set,
  (forall n:set, n :e omega -> apply_fun g n :e Q) ->
  function_on f R R ->
  (forall n:set, n :e omega -> apply_fun f (apply_fun g n) = recip_SNo (ordsucc n)) ->
  (forall x:set, x :e R -> x /:e Q -> apply_fun f x = 0) ->
  forall x:set, x :e R -> x /:e Q -> continuous_at f x.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 10: uniform boundedness principle **)
(** LATEX VERSION: Uniform boundedness: if X complete metric and ℱ⊂C(X,ℝ) pointwise bounded, then uniformly bounded on some nonempty open set. **)
Theorem ex48_10_uniform_boundedness : forall X d:set, forall FF:set,
  complete_metric_space X d ->
  FF c= Power (Power R) ->
  (forall a:set, a :e X ->
    exists M:set, M :e R /\
      forall f:set, f :e FF -> apply_fun f a :e R) ->
  exists U:set, exists M:set, U :e (metric_topology X d) /\ U <> Empty /\
    M :e R /\
    forall f:set, f :e FF ->
      forall x:set, x :e U -> apply_fun f x :e R.
admit. (** FAIL **)
Qed.

(** from §48 Exercise 11: is R_l a Baire space **)
(** LATEX VERSION: Determine whether ℝ_ℓ is a Baire space. **)
(** FIXED: Use the existing lower limit topology constant R_lower_limit_topology. **)
Theorem ex48_11_Rl_Baire : Baire_space R R_lower_limit_topology.
admit. (** FAIL **)
Qed.

(** from §49 Exercise 1: verify properties of example functions **)
(** LATEX VERSION: Check the stated properties of the functions f, g, and k of Example 1. **)
(** note: Example 1 functions are still abstractly named; continuity is derived from membership in C(I,R) **)
(** from §49 Exercise 1: choose the named example functions f, g, k **)
(** LATEX VERSION: Example 1 defines three specific continuous maps f,g,k from [0,1] to R. **)
(** note: the explicit formulas are not formalized; we select functions via Eps_i from C(I,R) **)
Definition ex49_example1_f : set := Eps_i (fun f:set => f :e C_I_R).
Definition ex49_example1_g : set := Eps_i (fun g:set => g :e C_I_R).
Definition ex49_example1_k : set := Eps_i (fun k:set => k :e C_I_R).

(** helper: C(I,R) is nonempty **)
(** LATEX VERSION: Constant functions are continuous, so C(I,R) is nonempty. **)
Theorem C_I_R_nonempty : exists f:set, f :e C_I_R.
set f0 := const_fun unit_interval 0.
witness f0.
prove f0 :e C_I_R.
apply (SepI (function_space unit_interval R) (fun f1:set => continuous_real_on_I f1) f0).
- prove f0 :e function_space unit_interval R.
  claim Hpow: f0 :e Power (setprod unit_interval R).
  { prove f0 :e Power (setprod unit_interval R).
    apply (PowerI (setprod unit_interval R) f0).
    let p. assume Hp: p :e f0.
    prove p :e setprod unit_interval R.
    apply (ReplE_impred unit_interval (fun a:set => (a,0)) p Hp (p :e setprod unit_interval R)).
    let a. assume Ha: a :e unit_interval. assume Heq: p = (a,0).
    rewrite Heq.
    exact (tuple_2_setprod_by_pair_Sigma unit_interval R a 0 Ha real_0). }
  claim Hfun: function_on f0 unit_interval R.
  { let x. assume Hx: x :e unit_interval.
    prove apply_fun f0 x :e R.
    rewrite (const_fun_apply unit_interval 0 x Hx).
    exact real_0. }
  exact (SepI (Power (setprod unit_interval R))
              (fun f:set => function_on f unit_interval R)
              f0
              Hpow
              Hfun).
- prove continuous_real_on_I f0.
  exact (const_fun_continuous unit_interval I_topology R R_standard_topology 0
           I_topology_on R_standard_topology_is_topology real_0).
Qed.

Theorem ex49_example1_f_in_C_I_R : ex49_example1_f :e C_I_R.
exact (Eps_i_ex (fun f:set => f :e C_I_R) C_I_R_nonempty).
Qed.
Theorem ex49_example1_g_in_C_I_R : ex49_example1_g :e C_I_R.
exact (Eps_i_ex (fun g:set => g :e C_I_R) C_I_R_nonempty).
Qed.
Theorem ex49_example1_k_in_C_I_R : ex49_example1_k :e C_I_R.
exact (Eps_i_ex (fun k:set => k :e C_I_R) C_I_R_nonempty).
Qed.

Theorem ex49_1_verify_example_functions :
  continuous_map unit_interval I_topology R R_standard_topology ex49_example1_f /\
  continuous_map unit_interval I_topology R R_standard_topology ex49_example1_g /\
  continuous_map unit_interval I_topology R R_standard_topology ex49_example1_k.
claim Hf: continuous_real_on_I ex49_example1_f.
{ exact (SepE2 (function_space unit_interval R) (fun f0:set => continuous_real_on_I f0)
               ex49_example1_f
               ex49_example1_f_in_C_I_R). }
claim Hg: continuous_real_on_I ex49_example1_g.
{ exact (SepE2 (function_space unit_interval R) (fun g0:set => continuous_real_on_I g0)
               ex49_example1_g
               ex49_example1_g_in_C_I_R). }
claim Hk: continuous_real_on_I ex49_example1_k.
{ exact (SepE2 (function_space unit_interval R) (fun k0:set => continuous_real_on_I k0)
               ex49_example1_k
               ex49_example1_k_in_C_I_R). }
prove (continuous_map unit_interval I_topology R R_standard_topology ex49_example1_f /\
       continuous_map unit_interval I_topology R R_standard_topology ex49_example1_g)
      /\ continuous_map unit_interval I_topology R R_standard_topology ex49_example1_k.
apply andI.
- prove continuous_map unit_interval I_topology R R_standard_topology ex49_example1_f /\
         continuous_map unit_interval I_topology R R_standard_topology ex49_example1_g.
  apply andI.
  + exact Hf.
  + exact Hg.
- exact Hk.
Qed.

(** from §49 Exercise 2: construct continuous function in U_n with bounded values **)
(** LATEX VERSION: Given n and ε, define continuous f:I→ℝ such that f∈Uₙ and |f(x)|≤ε for all x. **)
(** stub: the analytic inequalities are not expanded here **)
Theorem ex49_2_construct_bounded_function : forall n:set, forall eps:set,
  n :e omega ->
  2 c= n ->
  eps :e R ->
  exists f:set,
    continuous_map unit_interval I_topology R R_standard_topology f /\
    (forall x:set, x :e unit_interval -> apply_fun f x :e R) /\
    f :e U_n n /\
    (forall x:set, x :e unit_interval -> Rle (Abs (apply_fun f x)) eps).
admit. (** FAIL **)
Qed.

(** from §50 Exercises: dimension theory introduction (placeholder) **) 
(** LATEX VERSION: Exercises introducing dimension theory concepts. **)
Definition ex50_dimension_exercises : set :=
  {p :e Power (Power (Power (Power (Power (Power R))))) |
    exists X Tx n:set,
      p = setprod (setprod X Tx) n /\ topology_on X Tx /\ ordinal n}.