Library ssete2
Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Export sset13 ssete1.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
We start with some results that are not in the main files
There is a distribution law between powerset and intersection2
Lemma union_monotone3 A B:
sub A B -> sub (union A) (union B).
Proof.
move=> sAB t /setU_P [y ty yA]; apply/setU_P;exists y => //; fprops.
Qed.
Lemma intersection_greatest A B x:
sub x A -> sub x B -> sub x (A \cap B).
Proof. move=> xA xB t tx; apply /setI2_P; split;fprops. Qed.
Lemma powerset_inter A B:
powerset (A \cap B) = (powerset A) \cap (powerset B).
Proof.
apply: extensionality.
apply: intersection_greatest.
apply: powerset_mono; apply: subsetI2l.
apply: powerset_mono; apply:subsetI2r.
move=> x /setI2_P[] /setP_P xpA /setP_P xpB; apply /setP_P.
by apply: intersection_greatest.
Qed.
The following gives a well-ordering on doubleton a b, even when a=b
Definition example_worder a b := (tripleton (J a a) (J b b) (J a b)).
Lemma example_worder_gleP a b x y:
related (example_worder a b) x y <->
[\/ (x = a /\ y = a), (x = b /\ y = b) | (x = a /\ y = b)].
Proof.
split; first by case /set3_P => h;rewrite(pr1_def h)(pr2_def h); in_TP4.
case => [] [-> ->]; apply /set3_P; in_TP4.
Qed.
Lemma example_is_worder a b:
worder_on (example_worder a b) (doubleton a b).
Proof.
have gc:sgraph (example_worder a b).
move => t /set3_P; case => ->; fprops.
have subs: substrate (example_worder a b) = doubleton a b.
set_extens x.
case/(substrate_P gc)=> [] [y].
move / (example_worder_gleP a b x y); case; case => ->; fprops.
move /(example_worder_gleP a b y x); case; case => _ ->; fprops.
case /set2_P=> h; have aux: (related (example_worder a b) x x)
by apply/(example_worder_gleP a b x x); in_TP4.
substr_tac.
substr_tac.
have pa: related (example_worder a b) a a by apply/example_worder_gleP; in_TP4.
have pb: related (example_worder a b) b b by apply/example_worder_gleP; in_TP4.
have pc: related (example_worder a b) a b by apply/example_worder_gleP; in_TP4.
have oc: (order (example_worder a b)).
split => //.
by red;rewrite subs => y /set2_P [] ->.
move=> x y z; move /example_worder_gleP; case; move => [ -> ->]//.
move /example_worder_gleP; case; move => [ h ->] //.
move=> x y; move /example_worder_gleP; case;move => [ -> ->] //.
by move /example_worder_gleP; case; case.
split; [split; [ exact | ] | exact ].
move => x xab nex.
case: (inc_or_not a x)=> hyp.
exists a; red; rewrite (iorder_sr oc xab); split=>//.
move=> y yx; apply /(iorder_gleP _ hyp yx); apply /example_worder_gleP.
move: (xab _ yx); rewrite subs; case /set2_P; in_TP4.
move: nex=> [y yx]; exists y; red;rewrite (iorder_sr oc xab); split=>//.
move => z zx; apply /(iorder_gleP _ yx zx); apply /example_worder_gleP.
rewrite subs in xab.
move: (xab _ yx); case /set2_P => yb; first by case: hyp; rewrite -yb.
move: (xab _ zx); case /set2_P => zb; first by case: hyp; rewrite - zb.
in_TP4.
Qed.
Two examples of inductive sets
Lemma inductive_example1 A F: sub A (powerset F) ->
(forall S, (forall x y, inc x S -> inc y S -> sub x y \/ sub y x) ->
inc (union S) A) ->
inductive (sub_order A).
Proof.
move=> Ap ih X Xs [oX tX];exists (union X).
move: (sub_osr A) => [oi si].
move: tX; aw => tX;rewrite si in Xs;
have uA: inc (union X) A.
by apply: ih; move=> x y xX yX; move: (tX _ _ xX yX); case =>h;
move: (iorder_gle1 h) => /sub_gleP [_ _ h1]; [left | right].
split; first by rewrite si.
move=> y yX; apply /sub_gleP;split => //;first by apply: Xs.
by apply: setU_s1.
Qed.
Lemma inductive_graphs a b:
inductive (opp_order (extension_order a b)).
Proof.
have [or ssi] := (extension_osr a b).
have [ooi oos]:= (opp_osr or).
hnf; rewrite oos ssi => X Xs toX.
have sXs :sub X (substrate (extension_order a b)) by rewrite ssi.
have Ha:forall i, inc i X -> function i by move=> i /Xs /sfun_set_P [].
have Hb:forall i, inc i X -> target i = b by move=> i /Xs /sfun_set_P [_].
move: toX=> [orX]; aw => tor; last by ue.
set si:= Lg X source.
have Hd: forall i j, inc i (domain si) -> inc j (domain si) ->
agrees_on ((Vg si i) \cap (Vg si j)) i j.
rewrite /si; bw; move=> i j iX jX; bw.
split; [by apply: subsetI2l | by apply: subsetI2r | ].
move=> t /setI2_P [ti tj].
case: (tor _ _ iX jX)=> h; move: (iorder_gle1 h)=> h'.
apply: (extension_order_pr h' ti).
symmetry; apply: (extension_order_pr h' tj).
have He:forall i, inc i (domain si) -> function_prop i (Vg si i) b.
rewrite /si; bw; move=> i iX; red; bw;split;fprops.
move: (extension_covering He Hd) => [[fg sg tg] _ _ agg].
set g:= (common_ext si id b).
have gs: (inc g (sub_functions a b)).
apply /sfun_set_P;split => // t tsg.
rewrite sg in tsg; move: (setUf_hi tsg)=> [v].
rewrite {1}/si; bw => vx; rewrite /si; bw => tv.
by move: (Xs _ vx) => /sfun_set_P [_ sv _]; apply: sv.
exists g; red; rewrite oos ssi; split=>//.
move: agg; rewrite /si; bw => agg y yX.
move: (Xs _ yX) (agg _ yX)=> ys ag.
have fy: function y by move: ys; bw; fprops.
apply /igraph_pP; apply/extension_order_P1;split => //.
rewrite (sub_function fy fg).
move: ag; rewrite /agrees_on; bw;move=> [p1 p2 p3]; split => //.
by move=> u; symmetry; apply: p3.
Qed.
Exercise 5.3 of Bourbaki (see part 1)
Lemma exercise5_3 X i j (I:= domain X) (n := cardinal I)
(ssI := fun k => subsets_with_p_elements k I)
(uH := fun H => unionb (restr X H))
(iH := fun H => intersectionb (restr X H))
(iuH := fun k => intersectionf (ssI k) uH)
(uiH := fun k => unionf (ssI k) iH):
fgraph X -> inc n Bnat -> inc i Bnat -> inc j Bnat ->
(((i = j \/ j <> \0c) -> i +c j <=c succ n -> sub (iuH i) (uiH j))
/\ (succ n <=c i +c j -> (i = j \/ j <=c n) -> sub (uiH i) (iuH j))).
Proof.
move => fgX nB iB jB.
split.
move => spec le1 t hyp.
case: (equal_or_not j \0c) => jnz.
have i0: i = \0c by case: spec => // ->.
move: hyp; rewrite /iuH /uiH /ssI jnz i0.
have re: (restr X emptyset) = emptyset.
apply /set0_P => z /funI_P [a []]; case; case.
have ->: (subsets_with_p_elements \0c I) = singleton emptyset.
apply set1_pr.
by apply/Zo_P; rewrite cardinal_set0;split => //; apply/setP_P; fprops.
move => z /Zo_P [_]; apply:cardinal_nonemptyset.
by rewrite setUf_1 setIf_1 /uH /iH re setUb_0 setIb_0.
set A := Zo I (fun z => ~ inc t (Vg X z)); set B := I -s A.
have AI: sub A I by apply : Zo_S.
move: (cardinal_setC2 AI); rewrite -/n -/B.
rewrite -(csum2_pr2b A) -(csum2_pr2a A) => eq1.
have bp: forall z, inc z B -> inc t (Vg X z).
move => z /setC_P [zI] /Zo_P h; ex_middle tv; case: h;split => //.
have cbb: cardinalp (cardinal B) by fprops.
have cba: cardinalp (cardinal A) by fprops.
have cbB: inc (cardinal B) Bnat.
by move: nB; rewrite eq1 => h; move: (Bnat_in_sum cbb h).
have caB: inc (cardinal A) Bnat.
by move: nB; rewrite eq1 => h; move: (Bnat_in_sum2 cba h).
case: (card_le_to_el (CS_Bnat jB) cbb) => jcb.
have [C [CB cC]]: exists C, sub C B /\ cardinal C = j.
move: jcb; rewrite -(card_card (CS_Bnat jB)) => jcb.
move: (proj2 (eq_subset_cardP _ _) (cardinal_le_aux1 jcb)).
by move => [C c1 c2]; exists C;split => //; apply /card_eqP; eqsym.
have CI: sub C I by move => s sC; move:(CB _ sC);move /setC_P => [].
apply /setUf_P; exists C.
by apply/ Zo_P; split => //; apply/setP_P.
apply /setIb_P.
apply/domain_set0P;bw; apply /nonemptyP => ce.
by move: cC; rewrite ce cardinal_set0; apply:nesym.
by bw;move => l lC; bw; apply: bp; apply: CB.
have: n <c cardinal A +c j.
rewrite eq1; rewrite csumC (csumC _ j); apply:csum_Mlteq => //.
move /(card_le_succ_ltP _ nB) => le2.
move: (card_leT le1 le2); rewrite csumC (csumC _ j) => eq2.
move:(csum_le_simplifiable jB iB caB eq2) => icA.
have [C CB cC]: exists2 C, sub C A & cardinal C = i.
move: icA; rewrite -(card_card (CS_Bnat iB)) => icA.
move: (proj2 (eq_subset_cardP _ _) (cardinal_le_aux1 icA)).
by move => [C c1 c2]; exists C=> //; apply /card_eqP; eqsym.
have CI: sub C I by move => s sC; move:(CB _ sC); apply: AI.
have dsi:inc C (ssI i) by apply /Zo_i => //; apply /setP_P.
move:(setIf_hi hyp dsi)=> /setUb_P [y]; rewrite restr_d.
by move => yC; bw; move: (CB _ yC) => /Zo_P [].
move => le hij.
move => t /setUf_P [y pa pb]; apply /setIf_P.
case: hij => jn; first by rewrite - jn; exists y.
move: (BS_le_int jn nB) => kB.
rewrite /ssI; apply /nonemptyP => he.
move: (subsets_with_p_elements_pr nB kB (refl_equal n)); rewrite he.
by rewrite cardinal_set0; move: (binom_pr3 nB kB jn).
move => z /Zo_P[/setP_P szi cz].
move /Zo_P:pa => [/setP_P syi cy].
case: (emptyset_dichot (y \cap z)) => di.
move: (sub_smaller (setU2_12S syi szi)); rewrite (csum2_pr5 di).
rewrite -(csum2_pr2b y) cz -(csum2_pr2a y) cy -/n.
move => le1; move: (card_leT le le1) (card_lt_succ nB) => l1 l2; co_tac.
move: di => [l /setI2_P [jz jy]].
apply/setUf_P; exists l; bw.
have jr: inc l (domain (restr X y)) by bw.
move: (setIf_hi pb jr); bw.
Qed.
Alternate proof of Cantor Bernstein.
First, any increasing function on powerset E has a fix-point.
Second, assume f: E-> F and g: F-> E are injections.
There is a set M such that E-M = g(F- f(M)) .
The function that maps t to f(t) if t is not in this set,
to the unique y in F-f(M) such that t = g(y) is a bijection E-> F.
Lemma Cantor_Bernstein_aux E (g: fterm)
(m:= union (Zo (powerset E)(fun x=> sub x (g x)))):
(forall x, sub x E -> sub (g x) E) ->
(forall x y, sub x y -> sub y E -> sub (g x) (g y)) ->
(sub m E /\ g m = m).
Proof.
move=> p1 p2; rewrite /m; set (A := Zo _ _).
have su: (sub (union A) E).
by apply: setU_s2 => y /Zo_P [q1 q2]; apply /setP_P.
have p3: (forall x, inc x A -> sub x (g (union A))).
move=> x /Zo_P [q1 q2];apply: (sub_trans q2); apply: p2 =>//.
by apply setU_s1; apply: Zo_i.
have p4: (sub (union A) (g (union A))).
by move=> t /setU_P [y ty yA]; move: (p3 _ yA) =>q; apply: q.
split => //; apply: extensionality => //.
move=> t tg;move: (p1 _ su) => p5; move: (p2 _ _ p4 p5) => p6.
by apply: (setU_i tg); apply: Zo_i => //; apply /setP_P.
Qed.
Lemma Cantor_Bernstein2_full f g
(E:= source f) (F:= source g)
(h:= fun x => E -s (image_by_fun g (F -s (image_by_fun f x))))
(m:= union (Zo (powerset E) (fun x : Set => sub x (h x))))
(T:= image_by_fun g (F -s (image_by_fun f m)))
(p := fun a y => [/\ inc y F, ~ inc y (image_by_fun f m) & a = Vf g y])
(f2:= Lf (fun a =>Yo (inc a T) (select (p a) F) (Vf f a)) E F):
injection f -> injection g -> source f = target g -> source g = target f ->
bijection_prop f2 (source f)(source g).
Proof.
move=> [ff injf] [fg injg] sf sg.
have p1: (forall x, sub x E -> sub (h x) E) by move=> x xE; apply: sub_setC.
have p2: (forall x y, sub x y -> sub y E -> sub (h x) (h y)).
move=> x y xy yE; rewrite /h => t /setC_P [tE ti].
apply /setC_P;split => //; dneg aux.
have q1: sub x (source f) by apply: sub_trans yE.
have pa: sub (F -s image_by_fun f y) (source g) by apply:sub_setC.
have pb: sub (F -s image_by_fun f x) (source g) by apply:sub_setC.
move /(Vf_image_P fg pa): aux => [u] /setC_P [uF nuy] Wu.
apply /(Vf_image_P fg pb); exists u => //;apply /setC_P;split =>//; dneg aux2.
move /(Vf_image_P ff q1): aux2 => [s sx ->]; apply /(Vf_image_P ff yE).
by exists s=> //; apply: xy.
move: (Cantor_Bernstein_aux p1 p2) => [].
rewrite -/m /h -/T => mE hm.
have sc: sub (F -s (image_by_fun f m)) (source g) by apply: sub_setC.
set Pa := (Vf_image_P fg sc); set Pb := (Vf_image_P ff mE).
have TE: (sub T E) by move=> t /Pa [u] /setC_P [uF _] ->; rewrite /E sf; Wtac.
move: (setC_K TE); rewrite hm => cEm.
have sp: forall a, inc a T -> p a (select (p a) F).
move => a aT; apply: (proj1 (select_pr _ _)).
move: aT => /Pa [u] /setC_P [uF num] Wu;ex_tac.
split => //.
move =>x y xF [_ _ xa] yF [_ _ ya].
by apply: injg => //; rewrite -xa -ya.
rewrite /f2/bijection_prop; aw; split => //; apply: lf_bijective.
+ move=> z zE /=;Ytac zT; [ exact (proj31 (sp _ zT)) | rewrite /F; Wtac].
+ move=> u v uE vE; rewrite /f2; Ytac uT; Ytac vT=> aux.
move: (sp _ uT) (sp _ vT); move=> [_ _ W1] [_ _ W2]; by rewrite W1 W2 aux.
move: (sp _ uT) => [f1u nf1i Wf1] ; case: nf1i; apply /Pb.
by rewrite aux;exists v => //; rewrite -hm;apply /setC_P.
move: (sp _ vT) => [f1u nf1i Wf1]; case: nf1i; apply /Pb.
by rewrite -aux;exists u => //; rewrite -hm;apply /setC_P.
by apply: injf.
+ move=> y yF; case: (inc_or_not y (image_by_fun f m)).
move /Pb => [u um Wy]; exists u; first by apply: (mE).
by rewrite /f2 Y_false //; move: um; rewrite - hm => /setC_P [].
move=> aux; exists (Vf g y); first by rewrite /E; Wtac.
have wt: inc (Vf g y) T by apply /Pa; exists y => //; apply /setC_P.
rewrite /f2; Ytac0; move: (sp _ wt) => [q1 q2 q3].
symmetry; by apply: injg.
Qed.
Lemma Cantor_Bernstein2 f g:
injection f -> injection g -> source f = target g -> source g = target f ->
equipotent (source f)(source g).
Proof.
move => pa pb pc pd.
move:(Cantor_Bernstein2_full pa pb pc pd).
by set f0 := Lf _ _ _ => fp; exists f0.
Qed.
Direct proof of the transfinite principle
Theorem transfinite_principle_bis r (p:property):
worder r ->
(forall x, inc x (substrate r) ->
(forall y, inc y (substrate r) -> glt r y x -> p y) -> p x) ->
forall x, inc x (substrate r) -> p x.
Proof.
move => [or wor] hyp x xsr; ex_middle npx.
set (X:=Zo (substrate r) (fun x => ~ p x)).
have neX: (nonempty X) by exists x; apply: Zo_i.
have Xsr: sub X (substrate r) by apply: Zo_S.
move:(wor _ Xsr neX)=> [y []]; aw => /Zo_P [ysr npy] yle.
case: npy; apply: hyp =>//.
move=> t tsr ty; ex_middle npt.
move: (iorder_gle1 (yle _ (Zo_i tsr npt))) => nty; order_tac.
Qed.
Let E be an ordered set and ssub F the set of strict upper bounds of F.
Cantor says that E is well-ordered if E has a least element and, for any
non-empty subset F, if ssub F is not empty, it has a least element.
This agrees with the standard definition
Lemma cantor_worder r
(ssub := fun E => Zo (substrate r)(fun z => forall x, inc x E -> glt r x z)):
order r -> nonempty (substrate r) ->
( worder r <->
( (exists x, least r x)
/\ (forall F, sub F (substrate r) -> nonempty F -> nonempty (ssub F) ->
(exists x, least (induced_order r (ssub F)) x)))).
Proof.
move => or nesr; split.
move => [_ wor ]; split;first by apply: worder_least.
move => F sfr nef nef1; apply: wor => //; apply: Zo_S.
move => [[y [ysr ly]] pb]; split => //.
move => x xsr [x0 x0x].
case: (inc_or_not y x).
move => yx; exists y; red; rewrite (iorder_sr or xsr); split => //.
by move => t tx; apply /iorder_gleP => //; apply: ly; apply: xsr.
move => nyx.
set F:= Zo (substrate r) (fun z => forall t, inc t x -> glt r z t).
have sf1: sub F (substrate r) by apply: Zo_S.
have yf1: inc y F.
apply: Zo_i => // t tx; split; [ apply: (ly _ (xsr _ tx)) | dneg yt; ue].
set G := ssub F.
have pa : sub x G.
move => t tx; apply: Zo_i; first by apply: xsr.
by move => tv /Zo_P [_ aux]; apply: aux.
have neG: nonempty G by exists x0; apply: pa.
have neF: nonempty F by exists y.
have sg: sub (ssub F) (substrate r) by apply: Zo_S.
move: (pb _ sf1 neF neG) => [a []]; rewrite (iorder_sr or sg) => aG h.
exists a; red; rewrite (iorder_sr or xsr).
have qa: forall t, inc t x -> gle r a t.
move => t tx.
move: (h _ (pa _ tx)) => cp1; exact (iorder_gle1 cp1).
case: (inc_or_not a x) => iax.
by split => //; move => t tx; apply /iorder_gleP => //; apply: qa.
have aF: inc a F.
apply: Zo_i; [by apply: sg | move => t tx; split;[ by apply: qa| dneg ta;ue]].
by move: aG => /Zo_P [_ p]; move: (p _ aF) => [_].
Qed.
We study some properties that are forbidden by the axiom of fundation
Lemma afa_ex1 x: x = powerset x -> False.
Proof.
set A := Zo x (fun z => ~ inc z z) => h.
have aux: ~(inc A A).
move /Zo_P => [pa pb]; apply: (pb); apply/Zo_P; split => //.
apply: (aux); apply/Zo_P; split => //; rewrite h; apply /setP_P; apply:Zo_S.
Qed.
Lemma afa_ex2 a b: a = singleton b -> b = doubleton emptyset a ->
a = singleton (powerset a).
Proof. by move => pa pb; rewrite {2} pa setP_1 - pa - pb. Qed.
Lemma afa_ex3 a b c d: a = singleton b ->
b = (doubleton emptyset (singleton emptyset)) +s1 c +s1 d ->
c = doubleton emptyset a -> d = singleton a ->
a = singleton (powerset (powerset a)).
Proof.
move => pa pb pc pd; rewrite pa setP_1 {1} pb -pa; congr (singleton _).
set_extens t.
move => h; apply/setP_P; case /setU1_P :h.
case /setU1_P.
case /set2_P => ->; fprops;apply : set1_sub; fprops.
move => ->; rewrite -pc; fprops.
move => ->; rewrite pd; apply : set1_sub; fprops.
move /setP_P => h.
case: (inc_or_not emptyset t) => ta; case: (inc_or_not a t) => tb.
- apply /setU1_P; left; apply /setU1_P; right; rewrite pc.
by apply: extensionality => // => s; case /set2_P => ->.
- apply /setU1_P; left; apply /setU1_P; left; apply /set2_P; right.
apply set1_pr => // s st; move: (h _ st); case /set2_P => // sa; case: tb; ue.
- apply /setU1_P; right; rewrite pd; apply set1_pr => // s st.
move: (h _ st); case /set2_P => // sa; case: ta; ue.
- apply /setU1_P; left; apply /setU1_P; left; apply /set2_P; left.
apply /set0_P => // s st; move: (h _ st); case /set2_P => sa.
case: ta; ue.
case: tb; ue.
Qed.
Lemma afa_ex4 x: x = gfunctions emptyset x <-> x = singleton emptyset.
Proof.
have aux: inc emptyset (gfunctions emptyset x).
apply /graphset_P1;split;fprops.
apply: fgraph_set0.
by rewrite domain_set0.
have aux2: forall z, inc z (gfunctions emptyset x) -> z = emptyset.
by move => z /graphset_P1 [_ pa _]; apply/ domain_set0_P.
split => h.
by rewrite h;apply set1_pr.
symmetry; rewrite {2} h; apply /set1_pr => //.
Qed.
Lemma afa_ex5 X A: X = gfunctions X A <->
(exists a f, [/\ A = singleton a, X = singleton f & f = singleton (J f a)]).
Proof.
split; last first.
move => [a [f [Aa Xf fv]]].
symmetry; rewrite {2} Xf.
have fgg: fgraph f.
rewrite fv; split.
move => t /set1_P ->; fprops.
move => s t /set1_P -> /set1_P -> ; aw.
apply set1_pr.
apply /graphset_P1;split => //.
by rewrite fv domain_set1 Xf.
move => t; rewrite fv Aa Xf => /set1_P => ->; apply: setXp_i; fprops.
move => e /graphset_P1 [pa pb pc]; rewrite fv.
apply: set1_pr1.
apply /domain_set0P; rewrite pb Xf; fprops.
move => z ze; move: (pc _ ze); rewrite Aa Xf.
by move /setX_P => [qa ] /set1_P qb/set1_P qc; rewrite - qa qb qc.
move => xsg.
case: (emptyset_dichot X) => xne.
empty_tac1 emptyset; rewrite {2} xsg xne.
apply /graphset_P1;split;fprops.
apply: fgraph_set0.
by rewrite domain_set0.
move: xne => [f fX].
move: (fX); rewrite xsg; move => /graphset_P2 [pa pb pc].
set a := Vg f f.
have aA: inc a A.
apply: pc; apply /range_gP => //; rewrite pb; ex_tac.
case: (equal_or_not A (singleton a)) => Aa.
have pd: gfunctions X A = singleton f.
apply: set1_pr; first by ue.
move => z /graphset_P2 [qa qb qc].
apply: fgraph_exten => //; first by ue.
move => t td /=.
have : inc (Vg z t) A.
apply qc; apply /range_gP => //; rewrite qb; exists t => //; ue.
have : inc (Vg f t) A.
apply pc; apply /range_gP => //; rewrite pb; exists t => //; ue.
by rewrite Aa; move => /set1_P -> /set1_P ->.
exists a; exists f;split => //.
apply: set1_pr; first by apply: fdomain_pr1 => //; rewrite pb.
move => e zf; rewrite (in_graph_V pa zf).
by move: (domain_i1 zf); rewrite pb xsg pd => /set1_P ->.
have [b bA ba]: exists2 b, inc b A & b <> a.
ex_middle bad; case: Aa; apply: set1_pr => // z zA.
ex_middle h; case: bad; ex_tac.
set F := Lg X (fun z => Yo (Vg z z = a) b a).
have fgf: fgraph F by rewrite /F; fprops.
have df: domain F = X by rewrite /F; bw.
have fx: inc F X.
rewrite xsg; apply /graphset_P2;split => //.
by move => t /(range_gP fgf) [x qa ->]; rewrite /F; bw; try ue; Ytac h.
case: (equal_or_not (Vg F F) a) => eq1.
by case: ba; move: (eq1); rewrite {1} /F; bw; Ytac0.
by move: (eq1); rewrite {1} /F; bw; Ytac0; case.
Qed.
Lemma afa_ex6 X: X = gfunctions X X <->
(exists2 x, X = singleton x & x = singleton (J x x)).
Proof.
split.
move/afa_ex5 => [a [f [pa pb pc]]]; exists a => //.
by rewrite pa in pb; rewrite {1 2} (set1_inj pb).
by move => [x pa pb]; apply /afa_ex5; exists x; exists x.
Qed.
Lemma afa_ex7 X: X = gfunctions X X <->
X = singleton (singleton (singleton X)).
Proof.
apply (iff_trans (afa_ex6 X)).
have pa: forall t, J t t = singleton (singleton t).
by move => t; rewrite Pair.kprE /kpair /singleton.
split.
move => [a ab]; rewrite pa => s.
by rewrite {1} ab; congr (singleton _); rewrite ab.
move => h; exists (singleton (singleton X)) => //.
by rewrite (pa (singleton (singleton X))) -h.
Qed.
Lemma afa_ex8 X: X = singleton X -> X = gfunctions X X.
Proof. by move => h; apply /afa_ex7; rewrite -h -h. Qed.
Lemma afa_ex9 X A: X = functions X A <->
(exists a f, [/\ A = singleton a, X = singleton f & f = Lf (fun _ => a) X A]).
Proof.
have res: forall A a f t,
A = singleton a -> function f -> target f = A ->
inc t (source f) -> Vf f t = a.
move => B a f t sf pb pc pd;move: (Vf_target pb pd).
by rewrite pc sf => /set1_P.
split; last first.
move => [a [f [Aa Xf fv]]].
symmetry; rewrite {2} Xf.
have la: lf_axiom (fun _ : Set => a) X A by move => t _; rewrite Aa; fprops.
have aux: function (Lf (fun _ : Set => a) X A) by apply: lf_function.
apply: set1_pr.
apply /fun_set_P; rewrite fv;red;aw;split => //.
move => e /fun_set_P [pa pb pc]; rewrite fv.
apply function_exten => //; aw => z ze; aw; last by ue.
exact: (res A a e z Aa pa pc ze).
move => xsg.
case: (emptyset_dichot X) => xne.
move: (empty_function_tg_function A).
set f := empty_function_tg A; move => aux.
by empty_tac1 f; rewrite xsg xne; apply /fun_set_P.
move: xne => [f fX].
move: (fX); rewrite xsg; move => /fun_set_P [pa pb pc].
set a := Vf f f.
have aA: inc a A by rewrite -pc /a; Wtac.
case: (equal_or_not A (singleton a)) => Aa.
have pd: functions X A = singleton f.
apply: set1_pr; first by ue.
move => z /fun_set_P [qa qb qc].
apply: function_exten => //; try ue.
move => t td /=.
have tx: inc t (source f) by rewrite pb - qb.
rewrite (res A a f t Aa pa pc tx).
by rewrite (res A a z t Aa qa qc td).
have pe: lf_axiom (fun _ => a) (functions X A) A by move => t _ /=.
exists a; exists f;split => //.
apply: function_exten => //.
- by apply lf_function.
- by aw; rewrite -xsg.
- aw.
- move => t tf /=; aw; first by exact: (res A a f t Aa pa pc tf).
by move: tf; rewrite pb - xsg.
have [b bA ba]: exists2 b, inc b A & b <> a.
ex_middle bad; case: Aa; apply: set1_pr => // z zA.
ex_middle h; case: bad; ex_tac.
set F := Lf (fun z => Yo (Vf z z = a) b a) X A.
have ta: lf_axiom (fun z => Yo (Vf z z = a) b a) X A by move => t tX /=; Ytac h.
have fx: inc F X.
rewrite xsg; apply /fun_set_P;rewrite /F;red;aw;split => //.
by apply: lf_function.
case: (equal_or_not (Vf F F) a) => eq1.
by case: ba; move: (eq1); rewrite {1} /F; aw; Ytac0.
by move: (eq1); rewrite {1} /F; aw; Ytac0; case.
Qed.
Lemma afa_ex10 X : X = functions X X <->
(exists2 f, X = singleton f & f = triple X X (singleton (J f f))).
Proof.
have xx: forall f, X = singleton f -> f = triple X X (singleton (J f f))
-> f = Lf (fun _ => f) X X.
move => f Xf; set g := (singleton (J f f)) => fg.
have fgg: fgraph g.
split; first by move => t /set1_P ->; fprops.
move => s t /set1_P -> /set1_P ->; aw.
rewrite fg; apply function_exten; aw.
+ apply: function_pr => //.
rewrite /g range_set1 - Xf; fprops.
by rewrite domain_set1.
+ apply: lf_function => t _; rewrite -fg Xf; fprops.
+ move => t tx /=; aw; rewrite /Vf; aw.
rewrite - fg; move: tx; rewrite Xf => /set1_P => ->.
have pb: inc (J f f) g by rewrite /g; fprops.
by move: (in_graph_V fgg pb); aw =>h; rewrite - (pr2_def h).
move => _ _ /=; rewrite - fg Xf; fprops.
apply: (iff_trans (afa_ex9 X X)); split.
move => [a [f [xa xb xc]]]; exists f => //.
have pa: lf_axiom (fun _ => a) X X by move => t _ /=; rewrite xa; fprops.
set g := (singleton (J f f)).
have fgg: fgraph g.
split; first by move => t /set1_P ->; fprops.
move => s t /set1_P -> /set1_P ->; aw.
rewrite xc;apply function_exten; aw.
by apply: lf_function.
apply: function_pr => //.
rewrite /g range_set1 - xb; fprops.
by rewrite domain_set1.
move => t tx /=; aw; rewrite /Vf; aw.
have pb: inc (J f f) g by rewrite /g; fprops.
move: (in_graph_V fgg pb); aw =>h; move: (pr2_def h).
move: (tx); rewrite xb => /set1_P => <- <-.
by move: (tx); rewrite xa => /set1_P => <-.
by move => [f cf tf]; exists f; exists f;split => //; apply: xx.
Qed.
Lemma afa_ex11 X : X = functions X X <->
X = singleton (singleton (singleton (singleton (singleton X)))).
Proof.
split; last first.
move => h; apply /afa_ex10.
exists (singleton (singleton (singleton (singleton X)))).
exact.
rewrite /triple Pair.kprE /kpair.
by rewrite -! /(singleton _) -h -! /(singleton _).
move /afa_ex10 => [f pa pb].
have fa: f = singleton (singleton (singleton (singleton (singleton f)))).
move: pb; rewrite pa.
by rewrite /triple Pair.kprE /kpair - !/(singleton _).
by rewrite {1} pa fa -pa.
Qed.
Lemma afa_ex12 X : X = singleton X -> X = functions X X.
Proof. by move => h; apply /afa_ex11; rewrite -!h. Qed.
Lemma ord_div_nonzero_b a b c:
ordinalp a -> ordinalp b -> ordinalp c ->
a <o (ord_prod2 b c) -> b <> \0o.
Proof.
move=> oa ob oc ale.
move: (ord_gt_ne0 ale) => pz.
dneg x; rewrite x oprod0l //; apply: ordinal_pr10.
Qed.
Lemma ord_div_nonzero_b_bis a b:
ordinalp a -> \0o <o b ->
exists2 c, ordinalp c & a <o (b *o c).
Proof.
move=> oa bp.
move: (oprod_M1le bp (OS_succ oa)) (ord_succ_lt oa);rewrite -(ord_succ_pr oa).
move=> p1 p2; exists (a +o \1o) => //;ord_tac.
Qed.
Lemma odivision_exists_alt a b c:
ordinalp a -> ordinalp b -> ordinalp c ->
a <o (ord_prod2 b c) ->
exists q r, ord_div_pr1 a b c q r.
Proof.
move=> oa ob oc.
move => [] /ordinal_le_P0; rewrite /ord_prod2.
set pbc:= (order_prod2 (ordinal_o b) (ordinal_o c)) => qa qb.
move: (conj qa qb) => a_bc; clear qa qb.
have obc: worder pbc by rewrite /pbc; fprops.
move: (ordinal_lt_pr2 obc a_bc) => [f [x [xsp rgx om]]].
have orb: order (ordinal_o b) by fprops.
have orc: order (ordinal_o c) by fprops.
have ora: order (ordinal_o a) by fprops.
move: (ordinal_o_sr b) (ordinal_o_sr c) => sb sc.
move: (xsp); rewrite orprod2_sr // setX2_P.
rewrite sb sc;move=> [fgx dx xa xb].
have [w wsb wle]: exists2 w, inc w b &
(forall t, inc t b -> gle (ordinal_o b) w t).
have nesb: nonempty (substrate (ordinal_o b)) by rewrite sb;ex_tac.
move: (worder_least (ordinal_o_wor ob) nesb)=> [w [p1 p2]].
rewrite sb in p1 p2; ex_tac.
set y := variantLc (Vg x C0) w.
have ysp: inc y (substrate pbc).
rewrite orprod2_sr //; apply /setX2_P; rewrite sb sc /y; bw; split;fprops.
set r := (Vg x C1) ; set q := (Vg x C0).
have lt_rb: r <o b by apply /ord_ltP0; split => //; ord_tac0.
have lt_qc: q <o c by apply /ord_ltP0; split => //; ord_tac0.
have oq: ordinalp q by move: lt_qc => [[oq _] _].
have odr: ordinalp r by move: lt_rb => [[odr _] _].
have worr: worder (ordinal_o r) by fprops.
have orq: order (ordinal_o q) by fprops.
have sq :=(ordinal_o_sr q).
have sqc: sub q c by move: lt_qc => [[_ _ h] _].
have srb: sub r b by move: lt_rb => [[_ _ h] _].
exists q, r; rewrite /ord_div_pr1 /ord_div_pr0; split => //.
split => //.
have rsub: forall r A u v, order r -> sub A (substrate r) ->
(gle (induced_order r A) u v <-> [/\ inc u A, inc v A & gle r u v]).
move=> r0 A0 u v or Asr; split.
move /setI2_P => [pa] /setXp_P [ua va];split => //.
by move=> [uA vA rr]; apply /iorder_gleP.
set A:= segment pbc y.
have iuA: A = product2 q b.
have pa: inc C0 (doubleton C0 C1) by fprops.
have pb: inc C1 (doubleton C0 C1) by fprops.
set_extens u.
move /segmentP => [] /(orprod2_gleP orb orc).
rewrite sb sc variant_V_ca variant_V_cb.
move=> [pc v2p h] unv.
move: pc => /setX2_P [fgu du ua ub]; apply /setX2_P => //.
case: h;last by move /(ordo_ltP oc ua xa).
move=> [r1 r2]; move: (wle _ ub) => r3.
have Wv: w = (Vg u C1) by order_tac.
case: unv;rewrite /y;apply: fgraph_exten => //; [fprops | bw |].
rewrite du; move=> x0 x0d; try_lvariant x0d; ue.
move /setX2_P => [fgu du ua ub].
have uc:inc (Vg u C0) c by apply: sqc.
apply /segmentP; split; last first.
move => uy; case: (ordinal_irreflexive oq).
move: ua; rewrite uy /y variant_V_ca //.
apply /(orprod2_gleP orb orc); rewrite sb sc;split => //.
by apply /setX2_P.
rewrite /y;apply /setX2_P;bw;split;fprops.
right; rewrite variant_V_ca; apply /(ordo_ltP oc uc) => //.
have ss3: substrate pbc = product2 c b by rewrite orprod2_sr // sb sc.
have ss2: sub A (substrate pbc) by apply: sub_segment.
have sA: sub A (product2 c b) by ue.
have wo2: worder (induced_order pbc A) by apply: induced_wor.
have obq: ordinalp (ord_prod2 b q) by fprops.
have ->:ord_prod2 b q = ordinal (induced_order pbc A).
symmetry; apply: ordinal_o_isu2 => //.
set r1 := (order_prod2 (ordinal_o b) (ordinal_o q)).
have wo1: worder r1 by rewrite /r1; fprops.
apply: orderIT (ordinal_o_is wo1).
have or2:order (induced_order pbc A) by fprops.
have or1:order r1 by fprops.
suff: r1 = (induced_order pbc A) by move=> ->; apply: orderIR.
apply: order_exten => // u v; split.
move /(orprod2_gleP orb orq);rewrite sb sq; move => [pa pb pc].
apply /iorder_gleP; try ue; apply /(orprod2_gleP orb orc).
rewrite sb sc; split => //; try( apply :sA ; ue).
case: pc; [ by left | move => [ /ordo_leP [sa ssb ssc] sd] ; right ].
split => //;apply /ordo_leP;split;fprops.
move => /iorder_gle5P [uA vA] /(orprod2_gleP orb orc) [_ _ h].
apply /(orprod2_gleP orb orq); rewrite sb sq;split => //; try ue.
case: h; [by left | move=> [/ordo_leP [sa ssb ssc] sd]; right].
move: uA vA;rewrite iuA;move /setX2_P => [_ _ uq _] /setX2_P [_ _ vq _].
split => //;apply /ordo_leP;split;fprops.
set C := induced_order pbc (segment pbc x).
have oraC: order_isomorphic C (ordinal_o a).
have injf:= (order_morphism_fi om).
move: om=> [o1 o2 [ff sf tf] mof].
apply: orderIS; rewrite /C -rgx.
have sr: sub (range (graph f)) (substrate pbc).
rewrite - tf; fprops; apply: f_range_graph =>//.
have o3:= (proj1(iorder_osr o2 sr)).
have aux: (source (restriction1 f (source f))) = source f.
rewrite /restriction1; aw.
exists (restriction1 f (source f)); split => //.
red; rewrite - sf; aw; split => //; first by apply: restriction1_fb.
rewrite /restriction1; aw; rewrite -image_by_fun_source //.
red; rewrite aux => u v usf vsf;rewrite restriction1_V // restriction1_V //.
rewrite /pbc mof // rsub //; split; last by move => [_ _].
move=> Wuv; split => //; Wtac.
rewrite - (ordinal_o_o oa) -(ordinal_o_o odr).
have opbc: order pbc by fprops.
symmetry;apply: orsum_invariant5 => //.
apply: orderIT oraC.
set fo:= order_sum2 _ _.
have sfo: substrate fo = canonical_du2 A r.
by rewrite /fo orsum2_sr ;aw; fprops; rewrite ordinal_o_sr.
have ysp': inc y (product2 c b) by ue.
have xsp': inc x (product2 c b) by ue.
have lexy: gle pbc y x.
apply /(orprod2_gleP orb orc); rewrite sb sc /y;bw; split => //; left.
by split => //;apply: wle.
have ltAx: forall t, inc t A -> glt pbc t x.
move =>t /segmentP lttxy; order_tac.
have rprop: forall z, inc z r -> inc (variantLc (Vg x C0) z) (product2 c b).
move=> z zB; apply /setX2_P; bw; split;fprops.
have p1: forall z, inc z r -> gle pbc y (variantLc (Vg x C0) z).
move=> z zB; apply /(orprod2_gleP orb orc); rewrite sb sc; split;fprops.
by rewrite /y;bw;left; split => //; apply: wle; apply: srb.
set g := fun z => Yo (Q z = C0) (P z) (variantLc (Vg x C0) (P z)).
have ssx: sub (segment pbc x) (substrate pbc) by apply: sub_segment.
have srC: substrate C = (segment pbc x) by rewrite /C; aw.
have ta: forall z, inc z (substrate fo) -> inc (g z) (substrate C).
move=> z; rewrite sfo; move /candu2P=> [pz xx].
rewrite srC; apply /segmentP;case :xx.
by move => [Pz Qz]; rewrite /g; Ytac0;apply: ltAx => //.
move => [Pz Qz]; rewrite /g Qz; Ytac0; split; last first.
move => bad; case: (ordinal_irreflexive odr); rewrite {1} /r -bad; bw.
apply /(orprod2_gleP orb orc); rewrite sb sc.
move /(ordo_ltP ob (srb _ Pz) xb): (Pz) => [pa pb].
split; [ by apply: rprop | exact | left].
by rewrite variant_V_ca variant_V_cb.
have bg: bijection (Lf g (substrate fo) (substrate C)).
apply: lf_bijective => //.
move=> u v; rewrite sfo /g; move /candu2P => [pu p3] /candu2P [pv p4].
case: p3; case: p4; move=> [p5 p6][p7 p8];rewrite p6 p8; Ytac0; Ytac0=> aux.
+ by apply: pair_exten =>//; ue.
+ move/segmentP: p7 => lt1;move:(p1 _ p5);rewrite -aux => lt2; order_tac.
+ move/segmentP:p5 => lt1; move:(p1 _ p7); rewrite aux => lt2; order_tac.
+ by apply: pair_exten => //; [ move: (f_equal (Vg ^~ C1) aux); bw | ue ].
move=> v; rewrite srC => /segmentP hyp.
case: (p_or_not_p (glt pbc v y)) => aux.
exists (J v C0); last by rewrite /g; aw; Ytac0.
rewrite sfo; apply /candu2P; split;fprops;left.
by aw; split => //; apply /segmentP.
move: hyp aux => [] /(orprod2_gleP orb orc); rewrite sb sc.
move => [vp xp aux] nvx cvy.
case: aux; last first.
move=> aux2; case: cvy.
split; last by rewrite /y;move: aux2 =>[_ vx]; dneg ww; rewrite ww; bw.
apply /(orprod2_gleP orb orc); rewrite sb sc.
by split => //;rewrite /y; bw; right.
move=> [sva leva].
have vpr: v = variantLc (Vg x C0) (Vg v C1).
move: vp => /setX2_P [a1 a2 a3 a4].
apply: fgraph_exten => //;[ fprops | bw |].
rewrite a2; move => z zd; try_lvariant zd.
have ltva:glt (ordinal_o b) (Vg v C1) (Vg x C1).
split => //; clear cvy; dneg ww; rewrite vpr ww.
symmetry; move:xp => /setX2_P [a1 a2 _ _].
apply: fgraph_exten => //;[ fprops | bw |].
rewrite a2; move => z zd; try_lvariant zd.
exists (J (Vg v C1) C1); last by rewrite /g; aw; rewrite -vpr; Ytac0.
rewrite sfo;apply: candu2_prb => //.
move /ordo_leP: leva => [pa pb pc].
by apply /(ordo_ltP ob pa pb).
exists (Lf g (substrate fo) (substrate C)).
apply: total_order_isomorphism; rewrite ? lf_source ? lf_target //.
rewrite /fo;apply: orsum2_totalorder => //.
apply: total_order_sub => //;apply: worder_total => //.
apply: worder_total => //.
apply: (proj1 (iorder_osr opbc ssx)).
rewrite sfo; rewrite sfo in ta.
have oiA: order (induced_order pbc A) by fprops.
have oor: order (ordinal_o r) by fprops.
move=> u v uc vc /=; rewrite lf_V // lf_V // /fo /C rsub //.
move /orsum2_gleP => [_ _ h]; rewrite - srC;split => //; try (apply: ta => //).
rewrite /g; case: h.
move=> [h1 h2 h3]; Ytac0; Ytac0; apply: (iorder_gle1 h3).
move=> [h1 h2 h3]; Ytac0; Ytac0.
apply /(orprod2_gleP orb orc); rewrite sb sc; bw.
move /ordo_leP: h3 => [h3 h4 h5].
split; [by apply: rprop | by apply: rprop | left; split => //].
by apply /ordo_leP; split => //; apply: srb.
move => [h1 h2]; Ytac0; Ytac0.
move/candu2P: uc => [_]; case; last by move => [_ bad]; case: TP_ne1; ue.
move => [/segmentP [pa _] _].
move/candu2P: vc => [_];case; [ by move=> [_] | move=> [/p1 h0 _]; order_tac].
Qed.
Lemma odiff_pr_alt a b
(c := ordinal (induced_order (ordinal_o b) (b -s a))):
a <=o b -> (ordinalp c /\ b = a +o c).
Proof.
move => [oa ob ab].
set F:= b -s a.
set B := ordinal_o b.
have wB: worder B by rewrite /B;fprops.
move: (ordinal_o_sr b); rewrite -/B => sB.
have Es: sub a (substrate B) by ue.
have Fs: sub F (substrate B) by rewrite sB; apply: sub_setC.
set r := induced_order B a.
set r' := induced_order B F.
have wor: worder r by apply: induced_wor.
have wor': worder r' by apply: induced_wor.
have -> : c = ordinal r' by done.
set A:= ordinal r; set C := ordinal r'.
have oA: ordinalp A by apply: OS_ordinal.
have oC: ordinalp C by apply: OS_ordinal.
split; first by exact.
have ra : r = ordinal_o a.
apply: order_exten; fprops.
move => x y; split => le1.
move: (iorder_gle3 le1) => [p1 p2].
move: (iorder_gle1 le1) => /ordo_leP [_ _ h]; apply /ordo_leP;split => //.
move /ordo_leP: le1 => [pa pb pc]; apply /iorder_gleP => //.
apply /ordo_leP;split;fprops.
have <-: A = a by rewrite /A ra; apply: ordinal_o_o.
rewrite /A/C - (ordinal_o_o ob).
symmetry; apply: orsum_invariant5 => //.
have orb: order B by fprops.
have or: order r by fprops.
have or': order r' by fprops.
have sr: substrate r = a by rewrite /r; aw.
have sr': substrate r' = F by rewrite /r'; aw.
have ta: forall x, inc x (substrate (order_sum2 r r'))
-> inc (P x) (substrate B).
move=> x; rewrite orsum2_sr // => /candu2P; rewrite sr sr'.
by move=> [_ ]; case; move=> [pqx _]; [apply: Es |apply: Fs].
exists (Lf P (substrate (order_sum2 r r')) (substrate B)).
have xxa: total_order (order_sum2 r r').
by apply: orsum2_totalorder; apply: worder_total.
have xxb:bijection (Lf P (substrate (order_sum2 r r')) (substrate B)).
apply: lf_bijective => //.
move=> x y;rewrite orsum2_sr //;move /candu2P=> [px h1] /candu2P [py h2] sp.
apply: pair_exten =>//.
case: h1; case: h2; move=> [Px Qx][Py Qy];rewrite Qx Qy //.
by move: Px Py; rewrite sr sr' /F - sp; move /setC_P => [].
by move: Px Py; rewrite sr sr' /F - sp => aux; move /setC_P => [].
move=> y ysb; case: (inc_or_not y a) => yE.
exists (J y C0); last by aw.
by rewrite orsum2_sr //; apply candu2_pra; rewrite sr.
have yF: inc y F by rewrite /F - sB; apply /setC_P; split.
exists (J y C1); last by aw.
by rewrite orsum2_sr //; apply :candu2_prb; rewrite sr'.
apply: total_order_isomorphism => //; aw.
move=> x y xsr ysr /=; rewrite lf_V // lf_V //.
move: xsr ysr; rewrite orsum2_sr //; move=> xsr ysr => ha.
move /orsum2_gleP:ha => [_ _ h]; case: h.
by move=> [_ _ h1]; move: (iorder_gle1 h1).
by move=> [_ _ h1]; move: (iorder_gle1 h1).
move => [qxa qyb].
move: xsr ysr => /candu2P [px h1] /candu2P [py h2].
case: h1; last by move=> [_]; rewrite qxa => aux; case: TP_ne.
case: h2; first by move=> [_ xx]; rewrite xx in qyb; case: qyb.
rewrite sr sr'; move=> [Py _] [Px _ ].
move: (worder_total wB)=> [_ tob].
have xb: inc (P x) (substrate B) by apply: Es.
have yb: inc (P y) (substrate B) by apply: Fs.
case: (tob _ _ xb yb) => //.
move: Py => /setC_P [_ nya] /ordo_leP [iyb ixb xy]; case: nya.
case: (ordinal_sub (ordinal_hi ob iyb) (ordinal_hi ob ixb) xy).
by move=> ->.
apply: (ordinal_transitive oa Px).
Qed.
Lemma odiff_wrong_alt a b
(c := ordinal (induced_order (ordinal_o b) (b -s a))):
b <=o a -> c = \0c.
Proof.
rewrite /c; move=> [oa ob ab].
rewrite (setC_T ab).
have oon: order (ordinal_o b) by apply: ordinal_o_or.
apply: ordinal0_pr1; aw; last by fprops.
apply: (proj1 (iorder_osr oon _)); fprops.
Qed.
Lemma osum_limit_alt x y: ordinalp x -> limit_ordinal y ->
limit_ordinal (x +o y).
Proof.
move=> ox ly.
move:(proj31 ly) => oy.
case: (ord_zero_dichot ox) => xz; first by rewrite xz osum0l //.
move /limit_ordinal_P3:ly => [ ynz yl].
move: (@osum_Meqlt \0o y x ynz ox); rewrite (osum0r ox) => lt0.
apply /limit_ordinal_P3; split; first by ord_tac.
move => z lt1.
have y1: \1o <o y by rewrite - succ_o_zero; apply: yl.
have oz: ordinalp z by ord_tac.
rewrite - (ord_succ_pr oz).
case: (ord_le_to_ee oz ox) => zx.
exact (ord_le_ltT (osum_Mleeq zx OS1) (osum_Meqlt y1 ox)).
move: (odiff_pr zx) => [pd pe].
rewrite pe in lt1.
move: (yl _ (osum_Meqltr pd oy ox lt1)).
rewrite - (ord_succ_pr pd) => pg.
by move: (osum_Meqlt pg ox); rewrite (osumA ox pd OS1) -pe.
Qed.
Injectivity of cardinal successor, according to Bourbaki
Lemma succ_injective2 a b: cardinalp a -> cardinalp b ->
a +c \1c = b +c \1c -> a = b.
Proof.
move=> ca cb hyp.
suff: equipotent a b.
by move/card_eqP; rewrite (card_card ca) (card_card cb).
move: (disjointU2_pr4 a card_one) => eq1.
move: (disjointU2_pr4 b card_one) => eq2.
rewrite -hyp in eq2; clear hyp.
move: (equipotentS eq1) => [f [bf sf tf]] {eq1}.
move: (equipotentS eq2)=> [g [bg sg tg]] {eq2}.
set (A0:= image_by_fun f (a *s1 C0)).
set (B0:= image_by_fun g (b *s1 C0)).
rewrite /card_one in sf sg.
set xA:= J emptyset C0; set xB:= J emptyset C1.
have main: (forall c h, bijection h -> source h =
(c *s1 C0) \cup ((singleton emptyset) *s1 C1) ->
let w:= image_by_fun h (c *s1 C0) in
let v:= Vf h xB in
[/\ ~(inc v w), target h = w \cup (singleton v) & c \Eq w]).
move=> c h bh sh w v.
move: (bij_function bh)=> fh.
have sh1:sub (c *s1 C0) (source h) by rewrite sh; apply: subsetU2l.
have sh2: inc xB (source h).
rewrite sh; apply: subsetU2r; rewrite /xB;apply /indexed_P;aw;split;fprops.
split.
move /(Vf_image_P fh sh1) => [u vs vw].
have uW: (u = xB).
by move: bh=> [[ _ ih] _]; apply: ih=>//; apply: sh1.
move: vs; rewrite uW; move /indexed_P=> [_ _]; rewrite /xB; aw;fprops.
set_extens t.
move:bh => [_ sjh] tt; move:((proj2 sjh) _ tt)=> [y ys hy].
rewrite sh in ys; case /setU2_P: ys => p.
apply /setU2_P; left; rewrite -hy; apply /(Vf_image_P fh sh1); ex_tac.
have yp: y = xB.
move:p => /indexed_P; aw; move => [py Py Qy].
by apply: pair_exten; rewrite /xB; aw;fprops; move /set1_P: Py.
rewrite -hy yp -/v; apply /setU2_P; right; fprops.
case /setU2_P.
move /(Vf_image_P fh sh1)=> [u us ->]; Wtac.
move /set1_P=> ->; rewrite /v; Wtac.
eqtrans (c *s1 C0).
exists (restriction1 h (c *s1 C0));split.
by apply: restriction1_fb; move: bh => [ih _].
rewrite /restriction1; aw.
rewrite /restriction1; aw.
move: (main _ _ bf sf) (main _ _ bg sg); clear main.
simpl; fold A0 B0.
move=> [nWxfA0 tfA aA0][nWxfB0 tgB bB0].
have tfg: target f = target g by ue.
suff: equipotent A0 B0 by move=> h;eqtrans A0; eqtrans B0; eqsym.
case: (equal_or_not (Vf f xB) (Vf g xB))=> efg.
suff: (A0 = B0) by move=> ->; fprops.
set_extens t => ts.
have : (inc t (target f)) by rewrite tfA; apply: subsetU2l.
rewrite tfg tgB;case /setU2_P =>//.
move /set1_P;rewrite -efg =>tv; case: nWxfA0; ue.
have : (inc t (target f)) by rewrite tfg tgB; apply: subsetU2l.
rewrite tfA; case /setU2_P =>//.
move /set1_P; rewrite efg =>tv; case: nWxfB0; ue.
set (C0:= A0 \cap B0).
have A0v: (A0 = C0 \cup (singleton (Vf g xB))).
set_extens t => ts.
have : (inc t (target f)) by rewrite tfA;apply: subsetU2l.
rewrite tfg tgB; case /setU2_P.
by move=> tB; apply :setU2_1; apply: setI2_i.
move /set1_P => ->; apply /setU2_P; right; fprops.
case /setU2_P: ts; first by move/ setI2_P => [].
move /set1_P => tu.
have: (inc t (target f)).
rewrite tfg tgB; apply: setU2_2; aw; ue.
by rewrite tfA; case/setU2_P =>// /set1_P tw; case: efg; rewrite -tu -tw.
have B0v: (B0 = C0 \cup (singleton (Vf f xB))).
set_extens t => ts.
have : (inc t (target g)) by rewrite tgB;apply: setU2_1.
rewrite -tfg tfA; case /setU2_P.
by move=> tB; apply: setU2_1; apply: setI2_i.
move /set1_P => ->; apply /setU2_2; fprops.
case /setU2_P: ts; first by move /setI2_P => [].
move /set1_P => tu.
have: (inc t (target f)).
rewrite tfA; apply: setU2_2; aw; ue.
rewrite tfg tgB; case /setU2_P =>// /set1_P tw.
by case: efg; rewrite -tu -tw.
rewrite A0v B0v.
apply: equipotent_disjointU2; try apply:set1_equipotent; fprops;
apply /set0_P; move=> y; aw.
move /setI2_P => [] /setI2_P [qa qb] /set1_P qc; case: nWxfB0; ue.
move /setI2_P => [] /setI2_P [qa qb] /set1_P qc; case: nWxfA0; ue.
Qed.
End Exercise2_aux.
Module Exercise2.
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
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 => //; move=> 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_P; aw; split => //; 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=> h;move: (quotient_is_preorder h)=> pq.
move: h => [po es ssr].
set_extens x.
by move /(preorder_reflexivity _ pq) /quotient_orderP=> [xs _].
move=> xs; apply /(preorder_reflexivity _ pq) /quotient_orderP.
split => //; move=> 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 => //.
apply: quotient_is_preorder =>//.
red; 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].
move: (h _ (setQ_repi es xq)) => [y0 y0y aux].
have h1: (inc y0 (substrate s)) by rewrite sssr; order_tac.
have h2: (inc (rep x) (substrate s)) by rewrite sssr; order_tac.
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=> h; move: (quotient_is_preorder h) => pq.
move:(h) => [pr es sr].
rewrite /increasing_pre - sr substrate_quotient_order //; aw.
have gs: sgraph s by fprops.
split.
move=> [_ woc]; split;fprops.
split; fprops; aw.
move=> x y lexy.
have xss: inc x (substrate s) by rewrite sr; order_tac.
have yss: inc y (substrate s) by rewrite sr; order_tac.
apply /quotient_orderP; rewrite /quotient_order_r; aw; split;fprops.
move=> z /(class_P es) => xz; move: (woc _ _ _ lexy xz) => [y' syy' rzy'].
by exists y' => //;apply /(class_P es).
move=>[fc [_ _ _ _ ci]]; split => //.
move=> x y x' rxy sxx'; move: (ci _ _ rxy).
move /quotient_orderP; rewrite /quotient_order_r; move => [_ _].
have xss: inc x (substrate s) by rewrite sr; order_tac.
have yss: inc y (substrate s) by rewrite sr; order_tac.
move: sxx' => /(class_P es) sxx'.
by aw => h1; move: (h1 _ 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=> p1 p2; split;first split => //.
- by apply: order_product2_preorder.
- apply: first_proj_equivalence.
- rewrite first_proj_sr order_product2_sr1 //.
- move=> x y x' /order_product2_P [s1 s2 [rp rq]].
move /first_proj_eq_related_P => [_ s3 sp].
move: (s1)(s2)(s3) => /setX_P [px px1 qx2] /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.
have pt: (pairp t) by move:p2=> [g1 _ _ ]; apply: g1.
apply /setX_P;split => //; substr_tac.
move: ts => /setX_P [pt ps qs].
set (x1:= J x (Q t)); set (x2:= J x (P t)).
have x1p:inc x1 ((substrate r1) \times (substrate r2)) by rewrite /x1; fprops.
have x2p:inc x2 ((substrate r1) \times (substrate r2)) by rewrite /x2; fprops.
have r11: (gle (order_product2 r1 r2) x1 x1).
apply /(preorder_reflexivity _ p3); rewrite order_product2_sr1 //.
have r22: (gle (order_product2 r1 r2) x2 x2).
apply /(preorder_reflexivity _ p3); rewrite order_product2_sr1 //.
have s12: (related p x1 x2).
apply /first_proj_eq_related_P; split => //;rewrite /x1 /x2;aw.
have s21: (related p x2 x1).
apply /first_proj_eq_related_P; split => //;rewrite /x1 /x2;aw.
case: cp => cp.
move: (cp _ _ _ r11 s12) => /order_product2_P [_ _ [_] ].
by rewrite /x1 /x2; aw; rewrite - {3} pt.
move: (cp _ _ _ r22 s21) => /order_product2_P [_ _ [_]].
by rewrite /x1 /x2; aw; rewrite - {3} pt.
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.
move=> ff sf tf p1 p2 [z zE2] cp.
set (E1:= substrate r1) in *; set (E2:= substrate r2) in *.
have sr :substrate r = E1 \times E2.
by rewrite /r order_product2_sr1.
have ss:substrate s = E1 \times E2 by rewrite /s first_proj_sr.
have es :equivalence s by rewrite /s; apply: first_proj_equivalence.
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.
rewrite substrate_quotient_order//.
have bf: bijection f.
split.
split; first (by exact); move => x y xs ys sW.
have xqs: (inc x (quotient s)) by rewrite - sf //.
have yqs: (inc y (quotient s)) by rewrite - sf //.
have pa: inc (rep x) (substrate s) by fprops.
have pb: inc (rep y) (substrate s) by fprops.
apply /(related_rr_P es xqs yqs).
apply /first_proj_eq_related_P;split => //; try ue.
move: (pa)(pb); rewrite ss => pc pd.
move: (pa)(pb); rewrite ss - sc=> rsx rsy.
move: (compf_V cpa rsx) (compf_V cpa rsy).
rewrite cp first_proj_V // first_proj_V // => -> ->.
by aw; rewrite (class_rep es xqs) (class_rep es yqs).
split => //.
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 => //; first by apply: quotient_is_preorder => //; ue.
move=> x y xsf ysf.
set (u:= Vf f x); set (v:= Vf f y).
have xqs: (inc x (quotient s)) by rewrite - sf //.
have yqs: (inc y (quotient s)) by rewrite - sf //.
have pa: inc (rep x) (substrate s) by fprops.
have pb: inc (rep y) (substrate s) by fprops.
move: (pa)(pb); rewrite ss => rxp ryp.
move: (pa)(pb); rewrite ss - sc=> rsx rsy.
move: (compf_V cpa rsx) (compf_V cpa rsy).
rewrite cp first_proj_V // first_proj_V //.
aw; rewrite (class_rep es xqs) (class_rep es yqs) -/u -/v => pc pd.
have rx: (inc (rep x) x) by apply: (setQ_repi es xqs).
split.
move/quotient_orderP => [_ _ h].
move: (h _ rx) => [w wy].
move /order_product2_P => [rpx wp [le1 le2]].
move: (is_class_pr es wy yqs) => yc.
have ws: (inc w (substrate s)) by apply:(inc_in_setQ_sr es wy yqs).
move: (related_rep_class es ws).
by rewrite -yc -pc -pd ; move /first_proj_eq_related_P => [_ rys <-].
move=> h; apply/quotient_orderP; split => // w wx.
move: (inc_in_setQ_sr es wx xqs); rewrite ss.
move=> wpr; move: (wpr) => /setX_P [pw Pw Qw].
have JP: (inc (J v (Q w)) ((substrate r1) \times (substrate r2))).
apply /setXp_P;split => //; rewrite /v -/E1 -tf; Wtac.
exists (J v (Q w)).
rewrite - (class_rep es yqs); apply /(class_P es).
apply /first_proj_eq_related_P; split => //; aw.
apply /order_product2_P; split => //; aw;split; last first.
by move: p2=> [_ aa _]; apply: aa.
move: (is_class_pr es wx xqs) => xc.
have ws: (inc w (substrate s)) by apply: (inc_in_setQ_sr es wx xqs).
move:(related_rep_class es ws).
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.
move: (order_preorder or) => pr.
have pqa: preorder_quo_axioms r s by split => //.
move: (quotient_is_preorder pqa) => [p1 p2 p3].
split => //.
suff sxy: forall x y, related (quotient_order r s) x y ->
related (quotient_order r s) y x -> sub x y.
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.
move: (proj1 tor) => or.
move: (order_preorder or) => pr.
move: (quotient_is_preorder (And3 pr eqs ssr)) => [p1 p2 p3].
pose gr x := (the_greatest (induced_order r x)).
have gp: forall x, sub x (substrate r) -> nonempty x ->
(inc (gr x) x /\ forall y, inc y x -> gle r y (gr x)).
move => x xsr nex.
have fsx: finite_set x by exact(sub_finite_set xsr fs).
move: (finite_subset_torder_greatest tor fsx xsr nex) => h.
move:(iorder_osr or xsr) => [pa' pb'].
move: (the_greatest_pr pa' h).
rewrite -/ (gr x); move => []; rewrite pb'.
move => pa pb; split => // y yx; exact (iorder_gle1 (pb _ yx)).
have gp1: forall x, inc x (quotient s) ->
(inc (gr x) x /\ forall y, inc y x -> gle r y (gr x)).
move => x xq; apply: gp.
move => t tx; rewrite - ssr; apply: (inc_in_setQ_sr eqs tx xq).
exact (setQ_ne eqs 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];split => //.
move: (gp1 _ pa) (gp1 _ pb)=> [qa _][_ qd].
move: (pc _ qa); move => [z zy le1];move: (qd _ zy) => l2; order_tac.
move => t tx.
move: (gp1 _ pa) (gp1 _ pb)=> [_ qb][qc _]; ex_tac.
move: (qb _ tx) => le1; order_tac.
split.
split => //.
move => 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: (gp1 _ xsr) (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 gs: sgraph s.
move => t; case /setU2_P; first by move /diagonal_i_P => [].
case /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 /diagonal_pi_P => [pa <-].
by case /set2_P => h; rewrite (pr1_def h) (pr2_def h).
have pb: forall t, inc t E -> inc (J t t) s.
by move => t te; apply /setU2_P; left; apply /diagonal_pi_P.
have sr: substrate s = E.
set_extens t.
by move /(substrate_P gs);case;move => [y js]; move: (pa _ _ js) => [qa qb].
move => te; move: (pb _ te) => h; substr_tac.
have es: equivalence s.
split => //.
red; rewrite sr => t; apply pb.
move => x y z => aux.
move: (aux); case /setU2_P;[by move /diagonal_pi_P => [_ <-] | move => sxy].
case /setU2_P; first by move /diagonal_pi_P => [_ <-].
move => sxz; case /set2_P: sxy => h; rewrite (pr1_def h);
case /set2_P: sxz => h1; rewrite (pr2_def h1); try (apply:pb => //);
apply /setU2_P; right; fprops.
move => x y; case /setU2_P => h; apply /setU2_P.
by move /diagonal_pi_P: h => [p1 <-]; left; apply /diagonal_pi_P.
right;case /set2_P: h => h; rewrite (pr1_def h) (pr2_def h);fprops.
have ra: related s a c by apply /setU2_P; right; fprops.
have pc: ~ weak_order_compatibility r s.
move => [_ pc]; move: (pc a b c (proj1 lab) ra) => [z].
case /setU2_P; first by move /diagonal_pi_P => [_ <-] => cb; order_tac.
case /set2_P => h; first by case: (proj2 lab); rewrite (pr1_def h).
by case: (proj2 lbc); rewrite (pr1_def h).
have pd //: ~ Ex1_2_hC' r s.
move => hh; move: (hh a b c (proj1 lab) (proj1 lbc) ra).
case /setU2_P => h;first by case:(proj2 lab);move /diagonal_pi_P :h => [_ <-].
case /set2_P: h => h; first by case: (proj2 lbc); rewrite (pr2_def h).
by case: (proj2 lab); rewrite (pr2_def h).
Qed.
Lemma Exercise1_2e3 E: \3c <=c cardinal E ->
exists a b c,
[/\ inc a E, inc b E, inc c E & [/\ a <> b, a <> c & b <> c]].
Proof.
rewrite /card_three - (card_card (CS_succ \2c)) (succ_of_Bnat BS2).
move /eq_subset_cardP1 /eq_subset_ex_injP => [f [[ff injf] sf tf]].
exists (Vf f \0c); exists (Vf f \1c); exists (Vf f \2c).
have zs: inc \0c (source f).
by rewrite sf; apply /setU1_P; left; apply /set2_P; left.
have os: inc \1c (source f).
by rewrite sf; apply /setU1_P; left; apply /set2_P; right.
have ts: inc \2c (source f) by rewrite sf; apply /setU1_P; right.
rewrite -tf;split; fprops; split=> h.
by move: (injf _ _ zs os h); fprops.
by move: (injf _ _ zs ts h); fprops.
by move: (injf _ _ os ts h); fprops.
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] c3; rewrite /glt.
move: (Exercise1_2e3 c3) => [a [b [c [ae be ce [ab bc ac]]]]].
case: (tor _ _ ae be) => h1; case: (tor _ _ be ce) => h2.
by exists a; exists b; exists c.
case: (tor _ _ ae ce) => h3.
exists a; exists c; exists b; fprops.
exists c; exists a; exists b; fprops.
case: (tor _ _ ae ce) => h3.
exists b; exists a; exists c;fprops.
exists b; exists c; exists a; fprops.
exists c; exists b; exists 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 c3.
move: (Exercise1_2e4 tor c3) => [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) => fxy fyz.
move /(ea_relatedP ff) => [xsf ysf sw]; apply /(ea_relatedP ff).
rewrite - sw in fyz; 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' eay' x'y'].
move: aux eay'=> _ /(ea_relatedP ff) [pa pb pc].
by exists y'.
move=> ch; split; first split.
by apply: order_preorder.
by apply: graph_ea_equivalence.
by rewrite graph_ea_substrate.
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:
increasing_fun f r r' ->
composable g (canon_proj (equivalence_associated f)) ->
f = compose g (canon_proj (equivalence_associated f)) ->
(order_morphism g (quotient_order r (equivalence_associated f)) r'
<-> (Ex1_2_hD r f /\ Ex1_2_hD' r r' f)).
Proof.
move => incf cgf fc.
move: (Exercise1_2f1 incf) => qoa.
set (s:= equivalence_associated f) in *.
move: incf => [or or' [ff sr sr'] icf].
have es : equivalence s by rewrite /s; apply: graph_ea_equivalence.
have ss: substrate s = substrate r by rewrite /s graph_ea_substrate.
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 sr - ss.
move: (canon_proj_V rxs); rewrite class_rep // => cpv.
have rsc: inc (rep x) (source (canon_proj s)) by aw.
have: (Vf g (Vf (canon_proj s) (rep x)) = Vf g x) by rewrite cpv.
rewrite - 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).
move=> h;rewrite -(class_rep es xq); apply /(class_P es).
by apply /(ea_relatedP ff).
split.
move=> om.
have p1: forall x y x', inc x (source f) -> inc y (source f) ->
gle r' (Vf f x) (Vf f y) -> inc x' (class s x) ->
exists y', [/\ inc y' (source f), gle r x' y' & Vf f y = Vf f y'].
move=> x y x' xsf yxsf lext x'x.
have xs: (inc x (substrate s)) by rewrite ss - sr.
have csxq: (inc (class s x) (quotient s)) by fprops.
have: (inc x (class s x)) by apply: inc_itself_class.
move /(bpP _ csxq) => [p3 p4 p5]; move: (qp _ csxq) =>[p1 p2].
rewrite -p5 p2 in lext.
have ys: (inc y (substrate s)) by rewrite ss - sr.
have csyq: (inc (class s y) (quotient s)) by fprops.
have: (inc y (class s y)) by apply: inc_itself_class.
move / (bpP _ csyq) => [p3' p4' p5']; move: (qp _ csyq) => [p1' p2'].
rewrite -p5' p2' in lext.
move: om => [q1 q2 [q3 q4 q5]].
rewrite /fiso_prop; rewrite q4 substrate_quotient_order // => q6P.
move: lext => /(q6P _ _ csxq csyq) /quotient_orderP [_ _ q7].
move: (q7 _ x'x) => [u ucy xu]; exists u.
move: ucy => /(bpP _ csyq) [q8 q9 q10].
by rewrite p5' in q10.
split.
move => x y x' xy x'sf sW.
move: (icf _ _ xy); rewrite sW => fxy.
have xc: (inc x'(class s x')) by apply:inc_itself_class=>//;rewrite ss - sr.
have yc: (inc y (source f)) by rewrite sr; order_tac.
apply: p1 x'sf yc fxy xc.
move=> x y xsf ysf leW.
have xc: (inc x (class s x)) by apply: inc_itself_class=>//; rewrite ss - sr.
move: (p1 _ _ _ xsf ysf leW xc) => [x0 [p0 p2 p3]].
by exists x; exists x0.
move=> [CCt DDt].
have oq: (order (quotient_order r s)) by 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 Wrx][rys Wry].
rewrite -Wrx -Wry; split.
move /quotient_orderP => [_ _ aux].
move: (aux _ (setQ_repi es xsg)) => [z zy lerxz].
by move: zy => /(bpP _ ysg) [q1 q2 q3]; rewrite q3; apply: icf.
move => h; apply /quotient_orderP; split => //; move=> z.
move /(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.
done.
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.
rewrite Lg_domain; bw; move => yd; rewrite /disjointU_fam; bw.
by move /indexed_P => [].
Qed.
Lemma Exercise1_3a2: surjection E13_lam.
Proof.
split; first by apply: Exercise1_3a0.
rewrite /E13_lam => y.
rewrite {1 2}/second_proj; aw; move /(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=> [gg alne]; rewrite /E13_lam /second_proj; aw.
move: Exercise1_3a1 => gE.
set_extens t.
move=> tg;move: (alne _ tg) => [u us]; apply /(rangeP gE).
exists u; apply: disjoint_union_pi1 =>//.
by move /(rangeP gE) => [x Je]; move: (du_index_pr1 Je); aw; move => [].
Qed.
Lemma Exercise1_3a3': substrate E13_S = E13_sF.
Proof.
rewrite/ E13_S graph_ea_substrate /second_proj; aw; apply: second_proj_f.
Qed.
Lemma Exercise1_3a3'': substrate E13_S = source E13_lam.
Proof. rewrite 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 => //.
apply: (orsum_or h1).
split => //.
apply: Exercise1_3a0.
by rewrite (orsum_sr h1) /E13_lam /second_proj /E13_F; aw.
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; last (by aw); apply: function_pr; [ fprops | fprops | bw].
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.
rewrite / E13_sF -/f.
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; rewrite /sum_of_substrates -/f.
move=> /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].
rewrite /f/fam_of_substrates;exists (Q x).
split => //; bw; 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; move=> [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. rewrite /E13_S; apply: graph_ea_equivalence; apply: Exercise1_3a0. 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;aw; 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.
move=> [_ tsf Qyt]; move: (disjointU_hi tsf)=> [Qt Pt pt].
rewrite Qyt; apply /indexed_P;split => //.
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 ap]; rewrite (aux _ idg) in ap; apply /(setQ_P es).
have sa: sub a E13_sF.
move=> t; rewrite ap => /indexed_P [pt Pt Qt].
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.
by apply: foqc_f => //;[ apply: Exercise1_3a7 | rewrite Exercise1_3a3''].
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 : (xq) => /(Exercise1_3a8P x h2) [i idg xp].
ex_tac.
have sl: source E13_lam = substrate E13_S by rewrite Exercise1_3a3''.
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 => h2.
have sfoq: source (fun_on_quotient E13_S E13_lam) = quotient E13_S.
by rewrite /fun_on_quotient /section_canon_proj; aw.
move: Exercise1_3a9=> ffoq.
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 => ->.
split => // y.
rewrite sfoq {1} /fun_on_quotient; aw; rewrite -(Exercise1_3a3 h2) => 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).
rewrite -(indexed_p2 h).
by rewrite {2} p1 in h; rewrite -(indexed_p2 h).
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 r2.
move: r2 => /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.
rewrite /Ex1_2_hD /Ex1_2_hD' -Exercise1_3a3'' Exercise1_3a3'.
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)).
move=> h; exists x; split => //; order_tac; rewrite orsum_sr //.
move=> h; exists y; split => //; apply /orsum_gleP; split => //; red.
have <-: (Vf E13_lam x = Q x) by rewrite /E13_lam second_proj_V.
have <-: (Vf E13_lam y = Q y) by rewrite /E13_lam second_proj_V.
by left; split.
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].
move: Exercise1_3a1 => gg.
have oo: (order (order_sum r g)) by fprops.
move; move: Exercise1_3a13 => bf.
suff : (order_morphism (fun_on_quotient E13_S E13_lam)
(quotient_order E13_F (equivalence_associated E13_lam)) r).
move => [p1 p2 [p3 p4 p5] p6]; split => //.
by 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].
move: TP_ne1 => D.
have Js: (inc (J y C1) (substrate (order_sum2 r r'))).
by rewrite (orsum2_sr or or'); apply: candu2_prb.
move: (xgr _ Js) => /orsum2_gleP; aw.
move=> [_ p1 p2].
move: p1 => /candu2P [px]; case.
by move=> [_ qx];case: p2; move => [p1 p3];[case: D| case: p3| case: D].
move=> [pxs qxb]; split => // x0 x0sr.
have Js': (inc (J x0 C1) (substrate (order_sum2 r r'))).
by rewrite (orsum2_sr or or'); apply:candu2_prb.
move: (xgr _ Js') => /orsum2_gleP; aw.
move=> [q1 q2];case ; by case.
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 ysr.
move: (bij_surj sf ysr)=> [z zsf <-].
rewrite - (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 emptyset))=> []; 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; aw => h2.
case: TP_ne.
move: (h2 _ (set2_1 C0 C1)) (h2 _ (set2_2 C0 C1)).
by move /diagonal_pi_P => [_ ->] /diagonal_pi_P [_ ->].
have g1: greatest r1 emptyset.
red; rewrite sr1; split;fprops.
move => x /set1_P ->; apply/diagonal_pi_P;split;fprops.
have g2: greatest (order_sum2 r2 r1) (J emptyset C1).
move: g1 => [pa pb].
have xx:inc (J emptyset C1) (canonical_du2 (substrate r2) (substrate r1)).
by apply: candu2_prb.
red; rewrite (orsum2_sr or2 or1); split; first exact.
move => x xd; apply /orsum2_gleP; split ; [exact | exact | ].
move/candu2P: xd => [px]; case; move => [l1 l2].
constructor 3; aw; split;fprops.
constructor 2; aw; rewrite l2;split;fprops.
exists r2; exists r1;split => //; move => [f isf].
move: (orsum2_greatest or1 or2 ns2 (image_of_greatest isf g2)) => eg.
by case: (ng2 (P (Vf f (J emptyset 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; last by apply: disjoint_union_pi1.
rewrite /fam_of_substrates; bw.
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.
split.
move /right_directedP; bw; move=> [oor h]; split.
apply /right_directedP;split => //.
move => x y xsr ysr.
move: (orsum_pr0 alne xsr) => [x0 p1 p2].
move: (orsum_pr0 alne ysr) => [y0 p3 p4].
move: (h _ _ p2 p4) => [z [zs 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 [isr im].
rewrite sr in isr.
apply /right_directedP; split;fprops;move=> x y xsi ysi.
move: (disjoint_union_pi1 isr xsi)(disjoint_union_pi1 isr ysi) => p1 p2.
move: (h _ _ p1 p2) => [z [zs le1 le2]].
move: (du_index_pr1 zs) => [p3 p4 p5].
move: (orsum_gle_id oa le1); aw => aux; move: (im _ aux)=> Qzi.
exists (P z); split => //; first by ue.
move: le1 => /orsum_gleP [_ _];
by rewrite /order_sum_r Qzi/glt pr2_pair pr1_pair; case;case.
move: le2 => /orsum_gleP; move=> [_ _];
by rewrite /order_sum_r Qzi/glt pr2_pair pr1_pair; case; case.
move => [] /right_directedP [_ rr] imr; apply /right_directedP; split => //; bw.
move=> x y xsr ysr.
move: (du_index_pr1 xsr) (du_index_pr1 ysr) => [Qx Px px][Qy Py py].
rewrite sr in rr; move: (rr _ _ Qx Qy) => [z [zdg 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 /right_directedP => [oz etc].
rewrite eQxz in Px;rewrite eQyz in Py.
move: (etc _ _ Px Py)=> [t [ts t1 t2]].
move: mz =>[];rewrite sr=> zs _.
have aux:inc (J t z) (sum_of_substrates g) by apply: disjoint_union_pi1.
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]; ex_tac;
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 => //.
case: (equal_or_not (Q y) z) => nQyz.
exists y; split => //; last by order_tac; bw.
apply /orsum_gleP; split => //;left; rewrite nQyz; split => //.
rewrite - sr in zdg.
move: (orsum_pr0 alne zdg) => [v v1 v2];ex_tac;
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 => //.
move=> 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; move=> 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.
exists y; apply: sup_comparable => //.
case: (p_or_not_p (gle r y x)) => lyx.
exists x; rewrite set2_C; apply: sup_comparable => //.
set (z:= sup F (J y' y) (J x' x)) in *.
move: (arg2_sr le1).
rewrite sF => zs; move: (du_index_pr1 zs) => [Qz Pz pz]; exists (Q z).
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; move=> tg.
move: (aux _ tg) => [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)).
apply: orsum_g1 => //; move=> 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.
exists x; apply: inf_comparable => //.
case: (p_or_not_p (gle r y x)) => lyx.
exists y; rewrite set2_C; apply: inf_comparable => //.
set (z:= inf F (J y' y) (J x' x)) in *.
move: (arg1_sr le1).
rewrite sF => zs; move: (du_index_pr1 zs) => [Qz Pz pz]; exists (Q z).
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=> tg.
move: (aux _ tg) => [u uVg us].
rewrite sF in x'2 y'2 us.
have le4: (gle F (J u t) (J x' x)).
apply: orsum_g1 => //; move=> eyt; case: lxy; ue.
have le5: (gle F (J u t) (J y' y)).
apply: orsum_g1 => //; move=> 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 &
exists z, least (Vg g j) z].
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 &
exists z, greatest (Vg g j) z].
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); aw => s1.
move: (orsum_gle_id oa p5); aw => s2.
apply: (q3 _ s1 s2).
move: (arg1_sr q1); rewrite sr => asr.
move: (aux _ asr) => [y yVg Js].
rewrite sF in Js.
have s2 : (gle F (J y a) (J u i)).
apply: orsum_g1 => //; move=> eai; rewrite -eai in nij; contradiction.
have s3: (gle F (J y a) (J v j)).
apply: orsum_g1 => //; move=> eai; rewrite -eai in nji; contradiction.
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); aw => s1.
move: (orsum_gle_id oa p2); aw => s2.
apply: (q6 _ s1 s2).
move: (arg2_sr q4); rewrite sr => asr.
move: (aux _ asr) => [y yVg Js].
rewrite sF in Js.
have s2 : (gle F (J u i) (J y b)).
apply: orsum_g1 => //; move=> eai; rewrite eai in nji; contradiction.
have s3: (gle F (J v j) (J y b)).
apply: orsum_g1 => //; move=> eai; rewrite eai in nij; contradiction.
move: (p3 _ s2 s3) => s4;move: (orsum_gle_id oa s4); aw => s5.
order_tac.
move: (arg2_sr p2); rewrite sF => Bs.
move: (du_index_pr1 Bs) => [QB PB pB]; rewrite Hd in PB.
move: (arg1_sr p5); rewrite sF => As.
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)).
apply: orsum_g1 => //;move=> ib; case: nji; ue.
have s2: (gle F (J v j) (J x b)).
apply: orsum_g1 => //; move=> 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)).
apply: orsum_g1 => //; move=> ib; case: nij; ue.
have s2: (gle F (J x a) (J v j)).
apply: orsum_g1 => //;move=> 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.
set (z:= sup (order_sum r g) (J x i) (J y i)) in *.
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 z).
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 => [_]; case; 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.
set (z:= inf (order_sum r g) (J x i) (J y i)) in *.
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 z).
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) (fun k => glt r i k)) (substrate r)).
rewrite sr; apply: Zo_S.
have z1: inc (Q Z) (Zo (domain g) (fun k => glt r i k)) 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: (l5 _ l7 l8) => l9; move: (orsum_gle_id oa l9); aw.
exists (P Z);split => //.
move=> 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.
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_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: (l5 _ l7 l8) => l9; move: (orsum_gle_id oa l9); aw.
exists (P Z);split => //.
move=> 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 (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: lub_set2=> //.
apply /orsum_gleP;split => //; [ue | by right; aw].
apply /orsum_gleP;split => //; [ ue | by right; aw;rewrite - sq; aw].
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=> [ws lew].
have Js: (inc (J z w) (sum_of_substrates g)).
apply: disjoint_union_pi1 => //.
exists (J z w); apply: lub_set2 => //.
by apply /orsum_gleP;split => //; left; aw; move: ws => /Zo_P [_].
by apply /orsum_gleP;split => //; left; aw; move: ws => /Zo_P [_]; 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.
have Fxy: (gle F x y) by apply /orsum_gleP;split=> //;left; split => //; ue.
exists y; apply: sup_comparable=> //.
case: (equal_or_not (Q x) a) => Qxa.
have Fyx: (gle F y x) by apply /orsum_gleP;split => //; left;split => //;ue.
by exists x; rewrite set2_C; apply: sup_comparable.
case: h7=> h7'.
have lyy: (gle r (Q y) (Q y)) by order_tac; ue.
move: (order_antisymmetry or l2 (l3 _ h7' lyy)) => bad; contradiction.
have lxx: (gle r (Q x) (Q x)) by order_tac; ue.
move: (order_antisymmetry or l1 (l3 _ lxx h7')) => bad; contradiction.
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=> //.
apply /orsum_gleP; split => //; left; split => //; aw; split => //.
apply /orsum_gleP; split => //; left; split => //; aw; split => //.
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 => //.
by apply /orsum_gleP; split => //; try ue; right; aw.
apply /orsum_gleP; split => //; try ue; right; aw;split => //.
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=> [ws lew].
have Js: (inc (J z w) (sum_of_substrates g)).
apply: disjoint_union_pi1 => //.
exists (J z w); apply: glb_set2 => //.
by apply /orsum_gleP; split => //; left;aw; move: ws => /Zo_hi.
by apply /orsum_gleP; split => //; left;aw; move: ws => /Zo_hi; 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: (h2 _ _ Qx Qy) => h7.
case: (equal_or_not (Q y) a) => Qya.
have Fxy: (gle F y x).
by apply /orsum_gleP;split => //; left;split => //;[ ue | apply:nesym ].
exists y; rewrite set2_C;apply: inf_comparable=> //.
case: (equal_or_not (Q x) a) => Qxa.
have Fyx: (gle F x y) by apply /orsum_gleP;split => //; left; split => //; ue.
by exists x; apply: inf_comparable.
case: h7=> h7'.
have lyy: (gle r (Q x) (Q x)) by order_tac; ue.
by move: (order_antisymmetry or l1 (l3 _ lyy h7')) => bad; case: Qxa.
have lxx: (gle r (Q y) (Q y)) by order_tac; ue.
by move: (order_antisymmetry or l2 (l3 _ h7' lxx)) => bad; case: Qya.
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=> //.
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 :=
Sgraph (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].
split => //.
apply: equivalence_Sgraph => //.
apply: substrate_Sgraph => //.
apply: connected_comp_class => //.
move => x y rxy; rewrite /Sgraph /related/graph_on/coarse => //.
move: (ncre _ _ rxy) => pa.
move: (ncre _ _ (ncs _ _ rxy)) => pb.
apply: Zo_i; first by apply /setXp_i.
exists (chain_pair x y); split => //; aw.
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 constructor 1.
case: (emptyset_dichot b) => neb; first by constructor 2.
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; constructor 3.
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.
exists u; exists 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)) in *.
move=> nwa; exists u; exists w => //.
have : inc w (a \cup b).
apply: (rel_in_class2 p1 uc).
move: (rel_in_class p1 uc uu) (p4 _ _ r0) => pa pb; equiv_tac.
by case/setU2_P.
move: (h _ _ ua vb) uv => aux [_ _].
case => cv; [exists u; apply: setI2_i => // ; ue | contradiction].
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 => //; move=> 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); first by move=> ->; 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.
move=> nxy.
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.
case =>cv; [left | right]; apply /quotient_orderP; split => //.
move=> u ux; exists (rep y) => //.
have rrxu: (related (ncr_equiv r) (rep x) u) by apply: related_rep_in_class.
have rryy: related (ncr_equiv r)(rep y)(rep y) by apply: related_rep_in_class.
apply: (Exercise1_4b1 or rrxu rryy nsc cv).
move=> u ux; exists (rep x) => //.
have rrxu: (related (ncr_equiv r) (rep y) u) by apply: related_rep_in_class.
have rryy: related (ncr_equiv r)(rep x)(rep x) by apply: related_rep_in_class.
apply: (Exercise1_4b1 or rrxu rryy); fprops.
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.
move => u [q1 q2 h]; case: h; first by move=> ->.
by move=> bad; case: bad; 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; 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_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.
move => u [q1 q2 h]; case: h; first by move=> ->.
by move=> bad; case: bad; 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 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); red; 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).
apply: (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).
have to:forall x y,
inc x (substrate r) -> inc y (substrate r) -> gle r x y \/ glt r y x.
move=> x y xs ys; case: (tor _ _ xs ys); first by left.
move=> aux; case:(equal_or_not x y) => h; first by left; rewrite h; order_tac.
by right;split => //; apply:nesym.
have to':forall x y,
inc x (substrate r') -> inc y (substrate r') -> gle r' x y \/ glt r' y x.
move=> x y xs ys; case: (tor' _ _ xs ys); first by left.
move=> aux; case:(equal_or_not x y) => h; first by left; rewrite h; order_tac.
by right;split => //; apply:nesym.
case:(p_or_not_p(exists2 x, inc x (substrate r'') & ~ gle r'' w x)); last first.
move => bad; constructor 1; split => //; move=> x xsr.
case: (p_or_not_p (gle r'' w x)) => //.
move=> 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; constructor 2; split => //; move=> x xsr.
case: (p_or_not_p (gle r'' x w)) => //.
move=> bad1;case: bad; ex_tac.
move=> [gr grr grc].
constructor 3.
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].
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.
rename q1 into r0.
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.
rename q1 into r1.
move: (p7 _ r1) (p8 _ r0)=> q1 q2.
case: (to' _ _ Qw bs') => q3; last first.
by move:(p5 _ _ (np1 _ _ _ _ r1 q3) JbC); rewrite pw.
case: (to' _ _ cs' Qw) => q4; last first.
by move:(p6 _ _ (np1 _ _ _ _ r0 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 [xs ys p1] [_ _ p2].
move: xs ys => /Zo_P [_ fs1] /Zo_P [_ fs2].
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.
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.
rewrite -eq1 in le2.
rewrite (order_antisymmetry or le1 le2) //.
move=> x y [xs ys p1]; split => //; split =>//.
move=> a ax; ex_tac; apply: (Exercise1_5w or xs ax).
move=> a ax; ex_tac; 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_P;aw; split => //; 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)).
move=> x xsr; apply: Exercise1_5b => //.
move: (fs_order_osr or) => [pa pb].
split => //; first by split;aw => //; apply: lf_function.
red;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.
case: (t _ _ (xs _ xX) (xs _ yX)) => aux.
apply: (fs _ _ xX yX aux).
symmetry; apply: (fs _ _ yX xX aux).
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].
move: (fs_order_osr or) => [pa pb].
split => //; rewrite pb.
move=> 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].
have xp: (x = singleton X) by apply: set1_pr => // t tx; apply: sx.
have yp: (y = singleton Y) by apply: set1_pr => // t tx; apply: sy.
move: xsf ysf => /Zo_P [] /setP_P xsr _/Zo_P [] /setP_P ysr _.
move: (xsr _ Xx)(ysr _ Yiy) => Xsr Ysr.
rewrite xp yp;case: (tr _ _ Xsr Ysr) => h; [left | right].
by apply/(Exercise1_5cP or Xsr Ysr).
by apply/(Exercise1_5cP or Ysr Xsr).
Qed.
Lemma Exercise1_5h r: order r ->
total_order (free_subset_order r) -> total_order r.
Proof.
move=> or tor; split => //; move => 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
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.
move=> t ta; rewrite - sf in ta;move: (Vf_target ff ta).
by rewrite tf; move => /setX_P [].
have tb: lf_axiom (fun z=> Q (Vf f z)) a c.
move=> t ts; rewrite - sf in ts;move: (Vf_target ff ts).
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 /fun_set_P [ft st tt].
move: (Exercise1_6a ft st tt)=> [_ _ fa fb _].
apply: setXp_i; apply /fun_set_P;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 /fun_set_P [fu su tu] /fun_set_P [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 : (inc (Vf u x)(b \times c)) by rewrite -tu; Wtac.
have : (inc (Vf v x)(b \times c)) by rewrite -tv; Wtac.
move=> /setX_P [p1 _ _] /setX_P [p2 _ _]; apply: pair_exten => //.
rewrite -(h5 _ xa) - (h11 _ xa) sfp //.
rewrite -(h6 _ xa) - (h12 _ xa) ssp //.
move=> y /setX_P [yp] /fun_set_P [fp sp tp] /fun_set_P [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 /fun_set_P.
apply: pair_exten; [exact | fprops| |];
rewrite ? pr1_pair ? pr2_pair;
apply: function_exten; rewrite / first_projection /secnd_projection;
rewrite ? lf_source ? lf_target //;
[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 => [] /fun_set_P.
by move => [pa pd]; apply: Zo_i => //; apply /fun_set_P.
Qed.
Lemma imo_osr:
order_on (increasing_mappings_order r r') (increasing_mappings r r').
Proof.
rewrite /increasing_mappings_order.
move: (order_function_osr (substrate r) or'(erefl (substrate r'))) => [pa pb].
have pc: sub (increasing_mappings r r')
(substrate (order_function (substrate r) (substrate r') r')).
rewrite pb; apply: Zo_S.
exact: (iorder_osr pa pc).
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; split => //; move: (iorder_gle1 le1).
by move /graph_on_P1 => [_ _].
move=> [h1 h2 h3]; apply /iorder_gleP => //; apply /graph_on_P1.
move: h1 h2 => /Zo_S h1 /Zo_S h2; split => //.
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'').
Lemma Exercise1_6d f:
increasing_fun f r (order_product2 r' r'') ->
(increasing_fun (first_projection f (substrate r) (substrate r')) r r' /\
increasing_fun (secnd_projection f (substrate r) (substrate r'')) r r'').
Proof.
move=> [_ op [ff sr sor] icf].
rewrite order_product2_sr // in sor.
move: (Exercise1_6a ff sr sor);move=> [taP taQ fP fQ [WP WQ]].
rewrite /increasing_fun; split => //.
rewrite /first_projection; aw; split => //.
by split; aw.
move=> x y xy; aw; try order_tac.
by move: (icf _ _ xy) => /order_product2_P [_ _ ][].
rewrite /secnd_projection; aw; 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 (substrate r) (substrate r')(substrate r''))
(increasing_mappings r (order_product2 r' r''))
((increasing_mappings r r') \times
(increasing_mappings r r''))).
Proof.
move: (Exercise1_6c (substrate r) (substrate r') (substrate r'')) => bt.
move: (Exercise1_6b (a:=substrate r)(b:=substrate r') (c:=substrate r'')) => t1.
split => //.
fct_tac.
rewrite /two_projections lf_source /increasing_mappings.
rewrite order_product2_sr //; apply: Zo_S.
rewrite /two_projections /two_projections /increasing_mappings;aw.
apply: setX_Slr; apply: Zo_S.
move: (bij_function bt) => ff.
have pa: (sub (increasing_mappings r (order_product2 r' r''))
(source (two_projections (substrate r) (substrate r') (substrate r'')))).
move => t; rewrite /two_projections; aw; move /Zo_P => []; aw.
by rewrite order_product2_sr.
move=> t /(Vf_image_P ff pa) [u us ->].
move: us => /Zo_P; rewrite order_product2_sr //.
move=> [aux]; move: (aux) => /fun_set_P [fu su tu].
move: (Exercise1_6a fu su tu) => [_ _ p1 p2 _] uinc.
move: (Exercise1_6d uinc) => [i1 i2].
rewrite - /two_projections lf_V //; apply: setXp_i => //;
apply : Zo_i => //; apply /fun_set_P;split => //;
rewrite /first_projection/secnd_projection; aw.
Qed.
Lemma Exercise1_6f: bijection (two_projections_increasing r r' r'').
Proof.
move: (Exercise1_6e) => ra.
move: (Exercise1_6c (substrate r) (substrate r') (substrate r'')) => [fi fs].
have tpi:injection (two_projections_increasing r r' r'')
by rewrite /two_projections_increasing; apply: restriction2_fi.
split; first by exact.
split; first by fct_tac.
move: ra => [ftp sstp sttp saux].
rewrite {1} /two_projections_increasing /restriction2 corresp_t=> y yt.
move: (sttp _ yt) => yt1.
move: ((proj2 fs) _ yt1) => [x xs wx].
suff xs1: (inc x (increasing_mappings r (order_product2 r' r''))).
rewrite /two_projections_increasing;exists x.
rewrite /restriction2 corresp_s //.
rewrite restriction2_V //.
move: xs; rewrite/two_projections lf_source => xsf.
apply: Zo_i => //; first by rewrite order_product2_sr.
move: (xsf) => /fun_set_P [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 (substrate r)) by order_tac.
have vs: (inc v (substrate r)) by order_tac.
rewrite -tx.
split; first by Wtac.
Wtac.
move: (Exercise1_6b (a:=substrate r)(b:=substrate r') (c:=substrate r'')) => 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; [ 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 => //.
apply: Exercise1_6f => //.
rewrite /two_projections_increasing /restriction2 sr3; aw.
rewrite order_product2_sr // sr1 sr2.
rewrite /two_projections_increasing /restriction2; aw.
move=> x y.
rewrite corresp_s => xsi ysi.
move: (xsi) (ysi)=> /(soimP) [[fx sx tx] ix] /(soimP) [[fy sy ty] iy].
move: (Exercise1_6b (a:=substrate r) (b:=substrate r')(c:=substrate r'')) => 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 => [ftp sstp sttp saux].
move: sstp; rewrite {1} /two_projections lf_source => sstp'.
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 (substrate r) (substrate r')).
set (f2 := secnd_projection x (substrate r) (substrate r'')).
set (f3 := first_projection y (substrate r) (substrate r')).
set (f4 := secnd_projection y (substrate r) (substrate r'')).
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 //.
split; first by Wtac.
Wtac.
rewrite -(q5 _ isr) - (q6 _ isr) -(p5 _ isr) - (p6 _ isr).
move: if13 if24 => [_ _ s1] [_ _ s2].
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 = substrate r) by rewrite /f1 /first_projection; aw.
have sf2: (source f2 = substrate r) by rewrite /f2 /secnd_projection; aw.
have sf3: (source f3 = substrate r) by rewrite /f3 /first_projection; aw.
have sf4: (source f4 = substrate r) by rewrite /f4 /secnd_projection; aw.
have tf1: (target f1 = substrate r') by rewrite /f1 /first_projection; aw.
have tf2: (target f2 = substrate r'') by rewrite /f2 /secnd_projection; aw.
have tf3: (target f3 = substrate r') by rewrite /f3 /first_projection; aw.
have tf4: (target f4 = substrate r'') 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; first 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 (substrate r) -> nonempty (substrate r') ->
increasing_fun f (order_product2 r r') r'' ->
( (domain (source f)) = substrate r /\ (range (source f)) = substrate r').
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 (substrate r) -> nonempty (substrate r') ->
increasing_fun f (order_product2 r r') r'' ->
inc x (substrate r) -> 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).
split; [ exact |rewrite sf ; by exists (substrate r); exists (substrate r')].
move: (xsr);rewrite -dsf; move => xsr'.
move: (spf_f pfa xsr') => spf.
split => //.
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; order_tac.
have vr: inc v (range (source f)) by rewrite rsf; order_tac.
rewrite spf_V // spf_V //; apply: incf.
apply/order_product2_P; aw; rewrite - sf;split => //; split => //.
order_tac; ue.
Qed.
Lemma Exercise1_6j f:
nonempty (substrate r) -> nonempty (substrate r') ->
increasing_fun f (order_product2 r r') r'' ->
(restriction2_axioms (second_partial_function f) (substrate r)
(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).
split; [ exact |rewrite sf ; by exists (substrate r); exists (substrate r')].
move: (spfa_f pfa) => spfa.
split => //.
rewrite /second_partial_fun /second_partial_function; aw.
rewrite dsf; fprops.
rewrite /second_partial_fun /second_partial_function; aw.
rewrite rsf /increasing_mappings -tf; apply: Zo_S.
have aa: sub (substrate r) (source (second_partial_function f)).
rewrite /second_partial_function; aw; rewrite dsf; fprops.
move=> t /(Vf_image_P spfa aa) [x xsr ->].
move: (xsr);rewrite -dsf; move => xsr'.
move: (spf_f pfa xsr') => spf.
rewrite /second_partial_function; aw; last by apply: spfa_axiom.
apply /soimP; split.
split => //; rewrite /second_partial_fun; aw => //.
exact: (Exercise1_6i ne1 ne2 incf xsr).
Qed.
Lemma Exercise1_6k:
nonempty (substrate r) -> nonempty (substrate r') ->
lf_axiom (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'')).
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).
split; [ exact |rewrite st; by exists (substrate r); exists (substrate r')].
set g:= restriction2 _ _ _.
have fg: function g by rewrite /g; apply: (proj31(restriction2_prop ra)).
have sg: source g = substrate r by rewrite /g /restriction2; aw.
have tg: target g = substrate (increasing_mappings_order r' r'').
by rewrite sr2 /g /restriction2; aw.
apply /soimP; split => //; split => //.
move => x y xy.
have xsr: (inc x (substrate r)) by order_tac.
have ysr: (inc y (substrate r)) by 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].
rewrite /order_function_r; split => //.
apply /soimP; split => //.
apply /soimP; split => //.
split => //.
rewrite - 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 (substrate r) -> nonempty (substrate r') ->
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;red; aw;split => //.
have op: order (order_product2 r r') by apply: order_product2_or.
move: (order_product2_sr or or') => sop.
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 => su sv x xsu.
have pfau: (partial_fun_axiom u).
split;[exact |rewrite su; by exists (substrate r); exists (substrate r')].
have pfav: (partial_fun_axiom v).
split;[exact |rewrite sv; by exists (substrate r); exists (substrate r')].
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 {1} /second_partial_function lf_source dsu=> au.
transitivity (Vf (restriction2 (second_partial_function u) (substrate r)
(increasing_mappings r' r'')) a).
rewrite restriction2_V //; apply: Exercise1_6j => //.
rewrite sr 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; move => <- <-.
rewrite dsu -dsv in Ps; rewrite rsu -rsv in Qr.
move: (spfa_V pfav Ps) (spf_V pfav Ps Qr); rewrite px; move => <- <-.
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) )
((substrate r) \times (substrate r')) (substrate r'')).
move => t /setX_P; rewrite - sy; move=> [prt Pt Qt].
move: (Vf_target fy Pt); rewrite ty sr2 //.
move /soimP => [[fw sw tw] _].
rewrite -tw; Wtac.
set (g:= Lf (fun z => Vf (Vf y (P z)) (Q z) )
((substrate r) \times (substrate r')) (substrate r'')).
have fg: function g by rewrite /g; 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 = ((substrate r) \times (substrate r')) by rewrite /g;aw.
have sg1: (range (source g) = substrate r') by rewrite sg ; bw.
have tg: target g = substrate r'' by rewrite /g;aw.
have pfa: (partial_fun_axiom g).
split;[exact |rewrite sg; by exists (substrate r); exists (substrate r')].
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 xdg: inc x (domain (source g)) by rewrite sg (setX_domain _ ne2) - sy.
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; move=> isf.
rewrite - sg sg1 lf_V //; last by ue.
rewrite /g lf_V //;aw; apply /setXp_i => //; ue.
move=> t; move=> tr ; rewrite tg /g;rewrite lf_V //; aw.
rewrite -tw; apply: Vf_target =>//; rewrite sw //.
apply /setXp_i => //; ue.
Qed.
Lemma Exercise1_6m:
nonempty (substrate r) -> nonempty (substrate r') ->
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).
simpl; set f := (second_partial_map2 r r' r''); move=> [bf sf tf].
move:(Exercise1_6k ne1 ne2) => ta.
move: (imo_osr r' or'') => [o2 sr2].
have o3:order (order_product2 r r') by apply: order_product2_or.
move: (imo_osr (order_product2 r r') or'') => [o2' sr2'].
move: (imo_osr r o2) => [o2'' sr2''].
split => //.
rewrite sr2' sr2'';split => //.
move=> x y xsf ysf.
move: (order_product2_sr or or') => sop.
move: (xsf) (ysf); rewrite sf; move /soimP => [[fx sx tx] ix].
move /soimP => [[fy sy ty] iy].
have pfx: (partial_fun_axiom x).
split;[exact |rewrite sx; by exists (substrate r); exists (substrate r')].
have pfy: (partial_fun_axiom y).
split;[exact |rewrite sy; by exists (substrate r); exists (substrate r')].
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'').
move: (Exercise1_6i ne1 ne2 ix isr) => in1.
move: (Exercise1_6i ne1 ne2 iy isr) => in2.
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.
have ->: (i = J (P i) (Q i)) by 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 (substrate r) /\nonempty (substrate r'))).
move => [pa pb]; exists (second_partial_map2 r r' r'').
by apply: Exercise1_6m.
move => H.
have esa: (substrate r \times substrate r') = emptyset.
case: (emptyset_dichot (substrate r)); first by move => ->; rewrite setX_0l.
case: (emptyset_dichot (substrate r'));first by move => ->; rewrite setX_0r.
move => n1 n2; case: H; split => //.
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.
move: (imo_osr r' or'') => [];
set r2 := (increasing_mappings_order r' r'') => or2 sr2.
move: (imo_osr r3 or'') => [or4 sr4].
move: (imo_osr r or3) => [or5 sr5].
move: (imo_osr r or2) =>[or6 sr6].
have ssa: forall a,
functions emptyset a = singleton (empty_function_tg a).
move => a; move: (empty_function_tg_function a) => h.
apply: set1_pr; first by apply /fun_set_P.
move: h => [fa sa ta].
move => z /fun_set_P [ft st tt]; apply: function_exten => //; try ue.
by rewrite st => x /in_set0.
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 move /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 (substrate r'')); move => ssrc.
have si: singletonp (substrate (increasing_mappings_order r r2)).
case: (emptyset_dichot (substrate r)) => h.
rewrite (ssb _ _ or or2 h).
by exists (empty_function_tg (substrate r2)).
case: (emptyset_dichot (substrate r')) => h1; last by case: H;split => //.
rewrite sr6.
move: (ssb _ _ or' or'' h1).
set f1:= (empty_function_tg (substrate r'')) => sr2'.
rewrite /increasing_mappings.
set f := Lf (fun _ => f1) (substrate r) (substrate r2).
have ta: lf_axiom (fun _ => f1) (substrate r) (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/fun_set_P;split => //;aw.
split => //; first by split; aw.
move => x y lexy; aw; order_tac;rewrite sr2'; fprops.
move =>t /Zo_P [] /fun_set_P [ft st tt] _; rewrite /f.
apply: function_exten; aw; 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 _ : Set => w) (singleton f0) (singleton w).
move => t _ /=; fprops.
set f := Lf (fun z => w) (singleton f0)( singleton w).
have bf: bijection f.
apply: lf_bijective => //.
by move => u v /set1_P -> /set1_P ->.
move => y /set1_P ->; exists f0;fprops.
exists f;red; split => //.
rewrite ssrc ws /f; split => //; aw.
move => x y; rewrite lf_source; move => pa pb; aw.
move: pa pb => /set1_P -> /set1_P ->;split => h; order_tac.
rewrite /f ws; aw;fprops.
rewrite /f 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 (Hy: inc y (substrate r')):
(inc (constant_function (substrate r) Hy)
(increasing_mappings r r')).
Proof.
apply /soimP; rewrite /constant_function;split; aw.
split;aw; fprops.
split => //; first by split;aw; fprops.
move => u v uv; rewrite constant_V; last by order_tac.
by rewrite constant_V; order_tac.
Qed.
Lemma constant_increasing1:
nonempty (substrate r) ->
forall y (Hy: inc y (substrate r')) y' (Hy': inc y' (substrate r')),
gle r' y y' <->
gle (increasing_mappings_order r r')
(constant_function (substrate r) Hy)
(constant_function (substrate r) Hy').
Proof.
move=> [u usr] y ysr y' ysr'.
split.
move=> yy'; apply /imo_gleP => //;split => //;try apply: constant_increasing.
rewrite /constant_function;split.
by split; aw;fprops.
by split; aw;fprops.
by move => i isr; rewrite ! constant_V.
by move => h; move: (imo_incr or' h usr); rewrite !constant_V.
Qed.
Lemma Exercise1_6n: nonempty (substrate r) ->
(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].
set (E:=substrate r) in *; set (E':=substrate r') in *.
have ta1: (lf_axiom (fun i=> sup r' (Vf x i) (Vf y i)) E E').
move => c cE.
have w1: (inc (Vf x c) E') by rewrite -tx; apply: Vf_target =>//; ue.
have w2: (inc (Vf y c) E') by rewrite -ty; apply: Vf_target =>//; ue.
move: (lattice_sup_pr sl w1 w2)=> [aux _ _]; rewrite /E'; order_tac.
have ta2: (lf_axiom (fun i=> inf r' (Vf x i) (Vf y i)) E E').
move => c cE.
have w1: (inc (Vf x c) E') by rewrite -tx; apply: Vf_target =>//; ue.
have w2: (inc (Vf y c) E') by rewrite -ty; apply: Vf_target =>//; ue.
move: (lattice_inf_pr sl w1 w2)=> [aux _ _]; rewrite /E'; order_tac.
set (f1:= Lf (fun i=> sup r' (Vf x i) (Vf y i)) E E').
set (f2:= Lf (fun i=> inf r' (Vf x i) (Vf y i)) E E').
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(substrate r)(substrate r')by rewrite/f1; split; aw.
have fp2: function_prop f2(substrate r)(substrate r')by rewrite/f2; split; aw.
have if1:increasing_fun f1 r r'.
split => //; rewrite /f1; 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.
have uxE: (inc (Vf x u) E') by rewrite -tx; Wtac.
have uyE: (inc (Vf y u) E') by rewrite -ty; Wtac.
have vxE: (inc (Vf x v) E') by rewrite -tx; Wtac.
have vyE: (inc (Vf y v) E') by rewrite -ty; Wtac.
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.
have uxE: (inc (Vf x u) E') by rewrite -tx; Wtac.
have uyE: (inc (Vf y u) E') by rewrite -ty; Wtac.
have vxE: (inc (Vf x v) E') by rewrite -tx; Wtac.
have vyE: (inc (Vf y v) E') by rewrite -ty; Wtac.
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 //.
have wxe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have wye: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
by case: (lattice_sup_pr sl wxe wye).
split => //.
rewrite /f1; move => i isr; rewrite lf_V //.
have wxe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have wye: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
by move: (lattice_sup_pr sl wxe wye) => [_].
move=> z [z1 z2].
have xd: (inc x (doubleton x y)) by fprops.
have yd: (inc y (doubleton x y)) by fprops.
move: (imo_incr or' (z2 _ xd)) => inx.
move: (z2 _ yd) => /(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.
have xwe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have ywe: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
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. rewrite -/f2.
move => i isr; rewrite lf_V //.
have wxe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have wye: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
by case: (lattice_inf_pr sl wxe wye).
rewrite /f2;split => //; aw; move => i isr; rewrite lf_V //.
have wxe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have wye: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
by move: (lattice_inf_pr sl wxe wye) => [_].
move=> z [z1 z2].
have xd: (inc x (doubleton x y)) by fprops.
have yd: (inc y (doubleton x y)) by fprops.
move: (imo_incr or' (z2 _ xd)) => inx.
move: (z2 _ yd) => /(imo_gleP _ or') [p1 p2 [p3 p4 p5]].
rewrite /f2; apply /(imo_gleP _ or');split => //; split => //; aw.
move=> i isr; rewrite lf_V => //.
move: (inx _ isr) (p5 _ isr) => r1 r2.
have xwe: (inc (Vf x i) E') by rewrite -tx; Wtac; ue.
have ywe: (inc (Vf y i) E') by rewrite -ty; Wtac; ue.
by move: (lattice_inf_pr sl xwe ywe)=> [r3 r4 r5]; apply: r5.
move=> sl; split; first by exact.
move=> x y xsr ysr.
set (E:=substrate r) ; set (E':=substrate r').
set (f1:= constant_function E xsr).
set (f2:= constant_function E ysr).
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').
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 E') by rewrite /z/E' -ts; Wtac.
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 usr).
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/E'- constant_increasing1 //; apply: um; fprops.
have f24: (gle (increasing_mappings_order r r') f2 f4).
rewrite /f1/f4 /E/E'- 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 E') by rewrite /z/E' -ts; Wtac.
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 usr).
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/E'- constant_increasing1 //; apply: um; fprops.
have f24: (gle (increasing_mappings_order r r') f4 f2).
rewrite /f1/f4 /E/E'- 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 (substrate r)->
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 (substrate r') ->
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.
set (F := (substrate r')) in *.
have w1: (inc (Vf x i) F) by rewrite -tx; Wtac; ue.
have w2: (inc (Vf y i) F) by rewrite -ty; Wtac; ue.
by rewrite (s _ _ w1 w2); order_tac.
Qed.
Lemma Exercise1_6q:
singletonp (substrate r) -> 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 sr=> sx' sy'.
have w1:(inc (Vf x s)(substrate r')) by rewrite -tx; Wtac; ue.
have w2:(inc (Vf y s)(substrate r')) by rewrite -ty; Wtac; ue.
case: (torf _ _ w1 w2) => h; [left | right ];
by apply /imo_gleP => //;split => //; split => // i isr;
move: isr; rewrite sr => /set1_P ->.
Qed.
Lemma Exercise1_6r:
total_order r -> total_order r' ->
(exists a b, substrate r' = doubleton a b) ->
total_order (increasing_mappings_order r r').
Proof.
move=> [_ tor] [_ tor'] [u [v sr']].
set (E := substrate r').
case: (equal_or_not u v) => uv.
apply: Exercise1_6p => //; rewrite sr' -uv; exists u;split => //.
have [a [b [ab ltab]]]: exists a, exists b, E = doubleton a b /\ glt r' a b.
have ap: (inc u E) by rewrite /E sr'; fprops.
have bp: (inc v E) by rewrite /E 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].
have asr: inc a (substrate r') by order_tac.
have bsr: inc b (substrate r') by order_tac.
split => //.
rewrite pb1; move=> x y xs ys; rewrite /ocomparable.
move: (xs)(ys) => /soimP [[fx sx tx] ix] /soimP [[fy sy ty] iy].
have aux: (forall t, inc t (substrate r) -> glt r' (Vf x t) (Vf y t) ->
(Vf x t = a /\ Vf y t =b)).
move=> t tsr wt.
move: (wt).
have: inc (Vf x t) (substrate r') by order_tac.
have : inc (Vf y t) (substrate r') by order_tac.
rewrite -/E ab; case /set2_P => ->.
case /set2_P => pa; first by move => [_]; case.
rewrite pa; move => [pb _]; order_tac.
by case /set2_P => ->; [ move => _; split | move => [_]; case ].
case: (p_or_not_p (exists u, inc u (substrate r)/\ glt r' (Vf x u) (Vf y u))).
move=> [u [usr uwy]]; left.
apply /imo_gleP => //; split => //; split => // i isr.
have: (inc (Vf x i) E) by rewrite /E -tx; Wtac.
have: (inc (Vf y i) E) by rewrite /E -ty; Wtac.
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.
have xw: (inc (Vf x i) E) by rewrite /E -tx;Wtac.
have yw: (inc (Vf y i) E) by rewrite /E -ty;Wtac.
case: (tor' _ _ xw yw) => //.
case: (equal_or_not (Vf x i) (Vf y i)) =>sw; first by rewrite sw.
move=> nle; case: neu; exists i;split => //; split => //.
Qed.
Lemma Exercise1_6s:
nonempty(substrate r) -> nonempty (substrate r') ->
(total_order (increasing_mappings_order r r') <->
[\/ singletonp (substrate r'),
(singletonp (substrate r) /\ total_order r') |
[/\ total_order r', total_order r &
exists u v, substrate r' = 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''].
set F := substrate r'.
set E := substrate r.
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; exists y'; split => //; split => //; apply:nesym.
rewrite /glt;move => aux; exists y'; exists 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) (substrate r) (substrate r'))
(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 (substrate r)) by order_tac.
have vs: (inc v (substrate r)) by 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 (substrate r') (doubleton a b)) => //.
by move=> h; exists a;exists 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 (substrate r'), inc v (substrate r'), inc w (substrate r') ,
glt r' u v & glt r' v w]).
move: at3 => [c [cF ca cb]]; case: (tor'' _ _ cF aF)=> lca.
exists c; exists a; exists 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) vF).
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')); move=> 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 :=
Sgraph (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 _].
split => //.
- by apply: equivalence_Sgraph.
- by apply: substrate_Sgraph.
- 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 [zs 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 [zs 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) => //.
apply: symmetricity_e => //.
Qed.
Lemma Exercise1_7c r r' f x y: increasing_fun f r r' ->
decreasing_fun f r r' -> ocomparable r x y ->
Vf f x = Vf f y.
Proof.
move=> [or or' [ff sr sr'] incf][_ _ _ decf].
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].
have sw: (forall x y, ocomparable r x y -> Vf f x = Vf f y).
move=> u v uv; apply: (Exercise1_7c incf decf uv).
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 <- <-]].
move: c h1; elim; first by move => a b; simpl; apply: sw.
by move=> a c; simpl; move => xx [yy zz]; rewrite -(xx zz); apply: sw.
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].
set (f:= (fun 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: forall y, inc y (substrate r) -> ~(inc y (cr_component r x))
-> Vf g y = v.
by move=> y 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 //.
move: xA yA => / Zo_hi r1 /Zo_hi r2.
by rewrite -{2} r1 -{2} r2; move=> ->.
have sh: (surjection h).
split => //; rewrite Ha Hb; move=> y yB.
move: (p2 _ yB) => wA.
exists (Vf g y) => //; 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.
Lemma lattice_finite_sup4P f y:
fgraph f -> finite_set (domain f) -> nonempty (domain f) ->
sub (range f) (substrate r) ->
(gle r(sup_graph r f) y <-> (forall z, inc z (domain f) -> gle r (Vg f z) y)).
Proof.
move=> fgf fsd ned srf.
have ne: nonempty (range f) by move: ned => [x xd]; exists (Vg f x); fprops.
have fr: finite_set (range f) by apply: finite_range.
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 y:
fgraph f -> finite_set (domain f) -> nonempty (domain f) ->
sub (range f) (substrate r) ->
(gle r y (inf_graph r f) <-> (forall z, inc z (domain f) -> gle r y (Vg f z))).
Proof.
move=> fgf fsd ned srf.
have ne: nonempty (range f) by move: ned => [x xd]; exists (Vg f x); fprops.
have fr: finite_set (range f) by apply: finite_range.
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:
fgraph f -> finite_set (domain f) -> nonempty (domain f) ->
sub (range f) (substrate r) ->
inc (sup_graph r f) (substrate r).
Proof.
move=> fgf fsd ned srf.
have aux: (has_sup_graph r f).
rewrite /has_sup_graph; apply: lattice_finite_sup2 => //.
by apply: finite_range.
move: ned => [x xd]; exists (Vg f x); fprops.
move: lr => [or _];move: (is_sup_graph_pr1 or srf aux).
by move /(lubP or srf) => [[pa _] _].
Qed.
Lemma lattice_finite_inf5 f:
fgraph f -> finite_set (domain f) -> nonempty (domain f) ->
sub (range f) (substrate r) ->
inc (inf_graph r f) (substrate r).
Proof.
move=> fgf fsd ned srf.
have aux: (has_inf_graph r f).
rewrite /has_inf_graph; apply: lattice_finite_inf2 => //.
by apply: finite_range.
move: ned => [x xd]; exists (Vg f x); fprops.
move: lr => [or _];move: (is_inf_graph_pr1 or srf aux).
by move /(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.
apply /lattice_finite_sup4P; bw; fprops.
move=>t /Lg_range_P[b bi2] ->; apply: lattice_finite_inf5 => //; bw; fprops.
by move=>t' /Lg_range_P [b' bi1'] ->; apply: hb.
move => z zI;apply/lattice_finite_inf4P; fprops; bw.
move=>t/Lg_range_P [b bi2] ->; apply: lattice_finite_sup5 => //; bw; fprops.
by move=>t' /Lg_range_P [b' bi1'] ->; apply: hb.
move=> t tI; bw.
apply: (@order_transitivity _ _ (Vg f (J t z))) => //.
set (fa:= (Lg I1 (fun i : Set => Vg f (J i z)))).
have fga: (fgraph fa) by rewrite /fa;fprops.
have fsa: (finite_set (domain fa)) by rewrite /fa; bw.
have nea:(nonempty (domain fa)) by rewrite /fa; bw.
have sra: (sub (range fa) (substrate r)).
by rewrite /fa => y /Lg_range_P;move=> [x xI1] ->; bw; apply: hb.
have : (gle r (inf_graph r fa) (inf_graph r fa)).
by order_tac; apply: lattice_finite_inf5.
rewrite (lattice_finite_inf4P (inf_graph r fa) fga fsa nea sra).
have ->: (Vg f (J t z) = Vg fa t) by rewrite /fa; bw.
apply; rewrite /fa; bw.
set (fb:= Lg I2 (fun j => Vg f (J t j))).
have fgb:(fgraph fb) by rewrite /fb; fprops.
have fsb: (finite_set (domain fb)) by rewrite /fb; bw.
have neb: (nonempty (domain fb)) by rewrite /fb; bw.
have srb: (sub (range fb) (substrate r)).
by rewrite /fb => y /Lg_range_P [x xI1] ->; bw; apply: hb.
have : (gle r (sup_graph r fb) (sup_graph r fb)).
by order_tac; apply: lattice_finite_sup5.
move /(lattice_finite_sup4P (sup_graph r fb) fgb fsb neb srb).
have ->: (Vg f (J t z) = Vg fb z) by rewrite /fb; 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 f -> substrate r = source f ->
substrate r' = target f ->
((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 f -> substrate r = source f ->
substrate r' = target f ->
((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.
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 (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 Bnat_order Bnat_order)
(r':= Bnat_order)
(f := Lf (fun z => (P z) +c (Q z)) (Bnat \times Bnat) Bnat):
Exercise1_10_counterexample r r' f.
Proof.
move:Bnat_order_wor=> [pa sr'].
have l1: lattice Bnat_order.
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 => (P z) +c (Q z))(Bnat \times Bnat) Bnat.
move => z /setX_P [_ p1 p2]; fprops.
have sr: substrate r = Bnat \times Bnat.
by rewrite order_product2_sr// -/r' sr'.
have ff: function f by apply: lf_function.
have pb:function_prop f (substrate r) (substrate r').
by rewrite /f; split;aw.
rewrite /f;split => //.
split => // x y.
move /order_product2_P ; rewrite -/r' sr'; move=> [xp yp [le1 le2]].
rewrite lf_V // lf_V //.
move: le1 le2 => /Bnat_order_leP [p1 p2 p3] /Bnat_order_leP [p4 p5 p6].
by apply /Bnat_order_leP;split => //; fprops; apply: csum_Mlele.
set a := (J \1c \0c); set b:= (J \0c \1c).
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 _ []] _ /Bnat_order_leP [_ _ p1].
move => /order_product2_P [_ _ []] /Bnat_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.
move: (card_le0 p1) (card_le0 p2) => -> -> cv.
have cp: inc c (substrate r) by rewrite cv sr; apply /setX_P; aw;split;fprops.
have c1: cardinalp \1c by fprops.
have c0: cardinalp \0c by fprops.
move: csr; rewrite sr' => csr.
exists a; exists b; split => //; rewrite -/c (lf_V ta csr) cv.
have ap: inc a (Bnat \times Bnat) by ue.
have bp: inc b (Bnat \times Bnat) by ue.
rewrite (lf_V ta bp) (lf_V ta ap) !pr1_pair ! pr2_pair.
rewrite (csum0r c0) (csum0r c1) (csum0l c1).
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; first move => [-> _].
move: r4 => /cdo_gleP; case;first move => [-> _] //.
by move => [_]; rewrite /b; aw => sv; case: TP_ne.
by move => [_]; rewrite /b; aw => sv; case: TP_ne.
by move => [_]; rewrite /a; aw => sv; case: TP_ne.
by move => [_]; rewrite /a; aw => sv; case: TP_ne.
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; last first.
by move => [_]; rewrite ym; aw => eq; case: TP_ne.
by move => [_]; rewrite ym; aw => eq; case: TP_ne.
move => [-> _].
move: le2 => /cdo_gleP; case; first by move => [-> _].
by move => [_]; rewrite ym; aw => eq; case: TP_ne.
by move => [_]; rewrite ym; aw => eq; case: TP_ne.
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
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 ->
((exists a, greatest r a) /\ (exists b, least r b)).
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) (fun z => lower_bound r X z))).
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 [_ [_ ok]]; apply: ok.
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) (fun z => upper_bound r X z))).
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 [_ ok]; apply: ok.
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 sb]; apply: sb.
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=> poa ala.
move: (order_product_osr poa) => [og Ha].
apply: Exercise1_11b => //.
move:(poa) => alo.
move=> 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.
set (Xi := fun i=> (image_by_fun (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: (order_product_osr poa) => [og Ha].
move: (Exercise1_11a clp)=> [[a [asg _]] _].
move: (asg); rewrite Ha => /prod_of_substratesP [fgfa da vas].
move: poa clp => p2 [p3 p4].
move: (p2 _ idg) => o1.
apply: Exercise1_11b => //.
move=> 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.
rewrite /fam_of_substrates; fprops.
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: (p2 _ 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) ->
exists v, least (Vg g (supremum r j)) v),
(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) ->
~ (exists u, greatest (Vg g i) u ) ->
exists v, least_induced r (Zo (substrate r) (fun j =>
glt r i j)) v /\
exists w, least (Vg g v) w)]).
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.
set k:= fun 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] _ ].
exists x; split => //.
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.
split; first (by exact); apply /(lubP or jE); split.
split.
by move: (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.
have up1: (upper_bound (order_sum r g) Y (J (k z) z)).
split; first 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.
move: (orsum_gle_id oa (lux _ up1)); aw.
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; first (by 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; first by 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; first by 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.
move: (xleb _ sz1) => /orsum_gleP [_ _]; case => [][];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; first (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.
move: (xu _ pX) => /orsum_gleP [_ _]; case => [][]; 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.
apply /iorder_gleP => //.
exists (P x); split; first by 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 [_ _]; case => [][];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; first (by 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; first by (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 kg] _; move: kg; 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; first (by 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 => [] //.
move: (iorder_gle1 (vg _ Qzk)) => aux.
case:(equal_or_not v (Q z))=> h4;first by 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 (XE' y Hy))).
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' -tf; apply: Vf_target => //; ue.
exists u; apply /(lubP or' XE'); split.
split => //.
move=> y yE.
set (g:= constant_function E (XE' y yE)).
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') [_ _].
move=> [[p1 p2 p3] [p4 p5 p6] p7] ; move: (p7 _ xE).
rewrite /g constant_V //.
move=> z [zs zu].
set (g:= (constant_function E zs)).
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]]].
rewrite -/g yc - constant_increasing1//; apply: zu => //.
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 => //.
by move: clr => [_ aux]; move: (aux _ (se _ xE)) => [ok _].
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.
move=> x y xy.
have xE: inc x E by rewrite /E; order_tac.
have yE: inc y E by rewrite /E; order_tac.
rewrite /f lf_V // lf_V //.
move: (se _ xE) (se _ yE) => a1 a2.
move: (fp1 _ xE) (fp1 _ yE) => /(lubP or' a1) [p1 p2] /(lubP or' a2)[p3 p4].
move: p3 => [h1 h2].
apply: p2; split=>//; move=> t /funI_P [z zX ->].
set (w:= Vf z y).
have wi: (inc w (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.
move=> zs zu; apply /imo_gleP => //; split => //.
move:zs => /soimP [fpy incy]; split => //.
move=> 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 :(proj1 (clr _ xsr)) => hs; move: (supremum_pr1 or hs).
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: (proj2 (clr _ bsr))=> hs1; move: (infimum_pr1 or hs1).
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 (image_by_fun f X) X))).
Proof.
move=> ff sf tf; set F:=Zo _ _.
move: (sub_osr F) => [or sra].
apply: Exercise1_11b =>//.
move=> 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 invariants f := Zo (source f) (fun x => Vf f x = 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.
move=> p7 p8; order_tac.
order_tac.
Qed.
Lemma Exercise1_13c E: complete_lattice r ->
let F := invariants f in
sub E F -> inc (infimum r E) F.
Proof.
move: cf=> [icf c2 c3] [_ lr] F 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:
let F := invariants f in
inc x (source f) ->
least (induced_order r (upper_bounds F r x)) (Vf f x).
Proof.
move: cf => [icf c1 c2] F 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) -> exists y,
least (induced_order r (upper_bounds G r x)) y) ->
(closure (Lf g (substrate r) (substrate r)) r /\
(G = invariants (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); move: (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.13. 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 (compose fs 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 (compose fr 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 => //; move=> y /set1_P ->; order_tac.
red; rewrite sr; split => //.
move=> x xr; apply /sub_gleP;split => // =>s; move /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:
~ (exists e, least r e) ->
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 => //; move=> x xsr;apply /sub_gleP;split;fprops.
Qed.
Lemma Exercise1_15a12 : exists x, least (completion_order r) x.
Proof.
case: (p_or_not_p (exists e, least r e)).
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 _)).
split => //; move=> x xr.
by 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.
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 ->; rewrite /v //.
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 _)).
apply: Exercise1_15a8.
by 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; first (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.
by move: (aux _ _ _ xc zx ctz).
apply: (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 := Bint_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 (image_by_fun 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.
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.
by move => te; apply /(substrate_P gr1); left;exists t; apply: r1_refl.
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: BS2 => bs2.
move: card_lt_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 => ->; first by right; fprops.
right; fprops.
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 [] // tz;
[by case: ta; ue | by case: tb; rewrite - {1} tz].
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 [] // tz; [ 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(Binto_wor \0c \2c)); apply: worder_total.
move: (proj1 tor2) => or2.
have sr2': Bintcc \0c \2c = E.
set_extens t.
move /(BintcP BS2)=> ts.
case: (equal_or_not t \2c) => nt2; first by rewrite nt2.
by case: (card_lt2 (conj ts nt2)) => ->.
move => h; apply /(BintcP BS2).
case/set3_P: h => ->; fprops.
have sr2: substrate r2 = E by rewrite (proj2(Binto_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: (Binto_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_Bintcc.
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: card_leR; 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: (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 ->: (image_by_fun 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.
have ->: supremum (completion_order r1) Z = E.
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: (zb _ (set2_1 s0 s1)).
move /sub_gleP => [_ _ ta].
move: (zb _ (set2_2 s0 s1)).
move /sub_gleP => [_ _ 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.
by rewrite -g2 => bad; move: (proj2 lt12) => b2; case: b2.
Qed.
Exercise 1.16. Distributive lattice. There are alternate definitions
Definition distributive_lattice1 r :=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
sup r x (inf r y z) = inf r (sup r x y) (sup r x z).
Definition distributive_lattice2 r :=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
inf r x (sup r y z) = sup r (inf r x y) (inf r x z).
Definition distributive_lattice3 r :=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
sup r (inf r x y) (sup r (inf r y z) (inf r z x)) =
inf r (sup r x y) (inf r (sup r y z) (sup r z x)).
Definition distributive_lattice4 r :=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
gle r z x -> sup r z (inf r x y) = inf r x (sup r y z).
Definition distributive_lattice5 r:=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
gle r (inf r z (sup r x y)) (sup r x (inf r y z)).
Definition distributive_lattice6 r :=
forall x y z, inc x (substrate r) ->inc y (substrate r) ->
inc z (substrate r) ->
inf r (sup r x y) (sup r z (inf r x y))
= sup r (inf r x y) (sup r (inf r y z) (inf r z x)).
Lemma total_order_dlattice r:
total_order r -> distributive_lattice1 r.
Proof.
move=> [or tor] a b c ar br cr.
case: (tor _ _ ar br) => ab.
rewrite (sup_comparable1 or ab); case: (tor _ _ ar cr) => ac.
rewrite (sup_comparable1 or ac); case: (tor _ _ br cr) => bc.
by rewrite (inf_comparable1 or bc) (sup_comparable1 or ab).
by rewrite(inf_C r b c) (inf_comparable1 or bc)(sup_comparable1 or ac).
rewrite (sup_C r a c)(sup_comparable1 or ac).
rewrite (inf_C r b a) (inf_comparable1 or ab).
have cb: (gle r c b) by order_tac.
rewrite (inf_C r b c) (inf_comparable1 or cb).
by rewrite (sup_C r a c) (sup_comparable1 or ac).
rewrite (sup_C r a b) (sup_comparable1 or ab).
case: (tor _ _ ar cr) => ac.
rewrite (sup_comparable1 or ac) (inf_comparable1 or ac).
have bc: (gle r b c) by order_tac.
by rewrite (inf_comparable1 or bc) (sup_C r a b) (sup_comparable1 or ab).
rewrite (sup_C r a c) (sup_comparable1 or ac).
have aa: (gle r a a) by order_tac.
rewrite (inf_comparable1 or aa).
case: (tor _ _ br cr) => bc.
by rewrite (inf_comparable1 or bc) (sup_C r a b) (sup_comparable1 or ab).
rewrite (inf_C r b c) (inf_comparable1 or bc).
by rewrite (sup_C r a c) (sup_comparable1 or ac).
Qed.
Section Exercise1_16.
Variable r: Set.
Hypothesis lr: lattice r.
Lemma Exercise1_16a:
( (distributive_lattice1 r -> distributive_lattice3 r) /\
(distributive_lattice2 r -> distributive_lattice3 r)).
Proof.
move:(lattice_props lr) =>/=.
set (E:= substrate r).
move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]].
split.
move=> d1 x y z xE yE zE.
move: (iE _ _ yE zE) (sE _ _ xE yE) => iyzE sxyE.
rewrite (d1 _ _ _ iyzE zE xE) (sup_C r (inf r y z) x).
rewrite (d1 _ _ _ xE yE zE) (sup_C r x z) (sixy _ _ yE zE).
set (sxy :=sup r x y); set (syz:=sup r y z); set (szx:= sup r z x).
have ->:(inf r z (inf r sxy szx) = inf r z sxy).
rewrite (inf_C r sxy szx) (ixyz _ _ _ zE (sE _ _ zE xE) sxyE).
rewrite (inf_C r z (sup r z x)) (sup_C r z x) (isxy _ _ xE zE) //.
rewrite (d1 _ _ _ (iE _ _ xE yE) zE sxyE) (sup_C r _ z).
rewrite (d1 _ _ _ zE xE yE) (sup_C r z y) (sup_C r (inf r x y) _).
rewrite (d1 _ _ _ sxyE xE yE).
rewrite (sxyx _ _ xE yE) {2} (sup_C r x y) (sxyx _ _ yE xE).
rewrite (sup_C r y x) (ixx _ sxyE) inf_C (inf_C r syz szx) //.
move=> d1 x y z xE yE zE.
move: (sE _ _ yE zE) (iE _ _ xE yE) => syzE ixyE.
rewrite (d1 _ _ _ syzE zE xE) (inf_C r (sup r y z) x).
rewrite (d1 _ _ _ xE yE zE) (inf_C r x z) (isxy _ _ yE zE).
set (ixy := inf r x y); set (iyz:= inf r y z); set (izx:= inf r z x).
have ->:(sup r z (sup r ixy izx) = sup r z ixy).
rewrite (sup_C r ixy izx) (sxyz _ _ _ zE (iE _ _ zE xE) ixyE).
rewrite (sup_C r z (inf r z x)) (inf_C r z x) (sixy _ _ xE zE) //.
rewrite (d1 _ _ _ (sE _ _ xE yE) zE ixyE) (inf_C r _ z).
rewrite (d1 _ _ _ zE xE yE) (inf_C r z y) (inf_C r (sup r x y) _).
rewrite (d1 _ _ _ ixyE xE yE).
rewrite (ixyx _ _ xE yE) {2} (inf_C r x y) (ixyx _ _ yE xE).
rewrite (inf_C r y x) (sxx _ ixyE) sup_C (sup_C r iyz izx) //.
Qed.
Lemma Exercise1_16b:
[/\ (distributive_lattice3 r -> distributive_lattice4 r),
(distributive_lattice3 r -> distributive_lattice1 r) &
(distributive_lattice3 r -> distributive_lattice2 r)].
Proof.
move:(lattice_props lr) =>/=.
set (E:= substrate r).
move: (lr) => [or _].
move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]].
have p1: (distributive_lattice3 r -> distributive_lattice4 r).
move => h x y z xE yE zE zx.
move: (h _ _ _ xE yE zE).
rewrite (inf_comparable1 or zx)(sup_comparable1 or zx).
rewrite (sixy _ _ yE zE) (inf_C r (sup r y z) x).
rewrite (ixyz _ _ _ (sE _ _ xE yE) xE (sE _ _ yE zE)).
rewrite (sup_C r x y) (isxy _ _ yE xE) sup_C//.
split; first by exact.
move=> d3 x y z xE yE zE.
move: (d3 _ _ _ xE yE zE) => ab;move: (f_equal (sup r x) ab).
set (t := sup r x (inf r (sup r x y) (inf r (sup r y z) (sup r z x)))).
move: (iE _ _ xE yE) (iE _ _ yE zE) (iE _ _ zE xE) => ixyE iyzE izxE.
rewrite (sxyz _ _ _ xE ixyE (sE _ _ iyzE izxE)).
rewrite (sup_C r x _) (inf_C r x y) (sixy _ _ yE xE).
rewrite (sup_C r (inf r y z) (inf r z x)).
rewrite (sxyz _ _ _ xE izxE iyzE) (sup_C r x (inf r z x)) (sixy _ _ zE xE).
move=> ->.
rewrite /t.
rewrite (sup_C r x z); set sxy:= sup r x y; set szx:= sup r z x.
have xsxy:gle r x sxy by move: (lattice_sup_pr lr xE yE)=> [q1 q2 q3].
have sxyE: inc sxy (substrate r) by order_tac.
rewrite ((p1 d3) _ _ _ sxyE (iE _ _ (sE _ _ yE zE) (sE _ _ zE xE)) xE xsxy).
apply: f_equal.
rewrite sup_C inf_C -/szx.
have xsrx:gle r x szx by move: (lattice_sup_pr lr zE xE)=> [q1 q2 q3].
have szxE: inc szx (substrate r) by order_tac.
rewrite ((p1 d3) _ _ _ szxE (sE _ _ yE zE) xE xsrx).
rewrite -(sxyz _ _ _ yE zE xE) -/szx inf_C; apply: isxy => //.
move=> d3 x y z xE yE zE.
move: (d3 _ _ _ xE yE zE) => ab;move: (f_equal (inf r x) ab).
set (t := inf r x (sup r (inf r x y) (sup r (inf r y z) (inf r z x)))).
move: (sE _ _ xE yE) (sE _ _ yE zE) (sE _ _ zE xE) => sxyE syzE szxE.
rewrite (ixyz _ _ _ xE sxyE (iE _ _ syzE szxE)).
rewrite (inf_C r x _) (sup_C r x y) (isxy _ _ yE xE).
rewrite (inf_C r (sup r y z) (sup r z x)).
rewrite (ixyz _ _ _ xE szxE syzE) (inf_C r x (sup r z x)) (isxy _ _ zE xE).
move=> <-; rewrite /t.
rewrite (inf_C r x z); set ixy:= inf r x y; set izx:= inf r z x.
have xsxy:gle r ixy x by move: (lattice_inf_pr lr xE yE)=> [q1 q2 q3].
have ixyE: inc ixy (substrate r) by order_tac.
rewrite sup_C.
rewrite -((p1 d3) _ _ _ xE (sE _ _ (iE _ _ yE zE) (iE _ _ zE xE)) ixyE xsxy).
apply: f_equal.
have xsrx:gle r izx x by move: (lattice_inf_pr lr zE xE)=> [q1 q2 q3].
have izxE: inc izx (substrate r) by order_tac.
rewrite -((p1 d3) _ _ _ xE (iE _ _ yE zE) izxE xsrx).
rewrite inf_C -(ixyz _ _ _ yE zE xE) .
rewrite -/izx sup_C sixy //.
Qed.
Lemma Exercise1_16cP:
(distributive_lattice3 r <-> distributive_lattice5 r).
Proof.
move: (lr) => [or _].
move:(lattice_props lr) =>/=.
set (E:= substrate r).
move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]].
split => aux.
move: (Exercise1_16b) => [p1 p2 p3].
move=> x y z xE yE zE.
rewrite (p3 aux) // (inf_C r z y).
move: (iE _ _ yE zE) (iE _ _ zE xE); set b:= inf r y z.
move=> bE izxE.
move: (lattice_sup_pr lr xE bE) => [q1 q2 q3].
move: (lattice_sup_pr lr izxE bE)=> [_ _]; apply => //.
apply: order_transitivity q1 => //.
by move: (lattice_inf_pr lr zE xE) => [r1 r2 r3].
move: (Exercise1_16a) => [h _]; apply: h.
move => x y z xE yE zE.
move: (iE _ _ yE zE) (sE _ _ xE zE) (sE _ _ xE yE) => iyzE sxzE sxyE.
apply: (order_antisymmetry or).
move: (lattice_sup_pr lr xE (iE _ _ yE zE)) => [q1 q2 q3].
move: (lattice_inf_pr lr yE zE) => [r1 r2 _].
move: (lattice_inf_pr lr sxyE sxzE) => [_ _]; apply.
move: (lattice_sup_pr lr xE yE) => [p1 p2 p3].
apply: q3 => //; apply: order_transitivity p2 => //.
move: (lattice_sup_pr lr xE zE) => [p1 p2 p3].
apply: q3 => //; apply: order_transitivity p2 => //.
move: (aux _ _ _ xE yE zE).
move: (aux _ _ _ xE zE (sE _ _ xE yE)).
set (a:= inf r (sup r x y) (sup r x z)).
set (b:= sup r x (inf r y z)).
set (c:= inf r z (sup r x y)).
move=> le1 le2.
move: (lattice_sup_pr lr xE iyzE); rewrite -/b; move=> [le3 _ _].
move: (lattice_sup_pr lr xE (iE _ _ zE sxyE) ); rewrite -/c; move=> [_ _ hc].
apply: (order_transitivity or le1 (hc _ le3 le2)).
Qed.
Lemma Exercise1_16dP:
(distributive_lattice3 r <-> distributive_lattice6 r).
Proof.
move: (lr) => [or _].
move:(lattice_props lr) =>/=.
set (E:= substrate r).
move => [sE [iE [sixy [isxy [sxyz [ixyz [sxx [ixx [sxyx ixyx]]]]]]]]].
split => aux.
move=> x y z xE yE zE.
move: (sE _ _ xE yE)(iE _ _ xE yE) => sxyE ixyE.
move: (Exercise1_16b) => [_ _ il2];rewrite ((il2 aux) _ _ _ sxyE zE ixyE).
rewrite (inf_C r (sup r x y) z) ((il2 aux) _ _ _ zE xE yE)(inf_C r y z).
have ->: (inf r (sup r x y) (inf r x y) = inf r x y).
rewrite inf_C; apply: inf_comparable1 => //.
move: (lattice_sup_pr lr xE yE) (lattice_inf_pr lr xE yE).
move=> [p1 _ _] [p2 _ _]; order_tac.
rewrite sup_C; apply: f_equal; rewrite sup_C //.
apply /Exercise1_16cP; move=> x y z xE yE zE.
rewrite (inf_C r z (sup r x y)).
move: (aux _ _ _ xE yE zE).
move: (sE _ _ xE yE)(iE _ _ xE yE); set (b:= sup r x y); set (xy:= inf r x y).
move=> bE xyE.
move: (lattice_inf_pr lr bE zE)=> [z1 z2 z3].
move: (lattice_sup_pr lr zE xyE)=> [w1 w2 w3].
set A:= inf r _ _; set B := sup r _ _.
have l1: gle r (inf r (sup r x y) z) A.
rewrite /A;move: (lattice_inf_pr lr bE (sE _ _ zE xyE)).
move=> [q1 q2 q3]; apply: q3 => //; order_tac.
move: (iE _ _ yE zE)(iE _ _ zE xE); set (yz:= inf r y z); set (zx:= inf r z x).
move=> yzE zxE.
have l2: gle r B (sup r x yz).
rewrite /B.
move: (lattice_sup_pr lr xE yzE) => [q1 q2 q3].
move: (lattice_sup_pr lr xyE (sE _ _ yzE zxE))=> [_ _]; apply.
move: (lattice_inf_pr lr xE yE) => [h _ _]; order_tac.
move: (lattice_sup_pr lr yzE zxE) => [_ _ ]; apply;first by exact.
move: (lattice_inf_pr lr zE xE) => [_ h _]; order_tac.
move=> AB; rewrite AB in l1; order_tac.
Qed.
End Exercise1_16.
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, (exists u, least r u) &
(forall x y, gle r x y -> exists x', complement_pr r x y x')].
Definition boolean_lattice r:=
[/\ relatively_complemented r, (exists u, greatest r u) &
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.
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 _ (iE _ _ vs us) el).
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 : Set, inc x0 (substrate r) & complement_pr r x y x0.
by exists z => //; move: 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 standard_completion_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 standard_completion_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: (standard_completion_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 standard_completion_involutive r x:
boolean_lattice r -> inc x (substrate r) ->
standard_completion r (standard_completion r x) = x.
Proof.
move=> blr xsr; move: (standard_completion_pr blr xsr).
set (y:= standard_completion r x) ; rewrite /complement_pr.
rewrite sup_C inf_C ;move => [ysr ym yq].
symmetry; apply: standard_completion_unique => //.
Qed.
Lemma standard_completion_monotone 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: (standard_completion_pr blr xE) (standard_completion_pr blr yE).
set (a:= standard_completion r x).
set (b:= standard_completion r y).
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 (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: (Exercise1_16b 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: standard_completion_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: (standard_completion_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 -(standard_completion_involutive blr uE).
rewrite -(standard_completion_involutive blr vE) ss //.
move => u uE; exists (standard_completion r u); first by apply: ta.
by rewrite (standard_completion_involutive blr uE).
red; aw;move=> x y xE yE; aw; split.
by move => h; apply /opp_gleP; apply: standard_completion_monotone.
move /opp_gleP.
rewrite -{2} (standard_completion_involutive blr xE).
rewrite -{2} (standard_completion_involutive blr yE).
move: blr;apply: standard_completion_monotone.
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: (exists u, least r u) 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: (exists u, greatest r u) 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; rewrite /sup; 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; rewrite /sup; 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.
set_extens t.
case/setU2_P; [ apply: xy | by move /setC_P => []].
move => ty; case:(inc_or_not t x) => tx; apply /setU2_P; [by left | right].
by apply /setC_P.
by apply /set0_P => t; move /setI2_P => [tx] /setC_P [_] ntx.
have dl3: (distributive_lattice3 r).
apply /(Exercise1_16cP lr).
move=> x y z; rewrite sr => xA yA zA.
move: (xA)(yA)(zA) => /setP_P xA1 /setP_P yA1 /setP_P zA1.
rewrite (ge1 _ _ yA zA) (le1 _ _ xA yA).
have iyzA: (inc (y \cap z) (powerset A)).
by apply /setP_P;move=> t /setI2_P [ty _]; apply: yA1.
have uxyA: (inc (x \cup y) (powerset A))
by apply /setP_P; move=> t;case/setU2_P; fprops.
rewrite (le1 _ _ xA iyzA) (ge1 _ _ zA uxyA).
apply /sub_gleP.
set B:= (z \cap (x \cup y)).
set C:= (x \cup (y \cap z)).
have sCA: sub C A.
by move => t; case/setU2_P;[apply: xA1| move /setI2_P=> [ty _];apply: yA1].
have BC: sub B C.
move=> t /setI2_P [tz]; case/setU2_P => tx; first by apply /setU2_P; left.
by apply /setU2_P; right; fprops.
by split => //; try apply /setP_P => //;apply: sub_trans sCA.
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: standard_completion_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: (standard_completion_pr blr ysr); rewrite -/ys; move=> [ys1 ys2 ys3].
move: (Exercise1_16b 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) => [-> _ _ _].
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: (standard_completion_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.
rewrite -/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 latticethat is not distributive bu 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); move: tx.
move: ux vx => [ [aux1 _] _] [[aux2 _] _]; rewrite -{1} aux1 -aux2.
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; last (by exists t); apply /setI_covering2_P.
by exists y1; exists y2.
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].
have ->: a1=a2.
case: ((proj2 (proj1 ux)) _ _ a1u a2u) => // h1; empty_tac1 w.
have ->: b1=b2 => //.
case:((proj2 (proj1 vx)) _ _ 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 => //.
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; [apply: Ab | apply: Ac].
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=> pu pv.
move:(intersection_is_sup2 pu pv) => i2.
have hs: (has_supremum (coarser E) (doubleton u v)).
by exists (intersection_partition2 u v).
move: (coarser_osr E) => [pa pb].
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.
set (g := fun u => choose (fun v => inc t v /\ inc v (Vg f u))).
have gp: (forall u, inc u (domain f) -> (inc t (g u) /\ inc (g u) (Vg f u))).
move=> u udf; apply choose_pr; move:(alp _ udf) =>[[pu1 _] _].
by move: tx; rewrite -pu1 => /setU_P [z z1 z2]; 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);move: (setIb_hi yi2 idf)=> p3 p4.
rewrite dz2 in idf.
case:(proj2 (proj1 (alp _ idf)) _ _ p1 p4) => // 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.
red; 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.
set (g:= fun u => choose (fun z => inc z (Vg f u) /\ sub t z)).
have gp: (forall u, inc u (domain f) -> (inc (g u) (Vg f u) /\ sub t (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; move: (XsE _ uX); rewrite aux /f identity_ev.
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; first by rewrite Ee setU_0.
by move=> a b /in_set0.
exists emptyset; rewrite lub_set0 //.
split;first by rewrite aux.
move => x; rewrite 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.
by apply: (@setU_i _ t).
exists (least_partition E).
rewrite lub_set0 //; split.
by rewrite aux; apply: least_is_partition.
move=> x; rewrite 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
Definition big_set3 E :=
exists x y z, [/\ inc x E, inc y E, inc z E & [/\ x <> y, x <> z & y <> z]].
Lemma Exercise1_18b E: big_set3 E ->
~ (distributive_lattice1 (coarser E)).
Proof.
move=> [x [y [z [xE yE zE [xy xz yz]]]]].
set (o:= tripleton x y z).
set (F:= E -s o).
set (with_F := fun u => (u +s1 F) -s1 emptyset).
have wf1: (forall u, ~ (inc emptyset u) -> F = emptyset -> with_F u = u).
move=> u nsu Fe; rewrite /with_F; set_extens t.
by case/setC1_P; case/setU1_P => //; rewrite Fe.
move => tu; apply /setC1_P; split; first by apply /setU1_P; left.
by dneg xx; rewrite -xx.
have wf2: (forall u, ~ (inc emptyset u) -> F <> emptyset -> with_F u = u +s1 F).
move=> u une Fne; set_extens t; first by move /setC1_P => [].
move => h; apply /setC1_P;split => //; case/setU1_P: h => tu te.
case: une; ue.
by case: Fne; rewrite -tu te.
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 ->
a <> b -> a <> c -> b <> c -> partition_s (pa3 a b c) o).
move => a b c uo ab cb bc; split; last first.
move=> u => /set2_P; case=> ->; [apply: set1_ne | apply: set2_ne].
split => //; move=> u v /set2_P [] -> /set2_P [] ->;
try(solve [by left]); right; apply: disjoint_pr.
move=> w /set1_P -> /set2_P; case => //.
by move=> w /set2_P [] -> /set1_P; apply:nesym.
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 => //; set_extens t.
case /setU2_P; first by move => /set1_P ->; apply /set3_P; in_TP4.
case/set2_P => ->; apply /set3_P; in_TP4.
case/set3_P => ->; fprops.
have poy: partition_s (pa3 y x z) o.
apply: pa3p => //; [set_extens t | by apply:nesym ].
case /setU2_P; first by move => /set1_P ->; apply /set3_P; in_TP4.
case /set2_P => ->; apply /set3_P; in_TP4.
case /set3_P => ->; fprops.
have poz: partition_s (pa3 z x y) o.
by apply: pa3p => //; [rewrite setU2_C | apply:nesym | apply:nesym ].
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).
apply: wfp; apply: least_is_partition; exists z; apply /set3_P;in_TP4.
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=> oem; empty_tac1 z; apply /setU1_P; right.
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.
by exists a;fprops; apply /setC1_P;split => //; apply /setU1_P; right.
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 ->: (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.
apply /setC1_P;split; first by apply /setU1_P; left; apply /set2_P; right.
move=> de; empty_tac1 x.
move: (cc _ d1Py)=> [s1 p1 p2].
move: e2 =>/coarser_gleP [_ _ cc2].
have d2Py: inc (doubleton x y) Pz.
apply /setC1_P;split;first by apply /setU1_P; left; apply /set2_P; right.
move=> de; empty_tac1 x.
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.
apply /setC1_P; split; last by move=> ye; empty_tac1 y.
apply /setU1_P; left; apply /funI_P;exists y=> //; apply /set3_P; in_TP4.
rewrite -pa; move /setC1_P => [] /setU1_P; case.
move /set2_P; case =>h; first by move: (set1_inj h) => h1; case: xy.
have : inc z (singleton y) by rewrite h; fprops.
by move /set1_P => aux'; case: yz.
move=> yF; move: (set1_1 y); rewrite yF; move /setC_P => [_]; case.
apply /set3_P; in_TP4.
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.
move: (set2_1 a b); rewrite da; case/set2_P =>->; apply /set3_P; in_TP4.
have bo: inc b o.
move: (set2_2 a b); rewrite da; case/set2_P =>->; apply /set3_P; in_TP4.
have xo: inc x o by apply /set3_P; in_TP4.
have xnF: ~ (inc x F) by move /setC_P => [_]; case; apply /set3_P; in_TP4.
have ynF: ~ (inc y F) by move /setC_P => [_]; case; apply /set3_P; in_TP4.
have znF: ~ (inc z F) by move /setC_P => [_]; case; apply /set3_P; in_TP4.
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 (fun z0 : Set => singleton z0)) 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;
last by move=> ->; apply /setU1_P;right; rewrite uF; rewrite setI2_id.
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 ].
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; exists 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 by apply /setU1_P; left; apply /set2_P;fprops.
move => se; empty_tac1 x.
have ac2: inc (singleton a) C2.
apply /setC1_P;split; first by apply /setU1_P; left; apply /set2_P;fprops.
move => se; empty_tac1 a.
have bx2: inc (doubleton x b) C2.
apply /setC1_P;split; first by apply /setU1_P; left; apply /set2_P;fprops.
move => se; empty_tac1 x.
have ab2: inc (doubleton a b) C1.
apply /setC1_P;split; first by apply /setU1_P; left; apply /set2_P;fprops.
move => se; empty_tac1 a.
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)) => ru.
move: (cyx _ uX) => [w wY uW].
case: (py3 _ _ vy wY) => vw.
exists (rep u); apply: Zo_i; [ union_tac | exists u;split => //; ue].
empty_tac1 x.
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.
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.
exists (singleton x); fprops; apply: (Hb _ _ xa aX xrep).
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).
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.
move=> 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; rewrite 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, exists 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.
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.
apply /orsum_gleP; split => //; last by right; aw.
apply: disjoint_union_pi1 => //; order_tac.
apply: disjoint_union_pi1 => //; order_tac.
dneg sj; apply: (pr1_def sj).
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 => //.
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 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_order:=
order_prod Bnat_order (cst_graph Bnat canonical_doubleton_order).
Definition cantor_tri_sub:= productb (cst_graph Bnat C2).
Lemma cantor_tri_order_axioms: orprod_ax Bnat_order
(cst_graph Bnat canonical_doubleton_order).
Proof.
move : Bnat_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; apply: orprod_total.
by apply: cantor_tri_order_axioms.
red;bw; move => i iB; bw.
apply: worder_total; apply: (proj1 cdo_wor).
Qed.
Lemma cantor_tri_order_sr1 :
prod_of_substrates (cst_graph Bnat canonical_doubleton_order) =
cantor_tri_sub.
Proof.
rewrite /prod_of_substrates /fam_of_substrates; apply: f_equal.
bw; apply: Lg_exten; move=> x xB;bw.
simpl; bw; rewrite (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, [/\ inc j Bnat,
(forall i, inc i Bnat -> i <c j -> Vg x i = Vg x' i),
Vg x j = C0 & Vg x' j = C1]].
Proof.
rewrite /cantor_tri_order.
set r := Bnat_order;set g := cst_graph _ _.
have op: orprod_ax r g by apply: cantor_tri_order_axioms.
have sr: substrate r = Bnat by rewrite /r (proj2 Bnat_order_wor).
have rvP: forall j, inc j Bnat -> 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; bw;rewrite /glt; split.
move => [] /cdo_gleP h1 h2; case: h1 => //.
by move=> [p1 p2]; case: h2; rewrite p1 p2.
by move=> [p1 p2]; case: h2; rewrite p1 p2.
move=> [ -> -> ]; split; [ apply /cdo_gleP; in_TP4 | fprops].
have rijP: forall i j, inc j Bnat ->
(glt r i j <-> (inc i Bnat /\ i <c j)).
move => i j jB; split.
by move => [] /Bnat_order_leP [pa pb pc] pd.
by move => [pa [pb pc]]; split => //; apply/Bnat_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 lt1 lt2]].
move /(rvP _ jsr): lt1 => [pa pb].
by exists j; split => // i iB 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 [jB sj jx jy]]].
set (f:= fun i=> Yo (i <=c j) (Vg x i) C1).
set (g:= fun i=> Yo (i<=c j) (Vg y i) C0).
have fgPr: (fgraph (cst_graph Bnat C2)) by fprops.
move: (xb)(yb) => /setXf_P [fgx dx xVV] /setXf_P [fgy dy yVV].
have fPr: (inc (Lg Bnat f) cantor_tri_sub).
apply /setXf_P;split;fprops; bw;move=> i iB; rewrite /f; bw.
Ytac hle; fprops; move: (xVVg _ iB); bw.
have gPr: (inc (Lg Bnat g) cantor_tri_sub ).
apply /setXf_P;split;fprops; bw;move=> i iB; rewrite /g; bw.
Ytac h; fprops; move: (yVVg _ iB); bw.
move: cantor_tri_order_total => [co _].
have bnto: forall a b, inc a Bnat -> inc b Bnat ->
a <=c b \/ b <c a.
move=> a b aB bB; apply: card_le_to_el; fprops.
set Zab:= fun a x => Zo Bnat (fun i => j <c i /\ Vg x i = a).
have Zabp: forall a x, nonempty (Zab a x) -> exists k,
[/\ inc k Bnat, j <c k, Vg x k = a &
(forall i, inc i Bnat -> i <c k -> i <=c j \/ Vg x i <> a)].
move=> a xx ne.
have Zn: sub (Zab a xx) Bnat by apply: Zo_S.
move: Bnat_order_wor=> [[bor wor] sr].
rewrite - sr in Zn.
move: (wor _ Zn ne) => [k]; rewrite /least; aw.
move=> [kZ]; move: (kZ) => /Zo_P [kB [jk ka]] kl.
exists k; split => //. move=> i iB ik.
case: (bnto _ _ iB jB) => ji; [by left | right].
move=> ix; have iz: inc i (Zab a xx) by apply: Zo_i => //.
move: (kl _ iz) => h; move: (iorder_gle1 h).
move /Bnat_order_leP => [_ _ le1]; co_tac.
have p1: gle cantor_tri_order x (Lg Bnat f).
set Z := Zab C0 x.
case: (emptyset_dichot Z) => Ze.
suff: x = (Lg Bnat f).
move=> <- ;order_tac;rewrite cantor_tri_order_sr //.
apply: fgraph_exten => //; bw; fprops.
rewrite dx; move=> i iB; rewrite /f; bw.
Ytac hle =>//; move: (xVV _ iB); bw; case/C2_P => // vb.
empty_tac1 i; apply: Zo_i => //;split => //.
by case: (bnto _ _ iB jB).
suff: glt cantor_tri_order x (Lg Bnat f) by move=> [ok _].
move:(Zabp C0 x Ze) => [k [kB jk vk lt]].
apply /cantor_tri_order_gltP; split => //.
exists k; split => //.
move=> i iB ik; rewrite /f; bw.
Ytac hle => //; case: (lt _ iB ik)=> // va.
move: (xVV _ iB); bw; case/C2_P => //.
bw;rewrite /f; Ytac kb => //; co_tac.
have p2: gle cantor_tri_order (Lg Bnat g) y.
set Z := Zab C1 y.
case: (emptyset_dichot Z) => Ze.
suff: y = (Lg Bnat g).
move=> <- ;order_tac;rewrite cantor_tri_order_sr //.
apply: fgraph_exten => //; bw; fprops.
rewrite dy; move=> i iB; rewrite /g; bw.
Ytac hle => //; move: (yVV _ iB); bw; case/C2_P => // vb.
empty_tac1 i; apply: Zo_i => //;split => //.
by case: (bnto _ _ iB jB).
suff: glt cantor_tri_order (Lg Bnat g) y by move=> [ok _].
move:(Zabp C1 y Ze) => [k [kB jk vk lt]].
apply /cantor_tri_order_gltP; split => //.
exists k; split => //; last by rewrite /g;bw;Ytac kb => //; co_tac.
move=> i iB ik; rewrite /g; bw; Ytac ij => //.
case: (lt _ iB ik)=> // va; move: (yVV _ iB); bw; case/C2_P=> //.
have jj: j <=c j by apply: card_leR; fprops.
exists (Lg Bnat f), (Lg Bnat 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 [k1B k1p k1a k1b]]].
move /cantor_tri_order_gltP => [_ _ [k2 [k2B k2p k2a k2b]]].
move: k1a k2b; rewrite /f /g; bw; Ytac k1j; Ytac k2j => k1a k2b;
try (solve [apply: TP_ne; done]).
case: (bnto _ _ k1B k2B) => k1k2.
have l12: k1 <c k2.
by split =>//h; case: TP_ne; rewrite -k1b -k2a h.
move: (k2p _ k1B l12); rewrite /g; bw; rewrite (Y_true k1j) k1b.
have p: k1 <c j by co_tac.
rewrite -(sj _ k1B p) k1a; fprops.
move: (k1p _ k2B k1k2); rewrite /f; bw; rewrite (Y_true k2j) k2a.
have p: k2 <c j by co_tac.
rewrite (sj _ k2B p) k2b; fprops.
Qed.
Lemma Exercise1_20e: ~ (scattered cantor_tri_order).
Proof.
move=> ns.
set (all_a := Zo cantor_tri_sub (fun z => exists2 i, inc i Bnat & forall j,
inc j Bnat -> 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, inc i Bnat -> exists j, [/\ inc j Bnat, i <=c j & Vg a j = C1]).
move=> a; split.
move /setC_P => [p1 p2];split =>// i iB; ex_middle nf; case: p2.
apply: Zo_i => //; ex_tac => j jB ij; ex_middle vj; case: nf; ex_tac.
move: p1 => /setXf_P [_ _ aux]; move: (aux _ jB);case/C2_P =>//.
move => [pa pb]; apply /setC_P;split => //; move => /Zo_P [_ [i iB h]].
move: (pb _ iB) =>[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 Bnat C1).
set zab:= (Lg Bnat (fun i => Yo (i = \0c) C0 C1)).
have zbF: (inc zb F).
apply /FpP; rewrite /zb; split.
apply /setXf_P; split;fprops;bw => i iB; bw; fprops.
move=> i iB; exists i; split => //; bw; fprops.
have zabF: (inc zab F).
apply /FpP; rewrite /zab; split.
apply /setXf_P;split => //;bw; fprops => i iB; bw; Ytac h; fprops.
move=> i iB; exists (succ i); split => //; bw; fprops.
rewrite Y_false //; apply: succ_nz.
have [lt1 ne1]: (glt cantor_tri_order zab zb).
have zeb: inc \0c Bnat by fprops.
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 iB iz; case: (card_lt0 iz).
fprops.
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 [jB sj fj gj]]][fs gs].
have scj: (inc (succ j) Bnat) by fprops.
move: (gs)=>/FpP [gc ha].
move: (ha _ scj) => [k [kB kle Vk]].
move: kle;rewrite card_le_succ_ltP // => kle.
set (h:= Lg Bnat (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 iB; bw; Ytac h0; fprops.
by move: gc => /setXf_P [_ _]; apply.
move=> i iB.
have [l [lB il kl]]: exists l, [/\ inc l Bnat, i <=c l & k <c l].
have c1: cardinalp i by fprops.
have c2: cardinalp k by fprops.
case: (card_le_to_el c1 c2) => c3; last by exists i;split;fprops.
exists (succ k); move: (card_lt_succ kB) => c4.
split;fprops; move: c4 => [c4 _]; co_tac.
move: (ha _ lB) => [n [nB mn Vb]]; exists n;split => //; first by co_tac.
have: k <c n by co_tac.
by move=> [_ kn]; rewrite /h; bw; Ytac0.
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).
have [_ ik]: i <c k by co_tac.
by rewrite /h; bw;Ytac0.
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: (substrate (order_sum r g) = sum_of_substrates g).
by rewrite orsum_sr.
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 orsum_sr //.
move => 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) => [xax xbx].
move: (iorder_gle2 ab) => lab'.
have raw: inc (J (R a) a) w by apply /funI_P; exists a.
have rbw: inc (J (R b) b) w by apply /funI_P; exists b.
split; last by move: lab' => [_ nab] sj; move: (pr2_def sj).
apply /iorder_gleP => //; apply/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) => [uw vw].
move: (iorder_gle2 uv) => [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 //.
move => 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) => [xax xbx].
move: (iorder_gle2 ab) => [lab1 lab2].
have raw: inc (J a i) w by apply /funI_P; exists a.
have rbw: inc (J b i) w by apply /funI_P; exists b.
split; last by move => sj; move: (pr1_def sj).
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) => [uw vw].
move: (iorder_gle2 uv) => [luv nuv].
move: uw vw => /funI_P [u' u'x J1] /funI_P [v' v'x J2].
move: luv => /orsum_gleP //; move=> [_ _].
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'].
set f:= fun 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 //; apply: (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)); move=> [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; move: (alg _ (nss _ ins)) => og.
move: (fp1 i) => s2; apply:(proj1 (iorder_osr og (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).
move: h2; rewrite /g'; bw => h; by move: (iorder_gle1 h).
move => /orsum_gleP [pa pb pc]; apply /orsum_gleP;split => //.
by rewrite ss'.
by rewrite ss'.
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.
have g1: sgraph (induced_order (order_sum r g) x) by fprops.
have g2: sgraph (order_sum r' g') by fprops.
rewrite (sgraph_exten g1 g2) //.
rewrite -[related]/gle.
move=> 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.
move=> p2 p3; contradiction.
move: scr => [_ scr]; move: (scr _ nss); case; split; fprops.
case: wg1 => //; by move=> [i [u [v [isr uv]]]]; case: (p1 i u v isr).
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 u (rep (substrate (Vg g' u))) w); [ ue | done].
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 v w (rep (substrate (Vg g' v)))); [ ue | done].
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; move=> x xd.
by simpl;bw; aw; apply: iqs.
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 ->: (equivalence_associated (second_proj du)) = (E13_S g').
by rewrite /E13_S /E13_sF du1.
have sxx:related s x x by rewrite - sr in xsr;equiv_tac.
rewrite /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=> tor.
move: (Exercise1_21h tor) => [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_aux r x y :=
gle 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)]))).
Lemma Exercise1_21kP r x y: total_order r ->
gle r x y ->
(scattered (induced_order r (interval_cc 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)])))).
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; exists c;split => //; by apply: setI2_i.
case: (uxu _ bu) => bxy.
case: p1u; exists a; exists b;split => //; by apply: setI2_i.
case: p2u; exists c; exists 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; exists b;split => //; by apply: setI2_i.
case: p2u; exists a; exists b;split => //; by apply: setI2_i.
case: p2u; exists a; exists 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))
(fun z => open_r r z).
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 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 => //; move=> 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 => //; move=> 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: inc u (reg_opens r).
apply: Zo_i => //; apply /setP_P;exact (proj1 (proj1 ou)).
have vo: inc v (reg_opens r).
apply: Zo_i => //; apply /setP_P; exact: (proj1 (proj1 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 [zr 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.
move=> [p1 p2 p3]; apply /sub_gleP => //; split => //;apply: Zo_i=> //.
apply /setP_P; apply (proj1 (proj1 p1)).
apply /setP_P; apply (proj1 (proj1 p2)).
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; first by move /Zo_hi.
move => h; apply: Zo_i=> //; apply /setP_P; apply (proj1 (proj1 h)).
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.
move => w /setU_P [y wy yX]; move: (h _ yX) => /Exercise1_22rP.
by move=> [_ _]; 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/ (Exercise1_16cP 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 => //.
by case: oU'.
by apply: sU.
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 => //.
by apply: ta.
by apply: ta.
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 => //.
apply:(h _ _ pd).
apply:(h _ _ pe).
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.
apply:Zo_i => //.
by 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 _)).
move => 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.
move: (double_cardinal (reg_opens r)) => aux.
rewrite (proj2 (sub_osr _)) - (cprod2_pr2 aux aux) 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 - two_plus_two.
have aux2: \2c = \2c +c \0c by aw; fprops.
rewrite {1} aux2 => eq2;case: card2_nz.
by rewrite (csum_simplifiable_left BS2 BS0 BS2 eq2).
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 => //.
apply/Zo_P; split => //; apply /setP_P; apply: (proj1 (proj1 pa)).
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 => //.
rewrite /canonical_reg_open; apply: Exercise1_22j => //.
by apply: Exercise1_23c.
by 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.
rewrite /aux => 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.
move: (p2 _ _ xsr' ysr')=> [oi si di ai].
exists (i x y).
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').
by case: xy; apply: extensionality.
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) => //.
by apply /Exercise1_23bP.
apply: p1 => //.
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.
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 := Bnat -s1 \0c.
Definition Qplus1 := Bnat \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, inc (P x) Bnat, inc (Q x) Bnat & (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_simplifiable_left qy (BS_prod px qz) (BS_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, inc x Bnat -> inc y Bnat -> inc z Bnat -> 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: card_leR; fprops.
apply: (cprod_le_simplifiable 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: (BS_prod p2 r3) (BS_prod r2 p3)=> p5 p6.
rewrite (mc _ _ _ p5 p6 q3 q4).
rewrite (mc _ _ _ (BS_prod p5 q3) (BS_prod p6 q3) s3 s4).
move: (BS_prod q2 s3) (BS_prod s2 q3)=> q5 q6.
rewrite (mc _ _ _ q5 q6 p3 p4).
rewrite (mc _ _ _ (BS_prod q5 p3) (BS_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; congr (_ *c _).
by rewrite - cprodA (cprodC (Q a) (Q b')) cprodA.
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: card_leR; 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: card_leR; fprops.
move=> x y/=; move=> [xq yq le1] [_ _ le2].
move: (card_leA 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: card_leR; fprops.
have le4: (Q X) <=c (Q X) by apply: card_leR; fprops.
move: (cprod_Mlele le1 le3) (cprod_Mlele le2 le4).
rewrite - cprodA (cprodC (Q Y) _) cprodA.
have aB: inc ((P X) *c (Q Z)) Bnat by apply: BS_prod.
rewrite - (cprodA (P Y)) - (cprodA (P Y)) (cprodC (Q X)) => le5 le6.
move: (card_leT le5 le6).
rewrite (cprodC (P Z)) - (cprodA (Q Y)) - (cprodC (Q Y)).
have bB: inc ((P Z) *c (Q X)) Bnat by apply: BS_prod.
move=> le7; apply: (cprod_le_simplifiable 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: (card_le_to_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: inc k Bnat -> inc n Bnat ->
inc (J k (\2c ^c n)) Qplus1.
Proof.
move=> kB nB; rewrite /Qplus1; aw.
apply /setXp_P;split => //; apply /setC1_P;split;fprops;apply: cpow2_nz; fprops.
Qed.
Lemma Qpair_q k n: inc k Bnat -> inc n Bnat -> 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: inc k Bnat -> inc n Bnat -> inc m Bnat ->
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: BS_prod;fprops | fprops ].
red; aw; rewrite - cprodA; congr (_ *c _); apply: cpow_sum2.
Qed.
Lemma Qpair_le0P a b c d:
inc a Bnat -> inc b Bnat -> inc c Bnat -> inc d Bnat ->
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: inc k Bnat -> inc k' Bnat -> inc n Bnat ->
(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_le_simplifiable dB kB k'B dnz le1).
have le2: (\2c ^c n) <=c (\2c ^c n).
apply: card_leR; 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 (succ k) n).
Definition Qpairis :=
fun_image (Bnat \times Bnat) (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, [/\ inc k Bnat, inc n Bnat & 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 (succ k) n)).
Proof.
split; first by move => /Zo_hi.
move => [pa pb]; apply: Zo_i => //; order_tac.
Qed.
Lemma Qpairis_pr2 k n: inc k Bnat -> inc n Bnat ->
(inc (Qpair k n) (Qpairi k n) /\ inc (Qpair (succ k) n) (Qpairi k n)).
Proof.
move=> kB xB.
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 (succ k) n) (Qpair (succ k) n).
order_tac; rewrite p2; apply: Qpair_q;fprops.
have p5:gle Qplus_or (Qpair k n) (Qpair (succ k) n).
by apply /Qpair_leP; fprops; apply: card_le_succ.
by split; apply/Qpairis_pr1P.
Qed.
Lemma Qpairio_gle1P k n l m: inc k Bnat -> inc n Bnat ->
inc l Bnat -> inc m Bnat ->
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 (succ l) n) <=c (f (succ 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 (BS_succ lB) mB (BS_succ kB) nB).
move => [] /(Qpair_le0P kB nB lB mB) pa
/(Qpair_le0P (BS_succ lB) mB (BS_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: inc k Bnat -> inc n Bnat ->
inc l Bnat -> inc m Bnat ->
let f:= fun k n => (k *c (\2c ^c n)) in
gle Qpairi_o (Qpairi k n) (Qpairi l m) <->
(exists p, [/\ inc p Bnat, m = n +c p,
(f k p) <=c l & (succ l) <=c (f (succ k) p)]).
Proof.
move=> kB nB lB mB f.
have n2B: inc (\2c ^c n) Bnat 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 (succ k) _) - cprodA cprodC.
apply: cprod_Mlele; fprops.
move/ (Qpairio_gle1P kB nB lB mB).
rewrite (cprodC (succ l) _)(cprodC (succ k) _).
move=> [r1 r02]; move: (r02).
have m2B: inc (\2c ^c m) Bnat by fprops.
rewrite cprod_via_sum // cprod_via_sum //.
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: (card_leT r4 r2) => r5.
have fB: inc (f k m) Bnat by rewrite /f; fprops.
move: (csum_le_simplifiable fB n2B m2B r5) => aux.
have nm: n <=c m.
case: (card_le_to_el (CS_Bnat nB) (CS_Bnat mB)) => // nm.
move: (cpow_Mlelt BS2 nB nm card_lt_12) => aux1; co_tac.
move: (cdiff_pr nm); set p := (m -c n) => cp.
have pB: inc p Bnat by apply: BS_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 _ (succ k)) -/(f (succ k) p) => r1 r6.
have knz: ptn <> \0c by apply: cpow2_nz.
have fkpB: inc (f k p) Bnat by rewrite /f; fprops.
have fkspB: inc (f (succ k) p) Bnat by rewrite /f; fprops.
rewrite /Nstar;bw; aw; exists p; split => //.
apply: (cprod_le_simplifiable n2B fkpB lB knz r1).
apply: (cprod_le_simplifiable n2B (BS_succ lB) fkspB knz r6).
Qed.
Lemma Qpairio_eq k n l m:
inc k Bnat -> inc n Bnat -> inc l Bnat -> inc m Bnat ->
(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: (Bsum_M0le nB pB)(Bsum_M0le mB qB).
rewrite -np -nq => le5 le6.
have nm: n = m by co_tac.
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_simplifiable_left nB BS0 pB r1).
rewrite cpowx0; aw; fprops => kl.
move: le3; rewrite -(csum_simplifiable_left mB BS0 qB r2).
rewrite cpowx0; aw; fprops => lk.
split => //; co_tac.
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) (succ n).
move: BS2 BS1 => b2 b1.
have aux: gle Qpairi_o x y.
have p1: inc (k *c \2c) Bnat by fprops.
have p2: inc (succ n) Bnat 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) - card_succ_pr4 //; fprops; split;fprops.
rewrite !card_succ_pr4 // cprod_sumDr.
have ->: \1c *c \2c = \1c +c \1c
by aw; rewrite card_two_pr.
rewrite csumA.
apply: Bsum_M0le; fprops.
move=> [_ h]; move: (h _ aux).
have k2B: inc (k *c \2c) Bnat by fprops.
rewrite xv /y=> xy.
move: (Qpairio_eq k2B (BS_succ nB) kB nB xy) => [_ sn].
by move: nB => /BnatP /finite_cP [_] [].
Qed.
Lemma Qpairio_gle3 k n l m z:
inc k Bnat -> inc n Bnat -> inc l Bnat -> inc m Bnat ->
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 Bnat by apply: BS_diff.
have ptq: p = q +c t.
apply: (@csum_simplifiable_left 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 := ((succ k) *c (\2c ^c t)).
set q2:= (\2c ^c q).
move: BS2 => bs2.
have kpN: inc kt Bnat by rewrite /kt; fprops.
have kptN: inc kpt Bnat by rewrite /kpt; fprops.
have q2B: inc q2 Bnat by rewrite /q2; fprops.
have kptqN: inc (kpt *c q2) Bnat by fprops.
have lpqB: inc ((succ l) *c q2) Bnat by fprops.
move => le1 /(card_le_succ_ltP _ iN) le2 le3
/(card_le_succ_ltP _ iN) le4.
move: (card_le_ltT le1 le4) (card_le_ltT le3 le2).
have knz: q2 <> \0c.
by apply: cpow_nz; fprops.
rewrite !(cprodC _ q2) => le5 le6;split => //.
apply /card_lt_succ_leP=>//;apply: (@cprod_lt_simplifiable q2) => //; fprops.
apply /(card_le_succ_ltP _ lB).
apply: (@cprod_lt_simplifiable 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: (card_le_to_ee (CS_Bnat nB) (CS_Bnat 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: inc (succ k) Bnat 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 /(card_le_succ_succP kk (CS_Bnat lB)).
move=> lee leb.
have lk: l = k by apply: succ_injective1 => //; fprops;co_tac.
case: nxy; rewrite xv yv lk nm pz; aw.
have nmn: m <> n.
dneg mn; apply: (@csum_simplifiable_left 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) (succ l) kq2.
have l'B: inc l' Bnat.
move: BS2=> b2; rewrite /l'; Ytac aux; fprops; rewrite /kq2 /q2; fprops.
have ll': l <> l'.
by rewrite /l'; Ytac aux =>//; move: lB => /BnatP /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 (succ l) by apply: card_le_succ.
have p1: kq2 <=c (succ l) by co_tac.
have p2: kq2 <=c kq2 by apply: card_leR; co_tac.
have q2B: inc q2 Bnat by rewrite /q2; fprops.
have kq2B: inc kq2 Bnat by rewrite /kq2; fprops.
have skq2: inc ((succ k) *c q2) Bnat by fprops.
have knz: q2 <> \0c by apply: cpow2_nz.
have le3: (succ kq2) <=c ((succ k) *c q2).
apply /card_le_succ_ltP => //; split; first by co_tac.
rewrite cprodC cprod_via_sum // cprodC -/kq2.
dneg aux1; apply: (@csum_simplifiable_left kq2) => //; fprops.
rewrite -aux1; aw; fprops.
split => //; first by rewrite /l'; Ytac aux => //.
rewrite /l'; Ytac aux => //.
have slB: inc (succ l) Bnat by fprops.
have ckq2: cardinalp kq2 by fprops.
apply /(card_le_succ_ltP _ slB) => //; split => //.
rewrite aux card_succ_pr4// cprodC cprod_via_sum // cprodC -/kq2.
move=> aux2.
move: (csum_simplifiable_left kq2B BS1 q2B aux2) => q21.
move: BS1 (cpow_Mle1 CS2 pz) => oB.
by rewrite -/q2 -q21 - succ_one;move /(card_le_succ_ltP _ 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: inc m2 Bnat 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_le_simplifiable m2) => //.
have : (succ l') <=c (succ l).
apply: (@cprod_le_simplifiable m2) => //; fprops.
have cl: cardinalp l' by fprops.
move /(card_le_succ_succP cl (CS_Bnat lB)) => le6;case: ll'; co_tac.
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.