Section CPO_THEORY.
#[local] Existing Instance direct_product_of_two_Prosets.
#[local] Existing Instance subProset.
#[local] Existing Instance pi_isProset.
#[local] Existing Instance Scott_topology.
Definition U {D : Type} {PROSET : isProset D} (x : D) : ensemble D :=
fun z : D => ~ z =< x.
#[local] Hint Resolve ScottContinuousMap_isMonotonic : poset_hints.
Proof with eauto with *.
assert (MONOTONIC : isMonotonic1 f) by now eapply ScottContinuousMap_isMonotonic.
set (E.image f X) as Y in *. set (sup_Y := supremum_cpo Y DIRECTED').
pose proof (SUPREMUM' := supremum_cpo_spec Y DIRECTED').
assert (claim1 : sup_Y =< f sup_X).
{ eapply SUPREMUM'. intros y y_in_Y. unfold Y in *. s!.
des. subst y. eapply MONOTONIC, SUPREMUM...
}
assert (claim2 : f sup_X =< sup_Y).
{ eapply NNPP. intros f_sup_X_in_U_sup_Y.
assert (sup_X_in_preimage_f_U_sup_Y : sup_X \in E.preimage f (U sup_Y)) by now done!.
assert (f_U_sup_Y_isOpen : isOpen (E.preimage f (U sup_Y))) by now eapply CONTINUIOUS, U_x_isOpen.
inv f_U_sup_Y_isOpen. pose proof (LIMIT X sup_X DIRECTED SUPREMUM sup_X_in_preimage_f_U_sup_Y) as [x1 [x1_in_X x1_in_preimage_f_U_sup_Y]].
assert (f_x1_in_image_f_X : f x1 \in E.image f X).
{ econstructor... }
assert (f_x1_in_U_sup_Y : f x1 \in U sup_Y).
{ s!. des. done!. }
contradiction f_x1_in_U_sup_Y. eapply SUPREMUM'...
}
eapply @leProp_antisymmetry with (A_isProset := PROSET')...
Qed.
Definition preserves_supremum {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} (f : D -> D') : Prop :=
forall X, isDirected X -> exists sup_X, exists sup_Y, is_supremum_of sup_X X /\ is_supremum_of sup_Y (E.image f X) /\ f sup_X == sup_Y.
Proof with eauto with *.
intros x1 x2 x1_le_x2. pose (E.fromList [x1; x2]) as X. set (E.image f X) as Y.
assert (claim1 : is_supremum_of x2 X).
{ intros z. split.
- intros x2_le_z x x_in_X. unfold X in *. s!. destruct x_in_X as [x_eq_x1 | [x_eq_x2 | []]]; subst x; rewrite <- x2_le_z...
- intros z_isUpperBoundOf_X. eapply z_isUpperBoundOf_X. done!.
}
assert (X_isDirected : isDirected X).
{ split.
- exists x1. done!.
- intros z1 z2 ? ?. unfold X in *. s!. destruct x1_IN as [<- | [<- | []]], x2_IN as [<- | [<- | []]]; exists x2; done!.
}
pose proof (PRESERVES_SUPREMUM X X_isDirected) as [sup_X [sup_Y [sup_X_is_supremum_of_X [sup_Y_is_supremum_of_Y f_sup_X_eq_sup_Y]]]].
assert (it_is_sufficient_to_show : f sup_X == f x2).
{ eapply COMPAT_WITH_eqProp. eapply supremum_unique... }
unfold X, Y in *. transitivity (f sup_X).
- eapply sup_Y_is_supremum_of_Y; done!.
- eapply eqProp_implies_leProp; done!.
Qed.
Proof with eauto with *.
pose proof (isMonotonic_if_preserves_supremum f COMPAT_WITH_eqProp PRESERVES_SUPREMUM) as claim1.
ii; s!. inversion H. des. split.
- exists (f x0); done!.
- intros y1 y2 ? ?; des. s!. destruct x1_IN as [x1 [-> x1_in_X]], x2_IN as [x2 [-> x2_in_X]].
pose proof (DIRECTED' x1 x2 x1_in_X x2_in_X) as [x3 [x3_in_X [? ?]]]; unnw.
exists (f x3); done!.
Qed.
Proof with eauto with *.
split; [intros f_isContinuous | intros f_preservesSupremum].
- intros X X_isDirected. set (Y := E.image f X).
assert (Y_isDirected : isDirected Y).
{ eapply preservesDirectedness_if_isMonotonic... }
set (sup_X := supremum_cpo X X_isDirected).
pose proof (sup_X_is_supremum_of_X := supremum_cpo_spec X X_isDirected).
exists sup_X, (f sup_X). pose proof (proj2 (sup_Y_is_supremum_of_image_f_X_iff_f_sup_X_eq_sup_Y f X sup_X (f sup_X) f_isContinuous X_isDirected sup_X_is_supremum_of_X) (eqProp_refl (f sup_X))) as claim1...
- ii. s!. inversion H.
pose proof (isMonotonic_if_preserves_supremum f COMPAT_WITH_eqProp f_preservesSupremum) as f_isMonotonic.
split; ii.
+ s!. des. subst. done!.
+ pose proof (f_preservesSupremum X H0) as [sup [sup_Y [? [? ?]]]].
assert (sup_X_eq_sup : sup_X == sup).
{ eapply supremum_unique... }
assert (f_sup_X_in_Y : f sup_X \in Y).
{ s!. des. now subst. }
pose proof (preservesDirectedness_if_preservesSupremum f COMPAT_WITH_eqProp f_preservesSupremum X H0) as image_f_X_isDirected.
assert (sup_Y_eq_f_sup_X : sup_Y == f sup_X).
{ rewrite sup_X_eq_sup... }
assert (claim1 : exists y, y \in E.image f X /\ y \in Y).
{ eapply LIMIT... }
destruct claim1 as [y [y_in_image_f_X y_in_Y]].
inversion y_in_image_f_X; subst y.
exists x. done!.
Qed.
Definition supOfScottContinuousMaps {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} (F : ensemble `[D -> D']) (F_isDirected : isDirected F) : D -> D' :=
fun x => supremum_cpo (E.image (fun f_i => proj1_sig f_i x) F) (supOfScottContinuousMaps_isWellDefined F F_isDirected x).
Proof with eauto with *.
assert (claim1 : forall f_i, f_i \in F -> is_supremum_of (proj1_sig f_i sup_X) (E.image (fun x => proj1_sig f_i x) X)).
{ intros f_i f_i_in. eapply sup_Y_is_supremum_of_image_f_X_iff_f_sup_X_eq_sup_Y... exact (proj2_sig f_i). }
pose proof (claim2 := supOfScottContinuousMaps_isSupremum F F_isDirected sup_X).
eapply supremum_of_map_suprema_is_supremum_of_unions.
- intros Y ?; s!. destruct H as [f0 [? f0_in_F]]; subst Y...
- intros y. split.
+ intros f_sup_X_le_y sup_Y. unfold map_suprema. i. simpl in IN. red in IN. destruct IN as [Y [IN SUPREMUM]]. red in SUPREMUM. s!. destruct IN as [f_i [-> f_i_in]].
pose proof (f_i_sup_X_isSupremum := claim1 f_i f_i_in).
assert (sup_Y_eq : sup_Y == proj1_sig f_i sup_X).
{ eapply supremum_unique... }
assert (f_i_sup_X_in : proj1_sig f_i sup_X \in E.image (fun f => proj1_sig f sup_X) F).
{ done!. }
rewrite sup_Y_eq. rewrite <- f_sup_X_le_y. eapply claim2...
+ intros ?. eapply claim2. intros y' ?. s!. destruct IN as [f_i [-> f_i_in]].
eapply H. exists (E.image (fun x => proj1_sig f_i x) X); done!.
Qed.
Proof with eauto with *.
assert (unions_image_image_comm : E.unions (E.image (fun f_i => E.image (fun x_i => proj1_sig f_i x_i) X) F) == E.unions (E.image (fun x_i => E.image (fun f_i => proj1_sig f_i x_i) F) X)).
{ intros z. split; i; s!.
- destruct H as [Y [H_in H_IN]]. s!. destruct H_IN as [f [-> H_IN]]. s!. destruct H_in as [x [-> H_in]]. exists (E.image (fun f => proj1_sig f x) F); done!.
- destruct H as [Y [H_in H_IN]]. s!. destruct H_IN as [x [-> H_IN]]. s!. destruct H_in as [f [-> H_in]]. exists (E.image (fun x => proj1_sig f x) X); done!.
}
assert (lemma1 : forall sup_Y, is_supremum_of sup_Y (E.unions (E.image (fun f_i => E.image (fun x => proj1_sig f_i x) X) F)) <-> is_supremum_of sup_Y (E.unions (E.image (fun x => E.image (fun f_i => proj1_sig f_i x) F) X))).
{ i; now rewrite unions_image_image_comm. }
assert (lemma2 : forall sup_Y, is_supremum_of sup_Y (E.unions (E.image (fun x => E.image (fun f_i => proj1_sig f_i x) F) X)) <-> is_supremum_of sup_Y (map_suprema (E.image (fun x => E.image (fun f_i => proj1_sig f_i x) F) X))).
{ ii. symmetry. eapply supremum_of_map_suprema_is_supremum_of_unions.
intros Y ?. rewrite E.in_image_iff in H. destruct H as [x [-> x_in]].
exists (supOfScottContinuousMaps F F_isDirected x). eapply supOfScottContinuousMaps_isSupremum.
}
pose proof (lemma3 := supOfScottContinuousMaps_isMonotonic F F_isDirected).
assert (claim1 : forall f_i, f_i \in F -> is_supremum_of (proj1_sig f_i sup_X) (E.image (fun x => proj1_sig f_i x) X)).
{ intros f_i f_i_in. eapply sup_Y_is_supremum_of_image_f_X_iff_f_sup_X_eq_sup_Y... exact (proj2_sig f_i). }
assert (claim2 : is_supremum_of (supOfScottContinuousMaps F F_isDirected sup_X) (E.image (fun f_i => proj1_sig f_i sup_X) F)).
{ eapply supOfScottContinuousMaps_isSupremum. }
assert (claim3 : is_supremum_of (supOfScottContinuousMaps F F_isDirected sup_X) (E.unions (E.image (fun f_i => E.image (fun x => proj1_sig f_i x) X) F))).
{ eapply supOfScottContinuousMaps_F_sup_X_is_supremum_of_unions_i_image_f_i_X_F... }
rewrite lemma1, lemma2 in claim3.
intros y. split.
- intros ? y' ?. rewrite E.in_image_iff in IN. destruct IN as [x [-> x_in]].
eapply claim3... exists (E.image (fun f_i => proj1_sig f_i x) F). split.
+ econstructor...
+ red. eapply supOfScottContinuousMaps_isSupremum.
- ii. do 2 red in H. eapply claim3. intros upper_bound ?.
repeat red in IN. destruct IN as [Y [Y_in upper_bound_in]]. s!. destruct Y_in as [x [-> ?]].
red in upper_bound_in. transitivity (supOfScottContinuousMaps F F_isDirected x).
+ eapply eqProp_implies_leProp, supremum_unique.
{ exact upper_bound_in. }
{ eapply supOfScottContinuousMaps_isSupremum. }
{ reflexivity. }
+ eapply H; done!.
Qed.

Corollary supOfScottContinuousMaps_isContinuous {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} (F : ensemble `[D -> D'])
(F_isDirected : isDirected F)
: isContinuous (supOfScottContinuousMaps F F_isDirected).