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.
Proof with eauto with *.
eapply the_main_reason_for_introducing_ScottTopology.
- ii. eapply leProp_antisymmetry; eapply supOfScottContinuousMaps_isMonotonic...
- intros X X_isDirected.
pose proof (supremum_cpo_spec X X_isDirected) as sup_X_is_supremum_of_X.
exists (supremum_cpo X X_isDirected), (supOfScottContinuousMaps F F_isDirected (supremum_cpo X X_isDirected)).
pose proof (supOfScottContinuousMaps_preserves_supremum F X (supremum_cpo X X_isDirected) F_isDirected X_isDirected sup_X_is_supremum_of_X) as claim1...
Qed.
Definition supremum_of_ScottContinuousMaps {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'] :=
@exist (D -> D') isContinuous (supOfScottContinuousMaps F F_isDirected) (supOfScottContinuousMaps_isContinuous F F_isDirected).
Proof with eauto with *.
intros f. split.
- intros ? f_i ?. rewrite <- H. intros x. simpl.
eapply supOfScottContinuousMaps_isSupremum with (F := F) (F_isDirected := F_isDirected); done!.
- intros ?. intros x; simpl. unfold supOfScottContinuousMaps.
set (sup_F_x := supremum_cpo (E.image (fun f_i => proj1_sig f_i x) F) (supOfScottContinuousMaps_isWellDefined F F_isDirected x)).
pose proof (sup_F_x_isSupremum := supremum_cpo_spec (E.image (fun f_i => proj1_sig f_i x) F) (supOfScottContinuousMaps_isWellDefined F F_isDirected x)).
eapply sup_F_x_isSupremum. intros y ?. s!. destruct IN as [f_i [-> f_i_in]]. eapply H...
Qed.
Definition botOfScottContinuousMaps {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} : D -> D' :=
fun x => bottom_cpo.
Proof with eauto with *.
intros O O_isOpen. unfold botOfScottContinuousMaps. inversion O_isOpen. split.
- ii. s!. des. done!.
- ii. s!. des. subst y. inv H. des. exists x0. done!.
Qed.
Definition BotOfScottContinuousMaps {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} : `[D -> D'] :=
@exist (D -> D') isContinuous botOfScottContinuousMaps botOfScottContinuousMaps_isContinuous.
#[global]
Instance ScottContinuousMaps_isCpo {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} : isCpo `[D -> D'] :=
{ bottom_cpo := BotOfScottContinuousMaps
; supremum_cpo := supremum_of_ScottContinuousMaps
; bottom_cpo_spec := BottomOfScottContinuousMaps_isBottom
; supremum_cpo_spec := supremum_of_ScottContinuousMaps_is_supremum
}.
Proof with eauto with *.
inversion X_isDirected. destruct NONEMPTY as [x0 IN]. destruct x0 as [x1_0 x2_0]. split.
- exists (x1_0); done!.
- intros x1_1 x2_1 ? ?. s!. destruct x1_IN as [[x1 x1_2] [-> H_IN1]], x2_IN as [[x2 x2_2] [-> H_IN2]]; simpl in *.
pose proof (DIRECTED' _ _ H_IN1 H_IN2) as [[x3_1 x3_2] [? [[? ?] [? ?]]]]; simpl in *.
exists (x3_1); done!.
Qed.
Proof with eauto with *.
inversion X_isDirected. destruct NONEMPTY as [x0 IN]. destruct x0 as [x1_0 x2_0]. split; unnw.
- exists (x2_0); done!.
- intros x1_2 x2_2 ? ?. s!. destruct x1_IN as [[x1_1 x1] [-> H_IN1]], x2_IN as [[x2_1 x2] [-> H_IN2]]; simpl in *.
pose proof (DIRECTED' _ _ H_IN1 H_IN2) as [[x3_1 x3_2] [? [[? ?] [? ?]]]]; simpl in *.
exists (x3_2); done!.
Qed.
Proof with eauto with *.
intros [z1 z2]. split; intros ?; s!.
- destruct H as [SUPREMUM_LE_UPPER_BOUND1 SUPREMUM_LE_UPPER_BOUND2]; simpl in *. intros [x1 x2] ?; s!. split; simpl.
+ rewrite <- SUPREMUM_LE_UPPER_BOUND1. eapply supremum_cpo_spec... done!.
+ rewrite <- SUPREMUM_LE_UPPER_BOUND2. eapply supremum_cpo_spec... done!.
- inversion X_isDirected. s!. des. destruct x0 as [x1_0 x2_0]. split; simpl.
+ eapply supremum_cpo_spec. intros x1 ?. s!. destruct IN as [[x1_1 x2_1] [-> H_IN]]. exploit (H (x1_1, x2_1))... simpl; i. done!.
+ eapply supremum_cpo_spec. intros x1 ?. s!. destruct IN as [[x1_1 x2_1] [-> H_IN]]. exploit (H (x1_1, x2_1))... simpl; i. done!.
Qed.
#[global]
Instance direct_product_of_two_Cpos {D : Type} {D' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {CPO : isCpo D} {CPO' : isCpo D'} : isCpo (D * D') :=
{ bottom_cpo := (bottom_cpo, bottom_cpo)
; supremum_cpo (X : ensemble (D * D')) (X_isDirected : isDirected X) := (supremum_cpo (E.image fst X) (image_fst_preservesDirectedness X X_isDirected), supremum_cpo (E.image snd X) (image_snd_preservesDirectedness X X_isDirected))
; bottom_cpo_spec := bottom_of_pair_isBottom
; supremum_cpo_spec := supremum_of_pair_is_supremum
}.
Definition seperately_monotonic {D : Type} {D' : Type} {D'' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {PROSET'' : isProset D''} {CPO : isCpo D} {CPO' : isCpo D'} {CPO'' : isCpo D''} (f : D * D' -> D'') : Prop :=
(forall x2 : D', isMonotonic1 (fun x1 : D => f (x1, x2))) /\ (forall x1 : D, isMonotonic1 (fun x2 : D' => f (x1, x2))).
Proof with eauto with *.
revert x1 X2 X2_isDirected sup_X2 sup_X2_is_supremum_of_X2.
assert (f_isMonotonic : isMonotonic1 f).
{ eapply ScottContinuousMap_isMonotonic... }
assert (f_isMonotonic_at2 : forall x1, isMonotonic1 (fun x2 => f (x1, x2))).
{ eapply seperately_monotonic_iff_monotonic... }
assert (COMPAT_WITH_eqProp : eqPropCompatible1 f).
{ intros [x1 x2] [x1' x2'] [H_eq1 H_eq2]; simpl in *. eapply leProp_antisymmetry; eapply f_isMonotonic; split... }
intros x1.
assert (COMPAT_WITH_eqProp' : eqPropCompatible1 (fun x2 => f (x1, x2))).
{ ii. eapply COMPAT_WITH_eqProp. simpl. now rewrite x_EQ. }
intros X2 X2_isDirected.
set (X := E.image (fun x2 => (x1, x2)) X2).
set (Y := E.image (fun x2 => f (x1, x2)) X2).
assert (X_isDirected : isDirected X).
{ inversion X2_isDirected. des. rename x0 into x2_0. split.
- unfold X. exists (x1, x2_0); done!.
- intros ? ? x1_in_X x2_in_X. unfold X in *. s!.
destruct x1_in_X as [? [H_eq x2_1_in]]. inv H_eq.
destruct x2_in_X as [? [H_eq x2_2_in]]. inv H_eq.
pose proof (DIRECTED' x x0 x2_1_in x2_2_in) as [x2_3 [? [x2_1_le_x2_3 x2_2_le_x2_3]]].
exists (x1, x2_3). simpl. repeat split; done!.
}
intros sup_X2 sup_X2_is_supremum_of_X2.
set (sup_X := supremum_cpo X X_isDirected). pose proof (supremum_cpo_spec X X_isDirected) as sup_X_is_supremum_of_X. fold sup_X in sup_X_is_supremum_of_X.
assert (claim1 : (x1, sup_X2) == sup_X).
{ eapply supremum_unique with (X2 := X); [intros [x_1 x_2] | trivial | reflexivity]. split.
- intros [x1_le_x_1 sup_X2_le_x2] [x_1' x_2'] H_IN'. unfold X in *. s!. destruct H_IN' as [x [H_EQ H_IN']].
apply pair_equal_spec in H_EQ. destruct H_EQ; subst x_1' x_2'. split; simpl in *.
+ trivial.
+ eapply sup_X2_is_supremum_of_X2...
- intros ?. s!. split; simpl.
+ inversion X2_isDirected. des. enough (to_show : (x1, x0) =< (x_1, x_2)) by exact (proj1 to_show). unfold X in *. eapply H; econs...
+ eapply sup_X2_is_supremum_of_X2. intros x2 ?; des. eapply H with (x := (x1, x2))... unfold X. econs...
}
assert (claim2 : f (x1, sup_X2) == f sup_X).
{ eapply COMPAT_WITH_eqProp... }
assert (PRESERVES_SUPREMUM : 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').
{ eapply the_main_reason_for_introducing_ScottTopology with (f := f)... }
destruct PRESERVES_SUPREMUM as [sup_X' [sup_Y' [sup_X'_isSupremum [sup_Y'_isSupremum f_x1_sup_X'_eq_sup_Y']]]].
assert (claim3 : is_supremum_of (f sup_X) (E.image f X)).
{ eapply supremum_congruence with (sup_X1 := f sup_X') (X1 := E.image f X).
- rewrite f_x1_sup_X'_eq_sup_Y'...
- eapply COMPAT_WITH_eqProp. symmetry. eapply supremum_unique...
- reflexivity.
}
eapply supremum_congruence with (sup_X1 := f sup_X) (X1 := E.image f X); trivial.
- symmetry...
- intros y. split; intros H_IN; unfold X, Y in *; s!; des; subst y.
+ destruct x as [x_1 x_2]; done!.
+ exists (x1, x). done!.
Qed.
Proof with eauto with *.
revert x1.
assert (f_monotonic : isMonotonic1 f).
{ eapply ScottContinuousMap_isMonotonic... }
assert (f2_isMonotonic : forall x1, isMonotonic1 (fun x2 => f (x1, x2))).
{ ii. eapply ScottContinuousMap_isMonotonic; trivial. split... }
assert (f_preserves_eqProp : eqPropCompatible1 f).
{ intros [x1 x2] [x1' x2'] [? ?]; simpl in *. eapply leProp_antisymmetry; eapply f_monotonic; split... }
intros x1. eapply the_main_reason_for_introducing_ScottTopology.
- ii. eapply f_preserves_eqProp. split...
- intros X2 X2_isDirected. set (sup_X2 := supremum_cpo X2 X2_isDirected). exists (sup_X2), (f (x1, sup_X2)).
pose proof (supremum_cpo_spec X2 X2_isDirected) as claim1. split; trivial. split.
+ eapply f_x1_sup_X2_eq_sup_f_x1_X2...
+ reflexivity.
Qed.
Proof with eauto with *.
revert x2 X1 X1_isDirected sup_X1 sup_X1_is_supremum_of_X1.
assert (f_isMonotonic : isMonotonic1 f).
{ eapply ScottContinuousMap_isMonotonic... }
assert (f_isMonotonic_at2 : forall x2, isMonotonic1 (fun x1 => f (x1, x2))).
{ eapply seperately_monotonic_iff_monotonic... }
assert (f_preserves_eqProp : eqPropCompatible1 f).
{ intros [x1 x2] [x1' x2'] [H_eq1 H_eq2]; simpl in *. eapply leProp_antisymmetry; eapply f_isMonotonic; split... }
intros x2.
assert (f_preserves_eqProp_at2 : eqPropCompatible1 (fun x1 => f (x1, x2))).
{ ii. eapply leProp_antisymmetry; eapply f_isMonotonic_at2... }
intros X1 X1_isDirected.
set (X := E.image (fun x1 => (x1, x2)) X1).
set (Y := E.image (fun x1 => f (x1, x2)) X1).
assert (X_isDirected : isDirected X).
{ inversion X1_isDirected. des. rename x0 into x1_0. unfold X, Y in *. split.
- exists (x1_0, x2); done!.
- intros [x1_1 x2_1] [x1_2 x2_2] x1_in_X x2_in_X. s!.
destruct x1_in_X as [x1 [H_eq x1_1_in]]. inversion H_eq; subst x2_1 x1. clear H_eq.
destruct x2_in_X as [x1 [H_eq x1_2_in]]. inversion H_eq; subst x2_2 x1. clear H_eq.
pose proof (DIRECTED' x1_1 x1_2 x1_1_in x1_2_in) as [x1_3 [? [x1_1_le_x1_3 x1_2_le_x1_3]]]; s!.
exists (x1_3, x2). repeat split... unfold X, Y in *. done!.
}
intros sup_X1 sup_X1_is_supremum_of_X1.
set (sup_X := supremum_cpo X X_isDirected). pose proof (supremum_cpo_spec X X_isDirected) as sup_X_is_supremum_of_X. fold sup_X in sup_X_is_supremum_of_X.
assert (claim1 : (sup_X1, x2) == sup_X).
{ eapply supremum_unique with (X2 := X); [intros [x_1 x_2] | trivial | reflexivity]. split.
- intros [sup_X1_le_x1 x2_le_x_2] [x_1' x_2'] H_IN'. simpl in *. unfold X, Y in *. s!. destruct H_IN' as [x1 [H_EQ x1_in]].
apply pair_equal_spec in H_EQ. destruct H_EQ; subst x_1' x_2'. split; simpl in *; trivial. eapply sup_X1_is_supremum_of_X1...
- intros ?. split; simpl.
+ eapply sup_X1_is_supremum_of_X1. unfold X, Y in *. intros x1 ?. eapply H with (x := (x1, x2)); done!.
+ inversion X1_isDirected. des. enough (to_show : (x0, x2) =< (x_1, x_2)) by exact (proj2 to_show). eapply H. unfold X, Y in *. done!.
}
assert (claim2 : f (sup_X1, x2) == f sup_X).
{ eapply f_preserves_eqProp... }
assert (PRESERVES_SUPREMUM : 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').
{ eapply the_main_reason_for_introducing_ScottTopology with (f := f)... }
destruct PRESERVES_SUPREMUM as [sup_X' [sup_Y' [sup_X'_isSupremum [sup_Y'_isSupremum f_x1_sup_X'_eq_sup_Y']]]].
assert (claim3 : is_supremum_of (f sup_X) (E.image f X)).
{ eapply supremum_congruence with (sup_X1 := f sup_X') (X1 := E.image f X).
- rewrite f_x1_sup_X'_eq_sup_Y'...
- eapply f_preserves_eqProp. symmetry. eapply supremum_unique...
- reflexivity.
}
eapply supremum_congruence with (sup_X1 := f sup_X) (X1 := E.image f X); trivial.
- symmetry...
- intros y. split; intros H_IN; unfold X, Y in *; s!; des; subst y.
+ destruct x as [x_1 x_2]; done!.
+ exists (x, x2). done!.
Qed.

Corollary f1_cont_if_f_cont {D : Type} {D' : Type} {D'' : Type} {PROSET : isProset D} {PROSET' : isProset D'} {PROSET'' : isProset D''} {CPO : isCpo D} {CPO' : isCpo D'} {CPO'' : isCpo D''} (f : D * D' -> D'') (x2 : D')
(f_isContinuous : isContinuous f)
: isContinuous (fun x1 => f (x1, x2)).