(** * Theory of Sets : Exercises Copyright INRIA (2009-2012) Apics/Marelle Team (Jose Grimm). *) (* $Id: ssete2.v,v 1.131 2016/05/30 06:31:06 grimm Exp $ *) Require Import ssreflect ssrfun ssrbool eqtype ssrnat. Require Export sset13 ssete1. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module Exercise2. (** ** Section 1 *) (** Exercise 1.1: Example of a non-order *) Lemma Exercise1_1 r (E:= substrate r) (R := fun x y => [/\ inc x E, inc y E & glt r x y]) : order r -> (exists x y, x <> y /\ related r x y) -> [/\ transitive_r R, antisymmetric_r R & ~(reflexive_rr R)]. Proof. move=> or [x [y [xy rxy]]]; split => //. + move => a b c [aE bE ab] [_ cE bc];split => //; order_tac. + move => a b [aE bE [ab nab]] [_ _ ba]; order_tac. + have sxy : R x y by red; rewrite /E;split => //; try substr_tac; split. by move => ref; move: (ref _ _ sxy) => [_ [_ _ [_]]]. Qed. (** ---- Exercise 1.2: Quotient of a preorder relation [r] by an equivalence [s] We start with some auxiliary definitions *) Definition Ex1_2_strong_l r s:= (forall x x' y, gle r x y -> related s x x' -> gle r x' y). Definition Ex1_2_strong_r r s:= (forall x y y', gle r x y -> related s y y' -> gle r x y'). Definition Ex1_2_hC r s:= forall x y x', gle r x y -> related s x x' -> exists2 y', related s y y' & gle r x' y'. Definition Ex1_2_hC' r s:= forall x y z, gle r x y -> gle r y z -> related s x z -> related s x y. Definition Ex1_2_hD r f := forall x y x', gle r x y -> inc x' (source f) -> Vf f x = Vf f x' -> exists y', [/\ inc y' (source f), gle r x' y' & Vf f y = Vf f y']. Definition Ex1_2_hD' r r' f := forall x y, inc x (source f) -> inc y (source f) -> gle r' (Vf f x) (Vf f y) -> exists x' y', [/\ Vf f x = Vf f x', Vf f y = Vf f y' & gle r x' y']. Definition preorder_quo_axioms r s:= [/\ preorder r, equivalence s & substrate s = substrate r]. Definition weak_order_compatibility r s:= preorder_quo_axioms r s /\ Ex1_2_hC r s. Definition increasing_pre f r r':= [/\ preorder r, preorder r', function_prop f (substrate r) (substrate r') & fincr_prop f r r']. Definition preorder_isomorphism f r r' := [/\ preorder r, preorder r', bijection_prop f (substrate r) (substrate r') & fiso_prop f r r']. (** We can always endow the quotient with a preorder.*) Definition quotient_order_r r s X Y := [/\ inc X (quotient s), inc Y (quotient s) & forall x, inc x X -> exists2 y, inc y Y & gle r x y]. Definition quotient_order r s := graph_on (quotient_order_r r s) (quotient s). Lemma Exercise1_2a r s: preorder_quo_axioms r s -> preorder_r (quotient_order_r r s). Proof. move=> [ [gr rr tr] es sssr]; split. move=> a b c [aq bq abp] [_ cq bcp];split => //. move => x /abp [y /bcp [z zc yz] xy]; ex_tac; apply: tr xy yz. move=> a b [aq bq abp]. by split; split => // x xs; ex_tac; apply: rr; rewrite - sssr; apply: (inc_in_setQ_sr es xs). Qed. Lemma quotient_orderP r s x y: related (quotient_order r s) x y <-> quotient_order_r r s x y. Proof. split; [by move /Zo_hi; aw | move => h; move: (h) => [pa pb _] ]. by apply: Zo_i; aw; apply /setXp_P. Qed. Lemma quotient_is_preorder r s: preorder_quo_axioms r s -> preorder (quotient_order r s). Proof. by move=> h; apply: preorder_from_rel; apply: Exercise1_2a. Qed. Lemma substrate_quotient_order r s: preorder_quo_axioms r s -> substrate (quotient_order r s) = quotient s. Proof. move=> ax;move: (quotient_is_preorder ax)=> pq. set_extens x. by move /(preorder_reflexivity _ pq) /quotient_orderP => [xs _]. move=> xs; apply /(preorder_reflexivity _ pq) /quotient_orderP. have [po es ssr] := ax. split => //y yx; ex_tac; apply /(preorder_reflexivity _ po). rewrite - ssr; apply: (inc_in_setQ_sr es yx xs). Qed. (** Strong compatibility implies weak compatibility. Weak compatibilility says that [g: E/S -> F] is increasing if and only if it composition with the canonical projection is increasing [E -> F]. *) Lemma Exercise1_2b1 r s g r': preorder_quo_axioms r s -> function g -> quotient s = source g -> increasing_pre (g \co (canon_proj s)) r r' -> increasing_pre g (quotient_order r s) r'. Proof. move=> [_ es sssr] fg qs [pr pr' [fc sq sr'] ale]. split => //. by apply: quotient_is_preorder. hnf; aw; rewrite substrate_quotient_order//; split => //; rewrite - sr'; aw. have cc: (g \coP (canon_proj s)) by split;fprops; aw; ue. move => x y /quotient_orderP [xq yq h]. have [y0 y0y aux] := (h _ (setQ_repi es xq)). move:(arg1_sr aux)(arg2_sr aux); rewrite - sssr => h2 h1. have h0: source (canon_proj s) = substrate s by aw. move: (ale _ _ aux); aw; try ue. rewrite - (class_eq1 es (related_rep_in_class es yq y0y)). by rewrite (class_rep es xq) (class_rep es yq). Qed. Lemma strong_order_compatibility r s: preorder_quo_axioms r s -> Ex1_2_strong_l r s -> weak_order_compatibility r s. Proof. move=> h1 h2; split => //. move: h1 => [po eq ss] x y x' xy sxx'; exists y; last by apply: h2 xy sxx'. apply: reflexivity_e => //;red in xy;rewrite ss; substr_tac. Qed. Lemma compatibility_proj_increasing r s: preorder_quo_axioms r s -> (weak_order_compatibility r s <-> increasing_pre (canon_proj s) r (quotient_order r s)). Proof. move=> ax; move: (quotient_is_preorder ax) => pq. have [pr es sr] := ax. rewrite /increasing_pre - sr substrate_quotient_order //; aw. have gs: sgraph s by fprops. split. move=> [_ woc]; split;fprops; first by split; fprops; aw. move=> x y lexy. move:(arg1_sr lexy) (arg2_sr lexy); rewrite - sr => xss yss. apply /quotient_orderP; rewrite /quotient_order_r; aw; split;fprops. move=> z /(class_P es) /(woc _ _ _ lexy) [y' /(class_P es) syy' rzy'];ex_tac. move=>[fc [_ _ _ _ ci]]; split => //. move=> x y x' rxy /(class_P es) sxx'. move:(arg1_sr rxy) (arg2_sr rxy); rewrite - sr => xss yss. move /quotient_orderP:(ci _ _ rxy) => [_ _]; rewrite /quotient_order_r; aw => h. by move: (h _ sxx') => [y'] /(class_P es) pa pb; exists y'. Qed. (** The equivalence [ P x = P y] is weakly compatible with order-product; In general it is not strongly compatible (unless all elements of the second set are related by the preorder). *) Lemma Exercise1_2c1 r1 r2: preorder r1 -> preorder r2 -> weak_order_compatibility (order_product2 r1 r2) (first_proj_eq (substrate r1) (substrate r2)). Proof. move:(first_proj_equivalence (substrate r1) (substrate r2)) => [q1 q2]. move=> p1 p2; split;first split => //. - by apply: order_product2_preorder. - by rewrite q2 order_product2_sr1. - move=> x y x' /order_product2_P [/setX_P [px px1 qx2] s2 [rp rq]]. move /first_proj_eq_related_P => [_ s3 sp]. move: (s2)(s3) => /setX_P [py py1 qy2] /setX_P [px' px'1 qx'2]. exists (J (P y) (Q x')). by apply /first_proj_eq_related_P; aw;split => //; apply /setXp_P. apply /order_product2_P; aw;split => //; first by apply /setXp_P. by split => //; [ ue | apply /preorder_reflexivity]. Qed. Lemma Exercise1_2c2 r1 r2 (p :=first_proj_eq (substrate r1) (substrate r2)) : preorder r1 -> preorder r2 -> nonempty (substrate r1) -> (Ex1_2_strong_l (order_product2 r1 r2) p \/ Ex1_2_strong_r (order_product2 r1 r2) p) -> r2 = coarse (substrate r2). Proof. move=> p1 p2 [x xr1] cp. have p3: (preorder (order_product2 r1 r2)) by apply: order_product2_preorder. set_extens t => ts. apply /setX_P;split; first exact:(proj31 p2 _ ts); substr_tac. move/setX_P: ts => [pt ps qs]. set X := ((substrate r1) \times (substrate r2)). have x1p:inc (J x (P t)) X by rewrite /X; fprops. have x2p:inc (J x (Q t)) X by rewrite /X; fprops. have rp: forall s, inc s X -> gle (order_product2 r1 r2) s s. by move => s H; apply/(preorder_reflexivity _ p3);rewrite order_product2_sr1. move: (rp _ x1p) (rp _ x2p) => r11 r22. have s12: (related p (J x (P t)) (J x (Q t))). apply /first_proj_eq_related_P; split; aw. have s21: (related p (J x (Q t)) (J x (P t))). apply /first_proj_eq_related_P; split;aw. rewrite - pt; case: cp => cp. move: (cp _ _ _ r22 s21) => /order_product2_P [_ _ [_] ]; aw. move: (cp _ _ _ r11 s12) => /order_product2_P [_ _ [_] ]; aw. Qed. (** We define here a preorder isomorphism. If [P = f \co phi ], where [phi] is the canonical projection then [f] is an isomorphism *) Lemma Exercise1_2c4 r1 r2 f (s := first_proj_eq (substrate r1) (substrate r2)) (r:= order_product2 r1 r2) : function f -> source f = quotient s -> target f = (substrate r1) -> preorder r1 -> preorder r2 -> nonempty (substrate r2) -> f \co (canon_proj s)=(first_proj (product (substrate r1) (substrate r2))) -> preorder_isomorphism f (quotient_order r s) r1. Proof. set (E1:= substrate r1); set (E2:= substrate r2). move=> ff sf tf p1 p2 [z zE2] cp. have sr: substrate r = E1 \times E2. by rewrite /r order_product2_sr1. have [es ss] := (first_proj_equivalence E1 E2). have cpa: f \coP (canon_proj s) by split => //;aw; apply: canon_proj_f. have pr: preorder r by rewrite /r; apply: order_product2_preorder. have sc: (source (canon_proj s)= E1 \times E2) by aw. have pqa: preorder_quo_axioms r s by split => //; ue. have sq: substrate (quotient_order r s) = source f. by rewrite substrate_quotient_order. have aux: forall x, inc x (source f) -> [/\ inc x (quotient s), inc (rep x) (substrate s) & P (rep x) = Vf f x]. move => x xs. have xqs: inc x (quotient s) by rewrite - sf. have pa: inc (rep x) (substrate s) by fprops. move:(pa) (pa); rewrite ss => pc; rewrite - sc => rsx. split => //; move: (compf_V cpa rsx); rewrite cp first_proj_V //; aw. by rewrite (class_rep es xqs). have bf: bijection f. split; split => //. move => x y xs ys sW. move:(aux _ xs)(aux _ ys) => [pa b pc] [qa qb qc]. apply /(related_rr_P es pa qa). by apply /first_proj_eq_related_P;split => //; try ue; rewrite pc qc. rewrite tf => y ye1. have Js: (inc (J y z) (source (canon_proj s))) by ue. have ->: (source f = target (canon_proj s)) by aw. exists (Vf (canon_proj s) (J y z)); fprops. rewrite - (compf_V cpa Js) cp first_proj_V //; [ aw| ue]. split => //; [by apply: quotient_is_preorder => //; ue | move=> x y xsf ysf]. move:(aux _ xsf)(aux _ ysf) => [pa b pc] [qa qb qc]. have rx:=(setQ_repi es pa). split. move/quotient_orderP => [_ _ h]. move: (h _ rx) => [w wy /order_product2_P [rpx wp [le1 le2]]]. have yc :=(is_class_pr es wy qa). move: (related_rep_class es (inc_in_setQ_sr es wy qa)). by rewrite - yc - pc - qc; move /first_proj_eq_related_P => [_ rys <-]. move=> h; apply/quotient_orderP; split => // w wx. move: (inc_in_setQ_sr es wx pa); rewrite ss => wpr. move/setX_P: (wpr) => [pw Pw Qw]. have JP: (inc (J (Vf f y) (Q w)) ((substrate r1) \times (substrate r2))). apply /setXp_P;split => //; rewrite -/E1 -tf; Wtac. exists (J (Vf f y) (Q w)). rewrite - {2} (class_rep es qa); apply /(class_P es). apply /first_proj_eq_related_P; split => //; aw; ue. apply /order_product2_P; split => //; aw;split; last by apply: (proj32 p2). have xc:= (is_class_pr es wx pa). move:(related_rep_class es (inc_in_setQ_sr es wx pa)). rewrite -xc; move /first_proj_eq_related_P => [_ _ ->];ue. Qed. (** We give here a sufficient condition for the quotient to be an order *) Lemma Exercise1_2d r s: equivalence s -> order r -> substrate s = substrate r -> Ex1_2_hC' r s -> order (quotient_order r s). Proof. move => es or ss qoa. have pr:= (order_preorder or). have pqa: preorder_quo_axioms r s by []. have [p1 p2 p3] := (quotient_is_preorder pqa). split => //. suff sxy: forall x y, related (quotient_order r s) x y -> related (quotient_order r s) y x -> sub x y. by move=> x y xs ys; apply: extensionality; apply: sxy. move=> x y /quotient_orderP [xs ys q1] /quotient_orderP [_ _ q2] t tx. move: (q1 _ tx) => [z zy tz]; move: (q2 _ zy) => [w wt zw]. have tw: (related s t w). by apply /(in_class_relatedP es); exists x; split => //; apply /(setQ_P es). rewrite (is_class_pr es zy ys);apply /(class_P es); apply: (symmetricity_e es). exact: (qoa _ _ _ tz zw tw). Qed. (** Bourbaki says: there are examples of totally ordered sets [E] with four elements such that the quotient is ordered, and none of the two conditions is satisfied. We first show that [E/S] is isomorphic to a subset of [E] (two classes compare the same as their greatest element). If [a < b < c], the equivalence relation that relates [a] and [c], but is otherwise trivial satisfies none of the two conditions.*) Lemma Exercise1_2e1 r s: equivalence s -> total_order r -> substrate s = substrate r -> finite_set (substrate r) -> total_order (quotient_order r s). Proof. move => eqs tor ssr fs. have or := (proj1 tor). have pr := (order_preorder or). have [p1 p2 p3] := (quotient_is_preorder (And3 pr eqs ssr)). pose gr x := (the_greatest (induced_order r x)). pose A x := (inc (gr x) x /\ forall y, inc y x -> gle r y (gr x)). have gp: forall x, sub x (substrate r) -> nonempty x -> A x. move => x xsr nex. have h := (finite_subset_torder_greatest tor (sub_finite_set xsr fs) xsr nex). have [pa' pb'] := (iorder_osr or xsr). case: (the_greatest_pr pa' h); rewrite -/ (gr x) pb' => pa pb. split => // y yx; exact: (iorder_gle1 (pb _ yx)). have gp1: forall x, inc x (quotient s) -> A x. move => x xq; apply: gp (setQ_ne eqs xq). move => t tx; rewrite - ssr; apply: (inc_in_setQ_sr eqs tx xq). have paP: forall x y, related (quotient_order r s) x y <-> [/\ inc x (quotient s),inc y (quotient s) & gle r (gr x) (gr y)]. move => x y; apply: (iff_trans (quotient_orderP r s x y)). split; move=> [pa pb pc];move: (gp1 _ pa) (gp1 _ pb)=> [qa qb][qc qd]. split => //; move: (pc _ qa) => [z /qd le2 le1]; order_tac. split => //t tx; ex_tac; move: (qb _ tx) => le1; order_tac. split. split => // x y /paP [xq yq le1] /paP [_ _ le2]. have sv: (gr x) = (gr y) by order_tac. move: (gp1 _ xq) (gp1 _ yq) => [xs _] [ys _]. by rewrite (is_class_pr eqs xs xq) (is_class_pr eqs ys yq) sv. rewrite (substrate_quotient_order (And3 pr eqs ssr)) => x y xsr ysr. move: (proj1 (gp1 _ xsr)) (proj1 (gp1 _ ysr)) => xs ys. move: (inc_in_setQ_sr eqs xs xsr); rewrite ssr => x1. move: (inc_in_setQ_sr eqs ys ysr); rewrite ssr => y1. by case: (proj2 tor _ _ x1 y1) =>h; [left | right]; apply /paP. Qed. Lemma Exercise1_2e2 r a b c (E:= substrate r) (s := (diagonal E) \cup (doubleton (J a c) (J c a))): order r -> glt r a b -> glt r b c -> [/\ equivalence s, substrate s = substrate r, ~ ( weak_order_compatibility r s) & ~ ( Ex1_2_hC' r s)]. Proof. move => or lab lbc. have asr: inc a (substrate r) by order_tac. have csr: inc c (substrate r) by order_tac. have dp := (diagonal_i_P E); have dpi:= (diagonal_pi_P E). have gs: sgraph s by move => t /setU2_P [ /dp [] // | /set2_P [] ->]; fprops. have pa: forall u v, inc (J u v) s -> (inc u E /\ inc v E). move => u v;case/setU2_P; first by move/dp; aw; move=> [_ xE <-]. by case /set2_P => h;rewrite (pr1_def h) (pr2_def h). have pb: forall t, inc t E -> related s t t. by move => t te; apply /setU2_P; left; apply/dpi. have sr: substrate s = E. set_extens t; last by move /pb => h; substr_tac. by move /(substrate_P gs);case; move => [y /pa [tE tE']]. have sac: related s a c by apply /setU2_P; right; fprops. have sca: related s c a by apply /setU2_P; right; fprops. have es: equivalence s. split => //; first by red; rewrite sr => t; apply pb. move => x y z yx xz. case/setU2_P:(yx); [ by move/dp=> [_ _]; aw => -> | move => h1]. case/setU2_P:(xz); [ by move/dp=> [_ _]; aw => <- | move => h2]. case/set2_P: h1 => h1; rewrite ? (pr1_def h1) ? (pr2_def h1); case/set2_P:h2 => h2; rewrite ? (pr1_def h2) ? (pr2_def h2);fprops. move => x y xy;apply /setU2_P; case/setU2_P: xy. by move/dp;aw; move=> [_ ha <-]; left;apply /dpi. case/set2_P => h; rewrite (pr1_def h) (pr2_def h);fprops. move:(proj2 lab) (proj2 lbc) => nab nbc; move:(nesym nab) => nba. split => //. move => [_ pc]; move: (pc a b c (proj1 lab) sac) => [z]. case /setU2_P; first by move /dpi => [_ <-] => cb; order_tac. by case /set2_P => /pr1_def. move => hh; move: (hh a b c (proj1 lab) (proj1 lbc) sac). by case /setU2_P; [ move /dpi => [_ ] | case /set2_P => /pr2_def]. Qed. Lemma Exercise1_2e4 r: total_order r -> \3c <=c cardinal (substrate r) -> exists a b c, glt r a b /\ glt r b c. Proof. move => [or tor] /cardinal_ge3; rewrite /glt. move => [a [b [c [ae be ce [ab bc ac]]]]]. case:(tor _ _ ae be) => h1; case: (tor _ _ be ce) => h2; first by exists a,b,c. case: (tor _ _ ae ce) => h3; [ exists a,c, b | exists c, a,b ]; fprops. case: (tor _ _ ae ce) => h3; [ exists b,a,c | exists b,c, a]; fprops. exists c, b, a; fprops. Qed. Lemma Exercise1_2e5 r: total_order r -> finite_set (substrate r) -> \3c <=c cardinal (substrate r) -> exists s, [/\ equivalence s, substrate s = substrate r, total_order (quotient_order r s), ~ ( weak_order_compatibility r s) & ~ ( Ex1_2_hC' r s) ]. Proof. move => tor fso /(Exercise1_2e4 tor) [a [b [c [ab bc]]]]. move: (Exercise1_2e2 (proj1 tor) ab bc). set s := union2 _ _; move => [es ss pa pb]; exists s;split => //. by apply: Exercise1_2e1. Qed. (** Consider the equivalence induced by an increasing function [f:E -> F]. The second condition is alwats true; the first is equivalent to some condition [CC]. If [f = g \co phi] is the canonical decomposition then [g: E/S -> f(E)] is an isomorphism iff [CC] and [DD] hold *) Lemma Exercise1_2f1 r r' f: increasing_fun f r r' -> Ex1_2_hC' r (equivalence_associated f). Proof. move => [or or' [ff sr sr'] icf]. move=> x y z xy yz. move:(icf _ _ xy)(icf _ _ yz) => sa sb. move/(ea_relatedP ff) => [_ _ sw]; rewrite - sw in sb. apply /(ea_relatedP ff); rewrite sr; split => //; order_tac. Qed. Lemma Exercise1_2f2 r r' f: increasing_fun f r r' -> (weak_order_compatibility r (equivalence_associated f) <-> (Ex1_2_hD r f)). Proof. move => [or or' [ff sr sr'] icf]. rewrite /weak_order_compatibility. split. move=> [[pr ea sea] ch] x y x' xy x'sf sW. have aux: (related (equivalence_associated f) x x'). apply /ea_relatedP => //; split => //; rewrite sr; order_tac. move: (ch _ _ _ xy aux) => [y' /(ea_relatedP ff) [pa pb pc] x'y']. by exists y'. have [ee se]:=(graph_ea_equivalence ff). move=> ch; split; first split. + by apply: order_preorder. + done. + by rewrite se. + move=> x y y' xy /(ea_relatedP ff) [xsf ysf sv]. move: (ch _ _ _ xy ysf sv) => [z [zf y'z sv1]]. exists z=> //; apply /(ea_relatedP ff);split => //; rewrite sr; order_tac. Qed. Lemma Exercise1_2f3 r r' f g (s := (equivalence_associated f)): increasing_fun f r r' -> composable g (canon_proj s) -> f = compose g (canon_proj s) -> (order_morphism g (quotient_order r s) r' <-> (Ex1_2_hD r f /\ Ex1_2_hD' r r' f)). Proof. move => incf cgf fc. have qoa:= (Exercise1_2f1 incf). move: incf => [or or' [ff sr sr'] icf]. have [es ss]:= (graph_ea_equivalence ff). have sssr: substrate s = substrate r by rewrite ss. have pr: preorder r by apply: order_preorder. have qp: forall x, inc x (quotient s) -> (inc (rep x) (source f) /\ Vf f (rep x) = Vf g x). move=> x xq; move: (rep_i_sr es xq) => rxs. split; first by rewrite - ss. move: (canon_proj_V rxs); rewrite class_rep // => cpv. have rsc: inc (rep x) (source (canon_proj s)) by aw. by rewrite - {2} cpv - compf_V // - fc. have bpP :forall x, inc x (quotient s) -> forall a, (inc a x <-> [/\ inc (rep x) (source f), inc a (source f) & Vf f (rep x) = Vf f a]). move=> x xq a; split. by move=> ax; move: (related_rep_in_class es xq ax); move /(ea_relatedP ff). by move=> h;rewrite -(class_rep es xq); apply /(class_P es) /(ea_relatedP ff). have ax: preorder_quo_axioms r s by split. split => om. have aux: forall y, inc y (source f) -> [/\ inc (class s y) (quotient s), Vf f (rep (class s y)) = Vf g (class s y) & Vf f (rep (class s y)) = Vf f y]. move => y ; rewrite - ss => ys. have csyq:= (inc_class_setQ ys);have p2 := proj2 (qp _ csyq). by move /(bpP _ csyq): (inc_itself_class es ys) => [_ _ p5]. have p1: forall x y, inc x (source f) -> inc y (source f) -> gle r' (Vf f x) (Vf f y) -> exists y', [/\ inc y' (source f), gle r x y' & Vf f y = Vf f y']. move=> x y xsf ysf. have xc: (inc x (class s x)) by apply:inc_itself_class=>//;rewrite ss. move: (aux _ xsf)(aux _ ysf) => [csxq p2 p5][csyq p2' p5']. move: om => [q1 q2 [q3 q4 q5]]. rewrite /fiso_prop q4 substrate_quotient_order // => q6P. rewrite -p5 p2 -p5' p2' => /(q6P _ _ csxq csyq) /quotient_orderP [_ _ q7]. move /q7: xc => [u ucy xu]; rewrite - p2'; exists u. by move: ucy => /(bpP _ csyq) [q8 q9 q10]. split. move => x y x' xy x'sf sW. move: (icf _ _ xy); rewrite sW => fxy. have yc: (inc y (source f)) by rewrite sr; order_tac. apply: p1 x'sf yc fxy. move=> x y xsf ysf leW;move: (p1 _ _ xsf ysf leW) => [x0 [p0 p2' p3]]. by exists x; exists x0. move:om=> [CCt DDt]. have oq: (order (quotient_order r s)). apply: Exercise1_2d => //. have sg: (source g = quotient s) by move: cgf => [_ _ ->]; aw. have tg: substrate r' = target g by rewrite - sr' fc; aw. have sqo: substrate (quotient_order r s) = source g. by rewrite sg substrate_quotient_order. have icgP: (forall x y, inc x (source g) -> inc y (source g) -> (gle (quotient_order r s) x y <-> gle r' (Vf g x) (Vf g y))). rewrite sg;move=> x y xsg ysg. move: (qp _ xsg) (qp _ ysg) => [rxs <-][rys <-]; split. move /quotient_orderP => [_ _ aux]. move: (aux _ (setQ_repi es xsg)) => [z /(bpP _ ysg) [q1 q2 q3] lerxz]. by rewrite q3; apply: icf. move => h; apply /quotient_orderP; split => // z /(bpP _ xsg) [p4 p5 p6]. move: (DDt _ _ rxs rys h) => [x' [y' [p1 p2 p3]]]. rewrite p1 in p6. move: (CCt _ _ _ p3 p5 p6) => [t [p7 p8 p9]]. exists t=> //;apply /(bpP _ ysg); split => //; ue. have fg //: function g by fct_tac. Qed. (** ---- Exercise 1.3: properties of ordinal sum *) Section Exercise1_3a. Variables r g: Set. Definition E13_F:= order_sum r g. Definition E13_sF:= sum_of_substrates g. Definition E13_lam := second_proj E13_sF. Definition E13_S:= equivalence_associated (second_proj E13_sF). Definition E13_H1:= orsum_ax r g. Definition E13_H2:= sgraph g /\ forall i, inc i (domain g) -> nonempty (substrate (Vg g i)). (** We know thar [order_sum] is an ordering under condition [ E13_H1]. Let [E(i)] denote the [i]-th sustbrate and [F(i)] its image in the disjoint union [E13_sF]. If [ E13_H2] holds, then [F(i)] form a partition of the disjoint union; moreover the second projection [Q] (more precisely [E13_lam]) is surjective. *) Lemma Exercise1_3a0: function E13_lam. Proof. rewrite /E13_lam; apply: second_proj_f =>//. Qed. Lemma Exercise1_3a1: sgraph E13_sF. Proof. move=> t /setUb_P [y]; rewrite /fam_of_substrates ! Lg_domain => yd. by rewrite /disjointU_fam; bw; move /indexed_P => []. Qed. Lemma Exercise1_3a2: surjection E13_lam. Proof. split; first by apply: Exercise1_3a0. rewrite /E13_lam {1 2}/second_proj => y; aw =>/(rangeP Exercise1_3a1) [x h]. ex_tac; rewrite second_proj_V //; aw. Qed. Lemma Exercise1_3a3: E13_H2 -> domain g = target E13_lam. Proof. move: Exercise1_3a1 => gE [gg alne]; rewrite /E13_lam /second_proj; aw. set_extens t. move=> tg;move: (alne _ tg) => [u us]; apply /(rangeP gE). by exists u; apply: disjoint_union_pi1. by move /(rangeP gE) => [x Je]; move: (du_index_pr1 Je); aw; case. Qed. Lemma Exercise1_3a3'': equivalence_on E13_S (source E13_lam). Proof. exact: (graph_ea_equivalence Exercise1_3a0). Qed. Lemma Exercise1_3a3': substrate E13_S = E13_sF. Proof. rewrite (proj2 Exercise1_3a3'') /E13_lam/ second_proj; aw. Qed. Lemma Exercise1_3a4: E13_H1 -> E13_H2 -> increasing_fun E13_lam E13_F r. Proof. move=> h1 h2; move:(h1) => [p2 p3 p4]; split => //. + exact: (orsum_or h1). + split. * exact: Exercise1_3a0. * by rewrite (orsum_sr h1) /E13_lam /second_proj /E13_F; aw. * by rewrite -(Exercise1_3a3 h2). + move=> x y h3; move: (orsum_gle_id h1 h3). move: h3 => /orsum_gleP [xs ys xy] h4. rewrite / E13_lam second_proj_V // second_proj_V //. Qed. (** We consider the function [disjointU_function f] that maps [i] to [F(i)]; and the associated equivalence (two elements are related if they are in the same [F(i)]). We show that this the equivalence associated to [E13_lam] and two elements are related if they have the same second projection *) Definition disjointU_function f := triple (domain f)(range (disjointU_fam f))(disjointU_fam f). Lemma disjointU_function_pr f: function (disjointU_function f) /\ graph (disjointU_function f) = (disjointU_fam f). Proof. rewrite / disjointU_function /disjointU_fam. split; [ apply: function_pr; [ fprops | fprops | bw] | aw ]. Qed. Lemma Exercise1_3a5P x y (f := fam_of_substrates g) : related (partition_relation (disjointU_function f) (disjointU f)) x y <-> [/\ inc x E13_sF, inc y E13_sF & Q x = Q y]. Proof. move: (disjointU_function_pr f) => [p1 p2]. have p3:partition_w_fam (graph (disjointU_function f)) (disjointU f). rewrite p2; apply: partition_disjointU; apply: fos_graph. apply: (iff_trans (isc_rel_P p1 p3 x y)). rewrite /in_same_coset/Vf/disjointU/disjointU_function; aw. rewrite /disjointU_fam; split. move=> [i [idf]]; bw => /indexed_P [px pxv qx] /indexed_P [py pyv qy]. rewrite qx qy -px -py; split => //; apply: disjointU_pi; ue. have ->: domain f = domain g by rewrite /f/fam_of_substrates; bw. move=> [xsg ysg sq]. move: (du_index_pr1 xsg) (du_index_pr1 ysg)=> [qxd pxs px][_ pys py]. exists (Q x); rewrite /f /fam_of_substrates; bw. split => //;apply /indexed_P; split => //; ue. Qed. Lemma Exercise1_3a6P x y: related E13_S x y <-> [/\ inc x E13_sF, inc y E13_sF & Q x = Q y]. Proof. move: Exercise1_3a1 Exercise1_3a0 => gs fl. have ss: (source (second_proj E13_sF) = E13_sF) by rewrite /second_proj; aw. apply: (iff_trans (ea_relatedP fl x y)); rewrite ss. split => [] [xs ys]; rewrite !second_proj_V //. Qed. (** We show that [ E13_S ] is an equivalence, satisfying the two conditions of the previous Exercise. Let [ E13_lam = g \co phi ] be the canonical decomposition, where [phi] is the canonical projection of [E13_S]. Then [g] is an order isormorphism (its target is the set of indices [i]). *) Lemma Exercise1_3a7: equivalence E13_S. Proof. exact: (proj1 Exercise1_3a3''). Qed. Lemma indexed_p2 a b c: inc a (b *s1 c) -> Q a = c. Proof. by move /indexed_P => [_ _]. Qed. Lemma Exercise1_3a8P a: E13_H2 -> (inc a (quotient E13_S) <-> exists2 i, inc i (domain g) & a = (Vg (fam_of_substrates g) i) *s1 i). Proof. move: Exercise1_3a7 => es h2. have df : domain (fam_of_substrates g) = domain g. by rewrite /fam_of_substrates;bw. have aux: forall i, inc i (domain g) -> (Vg (fam_of_substrates g) i = substrate (Vg g i)). move=> i idg; rewrite /fam_of_substrates; bw. split. move => aq; set y := rep a. have ysf: (inc y E13_sF) by rewrite -Exercise1_3a3'; apply: (rep_i_sr es aq). move: (disjointU_hi ysf); rewrite df; move => [Qx Px px];ex_tac. move/(setQ_P es): aq => aq. set_extens t. move => ta; move: (rel_in_class es aq ta) => /Exercise1_3a6P [_ tsf ->]. by move: (disjointU_hi tsf)=> [Qt Pt pt]; apply /indexed_P. move /indexed_P => [pt Pt Qt]; apply/(rel_in_class2 es aq). apply /Exercise1_3a6P;split => //; rewrite - pt Qt. by apply:disjoint_union_pi1 => //;rewrite - aux. move=> [i idg]; rewrite (aux _ idg) => ap; apply /(setQ_P es). have sa: sub a E13_sF. rewrite ap => t /indexed_P [pt Pt Qt]. by rewrite - pt Qt; apply: disjoint_union_pi1. have ra: inc (rep a) a. apply: rep_i; exists (J (rep (substrate (Vg g i))) i); rewrite ap. by apply: indexed_pi; apply: rep_i; apply: (proj2 h2). split; first by rewrite Exercise1_3a3'; apply: sa. have qa : Q (rep a) = i by rewrite {2} ap in ra; move: (indexed_p2 ra). set_extens t. move => ta; apply /(class_P es) /Exercise1_3a6P;split;fprops. by rewrite ap in ta; rewrite (indexed_p2 ta). move/(class_P es) /Exercise1_3a6P => [pa pb pc]; rewrite ap. move: (disjointU_hi pb) => [pd pe <-]; rewrite -pc qa. by apply : indexed_pi; rewrite - aux // -qa pc. Qed. Lemma Exercise1_3a9: function (fun_on_quotient E13_S E13_lam). Proof. move: Exercise1_3a0 => aux. move:Exercise1_3a3'' => [sa sb]. by apply: foqc_f. Qed. Lemma Exercise1_3a10: (fun_on_quotient E13_S E13_lam) \coP (canon_proj E13_S). Proof. split => //; first by apply: Exercise1_3a9. apply: canon_proj_f; apply: Exercise1_3a7. rewrite /fun_on_quotient/section_canon_proj; aw. Qed. Lemma Exercise1_3a11: E13_lam = (fun_on_quotient E13_S E13_lam) \co (canon_proj E13_S). Proof. apply: (canonical_decomposition_surj2 Exercise1_3a2). Qed. Lemma Exercise1_3a12 x: E13_H2 -> inc x (quotient E13_S) -> exists i, [/\ inc i (domain g), x = (Vg (fam_of_substrates g) i) *s1 i & Vf (fun_on_quotient E13_S E13_lam) x = i]. Proof. move: Exercise1_3a0 Exercise1_3a7 => fl es h2 xq. move /(Exercise1_3a8P x h2): (xq) => [i idg xp]. have sl:=proj2 Exercise1_3a3''. ex_tac. rewrite foqc_V //. have <-: (Q (rep x) = Vf E13_lam (rep x)). by rewrite /E13_lam second_proj_V // -Exercise1_3a3'; apply: rep_i_sr. have:(inc (rep x) x) by apply: (rep_in_class es); apply /(setQ_P es). by rewrite {2} xp; move /indexed_P => [_ _]. Qed. Lemma Exercise1_3a13: E13_H2 -> bijection (fun_on_quotient E13_S E13_lam). Proof. move: Exercise1_3a9 => ffoq h2. have sfoq: source (fun_on_quotient E13_S E13_lam) = quotient E13_S. by rewrite /fun_on_quotient /section_canon_proj; aw. split; split => //. rewrite sfoq => x y xq yq. move: (Exercise1_3a12 h2 xq) (Exercise1_3a12 h2 yq). by move => [i [_ p1 p2]] [j [_ p3 p4]]; rewrite p2 p4 p1 p3; move => ->. rewrite sfoq {1} /fun_on_quotient; aw; rewrite -(Exercise1_3a3 h2) => y yd. set (a:= Vg (fam_of_substrates g) y *s1 y). have aq: (inc a (quotient E13_S)) by apply /(Exercise1_3a8P _ h2); ex_tac. ex_tac. move: (Exercise1_3a12 h2 aq) => [i [idg p1 ->]]. have h:= (setQ_repi Exercise1_3a7 aq); move: (h); rewrite {2} p1 => h1. by rewrite -(indexed_p2 h) -(indexed_p2 h1). Qed. Lemma Exercise1_3a14: E13_H1 -> E13_H2 -> [/\ Ex1_2_hC E13_F E13_S, Ex1_2_hC' E13_F E13_S, Ex1_2_hD E13_F E13_lam & Ex1_2_hD' E13_F r E13_lam]. Proof. move=> h1 h2. move: (orsum_sr h1); rewrite -/E13_sF -/E13_F => s1. move: (orsum_or h1) => o1. have pa: Ex1_2_hC E13_F E13_S. move => x y z r1 /Exercise1_3a6P [xs sz qxz]. have ys: inc y E13_sF by rewrite - s1; order_tac. case: (equal_or_not (Q x) (Q y)) => qxy. exists z; last by order_tac; rewrite s1. apply /Exercise1_3a6P;split => //; ue. exists y; first by apply /Exercise1_3a6P. apply /orsum_gleP; split => //; left; rewrite -qxz; split; last by exact. exact (orsum_gle_id h1 r1). have pb:Ex1_2_hC' E13_F E13_S. move => x y z r1 r2. move: (orsum_gle_id h1 r1) (orsum_gle_id h1 r2) => q1 q2. move: r1 r2 => /orsum_gleP [_ ys _] _ /Exercise1_3a6P [xs _ sq]. apply /Exercise1_3a6P; split => //; move: h1 => [or _ _]. rewrite - sq in q2; order_tac. have ww: source E13_lam = E13_sF by rewrite /E13_lam /second_proj; aw. rewrite /Ex1_2_hD /Ex1_2_hD' ww. split => //. move=> x y x' => /orsum_gleP [xs ys lexy] x's. have r1: (Vf E13_lam x = Q x) by rewrite /E13_lam second_proj_V. have r2: (Vf E13_lam x' = Q x') by rewrite /E13_lam second_proj_V. have r3: (Vf E13_lam y = Q y) by rewrite /E13_lam second_proj_V. rewrite r1 r2 r3;move=> sq; case: lexy. rewrite sq; move=> lt; exists y;split => //; apply /orsum_gleP. by split => //; left. move=> [p1 p2]; exists x'; split => //; last by rewrite r2 - sq -p1. order_tac; ue. move => x y xs ys lxy. exists x; case: (equal_or_not (Vf E13_lam x) (Vf E13_lam y)) => h. exists x; split => //; order_tac; rewrite orsum_sr //. exists y; split => //; apply /orsum_gleP; split => //; left. move: lxy h;rewrite /E13_lam !second_proj_V //. Qed. Lemma Exercise1_3a15: E13_H1 -> E13_H2 -> order_isomorphism (fun_on_quotient E13_S E13_lam) (quotient_order E13_F E13_S) r. Proof. move=> h1 h2; move: (Exercise1_3a14 h1 h2) => [pa pb pc pd]. have gg:= Exercise1_3a1. have oo: (order (order_sum r g)) by fprops. have bf:= Exercise1_3a13. suff : (order_morphism (fun_on_quotient E13_S E13_lam) (quotient_order E13_F (equivalence_associated E13_lam)) r). by move => [p1 p2 [p3 p4 p5] p6]; split => //; split => //; apply: bf. by rewrite Exercise1_2f3; [| apply: Exercise1_3a4 =>// | apply: Exercise1_3a10 | apply: Exercise1_3a11]. Qed. End Exercise1_3a. (** The ordinal sum is associative, not commutative. Associativity has been proved in the main text. A example of non-commutatitivity is that [omega+1] and [1+omega] are non-equal. We show here that if a sum of two sets has a greatest element, then the second one has a greatest element, and give a simple example *) Lemma orsum2_greatest r r' x: order r -> order r' -> nonempty (substrate r') -> greatest (order_sum2 r r') x -> greatest r' (P x). Proof. move=> or or' [y ysr] [xsp xgr]. have aux: forall z, inc z (substrate r') -> (inc (J z C1) (substrate (order_sum2 r r'))). by move => z zi; rewrite (orsum2_sr or or'); apply: candu2_prb. move: (xgr _ (aux _ ysr)) => /orsum2_gleP; aw; move => [_ p1 p2]. move: p1 => /candu2P [px]; case => [] [pxs qxb]. by case: p2=> [] [p1 p3];[case: C1_ne_C0| case: p3| case: C1_ne_C0]. split => // x0 x0sr;move /orsum2_gleP:(xgr _ (aux _ x0sr)); aw;move=> [q1 q2]. have D :=C1_ne_C0; case;case => //. Qed. Lemma orsum2_greatest' r r' x: order r -> order r' -> greatest r' x -> greatest (order_sum2 r r') (J x C1). Proof. move => or1 or2 [pa pb]. have xx:inc (J x C1) (canonical_du2 (substrate r) (substrate r')). by apply: candu2_prb. hnf; rewrite (orsum2_sr or1 or2); split; first exact. move => y yd; apply /orsum2_gleP; split ; [exact | exact | ]. move/candu2P: yd => [py]; case; move => [l1 l2]. constructor 3; aw; split;fprops. constructor 2; aw; rewrite l2;split;fprops. Qed. Lemma image_of_greatest r r' f x: order_isomorphism f r r' -> greatest r x -> greatest r' (Vf f x). Proof. move => [or or' [sf tf bf] incf] [xs xg]. rewrite - tf in xs. split; first by Wtac; fct_tac. rewrite - bf;move => y /(bij_surj sf) [z zsf <-]. apply/ (incf _ _ zsf xs);apply: xg; ue. Qed. Lemma orsum2_nc: exists r r', [/\ order r, order r' & ~ ( (order_sum2 r r') \Is (order_sum2 r' r))]. Proof. move: (diagonal_osr (singleton C0))=> []; set r1 := diagonal _ => or1 sr1. move: (diagonal_osr (doubleton C0 C1))=> []; set r2 := diagonal _ => or2 sr2. have ns2: nonempty (substrate r2). have jp: inc (J C0 C0) r2 by apply /diagonal_pi_P;split;fprops. exists C0; substr_tac. have ng2: forall x, greatest r2 x -> False. move => x [_]; rewrite sr2 => h2;case: C0_ne_C1. move: (h2 _ (set2_1 C0 C1)) (h2 _ (set2_2 C0 C1)). by move /diagonal_pi_P => [_ ->] /diagonal_pi_P [_ ->]. have g2: greatest (order_sum2 r2 r1) (J C0 C1). apply:(orsum2_greatest' or2 or1); red; rewrite sr1; split;fprops. move => x /set1_P ->; apply/diagonal_pi_P;split;fprops. exists r2; exists r1;split => // [] [f isf]. move: (orsum2_greatest or1 or2 ns2 (image_of_greatest isf g2)) => eg. by case: (ng2 (P (Vf f (J C0 C1)))). Qed. (** Conditions under which an ordinal sum is totally ordered, directed, a lattice *) Section Exercise13b. Variables r g: Set. Hypothesis oa: orsum_ax r g. Definition orsum_ax2:= (forall i, inc i (domain g) -> nonempty (substrate (Vg g i))). Lemma orsum_pr0: orsum_ax2 -> forall i, inc i (substrate r) -> exists2 y, inc y (Vg (fam_of_substrates g) i) & inc (J y i) (sum_of_substrates g). Proof. move=> h i idg. move: oa => [or sr alo]; rewrite sr in idg. move: (h _ idg) => [j js]; exists j; first by rewrite /fam_of_substrates; bw. by apply: disjoint_union_pi1. Qed. Lemma orsum_pr1: orsum_ax2 -> forall i, inc i (domain g) -> exists2 y, inc y (Vg (fam_of_substrates g) i) & inc (J y i) (substrate (order_sum r g)). Proof. move: (oa) => [_ sr _] h i idg; rewrite - sr in idg. rewrite orsum_sr //; apply: (orsum_pr0 h idg). Qed. Lemma orsum_directed: orsum_ax2 -> (right_directed (order_sum r g) <-> (right_directed r /\ forall i, maximal r i -> right_directed (Vg g i))). Proof. move=> alne. move: (oa) => [or sr alo]. have os: order (order_sum r g) by fprops. have srr: (substrate (order_sum r g)) = (sum_of_substrates g). by apply: orsum_sr. split. move /right_directedP; bw; move=> [oor h]; split. apply /right_directedP;split => // x y xsr ysr. move: (orsum_pr0 alne xsr) => [x0 p1 p2]. move: (orsum_pr0 alne ysr) => [y0 p3 p4]. rewrite - srr in p2 p4. move: (h _ _ p2 p4) => [z [ zx zy]]. move: (orsum_gle_id oa zx) (orsum_gle_id oa zy); aw=> q1 q2. by exists (Q z); split => //; move:(du_index_pr1 zs); rewrite sr; case. move=> i []; rewrite sr => isr im. apply /right_directedP; split;fprops;move=> x y xsi ysi. move: (disjoint_union_pi1 isr xsi)(disjoint_union_pi1 isr ysi) => p1 p2. rewrite - srr in p2 p1. move: (h _ _ p1 p2) => [z [le1 le2]]. move:(arg2_sr le1); rewrite srr => /du_index_pr1 [p3 p4 p5]. move: (orsum_gle_id oa le1); aw => /im Qzi. move: le1 => /orsum_gleP [_ _];rewrite /order_sum_r Qzi. case; [ by case; aw | aw;move => [ _ le1]]. move: le2 => /orsum_gleP [_ _]; rewrite /order_sum_r Qzi. case; [ by case; aw | aw;move => [ _ le2]]. exists (P z); split => //; ue. move => [ /right_directedP [_ rr] imr]; apply /right_directedP; split => //; bw. move=> x y xsr ysr; rewrite srr in xsr ysr. move: (du_index_pr1 xsr) (du_index_pr1 ysr) => [Qx Px px][Qy Py py]. rewrite - sr in Qx Qy; move: (rr _ _ Qx Qy) => [z [ Qxz Qyz]]. case: (equal_or_not (Q x) z) => eQxz; case: (equal_or_not (Q y) z) => eQyz. + case: (p_or_not_p (maximal r z)) => mz. - move: (imr _ mz). move: (proj1 mz); rewrite sr => zs. move /right_directedP => [oz etc]. rewrite eQxz in Px;rewrite eQyz in Py. move: (etc _ _ Px Py)=> [t [ t1 t2]]. have aux:inc (J t z) (sum_of_substrates g). by apply: disjoint_union_pi1 => //; apply: (arg2_sr t1). exists (J t z);split => //; apply /orsum_gleP=> //; rewrite/order_sum_r pr1_pair pr2_pair; split=> //; right;split => //;ue. - have [u us zu]: (exists2 u, inc u (substrate r) & glt r z u). ex_middle h; case: mz; split => //; first by ue. move=> t zt; case: (equal_or_not z t) => // nzt. by case: h; exists t=> //; order_tac. move: (orsum_pr0 alne us) => [v v1 v2]; exists (J v u); split; apply /orsum_gleP=> //; rewrite /order_sum_r ?eQxz ?eQyz; aw; split;fprops. + exists x; split => //; first by order_tac; bw. apply /orsum_gleP; split => //; left; rewrite eQxz; split => //. + exists y; split => //; last by order_tac; bw. apply /orsum_gleP; split => //;left; rewrite eQyz; split => //. + move:(arg2_sr Qxz) => zdg. move: (orsum_pr0 alne zdg) => [v v1 v2]; exists (J v z); split; apply /orsum_gleP; split => //; left; aw; order_tac. Qed. Lemma orsum_total1: orsum_ax2 -> total_order (order_sum r g) -> (total_order r /\ forall i, inc i (domain g) -> total_order (Vg g i)). Proof. move=> alne; rewrite /total_order. move: (oa) => [or sr alo]; bw;rewrite sr. move=> [ors to]; split. split => // x y xdg ydg. move: (alne _ xdg) (alne _ ydg) => [a asx][b bsy]. case: (to _ _ (disjoint_union_pi1 xdg asx) (disjoint_union_pi1 ydg bsy)); move=> h; move: (orsum_gle2 h); rewrite /glt. move => aux;left; case: aux; move=> [res _] //; rewrite res; order_tac; ue. move => aux;right; case: aux; move=> [res _] //; rewrite res; order_tac; ue. move=> i idg; move: (alo _ idg) => lo; split => // => x y xsr ysr; red. by case: (to _ _ (disjoint_union_pi1 idg xsr) (disjoint_union_pi1 idg ysr)); move=> h; move: (orsum_gle2 h); case; case => // _ ok; [left | right]. Qed. Lemma orsum_total2: total_order r -> (forall i, inc i (domain g) -> total_order (Vg g i)) -> total_order (order_sum r g). Proof. move=> [_ tor] alt; rewrite /total_order. move: (oa) => [or sr alo]; bw. rewrite sr in tor. split =>//; first by fprops. move=> x y xsr ysr; move: (du_index_pr1 xsr) (du_index_pr1 ysr). move=> [Qx Px px][Qy Py py]. case: (equal_or_not (Q x) (Q y)). move =>h; move: (alt _ Qx) => [lor ltor]; rewrite -h in Py. case: (ltor _ _ Px Py) => h1;aw ; [left | right]; apply /orsum_gleP;split => //; right; split => //; ue. move=> nQ; case: (tor _ _ Qx Qy) => h; [left | right]; apply /orsum_gleP;split => //; left;split; fprops. Qed. Lemma orsum_g1 i x i' x': inc (J i x) (sum_of_substrates g) -> inc (J i' x') (sum_of_substrates g)-> gle r x x' -> x <> x' -> gle (order_sum r g) (J i x) (J i' x'). Proof. move=> js1 js2 le1 lt1. apply /orsum_gleP; split => //; left; aw; split => //. Qed. Lemma orsum_lattice1: orsum_ax2 -> lattice (order_sum r g) -> lattice r. Proof. move=> alne lF. move:(orsum_pr1 alne); set (F:= order_sum r g) => aux. move: (oa) => [or sr alo]. have oF: (order F) by rewrite /F; fprops. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. split => //; rewrite sr => x y xsr ysr. move: (aux _ xsr) (aux _ ysr) => [x' x'1 x'2][y' y'1 y'2]. split. move: (lattice_sup_pr lF y'2 x'2); rewrite -/F; move=> [le1 le2 le3]. case: (p_or_not_p (gle r x y))=> lxy. by exists y; apply: sup_comparable. case: (p_or_not_p (gle r y x)) => lyx. by exists x; rewrite set2_C; apply: sup_comparable. move: (arg2_sr le1); rewrite sF => zs; move:(du_index_pr1 zs) => [Qz Pz pz]. exists (Q (sup F (J y' y) (J x' x))); apply: lub_set2 => //. move: (orsum_gle_id oa le2); aw. move: (orsum_gle_id oa le1); aw. move=> t xt yt. move: (arg2_sr xt); rewrite sr => /aux [u uVg us]. rewrite sF in x'2 y'2 us. have le4: gle F (J x' x) (J u t) by apply: orsum_g1 => //; dneg aa; ue. have le5: gle F (J y' y) (J u t) by apply: orsum_g1 => //eyt; case: lxy; ue. move: (le3 _ le5 le4) => le6; move: (orsum_gle_id oa le6); aw. move: (lattice_inf_pr lF y'2 x'2); rewrite -/F; move=> [le1 le2 le3]. case: (p_or_not_p (gle r x y))=> lxy; first by exists x; apply: inf_comparable. case: (p_or_not_p (gle r y x)) => lyx. by exists y; rewrite set2_C; apply: inf_comparable. move: (arg1_sr le1);rewrite sF => zs; move: (du_index_pr1 zs) => [Qz Pz pz]. exists (Q (inf F (J y' y) (J x' x))). apply: glb_set2 => //. move: (orsum_gle_id oa le2); aw. move: (orsum_gle_id oa le1); aw. move=> t xt yt. move: (arg1_sr xt); rewrite sr; move=> /aux [u uVg us]. rewrite sF in x'2 y'2 us. have le4: (gle F (J u t) (J x' x)) by apply: orsum_g1 => //eyt; case: lxy; ue. have le5: (gle F (J u t) (J y' y)) by apply: orsum_g1 => //ext; case: lyx; ue. move: (le3 _ le5 le4) => le6; move: (orsum_gle_id oa le6); aw. Qed. Let orsum_lattice_H1:= forall i j, inc i (domain g) -> inc j (domain g) -> [\/ gle r i j, gle r j i | (exists u v, least (Vg g (sup r i j)) u /\ greatest (Vg g (inf r i j)) v)]. Let orsum_lattice_H2 := forall i x y t, inc i (domain g) -> gle (Vg g i) x t -> gle (Vg g i) y t -> has_supremum (Vg g i) (doubleton x y). Let orsum_lattice_H3 := forall i x y t, inc i (domain g) -> gle (Vg g i) t x -> gle (Vg g i) t y -> has_infimum (Vg g i) (doubleton x y). Let orsum_lattice_H4 := forall i x y, inc i (domain g) -> inc x (Vg (fam_of_substrates g) i) -> inc y (Vg (fam_of_substrates g) i) -> (forall t, inc t (Vg (fam_of_substrates g) i) -> ~ (gle (Vg g i) x t /\ gle (Vg g i) y t)) -> exists j, [/\ inc j (domain g), least (induced_order r (Zo (domain g) (fun k=> glt r i k))) j & has_least (Vg g j)]. Let orsum_lattice_H5 := forall i x y, inc i (domain g) -> inc x (Vg (fam_of_substrates g) i) -> inc y (Vg (fam_of_substrates g) i) -> (forall t, inc t (Vg (fam_of_substrates g) i) -> ~ (gle (Vg g i) t x /\ gle (Vg g i) t y)) -> exists j, [/\ inc j (domain g), greatest (induced_order r (Zo (domain g) (fun k=> glt r k i))) j & has_greatest (Vg g j)]. Lemma orsum_lattice2: orsum_ax2 -> lattice (order_sum r g) -> orsum_lattice_H1. Proof. move=> alne los i j idg jdg. move: (orsum_lattice1 alne los)=> lr. move:(orsum_pr1 alne); set (F:= order_sum r g) => aux. have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. case: (p_or_not_p (gle r i j)); first by in_TP4. case: (p_or_not_p (gle r j i)); first by in_TP4. move=> nji nij; constructor 3. move: (aux _ idg) (aux _ jdg) => [u uVg Ju][v vVg Jv]. move: (lattice_sup_pr los Ju Jv) (lattice_inf_pr los Ju Jv); rewrite -/F. set (A:= inf F (J u i) (J v j)); set (a:= inf r i j). set (B:= sup F (J u i) (J v j)); set (b:= sup r i j). move=> [p1 p2 p3][p4 p5 p6]. rewrite - sr in idg jdg. rewrite sF in Ju Jv. move: (lattice_inf_pr lr idg jdg) (lattice_sup_pr lr idg jdg). rewrite -/a -/b; move=> [q1 q2 q3][q4 q5 q6]. have Hc: Q A = a. have s1: (gle r (Q A) a). move: (orsum_gle_id oa p4) (orsum_gle_id oa p5); aw => s1 s2. apply: (q3 _ s1 s2). move: (arg1_sr q1); rewrite sr => /aux [y yVg Js]. rewrite sF in Js. have s2: gle F (J y a) (J u i) by apply: orsum_g1 => // eai; case: nij;ue. have s3: gle F (J y a) (J v j) by apply: orsum_g1 => // eai; case: nji;ue. move: (p6 _ s2 s3) => s4;move: (orsum_gle_id oa s4); aw => s5; order_tac. have Hd: Q B = b. have s1: (gle r b (Q B)). move: (orsum_gle_id oa p1)(orsum_gle_id oa p2); aw => s1 s2. apply: (q6 _ s1 s2). move: (arg2_sr q4); rewrite sr => /aux [y yVg Js]. rewrite sF in Js. have s2 : (gle F (J u i) (J y b)) by apply: orsum_g1 => // eai;case: nji;ue. have s3: (gle F (J v j) (J y b)) by apply: orsum_g1 => // eai; case: nij;ue. move: (p3 _ s2 s3) => s4;move: (orsum_gle_id oa s4); aw => s5; order_tac. move: (arg2_sr p2) (arg1_sr p5); rewrite sF => Bs As. move: (du_index_pr1 Bs) => [QB PB pB]; rewrite Hd in PB. move: (du_index_pr1 As) => [QA PA pA]; rewrite Hc in PA. exists (P B); exists (P A). rewrite /least /greatest; split; split => //. move=> x xs. have J1s: (inc (J x b) (sum_of_substrates g)). apply: disjoint_union_pi1=> //; ue. have s1: (gle F (J u i) (J x b)) by apply: orsum_g1 => // ib; case: nji; ue. have s2: (gle F (J v j) (J x b)) by apply: orsum_g1 => // ib; case: nij; ue. move: (p3 _ s1 s2) => /orsum_gleP [s3 s4]. case; aw; [ by move => [_ ];rewrite Hd; case | by move => [->] ]. move=> x xs. have J1s: (inc (J x a) (sum_of_substrates g)). apply: disjoint_union_pi1=> //; ue. have s1: (gle F (J x a) (J u i)) by apply: orsum_g1 => // ib; case: nij; ue. have s2: (gle F (J x a) (J v j)) by apply: orsum_g1 => // ib; case: nji; ue. move: (p6 _ s1 s2) => /orsum_gleP [s3 s4]. case; aw; [ by move => [_ ];rewrite Hc; case | by move => [->] ]. Qed. Lemma orsum_lattice3: lattice (order_sum r g) -> orsum_lattice_H2. Proof. move=> lo i x y t idg le1 le2. set (F:= order_sum r g). have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. move: (arg1_sr le1)(arg2_sr le1) (arg1_sr le2). move=> xs ts ys. move: (disjoint_union_pi1 idg xs)(disjoint_union_pi1 idg ys). move: (disjoint_union_pi1 idg ts); rewrite - sF => Jts Jxs Jys. move: (lattice_sup_pr lo Jxs Jys) => [ple1 ple2 ple3]. have le4: (gle F (J y i) (J t i)) by apply /orsum_gleP;split => //; try ue; right;split => //; aw. have le5: (gle F (J x i) (J t i)) by apply /orsum_gleP;split => //; try ue; right;split => //; aw. move: (ple3 _ le5 le4) => le6. move: (orsum_gle_id oa ple1); aw => le7. move: (orsum_gle_id oa le6); aw => le8. move: (order_antisymmetry or le7 le8) => eq1. exists (P (sup (order_sum r g) (J x i) (J y i))). apply: lub_set2; first by apply: alo. move: ple1 =>/orsum_gleP [_ _]; case; first by move => [_]; aw;case. by aw; move => [->]. move: ple2 =>/orsum_gleP [_ _]; case; first by move => [_]; aw;case. by aw; move => [->]. move=> u xu yu. move: (disjoint_union_pi1 idg (arg2_sr xu)) => Jus. rewrite - sF in Jus. have le9: (gle F (J x i) (J u i)) by apply /orsum_gleP;split => //; [ue|ue| right;split => //; aw]. have le10: (gle F (J y i) (J u i)) by apply/orsum_gleP;split => //; [ue|ue| right;split => //; aw]. move: (ple3 _ le9 le10). move /orsum_gleP => [_ _]; case;aw; first by move => [_]; rewrite - eq1. by move => [->]. Qed. Lemma orsum_lattice4: lattice (order_sum r g) -> orsum_lattice_H3. Proof. move=> lo i x y t idg le1 le2. set (F:= order_sum r g). have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. move: (arg2_sr le1)(arg1_sr le1) (arg2_sr le2). move=> xs ts ys. move: (disjoint_union_pi1 idg xs)(disjoint_union_pi1 idg ys). move: (disjoint_union_pi1 idg ts); rewrite - sF => Jts Jxs Jys. move: (lattice_inf_pr lo Jxs Jys) => [ple1 ple2 ple3]. have le4: (gle F (J t i) (J y i)) by apply /orsum_gleP;split => //; try ue; right;split => //; aw. have le5: (gle F (J t i) (J x i)) by apply /orsum_gleP;split => //; try ue; right;split => //; aw. move: (ple3 _ le5 le4) => le6. move: (orsum_gle_id oa ple1); aw => le7. move: (orsum_gle_id oa le6); aw => le8. move: (order_antisymmetry or le7 le8) => eq1. exists (P (inf (order_sum r g) (J x i) (J y i))). apply: glb_set2; first by apply: alo. move: ple1 =>/orsum_gleP [_ _]; case; first by move => [_]; aw;case. by aw; move => [->]. move: ple2 =>/orsum_gleP [_ _]; case; first by move => [_]; aw;case. by aw; move => [->]. move=> u xu yu. move: (disjoint_union_pi1 idg (arg1_sr xu)) => Jus. rewrite - sF in Jus. have le9: (gle F (J u i) (J x i)) by apply /orsum_gleP;split => //; [ue|ue| right;split => //; aw]. have le10: (gle F (J u i) (J y i)) by apply/orsum_gleP;split => //; [ue|ue| right;split => //; aw]. move: (ple3 _ le9 le10). move /orsum_gleP => [_ _]; case;aw; first by move => [_]; case; rewrite eq1. by move => [->]. Qed. Lemma orsum_lattice5: orsum_ax2 -> lattice (order_sum r g) -> orsum_lattice_H4. Proof. move=> alne los i x y idg xVs yVs alt. move: (orsum_lattice1 alne los)=> lr. set (F:= order_sum r g). have aux:forall i, inc i (domain g) -> exists2 y, inc y (Vg (fam_of_substrates g) i) & inc (J y i) (substrate F) by apply: orsum_pr1. have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. move: xVs yVs;rewrite /fam_of_substrates; bw => xVs yVs. move: (disjoint_union_pi1 idg xVs) (disjoint_union_pi1 idg yVs) => l1 l2. rewrite - sF in l1 l2. move: (lattice_sup_pr los l1 l2). set (Z:=sup (order_sum r g) (J x i) (J y i)). move=> [] /orsum_gleP [_ zs l3] /orsum_gleP [_ _ l4] l5. move: (du_index_pr1 zs) => [QZ PZ pz]. have l6: (glt r i (Q Z)). move: l3; case; aw; move: l4; case; aw; move=> [iQ l3] [_ l4]. move:(alt (P Z)); rewrite /fam_of_substrates; bw. rewrite {1} iQ;move=> h; case: (h PZ); split => //. have sZ: (sub (Zo (domain g) (glt r i)) (substrate r)). rewrite sr; apply: Zo_S. have z1: inc (Q Z) (Zo (domain g) (glt r i)) by apply: Zo_i. exists (Q Z); split => //. red; aw;split => //; move => u /Zo_P [udg iu]; apply /iorder_gleP => //. by apply: Zo_i. move:(aux _ udg) => [v vVg Js]. have l7: (gle F (J x i) (J v u)) by apply /orsum_gleP;split => //; try ue; left; aw. have l8: (gle F (J y i) (J v u)) by apply /orsum_gleP;split => //; try ue; left; aw. move:(orsum_gle_id oa (l5 _ l7 l8)); aw. exists (P Z);split => // u us. move:(disjoint_union_pi1 QZ us) => Js. have l7: (gle F (J x i) (J u (Q Z))) by apply /orsum_gleP;split => //; try ue; left; aw. have l8: (gle F (J y i) (J u (Q Z))) by apply /orsum_gleP;split => //; try ue; left; aw. by move: (l5 _ l7 l8) => /orsum_gleP [r1 r2];case =>[] []; aw => _; case. Qed. Lemma orsum_lattice6: orsum_ax2 -> lattice (order_sum r g) -> orsum_lattice_H5. Proof. move=> alne los i x y idg xVs yVs alt. have lr:= (orsum_lattice1 alne los). set (F:= order_sum r g). have aux:forall i, inc i (domain g) -> exists2 y, inc y (Vg (fam_of_substrates g) i) & inc (J y i) (substrate F) by apply: orsum_pr1. have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. move: xVs yVs;rewrite /fam_of_substrates; bw => xVs yVs. move: (disjoint_union_pi1 idg xVs) (disjoint_union_pi1 idg yVs) => l1 l2. rewrite - sF in l1 l2. move: (lattice_inf_pr los l1 l2). set (Z:=inf (order_sum r g) (J x i) (J y i)). move => []/orsum_gleP [zs _ l3 ] /orsum_gleP [_ _ l4] l5. move: (du_index_pr1 zs) => [QZ PZ pz]. have l6: (glt r (Q Z) i). move: l3; case; aw; move: l4; case; aw; move=> [iQ l3] [_ l4]. move:(alt (P Z)); rewrite /fam_of_substrates; bw. rewrite - iQ;move=> h; case: (h PZ); split => //. have sZ: (sub (Zo (domain g) (fun k => glt r k i)) (substrate r)). rewrite sr; apply: Zo_S. have z1: inc (Q Z) (Zo (domain g) (fun k => glt r k i)) by apply Zo_i. exists (Q Z); split => //. red; aw; split => //; move => u /Zo_P [udg iu]. apply /iorder_gleP => //; first by apply: Zo_i. move:(aux _ udg) => [v vVg Js]. have l7: (gle F (J v u) (J x i)) by apply /orsum_gleP;split => //; try ue; left; aw. have l8: (gle F (J v u) (J y i)) by apply /orsum_gleP;split => //; try ue; left; aw. move: (orsum_gle_id oa (l5 _ l7 l8)); aw. exists (P Z);split => // u us. move:(disjoint_union_pi1 QZ us) => Js. have l7: (gle F (J u (Q Z)) (J x i)) by apply /orsum_gleP;split => //; try ue; left; aw. have l8: (gle F (J u (Q Z)) (J y i)) by apply /orsum_gleP;split => //; try ue; left; aw. by move: (l5 _ l7 l8); move /orsum_gleP => [r1 r2];case =>[] []; aw => _; case. Qed. Lemma orsum_lattice: orsum_ax2 -> (lattice (order_sum r g) <-> ((lattice r) /\ [/\ orsum_lattice_H1, orsum_lattice_H2, orsum_lattice_H3, orsum_lattice_H4 & orsum_lattice_H5])). Proof. move=> alne. set (F:= order_sum r g). have oF:order F by rewrite /F; fprops. move: (oa) => [or sr alo]. split. move=> h; split; last split. apply: (orsum_lattice1 alne h). apply: (orsum_lattice2 alne h). apply: (orsum_lattice3 h). apply: (orsum_lattice4 h). apply: (orsum_lattice5 alne h). apply: (orsum_lattice6 alne h). move=> [h1 [h2 h3 h4 h5 h6]]. have sF: substrate F = sum_of_substrates g by rewrite /F; bw. split=>//. rewrite sF;move=> x y xs ys. move: (du_index_pr1 xs) (du_index_pr1 ys) => [Qx Px px][Qy Py py]. rewrite - sr in Qx Qy. split. move: (lattice_sup_pr h1 Qx Qy); set (a:= sup r (Q x) (Q y)). move=> [l1 l2 l3]. have p1: (forall z, gle F x z -> gle F y z -> gle r a (Q z)). move=> z z1 z2; move: (orsum_gle_id oa z2). move: (orsum_gle_id oa z1); apply: l3. case: (equal_or_not (Q x) (Q y)) => sq. rewrite - sq in Py; rewrite sr in Qx Qy. case: (p_or_not_p (exists2 t, gle (Vg g (Q x)) (P x) t & gle (Vg g (Q x)) (P y) t)). move=> [t l4 l5]; move: (h3 _ _ _ _ Qx l4 l5) => sd. move: (sup_pr (alo _ Qx) Px Py sd). set (z:= sup _ _ _); move => [z1 z2 z3]. have jZs: (inc (J z (Q x)) (substrate F)). rewrite sF; apply: disjoint_union_pi1 => //; order_tac. exists (J z (Q x)). apply: lub_set2. + exact. + apply/orsum_gleP;split => //;try ue;right; aw => //; ue. + apply/orsum_gleP;split => //;try ue;right; aw => //; ue. + move => w /orsum_gleP [_ w0 w1] /orsum_gleP [_ _ w2]. apply /orsum_gleP;split => //; first by ue. case: w1 => [] [pa pb]; [ by left; aw; split | right; aw ]. case: w2; first by move => [_]; case; rewrite - sq. move => [->]; ue. move=> net. have aux: (forall t, inc t (Vg (fam_of_substrates g) (Q x)) -> ~ (gle (Vg g (Q x)) (P x) t /\ gle (Vg g (Q x)) (P y) t)). move=> t tVQ [ha hb]; case: net; exists t=>//. have Px': (inc (P x) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw. have Py': (inc (P y) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw. move: (h5 _ _ _ Qx Px' Py' aux) => [w [wdg lew [z [zs lez]]]]. set s:=(Zo (domain g) (fun k : Set => glt r (Q x) k)) in lew. have Hc:sub s (substrate r) by rewrite sr; apply: Zo_S. move: lew; rewrite /least; aw; move=> [/Zo_P [_] lt0 lew]. have Js: (inc (J z w) (sum_of_substrates g)). apply: disjoint_union_pi1 => //. exists (J z w); apply: lub_set2. exact. apply /orsum_gleP; split => //; left;aw; ue. apply /orsum_gleP; split => //; left;aw; ue. move=> t /orsum_gleP [_ ts l4] /orsum_gleP[_ _ l5 ]. apply /orsum_gleP;split => //. move: (du_index_pr1 ts) => [Qt Pt pt]. case: (equal_or_not w (Q t)) => wq. by right; aw;split => //; apply: lez; ue. left; aw;split => //; case: (p_or_not_p (glt r (Q x) (Q t))). move=> le3; apply: (iorder_gle1 (lew _ (Zo_i Qt le3))). move=> ltxt; case: l4; [ by move => r1 | move=> [r1 r2] ]. case: l5; rewrite - sq; [ by move => r3 | move=> [r3 r4] ]. have Pt': (inc (P t) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw; ue. case: (aux _ Pt'); split => //. rewrite sr in Qx Qy. move: (h2 _ _ Qx Qy) => h7. case: (equal_or_not (Q y) a) => Qya. exists y; apply: sup_comparable=> //. apply /orsum_gleP;split => //; left; split => //; ue. case: (equal_or_not (Q x) a) => Qxa. exists x; rewrite set2_C; apply: sup_comparable => //. apply /orsum_gleP;split => //; left; split => //; ue. case: h7=> h7'. have lyy: (gle r (Q y) (Q y)) by order_tac; ue. case: Qya; exact: (order_antisymmetry or l2 (l3 _ h7' lyy)). have lxx: (gle r (Q x) (Q x)) by order_tac; ue. case: Qxa; exact: (order_antisymmetry or l1 (l3 _ lxx h7')). move: h7' => [u [v [lea geb]]]. rewrite -/a in lea; move: lea => [us leu]. have J3: (inc (J u a) (sum_of_substrates g)). apply: disjoint_union_pi1 => //; rewrite - sr; order_tac. exists (J u a); apply: lub_set2. exact. by apply /orsum_gleP;split => //;left;split;aw => //; apply:nesym. by apply /orsum_gleP;split => //;left;split;aw => //; apply:nesym. move=> t l5 l6; move: (p1 _ l5 l6). move: l5 l6 => /orsum_gleP [xsg tsg s1] /orsum_gleP [ysg _ s2] aQ. apply /orsum_gleP;split => //. case: (equal_or_not a (Q t)) => naQ; last by left; aw. right; aw;split => //; apply: leu; rewrite naQ. by move: (du_index_pr1 tsg) => [_]. move: (lattice_inf_pr h1 Qx Qy); set (a:= inf r (Q x) (Q y)). move=> [l1 l2 l3]. have p1: (forall z, gle F z x -> gle F z y -> gle r (Q z) a). move=> z z1 z2; move: (orsum_gle_id oa z2). move: (orsum_gle_id oa z1); apply: l3. case: (equal_or_not (Q x) (Q y)) => sq. rewrite - sq in Py; rewrite sr in Qx Qy. case: (p_or_not_p (exists2 t, gle (Vg g (Q x)) t (P x) & gle (Vg g (Q x)) t (P y))). move=> [t l4 l5]; move: (h4 _ _ _ _ Qx l4 l5) => sd. move: (inf_pr (alo _ Qx) Px Py sd). set (z:= inf (Vg g (Q x)) (P x) (P y)); move => [z1 z2 z3]. have jZs: (inc (J z (Q x)) (substrate F)). rewrite sF; apply: disjoint_union_pi1 => //; order_tac. exists (J z (Q x)). apply: glb_set2. exact. apply/orsum_gleP;split => //;try ue;right; aw => //; ue. apply/orsum_gleP;split => //;try ue;right; aw => //; ue. move=> w /orsum_gleP [w0 _ w1 ] /orsum_gleP [_ _ w2]; apply /orsum_gleP; split => //; first by ue. case: w1; first by move => pa; left; aw. move => [pa pb];case: w2; first by move => pc; left; aw; ue. move => [pc pd]; right; aw;split => //; rewrite pa; apply: z3 => //; ue. move=> net. have aux: (forall t, inc t (Vg (fam_of_substrates g) (Q x) ) -> ~ (gle (Vg g (Q x)) t (P x) /\ gle (Vg g (Q x)) t (P y))). move=> t tVQ [ha hb]; case: net; exists t=>//. have Px': (inc (P x) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw. have Py': (inc (P y) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw. move: (h6 _ _ _ Qx Px' Py' aux) => [w [wdg lew [z [zs lez]]]]. set s:=(Zo (domain g) (fun k : Set => glt r k (Q x))) in lew. have Hc:sub s (substrate r) by rewrite sr; apply: Zo_S. move: lew; rewrite /greatest; aw; move=> [/Zo_hi lt0 lew]. have Js: (inc (J z w) (sum_of_substrates g)). apply: disjoint_union_pi1 => //. exists (J z w); apply: glb_set2. exact. apply /orsum_gleP; split => //; left;aw; ue. apply /orsum_gleP; split => //; left;aw; ue. move=> t /orsum_gleP [ts _ l4] /orsum_gleP [_ _ l5]. apply /orsum_gleP; split => //. move: (du_index_pr1 ts) => [Qt Pt pt]. case: (equal_or_not (Q t) w) => wq. by right; aw;split => //; rewrite wq;apply: lez; ue. left; aw;split => //; case: (p_or_not_p (glt r (Q t) (Q x))). move=> le3; apply: (iorder_gle1 (lew _ (Zo_i Qt le3))). move=> ltxt; case: l4; [ by move => r1 | move=> [r1 r2] ]. case: l5; rewrite - sq; [ by move => r3 | move=> [r3 r4] ]. have Pt': (inc (P t) (Vg (fam_of_substrates g) (Q x))). rewrite /fam_of_substrates; bw; ue. case: (aux _ Pt'); split => //; ue. rewrite sr in Qx Qy; move: (nesym sq) => sq'. move: (h2 _ _ Qx Qy) => h7. case: (equal_or_not (Q y) a) => Qya. exists y; rewrite set2_C;apply: inf_comparable=> //. apply /orsum_gleP;split => //; left; split => //; ue. case: (equal_or_not (Q x) a) => Qxa. exists x; apply: inf_comparable => //. apply /orsum_gleP;split => //; left; split => //; ue. case: h7=> h7'. have lyy: (gle r (Q x) (Q x)) by order_tac; ue. by case: Qxa; exact: (order_antisymmetry or (l3 _ lyy h7') l1). have lxx: (gle r (Q y) (Q y)) by order_tac; ue. case: Qya; exact: (order_antisymmetry or (l3 _ h7' lxx) l2). move: h7' => [u [v [lea geb]]]. rewrite -/a in geb; move: geb => [us leu]. have J3: (inc (J v a) (sum_of_substrates g)). apply: disjoint_union_pi1 => //; rewrite - sr; order_tac. exists (J v a); apply: glb_set2. exact. by apply /orsum_gleP;split => //;left;split;aw => //; apply:nesym. by apply /orsum_gleP;split => //;left;split;aw => //; apply:nesym. move=> t l5 l6; move: (p1 _ l5 l6). move: l5 l6 => /orsum_gleP [xsg tsg s1] /orsum_gleP [ysg _ s2] aQ. apply /orsum_gleP; split => //. case: (equal_or_not (Q t) a) => naQ; [right | left]; aw; last by split. split => //; rewrite naQ;apply: leu; rewrite -naQ. by move: (du_index_pr1 xsg) => [_]. Qed. End Exercise13b. (** ---- Exercise 1.4 : properties of the least equivalence extending [x] and [y] are not comparable (for the ordering [r], on the substrate of [r]). We denote by [ncr_equiv] the equivalence, by [ncr_component] the classes *) Definition not_comp_rel r := fun x y => [/\ inc x (substrate r), inc y (substrate r) & (x = y \/ ~ (ocomparable r x y))]. Definition ncr_equiv r := chain_equivalence (not_comp_rel r) (substrate r). Definition ncr_component r := connected_comp (not_comp_rel r) (substrate r). Lemma ncr_properties r: order r -> [/\ equivalence (ncr_equiv r), (substrate (ncr_equiv r) = substrate r), (forall x, inc x (substrate r) -> class (ncr_equiv r) x = ncr_component r x) & (forall x y, not_comp_rel r x y -> related (ncr_equiv r) x y)]. Proof. rewrite /ncr_equiv/ncr_component=> or. have ncre: forall x y, not_comp_rel r x y -> inc x (substrate r). by move=> x y [res _]. have ncr: (reflexive_re (not_comp_rel r) (substrate r)). move => x; split; [ by move => xsr; split => //; left | by apply: ncre]. have ncs:(symmetric_r (not_comp_rel r)). move=> x y [xsr ysr]; case => aux; split => //; [ by left | right]. by move => [] h; case: aux; [right | left]. move:(chain_equivalence_eq ncr ncs ncre) => [pa pb]. split => //. + by apply: connected_comp_class. + by move => x y rxy; apply: setF_pr0. Qed. (** Assume that a class is a union of two sets [a] and [b] such that every element of [a] is comparable to every element of [b]; then one of the two sets is empty, or the intersectpion is not empty. We deduce: if [x <= y] and [y] is equivalent to [y'] then [x <= y'] or [x] is equivalent to [y] *) Lemma Exercise1_4a1 r x y: order r -> inc x (substrate r) -> inc y (substrate r) -> ocomparable r x y \/ class (ncr_equiv r) x = class (ncr_equiv r) y. Proof. move => or xsr ysr. case: (p_or_not_p (ocomparable r x y)) =>h; [by left | right]. move:(ncr_properties or) => [p1 p2 p3 p4]. have: related (ncr_equiv r) x y by apply: p4; split => //; right. by move /(related_equiv_P p1) => [_ _]. Qed. Lemma Exercise1_4a2 r y: order r -> inc y (substrate r) -> forall a b, a \cup b = class (ncr_equiv r) y -> (forall u v, inc u a -> inc v b -> ocomparable r u v) -> [\/ a = emptyset, b = emptyset | nonempty (a \cap b)]. Proof. move=> or ysr a b uab h. case: (emptyset_dichot a)=> nea; first by apply: Or31. case: (emptyset_dichot b)=> neb; first by apply: Or32. move : nea neb (ncr_properties or) => [A Aa] [B Bb] [p1 p2 p3 p4]. have uc: classp (ncr_equiv r) (a \cup b). rewrite uab; apply: class_class => //; ue. have:(related (ncr_equiv r) A B). apply /(in_class_relatedP p1); exists (a \cup b); split;fprops. move /Zo_P; aw; move => [] /setXp_P [Asr Bsr] [x [xc hx tx]]. have ha: (inc (chain_head x) a) by ue. have tb: (inc (chain_tail x) b) by ue. clear hx tx; apply:Or33. have [u [v [ua vb uv]]]: exists u, exists v, [/\ inc u a, inc v b & (not_comp_rel r) u v]. elim:x xc ha tb => u v r1 r2 r3; first by exists u,v. move: r2 r3; simpl; move=> [r0 r2] r3 r4. case: (inc_or_not (chain_head v) a); first by move=> r5; apply: r1. have uu: inc u (a \cup b) by fprops. set (w := (chain_head v)). move=> nwa; exists u, w => //. suff: inc w (a \cup b) by case/setU2_P. apply: (rel_in_class2 p1 uc). move: (rel_in_class p1 uc uu) (p4 _ _ r0) => pa pb; equiv_tac. move: (h _ _ ua vb) uv => aux [_ _]; case => // cv. exists u; apply: setI2_i => // ; ue. Qed. Lemma Exercise1_4a3 r x y y': order r -> inc x (substrate r) -> related (ncr_equiv r) y y' -> gle r x y -> related (ncr_equiv r) x y \/ gle r x y'. Proof. move=> or xsr ryy' xy. move: (ncr_properties or) => [p1 p2 p3 p4]. set (C:= class (ncr_equiv r) y). set (A:=Zo C (fun z => gle r x z)). set (B:=Zo C (fun z => gle r z x)). have p5: (forall u v, inc u A -> inc v B -> gle r u v \/ gle r v u). move=> u v => /Zo_hi r1 /Zo_hi r2; right; order_tac. case: (p_or_not_p (related (ncr_equiv r) x y)); first by left. move=> nxy. have ysr: (inc y (substrate r)) by apply: (arg2_sr xy). have uc: (A \cup B = class (ncr_equiv r) y). set_extens t => ts; first by case /setU2_P: ts; move /Zo_P => []. have tsr: (inc t (substrate r)). rewrite -p2;apply: (sub_class_substrate p1 ts). case: (Exercise1_4a1 or xsr tsr). case; first by move=> c1;apply: setU2_1; apply: Zo_i. by move=> c2;apply: setU2_2; apply: Zo_i. move=> c3; case: nxy. apply /(class_P p1); rewrite c3; apply /(class_P p1). by apply: symmetricity_e =>//; apply /(class_P p1). have yC: inc y C by apply /(class_P p1);apply: reflexivity_e => //; ue. have yC': inc y' C by apply /(class_P p1). case: (Exercise1_4a2 or ysr uc p5) => h. + empty_tac1 y; apply: Zo_i => //. + move: yC'; rewrite /C -uc; case /setU2_P; first by move /Zo_hi => h'; right. by rewrite h=> /in_set0. + move: h => [z] /setI2_P [] /Zo_P [zC l1] /Zo_P [_ l2]; left. rewrite (order_antisymmetry or l1 l2). by apply: symmetricity_e => //; apply /(class_P p1). Qed. (** The equivalence relation is compatible with the order; and the quotient is totally ordered *) Lemma Exercise1_4b1 r x y x' y': order r -> related (ncr_equiv r) x x' -> related (ncr_equiv r) y y' -> class (ncr_equiv r) x <> class (ncr_equiv r) y -> gle r x y -> gle r x' y'. Proof. move=> or rxx' ryy' nsc xy. move: (ncr_properties or) => [p1 p2 p3 p4]. have xsr': (inc x' (substrate r)) by rewrite -p2; substr_tac. have ysr': (inc y' (substrate r)) by rewrite -p2; substr_tac. have xsr: (inc x (substrate r)) by rewrite -p2; substr_tac. have ysr: (inc y (substrate r)) by rewrite -p2; substr_tac. case: (Exercise1_4a1 or xsr' ysr'). case => // gle1. suff: related (ncr_equiv r) x y. by move /(related_equiv_P p1)=> [_ _ h]; case: nsc. case: (Exercise1_4a3 or xsr ryy' xy)=> // rxy'. have ex'x: (related (ncr_equiv r) x' x) by apply: symmetricity_e. case: (Exercise1_4a3 or ysr' ex'x gle1) => h. apply: (transitivity_e p1 rxx'); apply (symmetricity_e p1). apply: (transitivity_e p1 ryy' h). apply: (symmetricity_e p1). have -> //: x = y' by order_tac. move => sc; case: nsc; apply /(class_eq1 p1). apply: (transitivity_e p1 rxx'). have h: related (ncr_equiv r) x' y' by apply /(related_equiv_P p1); split => //; ue. by apply: (transitivity_e p1 h); apply: (symmetricity_e p1). Qed. Lemma Exercise1_4b r: order r -> total_order(quotient_order r (ncr_equiv r)). Proof. move => or. move: (ncr_properties or) => [p1 p2 p3 p4]. have sa:(substrate (quotient_order r (ncr_equiv r)) = quotient (ncr_equiv r)). rewrite substrate_quotient_order /preorder_quo_axioms; split => //. by apply order_preorder. have oq:(order (quotient_order r (ncr_equiv r))). apply: Exercise1_2d => // x y z xy yz xz. case: (p_or_not_p (related (ncr_equiv r) x y)) => // nxy. have yy: (related (ncr_equiv r) y y). by apply: reflexivity_e =>//; rewrite p2; order_tac. have nsc:(class (ncr_equiv r) x <> class (ncr_equiv r) y). dneg sc; apply: symmetricity_e =>//; apply /(related_equiv_P p1);split => //; rewrite p2; order_tac. move: (Exercise1_4b1 or xz yy nsc xy) => zy. rewrite (order_antisymmetry or yz zy) //. split => //. rewrite sa => x y xq yq. case: (equal_or_not x y) => nxy; first by rewrite nxy; left; order_tac; ue. move:(setQ_repi p1 xq) (setQ_repi p1 yq) => rx ry. have rxs: (inc (rep x) (substrate r)) by rewrite -p2; apply: rep_i_sr. have rys: (inc (rep y) (substrate r)) by rewrite -p2; apply: rep_i_sr. have nsc:class (ncr_equiv r) (rep x) <> class (ncr_equiv r) (rep y). by dneg bad; move: xq yq => /(setQ_P p1) [_ -> ] /(setQ_P p1) [_ -> ]. case: (Exercise1_4a1 or rxs rys); last by done. move:(related_rep_in_class p1) => H. case =>cv; [left | right]; apply /quotient_orderP; split => //. move=> u ux; exists (rep y) => //. exact: (Exercise1_4b1 or (H _ _ xq ux) (H _ _ yq ry) nsc cv). move=> u ux; exists (rep x) => //. exact: (Exercise1_4b1 or (H _ _ yq ux) (H _ _ xq rx) (nesym nsc) cv). Qed. (** Connected components of a product of two non-empty totally ordered sets. If one factor is a singleton, then the product is totally ordered, connected components are singletons; otherwise all elements of the product, with the possible exception of the greatest and least element form a connected component *) Lemma Exercise1_4c1 r x: order r -> greatest r x -> ncr_component r x = singleton x. Proof. move => or [xsr xge]. move: (ncr_properties or) => [p1 p2 p3 p4]. rewrite -(p3 _ xsr); apply set1_pr. apply /(class_P p1); apply: reflexivity_e => //; ue. have xt: forall t, not_comp_rel r t x -> t = x. by move => u [q1 q2 h]; case: h; [ move=> -> | case;left; apply: xge ]. move => z /(class_P p1) r1; move: (symmetricity_e p1 r1). move /Zo_P => [] /setXp_P; aw; move => _ [c [cc <- tc]]. move: c cc tc. elim => u v /=; first by move => h1 h2; rewrite h2 in h1; apply: (xt _ h1). by move=> h1 [h2 h3] h4; rewrite (h1 h3 h4) in h2; apply: xt. Qed. Lemma Exercise1_4c2 r x: order r -> least r x -> ncr_component r x = singleton x. Proof. move => or [xsr xge]. move: (ncr_properties or) => [p1 p2 p3 p4]. rewrite -(p3 _ xsr); apply set1_pr. apply /(class_P p1); apply: reflexivity_e => //; ue. have xt: forall t, not_comp_rel r t x -> t = x. by move => u [q1 q2 h]; case: h; [ move=> -> | case ; right; apply: xge]. move => z /(class_P p1) => r1; move: (symmetricity_e p1 r1). move /Zo_P => [] /setXp_P; aw; move => _ [c [cc <- tc]]. move: c cc tc. elim => u v; simpl; first by move => h1 h2; rewrite h2 in h1; apply: (xt _ h1). by move=> h1 [h2 h3] h4; rewrite (h1 h3 h4) in h2; apply: xt. Qed. Lemma tor_prop r: {inc substrate r &, forall x y , ocomparable r x y} -> forall x y, inc x (substrate r) -> inc y (substrate r) -> gle r x y \/ glt r y x. Proof. move=> tor x y xs ys; case: (tor _ _ xs ys); first by left. move=> aux; case:(equal_or_not x y) => h; first by left; move: aux;rewrite h. by right; split => //; apply:nesym. Qed. Lemma Exercise1_4c3 r r' x y: order r -> total_order r' -> substrate r = singleton x -> inc y (substrate r') -> ncr_component (order_product2 r r') (J x y) = singleton (J x y). Proof. move=> or [or' tr'] sr ysr'. set r'':= order_product2 r r'. have xsr: inc x (substrate r) by rewrite sr; fprops. have or'': order r'' by apply: order_product2_or. move: (ncr_properties or'') => [p1 p2 p3 p4]. have Jsr: inc (J x y) (substrate r'') by rewrite order_product2_sr; fprops. rewrite -(p3 _ Jsr). have lexx: gle r x x by order_tac. have pa: (substrate r \times substrate r') = substrate r''. by rewrite order_product2_sr. have xt: forall t, not_comp_rel r'' t (J x y) -> t = J x y. move => u [q1 q2 h]; case: h; first by move=> ->. move: (q1); rewrite -pa // sr; move => /setX_P [] pu /set1_P Pu Qu. case: (tr' _ _ Qu ysr'). by move=> h1 h2;case: h2; left; apply /order_product2_P; aw; rewrite pa Pu. by move=> h1 h2; case: h2; right; apply /order_product2_P; aw; rewrite pa Pu. set_extens t; last first. move /set1_P ->; apply /(class_P p1); apply: (reflexivity_e p1); ue. move /(class_P p1) => r1; apply /set1_P;move: (symmetricity_e p1 r1). move /Zo_hi; aw; move=> [c [cc <- tc]]; move: c cc tc. elim => u v; simpl; first by move => h1 h2; rewrite h2 in h1; apply: (xt _ h1). by move=> h1 [h2 h3] h4; rewrite (h1 h3 h4) in h2; apply: xt. Qed. Lemma Exercise1_4c4: forall r r' b c b' c' u, total_order r -> total_order r' -> glt r b c -> glt r' b' c' -> inc u (substrate (order_product2 r r')) -> [\/ least (order_product2 r r') u, greatest (order_product2 r r') u | inc u (ncr_component (order_product2 r r') (J b c'))]. Proof. move=>r r' b c b' c' w [or tor] [or' tor'] ltbc ltbc' us. set r'' := (order_product2 r r'). have or'': order r'' by apply: order_product2_or. move: (ncr_properties or'') => [p1 p2 p3 p4]. have sr'': substrate r'' = (substrate r) \times (substrate r'). rewrite /r'' order_product2_sr //. have bs:inc b (substrate r) by order_tac. have bs':inc b' (substrate r') by order_tac. have cs:inc c (substrate r) by order_tac. have cs':inc c' (substrate r') by order_tac. set C:= (ncr_component r'' (J b c')). have Jas: inc (J b c') (substrate r'') by rewrite sr''; apply /setXp_P. have Jbs: inc (J c b') (substrate r'') by rewrite sr''; apply /setXp_P. have p5: forall x y, not_comp_rel r'' x y -> inc y C -> inc x C. move=> x y h1; rewrite /C -p3 //; move /(class_P p1) => h2. apply /(class_P p1) /(transitivity_e p1 h2 (symmetricity_e p1 (p4 _ _ h1))). have p6: forall x y, not_comp_rel r'' x y -> inc x C -> inc y C. move=> x y h xC;apply: (p5 _ _ _ xC); move: h => [r1 r2 r3]; split => //. case: r3 ; first by move => ->; left. move => h; right => h1; case: h; by case: h1 => h1; [right | left]. have np1: forall u v u' v', glt r u v -> glt r' u' v' -> not_comp_rel r'' (J u v') (J v u'). move => u v u' v' uv uv'; split => //. + rewrite sr''; aw; apply: setXp_i; order_tac. + rewrite sr''; aw; apply: setXp_i; order_tac. + right; case; move / order_product2_P => [_ _] []; aw =>[b1 b2]; order_tac. have JaC: inc (J b c') C by rewrite /C -p3 //; apply /(class_P p1);apply: reflexivity_e => //; ue. have JbC: inc (J c b') C by apply: (p6 _ _ (np1 _ _ _ _ ltbc ltbc') JaC). have p7: forall u, glt r u c -> inc (J u c') C. move=> u u1; by apply: (p5 _ _ (np1 _ _ _ _ u1 ltbc') JbC). have p8: forall u, glt r b u -> inc (J u b') C. move=> u u1; by apply: (p6 _ _ (np1 _ _ _ _ u1 ltbc') JaC). have p9: forall v, glt r' v c' -> inc (J c v) C. move=> v v1; by apply: (p6 _ _ (np1 _ _ _ _ ltbc v1) JaC). have p10: forall v, glt r' b' v -> inc (J b v) C. move=> v v1; by apply: (p5 _ _ (np1 _ _ _ _ ltbc v1) JbC). case:(p_or_not_p(exists2 x, inc x (substrate r'') & ~ gle r'' w x)); last first. move => bad; apply: Or31; split => //; move=> x xsr. case: (p_or_not_p (gle r'' w x)) => // bad1; case: bad; ex_tac. move=> [pt ptr ptc]. case:(p_or_not_p(exists2 x, inc x (substrate r'') & ~ gle r'' x w)); last first. move => bad; apply: Or32; split => //; move=> x xsr. case: (p_or_not_p (gle r'' x w)) => // bad1;case: bad; ex_tac. move=> [gr grr grc]. apply: Or33. have ptd: ~(gle r (P w) (P pt) /\ gle r' (Q w) (Q pt)). move=> [h1 h2]; move: ptc => /order_product2_P; case; split => //; ue. have grd: ~(gle r (P gr) (P w) /\ gle r' (Q gr) (Q w)). move=> [h1 h2]; move: grc => /order_product2_P; case;split => //; ue. move: grr ptr us; rewrite /r'' order_product2_sr//. move=> /setX_P [pgr Pgr Qgr] /setX_P [ppt Ppt Qpt] /setX_P [pw Pw Qw]. move: (tor_prop tor)(tor_prop tor') => to to'. case: (to _ _ Pw bs)=> q1. case: (to' _ _ Qw bs') => q2. case: (to _ _ Pw Ppt)=> q3. case: (to' _ _ Qw Qpt) => q4; first by case: ptd; split => //. have q5: glt r' (Q w) c' by order_tac. have q6: glt r' (Q pt) c' by order_tac. move: (p9 _ q6) => q7. have q8: glt r (P w) c by order_tac. by move: (p5 _ _ (np1 _ _ _ _ q8 q4) q7); rewrite pw. have q5: (glt r (P w) c) by order_tac. have q6: (glt r (P pt) c) by order_tac. move: (p7 _ q6) => q7. have q8: glt r' (Q w) c' by order_tac. by move: (p6 _ _ (np1 _ _ _ _ q3 q8) q7); rewrite pw. move: (p10 _ q2) => q3. have q5: glt r (P w) c by order_tac. move: (p7 _ q5) => q6. case: (equal_or_not (P w) b) => q4. by move: q3; rewrite -q4 pw. have q7: glt r (P w) b by split. move: (p6 _ _ (np1 _ _ _ _ q7 ltbc') q6) => q8. by move: (p5 _ _ (np1 _ _ _ _ q7 q2) q8); rewrite pw. case: (to _ _ cs Pw)=> q1'. case: (to' _ _ cs' Qw) => q2. case: (to _ _ Pgr Pw)=> q3. case: (to' _ _ Qgr Qw) => q4; first by case: grd; split => //. have q5: (glt r' b' (Q w)) by order_tac. have q6: (glt r' b' (Q gr)) by order_tac. move: (p10 _ q6) => q7. have q8: glt r b (P w) by order_tac. by move: (p6 _ _ (np1 _ _ _ _ q8 q4) q7); rewrite pw. have q5: (glt r b (P w)) by order_tac. have q6: (glt r b (P gr)) by order_tac. move: (p8 _ q6) => q7. have q8: glt r' b' (Q w) by order_tac. by move: (p5 _ _ (np1 _ _ _ _ q3 q8) q7); rewrite pw. move: (p9 _ q2) => q3. have q5: glt r b (P w) by order_tac. move: (p8 _ q5) => q6. case: (equal_or_not (P w) c) => q4. by move: q3; rewrite -q4; rewrite pw. have q7: glt r c (P w) by split => //; apply:nesym. move: (p5 _ _ (np1 _ _ _ _ q7 ltbc') q6) => q8. by move: (p6 _ _ (np1 _ _ _ _ q7 q2) q8); rewrite pw. move: (p7 _ q1') (p8 _ q1)=> q1'' q2. case: (to' _ _ Qw bs') => q3; last first. by move:(p5 _ _ (np1 _ _ _ _ q1' q3) JbC); rewrite pw. case: (to' _ _ cs' Qw) => q4; last first. by move:(p6 _ _ (np1 _ _ _ _ q1 q4) JaC); rewrite pw. have q5: (gle r' c' b') by order_tac. order_tac. Qed. (** ---- Exercise 1.5: free subsets. A set is free if it contains no two comparable elements; two free subsets can be compared *) Definition free_subset r X := forall x y, inc x X -> inc y X -> gle r x y -> x = y. Definition free_subsets r:= Zo (powerset (substrate r)) (free_subset r). Definition free_subset_compare r X Y:= [/\ inc X (free_subsets r), inc Y (free_subsets r) & forall x, inc x X -> exists2 y, inc y Y & gle r x y]. Definition free_subset_order r:= graph_on (free_subset_compare r) (free_subsets r). Lemma Exercise1_5w r x a: order r -> inc x (free_subsets r) -> inc a x -> gle r a a. Proof. by move=> or xr ax; order_tac;move: xr => /Zo_P [] /setP_P xsr _; apply: xsr. Qed. Lemma Exercise1_5a r: order r -> order_r (free_subset_compare r). Proof. move=> or; rewrite /free_subset_compare; split. + move=> x y z [xs ys p1][_ zs p2]; split => //. move=> a ax; move: (p1 _ ax) => [b biy l1]; move: (p2 _ biy) => [c cy l2]. ex_tac; order_tac. + move=> x y [/Zo_P [_ fs1] /Zo_P [_ fs2] p1] [_ _ p2]. set_extens t => ts. move: (p1 _ ts) => [z zy le1]; move:(p2 _ zy) => [w wx le2]. move: (fs1 _ _ ts wx (order_transitivity or le1 le2)) => eq1. by rewrite -eq1 in le2;rewrite (order_antisymmetry or le1 le2). move: (p2 _ ts)=> [z zy le1]; move: (p1 _ zy)=> [w wx le2]. move: (fs2 _ _ ts wx (order_transitivity or le1 le2)) => eq1. by rewrite -eq1 in le2; rewrite (order_antisymmetry or le1 le2). + move=> x y [xs ys p1]; split => //; split =>//a ax; ex_tac; [apply: (Exercise1_5w or xs ax) | apply: (Exercise1_5w or ys ax) ]. Qed. Lemma fs_order_gleP r x y: gle (free_subset_order r) x y <-> free_subset_compare r x y. Proof. split; first by move /Zo_hi; aw. by move =>h; apply: Zo_i; aw; move: h => [pa pb _]; apply :setXp_i. Qed. Lemma fs_order_osr r: order r -> order_on (free_subset_order r) (free_subsets r). Proof. move=> or; red;rewrite /free_subset_order graph_on_sr //. split => //; apply: order_from_rel; apply: Exercise1_5a =>//. move => a ax; split => // t ts;ex_tac; apply: (Exercise1_5w or ax ts). Qed. Lemma Exercise1_5b r x: order r -> inc x (substrate r) -> inc (singleton x) (free_subsets r). Proof. move=> or xsr; apply: Zo_i; first by apply /setP_P; apply: set1_sub. by move=> u v /set1_P -> /set1_P ->. Qed. Lemma Exercise1_5cP r x y: order r -> inc x (substrate r) -> inc y (substrate r) -> (gle r x y <-> gle (free_subset_order r) (singleton x) (singleton y)). Proof. move => or xsr ysr. split. move => lxy; apply /fs_order_gleP; split => //; try apply: Exercise1_5b => //. move => u /set1_P ->; exists y; fprops. by move /fs_order_gleP => [_ _ rxy];move:(rxy _ (set1_1 x)) => [z] /set1_P ->. Qed. Lemma Exercise1_5d r: order r -> order_morphism (Lf singleton (substrate r) (free_subsets r)) r (free_subset_order r). Proof. move=> or. have tf: (lf_axiom singleton (substrate r) (free_subsets r)). by move=> x xsr; apply: Exercise1_5b. have [pa pb] :=(fs_order_osr or). split => //; first by split;aw => //; apply: lf_function. hnf;aw;move=> x y xsr ysr;aw;apply: (Exercise1_5cP or xsr ysr). Qed. (** The set of free subsets is totally ordered if and only if the set itself is totally ordered *) Lemma Exercise1_5e r X: total_order r -> inc X (free_subsets r) -> small_set X. Proof. move=> [_ t] /Zo_P [] /setP_P xs fs x y xX yX. by case: (t _ _ (xs _ xX) (xs _ yX)) => aux; [ | symmetry ]; apply: fs. Qed. Lemma Exercise1_5f r X Y: order r -> inc X (free_subsets r) -> inc Y (free_subsets r) -> sub X Y -> gle (free_subset_order r) X Y. Proof. move=> or Xsf Ysf XY; apply /fs_order_gleP; split => //. move=> x xX;move: (XY _ xX) => xY; ex_tac; apply: (Exercise1_5w or Ysf xY). Qed. Lemma Exercise1_5g r: total_order r -> total_order (free_subset_order r). Proof. move=> tor; move: (tor)=> [or tr]. have [pa pb] := (fs_order_osr or). split => //; rewrite pb => x y xsf ysf. have ef: (inc emptyset (free_subsets r)). apply: Zo_i; [ by apply:setP_0i | by move=> u _y /in_set0 ]. move: (Exercise1_5e tor xsf) (Exercise1_5e tor ysf) => sx sy. case: (emptyset_dichot x) => xe. rewrite xe; left; apply:Exercise1_5f; fprops. case: (emptyset_dichot y) => ye. rewrite ye; right; apply: Exercise1_5f; fprops. move: xe ye => [X Xx] [Y Yiy]. move: xsf ysf => /Zo_P [] /setP_P xsr _/Zo_P [] /setP_P ysr _. move: (xsr _ Xx)(ysr _ Yiy) => Xsr Ysr. have ->: (x = singleton X) by apply: set1_pr => // t tx; apply: sx. have ->: (y = singleton Y) by apply: set1_pr => // t tx; apply: sy. by case: (tr _ _ Xsr Ysr) => h; [left | right]; apply/(Exercise1_5cP or). Qed. Lemma Exercise1_5h r: order r -> total_order (free_subset_order r) -> total_order r. Proof. move=> or tor; split => // x y xsr ysr. move: tor => [_]; rewrite (proj2 (fs_order_osr or)) => h. by case: (h _ _ (Exercise1_5b or xsr) (Exercise1_5b or ysr)) => h1; [left | right];apply/Exercise1_5cP. Qed. (** ---- Exercise 1.6: Ordering of increasing mappings *) (** Let [r], [r'] and [r''] be orderings on [E], [F] and [G], let [K(E,F)] be the set of mappings [E->F] and let [A(E,F)] be the set of increasing mappings [E->F]. We first show that [K(E,FxG)] is equipotent to [K(E,F) x K(E,G)] and this induces a bijection from [A(E,FxG)] onto [A(E,F) x A(E,G)] which is an order isomorphism *) Definition increasing_mappings r r' := Zo (functions (substrate r) (substrate r')) (fun z=> increasing_fun z r r'). Definition increasing_mappings_order r r' := induced_order (order_function (substrate r) (substrate r') r') (increasing_mappings r r'). Definition first_projection f:= Lf (fun z=> P (Vf f z)). Definition secnd_projection f:= Lf (fun z=> Q (Vf f z)). Definition two_projections a b c := Lf (fun z => (J (first_projection z a b) (secnd_projection z a c))) (functions a (b \times c)) ((functions a b) \times (functions a c)). Definition two_projections_increasing r r' r'' := restriction2 (two_projections (substrate r) (substrate r')(substrate r'')) (increasing_mappings r (order_product2 r' r'')) ( (increasing_mappings r r') \times (increasing_mappings r r'')). Definition second_partial_map2 r r' r'':= Lf (fun f=> restriction2 (second_partial_function f) (substrate r) (increasing_mappings r' r'')) (increasing_mappings (order_product2 r r') r'') (increasing_mappings r (increasing_mappings_order r' r'')). Lemma Exercise1_6a f a b c: function f -> source f = a -> target f = b \times c -> [/\ lf_axiom (fun z=> P (Vf f z)) a b, lf_axiom (fun z=> Q (Vf f z)) a c, function (first_projection f a b), function (secnd_projection f a c) & (forall x, inc x a -> Vf (first_projection f a b) x = P (Vf f x)) /\ (forall x, inc x a -> Vf (secnd_projection f a c) x = Q (Vf f x))]. Proof. move=> ff sf tf. have ta: lf_axiom (fun z=> P (Vf f z)) a b. rewrite - sf ;move=> t /(Vf_target ff). by rewrite tf; move => /setX_P []. have tb: lf_axiom (fun z=> Q (Vf f z)) a c. rewrite - sf;move=> t /(Vf_target ff). by rewrite tf ; move => /setX_P []. rewrite /first_projection /secnd_projection. split => //;try (apply: lf_function => //); split; move=> x xa;aw. Qed. Lemma Exercise1_6b a b c: lf_axiom (fun z => (J (first_projection z a b) (secnd_projection z a c))) (functions a (b \times c)) ((functions a b) \times (functions a c)). Proof. move=> t /functionsP [ft st tt]. move: (Exercise1_6a ft st tt)=> [_ _ fa fb _]. apply: setXp_i; apply /functionsP;split => //; rewrite /first_projection /secnd_projection; aw. Qed. Lemma Exercise1_6c a b c: bijection (two_projections a b c). Proof. move: (Exercise1_6b (a:=a) (b:=b)(c:=c)) => ta. rewrite /two_projections; apply: lf_bijective => //. move=> u v /functionsP [fu su tu] /functionsP [fv sv tv] h. move: (pr1_def h)(pr2_def h) => sfp ssp. apply: function_exten=> //; try ue;rewrite su. move=> x xa; move: (Exercise1_6a fu su tu) (Exercise1_6a fv sv tv). move=> [h1 h2 h3 h4 [h5 h6]][h7 h8 h9 h10 [h11 h12]]. have /setX_P [<- _ _]: (inc (Vf u x)(b \times c)) by rewrite -tu; Wtac. have /setX_P [<- _ _] : (inc (Vf v x)(b \times c)) by rewrite -tv; Wtac. rewrite -(h5 _ xa) - (h11 _ xa) sfp -(h6 _ xa) - (h12 _ xa) ssp //. move=> y /setX_P [yp] /functionsP [fp sp tp] /functionsP [fq sq tq]. set (f:= Lf (fun z=> J (Vf (P y) z) (Vf (Q y) z)) a (b \times c)). have tb: (lf_axiom (fun z=> J (Vf (P y) z) (Vf (Q y) z)) a (b \times c)). move=> z za; apply /setXp_i; [rewrite -tp|rewrite -tq]; Wtac. have ff:(function f) by apply: lf_function => //. have sf: (source f = a) by rewrite /f; aw. have tf: (target f = b \times c) by rewrite /f; aw. move: (Exercise1_6a ff sf tf) => [h1 h2 h3 h4 [h5 h6]]. exists f => //; first by apply /functionsP. rewrite - yp; congr J; apply: function_exten; rewrite / first_projection /secnd_projection; aw; [rewrite sp | rewrite sq ]; move=> x xsr /=; rewrite lf_V // /f lf_V //; aw. Qed. Section Exercise1_6a. Variables r r': Set. Hypotheses (or: order r)(or': order r'). Lemma soimP f: inc f (increasing_mappings r r') <-> ((function_prop f (substrate r) (substrate r')) /\ increasing_fun f r r'). Proof. split; first by move /Zo_P => [] /functionsP. by move => [pa pd]; apply: Zo_i => //; apply /functionsP. Qed. Lemma imo_osr: order_on (increasing_mappings_order r r') (increasing_mappings r r'). Proof. move: (order_function_osr (substrate r) or'(erefl (substrate r'))) => [pa pb]. apply:(iorder_osr pa); rewrite pb; apply: Zo_S. Qed. Lemma imo_gleP f g: gle (increasing_mappings_order r r') f g <-> [/\ inc f (increasing_mappings r r'), inc g (increasing_mappings r r') & order_function_r (substrate r) (substrate r') r' f g]. Proof. rewrite /increasing_mappings_order;split. move: imo_osr => [or''' sr0] le1. move: (arg1_sr le1) (arg2_sr le1); rewrite sr0 => sr1 sr2. by split => //; move: (iorder_gle1 le1) => /graph_on_P1 [_ _]. move=> [h1 h2 h3]; apply /(iorder_gleP _ h1 h2) /graph_on_P1. by move: h1 h2 => /Zo_S h1 /Zo_S h2. Qed. Lemma imo_incr f g: gle (increasing_mappings_order r r') f g -> forall i : Set, inc i (substrate r) -> gle r' (Vf f i) (Vf g i). Proof. by move /imo_gleP => [_ _ [_ _]]. Qed. End Exercise1_6a. Section Exercise1_6. Variables r r' r'': Set. Hypotheses (or: order r)(or': order r')(or'': order r''). Let E := substrate r. Let F := substrate r'. Let G := substrate r''. Lemma Exercise1_6d f: increasing_fun f r (order_product2 r' r'') -> (increasing_fun (first_projection f E F) r r' /\ increasing_fun (secnd_projection f E G) r r''). Proof. move=> [_ op [ff sr sor] icf]. rewrite order_product2_sr // in sor. move: (Exercise1_6a ff sr sor) => [taP taQ fP fQ [WP WQ]]. rewrite /E/increasing_fun /first_projection/secnd_projection; split;aw. split => //; [split; aw | move=> x y xy; aw; try order_tac]. by move: (icf _ _ xy) => /order_product2_P [_ _ ][]. split => //; [split; aw | move=> x y xy; aw; try order_tac]. by move: (icf _ _ xy) => /order_product2_P [_ _ ][]. Qed. Lemma Exercise1_6e: (restriction2_axioms (two_projections E F G) (increasing_mappings r (order_product2 r' r'')) ((increasing_mappings r r') \times (increasing_mappings r r''))). Proof. move: (Exercise1_6c E F G) (Exercise1_6b (a:=E)(b:=F) (c:=G)) => bt t1. split => //. + fct_tac. + rewrite lf_source /increasing_mappings order_product2_sr //;apply: Zo_S. + rewrite lf_target; apply: setX_Slr; apply: Zo_S. + move: (bij_function bt) => ff. have pa: (sub (increasing_mappings r (order_product2 r' r'')) (source (two_projections E F G))). by move => t; rewrite lf_source => /Zo_S; rewrite order_product2_sr. move=> t /(Vf_image_P ff pa) [u /Zo_P []]. rewrite order_product2_sr //; move=> aux. move: (aux) => /functionsP [fu su tu]. move: (Exercise1_6a fu su tu) => [_ _ p1 p2 _] uinc. move: (Exercise1_6d uinc) => [i1 i2] ->. by rewrite - /two_projections lf_V //; apply: setXp_i => //; apply : Zo_i => //; apply /functionsP; hnf; rewrite lf_source lf_target. Qed. Lemma Exercise1_6f: bijection (two_projections_increasing r r' r''). Proof. move: (Exercise1_6e) (Exercise1_6c E F G) => ra [fi fs]. have tpi:=(restriction2_fi fi ra). split; [ exact | split; first by fct_tac ]. move: ra => [ftp sstp sttp saux]. rewrite corresp_t => y yt. move: ((proj2 fs) _ (sttp _ yt)) => [x]; rewrite lf_source => xsf wx. suff xs1: (inc x (increasing_mappings r (order_product2 r' r''))). rewrite corresp_s; ex_tac; rewrite restriction2_V //. apply: Zo_i => //; first by rewrite order_product2_sr. move: (xsf) => /functionsP [fx sx tx]. move: (Exercise1_6a fx sx tx) => [p1 p2 p3 p4 [p5 p6]]. split => //. apply: order_product2_or => //. rewrite order_product2_sr //. move=> u v uv; apply /order_product2_P. have us: (inc u E) by rewrite /E;order_tac. have vs: (inc v E) by rewrite /E;order_tac. rewrite -tx. move: (Exercise1_6b (a:=E)(b:=F) (c:=G)) => t1. move: wx; rewrite /two_projections lf_V // => aux. move:(f_equal P aux) (f_equal Q aux); aw => q1 q2. rewrite -(p5 _ us) -(p5 _ vs) -(p6 _ us) -(p6 _ vs) q1 q2. move: yt => /setX_P [_ ] /soimP [_ [_ _ _ ip]] /soimP [_ [_ _ _ iq]]. split;[ Wtac | Wtac | split; [ apply: (ip _ _ uv) | apply: (iq _ _ uv) ] ]. Qed. Lemma Exercise1_6g: order_isomorphism (two_projections_increasing r r' r'') (increasing_mappings_order r (order_product2 r' r'')) (order_product2 (increasing_mappings_order r r') (increasing_mappings_order r r'')). Proof. have orp: order (order_product2 r' r'') by apply: order_product2_or. move: (imo_osr r or') (imo_osr r or'') => [o1 sr1] [o2 sr2]. move: (imo_osr r orp) => [o3 sr3]. split => //; first by apply: order_product2_or => //. split => //. + by apply: Exercise1_6f => //. + by rewrite /two_projections_increasing /restriction2 sr3; aw. + by rewrite order_product2_sr // sr1 sr2 corresp_t. hnf;rewrite corresp_s => x y xsi ysi. move: (xsi) (ysi)=> /(soimP) [[fx sx tx] ix] /(soimP) [[fy sy ty] iy]. move: (Exercise1_6b (a:=E) (b:=F)(c:=G)) => t1. move: (Exercise1_6e) => ra. rewrite restriction2_V // restriction2_V //. rewrite order_product2_sr // in tx ty. move: (Exercise1_6a fx sx tx) => [p1 p2 p3 p4 [p5 p6]]. move: (Exercise1_6a fy sy ty) => [q1 q2 q3 q4 [q5 q6]]. move: ra => []; rewrite lf_source => ftp sstp sttp saux. move: (sstp _ xsi) (sstp _ ysi) => xsi' ysi'. rewrite /two_projections lf_V // lf_V //. move: (Exercise1_6d ix) (Exercise1_6d iy). move: p3 p4 p5 p6 q3 q4 q5 q6. set (f1 := first_projection x E F). set (f2 := secnd_projection x E G). set (f3 := first_projection y E F). set (f4 := secnd_projection y E G). move=> p3 p4 p5 p6 q3 q4 q5 q6 [if1 if2][if3 if4]. split; last first. move /order_product2_P => [_ _[] ];rewrite ! pr1_pair ! pr2_pair. move /(imo_gleP r or') => [Sf1 Sf3 if13]/(imo_gleP r or'') [Sf2 Sf4 if24]. apply /(imo_gleP r orp);rewrite order_product2_sr //;split => //; split => //. move=> i isr; apply /order_product2_P; rewrite - {1} tx -ty. rewrite -(q5 _ isr) - (q6 _ isr) -(p5 _ isr) - (p6 _ isr). move: if13 if24 => [_ _ s1] [_ _ s2]. split; [ Wtac | Wtac | split; fprops]. move => xx; move: (imo_incr orp xx) => h3. move /(imo_gleP r orp):xx => [h1 h2 _]. apply /order_product2_P; rewrite sr1 sr2. have sf1: (source f1 = E) by rewrite /f1 /first_projection; aw. have sf2: (source f2 = E) by rewrite /f2 /secnd_projection; aw. have sf3: (source f3 = E) by rewrite /f3 /first_projection; aw. have sf4: (source f4 = E) by rewrite /f4 /secnd_projection; aw. have tf1: (target f1 = F) by rewrite /f1 /first_projection; aw. have tf2: (target f2 = G) by rewrite /f2 /secnd_projection; aw. have tf3: (target f3 = F) by rewrite /f3 /first_projection; aw. have tf4: (target f4 = G) by rewrite /f4 /secnd_projection; aw. have Sf1: (inc f1 (increasing_mappings r r')) by apply /soimP. have Sf2: (inc f2 (increasing_mappings r r'')) by apply /soimP. have Sf3: (inc f3 (increasing_mappings r r')) by apply /soimP. have Sf4: (inc f4 (increasing_mappings r r'')) by apply /soimP. split; [by apply setXp_i | by apply setXp_i | aw; split]. apply /(imo_gleP r or');split => //; split => //. move=> i isr; rewrite (p5 _ isr) (q5 _ isr). by move: (h3 _ isr) => /order_product2_P [_ _ []]. apply /(imo_gleP r or'');split => //; split => //. move=> i isr; rewrite (p6 _ isr) (q6 _ isr). by move: (h3 _ isr) => /order_product2_P [_ _ []]. Qed. (** We show that [A(ExF,G)] is isomorphic to [A(E, A (F,G))] *) Lemma Exercise1_6h f: nonempty E -> nonempty F -> increasing_fun f (order_product2 r r') r'' -> ( (domain (source f)) = E /\ (range (source f)) = F). Proof. move=> ne1 ne2;move=> [_ _ [_ sf _ ] _]. move: sf; rewrite order_product2_sr//. move ->; rewrite (setX_domain _ ne2)(setX_range _ ne1); split => //. Qed. Lemma Exercise1_6i f x: nonempty E -> nonempty F -> increasing_fun f (order_product2 r r') r'' -> inc x E -> increasing_fun (second_partial_fun f x) r' r''. Proof. move=> ne1 ne2 incf xsr. move: (Exercise1_6h ne1 ne2 incf) => [dsf rsf]. move: incf => [op or''' [ff sf tf] incf]. move: sf; rewrite order_product2_sr // => sf. have pfa: (partial_fun_axiom f) by split; [ exact |rewrite sf ; exists E, F]. move: (xsr);rewrite -dsf; move => xsr'. move: (spf_f pfa xsr') => spf. split => //; [by split => //; rewrite /second_partial_fun; aw | move=> u v uv]. have us: (inc (J x u) (source f)). by rewrite sf; apply : setXp_i => //; order_tac. have vs: (inc (J x v) (source f)) by rewrite sf; apply : setXp_i => //; order_tac. have ur: inc u (range (source f)) by rewrite rsf /F; order_tac. have vr: inc v (range (source f)) by rewrite rsf /F; order_tac. rewrite spf_V // spf_V //; apply: incf. by apply/order_product2_P; aw; rewrite - sf;split => //; split => //;order_tac. Qed. Lemma Exercise1_6j f: nonempty E -> nonempty F -> increasing_fun f (order_product2 r r') r'' -> (restriction2_axioms (second_partial_function f) E (increasing_mappings r' r'')). Proof. move=> ne1 ne2 incf. move: (Exercise1_6h ne1 ne2 incf) => [dsf rsf]. move: (incf) => [op or''' [ff sf tf] icf]. move: sf; rewrite order_product2_sr // => sf. have pfa: (partial_fun_axiom f) by split; [ exact |rewrite sf ; exists E,F]. move: (spfa_f pfa) => spfa. split => //. rewrite lf_source dsf; fprops. rewrite lf_target rsf /increasing_mappings -tf; apply: Zo_S. have aa: sub E (source (second_partial_function f)). rewrite lf_source dsf; fprops. move=> t /(Vf_image_P spfa aa) [x xsr ->]. move: (Exercise1_6i ne1 ne2 incf xsr) => h. move: (xsr);rewrite -dsf => xsr'; move: (spf_f pfa xsr') => spf. rewrite (lf_V (spfa_axiom pfa) xsr'); apply /soimP; split => //. by hnf; rewrite lf_source lf_target. Qed. Lemma Exercise1_6k: nonempty E -> nonempty F -> lf_axiom (fun f=> restriction2 (second_partial_function f) E (increasing_mappings r' r'')) (increasing_mappings (order_product2 r r') r'') (increasing_mappings r (increasing_mappings_order r' r'')). Proof. move=> ne1 ne2. have o1: order (order_product2 r r') by apply: order_product2_or. move: (imo_osr r' or'') => [o2 sr2]. move=> t /soimP [[ft st tt] int]. move: (Exercise1_6j ne1 ne2 int) => ra. move: (Exercise1_6h ne1 ne2 int) => [dst rst]. move: st; rewrite order_product2_sr // => st. have pfa: (partial_fun_axiom t) by split; [ exact |rewrite st; exists E, F]. set g:= restriction2 _ _ _. have fg: function g by rewrite /g; apply: (proj31(restriction2_prop ra)). have sg: source g = E by rewrite /g /restriction2; aw. have tg: target g = substrate (increasing_mappings_order r' r''). rewrite sr2 /g /restriction2; aw. apply /soimP; split => //; split => //. move => x y xy. have xsr: (inc x E) by rewrite /E; order_tac. have ysr: (inc y E) by rewrite /E; order_tac. move: (xsr)(ysr); rewrite -dst => xsr' ysr'. rewrite /g restriction2_V // restriction2_V // spfa_V // spfa_V //. apply /imo_gleP => //. move:(Exercise1_6i ne1 ne2 int xsr)(Exercise1_6i ne1 ne2 int ysr). move=> inc1 inc2; move: (inc1)(inc2). move => [_ _ [fsx ssx tsx] isx] [_ _ [fsy ssy tsy] isy]. split; [ by apply /soimP | by apply /soimP | split => //]. rewrite -/F - rst; move=> i isr'; rewrite spf_V // spf_V //. rewrite rst in isr'. have Js: (inc (J x i) (source t)) by rewrite st; apply /setXp_i. have Js': (inc (J y i) (source t)) by rewrite st; apply /setXp_i. move: int => [_ _ _]; apply. apply /order_product2_P;split => //; aw; try apply /setXp_i => //. split => //; order_tac => //;ue. Qed. Lemma Exercise1_6l: nonempty E -> nonempty F -> bijection_prop (second_partial_map2 r r' r'' ) (increasing_mappings (order_product2 r r') r'') (increasing_mappings r (increasing_mappings_order r' r'')). Proof. move=> ne1 ne2. rewrite /second_partial_map2;split; aw. have op:=(order_product2_or or or'). have sop:=(order_product2_sr or or'). apply: lf_bijective. by apply: Exercise1_6k. move=> u v /soimP [[fu su tu] iu] /soimP [[fv sv tv] iv] sr. apply: function_exten => //; try ue. move: su sv; rewrite sop -/E -/F => su sv x xsu. have pfau: (partial_fun_axiom u) by split;[exact |rewrite su; exists E,F]. have pfav: (partial_fun_axiom v) by split;[exact |rewrite sv; exists E,F]. move: (Exercise1_6h ne1 ne2 iu) => [dsu rsu]. move: (Exercise1_6h ne1 ne2 iv) => [dsv rsv]. have ssp: (second_partial_function u = second_partial_function v). apply: function_exten. + by apply: spfa_f. + by apply: spfa_f. + by rewrite /second_partial_function; aw; ue. + by rewrite /second_partial_function; aw; rewrite rsu rsv tu tv //. + move=> a; rewrite lf_source dsu=> au. transitivity (Vf (restriction2 (second_partial_function u) E (increasing_mappings r' r'')) a); [ | rewrite sr]; rewrite restriction2_V //; apply: Exercise1_6j => //. move: (xsu); rewrite su; move /setX_P; rewrite -dsu -rsu; move=> [px Ps Qr]. move: (spfa_V pfau Ps) (spf_V pfau Ps Qr); rewrite px => <- <-. rewrite dsu -dsv in Ps; rewrite rsu -rsv in Qr. move: (spfa_V pfav Ps) (spf_V pfav Ps Qr); rewrite px => <- <-; ue. move: (imo_osr r' or'') => [o2 sr2]. move=> y /soimP [[fy sy ty] incy]. have ta: (lf_axiom (fun z => Vf (Vf y (P z)) (Q z) ) (E \times F) G). move => t /setX_P; rewrite /E - sy; move=> [prt Pt Qt]. move: (Vf_target fy Pt); rewrite ty sr2 /G //. move /soimP => [[fw sw <-] _]; Wtac; ue. set (g:= Lf (fun z => Vf (Vf y (P z)) (Q z) ) (E \times F) G). have fg: function g by apply: lf_function. have ig: (increasing_fun g (order_product2 r r') r''). split => //; first by split;[done | rewrite /g; aw | rewrite /g; aw ]. move=> u v uv. move: uv => /order_product2_P [us vs [le1 le2]]. rewrite /g lf_V // lf_V //. move: us vs; rewrite - sy => /setX_P [pu Pu Qu] /setX_P [pv Pv Qv]. move: (Vf_target fy Pu) (Vf_target fy Pv). rewrite ty sr2 //; move/soimP => [[f1 s1 t1] i1]/soimP [[f2 s2 t2] i2]. move: i2; move=> [_ _ [fw sw tw] iw]; move: (iw _ _ le2) => h'. have h: (gle r'' (Vf (Vf y (P u)) (Q u)) (Vf (Vf y (P v)) (Q u))). move: incy => [_ _ [f3 s3 t3] i3]. by move: (imo_incr or'' (i3 _ _ le1) Qu). order_tac. have sg: source g = (E \times F) by rewrite /g;aw. have sg1: (range (source g) = F) by rewrite sg ; bw. have tg: target g = G by rewrite /g;aw. have pfa: (partial_fun_axiom g) by split;[exact |rewrite sg; exists E, F]. exists g; first by apply /soimP; split => //; split => //; ue. apply: function_exten. - exact. - exact (proj31 (restriction2_prop (Exercise1_6j ne1 ne2 ig))). - rewrite /restriction2; aw. - rewrite /restriction2 ty sr2 //; aw. - move => x xs /=. rewrite restriction2_V //; [ | by apply: Exercise1_6j | ue ]. have xE: inc x E by rewrite /E - sy. have xdg: inc x (domain (source g)) by rewrite sg (setX_domain _ ne2). rewrite spfa_V //. move: (Vf_target fy xs); rewrite ty sr2 //. move=> /soimP [[fw sw tw] iw]. apply: function_exten => //. - apply: spf_f => //. - rewrite /second_partial_fun; aw; ue. - rewrite /second_partial_fun;aw; ue. - move => i; rewrite /second_partial_fun lf_source sw; move=> isf. rewrite - sg sg1 lf_V //; first by rewrite /g lf_V //;aw; apply /setXp_i. move=> t tr ; rewrite tg /g;rewrite lf_V //; aw; last by apply /setXp_i. by rewrite /G -tw; apply: Vf_target =>//; rewrite sw. Qed. Lemma Exercise1_6m: nonempty E -> nonempty F -> order_isomorphism (second_partial_map2 r r' r'') (increasing_mappings_order (order_product2 r r') r'') (increasing_mappings_order r (increasing_mappings_order r' r'')). Proof. move=> ne1 ne2. move: (Exercise1_6l ne1 ne2). set f := (second_partial_map2 r r' r''); move=> [bf sf tf]. have ta:= (Exercise1_6k ne1 ne2). have [o2 sr2]:= (imo_osr r' or''). have o3:order (order_product2 r r') by apply: order_product2_or. have [o2' sr2']:= (imo_osr (order_product2 r r') or''). have [o2'' sr2''] := (imo_osr r o2). split => //; first by rewrite sr2' sr2''. move=> x y xsf ysf. have sop:= (order_product2_sr or or'). move: (xsf) (ysf); rewrite sf; move /soimP => [[fx sx tx] ix]. move /soimP => [[fy sy ty] iy]. have pfx: (partial_fun_axiom x) by split;[exact |rewrite sx; exists E, F]. have pfy: (partial_fun_axiom y) by split;[exact |rewrite sy; exists E, F]. have ff: function f by fct_tac. have u1p:inc (Vf (second_partial_map2 r r' r'') x) (target (second_partial_map2 r r' r'')) by Wtac. have u2p:inc (Vf (second_partial_map2 r r' r'') y) (target (second_partial_map2 r r' r'')) by Wtac. move: (Exercise1_6j ne1 ne2 ix)(Exercise1_6j ne1 ne2 iy) => ta1 ta2. split. move /(imo_gleP _ or'') => [_ _ incx]. apply /(imo_gleP _ o2);rewrite -tf; split => //. rewrite /f lf_V //; last (by ue);rewrite lf_V //; last (by ue). split => //; rewrite ? sr2. split => //;rewrite /restriction2; aw. by apply: (proj31 (restriction2_prop ta1)). split => //;rewrite /restriction2; aw. by apply: (proj31 (restriction2_prop ta2)). move => i isr; rewrite restriction2_V //restriction2_V //. have idx: (inc i (domain (source x))) by rewrite sx sop setX_domain //. have idy: (inc i (domain (source y))) by rewrite sy sop setX_domain. rewrite spfa_V // spfa_V //; apply /(imo_gleP _ or''). have in1:= (Exercise1_6i ne1 ne2 ix isr). have in2 :=(Exercise1_6i ne1 ne2 iy isr). move: (in1)(in2) => [_ _ [f1 s1 s'1] i1] [_ _ [f2 s2 s'2] i2]. split => //; try apply /soimP;split => //. move=> j jsr'. rewrite spf_V //; last by rewrite sx sop; bw. rewrite spf_V //; last by rewrite sy sop; bw. move: incx => [ _ _]; apply; rewrite sop; fprops. move => h. apply /(imo_gleP _ or'');split => //; [ ue | ue | split => //]. rewrite sop; move=> i /setX_P [pi Pi Qi]. have q1: (inc (P i) (domain (source x))) by rewrite sx sop; bw. have q2: (inc (Q i) (range (source x))) by rewrite sx sop; bw. have q3: (inc (P i) (domain (source y))) by rewrite sy - sx. have q4: (inc (Q i) (range (source y))) by rewrite sy - sx. rewrite - pi; move:(imo_incr o2 h Pi). rewrite /f lf_V //; last (by ue);rewrite lf_V //; last (by ue). rewrite restriction2_V // restriction2_V // spfa_V // spfa_V //. move => h1; move: (imo_incr or'' h1 Qi); rewrite spf_V // spf_V //. Qed. Lemma Exercise1_6m': (increasing_mappings_order (order_product2 r r') r'') \Is (increasing_mappings_order r (increasing_mappings_order r' r'')). Proof. case: (p_or_not_p (nonempty E /\nonempty F)) => H. move: H => [pa pb]; exists (second_partial_map2 r r' r''). by apply: Exercise1_6m. have esa: (E \times F) = emptyset. case: (emptyset_dichot E); first by move => ->; rewrite setX_0l. case: (emptyset_dichot F);first by move => ->; rewrite setX_0r. by move => n1 n2; case: H. have: (substrate (order_product2 r r')) = emptyset. by rewrite (order_product2_sr or or'). have: order (order_product2 r r') by apply: order_product2_or. set r3:= (order_product2 r r'). move => or3 sr3. case: (imo_osr r' or'');set r2 := (increasing_mappings_order r' r'') => or2 sr2. have [or4 sr4]:= (imo_osr r3 or''). have [or5 sr5]:= (imo_osr r or3). have [or6 sr6]:= (imo_osr r or2). have ssa:= functions_empty. have ssb: forall ra rb, order ra -> order rb -> substrate ra = emptyset -> substrate (increasing_mappings_order ra rb) = singleton (empty_function_tg (substrate rb)). move => ra rb ora orb h. rewrite (proj2 (imo_osr _ orb)) /increasing_mappings h. rewrite (ssa (substrate rb)). move:(empty_function_tg_function (substrate rb)) => [wa wb wc]. set_extens t; first by case /Zo_P. move => ta; apply: Zo_i => //; move /set1_P:ta => ->;split => //. split => //;ue. move => x y le. have: inc x (substrate ra) by order_tac. by rewrite h => /in_set0. move: (ssb _ _ or3 or'' sr3). set f0 := (empty_function_tg G); move => ssrc. have si: singletonp (substrate (increasing_mappings_order r r2)). case: (emptyset_dichot E) => h. rewrite (ssb _ _ or or2 h). by exists (empty_function_tg (substrate r2)). case: (emptyset_dichot F) => h1; last by case: H;split => //. rewrite sr6. move: (ssb _ _ or' or'' h1). set f1:= (empty_function_tg G) => sr2'. set f := Lf (fun _ => f1) E (substrate r2). have ta: lf_axiom (fun _ => f1) E (substrate r2). move => t _ ; rewrite sr2'; fprops. have ff: function f by apply: lf_function. exists f; apply :set1_pr. rewrite /f;apply: Zo_i; first by apply/functionsP;split => //;aw. split => //; first by split; aw. move => x y lexy; rewrite /E; aw; order_tac;rewrite sr2'; fprops. move =>t /Zo_P [] /functionsP [ft st tt] _; rewrite /f. apply: function_exten; aw; rewrite /E; move => x xst /=; aw; last by ue. by move: (Vf_target ft xst); rewrite tt sr2' => /set1_P ->. move: si => [w ws]. have ta: lf_axiom (fun _ => w) (singleton f0) (singleton w). move => t _ /=; fprops. exists (Lf (fun z => w) (singleton f0)(singleton w)). split => //. split; aw; try ue; apply: lf_bijective. + done. + by move => u v /set1_P -> /set1_P ->. + move => y /set1_P ->; exists f0;fprops. move => x y; rewrite lf_source; move => pa pb; aw. move: pa pb => /set1_P -> /set1_P ->;split => h; order_tac. rewrite ws; aw;fprops. rewrite ssrc; aw; fprops. Qed. (** We show that [A(E,F)] is a lattice iff [F] is a lattice by considering constant functions *) Lemma constant_increasing y: inc y F -> (inc (constant_function E F y) (increasing_mappings r r')). Proof. move => yF;move:(constant_prop E yF) => fp; apply /soimP; split => //. rewrite /E;split => // u v uv. rewrite (constant_V yF); last by order_tac. by rewrite (constant_V yF); order_tac. Qed. Lemma constant_increasing1: nonempty E -> forall y y', inc y F -> inc y' F -> (gle r' y y' <-> gle (increasing_mappings_order r r') (constant_function E F y) (constant_function E F y')). Proof. move=> [u usr] y y' ysr ysr'. split; last by move => h; move: (imo_incr or' h usr); rewrite !constant_V. move:(constant_increasing ysr)(constant_increasing ysr') => pa pb. move:(constant_prop E ysr)(constant_prop E ysr') => pc pd. move=> yy'; apply /imo_gleP => //;split => //; split => //. by move => i isr; rewrite ! constant_V. Qed. Lemma Exercise1_6n: nonempty E -> (lattice r' <-> lattice (increasing_mappings_order r r')). Proof. move=> ne1; split. move:(imo_osr r or') => [pa pb]. move=> sl; split => //; rewrite pb. move=> x y xs ys. move: (xs)(ys) => /soimP [[fx sx tx] ix] /soimP [[fy sy ty] iy]. have Ha: forall c, inc c E -> (inc (Vf x c) F) /\ (inc (Vf y c) F). move => c cE; rewrite /F -{1} tx - ty;split; apply: Vf_target =>//; ue. have ta1: (lf_axiom (fun i=> sup r' (Vf x i) (Vf y i)) E F). move => c cE; move: (Ha _ cE) => [w1 w2]. move: (lattice_sup_pr sl w1 w2)=> [aux _ _]; rewrite /F; order_tac. have ta2: (lf_axiom (fun i=> inf r' (Vf x i) (Vf y i)) E F). move => c cE; move: (Ha _ cE) => [w1 w2]. move: (lattice_inf_pr sl w1 w2)=> [aux _ _]; rewrite /F; order_tac. set (f1:= Lf (fun i=> sup r' (Vf x i) (Vf y i)) E F). set (f2:= Lf (fun i=> inf r' (Vf x i) (Vf y i)) E F). have ff1: (function f1) by rewrite /f1; apply: lf_function. have ff2: (function f2) by rewrite /f1; apply: lf_function. have fp1: function_prop f1 E F by rewrite/f1; split; aw. have fp2: function_prop f2 E F by rewrite/f2; split; aw. have if1:increasing_fun f1 r r'. split => //; rewrite /f1; aw => u v uv. have uE: (inc u E) by rewrite /E;order_tac. have vE: (inc v E) by rewrite /E;order_tac. move:(Ha _ uE)(Ha _ vE) => [uxE uyE] [vxE vyE]. aw; move: (lattice_sup_pr sl uxE uyE) (lattice_sup_pr sl vxE vyE). move=> [p1 p2 p3] [p4 p5 p6]. have le1:(gle r' (Vf x u) (Vf x v)) by move: ix => [_ _ _ inx]; apply: inx. have le2:(gle r' (Vf y u) (Vf y v)) by move: iy => [_ _ _ inx]; apply: inx. apply: p3; order_tac. have if2:increasing_fun f2 r r'. split => //; rewrite /f2; aw. move=> u v uv. have uE: (inc u E) by rewrite /E;order_tac. have vE: (inc v E) by rewrite /E;order_tac. move:(Ha _ uE)(Ha _ vE) => [uxE uyE] [vxE vyE]. aw; move: (lattice_inf_pr sl uxE uyE) (lattice_inf_pr sl vxE vyE). move=> [p1 p2 p3] [p4 p5 p6]. have le1:(gle r' (Vf x u) (Vf x v)) by move: ix => [_ _ _ inx]; apply: inx. have le2:(gle r' (Vf y u) (Vf y v)) by move: iy => [_ _ _ inx]; apply: inx. apply: p6; order_tac. have sif1: inc f1 (increasing_mappings r r'). rewrite /f1;apply /soimP=> //;split; aw; split; aw. have sif2: inc f2 (increasing_mappings r r'). rewrite /f2;apply /soimP=> //;split; aw; split; aw. move: (imo_osr r or') => [o2 s2]. have sd:sub (doubleton x y) (substrate (increasing_mappings_order r r')). by move=> t; case /set2_P => -> //; rewrite s2. split. exists f1; apply /lubP =>//;split. split; first by rewrite s2. move=> u; case /set2_P => ->; apply /imo_gleP => //;split => //. split => //; rewrite /f1; move => i isr; rewrite lf_V //. by move: (Ha _ isr) => [wxe wye];case: (lattice_sup_pr sl wxe wye). split => //;rewrite /f1; move => i isr; rewrite lf_V //. by move: (Ha _ isr) => [wxe wye];case: (lattice_sup_pr sl wxe wye). move=> z [z1 z2]. move: (imo_incr or' (z2 _ (set2_1 x y))) => inx. move: (z2 _ (set2_2 x y)) => /(imo_gleP _ or') [_ p1 [xx fz hh]]. rewrite /f1; apply /(imo_gleP _ or');split => //;split => //; aw. move=> i isr; rewrite lf_V //. move: (inx _ isr) (hh _ isr) => r1 r2; move:(Ha _ isr) => [xwe ywe]. by move: (lattice_sup_pr sl xwe ywe)=> [r3 r4 r5]; apply: r5. exists f2; apply /glbP=> //;split. split; first by rewrite s2 //. move=> u; case /set2_P => ->; apply /(imo_gleP _ or');split => //. rewrite /f2; split => //; aw. move => i isr; rewrite lf_V //; move:(Ha _ isr) => [xwe ywe]. by case: (lattice_inf_pr sl xwe ywe). rewrite /f2;split => //; aw; move => i isr; rewrite lf_V //. by move:(Ha _ isr) => [xwe ywe];case: (lattice_inf_pr sl xwe ywe). move=> z [z1 z2]. move: (imo_incr or' (z2 _ (set2_1 x y))) => inx. move: (z2 _ (set2_2 x y)) => /(imo_gleP _ or') [p1 p2 [p3 p4 p5]]. rewrite /f2; apply /(imo_gleP _ or');split => //; split => //; aw. move=> i isr; rewrite lf_V => //; move:(Ha _ isr) => [xwe ywe]. move: (inx _ isr) (p5 _ isr) => r1 r2. by move: (lattice_inf_pr sl xwe ywe)=> [r3 r4]; apply. move=> sl; split; first by exact. move=> x y xsr ysr. set (f1:= constant_function E F x). set (f2:= constant_function E F y). have f1s: (inc f1 (increasing_mappings r r')) by apply: constant_increasing. have f2s: (inc f2 (increasing_mappings r r')) by apply: constant_increasing. move:(proj2 (imo_osr r or')) => sr2. move: (f1s)(f2s); rewrite - sr2 => f1si f2si. set (r''':= increasing_mappings_order r r') in *. have sd:sub (doubleton x y) (substrate r') by move=> t; case /set2_P=> ->. move: (ne1) => [t te]. split. move: (lattice_sup_pr sl f1si f2si) => [l1 l2 l3]. have: (inc (sup r''' f1 f2) (substrate r''')) by order_tac. rewrite {2} /r''' sr2 => /soimP [[fs ss ts] ifs]. set z := Vf (sup r''' f1 f2) t. have wt: (inc z F) by rewrite /z/F -ts; Wtac; ue. have xz: gle r' x z. move: (imo_incr or' l1 te); rewrite {1} /f1 constant_V //. have yz: gle r' y z. move: (imo_incr or' l2 te); rewrite {1} /f1 constant_V //. exists z; apply /lubP => //; split. split; [ exact | by move=> u; case /set2_P => ->]. move=> u [usr um]. set (f4:= constant_function E F u). have f4s:(inc f4 (increasing_mappings r r')) by apply: constant_increasing. have f14: (gle (increasing_mappings_order r r') f1 f4). rewrite /f1/f4 /E/F - constant_increasing1 //; apply: um; fprops. have f24: (gle (increasing_mappings_order r r') f2 f4). rewrite /f1/f4 /E/F - constant_increasing1 //; apply: um; fprops. by move: (imo_incr or' (l3 _ f14 f24) te);rewrite -/r'' -/z /f4 constant_V. move: (lattice_inf_pr sl f1si f2si) => [l1 l2 l3]. have: (inc (inf r''' f1 f2) (substrate r''')) by order_tac. rewrite {2} /r''' sr2;move /soimP => [[fs ss ts] ifs]. set z := Vf (inf r''' f1 f2) t. have wt: (inc z F) by rewrite /z/F -ts; Wtac; ue. have yz: gle r' z y by move: (imo_incr or' l2 te); rewrite {1} /f1 constant_V. have xz: gle r' z x by move: (imo_incr or' l1 te); rewrite {1} /f1 constant_V. exists z; apply /glbP => //; split. split; [ exact | by move=> u; case /set2_P => ->]. move=> u [usr um]. set (f4:= constant_function E F u). have f4s:(inc f4 (increasing_mappings r r')) by apply: constant_increasing. have f14: (gle (increasing_mappings_order r r') f4 f1). rewrite /f1/f4 /E/F - constant_increasing1 //; apply: um; fprops. have f24: (gle (increasing_mappings_order r r') f4 f2). rewrite /f1/f4 /E/F - constant_increasing1 //; apply: um; fprops. by move: (imo_incr or' (l3 _ f14 f24) te); rewrite -/r'' -/z /f4 constant_V. Qed. (** we study when [A(E,F)] is totally ordered *) Lemma Exercise1_6o: nonempty E -> total_order (increasing_mappings_order r r') -> total_order r'. Proof. move=> [t te] [orf torf]. split =>//; move => x y xsr ysr. move: (constant_increasing xsr) (constant_increasing ysr). rewrite (proj2 (imo_osr r or')) in torf. by move => p1 p2; case: (torf _ _ p1 p2) => h; move: (imo_incr or' h te); rewrite !constant_V // => h1 ; [left | right]. Qed. Lemma Exercise1_6p: singletonp F -> total_order (increasing_mappings_order r r'). Proof. move /singletonP => [_ s]. move: (imo_osr r or') => [pa pb]. split => //; rewrite pb => x y xs ys; left; rewrite imo_gleP//; split => //. move: xs ys => /soimP [[fx sx tx] ix] /soimP [[fy sy ty] iy]. split => //; move=> i isr. have w1: (inc (Vf x i) F) by rewrite /F -tx; Wtac; ue. have w2: (inc (Vf y i) F) by rewrite /F -ty; Wtac; ue. by rewrite (s _ _ w1 w2); order_tac. Qed. Lemma Exercise1_6q: singletonp E -> total_order r' -> total_order (increasing_mappings_order r r'). Proof. move=> [s sr] [orf torf]. move: (imo_osr r or') => [pa pb]. split => //; rewrite pb=> x y xs ys. move: (xs)(ys) => /soimP [[fx sx tx] ix] /soimP [[fy sy ty] iy]. move: (sx)(sy); rewrite -/E sr=> sx' sy'. have w1:(inc (Vf x s) F) by rewrite /F -tx; Wtac; ue. have w2:(inc (Vf y s) F) by rewrite /F -ty; Wtac; ue. case: (torf _ _ w1 w2) => h; [left | right ]; by apply /imo_gleP => //;split => //; split => // i isr; move: isr; rewrite -/E sr => /set1_P ->. Qed. Lemma Exercise1_6r: total_order r -> total_order r' -> (exists a b, F = doubleton a b) -> total_order (increasing_mappings_order r r'). Proof. move=> [_ tor] [_ tor'] [u [v sr']]. case: (equal_or_not u v) => uv. apply: Exercise1_6p => //; rewrite sr' -uv; exists u;split => //. have [a [b [ab aF bF ltab]]]: exists a b, [/\ F = doubleton a b, inc a F, inc b F & glt r' a b]. have ap: (inc u F) by rewrite sr'; fprops. have bp: (inc v F) by rewrite sr'; fprops. case: (tor' _ _ ap bp) => le1. exists u; exists v; split => //; split =>//. by exists v; exists u; rewrite set2_C; split => //; split =>//; apply:nesym. clear sr' uv u v. move: (imo_osr r or') => [pa1 pb1]. split => //. rewrite pb1; move=> x y xs ys; rewrite /ocomparable. move: (xs)(ys) => /soimP [[fx sx tx] ix] /soimP [[fy sy ty] iy]. have Ha: forall c, inc c E -> (inc (Vf x c) F) /\ (inc (Vf y c) F). move => c cE; rewrite /F -{1} tx - ty;split; apply: Vf_target =>//; ue. have aux: (forall t, inc t E -> glt r' (Vf x t) (Vf y t) -> (Vf x t = a /\ Vf y t = b)). move=> t tsr wt; move: (Ha _ tsr) (wt) => []. rewrite -/F ab; case /set2_P => -> ; case /set2_P => -> //; [by case | by move => [ha _]; order_tac | by case]. case: (p_or_not_p (exists2 u, inc u E & glt r' (Vf x u) (Vf y u))). move=> [u usr uwy]; left. apply /imo_gleP => //; split => //; split => // i isr. move: (Ha _ isr) => [];rewrite ab; case /set2_P => h1; case /set2_P => h2; rewrite h1 h2;try order_tac => //. move: (aux _ usr uwy) => [h3 h4]. move: ix iy => [_ _ _ ix] [_ _ _ iy]. by case: (tor _ _ usr isr) => h5; move: (ix _ _ h5) (iy _ _ h5); rewrite h2 h3 h4 h1. move=> neu; right; apply /imo_gleP => //; split => //;split => //. move=> i isr;move: (Ha _ isr) => [xw yw]. case: (tor' _ _ xw yw) => //. case: (equal_or_not (Vf x i) (Vf y i)) =>sw; first by rewrite sw. by move=> nle; case: neu; ex_tac. Qed. Lemma Exercise1_6s: nonempty E -> nonempty F -> (total_order (increasing_mappings_order r r') <-> [\/ singletonp F, (singletonp E /\ total_order r') | [/\ total_order r', total_order r & exists u v, F = doubleton u v]]). Proof. move=> ne1 ne2. split;last first. case; first by apply: Exercise1_6p. by move=> [h1 h2];apply: Exercise1_6q. by move=> [h1 [h2 h3]]; apply: Exercise1_6r. move => tor; move: (Exercise1_6o ne1 tor) => tor'. move: (tor') => [_ tor'']. move: (ne2) => [y yF]. case: (equal_or_not F (singleton y))=> Fp; first by constructor 1; exists y. move: (ne1) => [z zE]. case: (equal_or_not E (singleton z))=> Ep. by constructor 2; split => //;exists z. constructor 3. have [y' yF' yy']: (exists2 y1, inc y1 F & y1 <> y). ex_middle h; case: Fp; set_extens t. case: (equal_or_not t y); first by move => ->; fprops. move => ty ts; case: h;ex_tac. by move /set1_P => ->. have [a [b [aF bF ltab]]]: exists a b, [/\ inc a F, inc b F & glt r' a b]. case: (tor'' _ _ yF yF'). by move => aux; exists y, y'; split => //; split => //; apply:nesym. rewrite /glt;move => aux; exists y', y;split => //. clear yF yF' Fp yy' y y'. set sf:= fun x a b => fun u=> Yo (gle r u x) a b. have sfa: forall x a b, inc a F -> inc b F -> (lf_axiom (sf x a b) E F). by rewrite /sf=> x v w vF wF u uE; case: (p_or_not_p (gle r u x)) => h; Ytac0. have sfb: forall x a b, inc a F -> inc b F -> glt r' a b -> (inc (Lf (sf x a b) E F) (increasing_mappings r r')). move => x a' b' aF' bF' latab'; move: (sfa x _ _ aF' bF') => ta. move: (lf_function ta) => fb. apply /soimP => //;split => //; aw; split => //;aw. split; aw. move=> u v uv. have us: (inc u E) by rewrite /E;order_tac. have vs: (inc v E) by rewrite /E;order_tac. rewrite lf_V // lf_V // /sf. case: (p_or_not_p (gle r u x)) => ux; Ytac0; case: (p_or_not_p (gle r v x)) => vx; Ytac0; try order_tac => //. case: ux; order_tac. have to: (total_order r). split=> //; rewrite -/E;move=> x y xsr ysr. move: (sfb x _ _ aF bF ltab) (sfb y _ _ aF bF ltab) => fx fy. move: tor => [_]; rewrite (proj2 (imo_osr r or')); move=> aux; red. case: (p_or_not_p (gle r x y)); first by left. case: (p_or_not_p (gle r y x)); first by right. move=> be1 be2. have sfxx: sf x a b x = a by rewrite /sf Y_true //; order_tac. have sfyy: sf y a b y = a by rewrite /sf Y_true //; order_tac. have sfxy: sf x a b y = b by rewrite /sf Y_false//; order_tac. have sfyx: sf y a b x = b by rewrite /sf Y_false//; order_tac. move: (sfa x _ _ aF bF)(sfa y _ _ aF bF) => h1 h2. case: (aux _ _ fx fy) => h; move : (imo_incr or' h xsr) (imo_incr or' h ysr); rewrite !lf_V// sfxx sfyx sfyy sfxy; move=> h3 h4; order_tac. split => //. case: (equal_or_not F (doubleton a b)); first by move=> h; exists a,b. move=> at2. have at3: exists c, [/\ inc c F, c <> a & c <> b]. ex_middle at3; case: at2; set_extens t. case: (equal_or_not t a); first by move => ->; fprops. case: (equal_or_not t b); first by move => ->; fprops. move => tb ta ts; case: at3; exists t; split => //. by case/set2_P => ->. have [u [v [w [uF vF wF uv vw]]]]: (exists u v w, [/\ inc u F, inc v F, inc w F, glt r' u v & glt r' v w]). move: at3 => [c [cF ca cb]]; case: (tor'' _ _ cF aF)=> lca. exists c; exists a, b; split => //. case: (tor'' _ _ bF cF) => lbc. by exists a, b, c; split => //; split => //;apply:nesym. by exists a, c, b; split => //; split => //; apply:nesym. set (f:= constant_function (substrate r) F v). have fs:(inc f (increasing_mappings r r')) by apply: constant_increasing. have [z' zE' zz']: (exists2 y1, inc y1 E & y1 <> z). ex_middle h; case: Ep; set_extens t. case: (equal_or_not t z); first by move => ->; fprops. move => ty ts; case: h; ex_tac. by move /set1_P => ->. have [i [s [iF sF ltis]]]: exists i s, [/\ inc i E, inc s E & glt r i s]. move: to => [_ to];case: (to _ _ zE zE'). by move => aux; exists z, z';split => //; split => //; apply:nesym. rewrite /glt; move => aux; exists z', z;split => //. have ltuv: glt r' u w by order_tac. move: (sfa i u w uF wF) (sfb i u w uF wF ltuv). set g:= Lf _ _ _; move=> ta fg. move: tor => [_]; rewrite (proj2 (imo_osr r or')) => aux. have p1: Vf f i = v by rewrite /f constant_V. have p2: Vf f s = v by rewrite /f constant_V. have p3: Vf g i = u by rewrite /g /sf lf_V// Y_true//; order_tac. have p4: Vf g s = w by rewrite /g /sf lf_V // Y_false// => h; order_tac. case: (aux _ _ fs fg) => h; move: (imo_incr or' h iF) (imo_incr or' h sF); rewrite p1 p2 p3 p4 => p5 p6; order_tac. Qed. End Exercise1_6. (** ---- Exercise 1.7. A function that is both increasing and decreasing is constant iff the source is connected for [ocomparable]; this is the case: if the source is directed *) Definition cr_equiv r := chain_equivalence (ocomparable r) (substrate r). Definition cr_component r := connected_comp (ocomparable r) (substrate r). Lemma cr_properties r: order r -> [/\ equivalence (cr_equiv r) , (forall x y, ocomparable r x y -> (inc x (substrate r)/\ inc y (substrate r))), substrate (cr_equiv r) = substrate r, (forall x, inc x (substrate r) -> class (cr_equiv r) x = cr_component r x) & (forall x y, ocomparable r x y -> related (cr_equiv r) x y)]. Proof. move=> or. rewrite /cr_equiv /cr_component. have crs: (forall x y, ocomparable r x y -> (inc x (substrate r) /\ inc y (substrate r))). by move=> x y; case; split; order_tac. have rc: (reflexive_re (ocomparable r) (substrate r)). by move => x; split ; [ move=> xsr;left | case=> aux]; order_tac. have sc: (symmetric_r (ocomparable r)) by move=> x y; case; [right | left]. have crs': (forall x y, ocomparable r x y -> inc x (substrate r)). by move=> x y xy; move: (crs _ _ xy) => [ok _]. move:(chain_equivalence_eq rc sc crs') => [ha hb]. split => //. - by move=> x xsr; apply: connected_comp_class. - move => x y cr;apply /Zo_P; split. by move: (crs _ _ cr) => [xs ys]; apply: setXp_i. by aw; exists (chain_pair x y). Qed. Lemma Exercise1_7a r x: right_directed r -> inc x (substrate r) -> cr_component r x = substrate r. Proof. move /right_directedP => [or rdp]. move: (cr_properties or)=> [p1 p2 p3 p4 p5] xsr. rewrite -(p4 _ xsr);apply: extensionality. rewrite -p3;apply: sub_class_substrate => //. move=> t tsr; move: (rdp _ _ xsr tsr) => [z [xz yz]]. have r1: (related (cr_equiv r) x z) by apply: p5; left. have r2: (related (cr_equiv r) t z) by apply: p5; left. apply /(class_P p1). apply: (@transitivity_e _ z) => //; apply: symmetricity_e => //. Qed. Lemma Exercise1_7b r x: left_directed r -> inc x (substrate r) -> cr_component r x = substrate r. Proof. move /left_directedP => [or rdp]. move: (cr_properties or)=> [p1 p2 p3 p4 p5] xsr. rewrite -(p4 _ xsr);apply: extensionality. rewrite -p3;apply: sub_class_substrate => //. move=> t tsr; move: (rdp _ _ xsr tsr) => [z [xz yz]]. have r1: (related (cr_equiv r) x z) by apply: p5; right. have r2: (related (cr_equiv r) t z) by apply: p5; right. apply /(class_P p1); apply: (@transitivity_e _ z) => //. by apply: symmetricity_e. Qed. Lemma Exercise1_7c r r' f: increasing_fun f r r' -> decreasing_fun f r r' -> forall x y, ocomparable r x y -> Vf f x = Vf f y. Proof. move=> [or or' [ff sr sr'] incf][_ _ _ decf] x y. case=> h; move: (decf _ _ h)(incf _ _ h)=> p1 p2; order_tac. Qed. Lemma Exercise1_7d r r' f: increasing_fun f r r' -> decreasing_fun f r r' -> (exists2 x, inc x (substrate r) & cr_component r x = substrate r) -> (constantfp f). Proof. move=> incf decf [x xsr sr1]; set H := (Exercise1_7c incf decf). move: (incf) => [or or' [ff sr sr'] incf']. move: (cr_properties or)=> [p1 p2 p3 p4 p5]. split => //. suff sw': (forall u, inc u (source f) -> Vf f u = Vf f x). by move => a b asf bsf; move: (sw' _ asf) (sw' _ bsf) => -> ->. move => u; rewrite sr - sr1 -(p4 _ xsr) => /(class_P p1) rxu. have: related (cr_equiv r) u x by apply: symmetricity_e. move /Zo_P => [_]; aw; move => [c [h1 <- <-]]. elim: c h1;first by move => a b; apply: H. by move=> a c => xx [yy zz]; rewrite -(xx zz); apply:H. Qed. Lemma Exercise1_7e r r': order r -> order r' -> (exists u v, [/\ inc u (substrate r'), inc v (substrate r') & u <>v]) -> (exists2 x, inc x (substrate r) & cr_component r x <> substrate r) -> exists f, [/\ increasing_fun f r r', decreasing_fun f r r' & ~(constantfp f)]. Proof. move=> or or' [u [v [usr' vsr' uv]]] [x xsr nsr]. move: (cr_properties or)=> [p1 p2 p3 p4 p5]. pose f t := Yo (inc t (cr_component r x)) u v. have ta: (lf_axiom f (substrate r) (substrate r')). by move=> t tsr; rewrite /f; Ytac tc. set (g:= Lf f (substrate r) (substrate r')). have fg: (function g) by apply: lf_function. have sg: source g = substrate r by rewrite /g; aw. have tg: target g = substrate r' by rewrite /g; aw. have q1:(sub (cr_component r x) (substrate r)). by rewrite -(p4 _ xsr) -p3; apply: sub_class_substrate. have q2: forall y, inc y (cr_component r x) -> Vf g y = u. by move=> y yc; rewrite /g lf_V // /f; [ Ytac0 | apply: q1]. have q3 y: inc y (substrate r) -> ~(inc y (cr_component r x)) -> Vf g y = v. by move=> yc ync; rewrite /g lf_V // /f Y_false //. have ncg: (~ constantfp g). move=> [h1 h2]; case: nsr; apply: extensionality => //. move=> t tsr; ex_middle bad; rewrite sg in h2. have xc: inc x (cr_component r x). rewrite -(p4 _ xsr); apply /(class_P p1); apply: reflexivity_e =>//; ue. case: uv;move: (h2 _ _ xsr tsr);rewrite (q2 _ xc)(q3 _ tsr bad) //. have q4: (forall a b, gle r a b -> ((inc a (cr_component r x) <-> inc b (cr_component r x)))). move=> a b ab; rewrite - (p4 _ xsr). have cab: (ocomparable r a b) by left. move: (p5 _ _ cab)=> rab. split; move => /(class_P p1) => h; apply /(class_P p1). by apply: (@transitivity_e _ a). by apply: (@transitivity_e _ b) =>//; apply: symmetricity_e. have q5: (forall a b, gle r a b -> Vf g a = Vf g b). move=> a b ab. case: (p_or_not_p (inc a (cr_component r x))) => H. by rewrite (q2 _ H); move: H;rewrite (q4 _ _ ab) => H; rewrite (q2 _ H). have asr: inc a (substrate r) by order_tac. have bsr: inc b (substrate r) by order_tac. by rewrite (q3 _ asr H); move:H; rewrite (q4 _ _ ab)=> H;rewrite (q3 _ bsr H). exists g;split => //; split => //; move=> a b ab;rewrite (q5 _ _ ab); order_tac. rewrite -tg; apply: Vf_target => //; rewrite sg; order_tac. rewrite -tg; apply: Vf_target => //; rewrite sg; order_tac. Qed. (** ---- Exercise 1.8: fixed point of [f o g] and [g o f] are isomorphic *) Lemma Exercise1_8 r r' f g: let A := Zo (substrate r) (fun z => Vf g (Vf f z) = z) in let B := Zo (substrate r') (fun z => Vf f (Vf g z) = z) in increasing_fun f r r' -> increasing_fun g r' r -> (induced_order r A) \Is (induced_order r' B). Proof. move=> A B [o1 o2 [ff sf tf] incf][_ _ [fg sg tg] incg]. have p1: (forall x, inc x A -> inc (Vf f x) B). by move=> x /Zo_P [xsr r1]; apply: Zo_i; [Wtac | rewrite r1]. have p2: (forall x, inc x B -> inc (Vf g x) A). by move=> x /Zo_P [xsr r1]; apply: Zo_i ; [Wtac | rewrite r1]. have Ha: source (restriction2 f A B) = A by rewrite / restriction2; aw. have Hb: target (restriction2 f A B) = B by rewrite / restriction2; aw. have asf: sub A (source f) by rewrite sf; apply: Zo_S. set (h:=restriction2 f A B). have ra: (restriction2_axioms f A B). split => //. rewrite /B -tf; apply: Zo_S. by move => t /(Vf_image_P ff asf) [s sa ->]; apply: p1. have fh: function h by apply: (proj31 (restriction2_prop ra)). have ih: (injection h). split=> //; rewrite Ha; move => x y xA yA /=. rewrite /h restriction2_V // restriction2_V // => eq. move: xA yA => / Zo_hi <- /Zo_hi <-; ue. have sh: (surjection h). split => //; rewrite Ha Hb; move=> y yB. move: (p2 _ yB) => wA. ex_tac; move: yB => /Zo_P [ysr ww]; rewrite /h restriction2_V //. have As: (sub A (substrate r)) by apply: Zo_S. have Bs: (sub B (substrate r')) by apply: Zo_S. have Ash: A = source h by rewrite /h; aw. have Bsh: B = target h by rewrite /h; aw. move: (iorder_osr o1 As) => [pa pb]. move: (iorder_osr o2 Bs) => [pc pd]. exists h; split => //; first by rewrite pb pd; split. red;rewrite -Ash; move=> x y xA yA. rewrite /h restriction2_V // restriction2_V //; aw; try apply: p1 => //. split. move =>aux; apply /iorder_gleP; try apply: p1 => //. apply: (incf _ _ (iorder_gle1 aux)). move =>aux; apply /iorder_gleP => //. move: (incg _ _ (iorder_gle1 aux)). by move: xA yA => /Zo_hi -> /Zo_hi ->. Qed. (** ---- Exercise 1.9 [sup (inf xij) <= inf (sup xij)] *) Section Exercise1_9. Variable r: Set. Hypothesis lr: lattice r. Let Hf := fun f => [/\ fgraph f, finite_set (domain f), nonempty (domain f) & sub (range f) (substrate r) ]. Lemma lattice_finite_sup_aux f: Hf f -> nonempty (range f) /\ finite_set (range f). Proof. move=> [fgf fsd ned srf]; split; last by apply: finite_range. by move: ned => [x xd]; exists (Vg f x); fprops. Qed. Lemma lattice_finite_sup4P f: (Hf f) -> forall y, (gle r(sup_graph r f) y <-> (forall z, inc z (domain f) -> gle r (Vg f z) y)). Proof. move => hf y. move:(lattice_finite_sup_aux hf) => [ne fr]. move: hf=> [fgf fsd ned srf];split. move /(lattice_finite_sup3P lr _ fr ne srf) => h z sd; apply: h; fprops. move=> h; apply /(lattice_finite_sup3P lr _ fr ne srf). by move=> z; move /(range_gP fgf) => [x xdf] ->; apply: h. Qed. Lemma lattice_finite_inf4P f :(Hf f) -> forall y, (gle r y (inf_graph r f) <-> (forall z, inc z (domain f) -> gle r y (Vg f z))). Proof. move => hf y. move:(lattice_finite_sup_aux hf) => [ne fr]. move: hf=> [fgf fsd ned srf];split. move /(lattice_finite_inf3P lr _ fr ne srf) => h z sd; apply: h; fprops. move=> h; apply /(lattice_finite_inf3P lr _ fr ne srf). by move=> z; move /(range_gP fgf) => [x xdf] ->; apply: h. Qed. Lemma lattice_finite_sup5 f: (Hf f) -> inc (sup_graph r f) (substrate r). Proof. move: (proj1 lr) => or [fgf fsd ned srf]. have aux: (has_sup_graph r f). apply: lattice_finite_sup2 => //;first by apply: finite_range. move: ned => [x xd]; exists (Vg f x); fprops. by move: (sup_graph_pr1 or srf aux) => /(lubP or srf) [[pa _] _]. Qed. Lemma lattice_finite_inf5 f: (Hf f) -> inc (inf_graph r f) (substrate r). Proof. move: (proj1 lr) => or [fgf fsd ned srf]. have aux: (has_inf_graph r f). apply: lattice_finite_inf2 => //; first by apply: finite_range. move: ned => [x xd]; exists (Vg f x); fprops. by move: (inf_graph_pr1 or srf aux) => /(glbP or srf) [[pa _] _]. Qed. Lemma Exercise1_9 I1 I2 f: fgraph f -> domain f = I1 \times I2 -> finite_set I1 -> finite_set I2 -> nonempty I1 -> nonempty I2 -> sub (range f) (substrate r) -> gle r (sup_graph r (Lg I2 (fun j => inf_graph r (Lg I1 (fun i => Vg f (J i j)))))) (inf_graph r (Lg I1 (fun i => sup_graph r (Lg I2 (fun j => Vg f (J i j)))))). Proof. move=> fgf df fs1 fs2 ni1 ni2 srf. have or: order r by move: lr => [ok _]. have hb: forall i j, inc i I1 -> inc j I2 -> inc (Vg f (J i j)) (substrate r). move=> i j i1 j2;apply: srf; apply: inc_V_range => //; rewrite df; fprops. have Hu: forall b, inc b I2 -> Hf (Lg I1 (fun i => Vg f (J i b))). by move => b bp; split;bw; fprops =>t' /Lg_range_P [b' bi1'] ->; apply: hb. have Hv: forall b, inc b I1 -> Hf (Lg I2 (fun j => Vg f (J b j))). by move => b bp; split;bw; fprops=>t' /Lg_range_P [b' bi1'] ->; apply: hb. have Ha: Hf (Lg I2 (fun j => inf_graph r (Lg I1 (fun i=> Vg f (J i j))))). split => //; fprops; bw. move=>t /Lg_range_P[b bi2] ->; apply: lattice_finite_inf5 => //; bw; fprops. have Hb: Hf (Lg I1 (fun i => sup_graph r (Lg I2 (fun j => Vg f (J i j))))). split => //; fprops; bw. move=>t/Lg_range_P [b bi2] ->; apply: lattice_finite_sup5 => //; bw; fprops. apply /lattice_finite_sup4P => //. bw; move => z zI; bw. apply/(lattice_finite_inf4P Hb); bw => t tI. apply: (@order_transitivity _ _ (Vg f (J t z))) => //. set (fa:= (Lg I1 (fun i => Vg f (J i z)))). have Hfa: Hf fa. by rewrite /fa; split;bw; fprops => y /Lg_range_P [x xI1] ->; bw; apply: hb. have: (gle r (inf_graph r fa) (inf_graph r fa)). by order_tac; apply: lattice_finite_inf5. have ->: (Vg f (J t z) = Vg fa t) by rewrite /fa; bw. move/(lattice_finite_inf4P Hfa); apply; rewrite /fa; bw. set (fb:= Lg I2 (fun j => Vg f (J t j))). have Hfa: Hf fb. by rewrite /fb; split; bw; fprops => y /Lg_range_P [x xI1] ->; bw; apply: hb. have ->: (Vg f (J t z) = Vg fb z) by rewrite /fb; bw. have: (gle r (sup_graph r fb) (sup_graph r fb)). by order_tac; apply: lattice_finite_sup5. move /(lattice_finite_sup4P Hfa); bw; apply; rewrite /fb; bw. Qed. End Exercise1_9. (** ---- Exercise 1.10: in a lattice [f] is increasing iff [f(inf(x,y)) <= inf(f(x), f(y))]. We give an example where inequality is strict *) Section Exercise1_10. Variable r r': Set. Hypothesis (lr: lattice r) (lr': lattice r'). Lemma Exercise1_10 f: function_prop f (substrate r)(substrate r') -> ((increasing_fun f r r') <-> (forall x y, inc x (substrate r) -> inc y (substrate r) -> gle r' (Vf f (inf r x y)) (inf r' (Vf f x) (Vf f y)))). Proof. move => [ff sf tf]; split. move=> [or or' _ incf] x y xsr ysr. move: (lattice_inf_pr lr xsr ysr) => [Ha Hb _ ]. have p1: (inc (inf r x y) (source f)) by rewrite sf; order_tac. rewrite - sf in xsr ysr; move: (incf _ _ Ha) (incf _ _ Hb) => p2 p3. move: (Vf_target ff xsr)(Vf_target ff ysr); rewrite tf => w1 w2. by move: (lattice_inf_pr lr' w1 w2); move=> [_ _]; apply. move: (lr)(lr') => [or _][or' _] p;split => //. move=> x y xy. have xsr: (inc x (source f)) by rewrite sf; order_tac. have ysr: (inc y (source f)) by rewrite sf; order_tac. rewrite - sf in p;move: (p _ _ xsr ysr); rewrite (inf_comparable1 or xy). move: (Vf_target ff xsr)(Vf_target ff ysr); rewrite tf => w1 w2. move: (lattice_inf_pr lr' w1 w2) => [_ p1 _ ] p2; order_tac. Qed. Lemma Exercise1_10b f: function_prop f (substrate r)(substrate r') -> ((increasing_fun f r r') <-> (forall x y, inc x (substrate r) -> inc y (substrate r) -> gle r' (sup r' (Vf f x) (Vf f y)) (Vf f (sup r x y)))). Proof. move => [ff sf tf]; split. move=> [or or' _ incf] x y xsr ysr. move: (lattice_sup_pr lr xsr ysr) => [Ha Hb _ ]. have p1: (inc (sup r x y) (source f)) by rewrite sf; order_tac. rewrite - sf in xsr ysr; move: (incf _ _ Ha) (incf _ _ Hb) => p2 p3. move: (Vf_target ff xsr)(Vf_target ff ysr); rewrite tf => w1 w2. by move: (lattice_sup_pr lr' w1 w2); move=> [_ _]; apply. move: (lr)(lr') => [or _][or' _] p;split => //. move=> x y xy. move:(arg1_sr xy)(arg2_sr xy); rewrite - sf => xsr ysr. rewrite - sf in p;move: (p _ _ xsr ysr); rewrite (sup_comparable1 or xy). move: (Vf_target ff xsr)(Vf_target ff ysr); rewrite tf => w1 w2. move: (lattice_sup_pr lr' w1 w2) => [p1 _ _] p2; order_tac. Qed. Lemma product2_lattice: lattice (order_product2 r r'). Proof. move: (lr)(lr') => [or _][or' _]. move: (order_product2_or or or') => or''. split => //; rewrite order_product2_sr //. move=> x y xs ys; move: (xs)(ys)=> /setX_P [px Px Qx] /setX_P [py Py Qy]. move: (lattice_sup_pr lr Px Py) (lattice_inf_pr lr Px Py). move: (lattice_sup_pr lr' Qx Qy) (lattice_inf_pr lr' Qx Qy). set ap := (inf r (P x) (P y)); set bp := (sup r (P x) (P y)). set aq := (inf r' (Q x) (Q y)); set bq := (sup r' (Q x) (Q y)). move=> [p1 p2 p3][q1 q2 q3][r1 r2 r3][s1 s2 s3]. have b1: inc bp (substrate r) by order_tac. have b2: inc ap (substrate r) by order_tac. have b3: inc bq (substrate r') by order_tac. have b4: inc aq (substrate r') by order_tac. split. exists (J bp bq); apply: lub_set2 => //. apply /order_product2_P; split => //; aw;fprops. apply /order_product2_P; split => //; aw; fprops. move=> t /order_product2_P [_ tp [h1 h2]] /order_product2_P [_ _ [h3 h4]]; apply /order_product2_P; split;fprops; aw. split;[ by apply: r3 | by apply: p3]. exists (J ap aq); apply: glb_set2 => //. apply /order_product2_P;split=>//;aw; fprops. apply /order_product2_P; split => //;aw; fprops. move=> t /order_product2_P [tp _ [h1 h2]] /order_product2_P [_ _ [h3 h4]]; apply /order_product2_P; split;fprops; aw. split;[ by apply: s3 | by apply: q3]. Qed. End Exercise1_10. Definition Exercise1_10_counterexample r r' f:= [/\ lattice r, lattice r', function_prop f (substrate r)(substrate r'), (increasing_fun f r r') & exists x y, [/\ inc x (substrate r), inc y (substrate r) & (Vf f (inf r x y)) <> (inf r' (Vf f x) (Vf f y))]]. Lemma Exercise1_10_bis (r := order_product2 Nat_order Nat_order) (r':= Nat_order) (f := Lf (fun z => (P z) +c (Q z)) (Nat \times Nat) Nat): Exercise1_10_counterexample r r' f. Proof. move:Nat_order_wor=> [pa sr']. have l1: lattice Nat_order by apply: total_order_lattice;apply: worder_total. have l2: lattice r by apply: product2_lattice. move: (l1)(l2) => [or1 _][or2 _]. have sr: substrate r = Nat \times Nat. by rewrite order_product2_sr// -/r' sr'. rewrite /f - sr. have ta: lf_axiom (fun z => (P z) +c (Q z)) (substrate r) Nat. by rewrite sr;move => z /setX_P [_ p1 p2]; apply: NS_sum. have fp: function_prop (Lf (fun z => P z +c Q z) (substrate r) Nat) (substrate r) (substrate r') by split;aw => //;apply: lf_function. split => //. split => // x y. move /order_product2_P; rewrite -/r' sr' - sr; move=> [xp yp [le1 le2]]. rewrite lf_V // lf_V //. move: le1 le2 => /Nat_order_leP [p1 p2 p3] /Nat_order_leP [p4 p5 p6]. by apply /Nat_order_leP;split => //; fprops; apply: csum_Mlele. set a := (J \1c \0c); set b:= (J \0c \1c). move: NS0 NS1; rewrite /natp => ns0 ns1. have asr: inc a (substrate r) by rewrite sr /a; fprops. have bsr: inc b (substrate r) by rewrite sr /b; fprops. move: (lattice_inf_pr l2 asr bsr). set c:= inf r a b. move => [] /order_product2_P [csr _ []] _ /Nat_order_leP [_ _ p1]. move => /order_product2_P [_ _ []] /Nat_order_leP [_ _ p2] _ h. have: c = J (P c) (Q c) by aw; move: csr => /setX_P []. move: p1 p2; rewrite /a /b; aw => p1 p2. rewrite (cle0 p1) (cle0 p2) => cv. rewrite sr' - sr in csr. exists a; exists b; split => //; rewrite (lf_V ta csr) cv. rewrite (lf_V ta asr) (lf_V ta bsr) !pr1_pair ! pr2_pair. rewrite (csum0r CS0) (csum0r CS1) (csum0l CS1). have osr: inc \1c (substrate r') by rewrite sr'; fprops. by rewrite inf_comparable1 //; [fprops | order_tac]. Qed. Lemma Exercise1_10_ter (r':= canonical_doubleton_order) (r := order_product2 r' r') (f := Lf (fun z => (Yo (z = J C0 C0)) C0 C1) (C2 \times C2) C2): Exercise1_10_counterexample r r' f. Proof. move: cdo_wor => [cdo sr']. have l1: lattice r' by apply: total_order_lattice;apply: worder_total. have l2: lattice r by apply: product2_lattice. move: (l1)(l2) => [or1 _][or2 _]. have ta: lf_axiom (fun z => (Yo (z = J C0 C0)) C0 C1) (C2 \times C2) C2. move => z _; simpl; Ytac ww; fprops. have sr: substrate r = C2 \times C2. by rewrite order_product2_sr// -/r' sr'. have ff: function f by apply: lf_function. set c := J C0 C0. set a := J C0 C1. set b := J C1 C0. have nac: a <> c by move => ac; move: (pr2_def ac); fprops. have nbc: b <> c by move => ac; move: (pr1_def ac); fprops. have asr: inc a (substrate r) by rewrite sr /a; fprops. have bsr: inc b (substrate r) by rewrite sr /b; fprops. have csr: inc c (substrate r) by rewrite sr /c; fprops. have ic: (inf r a b) = c. move: (lattice_inf_pr l2 asr bsr) => [] /order_product2_P [itp _ [r1 r2]] /order_product2_P [_ _ [r3 r4]] _. rewrite - (setX_pair itp). move: r1 => /cdo_gleP;case. move => [-> _]; move: r4 => /cdo_gleP; case; first by move => [-> _]. by move => [_]; rewrite/b;aw => sv; case: C0_ne_C1. by move => [_]; rewrite/b;aw => sv; case: C0_ne_C1. by move => [_];rewrite/a; aw => sv; case: C0_ne_C1. by move => [_];rewrite/a; aw => sv; case: C0_ne_C1. have fp: function_prop f (substrate r) (substrate r') by rewrite /f;split; aw. split; aw; first split => //. move=> x y; move /order_product2_P; rewrite sr'. rewrite /f;move=> [xp yp [le1 le2]]; aw. apply /cdo_gleP => //;Ytac xm; Ytac ym; try in_TP4; case: xm. rewrite - (setX_pair xp); move: le1 => /cdo_gleP; case. + move => [-> _]; move: le2 => /cdo_gleP; case. - by move => [-> _]. - by move =>[_]; rewrite ym; aw => sv; case: C0_ne_C1. - by move =>[_]; rewrite ym; aw => sv; case: C0_ne_C1. + by move =>[_]; rewrite ym; aw => sv; case: C0_ne_C1. + by move =>[_]; rewrite ym; aw => sv; case: C0_ne_C1. exists a, b; split => //. rewrite sr in asr bsr csr. rewrite ic (lf_V ta asr) (lf_V ta bsr)(lf_V ta csr). rewrite -/c; Ytac0; Ytac0; Ytac0. rewrite inf_comparable1; [fprops | fprops | order_tac; rewrite sr'; fprops]. Qed. (** ---- Exercise 1.11: complete lattice*) (** a set is a complete lattice if any set has a supremum; it then has an infimum *) Definition complete_lattice r := order r /\ forall X, sub X (substrate r) -> (has_supremum r X /\ has_infimum r X). Lemma Exercise1_11a r: complete_lattice r -> (has_greatest r /\ has_least r). Proof. move=> [or cl]. have es:(sub emptyset (substrate r)) by fprops. move: (cl _ es) => [[x xse] [y yie]]. move: xse; rewrite (lub_set0 or) => xse. move: yie; rewrite (glb_set0 or) => yie. by split; [ exists y | exists x]. Qed. Lemma Exercise1_11b r: order r -> (forall X, sub X (substrate r) -> has_supremum r X) -> complete_lattice r. Proof. move=> or h; split => //. move=> X Xsr;split;fprops. set (Z := (Zo (substrate r) (lower_bound r X))). have zs: (sub Z (substrate r)) by apply: Zo_S. move: (h _ zs) => [x] /(lubP or zs) [[xz ux] leux]. exists x;apply /(glbP or Xsr); split. split; first by exact. move=> y yX; apply: leux; split; first by apply: Xsr. by move=> t /Zo_P [_ [_]]; apply. by move => z zl; apply: ux; apply: Zo_i => //;move: zl =>[ok _]. Qed. Lemma Exercise1_11h r: order r -> (forall X, sub X (substrate r) -> has_infimum r X) -> complete_lattice r. Proof. move=> or h; split => //. move=> X Xsr;split;fprops. set (Z := (Zo (substrate r) (upper_bound r X))). have zs: (sub Z (substrate r)) by apply: Zo_S. move: (h _ zs) => [x]. move /(glbP or zs)=> [[xz ux] leux]. exists x; apply /(lubP or Xsr);split. split; first by exact. move=> y yX; apply: leux; split; first by apply: Xsr. by move=> t /Zo_hi [_]; apply. by move => z zl; apply: ux; apply: Zo_i=> //;move: zl =>[ok _]. Qed. Lemma Exercise1_11i r: complete_lattice r -> complete_lattice (opp_order r). Proof. move => [p1 p2]. move: (opp_osr p1) => [q3 q4];split => //;rewrite q4. move=> X Xs; move: (p2 _ Xs) => [[x p3] [y p4]]; split. by exists y; apply/inf_sup_oppP. by exists x; apply/sup_inf_oppP. Qed. Lemma Exercise1_11j r: total_order r -> finite_set (substrate r) -> nonempty (substrate r) -> complete_lattice r. Proof. move => tor fsr nes. move: (tor) => [or _];apply: Exercise1_11b => // X Xsr. case: (emptyset_dichot X) => xE. move: (finite_set_torder_least tor fsr nes) => [x [xsr xl]]. exists x; apply /lubP => //; split. by split =>//; rewrite xE => y /in_set0. by move => z [ze _]; apply: xl. move: (sub_finite_set Xsr fsr) => fsx. move: (finite_subset_torder_greatest tor fsx Xsr xE) => [x []]. rewrite (iorder_sr or Xsr) => xsr xg; exists x; apply /lubP => //; split. split => //; [ by apply: Xsr | move => y yX ; exact: (iorder_gle1 (xg _ yX))]. by move => z [sr]; apply. Qed. (** When is a product a complete lattice *) Lemma Exercise1_11c g: order_fam g -> (allf g complete_lattice) -> complete_lattice (order_product g). Proof. move=> alo ala. move: (order_product_osr alo) => [og Ha]. apply: Exercise1_11b => // X Xsr. set f := Lg (domain g) (fun i => substrate (Vg g i)). have fgf: fgraph f by rewrite /f; fprops. have fpri: forall i, inc i (domain g) -> function (pr_i f i). move=> i idg;apply: pri_f; rewrite /f; fprops; bw. have pf: productb f = substrate (order_product g) by rewrite Ha. pose Xi i := (Vfs (pr_i f i) X). have p1: forall i, inc i (domain g) -> sub (Xi i) (substrate (Vg g i)). move => i idg; rewrite /Xi. have <-: (target (pr_i f i) = substrate (Vg g i)) by rewrite /pr_i/f; aw; bw. apply: fun_image_Starget1; apply: (fpri _ idg). set v:= Lg (domain g) (fun i => supremum (Vg g i) (Xi i)). have v1: forall i, inc i (domain g) -> least_upper_bound (Vg g i)(Xi i)(Vg v i). move=> i idg; rewrite /v; bw; move: (ala _ idg) => [_ ila]. by move: (ila _ (p1 _ idg)) => [hs _]; apply: supremum_pr1=> //; apply: alo. have vs: (inc v (substrate (order_product g))). rewrite Ha; apply /prod_of_substratesP;rewrite /v; split;fprops;bw. move=> i idg; bw. move: (v1 _ idg) => /(lubP (alo _ idg)(p1 _ idg)). rewrite /v;bw; move => [[ok _] _] //. exists v; apply /(lubP og Xsr); split. split => // y yX; apply /order_product_gleP; rewrite -Ha;split => //. by apply: Xsr. move=> i idg; move: (v1 _ idg) => /(lubP (alo _ idg)(p1 _ idg)). move=> [[p3 p2] _]; apply: p2. have yp: inc y (productb f) by rewrite pf; apply: Xsr. have idf: inc i (domain f) by rewrite /f; bw. apply /(Vf_image_P) => //; first by apply: pri_f. by rewrite /pr_i; rewrite lf_source pf. rewrite - (pri_V idf yp); ex_tac; apply: W_pr3. move => z [zs zu]; apply /order_product_gleP => //; rewrite -Ha;split => //. move=> i idg; move: (v1 _ idg). move/ (lubP (alo _ idg)(p1 _ idg));move=> [p2]; apply. split. move: zs; rewrite -pf => /prod_of_substratesP [q1 q2 q3]. move: (q3 _ idg); bw. have sX: sub X (source (pr_i f i)) by rewrite /pr_i; aw;ue. move: (fpri _ idg) => fi. move=> y /(Vf_image_P fi sX) [u uX ->]. have up: inc u (productb f) by rewrite pf; apply: Xsr. have idf: inc i (domain f) by rewrite /f; bw. rewrite (pri_V idf up). by move: (zu _ uX) => /order_product_gleP [_ _]; apply. Qed. Lemma Exercise1_11d g: order_fam g -> complete_lattice (order_product g) -> (allf g complete_lattice). Proof. move=> poa clp i idg; move: (clp) => [p3 p4]. move: (order_product_osr poa) => [og Ha]. move: (Exercise1_11a clp)=> [[a [asg _]] _]. move: (asg); rewrite Ha => /prod_of_substratesP [fgfa da vas]. move: (poa _ idg) => o1. apply: Exercise1_11b => // X Xsr. set (Y:= Lg (domain g) (fun j=> Yo (j = i) X (singleton (Vg a j)))). have sYs: (sub (productb Y) (substrate (order_product g))). rewrite Ha /Y; apply: setXb_monotone1 => //; fprops; bw. move=> j jdg; bw; Ytac ji; [ ue |by move => t; move /set1_P ->; apply: vas]. move: (p4 _ sYs)=> [[y ys] _]; move: ys => /(lubP p3 sYs) [[ys uby] luy]. set f := Lg (domain g) (fun i => substrate (Vg g i)). have df: domain f = domain g by rewrite /f; bw. have fgf: fgraph f by rewrite /f; fprops. have pf: productb f = substrate (order_product g) by rewrite Ha. exists (Vg y i); apply /lubP => //; split. split. move: ys; rewrite Ha => /prod_of_substratesP [_ q1 q2]. move: (q2 _ idg); bw. move=> z zX. have fs: (inc (Lg (domain g)(fun j=> (Yo (j = i) z (Vg a j)))) (productb Y)). apply /setXb_P; rewrite /Y;split;fprops; bw. move=> j jdg; bw; Ytac ji; Ytac0 => //; fprops. by move: (uby _ fs)=> /order_product_gleP [_ _ h];move: (h _ idg); bw; Ytac0. move=> z [zs zu]. set w:= (Lg (domain g)(fun j=> (Yo (j = i) z (Vg a j)))). have wp: (inc w (productb f)). apply /setXb_P; rewrite /w /f; split;fprops; bw. by move=> j jdg; bw; Ytac ji; [ ue | apply: vas]. have ubw: (upper_bound (order_product g) (productb Y) w). split; first by ue. move=> t tp; apply /order_product_gleP; split => //; try ue. have pa: fgraph Y by rewrite /Y; fprops. move=> j jdg; rewrite /w; bw. move: tp=> /setXb_P; rewrite /Y;bw; move=> [_ p5 p6]. move: (p6 _ jdg); bw. Ytac ji; Ytac0; first by rewrite ji;apply: zu. by move /set1_P ->; move: (poa _ jdg) => oj; order_tac; apply: vas. move: (luy _ ubw) => /order_product_gleP [_ _ h]. move: (h _ idg); rewrite /w; bw; rewrite Y_true //. Qed. (** When is an ordinal sum a complete lattice ? *) Definition greatest_induced r X x := greatest (induced_order r X) x. Definition least_induced r X x := least (induced_order r X) x. Lemma Exercise1_11e r g: orsum_ax r g -> orsum_ax2 g -> (complete_lattice (order_sum r g) <-> [/\ complete_lattice r, (forall j, sub j (substrate r) -> ~ (exists u, greatest_induced r j u) -> has_least (Vg g (supremum r j))), (forall i x, inc i (substrate r) -> sub x (substrate (Vg g i)) -> (exists u, upper_bound (Vg g i) x u) -> nonempty x -> (exists u, least_upper_bound (Vg g i) x u)) & (forall i, inc i (substrate r) -> ~ (has_greatest (Vg g i)) -> exists v, least_induced r (Zo (substrate r) (fun j => glt r i j)) v /\ has_least (Vg g v))]). Proof. move=> oa alne; move: (oa) => [or sr alo]. set (E:= substrate r). set F:= sum_of_substrates g. have ss: substrate (order_sum r g) = F by rewrite orsum_sr. have org: order (order_sum r g) by fprops. split => bigh. pose k i := rep (substrate (Vg g i)). have kp1: forall i, inc i E -> inc (k i) (substrate (Vg g i)). rewrite /E sr; move=> i idg; apply: (rep_i (alne _ idg)). have kp2: forall i, inc i E -> inc (J (k i) i) F. move=> i idg; move: (kp1 _ idg) => ps. rewrite /F/sum_of_substrates; apply: disjoint_union_pi1 =>//; ue. have p1: (forall j, sub j E -> exists x, [/\ least_upper_bound (order_sum r g) (fun_image j (fun i => J (k i) i)) x, inc x F & least_upper_bound r j (Q x) ]). move=> j jE; set (Y:= fun_image j (fun i=> J (k i) i)). have sYF: (sub Y F). move=> t /funI_P [z zj ->]; apply: (kp2 _ (jE _ zj)). move: bigh => [og cl]; rewrite ss in cl; move: (cl _ sYF) => [[x xs] _ ]. have YS: sub Y (substrate (order_sum r g)) by rewrite ss. move:(xs) => /(lubP og YS) [[xs' ux] lux]. have xF: (inc x F) by ue. exists x; split => //; apply /(lubP or jE); split; first split. + by case: (du_index_pr1 xF); rewrite sr. + move=> y yj. have pY: (inc (J (k y) y) Y) by apply /funI_P; exists y. move: (orsum_gle_id oa (ux _ pY)); aw. + move=> z [zs ubz]. move: (kp2 _ zs) (kp1 _ zs) => zF aux. suff up1 : (upper_bound (order_sum r g) Y (J (k z) z)). move: (orsum_gle_id oa (lux _ up1)); aw. split; [by ue | move=> y yY; apply /orsum_gleP;split => // ]. move : YS yY; rewrite (orsum_sr oa);apply. move: yY => /funI_P [t tJ ->]; red; aw; case: (equal_or_not t z). by rewrite sr in zs;move:(alo _ zs)=> ot ->;right;split=> //; order_tac. by move => tz; left; split => //; apply: ubz. split. - apply: Exercise1_11b => //. by move=> X Xsr; move:(p1 _ Xsr) => [x [_ _ xs]]; exists (Q x). - move=> X Xsr ngX; move:(p1 _ Xsr) => [x [lubx xF xs]]. have sX: (least_upper_bound r X ((supremum r X))). by apply: supremum_pr1 => //; exists (Q x). rewrite (supremum_unique or sX xs). move: xs => /(lubP or Xsr) [[qxs qxl] qxlu]. have nQX: (~ inc (Q x) X). dneg Qx; exists (Q x); split; first by aw. by rewrite iorder_sr // => t tx; apply /iorder_gleP=> //; apply: qxl. exists (P x); split; first by move: (du_index_pr1 xF) => [_]. move=> t ts. have pF: (inc (J t (Q x)) F) by apply: disjoint_union_pi1 => //; ue. set T:= (fun_image X (fun i => J (k i) i)). have sT: sub T (substrate (order_sum r g)). by rewrite ss;move=> y /funI_P [z zx ->];apply: kp2; apply: Xsr. have u1: (upper_bound (order_sum r g) T (J t (Q x))). rewrite /T;split; first (by ue);move=> y /funI_P [z zX ->]. apply /orsum_gleP;split;fprops;left; aw; split; first by apply: qxl=>//. dneg zq; ue. move: lubx => /(lubP org sT) [_ aux]; move: (aux _ u1). by move => /orsum_gleP [_ _]; case; [ move=> [_] |]; aw; case. - move=> i X iE sX [u [us ub]] [t tX]. have idg: (inc i (domain g)) by ue. set (Xi := X *s1 i). have XiF: sub Xi F. move=> v /indexed_P [pv Pq Qv]. by rewrite -pv Qv; apply: disjoint_union_pi1 =>//; apply: sX. have Xs1: sub Xi (substrate (order_sum r g)) by ue. move: bigh => [og cl]; rewrite ss in cl; move: (cl _ XiF) => [[x xs] _ ]. move: xs => /(lubP org Xs1) [[xs xu] xleb]. move: (xs); rewrite ss => xs1; move: (du_index_pr1 xs1) =>[Qx Px px]. have si: forall x, inc x X -> inc (J x i) Xi by move=> w; apply:indexed_pi. have Qxi: Q x = i. have pF: (inc (J u i) F) by apply: disjoint_union_pi1 =>//. have pub: (upper_bound (order_sum r g) Xi (J u i)). split;[ ue |move => y yXi ; apply /orsum_gleP; split;fprops; right]. by move: yXi=> /indexed_P [py Py Qy];rewrite Qy; aw;split=> //;apply ub. move: (orsum_gle_id oa (xleb _ pub)). move: (orsum_gle_id oa (xu _ (si _ tX))); aw => le1 le2; order_tac. exists (P x); apply /(lubP (alo _ idg) sX); split. split;[ ue | move=> y yX; move: (xu _ (si _ yX)) =>/orsum_gleP [_ _]]. by rewrite /order_sum_r Qxi;aw;case; [move=> [_] |]; case. move => z [zs zu]. have pF: (inc (J z i) F) by apply: disjoint_union_pi1. have sz1: (upper_bound (order_sum r g) Xi (J z i)). split; [ ue | move=> y yXi; apply /orsum_gleP; split;fprops; right ]. move: yXi => /indexed_P; aw;move => [pa pb pc];split => //; by rewrite pc; apply:zu. by move: (xleb _ sz1) => /orsum_gleP [_ _] [] []; rewrite Qxi;aw. - move=> i iE nege. set (X:= (substrate (Vg g i)) *s1 i). have XF: (sub X F). move=> v /indexed_P [pv Pq Qv]. rewrite - pv Qv; apply: disjoint_union_pi1 =>//; ue. move: bigh => [og cl]; rewrite ss in cl; move: (cl _ XF) => [[x xs] _ ]. have paa: sub X (substrate (order_sum r g)) by ue. move: xs => /(lubP org paa) [[xs xu] xleb]. move: (xs); rewrite ss => xs1; move: (du_index_pr1 xs1) =>[Qx Px px]. set (Ii:=Zo E (fun j => glt r i j)). have QxI: (inc (Q x) Ii). apply /Zo_P; split; [by rewrite /E;ue | split ]. have k1: inc (J (k i) i) X by apply : indexed_pi; fprops. move: (orsum_gle_id oa (xu _ k1)); aw. dneg iqx; exists (P x); split; first by ue. move=> y yv. have pX: (inc (J y i) X) by apply :indexed_pi; fprops. by move: (xu _ pX) => /orsum_gleP [_ _] [][]; aw; rewrite -iqx. have qx1: glt r i (Q x) by move: QxI => /Zo_P[]. have IE:sub Ii E by apply: Zo_S. exists (Q x); split. rewrite /least_induced/ least; aw; split => //; move=> v vI1; aw. have: (upper_bound (order_sum r g) X (J (k v) v)). split; first by rewrite ss; apply: kp2; apply: IE. move=> y yX; apply /orsum_gleP => // ;split;fprops; left; aw. by move: yX vI1 => /indexed_P [_ _ ->] /Zo_P []. move=> aux; move: (orsum_gle_id oa (xleb _ aux)); aw => h. by apply /iorder_gleP. exists (P x); split; [ exact | move => y ys ]. have p2: (inc (J y (Q x)) F) by apply: disjoint_union_pi1 =>//. have p3: (upper_bound (order_sum r g) X (J y (Q x))). split; first (by ue); move=> z zX; apply/orsum_gleP;split;fprops;left; aw. by move: zX => /indexed_P [_ _ ->]. by move: (xleb _ p3) =>/orsum_gleP [_ _] [][];aw. move: bigh => [hI hII hIII hIV]. apply: Exercise1_11b => //. rewrite ss; move=> X Xsr. set (j:= Zo E (fun i=> exists2 x, inc x X & i = Q x)). have jE: (sub j E) by apply: Zo_S. move: hI =>[_ h]; move: (h _ jE) => [ok _]; move: (supremum_pr1 or ok). have Xs: sub X (substrate (order_sum r g)) by ue. case: (p_or_not_p (exists u, greatest_induced r j u)); last first. move=> neu; move: (hII _ jE neu). set s:= (supremum r j); move=> [v [vs lv]]; move/(lubP or jE)=> [[sE su] slu]. have nsj: (~ inc s j). dneg sj; exists s; hnf;aw; split => //;move=> x xj; apply/iorder_gleP => //. by apply: su. set (b := J v s). have bf: inc b F by apply: disjoint_union_pi1 => //; ue. exists b; apply /(lubP org Xs); split. split; [ ue | move=> t tX ; apply /orsum_gleP; split;fprops;left ]. move: (du_index_pr1 (Xsr _ tX)) => [Qtd _ _]. have Qtj: inc (Q t) j by apply: Zo_i; [ rewrite /E;ue | ex_tac ]. move: (su _ Qtj) => aux; rewrite /b; aw; split => //; dneg qts; ue. move=> z [zs zu]. move: (zs); rewrite ss /F => h'; move: (du_index_pr1 h') => [h1 h2 h3]. have ub: (upper_bound r j (Q z)). split; [ue | move=> y /Zo_P [yE [z' xX ->]]]. apply: (orsum_gle_id oa (zu _ xX)). apply /orsum_gleP; split => //; case:(equal_or_not (Q b) (Q z)) => qb. right; split => //; rewrite /b; aw; apply: lv; move: h2;rewrite -qb /b; aw. by left; split => //; rewrite /b; aw; apply: slu. move => [k]; rewrite /greatest_induced /greatest; aw; move=> [kj kp] _. have kp1: forall x, inc x X -> gle r (Q x) k. move=> x xX. suff h1: inc (Q x) j by move: (iorder_gle1 (kp _ h1)). apply: Zo_i; last by ex_tac. by move: (du_index_pr1 (Xsr _ xX)); rewrite -/E - sr; case. have Hd:forall z, upper_bound (order_sum r g) X z -> gle r k (Q z). move: kj => /Zo_P [kE [w wX ->]]. rewrite /upper_bound ss; move => z [zs zu]. by move: (orsum_gle_id oa (zu _ wX)). set (Xj:= Zo (substrate (Vg g k)) (fun y=> exists x, [/\ inc x X, y = P x & k = Q x])). have neXj: nonempty Xj. move: kj => /Zo_P [kE [w wX kw]]. exists (P w); apply /Zo_P; move: (du_index_pr1 (Xsr _ wX))=> [_ Pw _]. split; [ue | ex_tac]. case: (p_or_not_p (exists u, upper_bound (Vg g k) Xj u)) => uxi. have Xjp: (sub Xj (substrate (Vg g k))) by apply: Zo_S. have og: order (Vg g k) by apply: alo; ue. move: (hIII _ _ (jE _ kj) Xjp uxi neXj) => [u] /(lubP og Xjp) [[us uu] ule]. have pF:(inc (J u k) F) by apply: disjoint_union_pi1 =>//; ue. exists (J u k); apply /(lubP org Xs); split. split; first (by ue); move=> y yX; apply /orsum_gleP; split;fprops. move: (kp1 _ yX) => le1. red; aw; case: (equal_or_not (Q y) k) => qyk; last by left; split. right; rewrite qyk; split => //; apply: uu; apply: Zo_i; last by ex_tac. by move: (du_index_pr1 (Xsr _ yX)) => [Qy Py py];rewrite -qyk. move => z zu; move: (Hd _ zu); move: zu =>[zs uz] lkq. apply /orsum_gleP; split => //; first by rewrite -/F - ss. move: (zs); rewrite ss /F => h'; move: (du_index_pr1 h') => [h1 h2 h3]. case: (equal_or_not k (Q z)) => kqz; last by left;aw; split. right; aw;rewrite -kqz;split =>//; apply: ule; split; first by ue. move=> y /Zo_P [ys [x [xX yP kQ]]]. rewrite yP; move: (uz _ xX) => /orsum_gleP [_ _]. by rewrite /order_sum_r -kQ - kqz /glt; case; case. case: (p_or_not_p (exists u, greatest (Vg g k) u)). move=> [u [us ug]]; case: uxi; exists u; split => //. by move => y /Zo_P [ys [x [xX yP kQ]]]; apply: ug. move => ng; move: (hIV _ (jE _ kj) ng) => [v [lv [x [xs xl]]]]. move: lv; set K:= Zo E _. have Kr: sub K (substrate r) by rewrite /K; apply: Zo_S. rewrite /least_induced /least; aw; move => [] /Zo_P [vE kv] vg. have pF: (inc (J x v) F) by apply: disjoint_union_pi1 => //; ue. exists (J x v); apply /(lubP org Xs); split. split;[ ue | move=> y yX; apply /orsum_gleP; split;fprops; left ]. move: (kp1 _ yX) => aux; aw; order_tac. move=> z zu; move: (Hd _ zu)=> le1; move: zu =>[zs uz]. move: (zs); rewrite ss /F => h'; move: (du_index_pr1 h') => [h1 h2 h3]. apply /orsum_gleP;split => //; rewrite /order_sum_r; aw. have Qzk: inc (Q z) K. apply: Zo_i; [rewrite /E;order_tac | split =>//]. move=> kq; case: uxi; exists (P z); split; first by ue. move=> y /Zo_P [ys [t [tX yp kq1]]]. move: (uz _ tX) => /orsum_gleP [_ _]. case; rewrite - ? kq1 - kq - ? yp; move => [] //. have aux := (iorder_gle1 (vg _ Qzk)). case:(equal_or_not v (Q z))=> h4; [ right;split => //;apply: xl; ue | by left]. Qed. (** When is the set of increasings mappings a complete lattice ? *) Lemma Exercise1_11f r r': order r -> order r' -> nonempty (substrate r) -> complete_lattice (increasing_mappings_order r r') -> complete_lattice r'. Proof. move => or or' nes clf; apply: Exercise1_11b =>//. set (E:= substrate r); set (E':=substrate r'). move: (imo_osr r or') => [oim sr1]. move=> X XE'. set (Y:= Zo (substrate (increasing_mappings_order r r')) (fun f => exists y, exists Hy: inc y X, f = constant_function E E' y)). have Ys: (sub Y (substrate (increasing_mappings_order r r'))) by apply: Zo_S. move: clf => [_ clf']; move: (clf' _ Ys)=> [[f fs] _]. move:fs => /(lubP oim Ys). rewrite {1} /upper_bound sr1. move => [] [] /soimP [[ff sf tf] incf] fg fge. move: (nes) => [x xE]. set (u:= Vf f x). have uE' : (inc u E') by rewrite /E' /u; Wtac. exists u; apply /(lubP or' XE'); split. split => // y yE; move:(XE' _ yE) => yE'. set (g:= constant_function E E' y). have gy: (inc g Y). apply: Zo_i; first by rewrite sr1; apply: constant_increasing. by exists y; exists yE. move: (fg _ gy) => /(imo_gleP _ or') [_ _]. by move=> [[p1 p2 p3] [p4 p5 p6] p7]; move: (p7 _ xE);rewrite /g constant_V. move=> z [zs zu]. set (g:= (constant_function E E' z)). have gs: inc g (increasing_mappings r r') by apply: constant_increasing. have aux: (upper_bound (increasing_mappings_order r r') Y g). split; first by rewrite sr1. move=> y /Zo_P [ys [v [vX yc]]]. by rewrite -/g yc - constant_increasing1//; [ apply: zu | apply:XE']. move: (fge _ aux) => /(imo_gleP _ or') [_ _] [[p1 p2 p3] [p4 p5 p6] p7]. move: (p7 _ xE);rewrite /g constant_V //. Qed. Lemma Exercise1_11g r r': order r -> order r' -> complete_lattice r' -> complete_lattice (increasing_mappings_order r r'). Proof. move=> or or' clr; move: (imo_osr r or') => [ori pb]. apply: Exercise1_11b => //; rewrite pb. set (E:=substrate r); set (E':=substrate r'). move=> X Xsi. set (img:= fun x=> fun_image X (fun f => Vf f x)). have se: (forall x, inc x E -> sub (img x) E'). move=> x xE t /funI_P [z zX ->]. move: (Xsi _ zX) => /soimP [[fz sz tez] iz]. rewrite /E' -tez; apply: Vf_target => //; ue. set (f:= fun x=> supremum r' (img x)). have fp1: (forall x, inc x E -> least_upper_bound r' (img x) (f x)). move=> x xE; apply: supremum_pr1 => //. exact: (proj1 ((proj2 clr) _ (se _ xE))). have ta: (lf_axiom f E E'). by move=> t tE; move: (fp1 _ tE) => /(lubP or' (se _ tE)) [[ti _] _]. have ff: (function (Lf f E E')) by apply: lf_function. have ffj:function_prop (Lf f E E') (substrate r) (substrate r') by split; aw. have ffi: (inc (Lf f E E') (increasing_mappings r r')). apply /soimP; split => //;split;aw => x y xy. move:(arg1_sr xy)(arg2_sr xy); rewrite -/E => xE yE. rewrite /f lf_V // lf_V //. move: (se _ xE) (se _ yE) => a1 a2. move:(fp1 _ xE)(fp1 _ yE)=> /(lubP or' a1) [_ p2] /(lubP or' a2)[[h1 h2] _]. apply: p2; split=>//; move=> t /funI_P [z zX ->]. have wi: (inc (Vf z y) (img y)) by apply /funI_P; exists z. move: (h2 _ wi) => le1. move: (Xsi _ zX) => /soimP [_ [_ _ _ df]]; move: (df _ _ xy)=> le2; order_tac. have Xs: sub X (substrate (increasing_mappings_order r r')) by rewrite pb. exists (Lf f E E'); apply /(lubP ori Xs); split. split; first by rewrite pb. move=> y yX;move: (Xsi _ yX) =>/soimP [pa incy]. apply /imo_gleP => //; split; fprops; split; fprops. move=> i isr; aw; move: (se _ isr)=> sei. move:(fp1 _ isr) => /(lubP or' sei) [[_ fiu] _]; apply: fiu. apply /funI_P;ex_tac. move=> z []; rewrite pb=> zs zu; apply /imo_gleP => //; split => //. move:zs => /soimP [fpy incy]; split => // i ise; rewrite lf_V //. move: (se _ ise)=> sei; move: (fp1 _ ise) => /(lubP or' sei) [h1 h2]. move:(fpy) => [fy sy ty]. apply: h2; split; first by rewrite -ty; apply: Vf_target =>//; ue. move=> y /funI_P [t tX ->]; apply: (imo_incr or' (zu _ tX) ise). Qed. Lemma tarski1 r f: complete_lattice r -> increasing_fun f r r -> complete_lattice (induced_order r (Zo (substrate r) (fun z => Vf f z = z))). Proof. move => [or clr][_ _ [ff sf tf] incf]. set fif := Zo _ _. have fs: sub fif (substrate r) by apply: Zo_S. move: (iorder_osr or fs) => [oa sra]. apply Exercise1_11b => //; rewrite iorder_sr //. move => X xf; move: (sub_trans xf fs) => xsr. move: (supremum_pr1 or (proj1 (clr _ xsr))). set w := (supremum r X); move /(lubP or xsr) => [[pa pb] pc]. have ta: inc w (source f) by rewrite sf. have ra: gle r w (Vf f w). apply: pc; split; first by rewrite - tf; Wtac. by move => y yx; move: (xf _ yx) => /Zo_P [_ <-]; apply: incf; apply: pb. set B := Zo (substrate r) (fun t => gle r w t /\ gle r (Vf f t) t). have bsr: sub B (substrate r) by apply: Zo_S. move: (infimum_pr1 or (proj2 (clr _ bsr))). set z := (infimum r B); move /(glbP or bsr) => [[qa qb] qc]. have rb: lower_bound r B (Vf f z). split; first by rewrite - tf; Wtac. move => y yb; move: (qb _ yb) => yz; move: (incf _ _ yz) => sa. move: yb => /Zo_hi [_] sb; order_tac. move: (qc _ rb) => rc; move: (incf _ _ rc) => rd. have re: gle r w (Vf f z). have h: lower_bound r B w by split; [ order_tac | move => y /Zo_hi []]. by move: (incf _ _ (qc _ h)) => h1; order_tac. have rf: inc (Vf f z) B by apply: Zo_i; [ order_tac | split => //]. move: (qb _ rf) => rg. have rh: Vf f z = z by order_tac. have ri: inc z fif by apply: Zo_i => //; order_tac. have pd: (substrate (induced_order r fif)) = fif by rewrite iorder_sr //. have pe: sub X (substrate (induced_order r fif)) by ue. exists z; apply /(lubP oa pe); split. split; first by rewrite pd. move => y yx; apply /iorder_gleP => //; first by apply: xf. move: (pb _ yx) => yw; rewrite -rh; order_tac. move => t []; rewrite pd => sa sb; apply /iorder_gleP => //. move: (fs _ sa) => sc. apply: qb; apply: Zo_i => //; split. apply: pc;split;[by apply: fs | move => s sy; exact: (iorder_gle1 (sb _ sy))]. by move /Zo_P: sa => [_ ->]; order_tac. Qed. (** ---- Exercise 1.12: example of complete lattice *) Lemma Exercise1_12 E f: function f -> source f = E -> target f = E -> complete_lattice (sub_order (Zo (powerset E) (fun X => sub (Vfs f X) X))). Proof. move=> ff sf tf; set F:=Zo _ _. move: (sub_osr F) => [or sra]. apply: Exercise1_11b =>// X; rewrite sra => XF. have fp: sub F (powerset E) by apply: Zo_S. have XP: (sub X (powerset E)) by apply: sub_trans fp. have uE: sub (union X) E. by move=> t /setU_P [y ty yX]; move: (XP _ yX) => /setP_P; apply. exists (union X); apply: (setU_sup1 fp XF); apply: Zo_i; first by apply /setP_P. have pa: sub (union X) (source f) by ue. move=> u /(Vf_image_P ff pa) [v vu ->]. move: vu => /setU_P [y ty yX]; apply /setU_P;ex_tac. move: (XF _ yX) => /Zo_P [_]; apply; apply /(Vf_image_P ff); last by ex_tac. by rewrite sf; move: (XP _ yX) => /setP_P. Qed. (** ---- Exercise 1.13: Closures. We assume [f] increasing, [ x <= f(x)] and [f(f(x))= f(x) ]. Let [F] be the set of fix-points of [f]. It satisfies some properties and uniquely defines [f]. We consider the case: where the set is a lattice or a complete lattice *) Definition closure f r := [/\ increasing_fun f r r, (forall x, inc x (substrate r) -> gle r x (Vf f x)) & (forall x, inc x (substrate r) -> Vf f (Vf f x) = Vf f x)]. Definition upper_bounds F r x := Zo F (fun y => gle r x y). Section Exercise1_13. Variables r f: Set. Hypothesis cf: closure f r. Lemma Exercise1_13d x y: lattice r -> inc x (substrate r) -> inc y (substrate r) -> Vf f (sup r x y) = Vf f (sup r (Vf f x) (Vf f y)). Proof. move: cf => [icf c1 c2] lr xsr ysr. move: (icf) => [or or' [ff sf tf] incf]. move: (icf); rewrite Exercise1_10b // => aux; move: (aux _ _ xsr ysr). have wxs:inc (Vf f x) (substrate r) by rewrite - tf; Wtac. have wys:inc (Vf f y) (substrate r) by rewrite - tf; Wtac. move: (lattice_sup_pr lr wxs wys) => [p1 p2 _]. move: (order_transitivity or (c1 _ xsr) p1) => p3. move: (order_transitivity or (c1 _ ysr) p2) => p4. move: (lattice_sup_pr lr xsr ysr) => [_ _ aux2]. move: (aux2 _ p3 p4). set z := sup r x y; set T:= (sup r (Vf f x) (Vf f y)). move => p5 p6; move: (incf _ _ p5) (incf _ _ p6); rewrite c2; last order_tac. move=> p7 p8; order_tac. Qed. Lemma Exercise1_13c E (F := fixpoints f) : complete_lattice r -> sub E F -> inc (infimum r E) F. Proof. move: cf=> [icf c2 c3] [_ lr] EF. move: (icf) => [or or' [ff sf tf] incf]. have sF: (sub F (substrate r)) by rewrite - sf; apply: Zo_S. have sE: (sub E (substrate r)) by apply: (sub_trans EF). move: (lr _ sE) => [_ hi]; move: (infimum_pr1 or hi). set (y:= infimum r E); move /(glbP or sE)=> [[yE ylb] yglb]. have wy: (inc (Vf f y) (substrate r)) by rewrite - tf; Wtac. apply: Zo_i; first (by ue); apply: (order_antisymmetry or); last by apply: c2. apply: yglb; split => //; move=> u uE; move: (incf _ _ (ylb _ uE)). by move: (EF _ uE) => /Zo_hi ->. Qed. Lemma Exercise1_13a x (F := fixpoints f): inc x (source f) -> least (induced_order r (upper_bounds F r x)) (Vf f x). Proof. move: cf => [icf c1 c2] xsf. move: icf => [or or' [ff sf tf] incf]. have wfl: (inc (Vf f x) (upper_bounds F r x)). apply: Zo_i; last by apply: c1; ue. apply: Zo_i; [ by rewrite sf - tf; Wtac | apply: c2; ue]. have ssr: (sub (upper_bounds F r x) (substrate r)). apply: (@sub_trans F) ;[ apply: Zo_S | rewrite - sf;apply: Zo_S]. rewrite /least; aw; split => //. move=> y ysu; apply /iorder_gleP => //. move: ysu => /Zo_P [] /Zo_P [ysf Wy] xy; move: (incf _ _ xy); rewrite Wy //. Qed. End Exercise1_13. Lemma Exercise1_13b r G: order r -> sub G (substrate r) -> let g:= fun x => the_least (induced_order r (upper_bounds G r x)) in (forall x, inc x (substrate r) -> has_least (induced_order r (upper_bounds G r x))) -> (closure (Lf g (substrate r) (substrate r)) r /\ (G = fixpoints (Lf g (substrate r) (substrate r)))). Proof. move => or Gsr g gu. set (E:= substrate r). have Ha:forall x, inc x E -> sub (upper_bounds G r x) E. move=> x xE; apply: sub_trans Gsr=> //; apply: Zo_S. have pg: (forall x, inc x E-> least (induced_order r (upper_bounds G r x)) (g x)). move=> x xst; apply: the_least_pr; last by apply: gu. by apply: (proj1 (iorder_osr or _)); apply: Ha. have Hc:forall x y, inc x E -> inc y G -> gle r x y -> gle r (g x) y. move=> x y xE yG xy; move: (pg _ xE)=> []; aw;last by apply: Ha. have ys: inc y (upper_bounds G r x) by apply: Zo_i. by move=> aa bb; move: (iorder_gle1 (bb _ ys)). have Hd:forall x, inc x E -> [/\ inc (g x) E, inc (g x) G & gle r x (g x)]. move=> x xE; move: (pg _ xE)=> [p1 p2]. move: (Ha _ xE) => s1; move: p1; aw; move /Zo_P=> [q1 q2];split;fprops. have He:forall x, inc x G -> (g x) = x. move=> x xG; move: (Gsr _ xG) => xE. have xs: gle r x x by order_tac. move: (Hd _ xE) (Hc _ _ xE xG xs) => [_ _ le2] le1; order_tac. have ta: lf_axiom g E E by move=> t tE; case: (Hd _ tE). have gv: (forall x, inc x E -> Vf (Lf g E E) x = g x) by move => x xE; aw. have fp:function_prop (Lf g E E) (substrate r) (substrate r). by split;aw; apply: lf_function. split. split. split => //; aw=> x y xy. have xE: inc x E by rewrite /E; order_tac. have yE: inc y E by rewrite /E; order_tac. rewrite (gv _ xE)(gv _ yE); move: (Hd _ yE) => [p1 p2 p3]. apply: Hc => //; order_tac. by move=> x xE; rewrite (gv _ xE); case: (Hd _ xE). move=> x xE; move: (Hd _ xE) => [p1 p2 p3]. by rewrite (gv _ xE) (gv _ p1); apply: He. set_extens t. by move => tG; move: (Gsr _ tG)=> tE; apply : Zo_i => //;aw; apply: He. move => /Zo_P []; rewrite lf_source => te; aw => <-. by move: (Hd _ te) => [_ ok _]. Qed. (** ---- Exercise 1.14. Let [R] be a graph on [A x B]. For a subset [X] of [A], let [ rho(X) ] the set of elements of [B] related to all elements of [X]. For a subset [Y] of [B], let [ sigma(Y) ] the set of elements of [A] related to all elemenrts of [Y]. These mappings are decreasing, and the composition is a closure *) Lemma Exercise1_14 A B R: let rho := fun X => Zo B (fun y => forall x,inc x X -> inc (J x y) R) in let sigma := fun Y => Zo A (fun x => forall y, inc y Y -> inc (J x y) R) in let fr:=Lf rho (powerset A) (powerset B) in let fs:= Lf sigma (powerset B) (powerset A) in let iA := subp_order A in let iB := subp_order B in sub R (A \times B) -> [/\ decreasing_fun fr iA iB, decreasing_fun fs iB iA, closure (compose fs fr) iA & closure (compose fr fs) iB]. Proof. move=> rho sigma fr fs iA iB sR. have ta: (lf_axiom rho (powerset A) (powerset B)). move=> t ts; apply /setP_P; apply: Zo_S. have tb: (lf_axiom sigma (powerset B) (powerset A)). move=> t ts; apply /setP_P; apply: Zo_S. have tc: forall t, sub t A -> sub (rho t) B. by move=> t /setP_P ta1; apply /setP_P; apply: ta. have td: forall t, sub t B -> sub (sigma t) A. by move=> t /setP_P ta1; apply /setP_P; apply: tb. have ffr: (function fr) by apply: lf_function. have ffs: (function fs) by apply: lf_function. have c1: (composable fs fr) by split => //; rewrite /fs/fr; aw. have c2: (composable fr fs) by split => //; rewrite /fs/fr; aw. have fc1: (function (compose fs fr)) by fct_tac. have fc2: (function (compose fr fs)) by fct_tac. have i1: (forall u v, sub u v -> sub (rho v) (rho u)). move=> u v uv t => /Zo_P [pa pb]; apply: Zo_i => //; fprops. have i2: (forall u v, sub u v -> sub (sigma v) (sigma u)). move=> u v uv t => /Zo_P [pa pb]; apply: Zo_i => //; fprops. have i3: (forall u v, sub u v -> sub (sigma (rho u)) (sigma (rho v))). by move=> u v uv; apply: i2; apply: i1. have i4: (forall u v, sub u v -> sub (rho (sigma u)) (rho (sigma v))). by move=> u v uv; apply: i1; apply: i2. move: (subp_osr A) (subp_osr B)=> [oA sA] [oB sB]. have pa:decreasing_fun fr iA iB. split => //; rewrite /fr; aw; first by split; aw. move=> x y /subp_gleP [xA yA xy]; aw; try apply /setP_P => //. apply /subp_gleP;split;fprops. have pb:decreasing_fun fs iB iA. split => //; rewrite /fs; aw; first by split; aw. move=> x y /subp_gleP [xA yA xy]; aw; try apply /setP_P => //. apply /subp_gleP;split;fprops. have Ha: forall x, sub x A -> sub x (sigma (rho x)). move=> x xA t tx; apply: Zo_i; first by apply: xA. by move=> y /Zo_P [yB h]; apply: h. have Hb: forall x, sub x B -> sub x (rho (sigma x)). move=> x xA t tx; apply:Zo_i; first by apply: xA. by move=> y /Zo_P [yB h]; apply: h. have ic1: (increasing_fun (compose fs fr) iA iA). split => //; rewrite /fr/fs; aw; first by split; aw. move=> x y /subp_gleP [xA yA xy]. have sa: inc x (powerset A) by apply /setP_P. have sb: inc y (powerset A) by apply /setP_P. aw; first (by apply /subp_gleP;split;fprops); by aw; apply: ta. have ic2: (increasing_fun (compose fr fs) iB iB). split => //; rewrite /fr/fs; aw; first by split; aw. move=> x y /subp_gleP [xA yA xy]. have sa: inc x (powerset B) by apply /setP_P. have sb: inc y (powerset B) by apply /setP_P. aw; first (by apply /subp_gleP;split;fprops); by aw; apply: tb. split => //; split => //. + move=> x; rewrite sA => xA; move: (xA); move /setP_P => xA'. rewrite /fr; aw; rewrite /fs;aw; last by apply: ta. apply /subp_gleP;split => //;[ by apply: td; apply: tc | by apply: Ha]. + rewrite sA;move=> x xA; set y := Vf (fs \co fr) x. move: (xA) => /setP_P xA'. have xs: inc x (source fr) by rewrite /fr; aw. have yv: (y = sigma (rho x)). by rewrite /y; aw; rewrite /fr;aw; rewrite /fs;aw; apply: ta. have yA: sub y A by rewrite yv;apply: td; apply: tc. move : (yA) => /setP_P => yA'. have ys: inc y (source fr) by rewrite /fr; aw. aw; rewrite /fr;aw; rewrite /fs;aw; last by apply: ta. suff ->: (rho y = rho x) by symmetry. by rewrite yv;apply: extensionality; [apply: i1; apply: Ha | apply: Hb; apply: tc]. + move=> x; rewrite sB => xB; move: (xB); move /setP_P => xB'. aw; rewrite /fs; aw; rewrite /fr;aw; last by apply: tb. apply /subp_gleP;split => //;[ by apply: tc; apply: td | by apply: Hb]. + rewrite sB;move=> x xB; set y := Vf (fr \co fs)x. move: (xB) => /setP_P xB'. have xs: inc x (source fs) by rewrite /fs; aw. have yv: (y = rho (sigma x)). by rewrite /y; aw; rewrite /fr;aw; rewrite /fs;aw; apply: tb. have yB: sub y B by rewrite yv;apply: tc; apply: td. move : (yB) => /setP_P => yB'. have ys: inc y (source fs) by rewrite /fs; aw. aw; rewrite /fs;aw; rewrite /fr;aw; last by apply: tb. suff ->: (sigma y = sigma x) by symmetry. by rewrite yv;apply: extensionality; [apply: i2; apply: Hb | apply: Ha; apply: td]. Qed. (** ---- Exercise 1.15. Let [sigma(X)] and [rho(X)] be the set of lower and upper bounds of [X]. Let [f = sigma o rho] this is a closure. The set of fix-points is a complete lattice (ordered by inclusion) and is called the completion. *) Definition up_bounds r X := Zo (substrate r)(fun z => upper_bound r X z). Definition lo_bounds r X := Zo (substrate r)(fun z => lower_bound r X z). Definition uplo_bounds r X := lo_bounds r (up_bounds r X). Definition completion r:= Zo (powerset(substrate r)) (fun z => z = uplo_bounds r z). Definition completion_order r := sub_order (completion r). Lemma Exercise1_15a1 r A B: sub A B -> sub (up_bounds r B) (up_bounds r A). Proof. move => AB t /Zo_P [tsr [_ p2]]; apply /Zo_i => //. by split=> //; move=> y yA; apply: p2; apply: AB. Qed. Lemma Exercise1_15a2 r A B: sub A B -> sub (lo_bounds r B) (lo_bounds r A). Proof. move => AB t /Zo_P [tsr [_ p2]]; apply /Zo_i => //. by split=> //; move=> y yA; apply: p2; apply: AB. Qed. Lemma Exercise1_15a3 r A B: sub A B -> sub (uplo_bounds r A) (uplo_bounds r B). Proof. by move=> AB; apply: Exercise1_15a2; apply: Exercise1_15a1. Qed. Lemma Exercise1_15a4 r A: sub A (substrate r) -> sub A (uplo_bounds r A). Proof. move=> Asr t tA; move: (Asr _ tA)=> tsr;apply: Zo_i => //. by split => //; move=> y /Zo_hi [_]; apply. Qed. Lemma Exercise1_15a5 r A: sub A (substrate r) -> lo_bounds r (up_bounds r (lo_bounds r A)) = (lo_bounds r A). Proof. move=> Asr; apply: extensionality. apply: Exercise1_15a2; move=> t tA; move: (Asr _ tA) => tsr;apply: Zo_i =>//. by split => //; move=> y /Zo_hi [_]; apply. apply: Exercise1_15a4; apply: Zo_S. Qed. Lemma Exercise1_15a6 r A: sub A (substrate r) -> uplo_bounds r (uplo_bounds r A) = (uplo_bounds r A). Proof. move=> Asr; rewrite /uplo_bounds Exercise1_15a5 /up_bounds//. apply: Zo_S. Qed. Lemma Exercise1_15a7 r A: sub A (substrate r) -> inc (uplo_bounds r A) (completion r). Proof. move=> Asr; apply: Zo_i; first by apply /setP_P; apply: Zo_S. by rewrite Exercise1_15a6. Qed. Lemma Exercise1_15a8 r A: sub A (substrate r) -> inc (lo_bounds r A) (completion r). Proof. move=> Asr; apply: Zo_i; first by apply /setP_P; apply: Zo_S. rewrite /uplo_bounds Exercise1_15a5 //. Qed. Section Exercise1_15. Variable r:Set. Hypothesis or: order r. Lemma Exercise1_15a9 x y: inc x (substrate r) -> inc y (substrate r) -> (lo_bounds r (singleton x) = lo_bounds r (singleton y)) -> x = y. Proof. move=> xsr ysr h. have : (inc x (lo_bounds r (singleton y))). by rewrite -h; apply: Zo_i => //; split => // u /set1_P ->; order_tac. have : (inc y (lo_bounds r (singleton x))). by rewrite h; apply: Zo_i => //; split => // v /set1_P ->; order_tac. move => /Zo_hi [_ p1] /Zo_hi [_ p2]. move: (p1 _ (set1_1 x)) (p2 _ (set1_1 y)) => q1 q2; order_tac. Qed. Lemma Exercise1_15a10 e: least r e -> least (completion_order r) (singleton e). Proof. move=> [es le]. have oc :order (completion_order r) by rewrite /completion_order; fprops. have sr: substrate (completion_order r) = completion r. by rewrite /completion_order (proj2(sub_osr _)). have sse: (sub (singleton e) (substrate r)) by move => t /set1_P ->. have se: inc (singleton e) (completion r). apply: Zo_i; first by apply /setP_P. apply: extensionality; first by apply: Exercise1_15a4. move=> t /Zo_P [tsr [_ h]]; apply /set1_P. apply: (order_antisymmetry or); last by apply: le. by apply: h; apply: Zo_i => //; split => // y /set1_P ->; order_tac. red; rewrite sr; split => //. move=> x xr; apply /sub_gleP;split => // s /set1_P ->. move: xr => /Zo_P [] /setP_P h ->; apply: Zo_i => //. by split => //; move=> y => /Zo_P [ ysr _]; apply: le. Qed. Lemma Exercise1_15a11: ~ (has_least r) -> least (completion_order r) emptyset. Proof. move=> nle. have oc :order (completion_order r) by rewrite /completion_order; fprops. have sr: substrate (completion_order r) = completion r. by rewrite /completion_order (proj2(sub_osr _)). have te: inc emptyset (completion r). apply: Zo_i; first by apply /setP_P; fprops. symmetry;apply /set0_P; move=> y; dneg yu; exists y. move: yu => /Zo_P [ysr [_ yp]]; split => //. move=> x xst; apply: yp;apply: Zo_i=> //; split => //. by move=> t /in_set0. red;rewrite sr; split => // x xsr;apply /sub_gleP;split;fprops. Qed. Lemma Exercise1_15a12 : has_least (completion_order r). Proof. case: (p_or_not_p (has_least r)). by move=> [e le]; exists (singleton e); apply: Exercise1_15a10. by exists emptyset; apply: Exercise1_15a11. Qed. Lemma Exercise1_15a13: greatest (completion_order r) (substrate r). Proof. have sc: (inc (substrate r) (completion r)). apply: Zo_i; first by aw; apply :setP_Ti. apply: extensionality; [ apply: Exercise1_15a4; fprops | apply: Zo_S]. red; rewrite /completion_order; rewrite (proj2 (sub_osr _)). by split => // x xr; apply /sub_gleP;split => //; move: xr =>/Zo_P [] /setP_P. Qed. Lemma Exercise1_15a14 X: sub X (completion r) -> least_upper_bound (completion_order r) X (uplo_bounds r (union X)). Proof. move=> Xc. have oc :order (completion_order r) by rewrite /completion_order; fprops. have sr: substrate (completion_order r) = completion r. by rewrite /completion_order (proj2(sub_osr _)). set (v := uplo_bounds r (union X)). have vc:inc v (completion r). apply: Exercise1_15a7; move => t /setU_P [y ty yX]. by move: (Xc _ yX) => /Zo_P [] /setP_P ysr _; apply: ysr. move: (Xc);rewrite - sr => Xc';apply /(lubP oc Xc'); split. split; first (by ue); move=> y yX; rewrite /completion_order; aw. apply /sub_gleP;split => //; first by apply:Xc. by move:(Xc _ yX) => /Zo_P [ysr] ->; apply: Exercise1_15a3; apply: setU_s1. move=> z []; rewrite sr => zc h; rewrite /completion_order; aw. move: zc => /Zo_P [] /setP_P zr ->; rewrite /v. apply /sub_gleP;split;fprops; first by apply: Exercise1_15a7. apply: Exercise1_15a3; move=> t /setU_P [y ty yX]. by move: (h _ yX) => /sub_gleP [_ _]; apply. Qed. Lemma Exercise1_15a15 X: sub X (completion r) -> nonempty X -> greatest_lower_bound (completion_order r) X (uplo_bounds r (intersection X)). Proof. move=> Xc neX. have oc: order (completion_order r) by rewrite /completion_order; fprops. have sr: substrate (completion_order r) = completion r. by rewrite /completion_order (proj2(sub_osr _)). set (v := uplo_bounds r (intersection X)). have vc: (inc v (completion r)). move: neX => [x xX]; move: (Xc _ xX) =>/Zo_P [] /setP_P xsr _. apply: Exercise1_15a7; move=> t ti; move: (setI_hi ti xX); apply: xsr. move: (Xc);rewrite - sr => Xc';apply /(glbP oc Xc'); split. split; first (by ue); move=> y yX; rewrite /completion_order; aw. move:(Xc _ yX) => /Zo_P [] /setP_P ysr ->. apply /sub_gleP;split => //; first by apply : Exercise1_15a7. by apply: Exercise1_15a3; apply :setI_s1. move=> z []; rewrite sr => zc h; apply /sub_gleP; split => //. move: zc => /Zo_P [] /setP_P zr ->. apply: Exercise1_15a3; move=> t tz; apply: (setI_i neX). by move => y yX; move: (h _ yX) => /sub_gleP [_ _]; apply. Qed. Lemma Exercise1_15a16: complete_lattice (completion_order r). Proof. apply: Exercise1_11b; first by rewrite /completion_order; fprops. rewrite {1} /completion_order (proj2(sub_osr _)). by move=> X Xsr; exists (uplo_bounds r (union X)); apply:Exercise1_15a14. Qed. (** [x -> sigma (singleton x)] is an order isomorphism of [E] into a subset of its completion *) Lemma Exercise1_15a17: lf_axiom (fun z => lo_bounds r (singleton z)) (substrate r) (substrate (completion_order r)). Proof. move=> t tsr; rewrite /completion_order (proj2(sub_osr _)). by apply: Exercise1_15a8; apply: set1_sub. Qed. Lemma Exercise1_15a18a x: inc x (substrate r) -> (inc x (lo_bounds r (singleton x))). Proof. by move=> xsr; apply: Zo_i => //; split => //;move=> u /set1_P ->; order_tac. Qed. Lemma Exercise1_15a18: order_morphism (Lf (fun z => lo_bounds r (singleton z)) (substrate r) (substrate (completion_order r))) r (completion_order r). Proof. move: (Exercise1_15a17). rewrite /order_morphism/completion_order (proj2(sub_osr _)) => ta. split => //; first by fprops. split; aw;apply: lf_function => //. hnf; aw;move=> x y xsr ysr; aw; split. move => xy => //; apply /sub_gleP;split;fprops. move=> t /Zo_P [tsr [_ ts]]; apply :Zo_i => //. move: (ts _ (set1_1 x)) => tx. split => //;move=> u /set1_P ->; order_tac. move /sub_gleP => [_ _ h]; move: (h _ (Exercise1_15a18a xsr)). move/Zo_hi => [_]; apply; fprops. Qed. Lemma Exercise1_15a19 X x: sub X (substrate r) -> least_upper_bound r X x -> least_upper_bound (completion_order r) (fun_image X (fun z => lo_bounds r (singleton z))) (lo_bounds r (singleton x)). Proof. move=> Xsr /(lubP or Xsr) [[xX xu] xlu]. set Y:= fun_image X _ . have Yc: (sub Y (completion r)). move=> y /funI_P [z zX ->]; apply: Exercise1_15a8. by move=> t /set1_P ->; apply: Xsr. set (t := lo_bounds r (singleton x)). suff : t = uplo_bounds r (union Y). move=> ->;apply: (Exercise1_15a14 Yc). have p1: (sub (union Y) t). move=> u /setU_P [y uy yY]. move: yY => /funI_P [z zX slb]. move: uy; rewrite slb; move /Zo_P => [usr [_ ulb]]. move: (ulb _ (set1_1 z)) (xu _ zX) => le1 le2. rewrite /t; apply: Zo_i=> //; split => //; move => v /set1_P ->; order_tac. symmetry;apply: extensionality. move: (Exercise1_15a5 (set1_sub xX)). by rewrite -/t;move => <-; apply: Exercise1_15a3. move=> u => /Zo_P[usr [_ leu]]; move: (leu _ (set1_1 x)). move=> ux; apply: Zo_i => //; split => //. move=> y /Zo_P [ysr [_ yu]]. suff: (gle r x y) by move=> xy; order_tac. apply: xlu; split => // v vX; apply: yu. apply: (@setU_i _ (lo_bounds r (singleton v))). by apply: Exercise1_15a18a => //; apply: Xsr. apply /funI_P; ex_tac. Qed. Lemma Exercise1_15a20 X x: sub X (substrate r) -> greatest_lower_bound r X x -> greatest_lower_bound (completion_order r) (fun_image X (fun z => lo_bounds r (singleton z))) (lo_bounds r (singleton x)). Proof. move=> Xsr /(glbP or Xsr) [[xX xu] xlu]. set Y:= fun_image X _ . have Yc: (sub Y (completion r)). move=> y /funI_P [z zX ->]; apply: Exercise1_15a8. by move=> t /set1_P ->; apply: Xsr. have oc: order (completion_order r) by rewrite /completion_order; fprops. have sr: substrate (completion_order r) = completion r. by rewrite /completion_order (proj2(sub_osr _)). case: (emptyset_dichot Y) => ye. have xE: (X = emptyset). apply /set0_P => u uX; case: (in_set0 (x:=lo_bounds r (singleton u))). rewrite -ye; apply /funI_P; ex_tac. have -> :(lo_bounds r (singleton x) = substrate r). apply: extensionality; first by apply: Zo_S. move=> t tsr; apply: Zo_i =>//; split => //;move=> y /set1_P ->; apply: xlu. by split => //; rewrite xE; move=> u /in_set0. rewrite ye glb_set0 //; exact: Exercise1_15a13. set (t := lo_bounds r (singleton x)). suff : t = uplo_bounds r (intersection Y). move=> ->;apply: (Exercise1_15a15 Yc ye). have p1: (sub t (intersection Y)). move=> u ut; apply: setI_i =>// y /funI_P [z zX slb]. move: ut => /Zo_P [usr [_ aux]]; move: (aux _ (set1_1 x)) => leux. rewrite slb; apply: Zo_i => //; split => //; move=> v /set1_P ->. move: (xu _ zX) => xz; order_tac. apply: extensionality. move: (Exercise1_15a5 (set1_sub xX)). by rewrite -/t;move => <-; apply: Exercise1_15a3. move=> u /Zo_P [usr [_ leu]]. apply: Zo_i => //; split =>//y /set1_P ->; apply: xlu; split => //. move=> v vX; move: (Xsr _ vX) => vs; apply: leu; apply: Zo_i => //;split => //. have aux: (inc (lo_bounds r (singleton v)) Y) by apply/funI_P;ex_tac. move=> w wi; move: (setI_hi wi aux) => /Zo_P [wsr[_ q]]. apply: (q _ (set1_1 v)). Qed. Lemma Exercise1_15b1 X: sub X (substrate r) -> least_upper_bound (completion_order r) (fun_image X (fun z => lo_bounds r (singleton z))) (uplo_bounds r X). Proof. move=> Xsr. set Y:= fun_image X _ . have Yc: (sub Y (completion r)). move=> y /funI_P [z zX ->]; apply: Exercise1_15a8. by move=> t /set1_P ->; apply: Xsr. suff: (uplo_bounds r (union Y) = uplo_bounds r X). by move <-; apply: Exercise1_15a14. set_extens t; move /Zo_P => [tsr [_ tp]]; apply: Zo_i => //; split => //; move=> y /Zo_P [ysr [_ uy]]; apply: tp; apply: Zo_i => //; split => // u. move /setU_P => [v vy] /funI_P [z zX vp]. move: vy; rewrite vp => /Zo_P [usr [_ aux]]. move: (aux _ (set1_1 z)) (uy _ zX) => le1 le2; order_tac. move => ux;apply: uy; apply: (@setU_i _ (lo_bounds r (singleton u))). apply: (Exercise1_15a18a (Xsr _ ux)). apply /funI_P; ex_tac. Qed. End Exercise1_15. Lemma Exercise1_15c r: total_order r -> total_order (completion_order r). Proof. move: (sub_osr (completion r)) => [pa pb] [or tor]. split => //; rewrite pb => x y xc yc. have aux: (forall x a b, inc x (completion r) -> inc a x -> gle r b a -> inc b x). move=> v a b => /Zo_P [vsr hv]. rewrite hv => /Zo_P [asr [_ lb]] ab; apply: Zo_i; first by order_tac. split; [ by order_tac | move=> w wl; move: (lb _ wl) => aw; order_tac ]. case: (p_or_not_p (sub x y)) => h; [left | right]; apply /sub_gleP;split => //. move => t ty; ex_middle tx; case: h; move=> z zx; ex_middle zy. have tsr: inc t (substrate r) by move: yc =>/Zo_P [] /setP_P ysr _; apply: ysr. have zsr: inc z (substrate r) by move: xc =>/Zo_P [] /setP_P ysr _; apply: ysr. case: (tor _ _ tsr zsr) => ctz. case: tx; exact: (aux _ _ _ xc zx ctz). exact: (aux _ _ _ yc ty ctz). Qed. Lemma Exercise1_15b2 (E := tripleton \0c \1c \2c) (r1 := diagonal E \cup doubleton (J \0c \2c) (J \1c \2c)) (r2 := Nint_cco \0c \2c) (f := identity E): [/\ [/\ order r1, substrate r1 = E & completion r1 = (doubleton (singleton \0c) (singleton \1c)) \cup (doubleton emptyset E)], complete_lattice r2, substrate r2 = E, increasing_fun f r1 r2 & ~(exists g, [/\ (increasing_fun g (completion_order r1) r2), (forall t, inc t E -> Vf f t = Vf g (lo_bounds r1 (singleton t)))& (forall Z, sub Z (completion r1) -> Vf g (supremum (completion_order r1) Z) = supremum r2 (Vfs g Z))])]. Proof. set goal1 := [/\ _, _ & _]. set goal := [/\ _, _ , _ , _ & _]. have diag1: forall t, inc t E -> inc (J t t) (diagonal E). move => t te; apply /diagonal_pi_P; split => //. have gr1: sgraph r1. move => t; case/setU2_P; first by move => /diagonal_i_P []. case /set2_P => ->; fprops. have r1_gle: forall a b, inc (J a b) r1 -> [\/ (a = b /\ inc a E), (a = \0c /\ b = \2c) | (a = \1c /\ b = \2c)]. move => a b; case /setU2_P. by move /diagonal_pi_P => [pa pb]; constructor 1; split. case /set2_P =>h; rewrite (pr1_def h) (pr2_def h); in_TP4. have r1_refl: forall t, inc t E -> inc (J t t) r1. by move => t te; apply /setU2_P; left; apply: diag1. have sr1: substrate r1 = E. set_extens t; last by move => /r1_refl tt; substr_tac. case/(substrate_P gr1) => [] [y yi]; case: (r1_gle _ _ yi); case=> //. + by move => -> _; apply /set3_P; in_TP4. + by move => -> _; apply /set3_P; in_TP4. + by move => ->. + by move => _ ->; apply /set3_P; in_TP4. + by move =>_ -> ; apply /set3_P; in_TP4. have or1: order r1. split => //. red;rewrite sr1 //. move => y x z; rewrite /related => ta tb. case: (equal_or_not x y); [by move => -> | move => xny]. case: (equal_or_not y z); [by move => <-| move => ynz]. apply /setU2_P; right; apply /set2_P. case: (r1_gle _ _ tb) =>[] [yv hh'];first (by case: ynz); rewrite hh'. by case: (r1_gle _ _ ta) =>[] [hh yv'] => //;rewrite hh; [left | right]. case: (r1_gle _ _ ta) =>[] [hh yv'];first (by case: xny); rewrite hh;fprops. move => x y; rewrite /related => ta tb. case: (r1_gle _ _ ta); first (by move => [-> _]); move => [ta1 ta2]. case: (r1_gle _ _ tb); first (by move => [<- _]); move => [tb1 tb2]. by rewrite ta1 tb1. by rewrite ta2 tb2. case: (r1_gle _ _ tb); first (by move => [<- _]); move => [tb1 tb2]. by rewrite ta2 tb2. by rewrite ta1 tb1. move: NS2 => bs2. move: clt_12 => lt12. have le12: (\1c <=c \2c) by move: lt12 => []. have E0: inc \0c E by apply /set3_P; in_TP4. have E1: inc \1c E by apply /set3_P; in_TP4. have E2: inc \2c E by apply /set3_P; in_TP4. pose rho := up_bounds r1. pose sigma:= lo_bounds r1. set d01 := doubleton \0c \1c;set d02 := doubleton \0c \2c. set d12 := doubleton \1c \2c. set s0 := singleton \0c;set s1 := singleton \1c;set s2 := singleton \2c. have rho1: forall x, sub x E -> inc \2c (rho x). move => x xE; apply /Zo_P; rewrite sr1; split => //; split; first by ue. move => y yx;apply /setU2_P. move: (xE _ yx) =>/ set3_P; case => ->;[right | right | left ]; fprops. have rho2: rho emptyset = E. set_extens t; first by move => /Zo_P []; rewrite sr1. by rewrite - sr1; move => te; apply : Zo_i => //; split => // y /in_set0. have rho3: forall x, sub x E -> inc \2c x -> rho x = s2. move => x xE x2; apply: set1_pr; first by apply: rho1. move => z /Zo_P; rewrite sr1; move =>[ te [_ ts]]; move: (ts _ x2) => h. case: (r1_gle _ _ h) => [][] //. have rho4: rho d01 = s2. apply: set1_pr; first by apply: rho1; move => s /set2_P [] ->. move => z /Zo_P []; rewrite sr1; move => pa [_ pb]. case/set3_P:pa => tv //. move: (pb _ (set2_2 \0c \1c)) => aux. move: (r1_gle _ _ aux); rewrite tv. case=>[] [ha hb] //; by case: card1_nz. move: (pb _ (set2_1 \0c \1c)) => aux. move: (r1_gle _ _ aux); rewrite tv. by case => [] [] //; move => h _; case: card1_nz. have rho5: rho s0 = d02. rewrite /d02;set_extens t; last first. case /set2_P => ->; last by apply: rho1; apply: set1_sub. apply: Zo_i; [ue | split; [ ue | move => s /set1_P ->]]. by rewrite - sr1 in E0; order_tac. move /Zo_P => [ta [_ tb]]; move: (tb _ (set1_1 \0c)) => aux. case: (r1_gle _ _ aux);first (move => [-> _]; fprops); move => [_ ->]; fprops. have rho6: rho s1 = d12. rewrite /d12;set_extens t; last first. case /set2_P => ->; last by apply: rho1; apply: set1_sub. apply: Zo_i; [ue | split; [ ue | move => s /set1_P ->]]. by rewrite - sr1 in E1; order_tac. move => /Zo_P [ta [_ tb]]; move: (tb _ (set1_1 \1c)) => aux. case: (r1_gle _ _ aux);first (move => [-> _]; fprops);move => [_ -> ]; fprops. have sig1: forall x, sub x E -> inc \1c x -> (~ inc \0c (sigma x) /\ ~ inc \2c (sigma x)). move => x xe x1; split; move /Zo_P=> [ta [_ tb]]. case: (r1_gle _ _ (tb _ x1)); move => [h1 h2]; [by case: card1_nz |by case: (proj2 lt12) |by case: (proj2 lt12) ]. by case: (r1_gle _ _ (tb _ x1)) => [] [h1 h2]; case: (proj2 lt12). have sig2: forall x, sub x E -> inc \0c x -> (~ inc \1c (sigma x) /\ ~ inc \2c (sigma x)). move => x xe x1; split; move /Zo_P => [ta [_ tb]]. case: (r1_gle _ _ (tb _ x1)); move => [h1 h2]; first (by case: card1_nz); by case: card2_nz. by case: (r1_gle _ _ (tb _ x1))=> [] [h1 h2]; case: card2_nz. have sig0: forall x, sub (sigma x) E. by move => x t /Zo_P; rewrite sr1; move => []. have sig3: sigma E = emptyset. apply /set0_P=> t ts. move: (sig1 _ (@sub_refl E) E1) => [pa pb]. move: (sig2 _ (@sub_refl E) E0) => [pc _]. by move: (sig0 _ _ ts) => /set3_P [] ta; [case: pa | case: pc | case: pb ]; rewrite - ta. have sig4: sigma d12 = s1. have sdE: sub d12 E by move => t /set2_P [] ->. move: (sig1 _ sdE (set2_1 \1c \2c)) => [ta tb]. apply: set1_pr. apply: Zo_i; [ by rewrite sr1 | split; first by rewrite sr1]. move => y; case/set2_P => ->; first by apply: r1_refl. apply /setU2_P; right; fprops. move=> t ts; move: (sig0 _ _ ts)=> /set3_P [] //H; [ case: ta| case: tb]; ue. have sig5: sigma d02 = s0. have sdE: sub d02 E by move => t /set2_P [] ->. move: (sig2 _ sdE (set2_1 \0c \2c)) => [ta tb]. apply: set1_pr. apply: Zo_i; [ by rewrite sr1 | split; first by rewrite sr1]. move => y;case/set2_P => ->; first by apply: r1_refl. apply /setU2_P; right; fprops. move=> t ts; move:(sig0 _ _ ts)=> /set3_P [] //H; [ case: ta | case: tb]; ue. have sig7: sigma s0 = s0. have sdE: sub s0 E by move => t /set1_P ->. move: (sig2 _ sdE (set1_1 \0c)) => [ta tb]. apply: set1_pr. apply: Zo_i; [ by rewrite sr1 | split; first by rewrite sr1]. move => y /set1_P ->; by apply: r1_refl. move => t ts; move:(sig0 _ _ ts) => /set3_P [] //tz;[case: ta |case: tb];ue. have sig8: sigma s1 = s1. have sdE: sub (singleton \1c) E by move => t /set1_P ->. move: (sig1 _ sdE (set1_1 \1c)) => [ta tb]. apply: set1_pr. apply: Zo_i; [ by rewrite sr1 | split; first by rewrite sr1]. move => y /set1_P ->; by apply: r1_refl. move=> t ts; move:(sig0 _ _ ts)=> /set3_P [] // h; [case: ta | case: tb]; ue. have sig6: sigma s2 = E. apply: extensionality => // t tE; apply /Zo_P; rewrite/lower_bound sr1. split => //; split => // y /set1_P ->;move: tE => /set3_P;case. move => ->; apply /setU2_P; right; fprops. by move => ->; apply /setU2_P; right; fprops. move => ->; by apply: r1_refl. have cpr1: completion r1 = doubleton s0 s1 \cup doubleton emptyset E. set_extens t. move /Zo_P => [] /setP_P; rewrite sr1 /uplo_bounds. move => tE; rewrite -/rho -/sigma => ts; apply /setU2_P; move: ts. case: (p_or_not_p (inc \2c t)) => t2. move: (rho3 _ tE t2) ->; rewrite sig6 => ->; right; fprops. case: (inc_or_not \1c t) => t1; case: (inc_or_not \0c t) => t0. + suff ta: t = d01 by rewrite {2} ta rho4 sig6 => ->; right; fprops. set_extens s; last by case/set2_P => ->. move => st; case/set3_P: (tE s st) => h; rewrite h; fprops. by case: t2; ue. + suff ta: t = s1 by rewrite {2} ta rho6 sig4 => ->; left; fprops. apply: set1_pr => // s st; case/set3_P: (tE _ st) => sa //. case: t0; ue. case: t2; ue. + suff ta: t = s0 by rewrite {2} ta rho5 sig5; move ->; left; fprops. apply: set1_pr => // s st; case /set3_P: (tE _ st) => si //. case: t1; ue. case: t2; ue. + suff ta: t = emptyset by rewrite{2} ta rho2 sig3;move=> ->; right;fprops. apply /set0_P => s st;case/set3_P: (tE _ st) => si; [case: t0; ue |case: t1; ue | case: t2; ue]. move => h; apply /Zo_P; rewrite sr1 /uplo_bounds -/rho. case/setU2_P: h; case/set2_P => ->. + split; [ by apply /setP_P;apply: set1_sub | by rewrite rho5 ]. + split; [ by apply /setP_P; apply: set1_sub | by rewrite rho6 ]. + split; [ apply /setP_P;fprops | by rewrite rho2 ]. + split; [ apply /setP_P;fprops |by rewrite (rho3 _ (@sub_refl E) E2)]. have gal1T: goal1 by split. have tor2: total_order r2. move: (proj1(Ninto_wor \0c \2c)); apply: worder_total. move: (proj1 tor2) => or2. have sr2': Nintcc \0c \2c = E. set_extens t. move /(NintcP NS2)=> ts. case: (equal_or_not t \2c) => nt2; first by rewrite nt2. by case: (clt2 (conj ts nt2)) => ->. move => h; apply /(NintcP NS2). case/set3_P: h => ->; fprops. have sr2: substrate r2 = E by rewrite (proj2(Ninto_wor \0c \2c)). have r2_gleP: forall x y, gle r2 x y <-> [/\ inc x E, inc y E & x <=c y]. move => x y; by move: (Ninto_gleP \0c \2c x y); rewrite sr2'. have cl2: complete_lattice r2. apply: Exercise1_11j => //; rewrite sr2; last by ex_tac. by rewrite - sr2'; apply finite_Nintcc. have icf: increasing_fun f r1 r2. split => //. rewrite /f sr1 sr2; apply: identity_prop. move => x y le1. rewrite identity_V; last by rewrite - sr1; order_tac. rewrite identity_V; last by rewrite - sr1; order_tac. have xE: inc x E by rewrite - sr1; order_tac. have yE: inc y E by rewrite - sr1; order_tac. apply /r2_gleP; split => //; move: (r1_gle _ _ le1); case. move => [-> _]; apply: cleR; case/set3_P: yE; move => ->; fprops. move: xE; rewrite - sr2'; bw => le2. move => [-> ->]; fprops. move => [-> ->]; fprops. split => // [] [g [incrg cpgf cgs]]. move: (cpgf _ E0); rewrite /f (identity_V E0) -/sigma sig7 => g0. move: (cpgf _ E1); rewrite /f (identity_V E1) -/sigma sig8 => g1. move: (cpgf _ E2); rewrite /f (identity_V E2) -/sigma sig6 => g2. set Z := doubleton s0 s1. have Zd: sub Z (completion r1). rewrite cpr1; apply: sub_set2; apply /setU2_P; left; fprops. move: (esym (cgs _ Zd)). move: incrg => [_ _ [fg srcg trgg _]]. move: (proj2 (sub_osr (completion r1))) => hh. have zg1: sub Z (substrate (completion_order r1)) by ue. have ->: (Vfs g Z) = d01. have esg: sub Z (source g) by ue. set_extens t. move /(Vf_image_P fg esg)=> [u uz ->]; move:uz => /set2_P; case => ->; ue. case/set2_P => ->; apply /(Vf_image_P fg esg). rewrite /Z;exists s0; fprops. rewrite /Z;exists s1; fprops. have ->: supremum r2 d01 = \1c. apply: sup_comparable1 => //; apply /r2_gleP;split;fprops. suff h: supremum (completion_order r1) Z = E by rewrite h -g2;exact: card_12. move: (Exercise1_15a16 r1) => [oc h]; move: (h _ zg1) => [hs _]. move: (supremum_pr oc zg1 hs). set z := supremum _ _; move => [[za zb] zc]. move: za; rewrite hh => zr1. move /sub_gleP: (zb _ (set2_1 s0 s1)) => [_ _ ta]. move /sub_gleP: (zb _ (set2_2 s0 s1)) => [_ _ tb]. move: (ta _ (set1_1 \0c)) => z0. move: (tb _ (set1_1 \1c)) => z1. move: zr1; rewrite cpr1; case/setU2_P; case /set2_P => zt. + by move:z1; rewrite zt => /set1_P bad; case: card1_nz. + by move:z0; rewrite zt => /set1_P bad; case: card1_nz. + by move:z1; rewrite zt => /in_set0. + done. Qed. (** ---- Exercise 1.16 Distributive lattices, see main text *) (** ---- Exercise 1.17 Boolean lattices *) Definition complement_pr r x y x' := [/\ inc x' (substrate r), sup r x x' = y & inf r x x' = the_least r]. Definition relatively_complemented r:= [/\ lattice r, has_least r & (forall x y, gle r x y -> exists x', complement_pr r x y x')]. Definition boolean_lattice r:= [/\ relatively_complemented r, has_greatest r & distributive_lattice3 r]. Definition the_complement r x y:= select (complement_pr r x y) (substrate r). Definition standard_completion r x := the_complement r x (the_greatest r). Lemma least_greatest_pr1 r a: boolean_lattice r -> inc a (substrate r) -> [/\ sup r (the_least r) a = a, inf r a (the_greatest r) = a, inf r (the_least r) a = (the_least r) & sup r a (the_greatest r) = (the_greatest r)]. Proof. move=> [[[or _] el _] eg _] asr. move: (least_greatest_pr or) => [h1 h2 h3 h4];split; fprops. Qed. Lemma Exercise1_17a r x y: relatively_complemented r -> distributive_lattice3 r -> gle r x y -> exists! x', complement_pr r x y x'. Proof. move => [lr el ec] dl3 xy; move: (lr) => [or _]. apply /unique_existence; split. by move:(ec _ _ xy) => [z za];exists z. move=> u v [us su iu][vs sv iv]. move:(lattice_props lr). set (E:= substrate r). move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]]. move:(arg1_sr xy) (arg2_sr xy) => xE yE. move: (dl3 _ _ _ us xE vs). rewrite (inf_C r u x) (sup_C r u x) iu iv su sv. move: (least_greatest_pr or) => [p1 _ _ _];rewrite ! (p1 el _ (iE _ _ vs us)). move: (lattice_sup_pr lr xE us)(lattice_sup_pr lr xE vs)=> [_ h2 _][_ h3 _]. move: (lattice_sup_pr lr vs us) => [q1 q2 q3]. move: h2 h3; rewrite su sv; move=> h2 h3; move: (q3 _ h3 h2) => h4. rewrite (inf_C r y _) (inf_C r y _) ! (inf_comparable1 or h4) => infs. move: (lattice_inf_pr lr vs us); rewrite infs; move => [r1 r2 r3]. move: (order_transitivity or q1 r2)(order_transitivity or q2 r1) => h5 h6. order_tac. Qed. Lemma the_complement_pr r x y: relatively_complemented r -> distributive_lattice3 r -> gle r x y -> complement_pr r x y (the_complement r x y). Proof. move => pa pb pc. move: (Exercise1_17a pa pb pc) => /unique_existence [[z zv] pe]. have pf: exists2 x0, inc x0 (substrate r) & complement_pr r x y x0. by exists z => //; case: zv. have pg: singl_val2 (inc^~ (substrate r)) (complement_pr r x y). by move => a b qa qb qc qd; apply: pe. exact: (proj1(select_pr pf pg)). Qed. Lemma scompl_pr r x: boolean_lattice r -> inc x (substrate r) -> complement_pr r x (the_greatest r) (standard_completion r x). Proof. move=> [rr eg dl3] xsr; move: (rr) => [[or _] _ _]. apply:the_complement_pr => //. by move: (the_greatest_pr or eg) => [_]; apply. Qed. Lemma scompl_unique r x y: boolean_lattice r -> inc x (substrate r) -> complement_pr r x (the_greatest r) y -> y = standard_completion r x. Proof. move=> blr xsr h1. move: (scompl_pr blr xsr) => h2. move: blr => [bl1 bl2 bl3]. move: (bl1) => [[or _] _ _]. move: (the_greatest_pr or bl2) => [_ sp]; move: (sp _ xsr) => xg. by move: (Exercise1_17a bl1 bl3 xg) => /unique_existence [_]; apply. Qed. Lemma scomplI r x: boolean_lattice r -> inc x (substrate r) -> standard_completion r (standard_completion r x) = x. Proof. move=> blr xsr; move: (scompl_pr blr xsr). rewrite /complement_pr sup_C inf_C ;move => [ysr ym yq]. symmetry; apply: scompl_unique => //. Qed. Lemma scompl_mon r x y: boolean_lattice r -> gle r x y -> gle r (standard_completion r y) (standard_completion r x). Proof. move=> blr xy. move: (arg1_sr xy) (arg2_sr xy) => xE yE. move: (scompl_pr blr xE) (scompl_pr blr yE). simpl; move=> [aE supa infa] [bE supb infb]. move: (blr) => [[lr _ _] eg dl3];move: (lr) => [or _]. move:(lattice_props lr). set (E:= substrate r). move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]]. set (a:= standard_completion r x). set (b:= standard_completion r y). set (c := inf r a b). have iyc: (inf r y c = the_least r). rewrite /c (inf_C r a b) (ixyz _ _ _ yE bE aE) infb. by move: (least_greatest_pr1 blr aE)=> [_ _ ok _]. move: (sE _ _ yE aE) => yaE. have syc: sup r y c = sup r y a. move: (distributive_lattice_prop2 lr)=> [_ h _]. rewrite /c ((h dl3) _ _ _ yE aE bE). by rewrite supb;move: (least_greatest_pr1 blr yaE)=> [_ ok1 _]. move: (the_greatest_pr or eg) => [_ ok]; move: (ok _ yaE) => le1. have : (gle r (sup r x a) (sup r y a)). by rewrite sup_C (sup_C r y a); apply: sup_monotone. rewrite supa => le2; rewrite (order_antisymmetry or le1 le2) in syc. move: (iE _ _ aE bE) => cE; have yc: c = standard_completion r y by apply: scompl_unique. move: (lattice_inf_pr lr aE bE) => [ac _ _]; rewrite -/c yc in ac; exact ac. Qed. Lemma Exercise1_17b r: boolean_lattice r -> order_isomorphism (Lf (standard_completion r) (substrate r)(substrate r)) r (opp_order r). Proof. move=> blr. have ta: (lf_axiom (standard_completion r) (substrate r) (substrate r)). by move=> t tsr; move: (scompl_pr blr tsr) => [ok _]. move: (blr) => [[[or _] _ _ ] _ _]. move: (opp_osr or) => [pa pb]. split => //. split; aw; try ue; apply: lf_bijective =>//. move=> u v uE vE ss; rewrite -(scomplI blr uE) -(scomplI blr vE) ss //. by move => u uE; move: (ta _ uE) => h; ex_tac; rewrite (scomplI blr uE). red; aw;move=> x y xE yE; aw; split. by move => h; apply /opp_gleP; apply: scompl_mon. move /opp_gleP; rewrite -{2} (scomplI blr xE) -{2} (scomplI blr yE). by apply: scompl_mon. Qed. Lemma Exercise1_17c A: (boolean_lattice (subp_order A) /\ (forall x, inc x (powerset A) -> standard_completion (subp_order A) x = A -s x)). Proof. move: (subp_osr A) => [];set (r:=subp_order A) => or sr. have ha: inc emptyset (powerset A) by apply /setP_P; fprops. have lee: (least r emptyset). split; first by rewrite sr. move=> x; rewrite /r sr => h; apply /sub_gleP;split;fprops. have el: has_least r by exists emptyset. have thel: (the_least r = emptyset) by apply: the_least_pr2. move: (setP_Ti A) => hh. have geA: (greatest r A). red; rewrite sr /r; split => // s sp. apply /sub_gleP;split => //; apply /setP_P => //. have eg: has_greatest r by exists A. have theg: (the_greatest r = A) by apply: the_greatest_pr2. move: (sup_inclusion (A:=A)) => les. move: (inf_inclusion (A:=A)) => ges. have lr: lattice r by apply: setP_lattice. have le1: (forall x y, inc x (powerset A) -> inc y (powerset A) -> sup r x y = x \cup y). move=> x y /setP_P xA /setP_P yA; symmetry. by apply: (supremum_pr2 or); apply: les. have ge1: (forall x y, inc x (powerset A) ->inc y (powerset A) -> inf r x y = x \cap y). move=> x y /setP_P xA /setP_P yA; symmetry. by apply: (infimum_pr2 or); apply: ges. have rc: forall x y, sub x y -> sub y A -> [/\ inc (y -s x) (substrate r), sup r x (y -s x) = y & inf r x (y -s x) = the_least r]. move=> x y xy yA. have xA:inc x (powerset A) by apply /setP_P;apply: sub_trans yA. have cA: inc (y -s x) (powerset A). by apply /setP_P; move=> t /setC_P [ty _]; apply: yA. rewrite sr le1 // ge1 // thel; split;fprops. move /setI2id_Pr: xy => {1} <-; exact: setI2_Cr. by apply /set0_P => t /setI2_P [tx] /setC_P [_] ntx. have iuA: forall x y, inc x (powerset A) -> inc y (powerset A) -> (inc (x \cup y) (powerset A) /\ inc (x \cap y) (powerset A)). move => x y /setP_P xa /setP_P ya; split; apply/setP_P => t. by case/setU2_P; fprops. move /setI2_P => [tx ty]; fprops. have dl3: (distributive_lattice3 r). apply /(distributive_lattice_prop3 lr). move=> x y z; rewrite sr => xA yA zA. move:(proj2 (iuA _ _ yA zA)) (proj1 (iuA _ _ xA yA)) => iyzA uxyA. rewrite (ge1 _ _ yA zA) (le1 _ _ xA yA) (le1 _ _ xA iyzA) (ge1 _ _ zA uxyA). apply /sub_gleP. split; [ apply (proj2(iuA _ _ zA uxyA)) | apply (proj1(iuA _ _ xA iyzA)) |]. move=> t /setI2_P [tz]; case/setU2_P => tx; first by apply /setU2_P; left. by apply /setU2_P; right; fprops. have rc1:relatively_complemented r. split => //; move=> x y /sub_gleP [xA yA xy]. by exists (y -s x); apply: rc => //; apply /setP_P. have bl: boolean_lattice r by split => //. split => // x xa; move : (xa) => /setP_P xA. have sAA: sub A A by fprops. symmetry;apply: scompl_unique =>//; try ue. by red; rewrite theg; apply: rc. Qed. Lemma Exercise1_17d r x y: boolean_lattice r -> inc x (substrate r) -> inc y (substrate r) -> let ys := (standard_completion r y) in [/\ inf r y (sup r ys x) = inf r y x, sup r y (inf r ys x) = sup r y x, inf r ys (sup r y x) = inf r ys x & sup r ys (inf r y x) = sup r ys x]. Proof. move=> blr xsr ysr ys. move: (blr) => [[lr _ _] _ dl3]; move: (lr) => [or _]. move: (scompl_pr blr ysr); rewrite -/ys; move=> [ys1 ys2 ys3]. move: (distributive_lattice_prop2 lr) => [_ ok1 ok2]. rewrite ((ok1 dl3) _ _ _ ysr ys1 xsr) ((ok1 dl3) _ _ _ ys1 ysr xsr). rewrite ((ok2 dl3) _ _ _ ysr ys1 xsr) ((ok2 dl3) _ _ _ ys1 ysr xsr). rewrite (sup_C r ys y) (inf_C r ys y) ys2 ys3. move:(lattice_props lr) =>/=; move => [sE [iE _]]; split. by case: (least_greatest_pr1 blr (iE _ _ ysr xsr)). by rewrite inf_C;move: (least_greatest_pr1 blr (sE _ _ ysr xsr))=> [_ ]. by case: (least_greatest_pr1 blr (iE _ _ ys1 xsr)). by rewrite inf_C;move: (least_greatest_pr1 blr (sE _ _ ys1 xsr)) => [_]. Qed. Lemma Exercise1_17e r x y: boolean_lattice r -> complete_lattice r -> inc y (substrate r) -> sub x (substrate r)-> inf r y (supremum r x) = supremum r (fun_image x (fun z => inf r y z)). Proof. move=> blr [or clr] ysr xsr. move: (blr) => [[lr _ _] _ _]. move: (clr _ xsr) => [hsx _]. move: (supremum_pr1 or hsx) => /(lubP or xsr) [[sxs sxu] sxp]. move: (lattice_inf_pr lr ysr sxs). set (v:= inf r y (supremum r x)); move => [p1 p2 p3]. set Y:= fun_image x _. have sY: sub Y (substrate r). move => t /funI_P [z zx ->]. move:(lattice_inf_pr lr ysr (xsr _ zx)) => [h _ _]; order_tac. move: (clr _ sY) => [hsy _]. move: (supremum_pr1 or hsy) => /(lubP or sY). set (u:= supremum r Y);move=> [[sus syu] syp]. set ys:= (standard_completion r y). have leuv: gle r u v. apply: syp; split; first (by order_tac); move=> t /funI_P [z zx ->]. move:(lattice_inf_pr lr ysr (xsr _ zx)) => [h1 h2 h3]. apply: p3 => //; move: (sxu _ zx) => zs; order_tac. have le1: gle r u y by order_tac. have <-:(inf r y (sup r ys u) = u). move: (Exercise1_17d blr sus ysr) => [-> _ _ _]. by rewrite inf_C; apply: inf_comparable1. have <-:(inf r y (sup r ys (supremum r x)) = v). by move: (Exercise1_17d blr sxs ysr) => [r1 _]. apply: f_equal. move: (scompl_pr blr ysr); rewrite -/ys ; move => [q1 _ _]. move: (lattice_sup_pr lr q1 sxs) (lattice_sup_pr lr q1 sus). rewrite /u;set z:= (sup r ys u); set z' :=(sup r ys (supremum r x)). move=>[r1 r2 r3] [r4 r5 r6]. apply: (order_antisymmetry or). apply: r3; first (by exact); apply: sxp; split; first by order_tac. move => t tx. have iyt: inc (inf r y t) Y by apply /funI_P; ex_tac. move: (sup_monotone lr q1 (syu _ iyt)). move: (Exercise1_17d blr (xsr _ tx) ysr) =>[_ _ _ aux ]. rewrite /ys aux -/ys -/z => le4. move: (lattice_sup_pr lr q1 (xsr _ tx)) => [_ le5 _]; order_tac. apply: r6; first (by exact); apply: syp; split; first by order_tac. move=> t /funI_P [s sx ->]. move: (lattice_inf_pr lr ysr (xsr _ sx)) => [_ le2 _]. move: (lattice_sup_pr lr q1 sxs) => [_ le3 _]. apply: (order_transitivity or le2 (order_transitivity or (sxu _ sx) le3)). Qed. (** ---- Exercise 1.18. Example of a complete lattice that is not distributive but relatively complemented *) Definition intersection_partition2 u v := Zo (intersection_covering2 u v) (fun z => nonempty z). Lemma disjoint_pr1 a b: (forall x, inc x a -> inc x b -> a = b) -> (disjointVeq a b). Proof. move=> h; case: (equal_or_not a b); first by left. move=> nab;right;apply: disjoint_pr; move=> u ua ub; case: nab; apply: h ua ub. Qed. Lemma intersection_is_partition2 u v x: partition_s u x -> partition_s v x -> partition_s (intersection_partition2 u v) x. Proof. move=> ux vx; rewrite /intersection_partition2. split; first split; last by move=> a => /Zo_hi. set_extens t. move=> /setU_P [y ty] /Zo_P [] /setI_covering2_P. move=> [a [b [au bv yv]]] _. move: ux => [[<- _] _]; apply /setU_P; ex_tac. by move: ty; rewrite -yv; move /setI2_P => [ta _]. move=> tx; move: tx (tx); move: ux vx => [ [ {2} <- _] _] [[<- _] _]. move => /setU_P [y1 ty1 y1u] /setU_P [y2 ty2 y2u]. have ti: inc t (y1 \cap y2) by apply: setI2_i. apply /setU_P;exists (y1 \cap y2) => //. apply: Zo_i; [ apply /setI_covering2_P;by exists y1, y2 | by exists t]. move=> a b /Zo_P [] /setI_covering2_P [a1 [b1 [a1u b1v]]] <- _ /Zo_P [] /setI_covering2_P [a2 [b2 [a2u b2v]]] <- _. apply: disjoint_pr1 => w /setI2_P [w1 w2] /setI2_P [w3 w4]. move:(proj2 (proj1 ux)) (proj2 (proj1 vx)) => ha hb. have ->: a1=a2 by case: (ha _ _ a1u a2u) => // h1; empty_tac1 w. have -> //: b1=b2 by case:(hb _ _ b1v b2v) => // d1; empty_tac1 w. Qed. Lemma intersection_p2_comm u v: (intersection_partition2 u v) = (intersection_partition2 v u). Proof. set_extens t; move /Zo_P => [] /setI_covering2_P [a [b [au bv it]]] net; apply /Zo_i => //; apply /setI_covering2_P; by exists b, a; rewrite setI2_C. Qed. Lemma intersection_is_sup2_a u v x: partition_s u x -> partition_s v x -> gle (coarser x) u (intersection_partition2 u v). Proof. move=> pu pv; apply /coarser_gleP; split => //. by apply: intersection_is_partition2. move=> y /Zo_P [] /setI_covering2_P [a [b [au bv h]]] _. ex_tac; rewrite -h;apply: subsetI2l. Qed. Lemma intersection_is_sup2 u v x: partition_s u x -> partition_s v x -> least_upper_bound (coarser x)(doubleton u v)(intersection_partition2 u v). Proof. move=> pu pv;apply: lub_set2. apply: (proj1 (coarser_osr _)). by apply: intersection_is_sup2_a. by rewrite intersection_p2_comm; apply: intersection_is_sup2_a. move=> t /coarser_gleP [_ pt c1] /coarser_gleP [_ _ c2]. apply /coarser_gleP;split => //;first by apply intersection_is_partition2. move=> A At; move: (c1 _ At)(c2 _ At) => [b bu Ab] [c cv Ac]. have sA: sub A (b \cap c) by move=> w wA;apply: setI2_i; fprops. exists (b \cap c) => //; apply: Zo_i. apply /setI_covering2_P; exists b, c; split => //. by move: ((proj2 pt) _ At) => [w wA]; exists w; apply: sA. Qed. Lemma intersection_is_sup2_b E u v: partition_s u E -> partition_s v E -> sup (coarser E) u v = (intersection_partition2 u v). Proof. move: (coarser_osr E) => [pa pb] pu pv. have i2 :=(intersection_is_sup2 pu pv). have hs: (has_supremum (coarser E) (doubleton u v)). by exists (intersection_partition2 u v). have sd: (sub (doubleton u v) (substrate (coarser E))). by move => t; rewrite pb;case/set2_P => ->; apply /partitionsP. by apply: (supremum_unique pa (supremum_pr1 _ hs) i2). Qed. Definition intersection_partition f := complement (fun_image (productb f) intersectionb) (singleton emptyset). Lemma intersection_is_partition f x: fgraph f -> (forall u, inc u (domain f) -> partition_s (Vg f u) x) -> nonempty (domain f) -> partition_s (intersection_partition f) x. Proof. move=> fgf alp nedf; move: (nedf) => [w wdf]. split; last by move=> a /setC1_P [_] /nonemptyP. rewrite /intersection_partition; split. set_extens t. move=> /setU_P [y ty] /setC1_P [] /funI_P [z zp h] _. move: (alp _ wdf) => [[pu1 pu3] pu2]. move: zp => /setXb_P [fgz df VV]; rewrite -df in wdf. have aux: inc t (Vg z w) by rewrite h in ty; apply: (setIb_hi ty wdf). rewrite -pu1; apply /setU_P; exists (Vg z w) => //; apply: VV; ue. move => tx; apply /setU_P. pose p u v := inc t v /\ inc v (Vg f u); set (g := fun u => choose (p u)). have gp: (forall u, inc u (domain f) -> p u (g u)). move=> u udf; move:(alp _ udf) tx =>[[<- _] _] /setU_P [z z1 z2]. by apply: (choose_pr); exists z. set (h:= Lg (domain f) g). have tih:(inc t (intersectionb h)). apply: setIb_i. exists (J w (Vg h w)); apply: fdomain_pr1; rewrite /h; bw;fprops. move=> i; rewrite /h Lg_domain => idf; move: (gp _ idf) => [res _]; bw. have hp:(inc h (productb f)). apply /setXb_P; rewrite /h; bw; split;fprops;move=> i idf; bw. by move: (gp _ idf) => [_ p2]. exists (intersectionb h) => //; apply /setC1_P; split. apply /funI_P;ex_tac. move=> he; move: tih; rewrite he; case/in_set0. move => a b /setC1_P [] /funI_P [z1 z1p] -> _ /setC1_P [] /funI_P [z2 z2p] -> _. apply: disjoint_pr1 => y yi1 yi2. move: z1p z2p => /setXb_P [fg1 dz1 VV1] /setXb_P [fg2 dz2 VV2]. apply: f_equal; apply: fgraph_exten => //; [ue | move=> i idf /=]. rewrite -dz1 in VV1. move: (VV1 _ idf)(setIb_hi yi1 idf) => p1 p2. rewrite -dz2 in VV2; rewrite dz1 -dz2 in idf. move: (VV2 _ idf) (setIb_hi yi2 idf)=> p3 p4. rewrite dz2 in idf. case:(proj2 (proj1 (alp _ idf)) _ _ p1 p3) => // di; empty_tac1 y. Qed. Lemma intersection_is_sup_a f x y: fgraph f -> (forall u, inc u (domain f) -> partition_s (Vg f u) x) -> inc y (range f) -> gle (coarser x) y (intersection_partition f). Proof. move=> fgf alp /(range_gP fgf) [z zdf ->]. have ne: nonempty (domain f) by exists z. apply /coarser_gleP; split;fprops; first by apply: intersection_is_partition. move=> a /setC1_P [] /funI_P [t zt h] _. move: zt => /setXb_P [fgt dt VV]; move: (VV _ zdf) => aux. ex_tac; rewrite h; move=> w wi; apply: (setIb_hi wi); ue. Qed. Lemma intersection_is_sup f x: fgraph f -> (forall u, inc u (domain f) -> partition_s (Vg f u) x) -> nonempty (domain f) -> least_upper_bound (coarser x) (range f) (intersection_partition f). Proof. move=> fgf alp nef. move: (intersection_is_partition fgf alp nef) => ip. move: (coarser_osr x) => [pa pb]. have aux: forall u, inc u (substrate (coarser x)) <-> partition_s u x. by move=> u; rewrite pb; apply:partitionsP. have aux2: sub (range f) (substrate (coarser x)). by move => t; rewrite aux;move /(range_gP fgf) => [u udf] ->; apply: alp. apply /(lubP pa aux2). split; first by split;[ rewrite aux | move=> y; apply: intersection_is_sup_a]. move=> z [];rewrite aux => pzx zle. apply /coarser_gleP;split => //; move=> t tz. pose p u z := (inc z (Vg f u) /\ sub t z); set (g:= fun u => choose (p u)). have gp: (forall u, inc u (domain f) -> p u (g u)). move=> u udf; apply: choose_pr; move: (zle _ (inc_V_range fgf udf)). by move/coarser_gleP => [_ _ h]; move: (h _ tz) => [zz za zb]; exists zz. have ai: (sub t (intersectionb (Lg (domain f) g))). move=> v vt; apply: setIb_i. move: nef => [y ydf]; exists (J y (Vg (Lg (domain f) g) y)). apply: fdomain_pr1; fprops; bw. by bw; move=> i idf; bw; move: (gp _ idf) => [_ tg]; apply: tg. exists (intersectionb (Lg (domain f) g)); last by exact. apply /setC1_P; split; last first. move: (proj2 pzx _ tz) => [b bt]; move=> ie; empty_tac1 b. apply /funI_P. exists (Lg (domain f) g) => //; apply /setXb_P; split => //;bw; fprops. by move=> i idf; bw; move: (gp _ idf) => [ok _]. Qed. Lemma Exercise1_18a E: complete_lattice (coarser E). Proof. move: (coarser_osr E) => [coE soE]. apply: Exercise1_11b => //. have aux: forall u, inc u (substrate (coarser E)) <-> partition_s u E. by move=> u; rewrite soE; apply:partitionsP. move=> X XsE;case: (emptyset_dichot X) => neX; last first. set (f := identity_g X). have fgf: (fgraph f) by apply: identity_fgraph. have rf: (range f = X) by apply: identity_r. have df: (domain f = X) by apply: identity_d. rewrite -df in neX; rewrite -rf. have alp: (forall u, inc u (domain f) -> partition_s (Vg f u) E). by rewrite df => u uX; rewrite /f (identity_ev uX); move/aux:(XsE _ uX). exists (intersection_partition f);apply: (intersection_is_sup fgf alp neX). rewrite neX. case: (emptyset_dichot E) => Ee. have pE: (partition_s emptyset E). split; last by move=> a /in_set0. split; [by rewrite Ee setU_0 | by move=> a b /in_set0 ]. exists emptyset; rewrite lub_set0 //; split;first by apply/ aux. move => x /aux xE; apply /coarser_gleP; split => //; move=> t tx. move:(proj2 xE _ tx) => [w wt]. move: (proj1(proj1 xE)); rewrite Ee => p1; empty_tac1 w; union_tac. exists (least_partition E). rewrite lub_set0 //; split. by apply/ aux; apply: least_is_partition. move=> x /aux px; apply/coarser_gleP; split => //. by apply: least_is_partition. move=> a ax; exists E; first by rewrite /least_partition; fprops. by rewrite - (proj1(proj1 px)); apply: setU_s1. Qed. (** This set is not distributive if there are at least three elements *) Lemma Exercise1_18b E: \3c <=c (cardinal E) -> ~ (distributive_lattice1 (coarser E)). Proof. move /cardinal_ge3 => [x [y [z [xE yE zE [xy xz yz]]]]]. set (o:= tripleton x y z); set (F:= E -s o). have oz: inc z o by apply /set3_P; in_TP4. have oy: inc y o by apply /set3_P; in_TP4. have ox: inc x o by apply /set3_P; in_TP4. have xnF: ~ (inc x F) by move /setC_P => [_]; case. have ynF: ~ (inc y F) by move /setC_P => [_]; case. have znF: ~ (inc z F) by move /setC_P => [_]; case. have Ha: forall x, singleton x <> emptyset by move => u se; empty_tac1 u. set (with_F := fun u => (u +s1 F) -s1 emptyset). have wf1: (forall u, ~ (inc emptyset u) -> F = emptyset -> with_F u = u). by move=> u nsu Fe; rewrite /with_F Fe; apply: setU1_K. have wf2: (forall u, ~ (inc emptyset u) -> F <> emptyset -> with_F u = u +s1 F). move=> u une Fne; apply: setC1_eq => /setU1_P; case; fprops. have oe: (sub o E) by move=> t /set3_P;case => ->. have wfp: (forall u, partition_s u o -> partition_s (with_F u) E). move=> u [[p1 p3] p2]; split; last by move=> a /setC1_P [_] /nonemptyP. split. set_extens t. move /setU_P=> [a ta]; case/setC1_P; case /setU1_P => h _. apply: oe; rewrite -p1; union_tac. by move: ta; rewrite h => /setC_P []. move=> tE; case: (inc_or_not t o). rewrite -p1; move /setU_P => [v tv vu]; apply /setU_P; exists v =>//. apply /setC1_P;split; first by apply /setU1_P; left. move=> ve;empty_tac1 t. move => to; have tF: inc t F by apply /setC_P. apply /setU_P; exists F => //; apply /setC1_P;split;fprops. move=> Fe;empty_tac1 t. move=> a b /setC1_P [] /setU1_P; case=> aa ane. move /setC1_P => [] /setU1_P; case=> bb bne; first by apply: p3. right; apply: disjoint_pr => v va vb. move: vb; rewrite bb => /setC_P [_]; case; rewrite -p1; union_tac. move /setC1_P => [] /setU1_P; case => bb bn; last by rewrite aa; left. right; apply: disjoint_pr => v vb va. move: vb; rewrite aa => /setC_P [_]; case; rewrite -p1; union_tac. set pa3 := fun a b c => (doubleton (singleton a) (doubleton b c)). have pa3p: (forall a b c, (singleton a) \cup (doubleton b c) = o -> partition_s (pa3 a b c) o). move => a b c H; split; last first. move=> u => /set2_P; case=> ->; [apply: set1_ne | apply: set2_ne]. have H1: disjoint (singleton a) (doubleton b c). apply: disjoint_pr => u /set1_P eq1; move: H; rewrite eq1 => e1 e2. have: sub o (doubleton b c). by rewrite - e1 => t /setU2_P; case => // /set1_P ->. move/sub_smaller; rewrite (cardinal_tripleton xy xz yz) => ha. case: (cleNgt (cleT ha (cardinal_doubleton b c)) (cltS NS2)). split => // u v /set2_P [] -> /set2_P [] ->; try (by left); right => //. by apply: disjoint_S. set (Px:= with_F (pa3 x y z)). set (Py:= with_F (pa3 y x z)). set (Pz:= with_F (pa3 z x y)). have pox: partition_s (pa3 x y z) o. apply: pa3p;rewrite setU2_C. set_extens t;case/set3_P => ->; apply/set3_P; in_TP4. have poy: partition_s (pa3 y x z) o. apply: pa3p; rewrite setU2_C. set_extens t;case/set3_P => ->; apply/set3_P; in_TP4. have poz: partition_s (pa3 z x y) o by apply: pa3p; rewrite setU2_C. have ppx: partition_s Px E by apply: wfp; apply: pox. have ppy: partition_s Py E by apply: wfp; apply: poy. have ppz: partition_s Pz E by apply: wfp; apply: poz. move: (coarser_osr E) => [oce pb]. have auxP: forall u, inc u (substrate (coarser E)) <-> partition_s u E. by move=> u; rewrite pb; apply: partitionsP. have Pxr: inc Px (substrate (coarser E)) by apply/auxP. have Pyr: inc Py (substrate (coarser E)) by apply/auxP. have Pzr: inc Pz (substrate (coarser E)) by apply/auxP. set (alpha:= with_F(greatest_partition o)). set (omga:= with_F(least_partition o)). have ppa: (partition_s alpha E) by apply: wfp; apply: greatest_is_partition. have ppo: (partition_s omga E). by apply: wfp; apply: least_is_partition; exists z. have lr: lattice (coarser E). move: (Exercise1_18a E) => [cl1 cl2]. by split => // u v uE vE;apply:cl2; move=> t /set2_P; case => ->. have or: order (coarser E) by move: lr => [ok _]. move=> bad; move: (bad Px Py Pz Pxr Pyr Pzr). have one: o <> emptyset by move => h; empty_tac1 z. have op1:forall u, partition_s u o -> gle (coarser E) omga (with_F u). move=> u pu; apply /coarser_gleP; split;fprops. move=> a /setC1_P [] /setU1_P; case => h ae. exists o => //. by apply /setC1_P; split => //; apply /setU1_P; left; apply/set1_P. by move: pu => [[pu1 pu3] pu2]; rewrite -pu1; apply: setU_s1. exists a;fprops; apply /setC1_P;split => //;rewrite h; fprops. have oPx: gle (coarser E) omga Px by apply: op1. have oPy: gle (coarser E) omga Py by apply: op1. have oPz: gle (coarser E) omga Pz by apply: op1. have Hb: forall u v, doubleton u v <> emptyset by move => u uv h; empty_tac1 u. have ->: (inf (coarser E) Py Pz = omga). move: (lattice_inf_pr lr Pyr Pzr) => [e1 e2 e3]. move: (arg1_sr e1) => /auxP infp. move: e1 => /coarser_gleP [_ _ cc]. have d1Py: inc (doubleton x z) Py. by apply /setC1_P;split; fprops;apply /setU1_P; left; apply /set2_P; right. move: e2 (cc _ d1Py)=> /coarser_gleP [_ _ cc2] [s1 p1 p2]. have d2Py: inc (doubleton x y) Pz. by apply /setC1_P;split;fprops; apply /setU1_P; left; apply /set2_P; right. move: (cc2 _ d2Py)=> [s2 p3 p4]. case: (proj2 (proj1 infp) _ _ p1 p3) => s1s2;last by empty_tac1 x. apply: (order_antisymmetry or); last by apply: e3. apply /coarser_gleP; split => //; move=> a. move /setC1_P => [] /setU1_P [] /set1_P p5 p6. rewrite p5;ex_tac => t;case/set3_P => ->; first by apply: p4; fprops. by apply p4; fprops. by rewrite - s1s2; apply p2; fprops. move: p6; move /set1_P: p5 => -> p6. have FPy: inc F Py by apply /setC1_P;split => //; apply /setU1_P; right. move: (cc _ FPy)=> [s3 p7 p8]; ex_tac. rewrite sup_C (sup_comparable1 or oPx). suff p3: forall a b, doubleton a b = doubleton y z -> (sup (coarser E) Px (with_F (pa3 a x b)) = alpha). rewrite /Py/Pz p3 // p3; last by apply: set2_C. rewrite (inf_comparable1 or); last (by order_tac; apply/auxP); move => pa. have: inc (singleton y) alpha. by apply/setC1_P; split;fprops; apply /setU1_P;left; apply /funI_P;exists y. rewrite -pa; move /setC1_P => [] /setU1_P; case. move /set2_P; case =>h; first by move: (set1_inj h) => h1; case: xy. have /set1_P /(nesym yz) //: inc z (singleton y) by rewrite h; fprops. by move=> yF; move: (set1_1 y); rewrite yF; move /setC_P => [_]; case. move=> a b da. have ax: a <> x. by move=> ax; move: (set2_1 a b); rewrite da ax;case /set2_P. have bx: b <> x. by move=> bx; move: (set2_2 a b); rewrite da bx; case/set2_P. have ab: a <> b. move=> ab; move: (set2_2 y z)(set2_1 y z). by rewrite -da ab => /set1_P <- /set1_P. have ao: inc a o by move: (set2_1 a b); rewrite da; case/set2_P =>->. have bo: inc b o by move: (set2_2 a b); rewrite da; case/set2_P =>->. set Pt:= with_F (pa3 a x b). have Ptsw: (Pt = Py \/ Pt = Pz). rewrite /Py /Pz /Pt. by case: (doubleton_inj da); move => [av bv]; rewrite av bv; [left | right]. rewrite intersection_is_sup2_b //; last by case: Ptsw => ->. have fg1: fgraph (Lg o singleton) by fprops. have in1: forall a b, (doubleton a b) \cap (singleton a) = singleton a. move=> A B; set_extens t; first by move /setI2_P => []. move => h; apply /setI2_P;split => //; move /set1_P: h => ->; fprops. have in2:(doubleton a b) \cap (doubleton x b) = singleton b. set_extens s. by move => /setI2_P []; case/set2_P => ->; fprops; case/set2_P. move /set1_P => ->; apply /setI2_P; split; fprops. set_extens t. move /Zo_P => [] /setI_covering2_P [u [v [u1 v1 i1]]] net. apply /setC1_P; split; last by apply /nonemptyP. move: net; rewrite -i1; move=> [w] /setI2_P [wu wv]. move: u1 v1 => /setC1_P [p1 p2] /setC1_P [p3 p4]. case /setU1_P: p1. - case /set2_P => p5; case /setU1_P: p3; first case /set2_P => p6. + by case: ax; move: wu wv; rewrite p5 p6 => /set1_P -> /set1_P ->. + by apply /setU1_P; left; apply /funI_P; exists x=> //; rewrite p5 p6 setI2_C in1. + by move => vF;case: xnF; move: wu wv; rewrite p5 vF; move => /set1_P ->. - case/set2_P => p6. + by rewrite p5 p6 -da in1; apply /setU1_P; left; apply /funI_P; exists a. + by rewrite p5 p6 -da in2; apply /setU1_P; left; apply /funI_P; exists b. + by move => vF; move: wu wv; rewrite vF p5; case/set2_P => -> h; [ by case: ynF | by case: znF ]. - move => uF; case/setU1_P: p3; first case/set2_P => h. + move:wv wu; rewrite h uF => /set1_P. move: (set2_1 a b); rewrite da; case/set2_P => -> -> h1; [ by case: ynF | by case: znF ]. + move: wv wu; rewrite h uF; case/set2_P; first by move => -> h2; case: xnF. move: (set2_2 a b); rewrite da; case/set2_P => -> -> h1; [ by case: ynF | by case: znF ]. + by move=> ->; apply /setU1_P;right; rewrite uF; rewrite setI2_id. move => /setC1_P [pa pb']; apply: Zo_i; last by apply /nonemptyP. apply /setI_covering2_P. case/setU1_P: pa; last first. move=> tf ; exists t, t; rewrite setI2_id;split => //; apply /setC1_P;split => //; apply /setU1_P; right; ue. move /funI_P => [c co] => tC. set C1 := (((pa3 x y z) +s1 F) -s1 emptyset). set C2 := (((pa3 a x b) +s1 F) -s1 emptyset). have xc1: inc (singleton x) C1. apply /setC1_P;split; first (apply /setU1_P; left; apply /set2_P);fprops. have ac2: inc (singleton a) C2. apply /setC1_P;split; first (apply /setU1_P; left; apply /set2_P);fprops. have bx2: inc (doubleton x b) C2. apply /setC1_P;split; first (apply /setU1_P; left; apply /set2_P);fprops. have ab2: inc (doubleton a b) C1. apply /setC1_P;split; first (apply /setU1_P; left; apply /set2_P);fprops. have cxab: (c = x \/ (c = a \/ c = b)). move: co =>/set3_P; case; first (by fprops); move => -> ;right. by move: (set2_1 y z); rewrite -da; move /set2_P. by move: (set2_2 y z); rewrite -da; move /set2_P. rewrite tC;case: cxab. move=> ->;exists (singleton x), (doubleton x b); split => //. by rewrite setI2_C in1. case=> ->. by exists (doubleton a b), (singleton a). by exists (doubleton a b), (doubleton x b). Qed. (** The set is relatively complemented *) Lemma Exercise1_18c E: greatest_partition E = the_greatest (coarser E). Proof. move: (coarser_osr E) => [pa pb]. symmetry; apply: the_greatest_pr2 => //. have p1: partition_s (greatest_partition E) E by apply: greatest_is_partition. red; rewrite pb; split; first by apply /partitionsP. move=> x => /partitionsP xE. apply /coarser_gleP;split => // => y. move /funI_P => [w wE ->]. rewrite -(proj1 (proj1 xE)) in wE; move:(setU_hi wE) => [z wz zx]. by ex_tac; move=> t /set1_P ->. Qed. Lemma Exercise1_18d E X Y (r := coarser E): gle r Y X -> exists X', [/\ inc X' (substrate r), inf r X X' = Y & sup r X X' = greatest_partition E]. Proof. move=> lYX; move: (lYX). move /coarser_gleP => [py px cyx]. move: (px)(py) => [[px1 px3] px2] [[py1 py3] py2]. set (X1 := Zo (powerset E) (fun z=> exists2 a, z = singleton a & ~(exists2 u, inc u X & a = rep u))). set X2 := fun_image Y (fun v => Zo E (fun z => exists u, [/\ inc u X, sub u v & z = rep u])). set (Z:=X1 \cup X2). have Hb: forall x a, inc x a-> inc a X -> x <> (rep a) -> inc (singleton x) Z. move=>x a xa aX nrep; apply /setU2_1. apply: Zo_i; first by apply /setP_P => w /set1_P ->; rewrite -px1;union_tac. exists x => //; move=> [w wx tr]. have xw: (inc x w) by rewrite tr; apply: rep_i; apply: px2. case: (px3 _ _ aX wx) => aw; first by case: nrep; ue. by red in aw; empty_tac1 x. have pz: (partition_s Z E). split; last first. move=> a; case/setU2_P. move /Zo_P => [_ [u ua _]];rewrite ua; exists u; fprops. move /funI_P => [v vy ->]; move: (py2 _ vy) => [x xv]. have : inc x E by rewrite -py1; union_tac. rewrite -px1; move=> /setU_P [u xu uX]. move: (rep_i (px2 _ uX)) (cyx _ uX) => ru [w wY uW]. case: (py3 _ _ vy wY) => vw; last by empty_tac1 x. exists (rep u); apply: Zo_i; [ union_tac | exists u;split => //; ue]. split; first set_extens x. move=> /setU_P [u xu]; case/setU2_P. by move /Zo_P => [] /setP_P uE _; apply: uE. by move=> /funI_P [v vy vw];move: xu; rewrite vw => /Zo_P [te _]. move=> xE;move: (xE); rewrite -px1=> /setU_P [a xa aX]; apply /setU_P. case: (equal_or_not x (rep a)) => xrep; last first. exists (singleton x); fprops; apply: (Hb _ _ xa aX xrep). move: (cyx _ aX)=> [b bY ab]. set (w:= Zo E (fun z => exists u, [/\ inc u X, sub u b & z = rep u])). have tw: (inc x w) by apply: Zo_i => //; exists a. by exists w => //; apply: setU2_2; apply /funI_P; exists b. move=> a b; case/setU2_P=> h1; case/setU2_P => h2. + move: h1 h2 => /Zo_hi [u au _] /Zo_hi [v bv _]. rewrite au bv; case: (equal_or_not u v) => uv; first by left;ue. by right; apply: disjoint_pr; move=> w /set1_P -> /set1_P. + move: h1 h2 => /Zo_P [aE [x ax nev]] /funI_P [z zY bv]. right; apply: disjoint_pr => u; rewrite ax bv => /set1_P ->. move /Zo_P => [xE [w [wX wz rw]]]; case: nev; ex_tac. + move: h2 h1 => /Zo_P [aE [x ax nev]] /funI_P [z zY bv]. right; apply: disjoint_pr => u; rewrite ax bv. move /Zo_P=> [xE [w [wX wz rw]]] /set1_P => h;case: nev; ex_tac; ue. + move: h1 h2 => /funI_P [x xY av] /funI_P [y yY bv]. rewrite av bv. case: (py3 _ _ xY yY); first by move=> xy; left; rewrite xy. rewrite {1} /disjoint;move=> dixy; right; apply: disjoint_pr. move=> u => /Zo_P [uE [c [cX cx ur]]] /Zo_P [_ [d [dX dx ur']]]. move: (rep_i (px2 _ cX))(rep_i (px2 _ dX)). rewrite -ur -ur' => uc ud; empty_tac1 u. have lr: lattice (coarser E). move: (Exercise1_18a E) => [cl1 cl2]. by split => // u v uE vE;apply: cl2; move=> t; case/set2_P => ->. move: (coarser_osr E) => [or sr]. have auxP: forall u, inc u (substrate r) <-> partition_s u E. by move=> u; rewrite sr; apply: partitionsP. have Xs: inc X (substrate r) by apply /auxP. have Ys: inc Y (substrate r) by apply /auxP. have Zs: inc Z (substrate r) by apply /auxP. exists Z; split; first by exact. move: (lattice_inf_pr lr Xs Zs); rewrite -/r; move => [i1 i2 i3]. have YZ: gle r Y Z. apply /coarser_gleP; split => //; move=> t /setU2_P; case. move=> /Zo_P [] /setP_P tE [a ta ap]. have: inc a E by apply: tE; rewrite ta; fprops. rewrite -py1 => /setU_P [y ay yY]. by exists y => //; rewrite ta; apply: set1_sub. move=> /funI_P [z zY tv]; ex_tac;rewrite tv; move=> u /Zo_P. move => [uE [v [vX vz ur]]]; apply: vz; rewrite ur. apply: (rep_i (px2 _ vX)). move: (i3 _ lYX YZ) => Yi. apply: (order_antisymmetry or); last by exact. move: i1 i2 => /coarser_gleP [p1 _ le1] /coarser_gleP [_ _ le2]. apply/coarser_gleP;split => //; move=> a aY. set (z:= Zo E (fun z => exists u, [/\ inc u X, sub u a & z = rep u])). have zz: (inc z Z) by apply: setU2_2; apply /funI_P; ex_tac. move: (le2 _ zz); move=> [b bi zb]; ex_tac => t ta. have tE: (inc t E) by rewrite -py1; union_tac. move: (tE);rewrite -px1 => /setU_P [c tc cX]. move: (cyx _ cX) => [d dY cd]. case: (py3 _ _ aY dY) => ad; last by empty_tac1 t. rewrite -ad in cd; clear dY ad d. move: (rep_i (px2 _ cX)) => rd1. have rcb: inc (rep c) b. by apply: zb; apply: Zo_i; [rewrite -px1;union_tac | ex_tac]. move: (le1 _ cX); move=> [d di db]. case: (proj2 (proj1 p1) _ _ bi di); first by move=> ->; apply: db. move => bd; empty_tac1 (rep c). rewrite intersection_is_sup2_b //. have Ha: forall a w, inc a X -> inc w X2 -> nonempty (a \cap w) -> a \cap w = (singleton (rep a)). move=> a b aX bX2 [q qt]; move: bX2 => /funI_P [v vY bv]. have rap: forall w, inc w (a \cap b) -> w = rep a. move=> w;rewrite bv => /setI2_P [wa]/Zo_P [wE [c [cX cb wr]]]. case: (px3 _ _ aX cX); first by move=> ->. move=> di; empty_tac1 (rep c); [ ue | apply: (rep_i (px2 _ cX))]. move: (rap _ qt) => t1; rewrite -t1 in rap |- *. by apply: set1_pr. set_extens t. move /Zo_P => [] /setI_covering2_P [a [b [aX bZ ti]]] net; apply /funI_P. move:bZ => /setU2_P; case. move /Zo_P=>[bE [c bs _]]. have cb: inc c b by rewrite bs; fprops. have tc: forall w, inc w t -> w = c. by move=> w; rewrite -ti bs => /setI2_P [_] /set1_P. move: bE => /setP_P bE; exists c; first (by apply: bE). by apply: set1_pr1. rewrite -ti in net;move => bX2; move: (Ha _ _ aX bX2 net) => wi. rewrite -ti wi -px1; exists (rep a)=> //; apply: (@setU_i _ a) => //. apply: (rep_i (px2 _ aX)). move /funI_P => [x xE st]. apply: Zo_i; last by rewrite st; apply: set1_ne. apply /setI_covering2_P. move: (xE); rewrite -px1 => /setU_P [a wa aX]. move: (cyx _ aX); move=> [b bY ab]. case: (equal_or_not x (rep a)) => ra. set (w:= Zo E (fun z => exists u, [/\ inc u X, sub u b & z = rep u])). have wX2: inc w X2 by apply /funI_P; ex_tac. have nei: nonempty (a \cap w). exists (rep a); apply: setI2_i; first by ue. apply: Zo_i; [rewrite -px1 -ra; union_tac | ex_tac]. exists a; exists w;rewrite (Ha _ _ aX wX2 nei) -ra st;split => //. by apply: setU2_2. exists a; exists (singleton x); split => //; first by apply: (Hb _ _ wa aX ra). rewrite st setI2_C; apply: set1_pr. by apply /setI2_P;split;fprops. by move => z /setI2_P [] /set1_P. Qed. (** ---- Exercise 1.19 Sets without gaps; example of ordinal sum *) Definition without_gaps r := [/\ order r, (exists x y, glt r x y) & (forall x y, glt r x y -> exists2 z, glt r x z & glt r z y)]. Section Exercise1_19. Variables (r g: Set). Hypotheses (ax:orsum_ax r g) (ax2: orsum_ax2 g). Hypothesis nesr: nonempty (substrate r). Lemma Exercise1_19a: without_gaps (order_sum r g) <-> [/\ (exists i j, glt r i j) \/ (exists i x y, inc i (substrate r) /\ glt (Vg g i) x y), (forall i x y, inc i (substrate r) -> glt (Vg g i) x y -> without_gaps (Vg g i)) & (forall i j, glt r i j -> [\/ (exists2 k, glt r i k & glt r k j), (forall u, ~ (maximal (Vg g i) u)) | (forall u, ~ (minimal (Vg g j) u))])]. Proof. move: (ax) => [q1 q2 q4]; set vg := Vg g. split. move=>[or [x1 [y1 x1y1]] wg]; split. + move: x1y1 => [] /orsum_gleP [p1 p2 p3] di. case: p3; first by move=> h; left; exists (Q x1); exists (Q y1). move=> [sq1 cp]; right; exists (Q x1); exists (P x1); exists (P y1). move: (du_index_pr1 p1) (du_index_pr1 p2) => [a1 a2 a3][a4 a5 a6]. by rewrite q2; split => //; split => // ; dneg sq; apply: pair_exten. + move => i x y isr lt1; split => //; first by apply: q4; ue. by exists x, y. move=> u v [leuv neuv]. rewrite q2 in isr. have lt2: (glt (order_sum r g) (J u i) (J v i)). split; last by dneg sj; apply: (pr1_def sj). apply /orsum_gleP; split => //; last (by right; aw); apply: disjoint_union_pi1=>//; order_tac. move: (wg _ _ lt2) => [z [zl1 zne1] [zl2 zne2]]. move: (orsum_gle_id ax zl1)(orsum_gle_id ax zl2); aw. move=> lea leb; move: (order_antisymmetry q1 lea leb) => lec. move: zl1 zl2 => /orsum_gleP [_ zs zl1] /orsum_gleP [_ _ zl2]. move: (du_index_pr1 zs)=> [a1 a2 a3]. exists (P z); rewrite /glt;split => //. - case: zl1; first by rewrite /glt pr2_pair; move => [neq]. move=> [_]; aw. - move=> upz; case: zne1; apply: pair_exten; aw => //; fprops. - case: zl2; first by rewrite /glt pr2_pair -lec; move => [_ neq]. move=> [_]; rewrite -lec;aw. - move=> upz; case: zne2; apply: pair_exten; aw => //; fprops. + move=> i j ij. case: (p_or_not_p (exists u, maximal (vg i) u)); last first. by move => bad; constructor 2 => u mu; case: bad; exists u. case: (p_or_not_p (exists v, minimal (vg j) v)); last first. by move => bad _; constructor 3 => v mu; case: bad; exists v. move => [v [vs vm]] [u [us um]]. have idf: (inc i (domain g)) by rewrite -q2; order_tac. have jdf: (inc j (domain g)) by rewrite -q2; order_tac. have J1: (inc (J u i) (sum_of_substrates g)) by apply: disjoint_union_pi1. have J2: (inc (J v j) (sum_of_substrates g)) by apply: disjoint_union_pi1. have l1: (glt (order_sum r g) (J u i) (J v j)). split; first by apply/orsum_gleP; split => //; left; aw. move=> sj; move: ij => [_]; case; apply: (pr2_def sj). move: (wg _ _ l1) => [z [z1 z2] [z3 z4]]. move: z1 z3 =>/orsum_gleP [_ zs z5] /orsum_gleP [_ _ z6]. move: (du_index_pr1 zs)=> [a1 a2 a3]. case: z5; rewrite pr2_pair => a4. case: z6; rewrite pr2_pair => a5; first by constructor 1; exists (Q z). move: a5 => [Qa]; rewrite pr1_pair Qa => Pa. move: (vm _ Pa) => pz; case: z4; apply: pair_exten; aw; fprops. move: a4 => [Qa]; rewrite pr1_pair => Pa. move: (um _ Pa) => pz; case: z2; apply: pair_exten; aw; fprops. move=> [CI CII CIII]. have os: order (order_sum r g) by fprops. split => //. case: CI. move=> [i [j ij]]. have idf: (inc i (domain g)) by rewrite -q2; order_tac. have jdf: (inc j (domain g)) by rewrite -q2; order_tac. move: (ax2 idf)(ax2 jdf) => [u us] [v vs]. have J1: (inc (J u i) (sum_of_substrates g)) by apply: disjoint_union_pi1. have J2: (inc (J v j) (sum_of_substrates g)) by apply: disjoint_union_pi1. have l1: (glt (order_sum r g) (J u i) (J v j)). split; first by apply /orsum_gleP; split => //; left; aw. move=> sj; move: ij => [_]; case; apply: (pr2_def sj). by exists (J u i); exists (J v j). move=> [i [u [v [isr [leij neij]]]]]. rewrite q2 in isr; move: (q4 _ isr) => oi. exists (J u i); exists (J v i);split; last by dneg sj; apply: (pr1_def sj). apply /orsum_gleP; split => //; last (by right; aw); apply: disjoint_union_pi1 => //; order_tac. move=> x y [lexy nexy]; move: lexy => /orsum_gleP //. move=> [xsr ysr lexy]. move: (du_index_pr1 xsr) (du_index_pr1 ysr)=> [a1 a2 a3][a4 a5 a6]. case: lexy => lea. case: (CIII _ _ lea). + move=> [k k1 k2]. have ksr: (inc k (domain g)) by rewrite -q2; order_tac. move: (ax2 ksr) => [z zs]. have J1: (inc (J z k) (sum_of_substrates g)) by apply: disjoint_union_pi1. have xn: x <> J z k by move: k1 =>[_ Qx]; dneg xj;rewrite xj; aw. have yn: J z k <> y by move: k2 =>[_ Qx]; dneg xj;rewrite - xj; aw. exists (J z k); split => //; apply /orsum_gleP; split => //; left; aw. + move => nmm; move: (nmm (P x)); rewrite /maximal => nm. have [z zs pz]: (exists2 z, inc z (substrate (vg (Q x))) & glt (vg (Q x)) (P x) z). ex_middle ww; case: nm; split => // z z1. case:(equal_or_not (P x) z) => // pzx; case: ww; exists z => //;order_tac. have J1:inc (J z (Q x)) (sum_of_substrates g)by apply: disjoint_union_pi1. have xn: x <> J z (Q x) by move: pz =>[_ Qx]; dneg xj;rewrite xj; aw. have yn: J z (Q x) <> y by move: lea =>[_ Qx]; dneg xj;rewrite - xj; aw. exists (J z (Q x)); split => //; apply /orsum_gleP;split => //. by right; aw; move: pz => [pz _]. left; aw. + move => nmm;move: (nmm (P y)); rewrite /minimal => nm. have [z zs pz]: (exists2 z, inc z (substrate (vg (Q y))) & glt (vg (Q y)) z (P y)). ex_middle ww; case: nm;split => // z zl. case: (equal_or_not z (P y)) => // pzx; case: ww;exists z => //;order_tac. have J1: inc (J z (Q y)) (sum_of_substrates g) by apply: disjoint_union_pi1. have xn: x <> J z (Q y) by move: lea =>[_ Qx]; dneg xj;rewrite xj; aw. have yn: J z (Q y) <> y by move: pz =>[_ Qx]; dneg xj;rewrite - xj; aw. exists (J z (Q y)); split => //; apply /orsum_gleP; split => //. left; aw. by right; aw; move: pz => [pz _]. move: lea => [qxy sv]. have lv1: (glt (vg (Q x)) (P x) (P y)). by split=>//; dneg h; apply: pair_exten. have qsr: (inc (Q x) (substrate r)) by ue. move: (CII _ _ _ qsr lv1) => [w1 w2 w3]. move: (w3 _ _ lv1) => [z [z1 z2] [z3 z4]]. have zs: inc z (substrate (vg (Q x))) by order_tac. have J1: inc (J z (Q x)) (sum_of_substrates g) by apply: disjoint_union_pi1. have xn: x <> J z (Q x) by move=> xe; case: z2;rewrite xe; aw. have yn: J z (Q x) <> y by move=> xe; case: z4;rewrite - xe; aw. by exists (J z (Q x)); split => //;apply /orsum_gleP; split => //;right; aw. Qed. Lemma Exercise1_19b: (forall i u, ~ (maximal (Vg g i) u)) -> (forall i, inc i (substrate r) -> without_gaps (Vg g i)) -> without_gaps (order_sum r g). Proof. move: nesr=> [y yE] nm wg. apply /Exercise1_19a;split => //. right; move: (wg _ yE)=> [_ [a [b ab]] _]. by exists y, a, b. by move => i c z h _; apply: wg. move=> i j ij; constructor 2; apply: nm. Qed. Lemma Exercise1_19c: (forall i u, ~ (minimal (Vg g i) u)) -> (forall i, inc i (substrate r) -> without_gaps (Vg g i)) -> without_gaps (order_sum r g). Proof. move: nesr => [y yE] nm wg. apply /Exercise1_19a;split => //. + by right; move: (wg _ yE)=> [_ [a [b ab]] _]; exists y, a, b. + by move => i c z h _; apply: wg. + move=> i j ij; constructor 3; apply: nm. Qed. Lemma Exercise1_19d: without_gaps r -> (forall i, inc i (substrate r) -> (without_gaps (Vg g i) \/ (forall x y, inc x (substrate (Vg g i)) -> inc y (substrate (Vg g i)) -> ~ (glt (Vg g i) x y)))) -> without_gaps (order_sum r g). Proof. move:nesr => [y yE] [_ q1 q2] wg. apply/Exercise1_19a=> //; split; fprops; last first. by move => i j /q2 h; constructor 1. move=> i u v isr luv; case: (wg _ isr) => // h. have p1:inc u (substrate (Vg g i)) by order_tac. have p2:inc v (substrate (Vg g i)) by order_tac. by case: (h _ _ p1 p2). Qed. End Exercise1_19. (** ---- Exercise 1.20 Scattered sets*) Definition scattered r := order r /\ (forall x, sub x (substrate r) -> ~ (without_gaps (induced_order r x))). Lemma Exercise1_20a r x: sub x (substrate r) -> scattered r -> scattered (induced_order r x). Proof. move=> xsr [or sc]; move: (iorder_osr or xsr) => [pa pb]. split => // y; rewrite pb => yx. by rewrite iorder_trans //; apply: sc; apply: (sub_trans yx). Qed. Lemma Exercise1_20b r: worder r -> scattered r. Proof. move=> wor;split; first by move: (wor) => [or _]. move=> z zsr. have : (worder (induced_order r z)) by apply: induced_wor. set (y:= induced_order r z). move=> woy [_ [a [b ab] yy]]. have asr: (inc a (substrate y)) by order_tac. have nesy: (nonempty (substrate y)) by exists a. move: (worder_least woy nesy) => [c [cs cl]]. move: woy => [oy woy]. set (F:= (substrate y) -s1 c). have zs: (sub F (substrate y)) by apply: sub_setC. have bF: (inc b F). apply /setC1_P; split; first by order_tac. move: (cl _ asr) => aux;have aux1: (glt y c b) by order_tac. by move: aux1 => [_];aw; apply:nesym. have neF: (nonempty F) by exists b. move: (woy _ zs neF) => [d []]; aw => dF dp. move: dF => /setC1_P [ds dc]; move: (cl _ ds) => cd1. have cd2: glt y c d by split => //; apply:nesym. move: (yy _ _ cd2)=> [e [e1 ne1] e2]. have eF: inc e F by apply /setC1_P; split;[order_tac | aw;apply:nesym]. move: (iorder_gle1 (dp _ eF)) => h; order_tac. Qed. (** any scattered set satisfies the following property; the convetse is false *) Definition Exercise1_20_prop r:= forall x y, glt r x y -> exists x' y', [/\ gle r x x', glt r x' y', gle r y' y & (forall z, ~ (glt r x' z /\ glt r z y'))]. Lemma Exercise1_20c r: scattered r -> Exercise1_20_prop r. Proof. move=> [or sc] x y xy. set (F:= interval_cc r x y). have Fs: (sub F (substrate r)) by apply: Zo_S. move: (iorder_osr or Fs)=> [or1 sr1]. move: (sc _ Fs) => nw; ex_middle bad; case: nw;split => //. have xsr: inc x (substrate r) by order_tac. have ysr: inc y (substrate r) by order_tac. exists x, y; move: xy => [xy nxy]; split; last by exact. by apply /iorder_gleP => //; apply: Zo_i =>//; split => //; order_tac. move => a b ab. have ab2: (glt r a b) by apply: (iorder_gle2 ab). move: (iorder_gle4 ab) => [aF bF]. move: (iorder_gle4 ab) => [] /Zo_hi [xa _] /Zo_hi [_ lby]. ex_middle bad1; case: bad;exists a,b;split => // z [[az anz] [bz bnz0]]. have zF: inc z F by apply: Zo_i; [ order_tac | split => //; order_tac]. by case: bad1; exists z; split => //;apply /iorder_gleP. Qed. Definition cantor_tri_aux := cst_graph Nat canonical_doubleton_order. Definition cantor_tri_order:= order_prod Nat_order cantor_tri_aux. Definition cantor_tri_sub:= productb (cst_graph Nat C2). Lemma cantor_tri_order_axioms: orprod_ax Nat_order cantor_tri_aux. Proof. rewrite/cantor_tri_aux;move : Nat_order_wor => [pa pb]. by split=> //; hnf; bw => i ib ; bw; move: cdo_wor => [[ok _] _]. Qed. Lemma cantor_tri_order_total : total_order cantor_tri_order. Proof. rewrite /cantor_tri_order/cantor_tri_aux; apply: orprod_total. by apply: cantor_tri_order_axioms. red;bw => i iN; bw; apply: (worder_total (proj1 cdo_wor)). Qed. Lemma cantor_tri_order_sr1 : prod_of_substrates cantor_tri_aux = cantor_tri_sub. Proof. congr (productb);rewrite /fam_of_substrates /cantor_tri_aux ; bw. apply: Lg_exten; move=> x xN /=; bw; exact (proj2 cdo_wor). Qed. Lemma cantor_tri_order_sr : substrate cantor_tri_order = cantor_tri_sub. Proof. rewrite /cantor_tri_order orprod_sr. apply: cantor_tri_order_sr1. apply: cantor_tri_order_axioms. Qed. Lemma cantor_tri_order_gltP x x': glt cantor_tri_order x x' <-> [/\ inc x cantor_tri_sub, inc x' cantor_tri_sub & exists j, [/\ natp j, (forall i, natp i -> i Vg x i = Vg x' i), Vg x j = C0 & Vg x' j = C1]]. Proof. rewrite /cantor_tri_order. set r := Nat_order;set g := cantor_tri_aux. have op: orprod_ax r g by apply: cantor_tri_order_axioms. have sr: substrate r = Nat by rewrite /r (proj2 Nat_order_wor). have rvP: forall j, natp j -> forall u v, (glt (Vg g j) (Vg u j) (Vg v j) <-> (Vg u j = C0 /\ Vg v j = C1)). move=> j jN u v; rewrite /g/cantor_tri_aux; bw;rewrite /glt; split. by move => [] /cdo_gleP h1; case: h1 => // [][-> ->]. move=> [ -> -> ]; split; [ apply /cdo_gleP; in_TP4 | fprops]. have rijP: forall i j, natp j -> (glt r i j <-> (natp i /\ i i j jN; split;first by move => [] /Nat_order_leP [pa pb pc] pd. by move => [pa [pb pc]]; split => //; apply/Nat_order_leP. split. move => [] /(orprod_gleP op); rewrite cantor_tri_order_sr1. move=> [p1 p2 p3] p4; split => //; case: p3; first by move=> aux. rewrite sr;move=> [j [jsr /(rvP _ jsr) [pa pb] lt2]]. by exists j; split => // i iN ij; apply: lt2; apply / rijP. move=> [p1 p2 [j [jb jp1 jp2 jp3]]]; split. apply /(orprod_gleP op);rewrite cantor_tri_order_sr1;split => //. right;exists j;split => //;[ ue | by apply/rvP | ]. move => i /(rijP _ _ jb) [pa pb]; apply: (jp1 _ pa pb). move=> uv; rewrite uv jp3 in jp2; fprops. Qed. Lemma Exercise1_20d: Exercise1_20_prop cantor_tri_order. Proof. move=> x y. move /cantor_tri_order_gltP => [xb yb [j [jN sj jx jy]]]. pose f i := Yo (i <=c j) (Vg x i) C1. pose g i := Yo (i <=c j) (Vg y i) C0. have fgPr: (fgraph (cst_graph Nat C2)) by fprops. move: (xb)(yb) => /setXf_P [fgx dx xVV] /setXf_P [fgy dy yVV]. have fPr: (inc (Lg Nat f) cantor_tri_sub). apply /setXf_P;split;fprops; bw;move=> i iN; rewrite /f; bw. Ytac hle; fprops; move: (xVVg _ iN); bw. have gPr: (inc (Lg Nat g) cantor_tri_sub ). apply /setXf_P;split;fprops; bw;move=> i iN; rewrite /g; bw. Ytac h; fprops; move: (yVVg _ iN); bw. move: cantor_tri_order_total => [co _]. pose Zab a x := Zo Nat (fun i => j exists k, [/\ natp k, j i i <=c j \/ Vg x i <> a)]. move=> a u [v vZ]. have ov: ordinalp v by apply /OS_nat; apply: (Zo_S vZ). move: (least_ordinal4 (p := fun z=> inc z (Zab a u)) ov vZ). set w:= least_ordinal _ _ ; move => [wa /Zo_P [wb [wc wd]] we]. exists w; split => // i iN iw. case: (inc_or_not i (Zab a u)) => h. case: (oleNgt (we _ (OS_nat iN) h) (oclt iw)). case: (equal_or_not (Vg u i) a) => eq; last by right. by case: (NleT_el iN (NS_lt_nat wc wb))=> ji; [by left | case: h;apply: Zo_i]. have p1: gle cantor_tri_order x (Lg Nat f). case: (emptyset_dichot (Zab C0 x)) => Ze. suff: x = (Lg Nat f) by move=> <- ;order_tac;rewrite cantor_tri_order_sr. apply: fgraph_exten => //; bw; fprops. rewrite dx; move=> i iN; rewrite /f; bw. Ytac hle =>//; move: (xVV _ iN); bw; case/C2_P => // vb. by empty_tac1 i; apply: Zo_i => //; split => //;case: (NleT_el iN jN). suff: glt cantor_tri_order x (Lg Nat f) by move=> [ok _]. move:(Zabp C0 x Ze) => [k [kN jk vk lt]]. apply /cantor_tri_order_gltP; split => //. exists k; split => //; last by bw;rewrite /f (Y_false (cltNge jk)). move=> i iN ik; rewrite /f; bw. Ytac hle => //; case: (lt _ iN ik)=> // va. move: (xVV _ iN); bw; case/C2_P => //. have p2: gle cantor_tri_order (Lg Nat g) y. case: (emptyset_dichot (Zab C1 y)) => Ze. suff: y = (Lg Nat g) by move=> <- ;order_tac;rewrite cantor_tri_order_sr //. apply: fgraph_exten => //; bw; fprops. rewrite dy; move=> i iN; rewrite /g; bw. Ytac hle => //; move: (yVV _ iN); bw; case/C2_P => // vb. by empty_tac1 i; apply: Zo_i => //;split => //; case: (NleT_el iN jN). suff: glt cantor_tri_order (Lg Nat g) y by move=> [ok _]. move:(Zabp C1 y Ze) => [k [kN jk vk lt]]. apply /cantor_tri_order_gltP; split => //. exists k; split => //; last by rewrite /g; bw; rewrite (Y_false (cltNge jk)). move=> i iN ik; rewrite /g; bw; Ytac ij => //. case: (lt _ iN ik)=> // va; move: (yVV _ iN); bw; case/C2_P=> //. have jj: j <=c j by apply: cleR; fprops. exists (Lg Nat f), (Lg Nat g); split => //. apply /cantor_tri_order_gltP;split => //;exists j. rewrite /f/g; bw; Ytac0; Ytac0; split => //. by move => i ib [ij nij]; bw; Ytac0; Ytac0;apply: sj. move=> z [] /cantor_tri_order_gltP [_ zsub [k1 [k1N k1p k1a k1b]]]. move /cantor_tri_order_gltP => [_ _ [k2 [k2N k2p k2a k2b]]]. move: k1a k2b; rewrite /f /g; bw; Ytac k1j; Ytac k2j => k1a k2b; try (solve [apply: C0_ne_C1; done]). case: (NleT_el k1N k2N) => k1k2. have l12: k1 //h; case: C0_ne_C1; rewrite -k1b -k2a h. move: (k2p _ k1N l12); rewrite /g; bw; rewrite (Y_true k1j) k1b. rewrite -(sj _ k1N (clt_leT l12 k2j)) k1a; fprops. move: (k1p _ k2N k1k2); rewrite /f; bw; rewrite (Y_true k2j) k2a. rewrite (sj _ k2N (clt_leT k1k2 k1j)) k2b; fprops. Qed. Lemma Exercise1_20e: ~ (scattered cantor_tri_order). Proof. move=> ns. set (all_a := Zo cantor_tri_sub (fun z => exists2 i, natp i & forall j, natp j -> i <=c j -> Vg z j = C0)). set (F:= cantor_tri_sub -s all_a). have sF: (sub F cantor_tri_sub) by apply: sub_setC. have FpP: forall a, inc a F <-> (inc a cantor_tri_sub /\ forall i, natp i -> exists j, [/\ natp j, i <=c j & Vg a j = C1]). move=> a; split. move /setC_P => [p1 p2];split =>// i iN; ex_middle nf; case: p2. apply: Zo_i => //; exists i => // j jN ij; ex_middle vj; case: nf. exists j; split => //. move: p1 => /setXf_P [_ _ aux]; move: (aux _ jN);case/C2_P =>//. move => [pa pb]; apply /setC_P;split => //; move => /Zo_P [_ [i iN h]]. move: (pb _ iN) =>[j [p3 p4]];rewrite (h _ p3 p4); fprops. have sf1: sub F (substrate cantor_tri_order) by rewrite cantor_tri_order_sr. move: (iorder_osr (proj1 ns) sf1) => [xa xb]. move: ns => [oc ns]; case: (ns _ sf1);split; fprops. set zb:= (cst_graph Nat C1). set zab:= (Lg Nat (fun i => Yo (i = \0c) C0 C1)). have zbF: (inc zb F). apply /FpP; rewrite /zb; split. apply /setXf_P; split;fprops;bw => i iN; bw; fprops. move=> i iN; exists i; split => //; bw;fprops; apply:NS_succ. have zabF: inc zab F. apply /FpP; rewrite /zab; split. apply /setXf_P;split => //;bw; fprops => i iN; bw; Ytac h; fprops. move=> i iN; move:(NS_succ iN) => nsiN; exists (csucc i). split=> //; bw; fprops; rewrite Y_false //; apply: succ_nz. have [lt1 ne1]: (glt cantor_tri_order zab zb). have zeb:= NS0. apply /cantor_tri_order_gltP => //;split => //. by move: zabF => /setC_P []. by move: zbF => /setC_P []. exists \0c; rewrite /zb /zab; split => //; bw; last by Ytac0. move => i iN iz; case: (clt0 iz). exists zab, zb; split => //; apply /iorder_gleP => //. move=> f g fg. move: (iorder_gle2 fg)(iorder_gle4 fg). move /cantor_tri_order_gltP => [fsr gsr [j [jN sj fj gj]]][fs gs]. have scj:= NS_succ jN. move: (gs)=>/FpP [gc ha]. move: (ha _ scj) => [k [kN kle Vk]]. move: kle;rewrite cleSltP // => kle. set (h:= Lg Nat (fun i=> Yo (i= k) C0 (Vg g i))). have hF: inc h F. apply /FpP; split. rewrite /h;apply/setXf_P;split => //;bw; fprops=> i iN; bw; Ytac h0; fprops. by move: gc => /setXf_P [_ _]; apply. move=> i iN. move:(cmax_p1 (CS_nat iN) (CS_succ k)) => []; set l := cmax _ _ => sa sb. have lN: natp l by rewrite/l /cmax; Ytac hp => //; fprops. move: (ha _ lN) => [n [nN mn Vb]]. exists n;split => //; first exact:(cleT sa mn). case: (equal_or_not k n) => kn; last by rewrite /h; bw; Ytac0. by move:(cltS nN) (cleT sb mn); rewrite kn => sc /(cltNge sc). have [lt1 n1]: glt cantor_tri_order f h. apply /cantor_tri_order_gltP; split;fprops;exists j; split => //. move=> i iB ij; rewrite (sj _ iB ij); rewrite /h; bw. by rewrite (Y_false (proj2 (clt_ltT ij kle))). by move: kle => [_ kne]; rewrite /h -gj; bw; Ytac0. have [lt2 n2]: glt cantor_tri_order h g. apply /cantor_tri_order_gltP; split => //. by move: hF => /setC_P []. exists k; split => //; last by rewrite /h; bw; Ytac0. by move=> i iB [_ iK]; rewrite /h; bw; Ytac0. exists h; split => //; apply /iorder_gleP => //. Qed. (** when is an ordinal sum scattered *) Lemma Exercise1_20f r g: orsum_ax r g -> orsum_ax2 g -> (scattered (order_sum r g) <-> (scattered r /\ forall i, inc i (domain g) -> scattered (Vg g i))). Proof. move=> oa alne. move: (oa) =>[or sr alg];split. have so := (orsum_sr oa). pose R i := rep (substrate (Vg g i)). move=> [oar sca]; split. split => //x xsr [] nw1 [xa [xb lab]] nw3. set w:= fun_image x (fun i => (J (R i) i)). have sw: (sub w (substrate (order_sum r g))). rewrite so => t /funI_P [z zx ->]. have zdg:inc z (domain g) by rewrite - sr; apply: xsr. by apply: disjoint_union_pi1 => //; apply: rep_i; apply: alne. move: (iorder_osr oar sw) => [oa1 sa1]. have p1: forall a b, glt (induced_order r x) a b -> glt (induced_order (order_sum r g) w) (J (R a) a) (J (R b) b). move=> a b ab. move: (iorder_gle4 ab)(iorder_gle2 ab) => [xax xbx] lab'. split; last by move: lab' => [_ nab] sj; move: (pr2_def sj). have raw: inc (J (R a) a) w by apply :funI_i. have rbw: inc (J (R b) b) w by apply :funI_i. apply /(iorder_gleP _ raw rbw)/orsum_gleP; split => //; try ue;left;aw. move: (sca _ sw); case; split => //. by exists (J (R xa) xa); exists (J (R xb) xb); apply: p1. move=> u v uv. move: (iorder_gle4 uv)(iorder_gle2 uv) => [uw vw] [luv nuv]. move: (orsum_gle_id oa luv) => le1. move: uw vw => /funI_P [u' u'x J1] /funI_P [v' v'x J2]. have lt1: glt (induced_order r x) u' v'. move: le1; rewrite J1 J2; aw => le2. split; [ by apply /iorder_gleP | by dneg uv1; rewrite J1 J2 uv1]. move: (nw3 _ _ lt1) => [z z1 z2]. by rewrite J1 J2; exists (J (R z) z); apply: p1. move=> i idg. move: (alg _ idg) => og. split => // x xsr [nw1 [xa [xb lab]] nw3]. set (w:= fun_image x (fun u => (J u i))). have sw: (sub w (substrate (order_sum r g))). rewrite orsum_sr // => t /funI_P [z zx ->]. by apply: disjoint_union_pi1 => //; apply: xsr. move: (iorder_osr oar sw) => [oa1 sa1]. have p1: forall a b, glt (induced_order (Vg g i) x) a b -> glt (induced_order (order_sum r g) w) (J a i) (J b i). move=> a b ab. move: (iorder_gle4 ab)(iorder_gle2 ab) => [xax xbx] [lab1 lab2]. split; last by move => sj; move: (pr1_def sj). have raw: inc (J a i) w by apply:funI_i. have rbw: inc (J b i) w by apply:funI_i. by apply /iorder_gleP => //; apply/orsum_gleP; split; try ue; right;aw. move: (sca _ sw); case; split => //. by exists (J xa i); exists (J xb i); apply: p1. move=> u v uv. move: (iorder_gle4 uv)(iorder_gle2 uv) => [uw vw] [luv nuv]. move: uw vw => /funI_P [u' u'x J1] /funI_P [v' v'x J2]. move: luv => /orsum_gleP // [_ _]. rewrite J1 J2; aw;case; first (by aw; move=> [_]; case); aw; move=> [_ le0]. have lt1: glt (induced_order (Vg g i) x) u' v'. split; [ by apply /iorder_gleP | by dneg uv1; rewrite J1 J2 uv1]. move: (nw3 _ _ lt1) => [z z1 z2]. by exists (J z i)=> //; apply: p1. move=> [scr alsci]; split; first by fprops. move=> x xsr. set (ns := Zo (substrate r) (fun z => exists2 i, inc i x & z = Q i)). set (r' := induced_order r ns). have nss: (sub ns (substrate r)) by apply: Zo_S. move: (iorder_osr or nss) => [or' sr']. pose f i := Zo (substrate (Vg g i)) (fun u => inc (J u i) x). have fp1: forall i, sub (f i) (substrate (Vg g i)) by move=> i; apply: Zo_S. set (g' := Lg ns (fun i=> induced_order (Vg g i) (f i))). have dr':substrate r' = domain g' by rewrite /g'; bw. move: alg;rewrite /order_fam /allf - sr => alg. have svig': forall i, inc i ns -> f i = substrate (Vg g' i). move=> i ins; rewrite /g'; bw. rewrite iorder_sr //; exact: (alg _ (nss _ ins)). have alne' : forall i, inc i (domain g') -> nonempty (substrate (Vg g' i)). rewrite -dr' sr'; move=> i ins; rewrite - svig' //. move: ins => /Zo_P [isr [j jx Qj]]; aw. rewrite orsum_sr // in xsr. move: (du_index_pr1 (xsr _ jx)) => [p1 p2 p3]. by exists (P j); apply: Zo_i; rewrite Qj // p3. have oa': orsum_ax r' g'. split => //; rewrite /g';hnf; bw; rewrite /g'=> i ins; bw. exact:(proj1 (iorder_osr (alg _ (nss _ ins)) (fp1 i))). have or'': order (order_sum r' g') by fprops. have sr'': (x = substrate (order_sum r' g')). move: xsr; rewrite ! orsum_sr // => xsr. set_extens t. move=> tx; move: (du_index_pr1 (xsr _ tx)) => [Qt Pt pt]. have qns: inc (Q t) ns by apply: Zo_i; [ ue | ex_tac ]. rewrite - pt; apply: disjoint_union_pi1. rewrite -dr' sr' //. by rewrite - svig' //; apply: Zo_i =>//; rewrite pt. move=> ts; move:(du_index_pr1 ts) => [Qt Pt pt]. have qns: inc (Q t) ns by rewrite - sr' dr'. by move: Pt; rewrite - (svig' _ qns) => /Zo_hi; rewrite pt. have ss': (sum_of_substrates g') = x by rewrite sr'' orsum_sr //. have auxP: forall u v, inc u x -> inc v x -> (gle (order_sum r g) u v <-> gle (order_sum r' g') u v). move=> u v ux vx. move: xsr; rewrite (orsum_sr oa) => xsr. move: (du_index_pr1 (xsr _ ux))=> [u1a u1b u1c]. move: (du_index_pr1 (xsr _ vx))=> [v1a v1b v1c]. have Quns: inc (Q u) ns by apply: Zo_i; [ue | exists u]. have Qvns: inc (Q v) ns by apply: Zo_i; [ue | exists v]. split; last first. move => /orsum_gleP [pa pb pc]; apply /orsum_gleP;split. move:xsr pa; rewrite - ss';apply. move:xsr pb; rewrite - ss'; apply. case: pc; move => [h1 h2]; [ left | right];split => //. by move: (iorder_gle1 h1). by move: h2; rewrite /g'; bw => /iorder_gle1. move => /orsum_gleP [pa pb pc]; apply /orsum_gleP;split; try ue. case: pc; move => [h1 h2]; [ left | right];split => //. by apply /iorder_gleP. rewrite /g'; bw; apply /iorder_gleP => //; apply: Zo_i => //; [ by rewrite u1c | ue| by rewrite h1 v1c]. have io: (induced_order (order_sum r g) x = (order_sum r' g')). have oo: (order (order_sum r g)) by fprops. move: (iorder_osr oo xsr) => [oo1 _]. have o1: order (induced_order (order_sum r g) x) by fprops. apply: order_exten => // => u v; split => rel1. move: (iorder_gle3 rel1) => [ux vx]. by move: (iorder_gle1 rel1) =>/(auxP _ _ ux vx). have ux: inc u x by rewrite sr'' ; order_tac. have vx: inc v x by rewrite sr''; order_tac. by apply /iorder_gleP => //; apply/auxP. rewrite io; apply /(Exercise1_19a oa' alne'). move=> [wg1 wg2 wg3]. have p1: (forall i x y, inc i (substrate r') -> ~ glt (Vg g' i) x y). move=> i u v isr'; case: (p_or_not_p (glt (Vg g' i) u v)) => // xy. move: (wg2 _ _ _ isr' xy) => p1. rewrite sr' in isr'. have idg: inc i (domain g) by rewrite - sr; apply: nss. move: (alsci _ idg) => [sca scb]. have scc: (sub (f i) (substrate (Vg g i))) by apply: Zo_S. move: p1 (scb _ scc); rewrite (svig' _ isr'); rewrite /g';bw; aw; done. move: scr => [_ scr]; move: (scr _ nss); case; split; fprops. case: wg1 => //; by move=> [i [u [v [isr uv]]]]; case: (p1 i u v isr). rewrite dr' in p1. move=> u v uv; case: (wg3 _ _ uv); first (by done); move => hm. have udg': inc u (domain g') by rewrite -dr'; order_tac. move: (rep_i (alne' _ udg')) => rm. case: (hm (rep (substrate (Vg g' u)))); split => //. move=> w we; symmetry; ex_middle wr; case:(p1 _ _ _ udg' (conj we wr)). have vdg': inc v (domain g') by rewrite -dr'; order_tac. move: (rep_i (alne' _ vdg')) => rm. case: (hm (rep (substrate (Vg g' v)))); split => //. move=> w we; ex_middle wr; case:(p1 _ _ _ vdg' (conj we wr)). Qed. (** ---- Exercise 1.21 Any set is isomorphic to an ordinal sum of scatteres sets whose index set is without gaps *) Lemma Exercise1_2g r s: weak_order_compatibility r s-> Ex1_2_hC' r s -> total_order r -> let r' := (quotient_order r s) in forall x y, gle r' x y <-> [/\ inc x (quotient s) , inc y (quotient s)& gle r (rep x) (rep y)]. Proof. move=> [[ps es sr] woc] qoa [or tor] r' x y. have ru: (forall u, inc u (quotient s) -> inc (rep u) u). by move=> u uq; apply: (setQ_repi es uq). split. move /quotient_orderP=> [xq yq etc]; split => //. move: (ru _ xq) (ru _ yq) => rxx ryy. have rxs: (inc (rep x) (substrate r)) by rewrite - sr; fprops. have rys: (inc (rep y) (substrate r)) by rewrite - sr; fprops. case: (tor _ _ rys rxs) => // crxy. move: (etc _ rxx) => [z zy rz]. have ryz: (gle r (rep y) z) by order_tac. have syz: (related s (rep y) z). by apply /(rel_in_class es _ zy); apply /(setQ_P es). by move: (qoa _ _ _ crxy rz syz) =>/(related_rr_P es yq xq) ->; order_tac. move => [xq yq rr]. apply /quotient_orderP;split => //;move=> u ux. move: (ru _ xq) (ru _ yq) => rxx ryy. have rrux: (related s (rep x) u). by apply /(rel_in_class es _ ux); apply /(setQ_P es). move: (woc _ _ _ rr rrux)=> [v v1 v2]; exists v => //. by apply: (rel_in_class2 es _ v1); apply /(setQ_P es). Qed. Lemma Exercise1_2h r s: weak_order_compatibility r s-> Ex1_2_hC' r s -> total_order r -> total_order (quotient_order r s). Proof. move=> woc qoa tor. move: (Exercise1_2g woc qoa tor) => e2g. move: (woc) tor => [[ps es sr] woc'] [or tor]. move: (Exercise1_2d es or sr qoa) => oqo; split => //. rewrite substrate_quotient_order //. move=> x y xq yq. have rx: (inc (rep x) (substrate r)) by rewrite - sr; apply: rep_i_sr. have ry: (inc (rep y) (substrate r)) by rewrite - sr; apply: rep_i_sr. by case: (tor _ _ rx ry) => h; [left | right]; rewrite e2g. Qed. Lemma Exercise1_2i r s (q := quotient s) (r' := quotient_order r s) (f' := identity_g q) (g' := Lg q (fun z => induced_order r z)) (du := disjointU f') (f := Lf (fun x => J x (class s x)) (substrate r) du): weak_order_compatibility r s-> Ex1_2_hC' r s -> total_order r -> [/\ orsum_ax r' g', (forall i, inc i (domain g') -> nonempty (substrate (Vg g' i))), substrate (order_sum r' g') = du, (forall x y, inc x (substrate r) -> inc y (substrate r) -> (related s x y <-> related (equivalence_associated (second_proj du)) (Vf f x) (Vf f y)))& order_isomorphism f r (order_sum r' g')]. Proof. move=> woc qoa tor. move: (Exercise1_2g woc qoa tor) (Exercise1_2h woc qoa tor)=> p1 [p2 p3]. move: woc tor => [[ps es sr] woc'] [or tor]. have sr': (substrate r' = q) by rewrite /r' substrate_quotient_order //. have iqs: (forall i, inc i q -> sub i (substrate r)). move=> i iq t ti; rewrite - sr;apply: (inc_in_setQ_sr es ti iq). have oa1: orsum_ax r' g'. rewrite /g';split => //; aw; bw. hnf;bw;move=> i iq; bw; move: (iqs _ iq) => h. apply: (proj1 (iorder_osr or h)). have oa2: (forall i : Set, inc i (domain g') -> nonempty (substrate (Vg g' i))). rewrite /g'; bw; move=> i iq; bw; move: (iqs _ iq) => h; aw. apply: (setQ_ne es iq). have sos: substrate (order_sum r' g') = du. rewrite orsum_sr // /du /sum_of_substrates /f' /fam_of_substrates. rewrite /g'; bw; apply: f_equal; apply: Lg_exten => x xd /=; bw; aw; fprops. have ta: lf_axiom (fun x => J x (class s x)) (substrate r) du. move=> t tr /=. have ts: inc t (substrate s) by ue. have tc: inc t (class s t) by apply:inc_itself_class => //. apply: disjointU_pi; rewrite /f'. rewrite identity_d; apply /(setQ_P es); apply: class_class => //. by rewrite /identity_g; bw; apply: inc_class_setQ. have bf: bijection f. rewrite /f;apply: lf_bijective => //. move=> u v _ _ sj; apply: (pr1_def sj). move=> y ydu; move: (disjointU_hi ydu). rewrite /f' /identity_g Lg_domain; move=> [qy]; bw => Py py. move: ((iqs _ qy) _ Py) => psr; ex_tac; apply: pair_exten; fprops; aw. apply: is_class_pr => //. have tf: du = target f by rewrite /f; aw. have sf: substrate r = source f by rewrite /f; aw. have du1: du = sum_of_substrates g' by rewrite - sos orsum_sr //. split => //. move=> x y xsr ysr. have sxx:related s x x by rewrite - sr in xsr;equiv_tac. rewrite du1 -/(E13_S _) /f; aw; split. move => sxy; apply/(Exercise1_3a6P g'); aw;split => //. by rewrite /E13_sF -du1; apply: ta. by rewrite /E13_sF -du1; apply: ta. by move /(related_equiv_P es): sxy => [_ _]. move /(Exercise1_3a6P g'); move => [_ _]; aw => h. apply /(related_equiv_P es);split => //; ue. split => //; fprops. split;aw; ue. red; rewrite - sf; move=> x y xsf ysf; rewrite /f; aw. have Jx: inc (J x (class s x)) du by apply: ta. have Jy: inc (J y (class s y)) du by apply: ta. rewrite - sr in xsf ysf. have cxq: inc (class s x) q by apply: inc_class_setQ. have cyq: inc (class s y) q by apply: inc_class_setQ. have xcx: inc x (class s x) by apply:inc_itself_class. have ycy: inc y (class s y) by apply:inc_itself_class. have sxx:related s x x by equiv_tac. split. move => rxy; apply /orsum_gleP; rewrite -du1;split => //. case: (p_or_not_p (related s x y)) => sxy. have aux: class s x = class s y by apply: class_eq1. right;split => //; aw; rewrite /g'; bw; apply /iorder_gleP => //; ue. left; aw;split; last by dneg xx; apply /(related_equiv_P es). apply /quotient_orderP; split => //. move=> z /(class_P es) sxz; move: (woc' x y z rxy sxz)=> [t syt rzt]. by exists t=> //; apply /(class_P es). move /orsum_gleP => [_ _]; case; last first. move=> [_]; aw; rewrite /g'; bw=> h; apply: (iorder_gle1 h). aw; move => [] /quotient_orderP [q1 q2 h] necc. move: (h _ xcx) => [z zc xz]. rewrite sr in xsf ysf;case: (tor _ _ xsf ysf) => // yx. case: necc; apply: (class_eq1 es). apply: (symmetricity_e es);move: zc => /(class_P es) zc. apply: (qoa y x z yx xz zc). Qed. Lemma Exercise1_2j r s: weak_order_compatibility r s-> Ex1_2_hC' r s -> total_order r -> let r' := (quotient_order r s) in forall x y, inc x (substrate r ) -> inc y (substrate r) -> ((gle r x y -> gle r' (class s x) (class s y)) /\ (glt r' (class s x) (class s y) -> glt r x y)). Proof. move=> woc qoa tor r' x y xsr ysr. move: (Exercise1_2h woc qoa tor) => [tqor _]. move: tor woc => [or tor'] [[ps es sr] woc']. have aux : forall x y,gle r x y -> gle r' (class s x) (class s y). move=> a b ab; apply /quotient_orderP. move: (arg1_sr ab) (arg2_sr ab). rewrite - sr => asr bsr; split => //; try apply: inc_class_setQ => //. move=> c /(class_P es) ac. by move: (woc' _ _ _ ab ac) => [d bd cd]; exists d=> //; apply /(class_P es). split; first by apply: aux => //. move=> [h1 nc]; split; last by dneg xy; ue. case: (tor' _ _ xsr ysr) => // xy; move: (aux _ _ xy) => h2. case: nc; order_tac. Qed. Definition scattered_rel r x y := (gle r x y /\ scattered (induced_order r (interval_cc r x y))) \/ (gle r y x /\ scattered (induced_order r (interval_cc r y x))). Definition scattered_equiv r := graph_on (scattered_rel r) (substrate r). Lemma Exercise1_21aP r v: order r -> sub v (substrate r) -> (scattered (induced_order r v) <-> (forall u, sub u v -> ~ without_gaps (induced_order r u))). Proof. move => or vsr; rewrite /scattered. move: (iorder_osr or vsr) => [pa pb];rewrite pb => //; split. by move=> [oi h] u uv; move: (h _ uv); rewrite iorder_trans //. move=> h;split;fprops;move=> x xv; move:(h _ xv); rewrite iorder_trans //. Qed. Lemma Exercise1_21bP r u: total_order r -> sub u (substrate r) -> ((exists x y, glt (induced_order r u) x y) <-> (exists x y, [/\ inc x u, inc y u & x<> y])). Proof. move=> [or tor] uv; split. move=> [x [y [h1 h2]]]. move: (iorder_gle3 h1) => [xr yr]; exists x, y; split => //. move=> [x [y [h1 h3 h4]]]; case: (tor _ _ (uv _ h1) (uv _ h3)) => h5. by exists x; exists y; split =>//; apply /iorder_gleP. by exists y; exists x; split; [ apply /iorder_gleP |apply:nesym ]. Qed. Lemma Exercise1_21cP r u: total_order r -> sub u (substrate r) -> ((forall a b, inc a u -> inc b u -> a = b) <-> ~ (exists x y, glt (induced_order r u) x y)). Proof. move=> tor usr; split. move => ha hb; move / (Exercise1_21bP tor usr) : hb =>[x [y [xu yu]]]. case; apply (ha _ _ xu yu). move =>h a b au bu; ex_middle ab; case: h. by apply/ (Exercise1_21bP tor usr); exists a, b. Qed. Lemma Exercise1_21dP r u: total_order r -> sub u (substrate r) -> ((~ without_gaps (induced_order r u)) <-> ((forall a b, inc a u -> inc b u -> a = b) \/ (exists a b, [/\ inc a u, inc b u, glt r a b & (forall z, inc z u -> gle r z a \/ gle r b z)]))). Proof. move=> tor usr; move: (tor) => [or tor']. move: (iorder_osr or usr) => [oi soi]. rewrite / without_gaps. set P1:= (exists x y, glt (induced_order r u) x y). split => h1. case: (p_or_not_p P1) => np1; [right | left ] =>//; last by apply/(Exercise1_21cP tor usr). ex_middle emh; case: h1; split => //; move=> x y ltxy. ex_middle aux; case: emh. move:(iorder_gle4 ltxy)(iorder_gle2 ltxy)=> [h2 h3] h4. exists x, y; split => //; move => z zu. move: (usr _ zu) (usr _ h2) (usr _ h3) => zs xs ys. case: (tor' _ _ zs ys) => h6; last by right. case: (tor' _ _ xs zs) => h5; last by left. case: (equal_or_not x z) => xz; first by left; rewrite xz; order_tac. case: (equal_or_not y z) => yz; first by right; rewrite yz; order_tac. have zy: z <> y by apply:nesym. case: aux; exists z; apply /iorder_gle6P; split => //. move=> [_ P1t h2]. case: h1; first by move /(Exercise1_21cP tor usr); case. move=> [a [b [au bu ab etc]]]. have aux: glt (induced_order r u) a b by apply /iorder_gle6P. move: (h2 _ _ aux)=> [z] /iorder_gle6P [_ zu za]/iorder_gle6P [_ _ zb]. case: (etc _ zu) => h3; order_tac. Qed. Lemma Exercise1_21e r u a b: total_order r -> let v:= u \cap (interval_cc r a b) in sub u (substrate r) -> without_gaps (induced_order r u) -> (exists x y, [/\ inc x v, inc y v & glt r x y]) -> without_gaps (induced_order r v). Proof. move=> tor v usr wg h1. have svu: (sub v u) by apply: subsetI2l. have svi: (sub v (interval_cc r a b)) by apply: subsetI2r. have svr: (sub v (substrate r)) by apply: (sub_trans svu). ex_middle wg1. move: wg1 => /(Exercise1_21dP tor svr) => wg1. have: (~ ~ without_gaps (induced_order r u)) by case. move /(Exercise1_21dP tor usr) => wg2. case: wg2; case: wg1. by move:h1 => [c [d [cv dv [_ cd]]]] h2; move: (h2 _ _ cv dv). move=> [c [d [cv dv cd icd]]]; right; exists c; exists d; split;fprops. move=> z szu. move: tor => [or tor]. case: (tor _ _ (usr _ szu) (svr _ cv)) => zc; first by left. case: (tor _ _ (svr _ dv) (usr _ szu) ) => zd; first by right. move: cv dv => /setI2_P [_] /Zo_hi [ac _] /setI2_P [_] /Zo_hi [_ db]. apply: icd; apply: setI2_i => //; apply: Zo_i ; [| split => //]; order_tac. Qed. Lemma Exercise1_21f r a b u: total_order r -> sub u (substrate r) -> inc a u -> inc b u -> glt r a b -> without_gaps (induced_order r u) -> without_gaps (induced_order r (u \cap (interval_cc r a b))). Proof. move=> tor usr au bu ab wg; move: (tor) => [or _]. by apply: Exercise1_21e => //; exists a, b;split => //;apply/setI2_P; split => //;apply /Zo_P;split => //; try split=> //; order_tac; apply: usr. Qed. Lemma Exercise1_21g r x y z: total_order r -> gle r x y -> gle r y z-> scattered (induced_order r (interval_cc r x y)) -> scattered (induced_order r (interval_cc r y z)) -> scattered (induced_order r (interval_cc r x z)). Proof. move=> tor xy yz scxy scyz. move: (tor) => [or tor']. have xz:(gle r x z) by order_tac. have sxz:sub (interval_cc r x z) (substrate r) by apply: Zo_S. have sxy:sub (interval_cc r x y) (substrate r) by apply: Zo_S. have syz:sub (interval_cc r y z) (substrate r) by apply: Zo_S. move: scxy scyz => /(Exercise1_21aP or sxy) scxy /(Exercise1_21aP or syz) scyz. apply /(Exercise1_21aP or sxz) => u uxz. case: (p_or_not_p (without_gaps (induced_order r u))) =>// wg. have us: (sub u (substrate r)) by apply: sub_trans sxz. set (u1 := u \cap (interval_cc r x y)). set (u2 := u \cap (interval_cc r y z)). have su1: sub u1 (interval_cc r x y) by apply: subsetI2r. have su2: sub u2 (interval_cc r y z) by apply: subsetI2r. have up1: forall t, inc t u -> gle r t y -> inc t u1. move=> t tu ty; move: (uxz _ tu) => /Zo_P [t1 [t2 t3]]. apply: setI2_i => //;apply: Zo_i => //. have up2: forall t, inc t u -> gle r y t -> inc t u2. move=> t tu ty; move: (uxz _ tu) => /Zo_P [t1 [t2 t3]]. apply: setI2_i => //;apply: Zo_i => //. apply /(Exercise1_21dP tor us). case: (p_or_not_p (exists x y, glt (induced_order r u) x y)); last first. by move /(Exercise1_21cP tor us); left. move=> [a [b ltab]]; right. move: (iorder_gle4 ltab) (iorder_gle2 ltab) => [au bu] ltab1. exists a, b; split => //; move=> t tu. case: (tor' _ _ (us _ au) (us _ tu)) => ta; last by left. case: (tor' _ _ (us _ tu) (us _ bu)) => tb; last by right. have ysr: inc y (substrate r) by order_tac. move: (scxy _ su1) (scyz _ su2) => wg1 wg2. case: (tor' _ _ ysr (us _ tu)) => ty. move: (up2 _ tu ty) (up2 _ bu (order_transitivity or ty tb)) => t2 b2. case: (equal_or_not t b); first by move => ->; right; order_tac; order_tac. move=> bt1; have bt: glt r t b by order_tac. case: wg2; apply: Exercise1_21e => //; exists t, b; split => //. move: (up1 _ tu ty) (up1 _ au (order_transitivity or ta ty )) => t2 b2. case: (equal_or_not a t); first by move => ->; left; order_tac; order_tac. move=> at1; have at2: glt r a t by order_tac. by case: wg1; apply: Exercise1_21e => //; exists a, t. Qed. Lemma Exercise1_21h r: total_order r -> equivalence_re (scattered_rel r) (substrate r). Proof. move=> tor; move: (tor) => [or tor']. have Ha: forall a b x y, gle r x a -> gle r b y -> sub (interval_cc r a b) (interval_cc r x y). move=> a b x y xa lby t /Zo_P [tsr [lat tb]]. apply /Zo_P;split => //; split; order_tac. have Hb: forall a b x y, gle r x a -> gle r b y -> sub (interval_cc r a b) (substrate (induced_order r (interval_cc r x y))). by move=> a b x y xa yb; aw; [ apply: Ha | apply: Zo_S]. red; rewrite /scattered_rel; split; last first. move=> y; split; last by case;move=> [yy _]; order_tac. move=> ysr; left;set I:= interval_cc r y y. have Iy: (forall t, inc t I -> t = y). move=> t /Zo_P [_ [t1 t2]]; order_tac. have Isr: (sub I (substrate r)) by apply: Zo_S. split; first (by order_tac); apply /Exercise1_21aP => //. move => u uI ; apply /(Exercise1_21dP) => //; first by apply: sub_trans Isr. by left; move=> a b aI bI; rewrite (Iy _ (uI _ aI)) (Iy _ (uI _ bI)). split; first by (move=> x y; rewrite /scattered_rel; case; [right| left]). move=> y x z; case; move=> [xy sxy]. case; move=> [yz syz]. left; split; [order_tac | apply: (Exercise1_21g tor xy yz sxy syz)]. have xsr: inc x (substrate r) by order_tac. have zsr: inc z (substrate r) by order_tac. case: (tor' _ _ xsr zsr) => xz; [left | right]; split => //. have xx: (gle r x x) by order_tac. move: (Hb _ _ _ _ xx yz) => hs; move: (Exercise1_20a hs sxy). rewrite iorder_trans //; by apply: Ha. have zz: (gle r z z) by order_tac. move: (Hb _ _ _ _ zz xy) => hs; move: (Exercise1_20a hs syz). rewrite iorder_trans // ; by apply: Ha. case; move=> [yz syz]; last first. by right; split; [order_tac | apply: (Exercise1_21g tor yz xy syz sxy) ]. have xsr: inc x (substrate r) by order_tac. have zsr: inc z (substrate r) by order_tac. case: (tor' _ _ xsr zsr) => xz; [left | right]; split => //. have zz: (gle r z z) by order_tac. move: (Hb _ _ _ _ xy zz) => hs; move: (Exercise1_20a hs syz). rewrite iorder_trans //; by apply: Ha. have xx: (gle r x x) by order_tac. move: (Hb _ _ _ _ yz xx) => hs; move: (Exercise1_20a hs sxy). rewrite iorder_trans // ; by apply: Ha. Qed. Lemma Exercise1_21i r: total_order r -> equivalence (scattered_equiv r). Proof. move /Exercise1_21h => [pa pb]. by apply: equivalence_from_rel. Qed. Lemma Exercise1_21j r: total_order r -> substrate (scattered_equiv r) = substrate r. Proof. move=> tor; apply: graph_on_sr. by move=> a asr; move: (Exercise1_21h tor) => [_ rr]; rewrite -rr. Qed. Definition scattered_aux1 r x y := (forall u, sub u (interval_cc r x y) -> ((forall a b, inc a u -> inc b u -> a = b) \/ (exists a b, [/\ inc a u, inc b u, glt r a b & (forall z, inc z u -> gle r z a \/ gle r b z)]))). Definition scattered_aux r x y := gle r x y /\ scattered_aux1 r x y. Lemma Exercise1_21kP r x y: total_order r -> gle r x y -> (scattered (induced_order r (interval_cc r x y)) <-> scattered_aux1 r x y). Proof. move=> tor xy. have or: order r by move: tor => [or _ ]. set (i:=interval_cc r x y). have si: (sub i (substrate r)) by apply: Zo_S. have usr: (forall u, sub u i -> sub u (substrate r)). move => u ui; apply: (@sub_trans _ _ _ ui si). split. move /(Exercise1_21aP or si) => h u ui. apply /(Exercise1_21dP tor (usr _ ui)); apply: (h _ ui). move => hyp; apply /(Exercise1_21aP or si) => u ui. apply /(Exercise1_21dP tor (usr _ ui)) => //; exact (hyp _ ui). Qed. Lemma Exercise1_21l r x y: total_order r -> (related (scattered_equiv r) x y <-> (scattered_aux r x y \/ scattered_aux r y x)). Proof. move=> tor; split. by move /graph_on_P1 => [xsr ysr scxy];case: scxy; move=> [rxy]; move /(Exercise1_21kP tor rxy) => aux;[ left | right]. by case; move=> [xsr aux]; apply /graph_on_P1;split => //; try order_tac; [left | right];split => //; apply / Exercise1_21kP. Qed. Lemma Exercise1_21m r: total_order r -> weak_order_compatibility r (scattered_equiv r). Proof. move=> tor; move: (tor) => [or tor']. move: (Exercise1_21i tor) => es. move: (Exercise1_21j tor) => ss. split => //; first by split => //; by apply: order_preorder. move=> x y x' xy. have ysr: (inc y (substrate r)) by order_tac. move: (ysr); rewrite - ss => yss. have seyy: (related (scattered_equiv r) y y) by equiv_tac. rewrite (Exercise1_21l x x' tor); case; move=> [xx' sc]; last first. exists y => //; order_tac. have x'sr: inc x' (substrate r) by order_tac. case: (tor' _ _ ysr x'sr) => yx'; last by exists y. exists x'=> //; last (by order_tac);rewrite Exercise1_21l//;left; split=> //. move=> u ui; apply: sc; move => t tu; move: (ui _ tu) => /Zo_P [tsr [xt tx']]. apply /Zo_P;split => //; split => //; order_tac. Qed. Lemma Exercise1_21n r x: total_order r -> inc x (substrate r) -> scattered (induced_order r (class (scattered_equiv r) x)). Proof. move=> tor xsr. move: (Exercise1_21i tor)(Exercise1_21j tor) => es ss. move: tor => [or tor]. have sc:(sub (class (scattered_equiv r) x) (substrate r)). by rewrite - ss;apply: sub_class_substrate. move: (iorder_osr or sc) => [pa pb]. split => //. move=> y; aw=> yc; rewrite (iorder_trans _ yc). have yp: forall u, inc u y -> related (scattered_equiv r) u x. move=> u uy; move: (yc _ uy) => /(class_P es)=> aux; equiv_tac. move=>[oiy [a [b rab]] wg2]. move: (iorder_gle4 rab)=> [ay biy]; move: (yp _ ay) (yp _ biy)=> ax bx. have xb:(related (scattered_equiv r) x b) by equiv_tac. have :(related (scattered_equiv r) a b ) by equiv_tac. rewrite Exercise1_21l //; case; move=> [aux1 aux2]; last first. move: (iorder_gle2 rab) => aux3; order_tac. have asr: inc a (substrate r) by order_tac. have bsr: inc b (substrate r) by order_tac. move: (@subsetI2r y (interval_cc r a b)) => uy. case: (aux2 _ uy). set u:= _ \cap _. have au:inc a u by apply: setI2_i => //;apply:Zo_i => //;split =>//;order_tac. have bu:inc b u by apply: setI2_i => //;apply:Zo_i => //;split =>//;order_tac. by move=> aux3; move: (aux3 _ _ au bu); move: rab => [_]. move=> [c [d [cu du cd cde]]]. have cd1: (glt (induced_order r y) c d). apply /iorder_gle6P;split => //; [ apply:(setI2_1 cu) |apply: (setI2_1 du) ]. move: (wg2 _ _ cd1) => [e ce ed]. move:(iorder_gle4 ce)(iorder_gle2 ce) (iorder_gle2 ed) => [_ er] ce' de'. have aux:inc e (y \cap (interval_cc r a b)). apply: setI2_i => //; apply: Zo_i; [ order_tac | split => //]. move:(setI2_2 cu) => /Zo_hi [ac _]. move: ce' => [ce' _];order_tac. move:(setI2_2 du) => /Zo_hi [_ db]. move: de' => [de' _];order_tac. case: (cde _ aux)=> aux3; order_tac. Qed. Lemma Exercise1_21o r: total_order r -> Ex1_2_hC' r (scattered_equiv r). Proof. move=> tor; move=> x y z xy yz; rewrite Exercise1_21l //. move:(Exercise1_21i tor)(Exercise1_21j tor) => es ss. move: tor => [or tor]; case;move=> [xx hyp]. rewrite Exercise1_21l //;left; split => //. move=> u ui; apply: hyp => //; move=> t tu; move: (ui _ tu) => /Zo_P. move=> [tsr [xt ty]]; apply /Zo_P; split => //;split => //; order_tac. have leyx: (gle r y x) by order_tac. have <-: (x = y) by order_tac. have:(inc x (substrate r)) by order_tac. rewrite - ss=> xsr;equiv_tac. Qed. Lemma Exercise1_21p r: total_order r -> order (quotient_order r (scattered_equiv r)). Proof. move => tor. move: (Exercise1_21i tor) (Exercise1_21j tor)(Exercise1_21o tor) => p1 p2 p3. by move: tor => [or _]; apply: Exercise1_2d. Qed. Lemma Exercise1_21q r: total_order r -> let r' := quotient_order r (scattered_equiv r) in small_set (substrate r') \/ without_gaps r'. Proof. move=> tor r'. move: (Exercise1_21m tor)(Exercise1_21o tor) => Ha Hb. move: (Exercise1_2g Ha Hb tor) (Exercise1_2h Ha Hb tor)=> qo [oq toq]. simpl in qo; rewrite -/r' in qo oq toq. move: (tor) => [or tor']. set (s:= scattered_equiv r) in *. have Hc:forall a b, gle r a b -> gle r' (class s a) (class s b). move=> a b ab. move: (arg1_sr ab) (arg2_sr ab) => asr bsr. by move: (Exercise1_2j Ha Hb tor asr bsr) => [ok _]; apply: ok. case: (p_or_not_p (small_set (substrate r'))); first by left. move=> nss; right; split => //. ex_middle ne; case: nss => a b asr' bsr'. ex_middle ab; case: (toq _ _ asr' bsr') => cab. by case: ne; exists a, b. by case: ne; exists b, a; split; fprops. move: Ha => [[pr es ss] woc]. have sr': (substrate r' = quotient s) by rewrite /r' substrate_quotient_order. move=> x y xy; move: (xy) => [lexy nxy]. have nsxy: (~ (related s (rep x) (rep y))). apply /related_rr_P =>//;rewrite - sr'; order_tac. ex_middle nez; case: nsxy. move: lexy; rewrite qo; move=> [xq yq lerxy]. apply /graph_on_P1; split => //; try order_tac. left;split => //. have si: (sub (interval_cc r (rep x) (rep y)) (substrate r)) by apply: Zo_S. apply /(Exercise1_21aP or si). have Hx:class s (rep x) = x by apply: class_rep. have Hy:class s (rep y) = y by apply: class_rep. move=> u ui [oi woi1 woi2]. have uxu: (forall a, inc a u -> inc a x \/ inc a y). move=> a au; move: (ui _ au) => /Zo_P [asr [rxa ary]]. move: (Hc _ _ rxa); rewrite Hx => xca. move: (Hc _ _ ary); rewrite Hy => yca. case: (equal_or_not x (class s a)) => xca1. left; rewrite xca1; apply: inc_itself_class => //; ue. have p1: (glt r' x (class s a)) by split. case: (equal_or_not (class s a) y) => yca1. right; rewrite -yca1; apply: inc_itself_class => //; ue. have p2: (glt r' (class s a) y) by split. case: nez; exists (class s a); split => //. move: (class_rep es xq) (class_rep es yq) => c1 c2. have rxsr: (inc (rep x) (substrate r)) by order_tac. have rysr: (inc (rep y) (substrate r)) by order_tac. have Hu:forall a, inc a x -> x = class s a by move=> b bx;apply: is_class_pr. have Hv:forall a, inc a y -> y = class s a by move=> b bx;apply: is_class_pr. have xsr: sub x (substrate r) by rewrite - ss - c1; apply: sub_class_substrate. have ysr: sub y (substrate r) by rewrite - ss - c2; apply: sub_class_substrate. move: (Exercise1_21n tor rxsr); rewrite -/s c1. move: (Exercise1_21n tor rysr); rewrite -/s c2. move /(Exercise1_21aP or ysr) => c3 /(Exercise1_21aP or xsr) c4. set (u1:= u \cap x). have u1x: (sub u1 x) by apply: subsetI2r. have u1sr: (sub u1 (substrate r)) by apply: (sub_trans u1x). move: (c4 _ u1x) => /(Exercise1_21dP tor u1sr) c5. set (u2:= u \cap y). have u2y: (sub u2 y) by apply: subsetI2r. have u2sr: (sub u2 (substrate r)) by apply: (sub_trans u2y). move: (c3 _ u2y) => /(Exercise1_21dP tor u2sr) c6. have p1u: (~(exists a b, [/\ inc a u1, inc b u1 & glt r a b])). move=> [a [b [au1 bu1 ab]]]. case: c5 => c5'; first by move:ab=> [_ ab]; case:ab; exact: (c5' _ _ au1 bu1). move: c5' => [a' [b' [a'u1 b'u1 ab' ie]]]. move: (@subsetI2l u x) => u1x'. have ab'': glt (induced_order r u) a' b' by apply/iorder_gle6P; split;fprops. move: (woi2 _ _ ab'') => [c ca cb]. move:(iorder_gle4 ca)(iorder_gle2 ca)(iorder_gle2 cb) => [_ cu] ca' cb'. suff uc1: (inc c u1) by case: (ie _ uc1)=> h; order_tac. apply: setI2_i => //; case: (uxu _ cu) => //cy. move: cb' => [cb'' _]; move: (Hc _ _ cb''). rewrite -(Hv _ cy) - (Hu _ (setI2_2 b'u1)) => bad; order_tac. have p2u: (~(exists a b, [/\ inc a u2, inc b u2 & glt r a b])). move=> [a [b [au1 bu1 ab]]]. case: c6 => c6'; first by move:ab=> [_ ab]; case:ab; exact: (c6' _ _ au1 bu1). move: c6' => [a' [b' [a'u1 b'u1 ab' ie]]]. move: (@subsetI2l u y) => u2y'. have ab'': glt (induced_order r u) a' b' by apply/iorder_gle6P; split;fprops. move: (woi2 _ _ ab'') => [c ca cb]. move:(iorder_gle4 ca)(iorder_gle2 ca)(iorder_gle2 cb) => [_ cu] ca' cb'. suff uc2: (inc c u2) by case: (ie _ uc2)=> h; order_tac. apply: setI2_i => //; case: (uxu _ cu) => //cx. move: ca' => [ca'' _]; move: (Hc _ _ ca''). rewrite -(Hu _ cx) - (Hv _ (setI2_2 a'u1)) => bad; order_tac. move: woi1 => [a [b lab]]; move: (woi2 _ _ lab) => [c lac lcb]. move: (iorder_gle4 lac)(iorder_gle4 lcb) => [au cu][_ bu]. move: (iorder_gle2 lac)(iorder_gle2 lcb) => ltac ltcb. have ltab: glt r a b by order_tac. case: (uxu _ au) => axy. have au1: inc a u1 by apply: setI2_i. case: (uxu _ cu) => cxy. case: p1u; exists a, c;split => //; by apply: setI2_i. case: (uxu _ bu) => bxy. case: p1u; exists a, b;split => //; by apply: setI2_i. case: p2u; exists c, b;split => //; by apply: setI2_i. have au2: inc a u2 by apply: setI2_i. case: (uxu _ cu) => cxy. case: (uxu _ bu) => bxy. case: p1u; exists c, b;split => //; by apply: setI2_i. case: p2u; exists a, b;split => //; by apply: setI2_i. case: p2u; exists a, c;split => //; by apply: setI2_i. Qed. Lemma Exercise1_21r r: total_order r -> exists r' g', [/\ orsum_ax r' g', (forall i, inc i (domain g') -> nonempty (substrate (Vg g' i))), r \Is (order_sum r' g'), (small_set (substrate r') \/ without_gaps r') & (forall i, inc i (domain g') -> scattered (Vg g' i))]. Proof. set (s:= (scattered_equiv r)) => tor. move: (@Exercise1_2i r s) => /=. have p1: weak_order_compatibility r s by apply: Exercise1_21m. have p2: Ex1_2_hC' r s by apply: Exercise1_21o. move=> h; move: (h p1 p2 tor). set q:= quotient s; set d := (disjointU _). move => [q1 q2 q3 q4 [q5 q6]] {h}. exists (quotient_order r s); exists(Lg q(fun z => induced_order r z)). split => //; first by exists (Lf (fun x => J x (class s x)) (substrate r) d). by apply: Exercise1_21q. bw;move=> i idg; bw; move: idg => /funI_P [z zs] ->. by apply: (Exercise1_21n tor); rewrite - (Exercise1_21j tor). Qed. (** ---- Exercise 1.22: open and regular sets. We define an open set [open_o] and a regular open set [open_r]. Every open set is cofinal in exactly one regular open set, namely [bar1_22]. This mapping is increasing for [sub]; it maps disjoint sets to disjoint sets *) Definition open_o r u:= sub u (substrate r) /\ forall x y, inc x u -> gle r x y -> inc y u. Definition open_r r u:= open_o r u /\ forall v, open_o r v -> sub u v -> cofinal (induced_order r v) u -> u = v. Definition bar1_22 r u := union (Zo (powerset(substrate r)) (fun z => open_o r z /\ cofinal (induced_order r z) u)). Definition reg_opens r := Zo (powerset (substrate r)) (open_r r). Definition reg_open_order r := sub_order (reg_opens r). Lemma inf_pr2 r x y z: order r -> gle r z x -> gle r z y -> (forall t, gle r t x -> gle r t y -> gle r t z) -> inf r x y = z. Proof. move=> or zx zy h. move: (glb_set2 or zx zy h) => aux. symmetry;apply: infimum_pr2 => //. Qed. Section Exercise1_22. Variable r:Set. Hypothesis or: order r. Lemma reg_opens_i x: open_r r x -> inc x (reg_opens r). Proof. move => h; apply /Zo_i => //; apply /setP_P; apply: (proj1 (proj1 h)). Qed. Lemma Exercise1_22a u1 u2: open_o r u1 -> open_o r u2 -> open_o r (u1 \cup u2). Proof. move=> [u1p u1r][u2p u2r]; split. move=> t; case/setU2_P; [apply: u1p | apply: u2p]. by move=> x y;case/setU2_P; move=> h le; apply /setU2_P; [left; apply: (u1r x) | right; apply: (u2r x)]. Qed. Lemma Exercise1_22b u: (forall x, inc x u -> open_o r x) -> open_o r (intersection u). Proof. move=> alo. have aux: forall t, inc t (intersection u) -> exists a, inc a u. move => t; case: (emptyset_dichot u). by move => ->; rewrite setI_0 => /in_set0. by move=> [a au] _; exists a. split. move=> t tu; move: (aux _ tu) => [a au]. move: (setI_hi tu au); move: (alo _ au) => [p1 _]; apply: p1. move=> x y xu xy; move: (aux _ xu) => [a au]. apply: setI_i; first by exists a;apply: au. move=> z zu; move: (alo _ zu) => [_ p2]; move: xy; apply: p2. exact (setI_hi xu zu). Qed. Lemma Exercise1_22c u: (forall x, inc x u -> open_o r x) -> open_o r (union u). Proof. move=> alo; split. by move=>t /setU_P [y ty yu]; move: (alo _ yu) => [p1 _]; apply: p1. move=> x y /setU_P [z xz zu] xy; move: (alo _ zu) => [_ p2]. apply /setU_P; exists z => //; exact (p2 _ _ xz xy). Qed. Lemma cofinal_inducedP v u: sub u (substrate r) -> (cofinal (induced_order r u) v <-> (sub v u /\ (forall x, inc x u -> exists2 y, inc y v & gle r x y))). Proof. move=> usr; rewrite /cofinal; aw. split; move=> [vu h]; split => //; move=> x xu; move: (h _ xu)=> [y yv yx]. ex_tac; apply: (iorder_gle1 yx). by ex_tac; apply /iorder_gleP => //; apply: vu. Qed. Lemma Exercise1_22d x u1 u2: open_o r x -> open_r r u1 -> open_r r u2 -> sub x u1 -> sub x u2 -> cofinal (induced_order r u1) x -> cofinal (induced_order r u2) x -> u1 = u2. Proof. move=> ox [ou1 pu1] [ou2 pu2] xu1 xu2 co1 co2. move: (Exercise1_22a ou1 ou2). move: (@subsetU2l u1 u2) (@subsetU2r u1 u2). set (u3:= u1 \cup u2) => su1 su2 ou3. have su3: (sub u3 (substrate r)) by move: ou3 => [ok _]. have su1r: (sub u1 (substrate r)) by move: ou1 => [ok _]. have su2r: (sub u2 (substrate r)) by move: ou2 => [ok _]. move: co1 co2 => /(cofinal_inducedP _ su1r) [_ co1] /(cofinal_inducedP _ su2r) [_ co2]. have co31:(cofinal (induced_order r u3) u1). red; aw; split => // t tu3. have [a ax ta]: exists2 a, inc a x & gle r t a. move: tu3;case/setU2_P =>tu;[apply: (co1 _ tu)| apply: (co2 _ tu)]. move: (xu1 _ ax) => au; ex_tac; apply /iorder_gleP => //. exact:(proj2 ou3 _ _ tu3 ta). move: (pu1 _ ou3 su1 co31) => u13. have co32:(cofinal (induced_order r u3) u2). red; aw; split => // t tu3. rewrite -u13 in tu3; move: (co1 _ tu3) => [y yx ty]; rewrite -u13. by move: (xu2 _ yx) => au; ex_tac;apply /iorder_gleP => //; apply: xu1. by move: (pu2 _ ou3 su2 co32) => ->. Qed. Lemma Exercise1_22e u: open_o r u -> sub u (bar1_22 r u). Proof. move=> ou t tu; move: (ou) => [ou1 ou2]; apply: (@setU_i _ u) => //. apply: Zo_i; [by apply /setP_P | split => //; split; aw => // ]. by move=> x xu; ex_tac; apply /iorder_gleP => //; order_tac; apply: ou1. Qed. Lemma Exercise1_22f u: open_o r u -> sub (bar1_22 r u) (substrate r). Proof. move=> [ou1 ou2] t => /setU_P [y ty] /Zo_P [] /setP_P ysr _. by apply: ysr. Qed. Lemma Exercise1_22g u: open_o r u -> cofinal (induced_order r (bar1_22 r u)) u. Proof. move=> ou; move:(Exercise1_22e ou) (Exercise1_22f ou) => h1 h2. apply /cofinal_inducedP => //; split => //. rewrite /bar1_22; move => x /setU_P [y xy] /Zo_P [] /setP_P ysr [oy ]. move /(cofinal_inducedP _ ysr) => [uy h]; apply: (h _ xy). Qed. Lemma Exercise1_22h u x: open_o r u -> inc x (substrate r) -> (forall y, gle r x y -> exists2 z, inc z u & gle r y z) -> inc x (bar1_22 r u). Proof. move=> ou xsr xp. move: (Exercise1_22f ou) => Ha. set (t:=(bar1_22 r u) \cup (Zo (substrate r) (fun z=> gle r x z))). have tsr: (sub t (substrate r)). move=> v; case/setU2_P; [ apply: Ha |apply: Zo_S]. apply: (@setU_i _ t). by apply: setU2_2; apply: Zo_i =>//; order_tac. have ob: (open_o r (bar1_22 r u)). by apply: Exercise1_22c => //;move=> v /Zo_hi []. apply: Zo_i; [by apply /setP_P | split]. apply:Exercise1_22a => //; split; first by apply: Zo_S. move=> a b => /Zo_P [asr xa] ab; apply: Zo_i; order_tac. move: (Exercise1_22g ou) => /(cofinal_inducedP _ Ha) [ubu c1]. red; rewrite (iorder_sr or tsr);split => //. by move=> a au; apply: setU2_1;exact: (ubu _ au). have sut: sub u t by move => s su; apply /setU2_P; left; apply: ubu. by move=> a iat; case/setU2_P: (iat) => h; [ move: (c1 _ h) | move: h =>/Zo_P [pa pb]; move : (xp _ pb)]; move => [z za zb]; exists z => //;apply /iorder_gleP => //; apply: sut. Qed. Lemma Exercise1_22i u: open_o r u -> open_r r (bar1_22 r u). Proof. move=> ou. move: (Exercise1_22f ou) => sbu. have op: (open_o r (bar1_22 r u)). by apply: Exercise1_22c => //; move => x => /Zo_hi []. split => // v [sv ov] sbv; move: (Exercise1_22g ou). move /(cofinal_inducedP _ sbu) => [_ c]. move /(cofinal_inducedP _ sv) => [_ c']; apply: extensionality =>// t tv. apply: Exercise1_22h => //; first by apply: sv. move=> y ty; move: (ov _ _ tv ty) => yv; move: (c' _ yv) => [z zb zy]. move: (c _ zb) => [w wu zw]; ex_tac; order_tac. Qed. Lemma Exercise1_22j u v: open_o r u -> open_o r v -> sub u v -> sub (bar1_22 r u) (bar1_22 r v). Proof. move=> ou ov uv. move=> t tu;apply: Exercise1_22h => //; first by apply: (Exercise1_22f ou). move: (Exercise1_22i ou) => [[ob1 ob2] _]. move=> y ty; move: (ob2 _ _ tu ty) => ybu. move: (Exercise1_22g ou) => /(cofinal_inducedP _ ob1) [_ h]. move: (h _ ybu) => [z zu yz]; exists z => //;fprops. Qed. Lemma Exercise1_22k u v: open_o r u -> open_o r v -> disjoint u v -> disjoint (bar1_22 r u) (bar1_22 r v). Proof. rewrite /disjoint;move=> ou ov iuve; apply /set0_P. move=> y /setI2_P [] /setU_P [z yz z1] /setU_P [z' yz' z2]. move: z1 z2 => /Zo_P [] /setP_P z1 [[_ o1] c1] /Zo_P [] /setP_P z2 [[_ o2] c2]. move: c1 c2 => /(cofinal_inducedP _ z1) [uz c1]/(cofinal_inducedP _ z2)[vz' c2]. move: (c1 _ yz)=> [y1 y1u le1]. move: (c2 _ (o2 _ _ yz' le1)) => [y2 y2u le2]. empty_tac1 y2; apply: setI2_i => //. move: ou => [_ ou]; exact: (ou _ _ y1u le2). Qed. (** Assume [E] not empty. Then there are two regular sets, namely [E] and the empty set. There is no other regular open set iff [E] is directed. *) Lemma Exercise1_22m: open_r r emptyset. Proof. split. split;[fprops | by move=> x y /in_set0]. move => v [sv ov] ev [_ ]; aw => h;symmetry;apply /set0_P. by move=> y yv; move: (h _ yv) => [z /in_set0]. Qed. Lemma Exercise1_22n: open_r r (substrate r). Proof. split. split; fprops; move=> x y _ xy; order_tac. by move=> v [v1 _] v2 _; apply: extensionality. Qed. Lemma Exercise1_22o: ~ (right_directed r) -> exists a b, [/\ open_r r a, open_r r b, nonempty a, nonempty b & a <> b]. Proof. move=> nrd. set (i:= fun x => Zo (substrate r) (fun z => gle r x z)). have io: (forall x, inc x (substrate r) -> open_o r (i x)). move=> x xsr; split; first by apply: Zo_S. move => a b /Zo_P [asr xa] ab; apply /Zo_P;split; order_tac. have obi: (forall x, inc x (substrate r) -> open_r r (bar1_22 r (i x))). by move=> x xsr; apply: Exercise1_22i =>//; apply: io. have bne1: forall x, inc x (substrate r) -> inc x (bar1_22 r (i x)). move=> x xsr; apply: Exercise1_22e =>//; [ apply: io => //| apply: Zo_i =>//]. by order_tac. set (p := fun a b => [/\ inc a (substrate r),inc b (substrate r) & (i a) \cap (i b) = emptyset]). case: (p_or_not_p (exists a b, p a b)). move=> [a [b [asr bsr iabe]]]. move: (bne1 _ asr) (bne1 _ bsr) => a1 b1. exists (bar1_22 r (i a)); exists (bar1_22 r (i b)); split;fprops. by exists a. by exists b. move: (Exercise1_22k (io _ asr) (io _ bsr) iabe). rewrite /disjoint. by move=> ie sv; rewrite sv in ie; empty_tac1 b; apply: setI2_i. move=> h; case: nrd; apply /right_directedP; split => //. move=> x y xsr ysr; ex_middle ep; case: h. exists x, y; split => //. apply /set0_P; move=> t /setI2_P [] /Zo_P [tsr xt] /Zo_P [_ yt]. by case: ep; exists t. Qed. Lemma Exercise1_22p x: open_r r x -> x = (bar1_22 r x) . Proof. move=> [osr p3];move: (Exercise1_22g osr) (Exercise1_22i osr). move=> p1 [p2a p2b]; apply: (p3 _ p2a (Exercise1_22e osr) p1). Qed. Lemma Exercise1_22qP: (exists a b, a <> b /\ reg_opens r = doubleton a b) <-> (nonempty (substrate r) /\ (right_directed r)). Proof. have pa: inc emptyset (reg_opens r). apply /Zo_P; split; [apply /setP_P; fprops | apply: Exercise1_22m]. have pb: inc (substrate r) (reg_opens r). apply /Zo_P; split; [apply /setP_P; fprops | apply: Exercise1_22n]. split. move=> [a [b [ab sd]]]. have : (inc a (reg_opens r)) by rewrite sd; fprops. have : (inc b (reg_opens r)) by rewrite sd; fprops. move /Zo_P => [] /setP_P bsr ob /Zo_P [] /setP_P asr oa. split. case: (emptyset_dichot a); last by move=> [a' a'a]; exists a'; apply: asr. case: (emptyset_dichot b); last by move=> [b' b'b]; exists b'; apply: bsr. by move => be ae; case: ab; rewrite ae be. ex_middle nrd; move:(Exercise1_22o nrd) =>[u [v [ou ov neu nev uv]]]. have uo := reg_opens_i ou. have vo := reg_opens_i ov. have c2: ~ (inc emptyset (doubleton u v)). case/set2_P => h' ;[ case: neu | case: nev]; move=> y; rewrite -h'; case; case. rewrite sd in uo vo pa. case/set2_P: uo => vu; case/set2_P:vo => vv; try (rewrite -vu in vv; case: uv; fprops); case: c2;rewrite vu vv //; rewrite set2_C //. move=> [ner rdr]; exists emptyset; exists (substrate r); split => //. by move=> esr; rewrite -esr in ner; case /nonemptyP: ner. set_extens t; last by case/set2_P => ->. move /Zo_P=> [tse ot]; case: (emptyset_dichot t); first by move => ->; fprops. move=> [y yt]; apply /set2_P; right; move /setP_P: tse => tse. apply: extensionality => // u usr. move: (ot) => [ot1 _]; rewrite (Exercise1_22p ot); apply: Exercise1_22h => //. move=> v uv. have vsr: inc v (substrate r) by order_tac. move: rdr => /right_directedP [_ h]. move: (h _ _ (tse _ yt) vsr) => [z [zy zv]]. move: ot1 =>[_ ot2]; move: (ot2 _ _ yt zy)=> zt; ex_tac. Qed. (** The set of regular open sets is a complete boolean lattice*) Lemma Exercise1_22rP u v: gle (reg_open_order r) u v <-> [/\ open_r r u, open_r r v &sub u v]. Proof. split; first by move /sub_gleP => [] /Zo_hi pa /Zo_hi pb pc. by move=> [p1 p2 p3]; apply /sub_gleP => //; split => //; apply:reg_opens_i. Qed. Lemma Exercise1_22s1P x: inc x (substrate (reg_open_order r)) <-> open_r r x. Proof. rewrite /reg_open_order (proj2 (sub_osr (reg_opens r))). split; [ by move /Zo_hi | apply:reg_opens_i ]. Qed. Lemma Exercise1_22s: greatest (reg_open_order r) (substrate r). Proof. move: (Exercise1_22n) => so. split; first by apply /Exercise1_22s1P. move=> x => /Exercise1_22s1P ox; move: (proj1 (proj1 ox)) => xsr. apply /Exercise1_22rP;split; fprops. Qed. Lemma Exercise1_22t: least (reg_open_order r) (emptyset). Proof. move: (Exercise1_22m) => so. split; first by apply /Exercise1_22s1P. move=> x => /Exercise1_22s1P ox; apply /Exercise1_22rP;split;fprops. Qed. Lemma Exercise1_22u u v: open_r r u -> open_r r v -> inf (reg_open_order r) u v = bar1_22 r (u \cap v). Proof. move => ou ov. set (z := bar1_22 r (u \cap v)). have oi: (open_o r (u \cap v)). apply: Exercise1_22b => //; move=> x. case/set2_P => ->; [by case: ou | by case: ov]. move: (Exercise1_22i oi) (Exercise1_22e oi)=> oz sz. apply: inf_pr2. rewrite/reg_open_order; fprops. apply /Exercise1_22rP; split => //; rewrite (Exercise1_22p ou). apply: Exercise1_22j => //; [by case: ou | apply: subsetI2l]. apply Exercise1_22rP; split => //; rewrite (Exercise1_22p ov). apply: Exercise1_22j => //; [by case: ov | apply: subsetI2r]. move => t /Exercise1_22rP [ot _ tu] /Exercise1_22rP [_ _ tv]. apply /Exercise1_22rP; split => //. apply: (@sub_trans (u \cap v)) => //. by move=> w wt; apply: setI2_i; [apply: tu | apply: tv]. Qed. Lemma Exercise1_22v X: sub X (substrate (reg_open_order r)) -> least_upper_bound (reg_open_order r) X (bar1_22 r (union X)). Proof. move=> Xsr. have ou: (open_o r (union X)). apply: Exercise1_22c => // x xX; move: (Xsr _ xX) => /Exercise1_22s1P. by case. have oru: (open_r r (bar1_22 r (union X))) by apply: Exercise1_22i. have us: (inc (bar1_22 r (union X)) (substrate (reg_open_order r))). by apply /Exercise1_22s1P. have orr: (order (reg_open_order r)) by rewrite /reg_open_order; fprops. apply /(lubP orr Xsr);split. split => // y yX; move:(Xsr _ yX) => /Exercise1_22s1P oy. apply /Exercise1_22rP;split => //; apply: (@sub_trans (union X)). by apply: setU_s1. apply: Exercise1_22e => //. move=> z [] /Exercise1_22s1P oz h; apply /Exercise1_22rP;split => //. rewrite (Exercise1_22p oz); apply: Exercise1_22j =>//; first by case: oz. by move => w /setU_P [y wy yX]; move: (h _ yX) => /Exercise1_22rP [_ _]; apply. Qed. Lemma Exercise1_22w u v: open_r r u -> open_r r v -> sup (reg_open_order r) u v = bar1_22 r (u \cup v). Proof. move=> ou ov. have sd: (sub (doubleton u v) (substrate (reg_open_order r))). by move=> t; case/set2_P => ->; apply /Exercise1_22s1P. symmetry; apply: supremum_pr2; first by rewrite /reg_open_order; fprops. apply: (Exercise1_22v sd). Qed. Lemma Exercise1_22x: complete_lattice (reg_open_order r). Proof. have oro: (order (reg_open_order r)) by rewrite /reg_open_order; fprops. apply: Exercise1_11b => //. move=> X Xsr; exists (bar1_22 r (union X)); apply: (Exercise1_22v Xsr). Qed. Lemma Exercise1_22y: lattice (reg_open_order r). Proof. move: (Exercise1_22x)=> [cl1 cl2]. by split => //u v => usr vsr; apply: cl2; move=> t; case/set2_P => ->. Qed. Lemma Exercise1_22z: relatively_complemented (reg_open_order r). Proof. move: (Exercise1_22t) => lee. have oro: (order (reg_open_order r)) by rewrite /reg_open_order; fprops. have thel: (the_least (reg_open_order r) = emptyset). by apply: the_least_pr2. split => //; [by apply: Exercise1_22y | exists emptyset => // |]. move=> x y => /Exercise1_22rP [ox oy xy]. move: (ox) (oy)=> [oox _] [ooy _]. set (z:= Zo y (fun u => forall t, gle r u t -> ~ (inc t x))). have zr: (sub z (substrate r)). apply: (@sub_trans y) ;[ apply: Zo_S | by case: (proj1 oy) ]. have oz: (open_o r z). split => //; move=> u v /Zo_P [uy h] uv; apply :Zo_i=> //. move:ooy => [aa h1]; apply: (h1 _ _ uy uv). by move=> t vt tx; case: (h _ (order_transitivity or uv vt)). move: (Exercise1_22i oz)=> orz. have ou: (open_o r (x \cup (bar1_22 r z))). by apply: Exercise1_22a =>//; move: orz; move=> [ok _]. exists (bar1_22 r z); red. rewrite thel Exercise1_22w // Exercise1_22u //. move: (Exercise1_22p ox)(Exercise1_22p oy) => bxp byp. have xze: (x \cap z) = emptyset. apply /set0_P; move=> a /setI2_P [ax] /Zo_P. move=> [ay h1]; case: (h1 a) => //; order_tac. by move: (oox) => [xsr _]; apply: xsr. have zy: sub z y by apply: Zo_S. split; first (by apply /Exercise1_22s1P); last first. rewrite bxp Exercise1_22k // - Exercise1_22p //; apply: Exercise1_22m=>//. apply: extensionality. rewrite byp;apply: Exercise1_22j => //. move=> t; case/setU2_P; first by apply: xy. rewrite byp; apply: (Exercise1_22j oz ooy zy). move: ooy=> [ysr ooy2]. move=> t ty; apply: Exercise1_22h =>//; first by apply: ysr. move=> u tu. move: (ooy2 _ _ ty tu) => uy. case: (p_or_not_p (exists2 t, inc t x & gle r u t)). by move=> [w wx uw]; exists w => //; apply: setU2_1. move: (ysr _ uy) => usr. move=> h; exists u => //; last (by order_tac); apply: setU2_2. apply: Exercise1_22e => //; apply: Zo_i => // w uw; case: (inc_or_not w x) =>//. by move=> wx; case: h; exists w. Qed. Lemma Exercise1_22A: boolean_lattice (reg_open_order r). Proof. move: (Exercise1_22t) => le. have oo: (order (reg_open_order r)) by rewrite /reg_open_order; fprops. split; first by apply: Exercise1_22z. by exists (substrate r); apply: (Exercise1_22s). move: (Exercise1_22y)=> lr. apply/ (distributive_lattice_prop3 lr) => x y z xsr ysr zsr. set (a1:= sup (reg_open_order r) x y). set (a2:= inf (reg_open_order r) y z). have a1s: (inc a1 (substrate (reg_open_order r))). move: (lattice_sup_pr lr xsr ysr) => [ok _ _]; order_tac. have a2s: (inc a2 (substrate (reg_open_order r))). move: (lattice_inf_pr lr ysr zsr) => [ok _ _]; order_tac. have b1s: inc (inf (reg_open_order r) z a1) (substrate (reg_open_order r)). move: (lattice_inf_pr lr zsr a1s) => [ok _ _]; order_tac. have b2s: inc (sup (reg_open_order r) x a2) (substrate (reg_open_order r)). move: (lattice_sup_pr lr xsr a2s) => [ok _ _]; order_tac. move: xsr ysr zsr a1s a2s b1s b2s =>/Exercise1_22s1P xor /Exercise1_22s1P yor /Exercise1_22s1P zor /Exercise1_22s1P a1or /Exercise1_22s1P a2or /Exercise1_22s1P b1or /Exercise1_22s1P b2or. apply /Exercise1_22rP; split => //. move: (refl_equal a1)(refl_equal a2); rewrite {2} /a1 {2} /a2. rewrite Exercise1_22u // Exercise1_22w// => a1s a2s. rewrite Exercise1_22u// Exercise1_22w// a1s a2s. move => a /setU_P [b ab] /Zo_P [] /setP_P bsr [[_ ob]]. move /(cofinal_inducedP _ bsr) => [bi bip]. move: (bsr _ ab) => asr. move: (xor)(yor)(zor) => [xo _] [yo _][zo _]. apply: Exercise1_22h => //. apply: Exercise1_22a => //; rewrite -a2s; by case: a2or. move=> c ac; move: (ob _ _ ab ac) => cb. move: (bip _ cb) => [d] /setI2_P [dz dbu] cd. move: dbu => /setU_P [e de] /Zo_P [] /setP_P esr [[_ oe]]. move /(cofinal_inducedP _ esr)=> [ei eip]. move: (eip _ de) => [f fxy ef]. exists f; last by order_tac. case/setU2_P: fxy => fx; first by apply: setU2_1. apply: setU2_2; apply: Exercise1_22e => //. by apply: Exercise1_22b => //; move=> i; case/set2_P => ->. apply: setI2_i => //. move: zo => [_ zo]; apply: (zo _ _ dz ef). Qed. (** if [R(E)] is the set of regular sets, [F] cofinal, then [U => intersection2 U F] is an isomorphism [R(E) -> R(F)] *) Lemma Exercise1_22B F x: cofinal r F -> open_r r x -> open_r (induced_order r F) (x \cap F). Proof. move=> cf ox. have sF: (sub F (substrate r)) by case: cf. move: (iorder_osr or sF) => [oio sio]. have oioi: (open_o (induced_order r F) (x \cap F)). red;aw; split; first by apply: subsetI2r. move=> a b /setI2_P [ax aF] ab. move: (iorder_gle1 ab)(iorder_gle3 ab) => leab [_ nF]. apply /setI2_P;split => //. move: ox => [[_ ox] _]; apply: (ox _ _ ax leab). split; first by exact. move=> v ov siv cfi; apply: extensionality =>// t tv. move: (ov) => [sov _]. move: sov; aw => sov;move: cfi; rewrite iorder_trans //. move /(cofinal_inducedP _ (sub_trans sov sF)) => [_ cfi]. have tF: inc t F by move: sov; aw; apply. move: sov => /setP_P sov. move: (sF _ tF) => ts. apply /setI2_P;split => //. rewrite (Exercise1_22p ox); apply: Exercise1_22h => //; first by case: ox. move => y ty. have ysr: inc y (substrate r) by order_tac. move: cf=> [_ cf]; move: (cf _ ysr) => [z zF yz]. have aux: (gle (induced_order r F) t z) by apply /iorder_gleP => //; order_tac. move:ov => [_ h]; move: (h _ _ tv aux) => zv. move: (cfi _ zv)=> [w h1 h2]; move: h1 => /setI2_P [wx wf]; ex_tac; order_tac. Qed. Lemma Exercise1_22C F U U': cofinal r F -> open_r r U -> open_r r U' -> sub (U \cap F) (U' \cap F) -> sub U U'. Proof. move=> [cf1 cfi] oU oU' sUU'. move: (oU) => [[sU sU1] _]. move=> t tU; rewrite(Exercise1_22p oU'); apply: Exercise1_22h; fprops. by case: oU'. move=> y ty. have ysr: (inc y (substrate r)) by order_tac. move: (cfi _ ysr) => [z zF yz]. move: (sU1 _ _ tU (order_transitivity or ty yz)) => zU. have zi: inc z (U' \cap F) by apply:sUU'; apply:setI2_i =>//. move: (setI2_1 zi) => zU'; ex_tac. Qed. End Exercise1_22. Lemma Exercise1_22D r F: order r -> cofinal r F -> order_isomorphism (Lf (fun z => z \cap F) (reg_opens r) (reg_opens (induced_order r F))) (reg_open_order r)(reg_open_order (induced_order r F)). Proof. move=> or cF. have Fs: (sub F (substrate r)) by move: cF => [ok _]. move: (iorder_osr or Fs) => []. set (r':= induced_order r F)=> oir sr'. have oi: (forall x, open_r r x -> open_r r' (x \cap F)). move=> x ox; apply: (Exercise1_22B or cF ox). have ta: (lf_axiom (fun z => z \cap F) (reg_opens r) (reg_opens r')). move=> t => /Zo_P [] /setP_P tsr ot; apply: Zo_i; fprops; apply /setP_P. rewrite sr'; apply: subsetI2r. set (g:=Lf (fun z : Set => z \cap F) (reg_opens r) (reg_opens r')). have bg: (bijection g). rewrite /g; apply: lf_bijective => //. move=> u v => /Zo_P [] /setP_P usr ou /Zo_P [] /setP_P vsr ov si. apply: extensionality. apply: (Exercise1_22C (U:=u) (U':=v) or cF) => //; rewrite si; fprops. apply: (Exercise1_22C (U:=v) (U':=u) or cF) => //; rewrite - si; fprops. move=> y /Zo_P [] /setP_P ysr' oy. have ysr: (sub y (substrate r)) by apply: (@sub_trans F) => //; ue. set (x1:= Zo (substrate r) (fun z => exists2 x, inc x y& gle r x z)). have x1sr: (sub x1 (substrate r)) by apply: Zo_S. have yx1: (sub y x1). by move=> t ty; move: (ysr _ ty)=> tsr;apply: Zo_i =>//; ex_tac; order_tac. have ox1: (open_o r x1). split => //; move=> a b /Zo_P [asr [c cy ca]] ab; apply /Zo_P. split; [ order_tac | ex_tac; order_tac]. set (x2:= bar1_22 r x1). have x2F: (sub y (x2 \cap F)). move=> t ty; apply: setI2_i. by apply: (Exercise1_22e or ox1); apply: yx1. by rewrite - sr'; apply: ysr'. move:(Exercise1_22i or ox1) => ob; exists (bar1_22 r x1). by apply: Zo_i => //; apply /setP_P; apply: Exercise1_22f. apply: extensionality => // x /setI2_P [xb xF]. rewrite (Exercise1_22p oir oy); apply:Exercise1_22h => //;[by case: oy | ue|]. move=> z xz; move: (iorder_gle1 xz) => xz1. have : (inc z (bar1_22 r x1)) by move: ob =>[[_ h] _]; apply: (h _ _ xb xz1). move /setU_P => [t zt] /Zo_P [] /setP_P tsr [ot]. move /(cofinal_inducedP or x1 tsr) => [x1t x1p]. move: (x1p _ zt) => [x3 yx3 xy3]. move: yx3 => /Zo_P [x3s [x4 x4y x4x3]]. move: cF => [_ cF]; move: (cF _ x3s) => [x5 x5F x35]. have r45: (gle r' x4 x5). apply /iorder_gleP => //; [ by rewrite - sr'; apply: ysr' | order_tac]. exists x5=> //; first by move:oy => [[_ oy] _]; apply: (oy _ _ x4y r45). apply /iorder_gleP => //; [rewrite - sr'; order_tac | order_tac ]. rewrite /reg_open_order /g. split => //; fprops. rewrite !(proj2 (sub_osr _)); split;aw. hnf; aw;move => x y xsr ysr; aw; split. move /sub_gleP => [i1 i2 i3]; apply /sub_gleP;split; fprops. by move=> t /setI2_P [tx tF]; apply/setI2_P;split => //; apply: i3. move /sub_gleP => [i1 i2 i3]; apply /sub_gleP;split => //. move: xsr ysr => /Zo_P [_ i4] /Zo_P [_ i5]. apply: (Exercise1_22C or cF i4 i5 i3). Qed. (** open sets in a product. This part of the exercise is false *) Lemma Exercise1_22E r r' X X': order r -> order r' -> open_o r X -> open_o r' X' -> open_o (order_product2 r r') (X \times X'). Proof. move=> or or' oX oX'; split. rewrite order_product2_sr //. apply: setX_Slr; [ by case: oX | by case: oX']. move=> x y xp /order_product2_P; move=> [_ yp [le1 le2]]. move: oX oX' => [_ ox][_ oy]. move: xp yp => /setX_P [px Px Qy] /setX_P [py _ _]; apply /setX_P;split => //. apply: (ox _ _ Px le1). apply: (oy _ _ Qy le2). Qed. Lemma Exercise1_22F E X: sub X E -> open_r (diagonal E) X. Proof. move=> XE. move: (diagonal_osr E) => [oi si]. have h: (forall x y, gle (diagonal E) x y -> x = y). by move=> x y /diagonal_pi_P [_]. split. split; [ue |by move=> x y xE xy; rewrite - (h _ _ xy) ]. move=> v [sv ov] Xv cf; apply: extensionality => //. move=> t tv; move: cf => /(cofinal_inducedP oi X sv) [_ cof]. by move: (cof _ tv)=> [y yX le]; rewrite (h _ _ le). Qed. Lemma Exercise1_22G E: let r := diagonal E in (order_product2 r r = diagonal (E \times E)). Proof. move=> r. move: (diagonal_osr E) => [or sr]. have h: (forall x y, gle r x y -> x = y). by move=> x y /diagonal_pi_P [_]. set_extens t. move /Zo_P; rewrite sr; move => [ ] /setX_P [pa pb pc] [pd pe]. apply /diagonal_i_P;split => //;move /setX_P: pb => [pf _ _]. move /setX_P: pc => [pg _ _]; apply: pair_exten; fprops. move /diagonal_i_P => [pt] /setX_P [pa pb pc] pd. have pf:inc (P t) (E \times E) by apply /setX_P. have pg: inc (J (P (P t)) (P (Q t))) r by apply /diagonal_pi_P;split => //; ue. have ph: inc (J (Q (P t)) (Q (Q t))) r by apply /diagonal_pi_P;split => //; ue. by apply:Zo_i => //; rewrite sr; apply /setX_P; rewrite -pd. Qed. Lemma Exercise1_22H: exists r, let r' := order_product2 r r in order r /\ (exists2 t, open_o r' t & forall a b, t <> a \times b). Proof. move: (Exercise1_22G C2). set r := diagonal C2 ; move => /= ta. move: (diagonal_osr C2) => [or sr]. exists r; split => //. exists ((C2 \times C2) -s1 (J C0 C0)). by rewrite ta; apply Exercise1_22F; move => t /setC1_P []. move => a b eq. have pa: inc (J C0 C1) (a \times b). rewrite - eq; apply /setC1_P; split; first by apply:setXp_i; fprops. move =>ba; move: (pr2_def ba); fprops. have pb: inc (J C1 C0) (a \times b). rewrite - eq; apply /setC1_P; split; first by apply:setXp_i; fprops. move =>ba; move: (pr1_def ba); fprops. move: pa pb => /setXp_P [pa _] /setXp_P [_ pb]. have : inc (J C0 C0) (a \times b) by apply:setXp_i; fprops. by rewrite -eq => /setC1_P [_]. Qed. Lemma Exercise1_22I: exists r, let r' := order_product2 r r in let R := reg_open_order r in order r /\ not(reg_open_order r' \Is order_product2 R R). Proof. set E := singleton \0c. move: (Exercise1_22G E) => /=. move: (diagonal_osr E) => []; set r := diagonal E => od sr h. exists r; split => //; move => [f [_ _ [bf sf tf] _]]. move: (proj1 (Exercise1_22y od)) => oR. move: sf tf. rewrite order_product2_sr // /reg_open_order (proj2 (sub_osr _)) => sf tf. have sr0: inc \0c (substrate r) by rewrite sr /E; fprops. have nef: nonempty (substrate r) by exists \0c. have rr: right_directed r. split => // x y; rewrite sr => /set1_P-> /set1_P ->; exists \0c;split => //. by move =>t /set1_P ->; order_tac. set r' := (order_product2 r r). have sr': substrate r' = E \times E by rewrite order_product2_sr // sr. have sr0': inc (J \0c \0c) (substrate r') by rewrite sr' ; apply /setXp_P;split => //; ue. have see: forall x, inc x (E \times E) -> x = J \0c \0c. move => x => /setX_P [ta] /set1_P tb / set1_P tc. by rewrite - ta tb tc. have nef': nonempty (substrate r') by exists (J \0c \0c). have or': order r' by apply: order_product2_or. have rr': right_directed r'. split => // x y; rewrite sr' => xsr ysr; rewrite (see _ xsr) (see _ ysr). exists (J \0c \0c); split => //. by move =>t ; case /set2_P => ->; order_tac. move: (proj2 (Exercise1_22qP od) (conj nef rr)) => [a [b [ab eab]]]. move: (cardinal_set2 ab); rewrite -eab => c1. move: (f_equal cardinal tf); rewrite - cprod2_pr1. rewrite (proj2 (sub_osr _)) - cprod2cl - cprod2cr c1. move: (proj2 (Exercise1_22qP or') (conj nef' rr')) => [a' [b' [ab' eab']]]. move: (cardinal_set2 ab'); rewrite -eab';rewrite - sf. have->: (cardinal (source f) = cardinal (target f)) by apply /card_eqP; exists f;split => //. move => ->;rewrite two_times_two; exact:(proj2 clt_24). Qed. (** ---- Exercise 1.23. Let [R0(E)] denote the set of non-empty regular open sets of [E]. Let [r(x)] the unique open regular set that contains the interval with endpoint [x]. This mapping is increasing. Its image is cofinal in [R0(E) ] *) Definition nreg_opens r := (reg_opens r) -s1 emptyset. Definition nregs_order r := opp_order (sub_order (nreg_opens r)). Lemma Exercise1_23aP r X: inc X (nreg_opens r) <-> (open_r r X /\ nonempty X). Proof. split. by move /Zo_P => [] /Zo_hi xe /set1_P xne;split => //; apply /nonemptyP. move => [pa pb]; apply /Zo_P;split; first by apply reg_opens_i. by move /set1_P; apply /nonemptyP. Qed. Lemma Exercise1_23bP r : order r -> forall X Y, (gle (nregs_order r) X Y <-> [/\ nonempty X, nonempty Y, open_r r X, open_r r Y & sub Y X]). Proof. move=> or X Y; split. by move /opp_gleP /sub_gleP => [] /Exercise1_23aP [pa pb] /Exercise1_23aP [pc pd] pe. by move => [pa pb pc pd pe]; apply /opp_gleP /sub_gleP; split => //;apply /Exercise1_23aP. Qed. Definition canonical_reg_open r x := bar1_22 r (Zo (substrate r) (fun z => gle r x z)). Lemma Exercise1_23c r x: order r -> open_o r (Zo (substrate r) (fun z => gle r x z)). Proof. move=> or; split; first by apply: Zo_S. move=> u v => /Zo_P [usr xu] uv; apply /Zo_P;split; order_tac. Qed. Lemma Exercise1_23d1 r x: order r -> inc x (substrate r) -> inc x (canonical_reg_open r x). Proof. move=> or xsr; apply: Exercise1_22e => //; first by apply: Exercise1_23c. by apply: Zo_i => //; order_tac. Qed. Lemma Exercise1_23d2 r x: order r -> inc x (substrate r) -> inc (canonical_reg_open r x) (nreg_opens r). Proof. move=> or xsr; apply /Exercise1_23aP; split. move: (Exercise1_23c x or) => aux; apply: Exercise1_22i => //. by exists x; apply: Exercise1_23d1. Qed. Lemma Exercise1_23e r x y: order r -> inc x (substrate r) -> inc y (substrate r) -> (inc y (canonical_reg_open r x) <-> forall z, gle r y z -> exists2 t, gle r z t & gle r x t). Proof. move=> or xsr ysr. rewrite /canonical_reg_open; split. move /setU_P=> [z yz] /Zo_P [] /setP_P zsr [[_ oz]]. move /(cofinal_inducedP or _ zsr) => [h1 h2]. move => t yt; move: (h2 _ (oz _ _ yz yt)) => [v v1 v2]. by move: v1 => /Zo_hi xv; exists v. move=> h; apply: Exercise1_22h => //. apply: Exercise1_23c => //. move=> z yz; move: (h _ yz) => [t zt xt]. exists t => //;apply: Zo_i=> //; order_tac. Qed. Lemma Exercise1_23f r x y: order r -> gle r x y -> gle (nregs_order r) (canonical_reg_open r x) (canonical_reg_open r y). Proof. move=> or xy. have xsr: (inc x (substrate r)) by order_tac. have ysr: (inc y (substrate r)) by order_tac. move: (Exercise1_23d2 or xsr) (Exercise1_23d2 or ysr) => s1 s2. apply /opp_gleP /sub_gleP;split => //. apply: Exercise1_22j; (try apply: Exercise1_23c) => //. move=> t => /Zo_P [tsr yt]; apply /Zo_i => //; order_tac. Qed. Lemma Exercise1_23g r: order r -> cofinal (nregs_order r) (fun_image (substrate r) (canonical_reg_open r)). Proof. move=> or; red. move:(sub_osr (nreg_opens r)) => [pr1 pr2]. have ->:(substrate (nregs_order r) = nreg_opens r). by rewrite /nregs_order (proj2 (opp_osr pr1)). split. move=> t /funI_P [z zsr] ->; apply: Exercise1_23d2 => //. move=> x /Exercise1_23aP [ox [y yx]]. have ysr: inc y (substrate r) by move: ox => [[xsr _] _]; apply: xsr. move: (Exercise1_23d2 or ysr) => /Exercise1_23aP [p1 p2]. exists (canonical_reg_open r y); first by apply /funI_P;exists y. apply /Exercise1_23bP=> //; split => //; first by exists y. move: (ox) => [ox1 _]. rewrite /canonical_reg_open (Exercise1_22p or ox);apply: Exercise1_22j => //. apply: Exercise1_23c => //. move=> t /Zo_hi yt; move: ox1 => [_ h]; apply: (h _ _ yx yt). Qed. (** Antidirected means that [canonical_reg_open] is injective; We give an equivalent condition *) Definition anti_directed r:= forall x y, inc x (substrate r) -> inc y (substrate r) -> (canonical_reg_open r x) = (canonical_reg_open r y) -> x = y. Lemma Exercise1_23hP r: order r -> let aux := (fun x y => forall z, gle r x z -> gle r y z -> False) in (anti_directed r) <-> ((forall x y, glt r x y -> exists2 z, glt r x z & aux y z) /\ forall x y, inc x (substrate r) -> inc y (substrate r) -> [\/ gle r x y, gle r y x, (exists2 x', gle r x x' & aux x' y) | (exists2 y', gle r y y' & aux x y')]). Proof. move=> or aux. have p1: (forall x y, inc x (substrate r) -> inc y (substrate r) -> (inc y (canonical_reg_open r x) <-> forall z, gle r y z -> ~ (aux x z))). move=> x y xsr ysr; rewrite Exercise1_23e // /aux; split. move=> h z yz h1; move: (h _ yz)=> [t zt xt]; apply: (h1 _ xt zt). move=> h z yz; move: (h _ yz) => h1;ex_middle h2; case: h1. by move=> t xt zt; case: h2; exists t. have Hb:forall x y, gle r x y -> sub (canonical_reg_open r y) (canonical_reg_open r x). move=> x y xy; move: (Exercise1_23f or xy) => /(Exercise1_23bP or). by move => [_ _ _]. have Hc:forall x y, aux x y -> aux y x. move => x y h z s1 s2; apply: (h _ s2 s1). split; last first. move=> [C1 C2] x y xsr ysr cxy; ex_middle nxy. have xc: (inc x (canonical_reg_open r x)) by apply: Exercise1_23d1. have yc: (inc y (canonical_reg_open r y)) by apply: Exercise1_23d1. case: (C2 _ _ xsr ysr) => c2p. + have ltxy: glt r x y by split. move: (C1 _ _ ltxy) => [z [xz _] yz]. by move: xc; rewrite cxy p1 // => h; case: (h _ xz). + have ltxy: glt r y x by split => //; apply:nesym. move: (C1 _ _ ltxy) => [z [xz _] yz]. by move: yc; rewrite - cxy p1 // => h; case: (h _ xz). + case: c2p=> [t xt ty]. by move: xc; rewrite cxy p1 // => h; case: (h _ xt); apply: Hc. + case: c2p=> [t xt ty]. by move: yc; rewrite - cxy p1 // => h; case: (h _ xt). move=> adr. have p2: (forall x y, inc x (substrate r) -> inc y (substrate r) -> (sub (canonical_reg_open r x) (canonical_reg_open r y) \/ (exists2 x', gle r x x' & aux x' y))). move=> x y xsr ysr. case: (p_or_not_p (exists2 x', gle r x x' & aux x' y)); first by right. move=> ne; left. move: (Exercise1_23d2 or ysr) => /Exercise1_23aP [o1 ne1]. rewrite(Exercise1_22p or o1); apply: Exercise1_22j => //. by apply: Exercise1_23c. by case: o1. move=> t /Zo_P [tsr xt]. rewrite (p1 _ _ ysr tsr) => z tz; case: (p_or_not_p (aux y z)) => // ayt. by case: ne; exists z; fprops; order_tac. suff:(forall x y : Set, glt r x y -> exists2 z, glt r x z & aux y z). move=> hs; split => // x y xsr ysr. case: (p_or_not_p (gle r x y)) => lexy; first by constructor 1. case: (p_or_not_p (gle r y x)) => leyx; first by constructor 2. case: (p2 _ _ xsr ysr) => q1. case: (p2 _ _ ysr xsr)=> q2. by case: lexy; rewrite (adr _ _ xsr ysr (extensionality q1 q2));order_tac. by constructor 4; move: q2 => [t t1 t2]; exists t => //; apply: Hc. by constructor 3; move: q1 => [t t1 t2]; exists t. move=> x y [xy nxy]. have xsr:(inc x (substrate r)) by order_tac. have ysr:(inc y (substrate r)) by order_tac. case: (p2 _ _ xsr ysr) => h. move: (Exercise1_23f or xy) => /(Exercise1_23bP or) [_ _ _ _ h']. by case: nxy; rewrite (adr _ _ xsr ysr (extensionality h h')). move: h => [u xyu uy]; exists u; fprops;split => // xu. by case: (uy y); [ ue | order_tac]. Qed. (** The set [set_of_nreg_order] is antidirected *) Lemma Exercise1_23i r x y: order r -> inc x y -> inc y (nreg_opens r) -> gle (nregs_order r) y (canonical_reg_open r x). Proof. move=> or xy. move /Exercise1_23aP => [h1 h2]. have ysr: (sub y (substrate r)) by move: h1 => [[ ok _] _]. move: (Exercise1_23d2 or (ysr _ xy)) => /Exercise1_23aP [h3 h4]. apply /Exercise1_23bP => //; split => //. rewrite (Exercise1_22p or h1); apply: Exercise1_22j => //. by apply: Exercise1_23c. by case: h1. move=> t /Zo_P [tsr xt]. move: h1 => [[_ h] _]; apply: (h _ _ xy xt). Qed. Lemma Exercise1_23j r: order r -> let r':= nregs_order r in (forall x y, inc x (substrate r') -> inc y (substrate r') -> ( (forall z, gle r' x z -> gle r' y z -> False) <-> (disjoint x y))). Proof. move=> or r' x y xsr' ysr'. move:(sub_osr (nreg_opens r)) => [pr1 pr2]. move: (opp_osr pr1) => [or' prb]. have sr': (substrate r' = nreg_opens r) by rewrite /r' prb pr2. rewrite /r'/nregs_order; aw; fprops. split. move=> h; apply: disjoint_pr=> u ux uy. rewrite sr' in xsr' ysr'. exact (h _ (Exercise1_23i or ux xsr') (Exercise1_23i or uy ysr')). rewrite /disjoint=> di z => /(Exercise1_23bP or) [_ [t tz] _ _ zx] /(Exercise1_23bP or) [_ _ _ _ zy]. empty_tac1 t; apply: setI2_i. Qed. Lemma Exercise1_23k r: order r -> anti_directed (nregs_order r). Proof. move=> or. move:(sub_osr (nreg_opens r)) =>[pa pb]. set (r':= nregs_order r). move: (opp_osr pa) => [or' prb]. have sr': (substrate r' = nreg_opens r) by rewrite /r' prb. set (aux:=(fun x y => forall z, gle r' x z -> gle r' y z -> False)). have p1: (forall x y, inc x (substrate r') -> inc y (substrate r') -> (disjoint x y) -> aux x y). by move=> x y xsr' ysr' dxy; rewrite /aux /r' Exercise1_23j // pr2. have Hv:substrate r' = nreg_opens r. rewrite /r' /nregs_order; aw; fprops; ue. set (i := fun x y => bar1_22 r (Zo x (fun u => forall t, gle r u t -> ~ (inc t y)))). have p2: (forall x y, inc x (substrate r') -> inc y (substrate r') -> [/\ open_r r (i x y), sub (i x y) x, disjoint (i x y) y & (i x y = emptyset -> sub x y)]). move=> x y xsr' ysr'. set (z:= Zo x (fun u => forall t, gle r u t -> ~ (inc t y))). have zx: sub z x by apply: Zo_S. move: xsr' ysr';rewrite Hv=> /Exercise1_23aP [ox nex]/Exercise1_23aP [oy ney]. move: (ox)(oy) => [[xsr xop] _] [oy1 _]. have zsr: (sub z (substrate r)) by apply: (@sub_trans x). have oz: (open_o r z). split => // u v /Zo_P [ux xp] uv; apply /Zo_P;split. apply: (xop _ _ ux uv). move => t vt; apply: (xp _ (order_transitivity or uv vt)). move: (Exercise1_22i or oz) => oi; rewrite /i -/z; split => //. rewrite(Exercise1_22p or ox); apply: Exercise1_22j => //. rewrite/disjoint (Exercise1_22p or oy); apply: Exercise1_22k => //. apply /set0_P => u /setI2_P [] /Zo_P [ux p] uy. by case: (p u) => //; order_tac; apply: xsr. move=> bze t tx. rewrite(Exercise1_22p or oy); apply: Exercise1_22h => //. by apply: xsr. move=> u ut; move: (xop _ _ tx ut)=> ux. ex_middle ep; empty_tac1 u; apply: Exercise1_22e => //. apply: Zo_i => // v uv. by case: (inc_or_not v y)=> // vy; case: ep; exists v. have p3: (forall x y, inc x (substrate r') -> inc y (substrate r') -> (inc (i x y) (substrate r') \/ sub x y)). move=> x y xsr' ysr';move: (p2 _ _ xsr' ysr') => [oi si di ai]. rewrite Hv; case: (emptyset_dichot (i x y)) => ei; first by right; apply: ai. by left; apply /Exercise1_23aP. apply /(Exercise1_23hP or'); split. move=> x y xy. have xsr': (inc x (substrate r')) by order_tac. have ysr': (inc y (substrate r')) by order_tac. move: xy=> [] /(Exercise1_23bP or) [nex ney ox oy yx] xy. case: (p3 _ _ xsr' ysr') => p3c; last by case: xy; apply: extensionality. move: (p2 _ _ xsr' ysr')=> [oi si di ai]. exists (i x y); first split. + apply /Exercise1_23bP => //; split => //. by move: p3c;rewrite Hv => /Exercise1_23aP []. + move=> xi; red in di;move: ney => [t ty]; empty_tac1 t. apply: setI2_i=> //; ue. + move: (disjoint_S di) => di'; apply: (p1 _ _ ysr' p3c di'). move=> x y xsr' ysr'. move: (xsr')(ysr') ; rewrite Hv => /Exercise1_23aP [ox nex] /Exercise1_23aP[oy ney]. case: (p3 _ _ xsr' ysr') => p3c; last by constructor 2; apply /Exercise1_23bP. move: (p3c); rewrite Hv => /Exercise1_23aP [oi nei]. move: (p2 _ _ xsr' ysr')=> [oi2 si di ai]. constructor 3; exists (i x y); last by apply: p1. by apply /Exercise1_23bP. Qed. (** Bourbaki says that the mapping is [R0(E) -> R0(R0(E))] bijective. Injectivity has been proved above. We do not know how to prove surjectivity*) Lemma Exercise1_23l r y: order r -> let r' := nregs_order r in inc y (nreg_opens r') -> exists ! x, (inc x (nreg_opens r) /\ y = canonical_reg_open r' x). Proof. move=> or r' ys. set (E:=nreg_opens r). set (E':=nreg_opens r'). move:(sub_osr (nreg_opens r)) =>[pa pb]. move: (opp_osr pa) => [or' prb]. have sr': (substrate r' = nreg_opens r) by rewrite /r' prb. have se: (E = substrate r') by ue. apply /unique_existence;split; last first. move => u v [uE up][vE vp]; apply: (Exercise1_23k or). by rewrite - se. by rewrite - se. ue. have p1: (forall x t, inc x E -> inc t E -> (inc t (canonical_reg_open r' x) <-> (forall u, gle r' t u -> nonempty (u \cap x)))). move=> x t xE tE; move: (xE) (tE); rewrite se => xs ts. rewrite Exercise1_23e//; split. move=> h u tu; move: (h _ tu) => [v]. move /(Exercise1_23bP or)=> [_ [w wv] _ _ vu] /(Exercise1_23bP or) [_ _ _ _ vx]. by exists w; apply: setI2_i; [apply: vu | apply: vx]. move=> h z zx; move: (h _ zx) => [w] /setI2_P [wz wx]. have zs: (inc z (substrate r')) by order_tac. rewrite - se in zs; move: (Exercise1_23i or wx xE) => le1. move: (Exercise1_23i or wz zs) => le2. by exists (canonical_reg_open r w). have p2: (forall x t, inc x E -> inc t E -> (inc t (canonical_reg_open r' x) <-> (forall a, inc a t -> (exists2 b, inc b x & gle r a b)))). move=> x t xE tE; rewrite p1 //; split. move => h a iat; move: (h _ (Exercise1_23i or iat tE)) => [u us]. move: xE =>/Exercise1_23aP [xo [w wx]]. move: us => /setI2_P;rewrite /canonical_reg_open (Exercise1_22p or xo). set z:= Zo _ _; case: (emptyset_dichot (z \cap x)) => ie. move: (xo) => [xo1 _] [h1 h2]. move:(Exercise1_22k or (Exercise1_23c a or) xo1 ie) => ie2. case: (in_set0 (x:= u)); rewrite -ie2; apply/setI2_P; split => //. move: ie => [v] /setI2_P [] /Zo_P [vsr le1] vx _. by exists v => //; apply: Exercise1_22e => //; case: xo. move=> h u => /(Exercise1_23bP or) [_ [b bu] ot ou ut]. move: (h _ (ut _ bu)) => [c cx bc]; exists c; apply: setI2_i =>//. move: ou => [[_ ou] _]; apply: (ou _ _ bu bc). have p3: (forall x t, nonempty x -> open_o r x -> inc t E -> (inc t (canonical_reg_open r' (bar1_22 r x)) <-> (forall a, inc a t -> (exists2 b, inc b x & gle r a b)))). move=> x t [z zx] o tE. have bE: (inc (bar1_22 r x) E). apply /Exercise1_23aP; split => //; first by apply: Exercise1_22i => //. exists z; apply: Exercise1_22e => //. rewrite (p2 _ _ bE tE); split. move=> h a ait; move: (h _ ait) => [c cb ac]. move: cb => /setU_P [d cd] /Zo_P [] /setP_P dsr [od]. move =>/(cofinal_inducedP or _ dsr) [xd h']. move: (h' _ cd) => [e ex ey]; ex_tac; order_tac. move=> h a ait; move: (h _ ait) => [b bx ab]. exists b => //; apply: Exercise1_22e => //. have Hu:forall x, inc x y -> open_r r x. move=> x xy; move: ys => /Exercise1_23aP [[[q1 q2] q3] ney]. by move: (q1 _ xy); rewrite - se => /Exercise1_23aP []. have Hv: (sub (union y) (substrate r)). move=> t /setU_P [x tx xy]; move: (Hu _ xy)=> [[h _] _]; by apply: h. have Hw: (open_o r (union y)). by apply: Exercise1_22c=> //; move=> x xy; case: (Hu _ xy). set (T:=Zo E (fun z => forall a, inc a z -> exists2 b, inc b (union y) & gle r a b)). set (y':= canonical_reg_open r' (bar1_22 r (union y))). have neuy: (nonempty (union y)). move: ys => /Exercise1_23aP [[[q1 q2] q3] ney]. move: ney => [z zy]; move: (q1 _ zy); rewrite - se => /Exercise1_23aP. move => [_ [t tz]]; exists t; union_tac. have Hx :inc (bar1_22 r (union y)) E. apply /Exercise1_23aP; split; first by apply: Exercise1_22i =>//. by move: neuy => [t tu]; exists t; apply: Exercise1_22e. have Ty: (T = y'). suff: (forall t, inc t E -> (inc t T <-> inc t y')). have p4: sub y' E. have p5: (inc (bar1_22 r (union y)) (substrate r')) by rewrite - se. move: (Exercise1_23d2 or' p5) => /Zo_P [ ] /Zo_P [] /setP_P. by rewrite se -/y'. move=> tp; set_extens t => ts. by rewrite -tp //; move: ts => /Zo_P []. by rewrite tp //; apply: p4. move=> t tE; rewrite /y'; rewrite (p3 _ _ neuy Hw tE). split; first by move => /Zo_P []. by move => h; apply: Zo_i. have syy': (sub y y'). move: ys =>/Exercise1_23aP [[[q1 _] _] _]. move=> t ty;rewrite -Ty; apply: Zo_i; first by rewrite se; apply: q1. move=> a ait; have au: (inc a (union y)) by union_tac. ex_tac; order_tac. by move: (q1 _ ty); rewrite - se =>/Exercise1_23aP [[[h _] _] _]; apply: h. have oy': open_o r' y'. rewrite /y'; rewrite se in Hx. move: (Exercise1_23d2 or' Hx) => /Exercise1_23aP. by move=> [[oo _] _]. have cf: substrate (induced_order r' y') = y'. aw; rewrite - se -Ty; apply: Zo_S. (* set (T:= intersection(Zo (powerset (substrate r)) (fun x => open_o r x /\ forall a, inc a (union y) -> exists b, inc b x /\ gle r a b))). assert (open_o r T). uf T. apply: Exercise1_22b. exists (union y). Ztac. apply: powerset_inc. split. apply: Exercise1_22c. ir. nin (Hu _ H7). am. ir. exists a. split. am. order_tac. apply: H6. ir. Ztac. nin H9; am. *) Abort. (** ---- Exercise 1.24: branched sets *) Definition branched r := order r /\ (forall x, inc x (substrate r) -> exists y z, [/\ gle r x y, gle r x z & (forall t, gle r y t -> gle r z t -> False)]). (** An antidirected set with no maximal element is branched *) Lemma Exercise1_24a r: order r -> anti_directed r -> (forall x, inc x (substrate r) -> ~ maximal r x) -> branched r. Proof. move=> or ar nm; split => // x xsr. move: ar => /(Exercise1_23hP or); move => [ar1 ar2]. move: (nm _ xsr)=> xnm. have [y xy]: (exists y, glt r x y). ex_middle xy; case: xnm;split => //. by move=> z xz; symmetry;ex_middle exz; case: xy; exists z. move: (ar1 _ _ xy) => [z xz h]. by move: xy xz => [xy _][ xz _]; exists y; exists z. Qed. (** We consider here the set of closed intervals witeh endpoints [k/2^n] and [(k+1)/2^n] in the set of rational numbers, ordered by inclusion. We first defined the set of positive rational numbers, and its ordering *) Definition Nstar := Nat -s1 \0c. Definition Qplus1 := Nat \times Nstar. Definition Qplus_eq_r x y := (P x) *c (Q y) = (P y) *c (Q x). Definition Qplus1_le_r x y := (P x)*c (Q y) <=c (P y) *c (Q x). Definition Qplus_eq := graph_on Qplus_eq_r Qplus1. Definition Qplus := quotient Qplus_eq. Definition Qplus_or:= graph_on (fun x y => Qplus1_le_r (rep x) (rep y)) Qplus. Lemma Qplus_eq_sr : substrate Qplus_eq = Qplus1. Proof. by apply: graph_on_sr; move=> a aq; rewrite /Qplus_eq_r. Qed. Lemma Qplus_eq_relatedP x y: related Qplus_eq x y <-> [/\ inc x Qplus1, inc y Qplus1 & Qplus_eq_r x y]. Proof. exact :graph_on_P1. Qed. Lemma Qplus1_inc1P x: inc x Qplus1 <-> [/\ pairp x, natp (P x), natp (Q x) & (Q x) <> \0c]. Proof. split; first by move /setX_P => [pa pb] /setC1_P [pc pd];split => //. by move => [pa pb pc pd]; apply /setX_P;split => //; apply /setC1_P. Qed. Lemma Qplus_equiv: equivalence Qplus_eq. Proof. have -> : Qplus_eq = graph_on (fun x y => [/\ inc x Qplus1,inc y Qplus1 & Qplus_eq_r x y]) Qplus1. apply: sgraph_exten. by move => t /Zo_P [] /setX_P []. by move => t /Zo_P [] /setX_P []. move => u v; split => /Zo_P; aw. move => [pa pb]; move: (pa)=> /setXp_P [pc pd]; apply:Zo_i => //;aw. split => // [pa [pvb pc pd]]; apply /Zo_P;split => //; aw. move => [pa [pvb pc pd]]; apply /Zo_P;split => //; aw. apply: equivalence_from_rel; split. move => a b [pa pb pc];split => //. move => y x z /= [pa pb pc] [pd pe pf]; split => //. move: pa pb pe => /Qplus1_inc1P [_ px qx _] /Qplus1_inc1P [_ _ qy nqy] / Qplus1_inc1P [_ pz qz _]. apply: (cprod_eq2l qy (NS_prod px qz) (NS_prod pz qx) nqy). rewrite cprodA (cprodC (Q y) (P x)) pc - cprodA. symmetry; rewrite cprodA (cprodC (Q y) (P z)) - pf - cprodA. by rewrite (cprodC (Q x)). Qed. Lemma Qplus_inc1 x: inc x Qplus -> (inc (rep x) Qplus1 /\ x = class Qplus_eq (rep x)). Proof. move:Qplus_equiv => qe xp; split. rewrite - Qplus_eq_sr; apply: rep_i_sr => //. by rewrite class_rep. Qed. Lemma Qplus_inc2 x: inc x Qplus1 -> inc (class Qplus_eq x) Qplus. Proof. rewrite - Qplus_eq_sr; apply: inc_class_setQ; apply: Qplus_equiv. Qed. Lemma Qplus_leq_compatP a b a' b': related Qplus_eq a a' -> related Qplus_eq b b' -> (Qplus1_le_r a b <-> Qplus1_le_r a' b'). Proof. move /Qplus_eq_relatedP => [a1 a'1 a2] /Qplus_eq_relatedP [b1 b'1 b2]. rewrite /Qplus1_le_r. have mc: forall x y z, natp x -> natp y -> natp z -> z <> \0c -> (x <=c y <-> (x *c z) <=c (y *c z)). move => x y z xB yB zB zne; split => h. apply: cprod_Mlele => //; apply: cleR; fprops. apply: (cprod_le2l zB xB yB zne). by rewrite cprodC (cprodC z y). move: a1 a'1 b1 b'1 => /Qplus1_inc1P [p1 p2 p3 p4] /Qplus1_inc1P [q1 q2 q3 q4] /Qplus1_inc1P [r1 r2 r3 r4] /Qplus1_inc1P [s1 s2 s3 s4]. move: (NS_prod p2 r3) (NS_prod r2 p3)=> p5 p6. rewrite (mc _ _ _ p5 p6 q3 q4). rewrite (mc _ _ _ (NS_prod p5 q3) (NS_prod p6 q3) s3 s4). move: (NS_prod q2 s3) (NS_prod s2 q3)=> q5 q6. rewrite (mc _ _ _ q5 q6 p3 p4). rewrite (mc _ _ _ (NS_prod q5 p3) (NS_prod q6 p3) r3 r4). have ->: ((P a *c Q b) *c Q a') *c Q b' = ((P a' *c Q b') *c Q a) *c Q b. rewrite (cprodC (P a) (Q b)) -(cprodA _ _ (Q a')) a2. rewrite - cprodA cprodC;apply: f_equal2. by rewrite - cprodA (cprodC (Q a) (Q b')) cprodA. exact. have ->: ((P b *c Q a) *c Q a') *c Q b' = ((P b' *c Q a') *c Q a) *c Q b. rewrite cprodC - cprodA - cprodA cprodA (cprodC _ (P b)) b2. rewrite -!cprodA; congr ( _ *c _ ). by rewrite cprodC cprodA (cprodC (Q a) _). done. Qed. Lemma Qplus_or_gle1P x y: inc x Qplus1 -> inc y Qplus1 -> (Qplus1_le_r x y <-> gle Qplus_or (class Qplus_eq x) (class Qplus_eq y)). Proof. move=> xq yq;rewrite /Qplus_or /graph_on /gle /related /Zo_P/coarse; aw. move: Qplus_eq_sr Qplus_equiv => p1 p2. move: (xq)(yq); rewrite -p1 => xq' yq'. move: (related_rep_class p2 xq')(related_rep_class p2 yq') => c1 c2. split. move /(Qplus_leq_compatP c1 c2) => h; apply /Zo_P; aw;split => //. by apply /setXp_P; split => //;apply: Qplus_inc2. move => /Zo_P [] /setXp_P [pa pb]; aw => h. by apply/(Qplus_leq_compatP c1 c2). Qed. Lemma Qplus_or_gle2 x y: gle Qplus_or x y -> Qplus1_le_r (rep x) (rep y). Proof. move => /Zo_P []; aw. Qed. Lemma Qplus_or_osr: order_on Qplus_or Qplus. Proof. have srq:substrate Qplus_or = Qplus. apply: graph_on_sr; move=> a aq; rewrite /Qplus_or /Qplus1_le_r. apply: cleR; fprops. split; last by exact. have ->: (Qplus_or = graph_on (fun a b => [/\ inc a Qplus , inc b Qplus & Qplus1_le_r (rep a) (rep b)]) Qplus). apply: sgraph_exten. by move => t /Zo_P [] /setX_P []. by move => t /Zo_P [] /setX_P []. move => u v; split => /Zo_P; aw. move => [pa pb]; move: (pa) => /setXp_P [pc pd]; apply /Zo_P;split => //;aw. split => //;move => [pa pb pc pd]; apply /Zo_P;split => //; aw. move => [pa [pb pc pd]]; apply /Zo_P;split => //; aw. apply: order_from_rel;split => //; last first. move=> x y /=; move=> [xq yq _]; split => //; split => //; rewrite /Qplus1_le_r; apply: cleR; fprops. move=> x y/=; move=> [xq yq le1] [_ _ le2]. move: (cleA le1 le2) => p3. move: (Qplus_inc1 xq) (Qplus_inc1 yq) => [r1 r2] [r3 r4]. apply /(related_rr_P Qplus_equiv). by rewrite r2; apply: inc_class_setQ; rewrite Qplus_eq_sr. by rewrite r4; apply: inc_class_setQ; rewrite Qplus_eq_sr. apply /Qplus_eq_relatedP;split => //. move=> y x z /=; move=> [xq yq le1] [_ zq le2];split => //. move:(Qplus_inc1 xq)(Qplus_inc1 yq)(Qplus_inc1 zq) => [x1 _][y1 _][z1 _]. move:x1 y1 z1 le1 le2; set X:= (rep x); set Y := rep y; set Z := rep z. move => /Qplus1_inc1P [_ px qx nqx] /Qplus1_inc1P [_ py qy nqy] /Qplus1_inc1P [_ pz qz nqz] le1 le2. have le3: (Q Z) <=c (Q Z) by apply: cleR; fprops. have le4: (Q X) <=c (Q X) by apply: cleR; fprops. move: (cprod_Mlele le1 le3) (cprod_Mlele le2 le4). rewrite - cprodA (cprodC (Q Y) _) cprodA. have aB: inc ((P X) *c (Q Z)) Nat by apply: NS_prod. rewrite - (cprodA (P Y)) - (cprodA (P Y)) (cprodC (Q X)) => le5 le6. move: (cleT le5 le6). rewrite (cprodC (P Z)) - (cprodA (Q Y)) - (cprodC (Q Y)). have bB: inc ((P Z) *c (Q X)) Nat by apply: NS_prod. move=> le7; apply: (cprod_le2l qy aB bB nqy le7). Qed. Lemma Qplus_or_tor: total_order Qplus_or. Proof. move: Qplus_or_osr => [or sr]. split => //. move=> x y; rewrite sr => xq yq. move: (Qplus_inc1 xq)(Qplus_inc1 yq) => [p1 p2] [p3 p4]. have sa: cardinalp (P (rep x) *c Q (rep y)) by fprops. have sb: cardinalp (P (rep y) *c Q (rep x)) by fprops. red; rewrite p2 p4. case: (cleT_ee sa sb) => h; [left | right ]. by apply /(Qplus_or_gle1P p1 p3). by apply /(Qplus_or_gle1P p3 p1). Qed. (** We define [k/2^n] and some properties *) Definition Qpair k n := class Qplus_eq (J k (\2c ^c n)). Lemma Qpair_q1 k n: natp k -> natp n -> inc (J k (\2c ^c n)) Qplus1. Proof. move=> kB nB; rewrite /Qplus1; aw. apply /setXp_P;split => //; apply/setC1_P;split; first by apply:(NS_pow NS2 nB). apply: cpow2_nz; fprops. Qed. Lemma Qpair_q k n: natp k -> natp n -> inc (Qpair k n) Qplus. Proof. by move=> kB nB; apply: inc_class_setQ; rewrite Qplus_eq_sr; apply: Qpair_q1. Qed. Lemma Qpair_eq k n m: natp k -> natp n -> natp m -> Qpair k n = Qpair (k *c (\2c ^c m)) (m +c n). Proof. move=> kB nB mB; apply: class_eq1; first by apply: Qplus_equiv. apply /Qplus_eq_relatedP; split => //. by apply: Qpair_q1. apply: Qpair_q1; [apply: NS_prod;fprops | apply:(NS_sum mB nB) ]. red; aw; rewrite - cprodA; congr (_ *c _); apply: cpow_sum2. Qed. Lemma Qpair_le0P a b c d: natp a -> natp b -> natp c -> natp d -> let f:= fun k n => k *c (\2c ^c n) in (gle Qplus_or (Qpair a b) (Qpair c d) <-> (f a d) <=c (f c b)). Proof. move=> aB bB cB dB f. move: (Qpair_q1 aB bB)(Qpair_q1 cB dB) => p1 p2. split. move / (Qplus_or_gle1P p1 p2); rewrite /Qplus1_le_r; aw. move => h; apply / (Qplus_or_gle1P p1 p2); red; aw. Qed. Lemma Qpair_leP k k' n: natp k -> natp k' -> natp n -> (k <=c k' <-> gle Qplus_or (Qpair k n) (Qpair k' n)). Proof. move=> kB k'B nB. symmetry. apply: (iff_trans (Qpair_le0P kB nB k'B nB)). move: (Qpair_q1 kB nB) => /Qplus1_inc1P; aw;move => [_ _ dB dnz]. split => le1. rewrite (cprodC) (cprodC k' _) in le1. apply: (cprod_le2l dB kB k'B dnz le1). have le2: (\2c ^c n) <=c (\2c ^c n). apply: cleR; fprops. apply: (cprod_Mlele le1 le2). Qed. (** We define the interval [ [a/2^n, (a+1)/2^n] ] and show how to compare these intervals *) Definition Qpairi k n := interval_cc Qplus_or (Qpair k n) (Qpair (csucc k) n). Definition Qpairis := fun_image (Nat \times Nat) (fun z => Qpairi (P z) (Q z)). Definition Qpairi_o := opp_order (sub_order Qpairis). Lemma Qpairis_prP x: inc x Qpairis <-> exists k n, [/\ natp k, natp n & x = Qpairi k n]. Proof. split. move /funI_P => [z /setX_P [pe Pqz Qz] xe]. by exists (P z); exists (Q z). move=> [k [n [kB nB xe]]]; apply /funI_P; exists (J k n); fprops; aw. Qed. Lemma Qpairio_osr: order_on Qpairi_o Qpairis. Proof. move:(sub_osr Qpairis) => [pa pb]. move: (opp_osr pa) => [pc pd]. rewrite /Qpairi_o /order_on; split => //; ue. Qed. Lemma Qpairio_gleP x y: gle Qpairi_o x y <-> [/\ inc x Qpairis, inc y Qpairis & sub y x]. Proof. apply: (iff_trans (opp_gleP _ _ _)). split; first by move /sub_gleP => [p1 p2 p3]. by move => [pa pb pc]; apply /sub_gleP. Qed. Lemma Qpairis_pr1P n k x: inc x (Qpairi k n) <-> (gle Qplus_or (Qpair k n) x /\gle Qplus_or x (Qpair (csucc k) n)). Proof. split; first by move => /Zo_hi. move => [pa pb]; apply: Zo_i => //; order_tac. Qed. Lemma Qpairis_pr2 k n: natp k -> natp n -> (inc (Qpair k n) (Qpairi k n) /\ inc (Qpair (csucc k) n) (Qpairi k n)). Proof. move=> kB xB; move: (NS_succ kB) => skN. move: Qplus_or_osr => [p1 p2]. have p3:gle Qplus_or (Qpair k n) (Qpair k n). by order_tac; rewrite p2; apply: Qpair_q. have p4:gle Qplus_or (Qpair (csucc k) n) (Qpair (csucc k) n). order_tac; rewrite p2; apply: Qpair_q;fprops. have p5:gle Qplus_or (Qpair k n) (Qpair (csucc k) n). apply /Qpair_leP; fprops. by split; apply/Qpairis_pr1P. Qed. Lemma Qpairio_gle1P k n l m: natp k -> natp n -> natp l -> natp m -> let f:= fun k n => (k *c (\2c ^c n)) in gle Qpairi_o (Qpairi k n) (Qpairi l m) <-> ((f k m) <=c (f l n) /\ (f (csucc l) n) <=c (f (csucc k) m)). Proof. move=> kB nB lB mB f. move: (Qpairis_pr2 lB mB) => [p4 p5]. split. move /Qpairio_gleP => [p1 p2 p3]. move: (p3 _ p4) => /Qpairis_pr1P [q1 q2]. move: (p3 _ p5) => /Qpairis_pr1P [q3 q4]. split. by apply /(Qpair_le0P kB nB lB mB). by apply /(Qpair_le0P (NS_succ lB) mB (NS_succ kB) nB). move => [] /(Qpair_le0P kB nB lB mB) pa /(Qpair_le0P (NS_succ lB) mB (NS_succ kB) nB) pb. apply /Qpairio_gleP;split => //. by apply /Qpairis_prP;exists k, n. by apply /Qpairis_prP;exists l, m. move: Qplus_or_osr => [or sr]. move=> t /Qpairis_pr1P [q3 q4]; apply /Qpairis_pr1P;split => //; order_tac. Qed. Lemma Qpairio_gle2P k n l m: natp k -> natp n -> natp l -> natp m -> let f:= fun k n => (k *c (\2c ^c n)) in gle Qpairi_o (Qpairi k n) (Qpairi l m) <-> (exists p, [/\ natp p, m = n +c p, (f k p) <=c l & (csucc l) <=c (f (csucc k) p)]). Proof. move=> kB nB lB mB f. have n2B: natp (\2c ^c n) by fprops. split; last first. move=> [p [pB eq le1 le2]]. apply /(Qpairio_gle1P kB nB lB mB); rewrite eq cpow_sum2; split. rewrite cprodA (cprodC k _) - cprodA cprodC. apply: cprod_Mlele; fprops. rewrite cprodA (cprodC (csucc k) _) - cprodA cprodC. apply: cprod_Mlele; fprops. move/ (Qpairio_gle1P kB nB lB mB). rewrite (cprodC (csucc l) _)(cprodC (csucc k) _). move=> [r1 r02]; move: (r02). have m2B: natp (\2c ^c m) by fprops. rewrite cprod_nS // cprod_nS //. rewrite (cprodC _ l)(cprodC _ k) -/(f k m) -/(f l n) => r2. have r3:(\2c ^c n) <=c (\2c ^c n) by fprops. move: (csum_Mlele r1 r3) => r4. move: (cleT r4 r2) => r5. have fB: natp (f k m) by rewrite /f; fprops. move: (csum_le2l fB n2B m2B r5) => aux. have nm: n <=c m. case: (cleT_el (CS_nat nB) (CS_nat mB)) => // nm. case: (cleNgt aux (cpow_Meqlt NS2 nB nm clt_12)). move: (cdiff_pr nm); set p := (m -c n) => cp. have pB: natp p by apply: NS_diff. move: r1 r02; rewrite - cp cpow_sum2. set ptn:= (\2c ^c n). rewrite cprodA (cprodC k _) - cprodA -/(f k p)(cprodC _ ptn). rewrite - cprodA (cprodC _ (csucc k)) -/(f (csucc k) p) => r1 r6. have knz: ptn <> \0c by apply: cpow2_nz. have fkpB: natp (f k p) by rewrite /f; fprops. have fkspB: natp (f (csucc k) p) by rewrite /f; fprops. rewrite /Nstar;bw; aw; exists p; split => //. apply: (cprod_le2l n2B fkpB lB knz r1). apply: (cprod_le2l n2B (NS_succ lB) fkspB knz r6). Qed. Lemma Qpairio_eq k n l m: natp k -> natp n -> natp l -> natp m -> (Qpairi k n) = (Qpairi l m) -> (k = l /\ n = m). Proof. move=> kB nB lB mB eq1. move: Qpairio_osr => [qo qs]. have mqs: inc (Qpairi k n) (substrate Qpairi_o). rewrite qs; apply /Qpairis_prP; exists k; exists n;split => //. have aux: gle Qpairi_o (Qpairi k n) (Qpairi k n) by order_tac. move: (aux); rewrite {2} eq1 => /(Qpairio_gle2P kB nB lB mB). move => [p [pB np le1 le2]]. move: aux; rewrite {1} eq1 => /(Qpairio_gle2P lB mB kB nB). move => [q [qB nq le3 le4]]. move: (Nsum_M0le p nB)(Nsum_M0le q mB). rewrite -np -nq => le5 le6. have nm: n = m by exact: cleA. have r1: n +c \0c = n +c p by aw; [rewrite -np nm | fprops]. have r2: m +c \0c = m +c q by aw; [rewrite -nq nm | fprops]. move: le1; rewrite -(csum_eq2l nB NS0 pB r1). rewrite cpowx0; aw; fprops => kl. move: le3; rewrite -(csum_eq2l mB NS0 qB r2). rewrite cpowx0; aw; fprops => lk. split => //; exact: cleA. Qed. (** This set has no maximal element *) Lemma Exercise1_24b x: inc x (substrate Qpairi_o) -> ~ (maximal Qpairi_o x). Proof. rewrite (proj2 Qpairio_osr) => /Qpairis_prP [k [n [kB nB xv]]]. set y := Qpairi (k *c \2c) (csucc n). move: NS2 NS1 => b2 b1. have aux: gle Qpairi_o x y. have p1: natp (k *c \2c) by fprops. have p2: natp (csucc n) by fprops. have p3: cardinalp k by fprops. have p4: cardinalp \2c by fprops. have p5: cardinalp (k *c \2c) by fprops. rewrite xv /y; apply /Qpairio_gle2P => //. exists \1c. rewrite (cpowx1 p4) - csucc_pr4 //; fprops; split;fprops. rewrite !csucc_pr4 // cprodDr. have ->: \1c *c \2c = \1c +c \1c by aw; rewrite card_two_pr. rewrite csumA. apply: Nsum_M0le; fprops. move=> [_ h]; move: (h _ aux). have k2B: natp (k *c \2c) by fprops. rewrite xv /y=> xy. move: (Qpairio_eq k2B (NS_succ nB) kB nB xy) => [_ sn]. by move: nB => /NatP /finite_cP [_] []. Qed. Lemma Qpairio_gle3 k n l m z: natp k -> natp n -> natp l -> natp m -> n <=c m -> gle Qpairi_o (Qpairi k n) z -> gle Qpairi_o(Qpairi l m) z -> gle Qpairi_o (Qpairi k n) (Qpairi l m). Proof. move=> kB nB lB mB nm le1 le2. have: inc z (substrate Qpairi_o) by order_tac. rewrite (proj2 Qpairio_osr) => / Qpairis_prP [i [s [iN sN zv]]]. move: le1 le2; rewrite zv => /(Qpairio_gle2P kB nB iN sN) [p [pB s1 le1 le2]] /(Qpairio_gle2P lB mB iN sN) [q [qB s2 le3 le4]]. move: (cdiff_pr nm); set t:=(m -c n) => tp. have tB: inc t Nat by apply: NS_diff. have ptq: p = q +c t. apply: (@csum_eq2l n) => //; fprops. by rewrite (csumC q t) csumA tp - s1. have ptq1: p = t +c q by rewrite csumC. move: le1 le2; rewrite ptq1 cpow_sum2 cprodA cprodA => le1 le2. apply /(Qpairio_gle2P kB nB lB mB); exists t. move: le1 le2 le3 le4. set kt := (k *c (\2c ^c t)). set kpt := ((csucc k) *c (\2c ^c t)). set q2:= (\2c ^c q). move: NS2 => bs2. have kpN: natp kt by rewrite /kt; fprops. have kptN: natp kpt by rewrite /kpt; fprops. have q2B: natp q2 by rewrite /q2; fprops. have kptqN: natp (kpt *c q2) by fprops. have lpqB: natp ((csucc l) *c q2) by fprops. move => le1 /(cleSltP iN) le2 le3 /(cleSltP iN) le4. move: (cle_ltT le1 le4) (cle_ltT le3 le2). have knz: q2 <> \0c. by apply: cpow_nz; fprops. rewrite !(cprodC _ q2) => le5 le6;split => //. apply /cltSleP=>//;apply: (@cprod_lt2l q2) => //; fprops. apply /(cleSltP lB). apply: (@cprod_lt2l q2) => //. Qed. Lemma Qpairio_gle4 x y: inc x (substrate Qpairi_o) -> inc y (substrate Qpairi_o) -> [\/ gle Qpairi_o x y, gle Qpairi_o y x | (forall z : Set, gle Qpairi_o x z -> gle Qpairi_o y z -> False)]. Proof. move=> xs ys. case: (p_or_not_p (gle Qpairi_o x y)) => h1; first by constructor 1. case: (p_or_not_p (gle Qpairi_o y x)) => h2; first by constructor 2. move: (xs) (ys); rewrite (proj2 Qpairio_osr) => /Qpairis_prP. move=> [k [n [kB nB xv]]] /Qpairis_prP [l [m [lB mB yv]]]. constructor 3; rewrite xv yv; move=> z le1 le2. case: (cleT_ee (CS_nat nB) (CS_nat mB)) => // nm. case: h1; rewrite xv yv; apply: (Qpairio_gle3 kB nB lB mB nm le1 le2). case: h2; rewrite xv yv; apply: (Qpairio_gle3 lB mB kB nB nm le2 le1). Qed. (** The set is antiditected thus branched *) Lemma Exercise1_24c: anti_directed Qpairi_o. Proof. move: Qpairio_osr => [h0 sr]. apply/(Exercise1_23hP h0); split => //. move=> x y [lexy nxy]. have xs: inc x (substrate Qpairi_o) by order_tac. have ys: inc y (substrate Qpairi_o) by order_tac. move: (xs) (ys); rewrite sr => /Qpairis_prP [k [n [kB nB xv]]] /Qpairis_prP [l [m [lB mB yv]]]. move: lexy; rewrite xv yv => /(Qpairio_gle2P kB nB lB mB). have skB: natp (csucc k) by fprops. move=> [p [pB nm le1 le2]]. case: (equal_or_not p \0c) => pz. move: le1 le2; rewrite pz cpowx0; aw; fprops. have kk: cardinalp k by fprops. have nc: cardinalp n by fprops. move /(cleSSP kk (CS_nat lB)). move=> lee leb. have lk: l = k by apply: succ_injective1 => //; fprops; apply:cleA. case: nxy; rewrite xv yv lk nm pz; aw. have nmn: m <> n. dneg mn; apply: (@csum_eq2l n) => //; fprops. rewrite -nm mn; aw; fprops. set q2:= (\2c ^c p) in le1 le2. set kq2 := (k *c q2) in le1. set l':= Yo (l = kq2) (csucc l) kq2. have l'B: natp l'. move: NS2=> b2; rewrite /l'; Ytac aux; fprops; rewrite /kq2 /q2; fprops. have ll': l <> l'. by rewrite /l'; Ytac aux =>//; move: lB => /NatP /finite_cP [_]. set z := Qpairi l' m. exists z => //. split; last first. rewrite /z => eq; move: (Qpairio_eq kB nB l'B mB eq) => [_ nm']. by case: nmn. apply /Qpairio_gle2P => //; exists p; rewrite -/q2 -/kq2. have lsl: l <=c (csucc l) by apply: cleS. have p1:= cleT le1 lsl. have p2:= cleR (proj31 p1). have q2B: natp q2 by rewrite /q2; fprops. have kq2B: natp kq2 by rewrite /kq2; fprops. have skq2: natp ((csucc k) *c q2) by fprops. have knz: q2 <> \0c by apply: cpow2_nz. have le3: (csucc kq2) <=c ((csucc k) *c q2). apply /cleSltP => //; split; first exact : (cleT p1 le2). rewrite cprodC cprod_nS // cprodC -/kq2. dneg aux1; apply: (@csum_eq2l kq2) => //; fprops. rewrite -aux1; aw; fprops. split => //; first by rewrite /l'; Ytac aux => //. rewrite /l'; Ytac aux => //. have slB: natp (csucc l) by fprops. have ckq2: cardinalp kq2 by fprops. apply /(cleSltP slB) => //; split => //. rewrite aux csucc_pr4// cprodC cprod_nS // cprodC -/kq2. move=> aux2. move: (csum_eq2l kq2B NS1 q2B aux2) => q21. move: NS1 (cpow_Mle1 CS2 pz) => oB. by rewrite -/q2 -q21 - succ_one;move /(cleSltP oB) => [_ ];case. move=> t; rewrite /z=> le1a le2a. have mm: m <=c m by fprops. move: (Qpairio_gle3 lB mB l'B mB mm le1a le2a). move /(Qpairio_gle1P lB mB l'B mB). set m2:= (\2c ^c m). have m2B: natp m2 by rewrite /m2; fprops. have knz: m2 <> \0c by apply: cpow2_nz. rewrite !(cprodC _ m2); move => [le3 le4]. have le5: l <=c l'. apply: (@cprod_le2l m2) => //. have : (csucc l') <=c (csucc l). apply: (@cprod_le2l m2) => //; fprops. have cl: cardinalp l' by fprops. by move /(cleSSP cl (CS_nat lB)) => le6;case: ll'; apply:cleA. move=> x y xs ys. case: ( Qpairio_gle4 xs ys);first by constructor 1. by constructor 2. by move=> h; constructor 3; exists x => //; order_tac. Qed. Lemma Exercise1_24d: branched Qpairi_o. Proof. apply: (Exercise1_24a (proj1 Qpairio_osr) Exercise1_24c Exercise1_24b). Qed. (** a product is branched *) Lemma Exercise1_24e r r': branched r -> order r' -> branched (order_product2 r r'). Proof. move=> [or bc] or'; split. apply: order_product2_or => //. move: (order_product2_sr or or') => sp. rewrite sp; move=> x xp. move: (xp) => /setX_P [px Px Qx]. move: (bc _ Px)=> [y [z [xy xz etc]]]. set s:= ((substrate r) \times (substrate r')). set y1 := J y (Q x);set z1 := J z (Q x). have y1sr: inc y1 s by rewrite /y1; apply /setX_P; split;fprops; aw;order_tac. have z1sr: inc z1 s by rewrite /s /z1; apply /setX_P; split;fprops;aw;order_tac. have leqa: gle r' (Q x) (Q x) by order_tac. exists y1; exists z1; split => //. by apply/order_product2_P;split => //; rewrite /y1; aw. by apply/order_product2_P;split => //; rewrite /z1; aw. move=> t /order_product2_P [_ _ [q1 _]] /order_product2_P [_ _ [q2 _]]. move: q1 q2; rewrite /y1/z1; aw; apply: etc. Qed. (** Bourbaki says: the product of [ Qpairi_o] and a well-orderd [r'] that has no countable cofinal subset has no antidirected cofinal subset. This is an attempt of a proof (but a part of the assumptions is missing *) Lemma Exercise1_24f: forall r' X, let r := Qpairi_o in let R := (order_product2 r r') in worder r' -> sub X (substrate R) -> cofinal R X -> anti_directed (induced_order R X) -> False. Proof. move => r' X r R wor' Xsr cfs anX. have or': order r' by move: wor' => [ok _]. move: Qpairio_osr => [or sr]. have oR: order R by apply: order_product2_or => //. move: (order_product2_sr or or') => sp. set R' := (induced_order R X). rewrite -/R' -/r in sp. set S:= (substrate r) \times (substrate r'). have srR': substrate R' = X by apply: iorder_sr. have oi: order R' by rewrite /R'; apply: (proj1 (iorder_osr oR _)). set Aux:= fun x y => forall z, gle R' x z -> gle R' y z -> False. move: anX => /(Exercise1_23hP oi) [p01 p02]. have p1: forall x y, glt R' x y -> exists2 z : Set, glt R' x z & Aux y z. by rewrite /Aux/R'. have p2: forall x y : Set, inc x (substrate R') -> inc y (substrate R') -> [\/ gle R' x y, gle R' y x, (exists2 x' , gle R' x x' & Aux x' y) | (exists2 y' : Set, gle R' y y'& Aux x y')]. by rewrite /Aux. clear p01 p02. have aux: forall x y,inc x (substrate R') -> inc y (substrate R') -> gle r (P x) (P y) -> ~ (Aux x y). move=> x y xsr ysr pxy aux. rewrite srR' in p2 xsr ysr. have xs1: inc x S by rewrite /S - sp; apply: Xsr. have ys1: inc y S by rewrite /S - sp; apply: Xsr. move: (xs1) (ys1) => /setX_P [px Px Qx] /setX_P [py Py Qy]. move: (worder_total wor') => [_ tor]. case: (tor _ _ Qx Qy) => le2. case: (aux y); first by apply /iorder_gleP=> //; apply /order_product2_P. order_tac; ue. set t := J (P y) (Q x). have ts: inc t S by rewrite /t;apply /setXp_P;split;fprops. have Rxt: (gle R x t). by apply /order_product2_P; split=> //; split=> //; rewrite /t;aw; order_tac. have Ryt: (gle R y t). by apply /order_product2_P; split=> //; split => //;rewrite /t;aw; order_tac. have trs: inc t (substrate R) by order_tac. move: cfs => [_ hh]; move: (hh _ trs) => [w wX tw]. case: (aux w); apply /iorder_gleP => //; order_tac. have aux2: forall x y, inc x (substrate R') -> inc y (substrate R') -> (Aux x y <-> (~ gle r (P x) (P y) /\ ~ gle r (P y) (P x))). move=> x y xsr ysr. case: (p_or_not_p (gle r (P x) (P y))) => r1. move: (aux _ _ xsr ysr r1) => r3. split => // [] [u1 u2] //. case: (p_or_not_p (gle r (P y) (P x))) => r2. move: (aux _ _ ysr xsr r2) => r3. split; last by move=> [u1 u2]. move=> aux3; case: r3 => z z1 z2; case: (aux3 z) => //. split => _; first by split => //. have xs1: inc x S by rewrite /S - sp; apply: Xsr; ue. have ys1: inc y S by rewrite /S - sp; apply: Xsr; ue. move: (xs1) (ys1) => /setX_P [px Px Qx] /setX_P [py Py Qy]. case: (Qpairio_gle4 Px Py); first by done. by done. move => raux z z1 z2. move: (iorder_gle1 z1) (iorder_gle1 z2) => /order_product2_P [_ _ [r3 _]] /order_product2_P [_ _ [r4 _]]. case: (raux _ r3 r4). Abort. (** Bournbaki says: Note that an ordinal sum contains a cofinal subset isomorphic to E; this seems to be wrong. Bourbaki deduces that there exists a set that is not antidirected but has an antidirected cofinal subset ?? *) Lemma Exercise1_24g r g: orsum_ax r g -> orsum_ax2 g -> anti_directed r -> let R := order_sum r g in exists X, [/\ sub X (substrate R), cofinal R X & anti_directed (induced_order R X)]. Proof. move=> osa alne ar R. pose f i := J (rep (substrate (Vg g i))) i. have oR: order R by rewrite /R; fprops. have p1: forall i, inc i (domain g) -> inc (f i) (substrate R). move=> i idg; rewrite orsum_sr //; apply: disjoint_union_pi1=> //. apply: rep_i; apply: (alne _ idg). set X:= fun_image (domain g) f. have Xsr: sub X (substrate R). move=> t /funI_P [z zdf ->]; exact (p1 _ zdf). exists X; split => //. split => //x; rewrite orsum_sr //. Abort. End Exercise2. Export Exercise2.