Library ssete4

Theory of Sets : Exercises sections 4

Copyright INRIA (2009-2013) Apics/Marelle Team (Jose Grimm).

Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Export sset13 ssete3.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Exercise4.

Exercise 4.1. is in file ssete3
Exercise 4.2. A set is finite iff every non-empty subset of the powerset has a maximal element (with respect to inclusion).

Definition meet A B := nonempty (A \cap B).

Lemma finite_is_maximal_inclusion x:
  finite_set x <->
  (forall y, sub y (powerset x) -> nonempty y -> exists2 z,
     inc z y & forall t, inc t y -> sub z t -> z = t).
Proof.
split.
  move: x; apply: finite_set_induction0.
    move=> y yp0 [t ty].
    have yp1: forall v, inc v y -> v = emptyset.
      by move=> v vy; move: (yp0 _ vy); rewrite setP_0 => /set1_P.
    by ex_tac => v vy tv; rewrite (yp1 _ ty) (yp1 _ vy).
  move=> a b hrec nba y yp yne.
  set Z:= Zo y (fun z => inc b z); case: (emptyset_dichot Z) => ze.
    have yp1: sub y (powerset a).
      move => t ty; move: (yp _ ty) => /setP_P ta; apply /setP_P => u ut.
      move: (ta _ ut); case /setU1_P => // ub;empty_tac1 t;apply: Zo_i =>//; ue.
    by apply: hrec.
    set T:= fun_image Z (intersection2 a).
    have Tp: sub T (powerset a).
      move => t /funI_P [z zZ ->]; apply /setP_P;apply: subsetI2l.
    have neT:nonempty T.
      move: ze => [z zZ]; exists (a \cap z); apply /funI_P; ex_tac.
  move: (hrec _ Tp neT)=> [z zT zm].
  move: zT => /funI_P[u uZ iau].
  move: uZ => /Zo_P [uy bu].
  ex_tac; move=> t ty ut.
  have bt: inc b t by apply: ut.
  have tz: inc t Z by apply: Zo_i => //.
  have it: inc (a \cap t) T by apply /funI_P; ex_tac.
  have it1: sub z (a \cap t).
    rewrite iau => w /setI2_P [p1 p2]; apply /setI2_P;split;fprops.
  move: (zm _ it it1) => zi.
  apply: extensionality => // v vt; move: (yp _ ty).
    move /setP_P => tt;move:(tt _ vt); case /setU1_P; last by move => ->.
  by move => va;apply: (@setI2_2 a);rewrite- iau zi; apply:setI2_i.
move=> h.
set F := (finite_subsets x).
have p1:sub F (powerset x) by apply: Zo_S.
have p2: nonempty F.
  exists emptyset; apply:Zo_i; [ apply: setP_0i| apply:emptyset_finite].
move: (h _ p1 p2) => [z /Zo_P [] /setP_P zpo zf zp].
case: (emptyset_dichot (x -s z)) => ce.
  have -> //: x = z by apply:extensionality => //; apply:empty_setC.
move: ce => [y] /setC_P [yx nyz].
set (t:= z +s1 y).
have tF: inc t F.
  by apply:Zo_i; [apply /setP_P; apply: setU1_sub | apply:setU1_finite].
have zt: sub z t by move=> u uz; rewrite /t; fprops.
move: (zp _ tF zt) => tz; case: nyz; rewrite tz /t; fprops.
Qed.

Exercise 4.3 is in file ssete3
Exercise 4.4. Assume that C is a subset of E x E that contains a pair (x , y) if and only if it does not contain (y, x). We can re-order the elements of E as (x(1), x(2), ..., x(n)) so that (x(i),x(i+1)) is in C.

Lemma Exercise4_4 n E C:
  inc n Bnat -> cardinal E = n -> sub C (coarse E) ->
  (forall x y, inc x E -> inc y E -> x <> y ->
    (exactly_one (inc (J x y) C) (inc (J y x) C))) ->
    exists2 f, bijection_prop f (Bintcc \1c n) E &
      (forall i, \1c <=c i -> i <c n ->
        inc (J (Vf f i) (Vf f (succ i))) C).
Proof.
move=> nB cn _; move: n nB E cn C.
have auxP: forall n, inc n Bnat -> forall x,
   (inc x (Bintcc \1c n) <-> (x <> \0c /\ x <=c n)).
  have ob: inc \1c Bnat by fprops.
  move=> n nB x; move:(Bint_pr5 nB) => [pa pb]; split.
     move => pc; split; first by dneg pd; rewrite -pd.
     apply /(BintcP nB); rewrite -pa; fprops.
  move => [pc] /(BintcP nB); rewrite - pa; case /setU1_P => //.
apply: cardinal_c_induction1.
move=> n nB hrec E nE C cp.
case: (emptyset_dichot E) => Ee.
  rewrite -nE Ee cardinal_set0.
  have ->: (Bintcc \1c \0c) = emptyset.
    apply /set0_P => t /(auxP _ BS0) [pa pb].
    case: (card_lt0 (conj pb pa)).
  move: (empty_function_tg_function emptyset).
  set f := empty_function_tg _; move => ww;exists f => //.
    move: ww => [pa pb pc]; split => //.
      split => //; split => //.
      by move => a b; rewrite pb => /in_set0.
      by move => ay; rewrite pc => /in_set0.
  by move => i _ i1; move: (card_lt0 i1).
move: Ee => [a aE].
set E1 := E -s1 a.
have s1:sub (singleton a) E by apply: set1_sub.
set Z1:= Zo E1 (fun z => inc (J z a) C).
set Z2:= Zo E1 (fun z => inc (J a z) C).
have Z1E1: sub Z1 E1 by apply: Zo_S.
have sE1E: sub E1 E by apply: sub_setC.
have Z1E: sub Z1 E by apply: sub_trans sE1E.
have Z2E: sub Z2 E by apply: sub_trans sE1E=>//; apply: Zo_S.
have Z2c: Z2 = E1 -s Z1.
  set_extens t.
    move /Zo_P => [ta tb]; apply /setC_P; split => //; move /Zo_P => [_ tc].
    move /setC_P: ta => [te ] /set1_P tna.
    by move: (cp _ _ te aE tna) => [_]; apply.
  move => /setC_P [te h]; apply /Zo_P;split => //.
  move /setC_P: (te) => [te1 ] /set1_P tna.
  move: (cp _ _ te1 aE tna) => [pa pb]; case: pa => // pc.
  case: h; apply :Zo_i => //.
move: (cardinal_setC s1); rewrite /card_diff cardinal_set1 -/E1.
move: (cardinal_setC Z1E1); rewrite /card_diff -Z2c nE; move => <-.
set n1:= cardinal Z1; set n2:= cardinal Z2; move => rel1.
have fe: finite_set E by red; apply /BnatP; ue.
have n1B: inc n1 Bnat by apply /BnatP; apply: (sub_finite_set Z1E fe).
have n2B: inc n2 Bnat by apply /BnatP; apply: (sub_finite_set Z2E fe).
clear fe.
have aux2: (n1 +c n2) <c n.
  have c1: cardinalp (n1 +c n2) by fprops.
  rewrite -rel1;rewrite (csumC \1c _) - card_succ_pr4 //.
  apply: card_lt_succ; fprops.
have aux3: n1 <=c (n1 +c n2) by apply: csum_M0le; fprops.
have aux4: n2 <=c (n1 +c n2) by rewrite csumC;apply: csum_M0le; fprops.
have ltn1n: n1 <c n by co_tac.
have ltn2n: n2 <c n by co_tac.
clear aux2 aux3 aux4.
have c1p: (forall x y, inc x Z1 -> inc y Z1 -> x <> y ->
  exactly_one (inc (J x y) C) (inc (J y x) C)).
   move=> x y xz1 yz1 xy; apply: (cp _ _ (Z1E _ xz1)(Z1E _ yz1) xy).
have c2p: (forall x y, inc x Z2 -> inc y Z2 -> x <> y ->
    exactly_one (inc (J x y) C) (inc (J y x) C)).
 by move=> x y xz1 yz1 xy; apply: (cp _ _ (Z2E _ xz1)(Z2E _ yz1)).
move: (hrec n2 nB n2B ltn2n Z2 (refl_equal (cardinal Z2)) C c2p).
move: (hrec n1 nB n1B ltn1n Z1 (refl_equal (cardinal Z1)) C c1p).
clear c1p c2p hrec.
move => [f1 [bf1 sf1 tf1] f1p][f2 [bf2 sf2 tf2] f2p].
pose f i := Yo (i = (succ n1)) a
 (Yo (i <=c n1) (Vf f1 i) (Vf f2 (i -c (succ n1)))).
move: (card_lt_succ n1B) => lt1.
have p1: f (succ n1) = a by rewrite /f; Ytac0.
have p2: forall i, i <=c n1 -> f i = Vf f1 i.
  move=> i lei.
  have in1:(i <> succ n1) by move=> h; rewrite -h in lt1;co_tac.
   by rewrite /f; Ytac0; Ytac0.
have p3: forall i, (succ n1) <c i -> f i = Vf f2 (i -c (succ n1)).
  move=> i [lesi nsi]; rewrite /f; Ytac0; Ytac in1 => //.
  have bad: (succ n1) <=c n1 by co_tac.
  co_tac.
have p4: forall i : Set, i <> \0c -> i <=c n1 -> inc (f i) Z1.
  move=> i inz in1; rewrite (p2 _ in1);rewrite -tf1; Wtac; try fct_tac.
  by rewrite sf1; apply /(auxP _ n1B).
move: (BS_succ n1B) => snB.
have nn12: n = ((succ n1) +c n2).
  rewrite csumC csum_via_succ // csumC card_succ_pr4; fprops.
  by rewrite csumC rel1.
have p5: forall i, (succ n1) <c i -> i <=c n ->
   inc (i -c (succ n1)) (source f2).
  move=> i [n1i ni3] n2i; rewrite sf2 ; apply /(auxP _ n2B).
  move: (cdiff_pr0 (BS_le_int n2i nB) snB n1i).
  set d := _ -c _ ; move=> [sB sv]; split.
    dneg dz; rewrite - sv dz; aw;co_tac.
  apply: (csum_le_simplifiable snB) => //; rewrite sv -nn12//.
have p6: forall i, (succ n1) <c i -> i <=c n ->
   inc (f i) Z2.
  move=> i in1 lin; rewrite (p3 _ in1) -tf2; Wtac; try fct_tac.
set sf3 :=(Bintcc \1c n).
have ta: forall i, inc i sf3 -> inc (f i) E.
  move=> i /(auxP _ nB) [inz lein].
  have ci: cardinalp i by co_tac.
  have cn: cardinalp (succ n1) by fprops.
  case: (card_le_to_el ci cn)=> aux1; last by apply: Z2E;apply: p6.
  case: (equal_or_not i (succ n1)) => is1; first by rewrite is1 p1.
  have : i <c (succ n1) by split.
   by move /(card_lt_succ_leP n1B); move => lin1; apply: Z1E; apply: p4.
set F := Lf f sf3 E.
have sF: source F = sf3 by rewrite /F; aw.
have tF: target F = E by rewrite /F; aw.
have fF: function F by apply: lf_function.
have fpF: function_prop F sf3 E by [].
have surjF: surjection F.
  apply: lf_surjective => // y yE.
  case: (equal_or_not y a).
    move=> ->; exists (succ n1) => //; apply /(auxP _ nB); split.
      apply: succ_nz.
    by apply /card_le_succ_ltP.
  move=> ya; move: (cp _ _ yE aE ya) => [p7 _]; case: p7 => pc.
    have yz1: inc y Z1 by apply: Zo_i => //; apply /setC1_P;split => //.
    move: yz1; rewrite -tf1 => yt1.
    move: bf1 => [_ srf1]; move: ((proj2 srf1) _ yt1) => [x xf1 <-].
    move: xf1; rewrite sf1; move /(auxP _ n1B)=> [xnz xn1].
    exists x; last by rewrite p2.
     apply /(auxP _ nB);split => //; move: ltn1n => [len1n _]; co_tac.
  have yz2: inc y Z2 by apply: Zo_i => //; apply/ setC1_P.
  move: yz2; rewrite -tf2 => yt2.
  move: bf2 => [_ srf2]; move: ((proj2 srf2) _ yt2) => [x xf2 <-].
  move: xf2; rewrite sf2; move /(auxP _ n2B) => [xnz xn2].
  move: (BS_le_int xn2 n2B) => xB.
  move: (cdiff_pr1 xB snB).
  set x1:= x +c (succ n1) => x1n1.
  have x1p: (succ n1) <c x1.
    have ->: (succ n1) = \0c +c (succ n1) by aw; fprops.
    rewrite /x1; apply: csum_Mlteq => //; fprops.
    by apply /strict_pos_P => //; apply:nesym.
  exists x1; last by rewrite (p3 _ x1p) x1n1.
  apply /(auxP _ nB); split.
    move=> h; rewrite h in x1p; apply: (card_lt0 x1p).
    rewrite /x1 nn12 csumC;apply: csum_Mlele => //; fprops.
exists F => //.
  split => //.
  apply: bijective_if_same_finite_c_surj => //.
    by rewrite /F lf_source lf_target /sf3 nE card_Bint1c.
    by rewrite /F lf_source /sf3 /finite_set (card_Bint1c nB); apply /BnatP.
move=> i i1 iN.
have inz: i <> \0c by move /card_ge1P: i1 => [_ /nesym].
move: (iN) => [lein _ ]; move: (BS_le_int lein nB) => iB.
have i3: inc i sf3 by apply /(auxP _ nB).
have si3: inc (succ i) sf3.
  by apply /(auxP _ nB); split; [ apply: succ_nz | apply /card_le_succ_ltP].
rewrite /F lf_V // lf_V //.
have ci: cardinalp i by co_tac.
have cn: cardinalp (succ n1) by fprops.
case: (card_le_to_el ci cn) => aux1.
  case: (equal_or_not i (succ n1)) => in1.
    have ltss: (succ n1) <c (succ (succ n1)) by apply: card_lt_succ.
    rewrite in1 p1 p3 //.
    have ->: (succ (succ n1)) -c (succ n1) = \1c.
      rewrite (card_succ_pr4 cn) csumC; apply: cdiff_pr1; fprops.
    have: inc (Vf f2 \1c ) Z2.
      Wtac ; first by fct_tac.
      rewrite sf2; apply /(auxP _ n2B);split;fprops; apply:card_ge1; fprops.
      move=> n2z; move: nn12; rewrite n2z; aw; rewrite -in1.
      by move: iN => [_ din] ein; case: din.
    by move => /Zo_hi.
  have lein1: i <=c n1 by apply /(card_lt_succ_leP n1B); split.
  case: (equal_or_not i n1) => eqin1.
    have n11: n1 <=c n1 by fprops.
    rewrite eqin1 p1 p2 //.
    have: (inc (Vf f1 n1) Z1).
      Wtac; first by fct_tac.
      rewrite sf1; apply /(auxP _ n1B); split => //;ue.
    by move /Zo_hi.
  have sin1: (succ i) <=c n1 by apply /card_le_succ_ltP.
  rewrite p2 // p2 //; apply: f1p => //.
have p7: (succ n1) <c (succ i).
  move: (card_le_succ iB) => aux3; co_tac.
rewrite p3 // p3 //.
move: (aux1) => [aux2 _].
move: (cdiff_pr0 iB snB aux2).
set k:= i -c (succ n1); move => [kB kp].
have ->: (succ i) -c (succ n1) = succ k.
  rewrite - csucc_diff // cdiff_pr6//.
apply: f2p.
  apply: card_ge1; fprops.
  by move=> kz; move:kp aux1; rewrite kz; aw; move=> ->; by case.
by apply: (csum_lt_simplifiable snB) => //;rewrite kp -nn12.
Qed.

Exercise 4.5. Let E be an ordered set, k the maximal number of elements in a free subset. Then E can be partitioned into k totally ordered subsets.
Definitions: Hw(k) says that any free subset has at most k elements, H(k) says moreover that there is a free subset with k elements. Cw(k) says that there exists at most k totally ordered, mutually disjoint sets whose union is E, C(k) says that this number is exactly k, and the sets are non-empty. The claim is H(k) implies C(k). We can restate it as Hw(k) implies Cw(k). Note that if we have a free subset with k elements, each element of the partition contains at most one element of the free subset, so that if Cw(k) holds, there are k sets, none of them is empty.
Lemma: a finite non-empty set has a minimal element.
Assume T is a subset of a set partitioned by Y, both sets have the same finite number of elements; assume that the intersection of T and each Yi is empty or a singleton. Then it is never empty.

Lemma finite_set_minimal r:
  order r ->finite_set (substrate r) -> nonempty (substrate r) ->
  exists x, minimal r x.
Proof.
move => or.
move: (opp_osr or) => [or' sr'].
rewrite - sr' => fsr nes.
move: (finite_set_maximal or' fsr nes) => [x xf]; exists x.
by apply /maximal_opp.
Qed.

Definition Exercise4_5_hyp r k :=
  (exists2 x, inc x (free_subsets r) & cardinal x = k) /\
  (forall x, inc x (free_subsets r) -> (cardinal x) <=c k).
Definition Exercise4_5_conc r k :=
  exists X, [/\ partition_s X (substrate r), cardinal X = k &
    forall x, inc x X -> total_order (induced_order r x)].

Lemma Exercise4_5a Y T k:
  cardinal Y = k -> cardinal T = k -> inc k Bnat ->
  sub T (union Y) ->
  (forall a b : Set, inc a Y -> inc b Y -> a = b \/ disjoint a b) ->
  (forall Z, inc Z Y -> small_set (T \cap Z)) ->
  (forall Z, inc Z Y -> singletonp (T \cap Z)).
Proof.
move => cY cT kB Tu ald als.
set V1 := Zo Y (fun z => (T \cap z) <> emptyset).
set V2 := Lg V1 (fun z => (T \cap z)).
move=> Z ZY; case: (small_set_pr (als _ ZY)) => //.
move=> itz.
have s1: sub V1 Y by apply: Zo_S.
have fsy: finite_set Y by apply /BnatP; rewrite cY.
have xy: V1 <> Y.
    move=> TZ; move: ZY;rewrite -TZ; move /Zo_P => [_ bad]; contradiction.
move: (strict_sub_smaller (conj s1 xy) fsy) => [_ bad] {itz s1 xy fsy ZY}.
case: bad.
have v1p: forall x, inc x V1 -> cardinal (Vg V2 x) = \1c.
  move=> x xV1; rewrite /V2; bw.
  move: xV1 => /Zo_P [zY ine].
  case: (small_set_pr (als _ zY));first by move=> aux; contradiction.
  by move=> [y] ->; rewrite cardinal_set1.
move: (csum_of_ones V1); rewrite /card_sum.
rewrite /disjointU.
set duf:= disjointU_fam _ ;set D:= unionb _.
move: (cardinal_pr D); move=> pa pb.
rewrite cY - cT; apply /card_eqP.
eqtrans D; first by move: pb; move /card_eqP; eqsym.
clear pa pb.
have pa: fgraph duf by rewrite /duf/disjointU_fam; fprops.
have pb:fgraph V2 by rewrite /V2; fprops.
have pc: domain duf = domain V2 .
  rewrite /duf/disjointU_fam/V2/cst_graph; bw.
have pd: (forall i, inc i (domain duf) -> equipotent (Vg duf i) (Vg V2 i)).
  rewrite /duf/disjointU_fam/V2/cst_graph; bw.
  move=> i iV1; bw; eqtrans \1c; first by eqsym; fprops.
  apply /card_eqP; rewrite -(v1p _ iV1) double_cardinal /V2; bw.
have pe: mutually_disjoint duf.
  apply: disjointU_disjoint; rewrite /cst_graph; fprops.
have pf: mutually_disjoint V2.
  rewrite /V2; apply: mutually_disjoint_prop2.
  move=> i j y => /Zo_S iY /Zo_S jY /setI2_P [_ yi] /setI2_P [_ yj].
  case: (ald _ _ iY jY) => // di; empty_tac1 y.
move: (equipotent_disjointU (conj pc pd) pe pf).
have ->: unionb V2 = T => //.
rewrite /V2;set_extens t.
  by move /setUb_P; bw; move => [y yv1]; bw; move /setI2_P => [].
move=> tT; move: (Tu _ tT) => /setU_P [y ty yY].
have tv: inc t (T \cap y) by apply: setI2_i.
have nei: nonempty (T \cap y) by exists t.
have yv1: inc y V1 by apply: Zo_i => //; apply /nonemptyP.
apply/setUb_P;exists y; bw.
Qed.

Proof by induction on the cardinal of E, when it is finite.

Lemma Exercise4_5b r k: finite_set (substrate r) ->
  order r -> inc k Bnat -> Exercise4_5_hyp r k -> Exercise4_5_conc r k.
Proof.
move /BnatP; set n := cardinal (substrate r).
move: (refl_equal n); rewrite {2} /n.
move: n; move=> n nc nB; move: n nB r k nc; apply: cardinal_c_induction1.
move=> n nB hrec r k csr or kB [[X Xf cX] h2].
The case where E is empty is trivial
case: (emptyset_dichot (substrate r)) => sre.
  move: Xf => /Zo_P []; rewrite /Exercise4_5_conc sre; move /setP_P => Xse _.
  exists emptyset => //;split.
      split;last by move=> a /in_set0.
      by split => //; try split => //; [rewrite setU_0 |move=> a b /in_set0].
    by move/sub_set0: Xse => <-.
  by move=> x /in_set0.
Assumption: we have a free set X with k elements, all other free subsets have at most k elements. We have chosen an element a, the complementary is E'. The results holds, for any k, on sets with less than n elements. In particular, if no free subset of E' has k elements, we can partition E' in k-1 subsets, and add (singleton a) as last set.
have fse: finite_set (substrate r) by red;rewrite - csr; apply /BnatP; fprops.
move: (finite_set_minimal or fse sre) => [a [asr amin]].
move: (card_succ_pr1 (substrate r) a).
rewrite (setC1_K asr) - csr; set E':= _ -s1 _ => eq1.
set r' := induced_order r E'.
have sE': sub E' (substrate r) by apply: sub_setC.
move: (iorder_osr or sE')=> [or' sr'].
set p1:= (cardinal E').
have p1c: p1 = (cardinal (substrate r')) by ue.
move: eq1; rewrite -/p1 => le1.
have cp: cardinalp p1 by rewrite /p1;fprops.
have p1B: inc p1 Bnat by apply/BnatP /(finite_succP cp)/BnatP; rewrite - le1.
 move: (card_lt_succ p1B); rewrite -le1 => p1n {le1 cp}.
have fsE: forall T, inc T (free_subsets r') -> inc T (free_subsets r).
  move=> T /Zo_P [] /setP_P p3 p2; apply /Zo_P;split.
    apply /setP_P; apply: (sub_trans _ sE'); ue.
  move => x y xt yt lexy;apply: p2=> //.
  by apply /iorder_gleP => //;rewrite - sr'; apply: p3.
have h21: forall x, inc x (free_subsets r') -> (cardinal x) <=c k.
  by move=> x xsr; apply: h2; apply: fsE.
rewrite - sr' in sE'.
case: (p_or_not_p (exists2 X',
   inc X' (free_subsets r') & cardinal X' = k)); last first.
  move=> ne.
  set X1 := X -s1 a.
  have X1f: inc X1 (free_subsets r').
    move: Xf => /Zo_P [] /setP_P p3 p2; apply /Zo_P; split.
      apply /setP_P; rewrite sr' => t; move /setC1_P=> [tX ta].
      by apply /setC1_P;split => //; apply: p3.
    move=> u v => /setC1_P [uX _] /setC1_P [vX _] uv.
    by move: (iorder_gle1 uv);apply: p2.
  case: (inc_or_not a X) => aX; last first.
    by case: ne; exists X => //; rewrite - (setC1_eq aX).
  move: (card_succ_pr1 X a); rewrite setC1_K // -/X1 cX.
  set k1:= (cardinal X1) => ks.
  have kB': inc k1 Bnat by apply: BS_nsucc; rewrite /k1; fprops; ue.
  have krec: Exercise4_5_hyp r' k1.
    split; first by exists X1.
    move=> x xsr'; move: (h21 _ xsr') => le1.
    have: (cardinal x) <c k.
      split => //; move=> xk; case: ne; ex_tac.
    by rewrite ks; move /(card_lt_succ_leP kB').
  move: (hrec p1 nB p1B p1n _ _ p1c or' kB' krec)
      => [Y [[[uY adi] ane] cY altY]].
  have nauy: ~(inc a (union Y)).
     by rewrite uY sr' /E'; move /setC1_P => [_].
  have nsY: ~ inc (singleton a) Y.
    move=> say; case: nauy; apply: (@setU_i _ (singleton a)); fprops.
  move: (card_succ_pr nsY); rewrite cY -ks => p3.
  set Y' := (Y +s1 (singleton a)).
  have pr1: union Y' = substrate r.
    set_extens t.
      move=> /setU_P [y ty];case /setU1_P => tY.
        apply: sE'; rewrite -uY; union_tac.
      by move: ty; rewrite tY; move /set1_P => ->.
    move=> tsr; case: (equal_or_not t a) => ta.
      rewrite /Y' - ta;apply /setU_P; exists (singleton t);fprops.
    have: inc t (substrate r') by rewrite sr'; apply /setC1_P; fprops.
    rewrite /Y' -uY => /setU_P [y ty uyY]; union_tac.
  have pr2: forall u v, inc u Y' -> inc v Y' -> u = v \/ disjoint u v.
    move => u v; case /setU1_P => us; case /setU1_P => vs.
        by apply: adi.
      right; rewrite vs; apply: disjoint_pr => t tu /set1_P ta.
      case: nauy; rewrite -ta; union_tac.
    right; rewrite us; apply: disjoint_pr => t /set1_P ta tu.
    case: nauy; rewrite -ta; union_tac.
    by left;rewrite us vs.
  have pr3: alls Y' nonempty.
   move=> u; case /setU1_P; [ by apply: ane| move=> ->; apply: set1_ne].
  exists (Y +s1 (singleton a)); split => //.
  move => x ;case /setU1_P => xy.
    have sx: sub x (substrate r') by rewrite -uY; apply: setU_s1.
    have sx1: sub x (substrate r).
      by apply: (@sub_trans (substrate r')) => //; rewrite sr' //.
    move: (altY _ xy) => []; aw => orx torx.
    move: (iorder_osr or sx1) => [pa pb].
   split => //; rewrite pb=> y z yx zx; case: (torx _ _ yx zx) => le1.
      by left; apply /iorder_gleP => //;move: (iorder_gle1(iorder_gle1 le1)).
      by right; apply /iorder_gleP => //;move: (iorder_gle1(iorder_gle1 le1)).
   have xsr: sub x (substrate r) by rewrite xy; apply: set1_sub.
   move: (iorder_osr or xsr) => [pa pb].
   split => //; rewrite pb xy;move=> y z.
   by move =>/set1_P -> /set1_P ->; left; apply /iorder_gleP; fprops; order_tac.
We assume now that there is a free subset with k elements in E' and partition E' into k parts. Let f T be the set of elements of T that are >= a. Assume that there is Z in the partition such that any free subset that contains no element of f Z has less than k elements. By induction we partition the complement of f Z into k-1 sets, and add f Z as last set.
move=> h22.
have krec: Exercise4_5_hyp r' k by [].
move: (hrec p1 nB p1B p1n _ _ p1c or' kB krec)=> [Y [[[uY adi] ane] cY altY]].
pose f T := Zo T (fun z => gle r a z).
case: (p_or_not_p (exists2 Z, inc Z Y &
   forall T, inc T (free_subsets (induced_order r (E' -s (f Z))))
     -> (cardinal T) <c k)).
  move => [Z ZY hZ].
  set E'':= (E' -s (f Z)).
  set r'':= induced_order r E''.
  have sEs: sub E'' (substrate r).
    apply: (@sub_trans E') => //; apply: sub_setC.
  move: (iorder_osr or sEs) => [or'' sr''].
  set X1:= X \cap (E' -s (f Z)).
  have X1f: inc X1 (free_subsets r'').
    apply: Zo_i; first by apply /setP_P; rewrite sr''; by apply: subsetI2r.
    move=> x y /setI2_P [xX _] /setI2_P [yX _] le1.
    move: Xf => /Zo_P [p3 p2].
     move: (iorder_gle1 le1) => le2; by apply: p2.
  move: (hZ _ X1f) => le1.
  have knz: k <> \0c.
    move=> kz; rewrite kz in le1; case: (card_lt0 le1).
  move: (cpred_pr kB knz); set k1 := cpred k; move => [k1B k1s].
  have krec1: Exercise4_5_hyp r'' k1.
    split; last first.
       by move=> x xr; move: (hZ _ xr);rewrite k1s; move/(card_lt_succ_leP k1B).
    move: Xf => /Zo_P [] /setP_P aa bb.
    have cXp: forall x, inc x (X -s X1) ->
      (inc x X /\ (x = a \/ (inc x Z /\ gle r a x))).
      move=> x /setC_P [xX] /setI2_P => x1.
      split => //; case: (equal_or_not x a) => xa;first by left.
      right; ex_middle aux; case: x1; split => //; apply /setC_P;split => //.
             by apply /setC1_P;split => //; apply: aa.
       by apply /Zo_P.
    have sc: small_set (X -s X1).
      move=> x y xc yc; move: (cXp _ xc) (cXp _ yc) => [xX ex] [yX ey].
      case: ex => xp; case: ey => yp.
            rewrite xp yp //.
          by move: yp; rewrite -xp; move => [_ xy]; apply: bb.
        by symmetry;move: xp; rewrite -yp; move => [_ xy]; apply: bb.
      move: xp yp => [xz _] [yz _].
      have Zs: sub Z (substrate r') by rewrite -uY; apply: setU_s1.
      move: (altY _ ZY) => [orz]; aw => aux.
      case: (aux _ _ xz yz) => le2; move: (iorder_gle1 (iorder_gle1 le2)) => le3.
         by apply: bb.
      by symmetry; apply: bb.
    have X1c: sub X1 X by apply: subsetI2l.
    move: (cardinal_setC X1c); rewrite cX k1s.
    have cX1: cardinalp (cardinal X1) by fprops.
    case: (small_set_pr sc) => cp1.
      rewrite /card_diff cp1 cardinal_set0 csum0r //.
      by move=> le2; move: le1; rewrite le2 -k1s; move => [_ bad]; case: bad.
    rewrite /card_diff; move: cp1; move=> [x] ->.
    rewrite cardinal_set1 - card_succ_pr4 // => ssc.
    have ck: cardinalp k1 by fprops.
    by exists X1 => //; apply: succ_injective1.
  set p2 := cardinal (E' -s (f Z)).
  have p2c: p2 = cardinal (substrate r'') by ue.
  have ee'': sub E'' E' by apply: sub_setC.
  move: (sub_smaller ee''); rewrite -/p1 -/p2 => p12.
  have p2n: p2 <c n by co_tac.
  have p2B: inc p2 Bnat by apply: (BS_le_int p12 p1B).
  move: (hrec p2 nB p2B p2n _ _ p2c or'' k1B krec1)
    => [Y' [[[uY' adi'] ane'] cY' altY']].
  set U1 := (f Z) +s1 a.
  have nauy: ~(inc a (union Y')).
     by rewrite uY' sr''; move /setC_P => [] /setC1_P [_].
  have nsY: ~ inc U1 Y'.
    move=> say; case: nauy; apply: (@setU_i _ U1); rewrite /U1;fprops.
  move: (card_succ_pr nsY); rewrite cY' -k1s => p3.
  have Zr': sub Z (substrate r') by rewrite -uY; apply: setU_s1.
  have Zr: sub Z (substrate r) by apply: (@sub_trans (substrate r')).
  have U1r: sub U1 (substrate r).
    move=> t;case /setU1_P ; last by move => ->.
    by move /Zo_P => [tz _]; apply: Zr.
  set Y'' := Y' +s1 U1.
  have pr1:union Y'' = substrate r.
    set_extens t.
      move=> /setU_P [y ty /setU1_P[]]=> tY.
        apply: sEs; rewrite - sr'' -uY'; union_tac.
         move: ty; rewrite tY;apply: U1r.
      move=> tsr; apply /setU_P;case: (equal_or_not t a) => ta.
      rewrite ta/Y'';exists U1 => //; rewrite /U1;fprops.
    have tE': inc t E' by apply /setC1_P; split.
    case: (inc_or_not t (f Z)) => tf.
      exists U1 => //; rewrite /Y''/U1;fprops.
    have : inc t E'' by apply /setC_P; split.
    rewrite - sr'' -uY'/Y'';move=> /setU_P [y ty yy]; exists y; fprops.
  have aux: forall u,inc u Y' -> disjoint u U1.
      move => u uy; rewrite /U1;apply: disjoint_pr => t tu /setU1_P ta.
      have : inc t (union Y') by union_tac.
      case: ta; last by move => ->;by apply: nauy.
      by rewrite uY' sr'' => tf; move /setC_P => [_]; case.
  have pr2:forall u v, inc u Y'' -> inc v Y'' -> u = v \/ disjoint u v.
    move => u v;case /setU1_P => us; case /setU1_P => vs.
        by apply: adi'.
      by right; rewrite vs; apply: aux.
    by right; apply /disjoint_S;rewrite us; apply: aux.
    by left;rewrite us vs.
  have pr3: alls Y'' nonempty.
    move=> u; case /setU1_P; [ by apply: ane'| move=> ->; exists a].
    rewrite /U1;fprops.
  exists (Y''); split => //.
  move => x;case /setU1_P => xy.
    have sx: sub x (substrate r'') by rewrite -uY'; apply: setU_s1.
    have sx1: sub x (substrate r).
      by apply: (@sub_trans (substrate r'')) => //; rewrite sr'';apply: sEs.
    move: (altY' _ xy) => []; aw => orx torx.
    move: (iorder_osr or sx1) => [pa pb].
    split => //; rewrite pb=> y z yx zx; case: (torx _ _ yx zx) => le2.
      by left; apply /iorder_gleP => //; move: (iorder_gle1 (iorder_gle1 le2)).
    by right;apply /iorder_gleP => //; move: (iorder_gle1(iorder_gle1 le2)).
  move: (iorder_osr or U1r) => [pa pb].
  rewrite xy; split => //; rewrite pb; move=> x1 y1 x1u y1u.
  suff: ocomparable r x1 y1.
    case => cp; [left | right]; apply /iorder_gleP => //.
  red;move: (altY _ ZY) => [_]; aw; move=> torz.
  move: x1u y1u; case /setU1_P=> x1p; case /setU1_P => y1p.
        move: x1p y1p => /Zo_S a1 /Zo_S a2.
        case:(torz _ _ a1 a2) => ax; move: (iorder_gle1(iorder_gle1 ax));fprops.
      by rewrite y1p; move: x1p => /Zo_hi; right.
    by rewrite x1p; move: y1p => /Zo_hi; left.
  by rewrite x1p y1p; left; order_tac.
For each Z in the partition Y, there is g Z a free subset with k elements in the complement of f Z
pose io Z := (induced_order r (E' -s (f Z))).
move=> bad.
have Zp1: forall Z, sub (E' -s (f Z)) (substrate r).
  move=> Z ;by apply: (@sub_trans E'); [ apply: sub_setC | ue].
have Zp2: forall Z, substrate (io Z) = E' -s (f Z).
   by move => Z;rewrite /io; aw.
have sfr: forall Z T, inc Z Y ->
  inc T (free_subsets (io Z)) -> inc T (free_subsets r).
  move=> Z T ZY /Zo_P [] /setP_P pa pb; apply /Zo_P.
  move: (Zp1 Z)(Zp2 Z) => pc pd; rewrite pd in pa.
  split; first by apply /setP_P;apply: (@sub_trans (E' -s (f Z))).
  by move=> x y xT yT xy; apply: pb => //; apply /iorder_gleP => //; apply: pa.
have good: forall Z, inc Z Y -> exists2 T,
     inc T (free_subsets (io Z)) & cardinal T = k.
  move => Z ZY; ex_middle bad2.
  case: bad; exists Z => // => T Tf.
  move: (sfr _ _ ZY Tf) => f1.
  split; first by apply: (h2 _ f1).
  case: (equal_or_not (cardinal T) k) => // Tk; case: bad2; ex_tac.
pose g Z := choose(fun T => inc T (free_subsets(io Z)) /\ cardinal T = k).
have gp1: forall Z, inc Z Y ->
  (inc (g Z) (free_subsets (io Z)) /\ cardinal (g Z) = k).
  by move=> Z /good [t ta tb]; apply choose_pr; exists t.
clear bad good.
Let W the set of all free subsets of E' that have k elements. Then g Z is in W. An element of W intersects Z at most once. By the previous lemma, the intersection of g Z and T is a singleton say sij Z T, whenever Z and T are in the partition. The relations (sij Z T) <= a are false; as well as a <= (sij Z Z).

pose krec1 T:= [/\ inc T (free_subsets r), sub T E' & cardinal T = k].
have gp2: forall Z, inc Z Y -> krec1 (g Z).
  move=> Z ZY; move: (gp1 _ ZY) => [pa pb]; split => //.
    apply: (sfr _ _ ZY pa).
  move: pa =>/Zo_P [] /setP_P pa _.
  apply: (@sub_trans (substrate (io Z))) => //.
  rewrite /io; aw; apply: sub_setC.
have gp3: forall T Z, krec1 T -> inc Z Y -> small_set (T \cap Z).
  move=> T Z [pa pb pc] ZY x y /setI2_P [xT xZ] /setI2_P [yT yZ].
  have Zr': sub Z (substrate r') by rewrite -uY; apply: setU_s1.
  have Zr: sub Z (substrate r) by apply: (@sub_trans (substrate r')).
  move: pa => /Zo_P [_ aux2].
  move: (altY _ ZY) => [_]; aw;move=> tor; case: (tor _ _ xZ yZ)=> aux.
    by move: (iorder_gle1 (iorder_gle1 aux)); apply: aux2.
    by symmetry; move: (iorder_gle1 (iorder_gle1 aux)); apply: aux2.
have gp4: forall T Z, krec1 T -> inc Z Y ->
    singletonp (T \cap Z).
  move => T Z kr; move: (kr) => [kt1 kt2 kt3].
  have stu: sub T (union Y) by rewrite uY sr'.
  apply: (Exercise4_5a cY kt3 kB stu adi).
  move=> z zy;apply: (gp3 _ _ kr zy).
pose sij z1 z2 := union ((g z1) \cap z2).
have sijp: forall z1 z2, inc z1 Y -> inc z2 Y ->
   (g z1) \cap z2 = singleton (sij z1 z2).
  move=> z1 z2 z1Y z2Y; rewrite /sij; move: (gp4 _ _ (gp2 _ z1Y) z2Y) => [s] ->.
  by rewrite setU_1.
have sij1: forall i j, inc i Y -> inc j Y -> inc (sij i j) (g i).
   move => i j iY jY; apply: (@setI2_1 _ j).
   rewrite (sijp _ _ iY jY); fprops.
have sij2: forall i j, inc i Y -> inc j Y -> inc (sij i j) j.
   move => i j iY jY; apply: (@setI2_2 (g i)).
   rewrite (sijp _ _ iY jY); fprops.
have sija1: forall i j, inc i Y -> inc j Y -> gle r (sij i j) a-> False.
  move=> i j iY jY; move: (sij1 _ _ iY jY) => aux2.
  move: (gp1 _ iY) => [] /Zo_P [] /setP_P; rewrite /io; aw=> s1 _.
  move: (s1 _ aux2) => /setC_P [] /Zo_P [pa] /set1_P pb pc _.
  by move => aux1; move: (amin _ aux1).
have sija2: forall i, inc i Y-> gle r a (sij i i) -> False.
  move=> i iY; move: (sij1 _ _ iY iY) => pa pc.
  move: (gp1 _ iY) => [] /Zo_P [] /setP_P; rewrite /io; aw=> s1 _.
  move: (s1 _ pa) => /setC_P [] /Zo_P [pb] /set1_P pe pd _.
  by case: pd; apply: Zo_i=> //; apply: sij2.

Fix T; consider the least of the sij Z T. This exists, since we consider a non-empty finite subset of a totally ordered set. This gives some sj T. These elements are all distinct. Together with a, we get a free subset with k+1 elements, absurd.
pose V1 j:= fun_image Y (fun i => sij i j).
pose sj j := the_least (induced_order r (V1 j)).
have v1p: forall j, inc j Y ->
   let r1 := (induced_order r (V1 j)) in
     [/\ order r1, substrate r1 = V1 j & least r1 (sj j)].
  move=> j jY r1.
  have s1: sub (V1 j) j.
    move => t /funI_P [z zY ->]; apply: (sij2 _ _ zY jY).
  have s0: sub j (substrate r').
    move=> t tj;rewrite -uY; union_tac.
  move: (sub_trans s1 s0) => s2.
  move: (sub_trans s2 sE') => s3.
  move: (sub_trans s0 sE') => s4.
  move: (iorder_osr or s3) => [or1 pb].
  have ne1: nonempty (V1 j) by exists (sij j j); apply /funI_P; ex_tac.
  have fs1: finite_set (V1 j) by apply: ( sub_finite_set s3 fse).
  rewrite /r1;split => //; aw; apply: the_least_pr => //.
  have s5: sub (V1 j) (substrate (induced_order r j)) by aw.
  move: (altY _ jY) => to1.
  rewrite - (iorder_trans r s1).
  apply: finite_subset_torder_least => //.
  rewrite - (iorder_trans r s0) sr'//.
have v2p: forall i j, inc i Y -> inc j Y ->
   gle r (sj i) (sj j) -> i = j.
  move=> i j iY jY leij.
  move: (v1p _ iY) (v1p _ jY) => [o1 sr1 le1][o2 sr2 le2].
  move: le1 => []; rewrite sr1; move /funI_P => [z zY sa] _.
  have sb: inc (sij z j) (substrate (induced_order r (V1 j))).
    rewrite sr2; apply /funI_P; ex_tac.
  move:le2 => [le3 le4]; move: (le4 _ sb) => le5.
  move: (order_transitivity or leij (iorder_gle1 le5)); rewrite sa => le6.
  move: (sijp _ _ zY iY)(sijp _ _ zY jY) => s1 s2.
  move: (gp2 _ zY) => [fk _]; move: fk => /Zo_P [_ fk2].
  move: (fk2 _ _ (sij1 _ _ zY iY) (sij1 _ _ zY jY) le6).
  move: (sij2 _ _ zY iY) (sij2 _ _ zY jY) => i1 i2 sv.
  case: (adi _ _ iY jY) => //; rewrite /disjoint => di.
  empty_tac1 (sij z i); apply: setI2_i => //; ue.
set V2 := fun_image Y sj.
have sii: forall j, inc j Y-> exists2 i, inc i Y & sj j = sij i j.
  move=> j jY; move: (v1p _ jY) => [pa pb [pc pd]].
    move:pc; rewrite pb => /funI_P [z zY ->]; ex_tac.
have v3p: forall j, inc j Y -> inc (sj j) (substrate r).
  move=> l lY;move: (sii _ lY) => [j jY ->].
  apply: sE'; rewrite -uY; move: (sij2 _ _ jY lY) => su; union_tac.
have c2: cardinal V2 = k.
   symmetry; rewrite - cY; apply /card_eqP.
   exists (Lf sj Y V2); hnf; rewrite lf_source lf_target; split => //.
   apply: lf_bijective.
      move=> t TY; apply /funI_P; ex_tac.
    move=> u v uY1 vY ss; apply: (v2p _ _ uY1 vY); rewrite - ss; order_tac.
    by apply: v3p.
  by move => y /funI_P.
set v3:= V2 +s1 a.
have an2: ~ (inc a V2).
  move=> /funI_P [z zY]; move: (sii _ zY) => [j jY] -> ta.
  by case: (sija1 _ _ jY zY); rewrite - ta; order_tac.
move: (card_succ_pr an2); rewrite c2;set (V3:= V2 +s1 a) => bad1.
have V3t: inc V3 (free_subsets r).
  apply: Zo_i.
    apply /setP_P => t; case /setU1_P; last by move => ->.
    by move=> /funI_P [z zY ->];apply: v3p.
  move=> x y ; case /setU1_P => pa; case /setU1_P => pb.
  move: pa pb => /funI_P [z zY ->] /funI_P [z' zY' ->].
        by move=> aux; rewrite (v2p _ _ zY zY' aux).
      rewrite pb; move: pa => /funI_P [z zY ->].
      move: (sii _ zY) => [j jY ->] le1.
      case: (sija1 _ _ jY zY le1).
    rewrite pa; move: pb => /funI_P [z zY ->].
    move: (v1p _ zY) => [qa qb [qc qd]] asj; rewrite qb in qd.
    have sb: inc (sij z z) (V1 z) by apply /funI_P; ex_tac.
    move: (order_transitivity or asj (iorder_gle1 (qd _ sb))) => le2.
    case: (sija2 _ zY le2).
  by rewrite pa pb.
move: (h2 _ V3t); rewrite bad1; move: (card_lt_succ kB) => pa pb; co_tac.
Qed.

Corollary: Assume E finite. Then Hw(k) implies Cw(k).

Lemma Exercise4_5c r k:
  finite_set (substrate r) -> order r -> inc k Bnat ->
  (forall x, inc x (free_subsets r) -> (cardinal x) <=c k) ->
  exists X, [/\ (cardinal X) <=c k,
    union X = (substrate r),
    (forall a b, inc a X -> inc b X -> disjointVeq a b) &
    (forall x, inc x X -> total_order (induced_order r x))].
Proof.
move=> fsr or kB h1.
set T := fun_image (free_subsets r) cardinal.
have neT: nonempty T.
  exists \0c; apply /funI_P; exists emptyset; rewrite ? cardinal_set0 //.
   apply: Zo_i; first by apply /setP_P;fprops.
   by move=> x y /in_set0.
have zb: inc \0c Bnat by fprops.
have sT: sub T (Bintcc \0c k).
  by move=> x /funI_P [z zf ->];apply /BintcP => //; apply: h1.
move: (Binto_wor \0c k) => [hh sio].
move: (worder_total hh) => iot.
move: (iot) => [ior _].
rewrite - sio in sT.
have fss: finite_set (substrate (Bint_cco \0c k)).
  rewrite sio; apply : finite_Bintcc.
move: (sub_finite_set sT fss) => fst.
move: (finite_subset_torder_greatest iot fst sT neT) => [x [xs xg]].
move: xs;aw => /funI_P pa.
have hyp: Exercise4_5_hyp r x.
  split; first by move:pa => [z p1 p2]; ex_tac.
  move => y yf.
  have ct: inc (cardinal y) T by apply /funI_P; ex_tac.
  move: xg; aw; move=> h; move: (h _ ct) => h2; move: (iorder_gle1 h2).
   by move /Binto_gleP => [_ _].
have lxk:x <=c k by move: (proj1 hyp)=> [z zs cs]; ue.
have xB: inc x Bnat by apply: (BS_le_int lxk kB).
move: (Exercise4_5b fsr or xB hyp) => [X [[[p1 p2] p3] p4 p5]].
by exists X;split => //; rewrite p4.
Qed.

Proof by induction on k in the general case; k=0 is trivial

Lemma Exercise4_5d r k:
  order r -> inc k Bnat -> Exercise4_5_hyp r k -> Exercise4_5_conc r k.
Proof.
move=> or kB; move: k kB r or.
apply:cardinal_c_induction.
  move=> r or [hyp1 hyp2]; exists emptyset.
  case: (emptyset_dichot (substrate r)).
     move => ->; rewrite cardinal_set0; split => //.
     split; last by move=> a /in_set0.
     split; first by apply: setU_0.
     by move=> a b /in_set0.
    by move=> x /in_set0.
  move=> [x sxr].
  have px: inc (singleton x) (free_subsets r).
    apply: Zo_i; first by apply /setP_P; apply: set1_sub.
    by move=> u v /set1_P -> /set1_P ->.
  move:(hyp2 _ px); rewrite cardinal_set1 => h.
  by move: (card_le0 h) => h1; case: card1_nz.
move=> k kB hrec r or [[X0 X0f cX0] gensiz].
We assume the result true for k, and X0 is free with k+1 elements. Assume that there is a totally ordered set C, such that any free subset in the complementary has at most k elements. Then there is a free subset with k elements, we can partition the complement into k subsets. With C, this gives k+1 sets.
pose comp C := ((substrate r) -s C).
pose indC C := induced_order r ((substrate r) -s C).
suff: exists C, [/\ sub C (substrate r), (total_order (induced_order r C))&
    (forall T, sub T (comp C) -> (free_subset r T) ->
     (cardinal T) <=c k)].
  move=> [C [Cs torC h1]].
  set E1 := comp C.
  have s1: sub E1 (substrate r) by apply: sub_setC.
  set r1:= indC C.
  move: (iorder_osr or s1) => [or1 sr1].
  have p1: forall x, inc x (free_subsets r1) ->
    (cardinal x) <=c k.
    move => x => /Zo_P [] /setP_P p1 p2.
    have p3: free_subset r x.
     move=> u v ux vx uv; apply:p2 =>//;rewrite /r1 /indC -/(comp C) -/E1 - sr1.
     by apply /iorder_gleP => //; apply: p1.
    rewrite sr1 in p1;exact: (h1 _ p1 p3).
  have i1: inc (X0 \cap E1) (free_subsets r1).
    apply: Zo_i; first by apply /setP_P;rewrite sr1; apply: subsetI2r.
    move=> x y /setI2_P [xX0 xE1] /setI2_P [yX0 yE1] xy.
    move: X0f => /Zo_P [_ X0f1]; apply: X0f1 => //.
    exact (iorder_gle1 xy).
  have X0sr: sub X0 (substrate r).
    by move: X0f =>/Zo_P [] /setP_P X0s X0f.
  case: (emptyset_dichot C) => neC.
    move: (p1 _ i1).
    have ->: X0 \cap E1 = X0.
      rewrite /E1/comp neC;set_extens t; first by move /setI2_P => [].
      move=> tx; apply /setI2_P;split => //; apply /setC_P.
      split => //; [by apply: X0sr | case;case ].
    rewrite cX0; move: (card_lt_succ kB) => pa pb; co_tac.
  have hrec1: Exercise4_5_hyp r1 k.
    split => //; exists (X0 \cap E1) => //.
    move: (p1 _ i1) => rel1; ex_middle q.
    have : (cardinal (X0 \cap E1)) <c k by split.
    have c1: sub (X0 \cap E1) X0 by apply: subsetI2l.
    move:(cardinal_setC c1); rewrite cX0 /card_diff.
    set a := cardinal _; set b := cardinal _.
    have skB: inc (succ k) Bnat by fprops.
    have ca: cardinalp a by rewrite /a; fprops.
    have cb: cardinalp b by rewrite /b; fprops.
    have csa: cardinalp (succ a) by apply: CS_succ.
    move => p2; rewrite -p2 in skB.
    move: (Bnat_in_sum cb skB) (Bnat_in_sum2 ca skB) => bB aB.
    move/ (card_le_succ_ltP _ aB) /(card_le_succ_succP csa (CS_Bnat kB)).
    rewrite -p2 (card_succ_pr4 csa) (card_succ_pr4 ca) - csumA.
    rewrite card_two_pr => p3.
    move: (csum_le_simplifiable aB BS2 bB p3) => b2.
    move: b2 => /card_le2P [x1 [x2 [x1b x2b x12]]].
    move: X0f =>/Zo_P [] /setP_P X0s X0f.
    move: x1b x2b => /setC_P [x10] /setI2_P e1 /setC_P [x20] /setI2_P e2.
    move: (X0s _ x10) (X0s _ x20) => x1s x2s.
    case: (inc_or_not x1 C) => x1C; last by case: e1; split => //; apply /setC_P.
    case: (inc_or_not x2 C) => x2C; last by case: e2; split => //; apply /setC_P.
    move: torC => [_ ]; aw; move => tc.
    case: (tc _ _ x1C x2C) => h; move: (iorder_gle1 h) => aux.
      by case: x12; move: (X0f _ _ x10 x20 aux).
      by case: x12; move: (X0f _ _ x20 x10 aux).
  move: (hrec _ or1 hrec1) => [Y [[[uY adi] ane] cY altY]].
  set X:= Y +s1 C.
  have nCY : ~ (inc C Y).
    move=> CY; move: (ane _ CY) => [x xC].
    have : inc x (union Y) by union_tac.
    rewrite uY sr1 => /setC_P [_ nxc]; contradiction.
  move: (card_succ_pr nCY); rewrite cY -/X => p3.
  have pr1: union X = substrate r.
    rewrite /X;set_extens t.
      move=> /setU_P [y ty /setU1_P]; case => yy; last by apply: Cs; ue.
      apply: s1; rewrite - sr1 -uY; union_tac.
     move=> tsr; apply /setU_P;case: (inc_or_not t C) => tC.
        by exists C;fprops.
     have : inc t (union Y) by rewrite uY sr1; apply /setC_P.
     move /setU_P=> [y ty yY]; exists y; fprops.
  have pr2: forall a b, inc a X -> inc b X -> disjointVeq a b.
    move=> a b; case /setU1_P => aY; case /setU1_P => bY.
          by apply: adi.
        right; rewrite bY; apply: disjoint_pr => u uA.
        have:inc u (union Y) by union_tac.
        by rewrite uY sr1 => /setC_P [_ nxc].
      right; rewrite aY; apply: disjoint_pr => u uA uB.
      have:inc u (union Y) by union_tac.
      by rewrite uY sr1 => /setC_P [_ nxc].
    by left; rewrite aY bY.
  have pr3: alls X nonempty.
    by move=> a; case /setU1_P => ay; [ apply: ane | ue ].
  exists X; rewrite /partition_s; split => //.
  move=> x;case /setU1_P => aY; last by ue.
  move: (altY _ aY); rewrite /r1 /indC iorder_trans //.
  by rewrite -/(comp C) -/E1 - sr1 -uY; apply: setU_s1.
Let sra F X stand for: X is a weak partition of F of totally ordered set with at most k+1 elements. Let sr C mean: for any finite set F, there is X such that sra F X and C \cap F is a subset of one element of X. The previous lemma says that sr holds for the empty set.
pose sra F X := [/\ (cardinal X) <=c (succ k), union X = F,
     (forall a b : Set, inc a X -> inc b X -> disjointVeq a b) &
    (forall Y, inc Y X -> (total_order (induced_order r Y)))].
pose sr C := sub C (substrate r) /\ forall F, finite_set F ->
    sub F (substrate r) -> exists2 X, sra F X &
     exists2 Y, inc Y X & sub (C \cap F) Y.
set ssr:= Zo (powerset (substrate r)) sr.
set sso:= sub_order ssr.
move: (sub_osr ssr) => [osso sssr].
have sre: (sr emptyset).
  split; first by fprops.
  move=> F Fsf Fsr.
  set r1:= induced_order r F.
  move: (iorder_osr or Fsr) => [pa pb].
  have fsr1: finite_set (substrate r1) by ue.
  have fk: forall x, inc x (free_subsets r1)
     -> (cardinal x) <=c (succ k).
    move=> x /Zo_P [] /setP_P xr1 fs1; rewrite pb in xr1.
    apply: gensiz; apply: Zo_i.
       by apply /setP_P; apply: (@sub_trans F) => //.
   by move=> u v ux vx uv; apply: fs1 => //; apply/iorder_gleP => //;apply: xr1.
  have skB: inc (succ k) Bnat by fprops.
  case: (emptyset_dichot F) => eF.
    have pr1:sra F (singleton emptyset).
       rewrite /sra cardinal_set1 eF setU_1; split => //.
          rewrite - succ_zero; apply /(card_le_succ_succP CS0 (CS_Bnat kB)).
          apply: czero_least; fprops.
        by move=> a b /set1_P -> /set1_P ->; left.
      have s1: sub emptyset (substrate r) by fprops.
      move: (iorder_osr or s1) => [pax pbx].
      by move=> a /set1_P ->; split; fprops; aw; move=> x y /in_set0.
    exists (singleton emptyset) => //.
    by exists emptyset; fprops; move => t /setI2_P; case.
  move: (Exercise4_5c fsr1 pa skB fk).
  rewrite /sra;move=> [X [cX uX mdX toX]]; exists X; first split => //.
      ue.
    move=> Y YX; move: (toX _ YX); rewrite /r1 iorder_trans //.
    by rewrite - pb -uX; apply: setU_s1.
  move: eF => [u]; rewrite - pb -uX => /setU_P [y uy yX].
  by ex_tac; move=> t/setI2_P [] /in_set0.
The set of subsets satisfying sr is inductive. Assume we have sets Ci, totally ordered by sub, and let C be the union. Let F be a finite set, Vf = C \cap F. For x in W, there is an index i such that x is in Ci. Since W is finite, there is a greatest such Ci. We deduce C \cap F = Ci \cap F. Then sr C follows trivially.
have isso: inductive sso.
  move=> X sX tio;rewrite sssr in sX.
  set uX:= union X.
  have uXr: sub uX (substrate r).
    apply: setU_s2 => y yX t ty.
    move: (sX _ yX) => /Zo_P [] /setP_P ysr _; apply: (ysr _ ty).
  suff uxs: inc (union X) ssr.
    exists (union X); red; rewrite sssr; split => //.
     by move=> y yX; apply /sub_gleP;split;fprops;apply: setU_s1.
  apply: Zo_i; [ by apply /setP_P | split => //].
  move => F fsF Fsr; set w := ((union X) \cap F).
  case: (emptyset_dichot w) => wne.
    move: sre; move=> [_ h]; move: (h _ fsF Fsr).
    have -> // : emptyset \cap F = w.
    by rewrite wne; apply /set0_P; move=> y /setI2_P [/in_set0].
  pose f x:= choose (fun y => inc x y /\ inc y X).
  have fp: forall x, inc x w -> (inc x (f x) /\ inc (f x) X).
    move=> x /setI2_P [] /setU_P [y p1 p2] _.
    by apply choose_pr; exists y.
  set w1:= fun_image w f.
  move: (sub_finite_set (@subsetI2r (union X) F) fsF) => fsw.
  move: (finite_fun_image f fsw); rewrite -/w -/w1 => fsw1.
  have sw1: sub w1 X.
    by move => t /funI_P [z zw ->]; case: (fp _ zw).
  have w1ne : nonempty w1.
    move: wne => [x xw]; exists (f x); apply /funI_P; ex_tac.
  have sis: substrate (induced_order sso X) = X by aw; ue.
  move: (sw1); rewrite - sis => sw2.
  move: sX; rewrite - sssr => sw3.
  move: (sub_trans sw1 sw3) => sw4.
  move: (finite_subset_torder_greatest tio fsw1 sw2 w1ne) => [x].
  rewrite iorder_trans //; move=> []; aw => xw1 xle.
  move: (sw1 _ xw1) => xX.
  have ->: w = x \cap F.
    set_extens t.
      move=> tw; apply /setI2_P.
      have ft: inc (f t) w1 by apply /funI_P; ex_tac.
      move: (xle _ ft) => /(iorder_gleP _ ft xw1)
          /sub_gleP [fts xsr ftx].
      move: (fp _ tw) => [pa pb]; split; first by apply: (ftx _ pa).
      by apply: (@setI2_2 (union X)).
   move=> /setI2_P[pa pb]; apply /setI2_P;split => //; union_tac.
  move: (sw3 _ xX); rewrite sssr;move => /Zo_P [_ [_ ok]].
  apply: (ok F fsF Fsr).
By Zorn, there is a maximal C satisfying sr; Taking for F a doubleton shows that C is totally ordered
move: (Zorn_lemma osso isso) => [C [Cs Cm]].
move: Cs; rewrite sssr => Cs1; move: (Cs1) => /Zo_P [_ [cp1 cp2]].
have toc: total_order (induced_order r C).
  move: (iorder_osr or cp1) => [pax pbx].
  split => //; rewrite pbx => x y xC yC; red.
  suff: gle r x y \/ gle r y x.
     by case => h; [left| right]; apply /iorder_gleP.
  set F:= doubleton x y.
  have fsF: finite_set F by apply: set2_finite.
  have FC:sub F C by apply: sub_set2.
  have Fsr: sub F (substrate r) by apply: sub_trans cp1.
  move: (cp2 _ fsF Fsr) => [X [pa pb pc pd]] [Y YX si].
  have ysr: sub Y (substrate r).
    by apply: sub_trans Fsr => //; rewrite -pb; apply: setU_s1.
  move: (pd _ YX) => [ory]; aw.
  have xY: inc x Y by apply: si; apply /setI2_P;rewrite /F;split;fprops.
  have yY: inc y Y by apply: si; apply /setI2_P;rewrite /F;split;fprops.
  move=> aux; case: (aux _ _ xY yY) => aux2; move: (iorder_gle1 aux2); fprops.
All we need to do is show that free subsets in the complementary of C have at most k elements. By contradiction, assume there is T with k+1 elements. Let Ci x be the union of C and an element x of T. By maximality, there exists a finite set Ciq x, denoted here F such that for any X such that sra X holds, for any Y in X, (Ci x) \cap F is not a subset of Y. Let G be the union of these sets, together with T.
case: (p_or_not_p (forall T,
      sub T (comp C) -> free_subset r T -> (cardinal T) <=c k)) => hh.
  by exists C.
case: hh => T TC fsT.
have Tc: sub T (substrate r).
  apply: (@sub_trans (comp C)) => //; apply: sub_setC.
have Tf: inc T (free_subsets r) by apply: Zo_i => //; apply /setP_P.
move: (gensiz _ Tf); case: (equal_or_not (cardinal T) (succ k)); last first.
  move=> pa pb; apply /card_lt_succ_leP => //; split => //.
move => cTk _.
pose Ci i := C +s1 i.
pose Cip i F := finite_set F /\ sub F (substrate r)
    /\ forall X, sra F X -> forall Y, inc Y X ->
     ~ ( sub ((Ci i) \cap F) Y).
have Cip1: forall i, inc i T -> exists F, Cip i F.
  move=> i iT; case: (p_or_not_p (gle sso C (Ci i))) => h.
    move: (TC _ iT) => /setC_P [_]; rewrite - (Cm _ h); case; apply: setU1_1.
  ex_middle ef; case: h.
  have cc: sub C (Ci i) by apply : sub_setU1.
  have cc2: sub (Ci i) (substrate r) by apply: setU1_sub => //; apply: Tc.
  apply /sub_gleP;split=> //;apply/ Zo_P; split;first by apply /setP_P.
  split => // F Fsf Fsr; ex_middle exp.
  case: ef; exists F;rewrite /Cip;split => //; split => // X p1 Y YX.
  case: (p_or_not_p (sub ((Ci i) \cap F) Y)) => //.
  move => bad2; case: exp; exists X => //; ex_tac.
pose Ciq i := choose (fun F => Cip i F).
have Cip2: forall i, inc i T -> Cip i (Ciq i).
  by move => i iT; apply: choose_pr; apply: Cip1.
set G:= T \cup (unionb (Lg T Ciq)).
have fG: finite_set G.
  apply: finite_union2; first by rewrite /finite_set cTk ; apply /BnatP; fprops.
   apply: finite_union_finite; fprops; red;bw.
     by move=> i iT; bw; move: (Cip2 _ iT) => [Ok _].
   red; rewrite cTk; apply /BnatP; fprops.
have Gs: sub G (substrate r).
  rewrite /G=> t; case /setU2_P; first by apply: Tc.
  move /setUb_P; bw; move=> [y yd]; bw => tC.
  by move: (Cip2 _ yd) => [_ [Ok _]]; apply: Ok.
By construction there is a partition X of G, and Y such that C \cap G is a subset of Y. We have sra ( Ciq i) (mp i), where mp i is the set of intersections of Ciq i with the elements of X.

move: (cp2 _ fG Gs) => [X [cX uX mdX toX] [Y YX si]].
pose mp i := fun_image X (fun k => (Ciq i) \cap k).
have Cip3: forall i, inc i T -> sra (Ciq i) (mp i).
  move=> i iT.
  have pr1:cardinal (mp i) <=c succ k.
    set fa:= Lf (fun k => (Ciq i) \cap k) X (mp i).
    have ff: function fa.
      apply: lf_function; move=> t tX; apply /funI_P; ex_tac.
    move: (image_smaller_cardinal ff).
    rewrite /fa; aw; set y := image_of_fun _.
    have ->: y = (mp i).
      rewrite /y /mp/image_of_fun lf_source.
      set Ta := [eta intersection2 (Ciq i)].
      have aa: sub X (source (Lf Ta X (fun_image X Ta))) by aw.
      have bb: lf_axiom Ta X (fun_image X Ta)
           by move=> t tx; apply /funI_P; ex_tac.
      set_extens t.
        move /(Vf_image_P ff aa) => [z pa pb]; apply /funI_P; ex_tac.
        rewrite pb /fa; aw.
      move /funI_P => [z pa pb] ;apply /(Vf_image_P ff aa); ex_tac.
      rewrite pb /fa; aw.
    move=> le1; co_tac.
  have pr2: union (mp i) = Ciq i.
    set_extens t.
      move=> /setU_P [y ty] /funI_P [z zX izy].
      by apply:(@setI2_1 _ z); rewrite - izy.
    move=> ti; apply /setU_P.
    have : inc t G by apply /setU2_P; right; apply /setUb_P; bw; exists i;bw.
    rewrite -uX => /setU_P [y ty yX].
    exists ((Ciq i) \cap y) => //; first by apply /setI2_P.
    apply /funI_P; ex_tac.
  have pr3:forall a b, inc a (mp i) -> inc b (mp i) -> disjointVeq a b.
    move=> a b /funI_P [za zaX ->] /funI_P [zb zbX ->].
    case: (mdX _ _ zaX zbX); first by move=> ->; left.
    rewrite {1}/disjoint; right; apply: disjoint_pr => u.
    by move=> /setI2_P [_ ua] /setI2_P [_ ub]; empty_tac1 u; apply: setI2_i.
  split => //.
  move=> Y1 => /funI_P [z zX ->]; move: (toX _ zX) => to1.
    have aux2: sub z (substrate r).
      by apply: sub_trans Gs => //; rewrite -uX; apply: setU_s1.
  have aux1: sub ((Ciq i) \cap z) z by apply: subsetI2r.
  have aux: sub ((Ciq i) \cap z) (substrate (induced_order r z)) by aw.
  move: (total_order_sub to1 aux); rewrite iorder_trans //.
The sets T and Y are disjoint. But T intersects each element of X at most once, thus exactly once, absurd.

have TYe: T \cap Y = emptyset.
  apply /set0_P => y /setI2_P [yT yY].
   move: (Cip2 _ yT) => [pa [pb pc]]; move: (pc _ (Cip3 _ yT)) => aux.
   have YMP: inc ((Ciq y) \cap Y) (mp y) by apply /funI_P; ex_tac.
  case: (aux _ YMP) => t /setI2_P [ta tb]; apply /setI2_P;split => //.
  move: ta; case /setU1_P; last move=> ->; fprops.
  move=> tC;apply: si; apply /setI2_P;split => //; apply /setU2_P;right.
  apply /setUb_P; bw; ex_tac; bw.
have stu: sub T (union X) by rewrite uX /G; apply: subsetU2l.
set k1:= cardinal X.
have ksb: inc (succ k) Bnat by fprops.
have k1B: inc k1 Bnat by apply: (BS_le_int cX ksb).
move:cX; rewrite - cTk -eq_subset_cardP1; move=> [T1 T1S].
move/card_eqP; rewrite -/k1 => pa; symmetry in pa.
have sm:(forall Z : Set, inc Z X -> small_set (T1 \cap Z)).
  move=> Z ZY x y /setI2_P [xT xZ] /setI2_P [yT yZ].
  move: (T1S _ xT) (T1S _ yT) => xt1 yt1.
  have Zr': sub Z G by rewrite -uX; apply: setU_s1.
  have Zr: sub Z (substrate r) by apply: sub_trans Gs.
  move: (toX _ ZY) => [orZ]; aw; move=> tor; case: (tor _ _ xZ yZ)=> aux.
    by move: (iorder_gle1 aux); apply: fsT.
    by symmetry; move: (iorder_gle1 aux); apply: fsT.
move: ((@Exercise4_5a X T1 k1 (refl_equal (cardinal X)) pa k1B
   (sub_trans T1S stu) mdX sm) _ YX).
move=> [x]; aw => sx; move: (set1_1 x); rewrite - sx.
move=> /setI2_P [ha hb]; empty_tac1 x; aw; split => //.
Qed.

Exercise 4.6. We start with some follow-ups to the previous exercise. The notations H, Hw, C and Cw are as above. We first show that a non-empty bounded set of integers has a greatest element. It follows that if Hw(n) holds, then H(k) holds for some k. If Hw(n+h) holds and there is a free subset with n elements, then H(n+k) holds for some k.

Lemma finite_bounded_greatest_B n T:
  inc n Bnat -> (forall m, inc m T -> m <=c n) ->
  nonempty T ->
  exists2 m, inc m T & forall k, inc k T -> k <=c m.
Proof.
move=> nB Tp neT.
have zb: inc \0c Bnat by fprops.
have Ti: sub T (Bintcc \0c n).
  by move=> i iT; bw; move: (Tp _ iT) => lein; apply /BintcP.
have aux: Bnat_le \0c n by split;fprops; apply /BintcP.
move: (sub_finite_set Ti (finite_Bintcc \0c n)) => fst.
move: (Binto_wor \0c n) => [/worder_total iot sio].
rewrite - sio in Ti.
move: (finite_subset_torder_greatest iot fst Ti neT) => [x []].
move: iot=> [ot _];aw => xT aux2; ex_tac.
move=> k kT; move: (iorder_gle1 (aux2 _ kT)).
by move /Binto_gleP => [_ _].
Qed.

Lemma Exercise4_5A1 r n:
  inc n Bnat ->
  (forall x, inc x (free_subsets r) ->
     (cardinal x) <=c n) ->
  exists2 k, inc k Bnat & Exercise4_5_hyp r k.
Proof.
move=> nB hyp.
set T := Zo Bnat (fun k => exists2 x, inc x (free_subsets r) &
   cardinal x = k).
have pa: (forall m, inc m T -> m <=c n).
  by move=> m /Zo_P [mB [x xfr <-]]; apply: hyp.
have neT: nonempty T.
  exists \0c; apply: Zo_i;fprops; exists emptyset.
     by apply: Zo_i; [ apply /setP_P;fprops | move=> x y /in_set0].
    apply: cardinal_set0.
move:(finite_bounded_greatest_B nB pa neT) => [m mT mg].
move: mT => /Zo_P [mb mp]; ex_tac; split => //.
move => x xs.
move: (hyp _ xs) => le1; move: (BS_le_int le1 nB) => cxB.
by apply: mg;apply: Zo_i => //; ex_tac.
Qed.

Lemma Exercise4_5A2 r n h:
  inc n Bnat -> inc h Bnat ->
  (forall x, inc x (free_subsets r) ->
     (cardinal x) <=c (n +c h)) ->
  (exists2 x, inc x (free_subsets r) & (cardinal x = n)) ->
  exists k, [/\ inc k Bnat, k <=c h & Exercise4_5_hyp r (n +c k)].
Proof.
move=> nB hB hyp1 [x xf cx].
move: (Exercise4_5A1 (BS_sum nB hB) hyp1) => [k kB [pa pb]].
move: (pb _ xf); rewrite cx => lexk.
move: (cdiff_pr0 kB nB lexk);set m := _ -c _.
move => [mB aux]; ex_tac; last by rewrite aux.
move: pa => [y ys yx]; move: (hyp1 _ ys); rewrite yx -aux.
move=> aux3; apply: (csum_le_simplifiable nB) => //.
Qed.

Assumptions: we have two non-empty families X and Y with m and n elements. Let E46_hprop h be the property that, whenever we take r+h elements of X, the union of these sets meets at least r elements of Y. Let E46_h h be the property that h is the least integer satisfying this property. Then there is a set with at most n+h elements that meets every element of X and Y.
For simplicity, we assume the domains of X and Y disjoint, and we define an ordering on the union of the domains such that i<j if X(i) meets Y(j).

Section Exercise46.
Variables A X Y m n :Set.
Hypothesis (nB: inc n Bnat) (mB: inc m Bnat).
Hypothesis Xpr:
  [/\ fgraph X, cardinal (domain X) = m, sub (range X) (powerset A) &
   forall i, inc i (domain X) -> nonempty (Vg X i)].
Hypothesis Ypr:
  [/\ fgraph Y, cardinal (domain Y) = n, sub (range Y) (powerset A) &
   forall i, inc i (domain Y) -> nonempty (Vg Y i)].
Hypothesis disdom: disjoint (domain X) (domain Y).

Definition E46_hprop h := forall r Z, r <=c (m -c h) ->
   sub Z (domain X) -> cardinal Z = r +c h ->
   exists T, [/\ sub T (domain Y), cardinal T = r &
   forall j, inc j T -> meet (Vg Y j) (unionb (restr X Z))].

Definition E46_hp h := [/\ inc h Bnat, h <=c m, E46_hprop h &
   forall l, inc l Bnat -> l <=c m -> E46_hprop l -> h <=c l].

Definition E46_conc h := exists B, [/\ (cardinal B) <=c (n +c h),
  finite_set B, (forall i, inc i (domain X) -> meet (Vg X i) B),
  sub B A & (forall j, inc j (domain Y) -> meet (Vg Y j) B)].

Definition E46_u := (domain X) \cup (domain Y).
Definition E46_order_rel x y :=
  x = y \/ [/\ inc x (domain X), inc y (domain Y) & meet (Vg X x) (Vg Y y)].
Definition E46_order_r := graph_on E46_order_rel E46_u.

Lemma Exercise4_6a:
  order_on E46_order_r E46_u /\
  (forall x y, gle E46_order_r x y <->
    [/\ inc x E46_u, inc y E46_u & E46_order_rel x y]).
Proof.
have pa: (forall a : Set, inc a E46_u -> E46_order_rel a a).
  by move => a _; left.
move: (graph_on_sr pa); rewrite -/E46_order_r => sr.
have or: order E46_order_r.
  apply: order_from_rel;split => //.
      move=> y x z; case => xy; first (by rewrite xy); case => yz => //.
        by rewrite -yz; right.
      move: xy yz => [_ yY _][yX _ _];empty_tac1 y.
    move => x y; case => // xy; case => // yx.
    move: xy yx => [_ yY _][yX _ _]; empty_tac1 y.
  by move => x y _; split; left.
split => //; move=> x y; apply /graph_on_P1.
Qed.

We show that there is h such that E46_hp h holds

Lemma Exercise4_6b h: h <=c m ->
  E46_hprop h -> m <=c (n +c h).
Proof.
move => hm hp; move: (BS_le_int hm mB) => hB.
move: (cdiff_pr0 mB hB hm); set r := (m -c h); move=> [rB phm].
have pa: r <=c (m -c h) by rewrite -/r; fprops.
have pb: sub (domain X) (domain X) by fprops.
have pc: cardinal (domain X) = r +c h.
   by rewrite csumC phm; move: Xpr => [_ ok _ _].
move: (hp _ _ pa pb pc) => [T [Td cT _]].
move: (sub_smaller Td); move: Ypr => [_ cdY _ _]; rewrite cT cdY.
have lehh: h <=c h by fprops.
by move=> pd; move: (csum_Mlele pd lehh); rewrite csumC phm.
Qed.

Lemma Exercise4_6c: exists h, E46_hp h.
Proof.
set F:= Zo Bnat (fun h => h <=c m /\ E46_hprop h).
move: Bnat_order_wor => [[pa pb] pc].
have sFb: sub F (substrate Bnat_order) by rewrite pc; apply: Zo_S.
have neF: nonempty F.
  exists m; apply: Zo_i; first (rewrite /E46_hprop;fprops); split; fprops.
  move=> r Z le1 Zd cT.
  exists emptyset;split;fprops;last by move=> j /in_set0.
  rewrite (cdiff_n_n m) in le1.
  rewrite (card_le0 le1) cardinal_set0 //.
move: (pb _ sFb neF) => [h []]; aw => /Zo_P [hB [lhm hp]] hm.
exists h;split => //.
move=> l lB lm lp; have lF: inc l F by apply: Zo_i.
by move: (iorder_gle1 (hm _ lF)); move /Bnat_order_leP => [_ _].
Qed.

We restate E46_hprop h as a property of the ordering

Lemma Exercise4_6d h: E46_hprop h <->
  forall r Z, r <=c (m -c h) ->
   sub Z (domain X) -> cardinal Z = r +c h ->
   exists T, [/\ sub T (domain Y), cardinal T = r &
   forall j, inc j T -> exists2 i, inc i Z & gle E46_order_r i j].
Proof.
move: Exercise4_6a Xpr => [[oR sR] rR] [fgX _].
split; move=> aux r Z pa pb pc;
   move: (aux _ _ pa pb pc) => [T [tdY cT aux1]]; exists T;split => // j jT.
  move: (aux1 _ jT) => [k] /setI2_P [kVg] /setUb_P [y].
  rewrite restr_d // => yd; rewrite restr_ev//.
  have yX: inc y (domain X) by apply: pb.
  have jY: inc j (domain Y) by apply: tdY.
  move=> kV1; ex_tac; apply/rR;rewrite /E46_u; split;fprops.
  by right; split => //;exists k; apply: setI2_i.
move: (aux1 _ jT) => [i iZ]; move / rR => [_ _ ].
case => h0.
  empty_tac1 j;rewrite -h0; fprops.
move: h0 => [_ _ [k]] /setI2_P [k1 k2]; exists k; apply /setI2_P;split => //.
apply /setUb_P; exists i; rewrite ?restr_d //; rewrite restr_ev//.
Qed.

Proprety E46_hprop h says that free subsets are not too big

Lemma Exercise4_6e h K:
  inc h Bnat -> E46_hprop h -> inc K (free_subsets E46_order_r) ->
  (cardinal K) <=c (n +c h).
Proof.
move=> hB; rewrite Exercise4_6d => aux free.
set Z := K \cap (domain X).
set Z1 := K \cap (domain Y).
have ZX: sub Z (domain X) by apply: subsetI2r.
have Z1Y: sub Z1 (domain Y) by apply: subsetI2r.
move: Exercise4_6a => [[oR sR] rR].
move: free => /Zo_P [] /setP_P;rewrite sR /E46_u; move=> pa pb.
have uZ: K = Z \cup Z1.
  rewrite - (set_IU2r K (domain X) (domain Y)).
  by symmetry; apply /setI2id_Pl.
have dj: disjoint Z Z1.
   apply: disjoint_pr => u ux uy; empty_tac1 u; aw;split => //.
move: (csum2_pr5 dj); rewrite -uZ - csum2_pr2b - csum2_pr2a => cs.
have ca: cardinalp (cardinal Z) by fprops.
have cn: cardinalp h by fprops.
move: Ypr => [_ cY _ _]; move: Xpr => [_ cX _ _].
case: (card_le_to_ee ca cn).
  move: (sub_smaller Z1Y) => aux1 aux2; move: (csum_Mlele aux2 aux1).
  by rewrite - cs csumC cY.
move => le1.
have cZB: inc (cardinal Z) Bnat.
  have fsdX: finite_set (domain X) by red; rewrite cX; apply /BnatP.
  by move: (sub_finite_set ZX fsdX) => /BnatP.
move: (cdiff_pr0 cZB hB le1); set r := (_ -c h); move=> [rB phm].
move: (sub_smaller ZX); rewrite cX => Zm.
have c2:cardinal Z = r +c h by symmetry; rewrite csumC.
rewrite cs c2 csumC csumA.
apply: csum_Mlele; last by fprops.
have c1: r <=c (m -c h).
   rewrite -phm in Zm; apply: (csum_le_simplifiable hB) => //; fprops.
   rewrite cdiff_pr //.
   have le2: h <=c (h +c r) by apply: csum_M0le; fprops.
   co_tac.
move: (aux _ _ c1 ZX c2) => [T [TdY cT etc]].
have di: disjoint Z1 T.
  apply: disjoint_pr => j jZ1 jT; move: (etc _ jT) => [i iZ le].
  have iK: inc i K by rewrite uZ; apply /setU2_P; left.
  have jK: inc j K by rewrite uZ; apply /setU2_P; right.
  move: (pb i j iK jK le) => ij.
  by empty_tac1 i; rewrite ij.
move:(csum2_pr5 di); rewrite - cY - cT csum2_pr2b csum2_pr2a => <-.
apply: sub_smaller; move=> t; case /setU2_P => ta; fprops.
Qed.

Property E46_hp h says H(n+k) for some k

Lemma Exercise4_6f h: inc h Bnat -> E46_hprop h ->
  exists k, [/\ inc k Bnat, k <=c h & Exercise4_5_hyp E46_order_r (n +c k)].
Proof.
move=> hB hp; apply: Exercise4_5A2 => //.
   move=> x xs;apply: Exercise4_6e => //.
move: Exercise4_6a => [[oR sR] rR].
exists (domain Y).
apply: Zo_i; first by apply /setP_P;rewrite sR /E46_u; apply: subsetU2r.
move=> x y; rewrite rR; move=> xY yY [_ _ ]; case => //; move=> [xX _].
  empty_tac1 x.
by move: Ypr => [_ pa _].
Qed.

Lemma Exercise4_6g h: E46_hp h ->
  exists k, [/\ inc k Bnat, k <=c h & Exercise4_5_conc E46_order_r (n +c k)].
Proof.
move=> [hB _ hprop _]; move: (Exercise4_6f hB hprop).
move=> [k [kB pa pb]]; ex_tac.
move: Exercise4_6a => [[oR sR] rR].
by move: (Exercise4_5d oR (BS_sum nB kB) pb).
Qed.

We apply the previous exercise. It gives a partition of E into totally ordered sets. Note that an ordered set U is either singleton A, where A is in X or Y, or a doubleton (A,B) where A is in X and B in Y, and these sets meet; let xU be an element of A in the first case, an element of A \cap B in the second case. The set of these xU is a solution.

Lemma Exercise4_6h h: E46_hp h -> E46_conc h.
Proof.
move=> hp; move: (Exercise4_6g hp) => [k [kB kh [C [pC cc altc]]]].
move: pC => [[pca pcc] pcb].
move: Exercise4_6a => [[oR sR] rR].
red in disdom.
have tcp: forall x a b, inc x C -> inc a x -> inc b x ->
   [\/ a = b, glt E46_order_r a b | glt E46_order_r b a].
  move=> x a b xC ax bx; case: (equal_or_not a b) => nab; first by in_TP4.
  have nba: b <> a by apply:nesym.
  have sxs: sub x (substrate E46_order_r) by rewrite -pca; apply: setU_s1.
  move: (altc _ xC) => [or]; aw; move => aux; move: (aux _ _ ax bx).
  by case => aux2; [constructor 2 | constructor 3]=> //;move:(iorder_gle1 aux2).
have tcp1: forall i j, glt E46_order_r i j ->
  [/\ inc i (domain X), inc j (domain Y) & meet (Vg X i) (Vg Y j)].
  move=> i j [leij nij]; move: leij;rewrite rR; move => [isR jsR].
  case => h0 //.
have tcp2: forall x, inc x C ->
  [\/ (exists2 i, inc i (domain X) & x = singleton i),
      (exists2 j, inc j (domain Y) & x = singleton j) |
      (exists i j, glt E46_order_r i j /\ x = doubleton i j)].
  move=> x xC; move: (pcb _ xC) => xne.
  move: (xne) => [y yx].
  case: (equal_or_not x (singleton y)) => xs.
    have: inc y (union C) by union_tac.
    rewrite pca sR /E46_u.
    case /setU2_P => yc; [constructor 1 | constructor 2 ]; ex_tac.
  have [z zx yz]: exists2 z, inc z x & y <> z.
    ex_middle bad; case: xs; apply set1_pr => // z zx.
    ex_middle ty; case: bad; exists z;fprops.
  have [i [j [ix jx ltij]]]: exists i j, [/\ inc i x, inc j x &
    glt E46_order_r i j].
    case: (tcp _ _ _ xC yx zx); first (by contradiction); case => h0.
       by exists y, z.
     by exists z, y.
  move: (tcp1 _ _ ltij) => [iX jY _].
  constructor 3; exists i, j; split => //.
  set_extens t; last by case /set2_P => ->.
  move => tx; case: (tcp _ _ _ xC tx ix); first by move => ->; fprops.
    by move => ti; move: (tcp1 _ _ ti) => [_ iY _]; empty_tac1 i; aw.
  case: (tcp _ _ _ xC jx tx); first by move => ->; fprops.
    by move => tj; move: (tcp1 _ _ tj) => [jX _]; empty_tac1 j; aw.
  move => ti tj; move: (tcp1 _ _ ti) (tcp1 _ _ tj) => [tX _ _] [_ tY _].
  empty_tac1 t.
 pose xup x y:= forall i,
    ( (inc i (x \cap (domain X)) -> inc y (Vg X i) ) /\
      (inc i (x \cap (domain Y)) -> inc y (Vg Y i))).
pose f x := choose (fun y => xup x y).
have fp1: forall x, inc x C -> xup x (f x).
  move=> x xc; apply: choose_pr; case: (tcp2 _ xc).
      move => [i idX ->]; exists (rep (Vg X i)); red.
      move=> j;split; move => /setI2_P [] /set1_P -> uu.
        by apply: rep_i;move: Xpr => [_ _ _ hh]; apply: hh.
      empty_tac1 i; apply /setI2_P;split => //.
    move => [i idX ->]; exists (rep (Vg Y i)); red.
    move=> j; split; move => /setI2_P [] /set1_P -> uu.
      empty_tac1 i; aw.
    by apply: rep_i;move: Ypr => [_ _ _ hh]; apply: hh.
  move=> [i [j [ltij]]] ->; move: (tcp1 _ _ ltij) => [idx jdy mt].
  exists (rep ((Vg X i) \cap (Vg Y j))).
  move: (rep_i mt) => /setI2_P; set r:= rep _; move=> [ra rb].
  move => z;aw;split; move => /setI2_P [];case /set2_P => -> bad //.
    empty_tac1 j; aw.
  empty_tac1 i; aw.
set B:= fun_image C f.
have pa: (cardinal B) <=c (n +c h).
  have sjb: (surjection (Lf f C (fun_image C f))).
    apply: lf_surjective; first by move=> t ta; apply /funI_P; exists t.
    move=> y /funI_P //.
  move: (image_smaller_cardinal (proj1 sjb)); rewrite (surjective_pr0 sjb).
  aw; rewrite -/B => le1.
  have le2: ((cardinal C) <=c (n +c h)).
    rewrite cc; apply: csum_Mlele => //; fprops.
  co_tac.
have pb: finite_set B.
  move: hp => [hB _ _ _].
  red; apply /BnatP; apply: (@BS_le_int _ (n +c h)); fprops.
have sBA: sub B A.
  move=> t /funI_P [z zC ->]; move: (fp1 _ zC) => fz.
  move: Xpr Ypr => [fgX _ rpX _][fgY _ rpY _].
  have auxx: forall i y, inc i (domain X) -> inc y (Vg X i) -> inc y A.
    move=> i y id yv.
    have : sub (Vg X i) A.
       apply /setP_P; apply: rpX; apply /(range_gP fgX); ex_tac.
    by apply.
  have auxy: forall i y, inc i (domain Y) -> inc y (Vg Y i) -> inc y A.
    move=> i y id yv.
    have : sub (Vg Y i) A.
       apply /setP_P; apply: rpY; apply /(range_gP fgY); ex_tac.
    by apply.
  case: (tcp2 _ zC).
      move=> [i idx zi].
      have ii2: inc i (z \cap (domain X)) by rewrite zi; fprops.
      move: (fz i) => [fa _]; move: (fa ii2) => fv; apply: (auxx _ _ idx fv).
    move=> [i idx zi].
    have ii2: inc i (z \cap (domain Y)) by rewrite zi; fprops.
    move: (fz i) => [_ fa]; move: (fa ii2) => fv; apply: (auxy _ _ idx fv).
  move=> [i [j [ltij zi]]]; move: (tcp1 _ _ ltij) => [idx jdy mt].
  have ii2: inc j (z \cap (domain Y)) by rewrite zi; fprops.
  move: (fz j) => [_ fa]; move: (fa ii2) => fv; apply: (auxy _ _ jdy fv).
exists B; split => // i idx.
  have : inc i (union C) by rewrite pca sR /E46_u; fprops.
  move=> /setU_P [y iy yC]; move: (fp1 _ yC i) => [fa _].
  move: (fa (setI2_i iy idx)) => pc.
  exists (f y); apply /setI2_P;split => //; apply /funI_P; ex_tac.
have : inc i (union C) by rewrite pca sR /E46_u; fprops.
move=> /setU_P [y iy yC]; move: (fp1 _ yC i) => [_ fa].
move: (fa (setI2_i iy idx)) => pc.
exists (f y); apply /setI2_P;split => //; apply /funI_P; ex_tac.
Qed.
End Exercise46.

Assume A(x) is a subset of F for any x in E. We want to know when E46b_hyp holds, namely that there exists an injection f such that f(x) is in A(x), or when E46c_hyp G holds (this is E46b_hyp , where moreover G is a subset of the image of f.
Let E46b_conc be the assertion: for any set H, the union of all A(x), for x in H has at least as many elements as H, and let E46c_conc G be: for any subset L of G, the number of elements x such that A(x) meets L is at least the cardinal of L.
We have: E46b_hyp implies E46b_conc, and E46c_hyp G implies E46b_conc and E46c_conc G.

Definition E46b_hyp E F A :=
  exists2 f, injection_prop f E F &
  (forall x, inc x E -> inc (Vf f x) (A x)).

Definition E46c_hyp E F A G :=
  exists f, [/\ injection_prop f E F,
  sub G (image_of_fun f) & (forall x, inc x E -> inc (Vf f x) (A x))].

Definition E46b_conc E A :=
  forall H, sub H E ->
  (cardinal H) <=c (cardinal (union (fun_image H A))).

Definition E46c_conc E A G :=
  forall L, sub L G ->
    (cardinal L) <=c (cardinal (Zo E (fun z => meet (A z) L))).

Lemma Exercise4_6i E F A: E46b_hyp E F A -> E46b_conc E A.
Proof.
move=> [f [injf sf tf] fp] H HE.
set fH:= image_by_fun f H.
have ff: function f by fct_tac.
have shs:sub H (source f) by ue.
have pa:sub fH (union (fun_image H A)).
  move=> t /(Vf_image_P ff shs) [u uH ->].
  move: (fp _ (HE _ uH)) => aux; apply /setU_P;exists (A u) => //.
  apply /funI_P; ex_tac.
move: (sub_smaller pa) => pb.
move: (equipotent_restriction1 shs injf); rewrite -/fH.
by move /card_eqP => ->.
Qed.

Lemma Exercise4_6j E F A G: E46c_hyp E F A G ->
  (E46b_conc E A /\ E46c_conc E A G).
Proof.
move => [f [[injf pa pb] pc pd]].
split; first by apply: (@Exercise4_6i _ F) ; exists f => //.
move => L LG; set K := inv_image_by_fun f L.
have ff: function f by fct_tac.
have Ksf: sub K (source f).
  move=> t /iim_graph_P [u uL Jg]; Wtac.
have aux: L = image_by_fun f K.
   set_extens t.
    move => tL; apply /(Vf_image_P ff Ksf).
    move: (pc _ (LG _ tL)) => /(Vf_image_P1 ff) [x xsf Jg].
    exists x => //; apply /iim_graph_P; exists t => //; rewrite Jg; Wtac.
  move /(Vf_image_P ff Ksf) => [u ui ->]; move:ui => /iim_graph_P [v vL Jg].
  by rewrite - (Vf_pr ff Jg).
move: (equipotent_restriction1 Ksf injf).
rewrite -aux; move /card_eqP=> <-; apply: sub_smaller.
move => t /iim_graph_P [u uL jg]; move: (p1graph_source ff jg) => tf.
rewrite pa in tf;apply: Zo_i => //; move: (pd _ tf); rewrite - (Vf_pr ff jg).
by move=> ua; exists u; apply /setI2_P.
Qed.

Converse: E46b_conc and E46c_conc G imply E46b_conc if E and F are finite

Lemma Exercise4_6k E F A G:
  finite_set F -> sub G F ->
  (forall x, inc x E -> sub (A x) F) ->
   E46b_conc E A -> E46c_conc E A G -> E46b_hyp E F A.
Proof.
move=> fsF GF Ap h1 h2.
we consider some ordering on the disjoint union of E, F and G
set za:= \0c; set zb:= \1c; set zc:= \2c.
set Gi:= G *s1 za.
set Fi:= F *s1 zb.
set Ei:= E *s1 zc.
set Et := Gi \cup (Fi \cup Ei).
have Gp1: forall x, inc x G -> inc (J x za) Et.
   by move=> x xG; apply /setU2_P;left; apply:indexed_pi.
have Fp1: forall x, inc x F -> inc (J x zb) Et.
  by move=> x xG; apply /setU2_P;right; apply /setU2_P;left; apply:indexed_pi.
have Ep1: forall x, inc x E -> inc (J x zc) Et.
  by move=> x xG;apply /setU2_P;right; apply /setU2_P;right; apply:indexed_pi.
pose rc x y := [\/ x = y, [/\ Q x = za, Q y = zb & P x = P y] |
    [/\ (Q x = za \/ Q x = zb), Q y = zc & inc (P x) (A (P y))]].
set r := graph_on rc Et.
have sr: substrate r = Et by apply: graph_on_sr; move=> a _; in_TP4.
have rvP: forall x y, gle r x y <-> [/\ inc x Et, inc y Et & rc x y].
  by move=> x y; apply /graph_on_P1.
have nab: za <> zb by rewrite /za /zb; fprops.
have nac: zc <> za by rewrite /za /zc; apply: card2_nz.
have nbc: zb <> zc by rewrite /zb /zc; apply: card_12.
have trr: transitive_r rc.
  move => x y z xy; case: (xy); first by move=> ->.
    move=> aux; case; first by move=> <-.
      by move: aux => [_ pa _] [pb _ _]; case: nab; rewrite - pa - pb.
    move => [a2 pa pb]; case: a2.
      by move => a2; case: nab; rewrite -a2; move : aux => [_ -> _].
    by move: aux => [pc pd pe] h; constructor 3; rewrite pe; split => //; left.
  move=> [pa pb pc]; case; first by move => <-.
    by move => [pd _ _]; case: nac; rewrite -pb -pd.
  rewrite pb;move => [pd _ _];case: pd => pd; [ by case: nac | by case: nbc].
have arr: antisymmetric_r rc.
  move => x y xy; case: xy; first by move=> ->.
    move=> aux; case; first by move=> <-.
      by move: aux => [_ pa _] [pb _ _]; case: nab; rewrite - pa - pb.
    by move: aux => [pa _ _] [_ pb _]; case: nac; rewrite - pa - pb.
  move=> [_ pb _]; case; first by move => <-.
    by move => [pd _ _]; case: nac; rewrite -pb -pd.
  rewrite pb;move => [pd _ _];case: pd => pd; [ by case: nac | by case: nbc].
have or: order r.
  apply: order_from_rel;split => //.
  by move=> x y _; split; constructor 1.
We consider the size of the biggest free subset
set m := cardinal F.
have pa: (exists2 x, inc x (free_subsets r) & cardinal x = m).
  exists Fi; last by apply /card_eqP; eqsym; rewrite /m /Fi; fprops.
  apply: Zo_i; first by apply /setP_P; rewrite sr /Et => t; fprops.
  move=> x y xFi yFi; move: xFi yFi=> /indexed_P [_ _ qx] /indexed_P [_ _ qy].
  move /rvP => [_ _]; case => //.
    by move=> [qxa _]; case: nab; rewrite -qx -qxa.
  by move=> [_ qya _]; case: nbc; rewrite -qy -qya.
have pb: forall x, inc x Et -> pairp x.
  by move => x;case /setU2_P; [ | case /setU2_P]; move/indexed_P => [].
have pc: Exercise4_5_hyp r m.
  split => // x0 => /Zo_P [] /setP_P; rewrite sr; move=> xET x0f.
  pose f x := Yo (Q x = za) (J (P x) zb) x.
  set x1 := fun_image x0 f.
  have x1E: sub x1 Et.
    rewrite /x1; move=> t /funI_P [z zx0 ->].
    move: (xET _ zx0) => zEt; rewrite /f; Ytac zza => //;apply: Fp1.
    move: (zEt); case /setU2_P.
      by move /indexed_P => [_ hh _]; apply: GF.
    by case /setU2_P;move/indexed_P => [_ h3 h4]//;case: nac;rewrite -h4 - zza.
  have x1f: free_subset r x1.
    move=> x y /funI_P [u ux0 ->] /funI_P [v vx0 ->] h.
    case: (equal_or_not u v) => nuv; first by rewrite nuv.
    move: (xET _ ux0)(xET _ vx0) => uEt vEt.
    move: h;rewrite /f; Ytac uza; Ytac vza.
          by move /rvP=> [_ _]; case => //;aw;
             move => [xx yy]; [case: nab | case: nbc].
        move /rvP => [_ _]; case => //; aw; first by move => [p1]; case: nab.
        move => [_ aa bb].
        case: nuv;apply: (x0f u v ux0 vx0); apply /rvP; split => //.
        by constructor 3; split => //; left.
     move /rvP => [ _ _]; case => //; aw; move => [aa bb] //.
    move=> uv;case: nuv; apply: (x0f u v) => //.
  have -> : cardinal x0 = cardinal x1.
    apply /card_eqP; exists (Lf f x0 x1); split; aw; apply: lf_bijective.
        move=> t tx0; apply /funI_P; ex_tac.
      move=> u v ux0 vx0; rewrite /f; Ytac uza; Ytac vza.
            move: (pb _ (xET _ ux0)) (pb _ (xET _ vx0)) => xp yp sJ.
            apply: pair_exten => //; [apply: (pr1_def sJ) | ue ].
          move=> sj; move: (f_equal P sj) (f_equal Q sj); aw => qa qb.
          by apply: (x0f u v) => //; apply /rvP;split;fprops; constructor 2.
        move=> sj; move: (f_equal P sj) (f_equal Q sj); aw => qa qb.
        by symmetry;apply:(x0f v u)=>//; apply /rvP;split;fprops; constructor 2.
      trivial.
    by move=> y/funI_P.
  set H1 := Zo E (fun z => inc (J z zc) x1).
  set H2 := Zo F (fun z => inc (J z zb) x1).
  have ->: cardinal x1 = (cardinal H1) +c (cardinal H2).
    have ->: x1 = (x1 \cap Ei) \cup (x1 \cap Fi).
    rewrite - (set_IU2r x1 Ei Fi); symmetry; apply /setI2id_Pl.
    move => t; case /funI_P => [z zx0 ->].
       move: (xET _ zx0); case /setU2_P.
         move /indexed_P => [pz Pz Qz]; apply /setU2_P; right.
         by rewrite /f; Ytac0; apply: indexed_pi; apply: GF.
       case /setU2_P; move /indexed_P => [pz Pz Qz]; rewrite /f.
         rewrite Qz; Ytac0; apply /setU2_P; right; by apply /indexed_P.
         rewrite Qz; Ytac0; apply /setU2_P; left; by apply /indexed_P.
    transitivity (H1 +c H2); last by apply: csum2_pr4; fprops.
    have di: disjoint (x1 \cap Ei) (x1 \cap Fi).
      by apply: disjoint_pr; move => u /setI2_P [_] /indexed_P [_ _ qc]
       /setI2_P [_] /indexed_P[_ _ qb]; case: nbc; rewrite - qc -qb.
    rewrite (csum2_pr5 di); apply: csum2_pr4.
       exists (Lf P (x1 \cap Ei) H1).
        split; aw => //; apply: lf_bijective.
            move=> t /setI2_P [tx1] /indexed_P [pt PE Qt].
            by apply: Zo_i => //; rewrite -Qt pt.
         move=> u v /setI2_P [_] /indexed_P [pt _ Qt]
           /setI2_P [_] /indexed_P [pv _ Qv].
           by move=> aux; apply: pair_exten => //; ue.
        move=> y /Zo_P [yE px1].
        by exists (J y zc)=> //;aw;apply /setI2_P;split => //;apply: indexed_pi.
      exists (Lf P (x1 \cap Fi) H2).
        split; aw => //; apply: lf_bijective.
            move=> t /setI2_P [tx1] /indexed_P [pt PE Qt].
            by apply: Zo_i => //; rewrite -Qt pt.
          move=> u v /setI2_P [_] /indexed_P [pt _ Qt]
            /setI2_P[_] /indexed_P [pv _ Qv] aux.
           apply: pair_exten => //; ue.
        by move=> y =>/Zo_P [yE px1]; exists (J y zb); aw;
        apply /setI2_P; split => //; apply: indexed_pi.
  have hE: sub H1 E by apply: Zo_S.
  move: (h1 _ hE); set K:= (union _).
  have KM: sub K F.
    move=> t /setU_P [y ty] /funI_P [z zH1 zh2].
    move: zH1 => /Zo_P [zE _].
    by move: (Ap _ zE); rewrite - zh2; apply.
  move: (cardinal_setC KM); rewrite -/m.
  suff: (sub H2 (F -s K)).
    move=> s1; move: (sub_smaller s1) => qa qb qc.
    by rewrite -qb; apply: csum_Mlele.
  move=> t =>/Zo_P [tF px1]; apply /setC_P;split => //.
  move=> /setU_P [y ty] /funI_P [z zH1 Az].
  move: zH1 => /Zo_P [zE J2x1].
  have le1: (gle r (J t zb) (J z zc)).
    apply /rvP;split;fprops; constructor 3; aw.
    split => //; [ by right | by rewrite - Az].
  move: (pr2_def (x1f _ _ px1 J2x1 le1)); exact nbc.
To each element x of F we associate the set of the partition that contains x; this is a bijection f; we get similarly an injection g on E.
have mB: inc m Bnat by move: fsF => /BnatP.
move: (Exercise4_5d or mB pc) => [X [[[uX deX] neX] cX toeX]].
pose f x := choose (fun z => inc (J x zb) z /\ inc z X).
have fp1: forall x, inc x F -> (inc (J x zb) (f x) /\ inc (f x) X).
  move=> x xF; apply choose_pr;move:(Fp1 _ xF); rewrite - sr -uX;move /setU_P.
  by move => [t t1 t2]; exists t.
have taf: lf_axiom f F X by move => t tF; move: (fp1 _ tF) => [p1 p2].
have bijF: bijection (Lf f F X).
   apply:bijective_if_same_finite_c_inj;first by rewrite lf_source lf_target cX.
     aw.
  apply: lf_injective => //.
  move => u v uF vF; move: (fp1 _ uF) (fp1 _ vF) => [p1 p2] [p3 p4] sf.
  have sfu: sub (f u) (substrate r) by rewrite -uX; apply: setU_s1.
  rewrite - sf in p3; move: (toeX _ p2) => [orf]; aw.
  move=> aux; move: (aux _ _ p1 p3); case => leuv; move: (iorder_gle1 leuv)
     => /rvP [qa qb]; case => aux1.
            apply: (pr1_def aux1).
         by move: aux1; aw; move=> [r1 _ _]; case: nab.
       by move: aux1; aw; move=> [_ r1 _]; case: nbc.
     by rewrite (pr1_def aux1).
     by move: aux1 => [_ _ ]; aw.
   by move: aux1; aw; move=> [_ r1 _]; case: nbc.
pose g x := choose (fun z => inc (J x zc) z /\ inc z X).
have gp1: forall x, inc x E -> (inc (J x zc) (g x) /\ inc (g x) X).
  move=> x xE;apply choose_pr;move: (Ep1 _ xE); rewrite - sr -uX; move/setU_P.
  by move => [t t1 t2]; exists t.
have tag: lf_axiom g E X by move => t tE; move: (gp1 _ tE) => [p1 p2].
have bijG: injection (Lf g E X).
  apply: lf_injective => //.
  move => u v uF vF; move: (gp1 _ uF) (gp1 _ vF) => [p1 p2] [p3 p4] sf.
  have sfu: sub (g u) (substrate r) by rewrite -uX; apply: setU_s1.
  rewrite - sf in p3; move: (toeX _ p2) => [orf]; aw.
  move=> aux; move: (aux _ _ p1 p3); case => leuv; move: (iorder_gle1 leuv)
     => /rvP [qa qb]; case; aw => aux1.
            apply: (pr1_def aux1).
         by move: aux1 => [_ _].
       by move: aux1 => [aux2 _ _];case: aux2=> h; [case: nac | case: nbc].
     by rewrite (pr1_def aux1).
   by move: aux1 => [_ _ ->].
  by move: aux1 => [aux2 _ _];case: aux2=> h; [case: nac | case: nbc].
By composition, we have an injection E->F, a solution to the problem
set h := compose (inverse_fun (Lf f F X)) (Lf g E X).
have sh: source h = E by rewrite /h; aw.
have th: target h = F by rewrite /h; aw.
move: (inverse_bij_fb bijF) => bif.
have cifg: composable (inverse_fun (Lf f F X)) (Lf g E X).
  split => //; try fct_tac; aw.
have ih: injection h by apply: compose_fi => //; move: bif => [ok _].
have ph: forall x, inc x E -> inc (Vf h x) (A x).
  move=> x xE; rewrite /h; aw.
  set y := Vf (inverse_fun (Lf f F X)) (g x).
  have yF: inc y F.
     have ->: F = target (inverse_fun (Lf f F X)) by aw.
     by apply: Vf_target; try fct_tac; aw; apply: tag.
  move: (fp1 _ yF) (gp1 _ xE) => [p1 p2] [p3 p4].
  have aux: inc (g x) (target (Lf f F X)) by aw; apply: tag.
  move: (inverse_V bijF aux); rewrite -/y; aw.
  move=> eq0; rewrite - eq0 in p3.
  have sfy:sub (f y) (substrate r) by rewrite -uX; apply: setU_s1.
  move: (toeX _ p2) => [orX]; aw.
  move=> aux1; move: (aux1 _ _ p1 p3); case => leuv; move: (iorder_gle1 leuv);
    move /rvP=> [qa qb]; case => aux2;
     try (case: nbc;move: (pr2_def aux2); fprops); move: aux2;aw.
        by move=> [zbc _]; case: nab.
      by move=> [_ _].
    by move=> [zba _]; case: nab.
  by move=> [_ zbc _]; case: nbc.
have gp: forall t, inc t G -> inc (J t za) (f t).
  move=> t tG; move: (Gp1 _ tG); rewrite - sr -uX => /setU_P [y Jy yX].
  move: (fp1 _ (GF _ tG)) => [Jf1 fX].
  set z := Vf (inverse_fun (Lf f F X)) y.
  have zF: inc z F.
    have ->: F = target (inverse_fun (Lf f F X)) by aw.
     apply: Vf_target => //; [fct_tac | aw ].
  have: y = Vf (Lf f F X) z by rewrite inverse_V => //; aw.
  aw; move: (fp1 _ zF) => [p5 p6].
  move => yf; rewrite yf in Jy.
  have aux3: sub (f z) (substrate r) by rewrite -uX; apply: setU_s1.
  case: (equal_or_not z t) => zt; first by move: Jy; rewrite zt.
  move: (toeX _ p6) => [orX]; aw.
  move=> aux1; move: (aux1 _ _ Jy p5);case => leuv;move: (iorder_gle1 leuv);
    move /rvP => [qc qd]; case => aux2.
            by case: zt; move: (pr2_def aux2).
          by case: zt; move: aux2 => [_ _]; aw.
        case: nbc;move: aux2=> [_ e1 _]; move: e1;aw.
      by case: zt; move: (pr1_def aux2).
     by case: zt; move: aux2 => [_ _]; aw.
  by case: nac;move: aux2=> [_ e1 _]; move: e1;aw.
by exists h.
Qed.

We deduce that E46b_conc implies E46b_conc

Lemma Exercise4_6l E F A:
  finite_set F -> (forall x, inc x E -> sub (A x) F) ->
   E46b_conc E A -> E46b_hyp E F A.
Proof.
move=> pa pb pc.
apply: (Exercise4_6k (G := emptyset)) => //; first fprops.
move=> L LE.
have ->: L =emptyset.
   apply /set0_P; move=> y yL; case: (LE _ yL); case.
rewrite cardinal_set0.
apply: czero_least; fprops.
Qed.

TODO: show that E46c_hyp G holds. But we do not know what to do with assumption E46c_conc G
Exercise 4.7. In a lattice E, an element is said to be irreducible if it is never a strict supremum.
Let J be the set of irreducible elements; P the set J minus the least element (if it exists); S(x) be the set of irreducible elements that are <= x. We start with some auxiliary results. In particular, in a distributive lattice, if a is ireducible and a <= sup(x,y) then a<=x or a<=y.

Lemma char_fun_sub A A' B: sub A B -> sub A' B ->
  ((sub A A') <-> (forall x, inc x B ->
     (Vf (char_fun A B) x) <=c (Vf (char_fun A' B) x))).
Proof.
move=> AB A'B; split.
  move => AA' x xB; case: (inc_or_not x A) => xA.
    rewrite char_fun_V_a // char_fun_V_a //;[ fprops | by apply: AA'].
  rewrite char_fun_V_b //; last by apply /setC_P.
  by apply: czero_least; apply: char_fun_V_cardinal.
move=> h t tA; ex_middle ta'; move: (AB _ tA) => tB.
move: (h _ tB); rewrite char_fun_V_a // char_fun_V_b //; last by apply /setC_P.
move: card_lt_01 => h1 h2; co_tac.
Qed.

Definition sup_irred r x:=
  forall a b, inc a (substrate r) -> inc b (substrate r) ->
   x = sup r a b -> (x = a \/ x = b).

Definition irreds r := Zo (substrate r)(sup_irred r).

Definition E47S r x := Zo (substrate r)
   (fun z => (sup_irred r z) /\ (gle r z x)).

Section Irred_lattice.

Variable r:Set.
Hypothesis lr:lattice r.

Lemma Exercise4_7a x: inc x (substrate r) ->
 sup_irred r x \/ (exists a b, [/\ glt r a x, glt r b x & x = sup r a b]).
Proof.
case: (p_or_not_p (sup_irred r x)); first by left.
move=> p1; right; ex_middle h; case: p1 => a b asr bsr xs.
case: (equal_or_not x a)=> xa; first by left.
case: (equal_or_not x b)=> xb; first by right.
move: (lattice_sup_pr lr asr bsr); rewrite -xs; move => [p2 p3 _].
by case: h; exists a, b; rewrite /glt;split => //;split => //; apply: nesym.
Qed.

Lemma Exercise4_8a a: distributive_lattice3 r ->
  sup_irred r a ->
  forall x y, inc x (substrate r) -> inc y (substrate r) ->
   gle r a (sup r x y) -> (gle r a x \/ gle r a y).
Proof.
move => dl1 sia x y xsr ysr sa.
have or: order r by move: lr => [or _].
have asr: inc a (substrate r) by order_tac.
 move:(Exercise1_16b lr) => [_ _ p1]; move: ((p1 dl1) _ _ _ asr xsr ysr).
rewrite (inf_comparable1 or sa) => ia.
move: (lattice_inf_pr lr asr xsr)(lattice_inf_pr lr asr ysr).
move=> [_ px _] [_ py _].
have r1: inc (inf r a x) (substrate r) by order_tac.
have r2: inc (inf r a y) (substrate r) by order_tac.
by case: (sia _ _ r1 r2 ia); move=> ->; [left | right].
Qed.

If E is finite, any non-empty set has a minimal and a maximal element. In particular, E has a least element, which is irreducible. Any finite set has a supremum and an infimum. The supremum of S(x) is x. We restate this: any x is the supremum of a finite number of irreducible elements.

Hypothesis fs: finite_set (substrate r).
Hypothesis nes: nonempty (substrate r).

Definition E48P := (irreds r) -s1 (the_least r).

Lemma Exercise4_7b: order r.
Proof. by move: lr => [or _]. Qed.

Lemma finite_set_maximal1 U: sub U (substrate r) -> nonempty U ->
  exists2 x, inc x U & (forall y, inc y U -> gle r x y -> x = y).
Proof.
move: Exercise4_7b=> or Usr neU.
set r':= induced_order r U.
move: (iorder_osr or Usr) => [or' sr'].
move:(sub_finite_set Usr fs); rewrite - sr' => fsE.
rewrite - sr' in neU.
move: (finite_set_maximal or' fsE neU) => [x [xs xm]].
ex_tac; move=> y yser' xy; symmetry; apply: xm; apply /iorder_gleP => //; ue.
Qed.

Lemma finite_set_minimal1 U: sub U (substrate r) -> nonempty U ->
  exists2 x, inc x U & (forall y, inc y U -> gle r y x -> y = x).
Proof.
move: Exercise4_7b => or Usr neU.
set r':= opp_order (induced_order r U).
move: (iorder_osr or Usr) => [or1 sr1].
move: (opp_osr or1) => [or']; rewrite sr1 => sr'.
move:(sub_finite_set Usr fs); rewrite - sr' => fsE.
rewrite - sr' in neU.
move: (finite_set_maximal or' fsE neU) => [x [xs xm]].
ex_tac; move=> y yser' xy; apply: xm; apply /opp_gleP.
apply /iorder_gleP => //; ue.
Qed.

Lemma Exercise4_7c: exists a, least r a.
Proof.
move: (finite_set_minimal1 (@sub_refl (substrate r)) nes).
move=> [x xsr xp]; exists x;split => //.
move=> u usr; move: (lattice_inf_pr lr xsr usr); move=> [p1 p2 p3].
move: lr => [or _].
have isr:inc (inf r x u) (substrate r) by order_tac.
by move: (xp _ isr p1) => aux; rewrite aux in p2.
Qed.

Lemma Exercise4_7d: inc (the_least r) (irreds r).
Proof.
move: Exercise4_7b Exercise4_7c => or el.
move: (the_least_pr or el) => [p1 p2].
apply: Zo_i => //; case: (Exercise4_7a p1) => // aux.
move: aux => [a [_ [al _ _]]].
have asr: inc a (substrate r) by order_tac.
move: (p2 _ asr) => p3; order_tac.
Qed.

Lemma Exercise4_7e: sub E48P (substrate r).
Proof.
apply: (@sub_trans (irreds r));[ apply: sub_setC | apply: Zo_S].
Qed.

Lemma Exercise4_7f:
  irreds r = E48P +s1 (the_least r).
Proof. rewrite setC1_K //; apply: Exercise4_7d. Qed.

Lemma Exercise4_7g a: inc a (substrate r) ->
  inc (the_least r) (E47S r a).
Proof.
move: Exercise4_7b=> or asr.
move: (the_least_pr or (Exercise4_7c)) => [p1 p2].
apply: Zo_i => //;split;fprops.
by move: Exercise4_7d => /Zo_P [].
Qed.

Lemma Exercise4_7h a: inc a (substrate r) -> nonempty (E47S r a).
Proof. by exists (the_least r); apply: Exercise4_7g. Qed.

Lemma Exercise4_7i x: sub x (substrate r) ->
  has_supremum r x.
Proof.
move: Exercise4_7b => or xr; case: (emptyset_dichot x) => nex.
  move: (the_least_pr or Exercise4_7c) => tlp.
  rewrite nex; exists (the_least r).
  rewrite lub_set0 //.
by apply: (lattice_finite_sup2 lr (sub_finite_set xr fs) xr).
Qed.

Lemma Exercise4_7j a: inc a (substrate r) ->
  gle r (supremum r (E47S r a)) a.
Proof.
move => asr; move: (Exercise4_7h asr) => ne.
have sE: sub (E47S r a) (substrate r) by apply: Zo_S.
apply /(lattice_finite_sup3P lr _ (sub_finite_set sE fs) ne sE).
by move=> z /Zo_hi [].
Qed.

Lemma Exercise4_7k a b:
  gle r a b -> sub (E47S r a) (E47S r b).
Proof.
move: Exercise4_7b=> or ab t.
move /Zo_P => [p1 [p2 p3]]; apply /Zo_P; split => //; split => //;order_tac.
Qed.

Lemma Exercise4_7l u: inc u (substrate r) ->
  (supremum r (E47S r u)) = u.
Proof.
move: Exercise4_7b => or usr.
apply: (order_antisymmetry or); first by apply: Exercise4_7j.
ex_middle bad.
set U := Zo (substrate r) (fun z => ~ gle r z (supremum r (E47S r z))).
have neU:nonempty U by exists u; apply: Zo_i.
have su: sub U (substrate r) by apply: Zo_S.
move: (finite_set_minimal1 su neU) => [t tu tv].
move: (tu) => /Zo_P [tsr bad1]; case: bad1.
have sV: sub (E47S r t) (substrate r) by apply: Zo_S.
move: (Exercise4_7i sV) => hst.
move: (supremum_pr or sV hst) => [[ub1 ub2] _].
case: (Exercise4_7a (su _ tu)) => aux.
   have h: inc t (E47S r t) by apply: Zo_i => //;split => //; order_tac.
   by apply: ub2.
move: aux => [a [b [[leat neat] [lebt nebt ts]]]].
case: (p_or_not_p (gle r a (supremum r (E47S r a)))); last first.
  move=> p1;case: neat; apply: tv => //; apply: Zo_i => //; order_tac.
case: (p_or_not_p (gle r b (supremum r (E47S r b)))); last first.
  move=> p1;case: nebt; apply: tv => //; apply: Zo_i => //; order_tac.
move=> bs1 bs2.
have asr: inc a (substrate r) by order_tac.
have bsr: inc b (substrate r) by order_tac.
move: (Exercise4_7k leat) => s1.
move: (Exercise4_7k lebt) => s2.
move: (Exercise4_7i (sub_trans s1 sV)) => hs1.
move: (Exercise4_7i (sub_trans s2 sV)) => hs2.
move: (sup_increasing or (sub_trans s1 sV) sV s1 hs1 hst).
move: (sup_increasing or (sub_trans s2 sV) sV s2 hs2 hst).
move=> le1 le2.
move: (lattice_sup_pr lr asr bsr); rewrite -ts; move=> [h1 h2 h3].
apply: h3; order_tac.
Qed.

The function S is an order isomorphism E -> X for some subset X of the powerset of E order by inclusion. S of inf is intersection of S

Lemma Exercise4_7m a b:
  inc a (substrate r) -> inc b (substrate r) ->
  sub (E47S r a) (E47S r b) -> gle r a b.
Proof.
move => asr bsr sab.
set E := (E47S r a).
have sE: sub E (substrate r) by apply: Zo_S.
move: (sub_finite_set sE fs) => fsE.
rewrite - (Exercise4_7l asr).
apply /(lattice_finite_sup3P lr _ fsE (Exercise4_7h asr) sE).
by move=> z zE; move: (sab _ zE) =>/Zo_hi [_].
Qed.

Lemma Exercise4_7n a: inc a (substrate r) ->
  exists S, [/\ finite_set S, nonempty S, sub S (substrate r),
  (forall x, inc x S -> sup_irred r x) &
  supremum r S = a].
Proof.
move=> asr.
have sE: sub (E47S r a) (substrate r) by apply: Zo_S.
move: (sub_finite_set sE fs) => fsE.
move: (Exercise4_7h asr) (Exercise4_7l asr) => ne ass.
exists (E47S r a);split => //.
by move=> x /Zo_hi [].
Qed.

Lemma Exercise4_7o a b: inc a (substrate r) -> inc b (substrate r) ->
  (E47S r (inf r a b)) = (E47S r a) \cap (E47S r b).
Proof.
move=> asr bsr.
move: (lattice_inf_pr lr asr bsr)=> [p1 p2 p3].
have isr: inc (inf r a b) (substrate r) by order_tac.
move: (Exercise4_7k p1) (Exercise4_7k p2) => p4 p5.
set_extens t; first by move=> t1; apply /setI2_P; split; fprops.
move => /setI2_P [] /Zo_P [tsr [si ta]] /Zo_hi [_ tb]; apply /Zo_P;split;fprops.
Qed.

Lemma Exercise4_7p:
  let tg := (irreds r) in
   order_morphism (Lf (E47S r) (substrate r) (powerset tg))
   r (subp_order tg).
Proof.
move: lr => [or _] tg.
have ta: forall x, inc x (substrate r) -> inc (E47S r x) (powerset tg).
  by move=> x xsr; apply /setP_P => t /Zo_P [p1 [p2 p3]]; apply /Zo_P.
move: (subp_osr tg) => [pa pb].
split; fprops; rewrite ? pb;first by split; aw; apply: lf_function.
hnf; aw;move=> x y xsr ysr; red;aw; split.
   move => pa1; apply /sub_gleP;split;fprops.
   by apply: Exercise4_7k.
by move /sub_gleP => [pa1 [pb1 pc]]; apply:Exercise4_7m.
Qed.

Lemma Exercise4_7q a: inc a (substrate r)
 -> sub (E47S r a) (irreds r).
Proof. by move=> asr b => /Zo_P [pa [pb pc]]; apply /Zo_P. Qed.

Exercise 4.8. We assume that E is a distributive lattice.
We have: S of sup is union of S. If t is irreducible, U a non-empty set of irreducibles, t<= sup U simplies that t <= x for at least one element of U. Let p(U) be the property that U is a non-empty set of irreducibles, such that x <=y, x irreducible and y in U implies x in U. Then U = S(sup U). Moreover p (S(x)) holds for any x.

Hypothesis dl3: distributive_lattice3 r.

Lemma Exercise4_8b a b: inc a (substrate r) -> inc b (substrate r) ->
  (E47S r (sup r a b)) = (E47S r a) \cup (E47S r b).
Proof.
move=> asr bsr.
move: (lattice_sup_pr lr asr bsr)=> [p1 p2 p3].
have isr: inc (sup r a b) (substrate r) by order_tac.
have or: order r by move: lr => [ok _].
move: (Exercise4_7k p1) (Exercise4_7k p2) => p4 p5.
set_extens t; last first.
  case /setU2_P => /Zo_P [tsr [si ta]];
       apply /Zo_P;split => //; split => //; order_tac.
move /Zo_P=> [tsr [si ts]].
by case: (Exercise4_8a dl3 si asr bsr ts)=> le;
 apply /setU2_P;[left | right]; apply: Zo_i.
Qed.

Lemma Exercise4_8c1 t U: inc t (substrate r) ->
  sup_irred r t -> sub U (irreds r) -> gle r t (supremum r U) ->
  nonempty U -> exists2 x, inc x U & gle r t x.
Proof.
move: Exercise4_7b => or tsr sit Usi tsU neU.
pose pA U := sub U (irreds r) /\ gle r t (supremum r U).
pose pB U := exists2 x, inc x U & gle r t x.
have sis: sub (irreds r) (substrate r) by apply: Zo_S.
have Usr: sub U (substrate r) by apply: (@sub_trans (irreds r)).
move: (sub_finite_set Usr fs) => fsU.
apply: (@finite_set_induction2 pA pB U) => //.
  move => a; rewrite /pA /pB; move=> [p1 p2].
  have :inc a (irreds r) by apply: p1; fprops.
   move /Zo_P=> [asr ai]; move: p2.
   rewrite supremum_singleton // => ta; exists a;fprops.
move => a b aux nea; rewrite /pA /pB; move=> [p1 p2].
have air: sub a (irreds r).
  apply: (@sub_trans (a +s1 b)) => //; fprops.
have bir: inc b (irreds r) by apply: p1; fprops.
have asr: sub a (substrate r) by apply: (@sub_trans (irreds r)).
have bsr: inc b (substrate r) by apply: sis.
move: (sub_finite_set asr fs) => fsa.
have hsa: has_supremum r a by apply: lattice_finite_sup2 => //.
move: p2; rewrite supremum_setU1 // => aux2.
move: (supremum_pr1 or hsa) => /(lubP or asr) [[p2 p3] p4].
case: (Exercise4_8a dl3 sit p2 bsr aux2)=> aux3; last by exists b; fprops.
have aux4: pA a by split.
move: (aux aux4 nea); move=> [x xa tx]; exists x;fprops.
Qed.

Lemma Exercise4_8c U: sub U (irreds r) ->
   (forall x y, inc y U -> sup_irred r x -> gle r x y -> inc x U) ->
   nonempty U ->
  U = (E47S r (supremum r U)).
Proof.
move: Exercise4_7b => or Usi hU neU.
have sis: sub (irreds r) (substrate r) by apply: Zo_S.
have Usr: sub U (substrate r) by apply: (@sub_trans (irreds r)).
move: (sub_finite_set Usr fs) => fsU.
move: (lattice_finite_sup2 lr fsU Usr neU) => hs.
move: (supremum_pr or Usr hs) => [[ub1 ub2] ub3].
set_extens t => ts.
  move: (ub2 _ ts) (Usi _ ts) => aux /Zo_P [p1 p2].
  apply /Zo_P;split => //; by apply: Usr.
move: ts => /Zo_P [tsr [srt ltsr]].
move: (Exercise4_8c1 tsr srt Usi ltsr neU).
   move=> [x sU tx]; apply: (hU _ _ sU srt tx).
Qed.

Lemma Exercise4_8d:
  let p:= fun U => [/\ sub U (irreds r), nonempty U &
    (forall x y, inc y U -> sup_irred r x -> gle r x y -> inc x U)] in
  (forall x, inc x (substrate r) -> p (E47S r x)) /\
  (forall U, p U -> exists2 x, (inc x (substrate r)) & U = (E47S r x)).
Proof.
move: Exercise4_7b=> or p; split.
  move=> x xsr; split => //.
      move=> t /Zo_P [pa [pb pc]]; apply /Zo_P; split => //.
    by apply: Exercise4_7h.
  move=> u v /Zo_P [vsr [su vx]] iu uv.
  apply /Zo_P; split => //; try split => //;order_tac.
move=> U [p1 p2 p3]; rewrite (Exercise4_8c p1 p3 p2).
exists (supremum r U) => //.
have sU: sub U (substrate r).
  by move=> t tu; move: (p1 _ tu) => /Zo_P [].
by move: (supremum_pr1 or (Exercise4_7i sU)) => /(lubP or sU) [[ok _] _].
Qed.

Let Sb(x) be S(x) without the least element of E. These two sets have the same supremum. The previous result can be rewriten as Let q(U) be the property that U is a subset of P such that x <=y, x irreducible and y in U implies x in U. Then Sb(x) satisfies q and any set satisfying q has the form Sb(x).

Lemma Exercise4_8e:
  let comp:= fun X => X -s1 (the_least r) in
  let p:= fun U => (sub U E48P /\
    (forall x y, inc y U -> inc x E48P -> gle r x y -> inc x U)) in
  (forall x, inc x (substrate r) -> p (comp (E47S r x))) /\
  (forall U, p U -> exists2 x, (inc x (substrate r)) & U = comp (E47S r x)).
Proof.
move: Exercise4_7b Exercise4_8d => or [pa pb] comp p; split.
  move=> x xsr; move: (pa _ xsr) => [p1 p2 p3]; split.
    move => t /setC1_P [p4 p5]; apply /setC1_P;split;fprops.
  move=> z y => /setC1_P [yE yne] /setC1_P [zi znl] zy;apply/setC1_P;split=> //.
  move: zi => /Zo_P [_ zi]; apply: (p3 _ _ yE zi zy).
move=> U [p1 p2].
set U' := U +s1 (the_least r).
have [x xsr aux]:exists2 x, inc x (substrate r) & U' = E47S r x.
  apply: (pb U'); split => //.
      move=> t; case /setU1_P; last by move => ->; apply: Exercise4_7d.
      by move=> tu; move: (p1 _ tu) => /setC1_P [].
    by exists (the_least r); rewrite /U';fprops.
  move=> x y yU' ir xy; apply /setU1_P.
  have xsr: inc x (substrate r) by order_tac.
  case: (equal_or_not x (the_least r)); first by right.
  move => nxle; left.
  have xp: inc x E48P by apply /setC1_P;split => //; apply: Zo_i => //.
  move: yU' => /setU1_P; case.
    by move=> yU; move: (p2 _ _ yU xp xy).
    move: (the_least_pr or Exercise4_7c) => [_ tle].
  move=> h; rewrite h in xy; case: nxle; move: (tle _ xsr) => aux; order_tac.
ex_tac.
rewrite -aux; set_extens t.
   move => tu; apply /setC1_P; split => //; first by apply /setU1_P; left.
   by move: (p1 _ tu) => /setC1_P [].
move /setC1_P => [] /setU1_P; case => //.
Qed.

Let's consider the sets FJ and FP of increasing functions J->d and P->d, respectively, where the first set is J or P, ordered by the opposite ordering, and the second set is the doubleton (0,1) ordered by 0<1. These are ordered sets. To each x we associate the characteristic function of S(x) and Sb(x). This give an order isomorphism from E onto a subset of FJ and FP, because the conditions p and q considered above just say that the characteristic function is increasing.
Bourbaki says that the first mapping is bijective. This is wrong, because the constant function zero is never the characteristice function of S(x). We get a bijection be excluding this function. On the other hand the second mapping is bijective.

Definition E48I := doubleton \0c \1c.
Definition E48z := Lf (fun z => \0c) (irreds r) E48I.
Definition E48Ps := opp_order (induced_order r E48P).
Definition E48Js := opp_order (induced_order r (irreds r)).
Definition E48Io := Bint_cco \0c \1c.
Definition E48AJIo := increasing_mappings_order E48Js E48Io.
Definition E48APIo := increasing_mappings_order E48Ps E48Io.
Definition E48AJI := increasing_mappings E48Js E48Io.
Definition E48API := increasing_mappings E48Ps E48Io.
Definition E48AJImo:=
  induced_order E48AJIo ((substrate E48AJIo) -s1 E48z).

Lemma Exercise4_8f K: sub K (substrate r) ->
   order_on (opp_order (induced_order r K)) K.
Proof.
move: Exercise4_7b => or Ksr.
move: (iorder_osr or Ksr) => [or1 sr1]; rewrite - {2} sr1;exact: (opp_osr or1).
Qed.

Lemma Exercise4_8g:
  order_on E48Js (irreds r) /\ order_on E48Ps E48P.
Proof.
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
by move: (Exercise4_8f s1) (Exercise4_8f Exercise4_7e) => [p1 p2][p3 p4].
Qed.

Lemma Exercise4_8h: order_on E48Io E48I.
Proof.
hnf;move: (Binto_wor \0c \1c)=> [[ok _] ->].
split => //;set_extens t.
  move /(BintcP BS1) => t1.
  case: (equal_or_not t \1c) => to; first by apply /set2_P; right.
  by move /card_lt1: (conj t1 to) => -> ; apply /set2_P; left.
by case /set2_P => ->; apply /(BintcP BS1); fprops.
Qed.

Lemma Exercise4_8iP K: sub K (substrate r) ->
  let o := opp_order (induced_order r K) in
  let A:= increasing_mappings o E48Io in
 forall f, inc f A <->
  [/\ function f, source f = K, target f = E48I &
  (forall i j, inc i K -> inc j K -> gle r i j ->
     Vf f j = \1c -> Vf f i = \1c)].
Proof.
move=> Ksr o A f.
move: Exercise4_8h (Exercise4_8f Ksr) => [o1 s1] [o2 s2].
have oi: order r by move: lr => [or _].
move: (iorder_osr oi Ksr) => [o0 s0].
split.
  move /soimP => [[ff sf tf] incf]; split => //; try ue.
  move => i j isr jsr ij f1.
  move:incf => [p1 p2 [p3 p4 p5] p6].
  have aux: gle o j i by apply /opp_gleP/iorder_gle5P;split => //.
  move: (p6 _ _ aux).
  rewrite f1;move /Binto_gleP => [_] /(BintcP BS1) => pa pb; co_tac.
move=> [ff sf tf incf].
have aux: function_prop f (substrate o) (substrate E48Io) by split => //; ue.
apply /soimP; split => //; split => //.
move => x y; move/ opp_gleP /iorder_gle5P => [xk yk yx].
have wx: inc (Vf f x) (target f) by Wtac.
have wy: inc (Vf f y) (target f) by Wtac.
move: s1; rewrite (proj2 (Binto_wor \0c \1c)) => ww.
rewrite tf in wx wy;apply /(Binto_gleP); rewrite ww;split => //.
move: (incf _ _ xk yk yx).
case /set2_P: wx => -> ; case /set2_P: wy => ->; fprops.
by move => h; move: (h (erefl \1c)) => ->; fprops.
Qed.

Lemma Exercise4_8j K: sub K (substrate r) ->
  let o := opp_order (induced_order r K) in
  let A:= increasing_mappings o E48Io in
  let no := increasing_mappings_order o E48Io in
  order_on no A.
Proof.
move=> Ksr o A no; move: (Exercise4_8f Ksr) Exercise4_8h => [p1 p2] [p3 p4].
by apply: imo_osr.
Qed.

Lemma Exercise4_8k:
  order_on E48AJIo E48AJI /\ order_on E48APIo E48API.
Proof.
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
by move: (Exercise4_8j s1) (Exercise4_8j Exercise4_7e) => [p1 p2][p3 p4].
Qed.

Lemma Exercise4_8l: inc E48z (substrate E48AJIo).
Proof.
move: Exercise4_8k => [[_ p1] _ ]; rewrite p1.
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
have ta: lf_axiom (fun _ : Set => \0c) (irreds r) E48I.
   rewrite /E48I;move=> t _; fprops.
apply /(Exercise4_8iP s1); rewrite /E48z; aw;split => //.
  by apply: lf_function.
move => i j ii ji; aw.
Qed.

Lemma Exercise4_8m:
 order_on E48AJImo (E48AJI -s1 E48z) /\
 forall f, inc f (substrate E48AJImo) <->
    (inc f E48AJI /\ Vf f (the_least r) = \1c).
Proof.
move: Exercise4_8k Exercise4_8l => [[p1 p2] _] p3.
have p4:sub (E48AJI -s1 E48z) E48AJI by apply: sub_setC.
move: p4; rewrite -p2 => p5.
have p6:substrate E48AJImo = E48AJI -s1 E48z.
  rewrite /E48AJImo; aw; ue.
split; first by apply:(iorder_osr p1 p5).
move: Exercise4_7d => lj.
have ta:lf_axiom (fun _ : Set => \0c) (irreds r) E48I.
  rewrite /E48I => t _; fprops.
rewrite p6 p2=> f; split; last first.
  move=> [p7 p8];apply /setC1_P; split => //.
  move=> sf; rewrite sf in p8; move: p8; rewrite /E48z; aw; fprops.
move /setC1_P => [p7 p8];split => //.
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
move: p7 => /(Exercise4_8iP s1) [ff sf tf icf].
move: (lj); rewrite - sf => lj1.
move: (Vf_target ff lj1);rewrite tf; case /set2_P => // wlp.
case: p8; rewrite /E48z;apply: function_exten;aw.
  by apply: lf_function.
move=> x xsf; move: (xsf); rewrite sf => xsr;aw.
move: (Vf_target ff xsf);rewrite tf; case /set2_P => // wo.
move: lr => [or _].
move: (the_least_pr or Exercise4_7c) => [_ tle].
move: (icf _ _ lj xsr (tle _ (s1 _ xsr)) wo).
by rewrite wlp; move=> ->.
Qed.

Lemma Exercise4_8n x: inc x (substrate r) ->
  inc (char_fun (E47S r x) (irreds r)) (substrate E48AJImo).
Proof.
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
move => xsr.
move: (Exercise4_7q xsr) (Exercise4_7g xsr) => q0 q1.
move: Exercise4_8m => [[p1 p2] p3]; rewrite p3.
split; last by rewrite char_fun_V_a //.
apply /(Exercise4_8iP s1); rewrite /char_fun;aw;split => //.
    apply: char_fun_f.
  apply: set2_C.
move=> i j isr jsr ij; aw; try apply: char_fun_axioms.
rewrite /varianti.
Ytac jE; last by move=> zo; case: card1_nz.
move=> _; Ytac iE => //; case: iE.
move: jE isr => /Zo_hi [_ jx] /Zo_P [pa pb]; apply /Zo_P;split => //.
move: lr => [or _];split => //; order_tac.
Qed.

Lemma Exercise4_8o x: inc x (substrate r) ->
  let comp:= fun X => X -s1 (the_least r) in
  inc (char_fun (comp (E47S r x)) E48P) E48API.
Proof.
move: (Exercise4_7e) => s1.
move => xsr comp.
apply /(Exercise4_8iP s1); rewrite /char_fun;aw;split => //.
    apply: char_fun_f.
  apply: set2_C.
move=> i j isr jsr ij; aw; try apply: char_fun_axioms.
rewrite /varianti;Ytac jE; last by move=> zo; case: card1_nz.
move=> _; Ytac iE => //; case: iE.
move:jE isr => /setC1_P [] /Zo_hi [_ jx] njl /Zo_P []/Zo_P [pa pb]/set1_P nil.
apply /setC1_P;split => //; apply /Zo_P;split => //; split => //.
move: lr => [or _];order_tac.
Qed.

Lemma Exercise4_8p f: function f -> target f = E48I ->
   char_fun (inv_image_by_fun f (singleton \1c)) (source f) = f.
Proof.
move=> ff tf;rewrite /char_fun; apply: function_exten; aw.
  apply: char_fun_f.
  rewrite tf set2_C //.
move=> x xs; rewrite /inv_image_by_fun; aw; last by apply: char_fun_axioms.
move: (Vf_target ff xs); rewrite tf; case /set2_P => wf.
  rewrite /varianti Y_false //; move /iim_graph_P => [u] /set1_P -> h.
  move: (Vf_pr ff h); rewrite wf; fprops.
rewrite /varianti Y_true //; apply /iim_graph_P; exists \1c; fprops.
by rewrite -wf; apply: Vf_pr3.
Qed.

Lemma Exercise4_8qP X Y Z: sub X Z -> sub Y Z ->
  ((sub X Y) <-> (forall x, inc x Z ->
    gle E48Io (Vf (char_fun X Z) x) (Vf (char_fun Y Z) x))).
Proof.
move => XZ YZ; split.
   move => XY x xZ.
  apply / (Binto_gleP2 BS0 BS1).
  case: (inc_or_not x X) => xX.
   rewrite (char_fun_V_a XZ xX) (char_fun_V_a YZ (XY _ xX)); split;fprops.
  have xc: inc x (Z -s X) by apply /setC_P.
  rewrite (char_fun_V_b XZ xc).
  case: (inc_or_not x Y) => xY.
     by rewrite (char_fun_V_a YZ xY);split;fprops.
  have xc1: inc x (Z -s Y) by apply /setC_P.
  rewrite (char_fun_V_b YZ xc1); split;fprops.
move=> h t tx; move: (h _ (XZ _ tx)).
rewrite /E48Io; move /(Binto_gleP) => [_ _ aux]; ex_middle ty.
have tc: inc t (Z -s Y) by apply /setC_P;split => //; apply: XZ.
move: aux; rewrite (char_fun_V_a XZ tx) (char_fun_V_b YZ tc).
move: card_lt_01 => p1 p2; co_tac.
Qed.

Lemma Exercise4_8r: order_isomorphic r E48APIo.
Proof.
pose comp X:= X -s1 (the_least r).
pose chrf x := char_fun (comp (E47S r x)) E48P.
have ta: lf_axiom chrf (substrate r) E48API.
 by move=> x xsr;apply: Exercise4_8o.
exists (Lf chrf (substrate r) E48API).
move: lr => [or _]; move: Exercise4_8k => [_ [p1 p2]].
have chrp: forall u, inc u (substrate r) -> sub (comp (E47S r u)) E48P.
  move=> u usr; move: (Exercise4_7q usr) => aux t /setC1_P [q1 q2] => //.
  by apply /setC1_P;split => //; apply: aux.
split => //; aw.
  split; aw => //; apply: lf_bijective => //.
    move => u v usr vsr.
    move /(char_fun_injectiveP (chrp _ usr) (chrp _ vsr))=> scf.
    move: (Exercise4_7g usr)(Exercise4_7g vsr) => leu lev.
    move: (setC1_K leu).
    rewrite -/(comp (E47S r u)) scf /comp (setC1_K lev) => scf1.
    move: (f_equal (supremum r) scf1); rewrite Exercise4_7l // Exercise4_7l //.
   move:Exercise4_8e => [_ p3].
  move=> y yf; set U := inv_image_by_fun y (singleton (\1c)).
  move: yf => /(Exercise4_8iP (Exercise4_7e)) [fy sy ty yp].
  have p4: sub U E48P.
    rewrite - sy /U; apply: sub_inv_im_source => //; rewrite ty.
    rewrite /E48I;apply: set1_sub; fprops.
  have p5: (sub U E48P /\
      (forall x y, inc y U -> inc x E48P -> gle r x y -> inc x U)).
    split => //; move=> x z zU xE xz.
    move: zU => /iim_fun_P [u /set1_P ->] Jg; move: (Vf_pr fy Jg).
    move: (p1graph_source fy Jg); rewrite sy => zy wv.
    apply /iim_fun_P; exists \1c; first by fprops.
    symmetry in wv; rewrite - (yp _ _ xE zy xz wv); apply: Vf_pr3 => //; ue.
  move: (p3 _ p5) => [x xsr aux]; ex_tac.
  by rewrite /chrf /comp -aux /U - sy Exercise4_8p.
red; aw;move=> x y xsr ysr; aw.
move: Exercise4_8g Exercise4_8h => [[q1 q2] [q3 q4]] [q5 q6].
have chrf1: forall x, inc x (substrate r) ->
  [/\ function (chrf x), source (chrf x) = substrate E48Ps &
   target (chrf x) = substrate E48Io].
  move => z zsr; split; first (by apply: char_fun_f).
    by rewrite /chrf /char_fun; aw.
    rewrite /chrf /char_fun; aw; rewrite q6 /E48I set2_C => //; aw.
split.
move => h; move: (Exercise4_7k h) => h1.
  move: (chrf1 _ xsr)(chrf1 _ ysr) => [q7 q8 q9] [q10 q11 q12].
  have aux: (sub (comp (E47S r x)) (comp (E47S r y))).
    by move => t /setC1_P [t1 t2]; apply /setC1_P;split => //; apply: h1.
  move /(Exercise4_8qP (chrp _ xsr) (chrp _ ysr)): aux => hh.
  by apply /imo_gleP; fprops; split => //; fprops; split => //; rewrite q4.
move => h; apply : (Exercise4_7m xsr ysr).
move /(imo_gleP _ q5) :h => [_ _ [_ _]].
rewrite q4 => /(Exercise4_8qP (chrp _ xsr) (chrp _ ysr)).
move=> aux t t1; case: (equal_or_not t (the_least r)) => tl.
  by rewrite tl; apply: Exercise4_7g.
have t2: inc t (comp (E47S r x)) by apply /setC1_P.
by move: (aux _ t2) => /setC1_P [].
Qed.

Lemma Exercise4_8s: order_isomorphic r E48AJImo.
Proof.
pose chrf x := char_fun (E47S r x) (irreds r).
have ta: lf_axiom chrf (substrate r) (substrate E48AJImo).
  by move=> x xsr;apply: Exercise4_8n.
exists (Lf chrf (substrate r) (substrate E48AJImo)).
move: lr => [or _]; move: Exercise4_8k => [[p1 p2] _].
move: Exercise4_8m => [[p3 p4] p5].
have s1: sub (irreds r) (substrate r) by apply: Zo_S.
split => //;aw.
   split; aw; apply: lf_bijective => //.
    move => u v usr vsr.
    move /(char_fun_injectiveP (Exercise4_7q usr) (Exercise4_7q vsr))=> scf.
    move: (f_equal (supremum r) scf); rewrite Exercise4_7l // Exercise4_7l //.
  move:Exercise4_8d => [_ p6].
  move=> y yf; set U := inv_image_by_fun y (singleton (\1c)).
  move: yf; rewrite p5; move => [aux Wl]; move: aux.
  move /(Exercise4_8iP s1) => [fy sy ty yp].
  have p7: sub U (irreds r).
    rewrite - sy /U; apply: sub_inv_im_source => //; rewrite ty.
    rewrite /E48I;apply: set1_sub; fprops.
  have p8: nonempty U.
    exists (the_least r); apply /iim_fun_P.
    exists \1c; [ fprops | rewrite -Wl; apply: Vf_pr3 => // ].
    by rewrite sy;apply: Exercise4_7d.
  have p9: [/\ sub U (irreds r), nonempty U &
      (forall x y, inc y U -> sup_irred r x -> gle r x y -> inc x U)].
    split => //; move=> x z zU xE xz.
    move: zU => /iim_fun_P [u /set1_P ->] Jg; move: (Vf_pr fy Jg).
    move: (p1graph_source fy Jg); rewrite sy => zy wv.
    apply /iim_fun_P;exists \1c; first by fprops.
    have xE1: inc x (irreds r) by apply: Zo_i => //; order_tac.
    symmetry in wv;rewrite - (yp _ _ xE1 zy xz wv); apply: Vf_pr3 => //; ue.
  move: (p6 _ p9) => [x xsr aux]; ex_tac.
  by rewrite /chrf -aux /U - sy Exercise4_8p.
red; aw;move=> x y xsr ysr; aw; rewrite -/(chrf x) -/ (chrf y).
move: Exercise4_8g Exercise4_8h => [[q1 q2] [q3 q4]] [q5 q6].
move: (ta _ xsr) (ta _ ysr); rewrite p5 p5; move=> [p6 p7] [p8 p9].
have ta1: lf_axiom (fun _ : Set => \0c) (irreds r) E48I.
  by rewrite /E48I => t _; fprops.
move : Exercise4_7d => aux2.
have p10:inc (chrf x) ((substrate E48AJIo) -s1 E48z).
  apply /setC1_P;split; [ue | move=> h; move: p7; rewrite h / E48z; aw; fprops].
have p11:inc (chrf y) ((substrate E48AJIo) -s1 E48z).
  apply /setC1_P;split; [ue | move=> h; move: p9; rewrite h / E48z; aw; fprops].
have chrf1: forall x, inc x (substrate r) ->
  function_prop (chrf x) (substrate E48Js) (substrate E48Io).
  move => z zsr; split; first by apply: char_fun_f.
    by rewrite /chrf /char_fun q2; aw.
  rewrite /chrf /char_fun q6 /E48I set2_C; aw.
split.
   move: (chrf1 _ xsr)(chrf1 _ ysr) => [q7 q8 q9] [q10 q11 q12].
   move => h; apply /iorder_gleP=> //; apply /(imo_gleP _ q5); split;fprops.
   split => //.
   rewrite q2; apply /Exercise4_8qP; try apply: Exercise4_7q => //.
   exact (Exercise4_7k h).
move /iorder_gle5P => [pa pb] /(imo_gleP _ q5) [_ _ [_ _]].
rewrite q2; move/(Exercise4_8qP (Exercise4_7q xsr) (Exercise4_7q ysr)).
by apply: Exercise4_7m.
Qed.

Let M(x) be the set of minimal elements that are >x. If y is in M(x) then S(x) is a strict subset of S(y) and there is z such that z is in S(y) but not in S(x). These elements z are uncomparable, and the number of such z is the cardinal of M(x).

Definition all_uncomp_inP K :=
  sub K E48P /\ forall x y, inc x K -> inc y K -> gle r x y -> x = y.

Definition minimal_in_int x a :=
   glt r x a /\ (forall b, glt r x b -> gle r b a -> b = a).

Definition minimals x := Zo (substrate r) (minimal_in_int x).

Lemma Exercise4_8t x: inc x (substrate r) ->
  exists K, all_uncomp_inP K /\ equipotent K (minimals x).
Proof.
move=> xsr.
pose f y := choose (fun z => inc z (E47S r y) /\ ~ inc z (E47S r x)).
move: lr => [or _ ].
have fpr: forall y, inc y (minimals x) ->
  (inc (f y) (E47S r y) /\ ~ inc (f y) (E47S r x)).
  move=> y ysr; apply choose_pr.
  move: ysr => /Zo_P [ysr [[xle xney] ymin]].
  move: (Exercise4_7k xle) => p1.
  case: (emptyset_dichot ((E47S r y) -s (E47S r x))) => ne.
    move: (Exercise4_7m ysr xsr (empty_setC ne)) => yx.
    case: xney; order_tac.
  by move:ne => [z] /setC_P aux; exists z.
have fpr1: forall y, inc y (minimals x) -> sup r x (f y) = y.
  move=> y ysm; move: (fpr _ ysm) => [p1 p2].
  move: p1 =>/Zo_P [fsr [firr le1]].
  move: (lattice_sup_pr lr xsr fsr) => [p3 p4 p5].
  have p9: glt r x (sup r x (f y)).
    split => //; dneg xs; apply: Zo_i => //; split => //; ue.
  move: ysm => /Zo_P [p6 [p7 p8]].
  apply: p8 => //; apply: p5 => //; order_tac.
set K:= fun_image (minimals x) f.
have KP: sub K E48P.
  move=> t /funI_P [z zm ->]; move: (fpr _ zm).
  move => [] /Zo_P [p1 [p2 p3]] p4; apply /setC1_P;split; first by apply: Zo_i.
  dneg fzl; apply /Zo_P;split => //; split => //; rewrite fzl.
  by move: (the_least_pr or Exercise4_7c) => [_ tle]; apply: tle.
have auK: all_uncomp_inP K.
  split => // u v /funI_P [y ym ->] /funI_P [z zm ->] le1.
  move:(fpr _ ym)(fpr _ zm)=> [] /Zo_P [p1 [p2 p3]] p4 [] /Zo_P [p5 [p6 p7]] p8.
  move: (lattice_sup_pr lr xsr p1) => [_ _ q2].
  move: (lattice_sup_pr lr xsr p5) => [q1 q4 _].
  have: gle r (sup r x (f y)) (sup r x (f z)) by apply: q2 => //; order_tac.
  rewrite (fpr1 _ ym) (fpr1 _ zm) => le2.
  move: ym zm => /Zo_P [r1 [r2 r3]] /Zo_P [r4 [r5 r6]].
  by move: (r6 _ r2 le2) => ->.
exists K;split => //; eqsym;exists (Lf f (minimals x) K);split;aw.
apply: lf_bijective.
    move => t ts; apply /funI_P; ex_tac.
  by move=> u v um vm sf; rewrite -(fpr1 _ um) -(fpr1 _ vm) sf.
by move=> y /funI_P.
Qed.

Converse: if M is a set of uncomparable elements of P, with k elements, there is x such that set_of_minimal x has at least k elements.

Lemma Exercise4_7c1: exists a, greatest r a.
Proof.
move: (finite_set_maximal1 (@sub_refl (substrate r)) nes).
move=> [x xsr xp]; exists x;split => //.
move=> u usr; move: (lattice_sup_pr lr usr xsr); move=> [p1 p2 p3].
move: lr => [or _].
have isr:inc (sup r u x) (substrate r) by order_tac.
by move: (xp _ isr p2) => aux; rewrite - aux in p1.
Qed.

Lemma Exercise4_7i1 x: sub x (substrate r) ->
  has_infimum r x.
Proof.
move: Exercise4_7b => or xr; case: (emptyset_dichot x) => nex.
  move: (the_greatest_pr or Exercise4_7c1) => tlp.
  rewrite nex; exists (the_greatest r).
  rewrite glb_set0 //.
by apply: (lattice_finite_inf2 lr (sub_finite_set xr fs) xr).
Qed.

Lemma Exercise4_8u: infimum r emptyset = the_greatest r.
Proof.
move: Exercise4_7b => or.
move: (the_greatest_pr or Exercise4_7c1) => tlp.
have ok: (sub emptyset (substrate r)) by fprops.
move: (infimum_pr1 or (Exercise4_7i1 ok)).
rewrite (glb_set0) // => tlp1.
by apply: (unique_greatest or).
Qed.

Lemma distributive_rec x T:
  inc x (substrate r) -> sub T (substrate r) ->
  sup r x (infimum r T) = infimum r (fun_image T (fun z => sup r z x)).
Proof.
move: Exercise4_7b => or xsr Tsr.
move: (sub_finite_set Tsr fs) => ft; move: T ft Tsr.
apply: finite_set_induction0.
  move=> ok;set im:= fun_image _ _; have ->: im = emptyset.
    by rewrite /im; apply /set0_P => y /funI_P [z /in_set0].
  rewrite Exercise4_8u.
  move: (the_greatest_pr or Exercise4_7c1) => [_ tlp].
  by move: (tlp _ xsr) => aux; apply: (sup_comparable1 or aux).
move=> K a hrec naK sKas.
have Ksr: sub K (substrate r) by apply: (@sub_trans (K +s1 a)); fprops.
have asr: inc a (substrate r) by apply: sKas; fprops.
move: (Exercise4_7i1 Ksr) => his.
set aux:= fun_image _ _.
set K1 := (fun_image K (fun z : Set => sup r z x)).
have K1sr:sub K1 (substrate r).
  move => t /funI_P [z zK ->].
  move: (lattice_sup_pr lr (Ksr _ zK) xsr) => [p1 _ _]; order_tac.
move: (Exercise4_7i1 K1sr) => K1is.
move: (lattice_sup_pr lr asr xsr) => [p1a p2a p3a].
have saxr: inc (sup r a x) (substrate r) by order_tac.
have ->: aux = K1 +s1 (sup r a x).
   set_extens t.
      move /funI_P => [z zt ->].
      case /setU1_P: zt => s; apply /setU1_P; [left |right; ue].
      apply /funI_P; ex_tac.
   case /setU1_P => h; apply /funI_P.
     move /funI_P: h => [z za zb]; exists z;fprops.
   rewrite h; exists a;fprops.
rewrite (infimum_setU1 lr Ksr his asr) (infimum_setU1 lr K1sr K1is saxr).
move: (infimum_pr1 or his) => /(glbP or Ksr) [[p1K p2K] p3K].
move: (Exercise1_16b lr) => [_ p1 _].
by rewrite ((p1 dl3) _ _ _ xsr p1K asr) (hrec Ksr) -/K1 sup_C.
Qed.

Lemma Exercise4_8v K: all_uncomp_inP K -> exists x,
  inc x (substrate r) /\
   (cardinal K) <=c (cardinal (minimals x)).
Proof.
move=> [kp1 kp2].
For each x in K, we consider f(x) the supremum of the complement of x in K. If u is the sup of K we have f(x) < u.
pose c x := K -s1 x.
have Ks: sub K (substrate r).
  by move => t tk;move: (kp1 _ tk) =>/setC1_P [] /Zo_P [].
have cp: forall x, inc x K -> sub (c x) (substrate r).
  by rewrite /c => x xK t /setC1_P [tK _]; apply: Ks.
pose f x:= supremum r (c x).
set u := supremum r K.
have fpr0: forall x, inc x K -> least_upper_bound r (c x) (f x).
  by move => x xK;move: (supremum_pr1 (proj1 lr) (Exercise4_7i(cp _ xK))).
have fpr1: forall x, inc x K -> u = sup r (f x) x.
  move => x xK; move: (cp _ xK) => asr.
  move: (supremum_setU1 lr asr (Exercise4_7i asr) (Ks _ xK)).
  rewrite {1} /c (setC1_K xK) //.
move: lr => [or _].
have fpr2: forall x, inc x K -> glt r (f x) u.
  move => x xK;move: (cp _ xK) => csr; move: (fpr0 _ xK).
  move => /(lubP or csr) [[fs1 _] _].
  move: (lattice_sup_pr lr fs1 (Ks _ xK)) => [p1 p2 p3].
  split; first by rewrite (fpr1 _ xK); apply: p1.
  move=> fxu; rewrite -(fpr1 _ xK) -fxu in p2.
  have six: sup_irred r x.
    by move: (kp1 _ xK) => /setC1_P [] /Zo_P [].
  have Kir: sub K (irreds r).
    apply: (@sub_trans E48P) => //; apply: sub_setC.
  have cir: sub (c x) (irreds r).
     apply: (@sub_trans K) => //; apply: sub_setC.
  case: (emptyset_dichot (c x)) => ec; last first.
    move: (Exercise4_8c1 (Ks _ xK) six cir p2 ec).
    by move=> [v ] /setC1_P [vK vx] xv;case: vx; move: (kp2 _ _ xK vK xv).
  move: (fpr0 _ xK); rewrite ec lub_set0 // fxu => lu.
  have Ksx: K = singleton x.
    by apply: set1_pr => // t tk; ex_middle tx; empty_tac1 t; apply /setC1_P.
  move: (supremum_singleton or (Ks _ xK)); rewrite -Ksx -/u => ux.
  move: (kp1 _ xK) => /setC1_P [_]; case.
  move: (the_least_pr or Exercise4_7c) => ol.
  by apply: (unique_least or) => //; rewrite - ux.
Assume x and y distinct in K; Then obviously x <= f(y) and sup(f(x),f(y))=u; Thus f is injective.

have fpr3: forall x y, inc x K -> inc y K -> x <> y -> gle r x (f y).
  move => x y xK yK xy; move: (cp _ yK) => cK; move: (fpr0 _ yK).
  by move=> /(lubP or cK) [[_ ub] _]; apply: ub; apply /setC1_P.
have fpr4: forall x y, inc x K -> inc y K -> x <> y ->
  sup r (f x) (f y) = u.
  move=> x y xK yK xy.
  move: (fpr2 _ xK) (fpr2 _ yK) => [p1 _] [p2 _].
  have fxs: inc (f x) (substrate r) by order_tac.
  have fys: inc (f y) (substrate r) by order_tac.
  move: (lattice_sup_pr lr fxs fys) => [p3 p4 p5].
  move: (p5 u p1 p2) => p6.
  have p7: gle r u (sup r (f x) (f y)).
    rewrite (fpr1 _ xK).
    move: (lattice_sup_pr lr fxs (Ks _ xK)) => [p3a p4a p5a].
    apply: p5a => //; move: (fpr3 _ _ xK yK xy) => aux; order_tac.
  order_tac.
have fpr5: forall x y, inc x K -> inc y K -> f x = f y -> x = y.
   move=> x y xK yK sf; ex_middle xny; move: (fpr2 _ xK) => [ _ ]; case.
   have fxs:inc (f x) (substrate r) by move: (fpr2 _ xK) => xx; order_tac.
   by move: (fpr4 _ _ xK yK xny); rewrite /sup - sf supremum_singleton.
Let L be the set of all these f(x). We set v the be the infimum of L, g(x) the infimum of the complement of x in L. The same argument as above says v < g(x)
set L := fun_image K f.
have lp1: sub L (substrate r).
  move=> t /funI_P [z zK ->]; move: (fpr2 _ zK) => xx; order_tac.
have ->: cardinal K = cardinal L.
  apply /card_eqP.
  exists (Lf f K L); split; aw ;apply: lf_bijective; aw.
    move=> t tK; apply /funI_P; ex_tac.
  by move=> y /funI_P.
pose d x := L -s1 x.
have dp: forall x, inc x L -> sub (d x) (substrate r).
  by rewrite /d => x xK t /setC1_P [tK _]; apply: lp1.
pose g x:= infimum r (d x).
set v := infimum r L.
have lp2: forall x, inc x L -> greatest_lower_bound r (d x) (g x).
  by move => x xK;move: (infimum_pr1 or (Exercise4_7i1 (dp _ xK))).
have lp3: forall x, inc x L -> v = inf r (g x) x.
  move => x xK; move: (dp _ xK) => asr.
  move: (infimum_setU1 lr asr (Exercise4_7i1 asr) (lp1 _ xK)).
  rewrite {1} /d (setC1_K xK) //.
have lp4: forall x, inc x L -> glt r v (g x).
  move => x xL;move: (dp _ xL) => csr; move: (lp2 _ xL).
  move /(glbP or csr) => [[fs1 _] _].
  move: (lattice_inf_pr lr fs1 (lp1 _ xL)) => [p1 p2 p3].
  split; first by rewrite (lp3 _ xL); apply: p1.
  move=> gxv; rewrite -(lp3 _ xL) gxv in p2.
  move: (sup_comparable1 or p2); rewrite sup_C.
  rewrite (distributive_rec (lp1 _ xL) csr).
  set aux2 := fun_image _ _.
  case: (emptyset_dichot (d x)) => de.
    have -> : aux2 = emptyset.
     by apply /set0_P => y; rewrite /aux2 de => /funI_P [z /in_set0].
    move: (the_greatest_pr or Exercise4_7c1) => ol.
    move: xL => /funI_P [z zK fz] ie.
    move: (fpr2 _ zK) ol;rewrite -Exercise4_8u ie fz; move => lt [_ xv].
     have usr: inc u (substrate r) by order_tac.
    move: (xv _ usr) => le2; order_tac.
  move: de => [y yd].
  have: inc (sup r y x) aux2 by apply /funI_P;ex_tac.
  move: yd xL => /setC1_P [] /funI_P [z1 z1k eq1] yx /funI_P [z2 z2K eq2].
  have nz12: z1 <> z2 by dneg z12; rewrite eq1 eq2; ue.
  rewrite eq1 eq2 fpr4 // => ua.
  have ->: aux2 = singleton u.
    apply: set1_pr => // t /funI_P [z zd ->].
    move : zd => /setC1_P [] /funI_P [s sk fs3] zx.
    by rewrite fs3 eq2; apply fpr4 => // => h; case: zx; rewrite fs3 h.
  move: (fpr2 _ z2K) => [lt2 ne2].
  have usr: inc u (substrate r) by order_tac.
  by rewrite -/(inf r u u) inf_comparable1=> //; [ apply:nesym | order_tac].
have lp5: forall x y, inc x L -> inc y L -> x <> y -> gle r (g y) x.
  move => x y xL yL xy; move: (dp _ yL) => cL; move: (lp2 _ yL).
  move=> /(glbP or cL) [[_ ub] _]; apply: ub; apply /setC1_P;split => //.
have lp6: forall x y, inc x L -> inc y L -> x <> y -> inf r (g x) (g y) = v.
  move=> x y xL yL xy.
  move: (lp4 _ xL) (lp4 _ yL) => [p1 _] [p2 _].
  have fxs: inc (g x) (substrate r) by order_tac.
  have fys: inc (g y) (substrate r) by order_tac.
  move: (lattice_inf_pr lr fxs fys) => [p3 p4 p5].
  move: (p5 v p1 p2) => p6.
  have p7: gle r (inf r (g x) (g y)) v.
    rewrite (lp3 _ xL).
    move: (lattice_inf_pr lr fxs (lp1 _ xL)) => [p3a p4a p5a].
    apply: p5a => //; move: (lp5 _ _ xL yL xy) => aux; order_tac.
  order_tac.
Since v< g(x) we can choose h(x) such that x< h(x) <= g(x) and h(x) minimal in the interval. This is an injective function (since inf(h(a),h(b)) <= inf(g(a),g(b)) = v.
pose h x := choose (fun a => gle r a (g x) /\ minimal_in_int v a).
have lp7: forall x, inc x L -> (gle r (h x) (g x) /\ minimal_in_int v (h x)).
  move=> x xL; apply choose_pr.
  set U:= Zo (substrate r) (fun a => glt r v a /\ gle r a (g x)).
  have Usr: sub U (substrate r) by apply: Zo_S.
  have neU: nonempty U.
    move:(lp4 _ xL) => lt1;exists (g x); apply: Zo_i=> //;try order_tac.
    split => //; order_tac; order_tac.
  move: (finite_set_minimal1 Usr neU) => [a aU etc].
  move: aU => /Zo_P [a1 [a2 a3]].
  exists a; split => //; split => // b bv ba.
  apply: etc => //; apply: Zo_i => //; try split => //; order_tac.
set M := fun_image L h.
have Mm: sub M (minimals v).
  move=> t /funI_P [z zL ->]; move: (lp7 _ zL) => [p1 p2].
  apply: Zo_i => //; order_tac.
have ->: cardinal L = cardinal M.
  apply /card_eqP; exists (Lf h L M); split;aw; apply: lf_bijective.
      move=> t tL; apply /funI_P; ex_tac.
    move => a b aL bL sh.
    move: (lp7 _ aL) (lp7 _ bL) => [p1 [p2 p3]] [p4 [p5 p6]].
    ex_middle nab;rewrite - sh in p4.
    have gasr: inc (g a) (substrate r) by order_tac.
    have gbsr: inc (g b) (substrate r) by order_tac.
    move: (lattice_inf_pr lr gasr gbsr)=> [g1 g2 g3].
    move: (g3 _ p1 p4); rewrite (lp6 _ _ aL bL nab) => g4;order_tac.
  by move=> y /funI_P.
Obvioulsy v is a solution
exists v;split => //; last by apply: sub_smaller.
by move: (infimum_pr1 or (Exercise4_7i1 lp1)) => /(glbP or lp1) [[ok _] _].
Qed.

End Irred_lattice.

Exercise 4.9 Let E be a distributive lattice, A a sublattice (invariant by sup and inf). Then A is isomorphic to a sublattice of a product of n totally ordered sets iff the maximal cardinal of a free subset containing only irreducible elements is n.
We first characterise the sup and inf in a product. We show that the product of dlattices is a dlattice, that the product of totally ordered sets is a dlattice.

Lemma setX_lattice_sup g (r := order_product g) x y
   (z := sup r x y) (t := inf r x y):
  order_fam g -> (allf g lattice) ->
  inc x (substrate r) -> inc y (substrate r) ->
  [/\ inc z (substrate r),
    inc t (substrate r),
    (forall i, inc i (domain g) -> Vg z i = sup (Vg g i)(Vg x i) (Vg y i)) &
    (forall i, inc i (domain g) -> Vg t i = inf (Vg g i)(Vg x i) (Vg y i))].
Proof.
move => ofg alg xsr ysr.
move: (setX_lattice ofg alg) => []; rewrite -/r => or hr.
move: (hr _ _ xsr ysr); set xy:= doubleton x y; move => [hs hi].
have zsr: inc z (substrate r).
  by move: (sup_pr or xsr ysr hs) => [pa _ _]; rewrite /z; order_tac.
have tsr: inc t (substrate r).
 by move: (inf_pr or xsr ysr hi) => [pa _ _]; rewrite /t; order_tac.
move: (xsr) (ysr); rewrite {1 2} (proj2(order_product_osr ofg)) => xsr1 ysr1.
have sd: sub xy (prod_of_substrates g) by move=> u; case /set2_P => ->.
move: (sup_in_product ofg sd) => [pa pb].
move: hs;rewrite -pa; move => hs; move: (pb hs) => hz.
move: (inf_in_product ofg sd) => [pc pd].
move: hi;rewrite -pc; move => hi; move: (pd hi) => ht.
clear pa pb pc pd hs hi.
have fgf: fgraph (fam_of_substrates g) by rewrite /fam_of_substrates; fprops.
have aidf: forall i, inc i (domain g) ->
   [/\ inc i (domain (fam_of_substrates g)),
     function (pr_i (fam_of_substrates g) i),
    sub xy (source (pr_i (fam_of_substrates g) i)) &
    image_by_fun(pr_i(fam_of_substrates g) i) xy = doubleton (Vg x i) (Vg y i)].
   move => i idg.
    have id: inc i (domain (fam_of_substrates g)).
         by rewrite /fam_of_substrates; bw.
    have fp: function (pr_i (fam_of_substrates g) i) by fprops.
    have sxy: sub xy (source (pr_i (fam_of_substrates g) i)).
      by rewrite /pr_i; aw.
   split => //; set_extens u.
     move => /(Vf_image_P fp sxy) [w wxy ->].
     move: (sxy _ wxy); rewrite {1} /pr_i lf_source => ws.
     rewrite pri_V //; move: wxy;case /set2_P => ->; fprops.
  have ixxy: inc x xy by rewrite /xy; fprops.
  have iyxyy: inc y xy by rewrite /xy; fprops.
  by case /set2_P=> ->; apply /(Vf_image_P fp sxy);
     [exists x | exists y] => //;rewrite pri_V.
split => //.
  move => i idg; move: (f_equal (Vg^~ i) hz); bw; move => ->.
  by move: (aidf _ idg) => [qa qb qc ->].
move => i idg; move: (f_equal (Vg^~i) ht); bw; move => ->.
  by move: (aidf _ idg) => [qa qb qc ->].
Qed.

Lemma setX_dlattice g:
  order_fam g -> (allf g lattice) ->
   (allf g distributive_lattice1) ->
  distributive_lattice1 (order_product g).
Proof.
move => pa pb pc; move: (setX_lattice pa pb) => lp.
move => x y z; set r := (order_product g) => xsr ysr zsr.
move: (setX_lattice_sup pa pb ysr zsr); rewrite -/r.
set yz := inf r y z; move=> [ _ yzsr _ yzv].
move: (setX_lattice_sup pa pb xsr ysr); rewrite -/r.
set xy := sup r x y; move=> [ xysr _ xyv _ ].
move: (setX_lattice_sup pa pb xsr zsr); rewrite -/r.
set xz := sup r x z; move=> [ xzsr _ xzv _ ].
move: (setX_lattice_sup pa pb xsr yzsr); rewrite -/r.
set xyz := sup r x yz; move=> [ xyzsr _ xyzv _ ].
move: (setX_lattice_sup pa pb xysr xzsr); rewrite -/r.
set xyxz := inf r xy xz; move=> [ _ xyxzsr _ xyxzv].
have aux: forall t, inc t (substrate r) -> [/\ fgraph t, domain t = domain g &
   forall i, inc i (domain g) -> inc (Vg t i) (substrate (Vg g i))].
  move => t ; rewrite /r (proj2(order_product_osr pa)) /prod_of_substrates.
  have pd: fgraph (fam_of_substrates g) by rewrite /fam_of_substrates; fprops.
  move/setXb_P; bw; move => [fgt dt hh]; split => //.
  move => i idt; move: (hh _ idt); bw; ue.
move: (aux _ xyzsr) (aux _ xyxzsr) => [g1 d1 v1] [g2 d2 v2].
apply: fgraph_exten => // ; [ ue | rewrite d1 => i idg].
move: (aux _ xsr) (aux _ ysr) (aux _ zsr).
move => [_ _ xsi][_ _ ysi][_ _ zsi].
move: (xsi _ idg)(ysi _ idg)(zsi _ idg) => xsa ysa zsa.
rewrite (xyxzv _ idg) (xyzv _ idg) (yzv _ idg) (xyv _ idg) (xzv _ idg).
rewrite (pc _ idg) //.
Qed.

Lemma setX_torder_dlattice g:
  order_fam g -> (allf g total_order) ->
  (lattice (order_product g) /\ distributive_lattice1 (order_product g)).
Proof.
move => ofg alg.
have aux: forall i, inc i (domain g) -> lattice (Vg g i).
  move => i idg; move: (alg _ idg); apply: total_order_lattice.
split; first by apply: setX_lattice => //.
apply: setX_dlattice => //.
move => i idg; move: (alg _ idg); apply: total_order_dlattice.
Qed.

Lemma setX_lattice_finite_sup
   g (r := order_product g) E (z := supremum r E):
  order_fam g -> (forall i, inc i (domain g) -> lattice (Vg g i)) ->
  finite_set E -> sub E (substrate r) -> nonempty E ->
  (inc z (substrate r) /\
    forall i, inc i (domain g) -> Vg z i = supremum (Vg g i)(fun_image E (Vg^~i))).
Proof.
move => ofg alg fsE sEs neE.
move: (setX_lattice ofg alg) => lp.
move: (lattice_finite_sup2 lp fsE sEs neE) => hs.
move: (supremum_pr (proj1 lp) sEs hs) => []. rewrite -/r -/z => pa pb.
move: pa => [pa1 pa2]; split; first by exact.
move => i idg.
have pc: sub E (productb (fam_of_substrates g)).
  by move: sEs; rewrite (proj2 (order_product_osr _)) /prod_of_substrates.
move: (sup_in_product ofg pc) => [ha hb].
move: hs; rewrite - ha => hc; rewrite /z /r (hb hc); bw.
have fgf: fgraph (fam_of_substrates g) by rewrite /fam_of_substrates; fprops.
have idf: inc i (domain (fam_of_substrates g)) by rewrite /fam_of_substrates;bw.
have fp: function (pr_i (fam_of_substrates g) i) by fprops.
have sE: sub E (source (pr_i (fam_of_substrates g) i)) by rewrite /pr_i; aw.
congr (supremum (Vg g i) _); set_extens t.
  move => /(Vf_image_P fp sE) [y ye ->]; apply /funI_P;ex_tac.
  by rewrite pri_V //; apply:pc.
move /funI_P => [y ye ->]; apply /(Vf_image_P fp sE).
ex_tac;by rewrite pri_V //; apply:pc.
Qed.

We say that A is a sublattice if the sup and and of two elements of A is in A. If E is a lattice, then A is a lattice, sup and inf coincide

Definition sublattice r A :=
   forall x y, inc x A -> inc y A -> (inc (sup r x y) A /\ inc (inf r x y) A).

Lemma sublattice_pr r A (rA:= induced_order r A):
  lattice r -> sublattice r A -> sub A (substrate r)->
  [/\ lattice rA, substrate rA = A,
   (forall a b, inc a A -> inc b A -> sup r a b = sup rA a b) &
   (forall a b, inc a A -> inc b A -> inf r a b = inf rA a b) ].
Proof.
move => lr sla sa.
move: (lr) => [or lr1].
move: (iorder_osr or sa) => [orA srA].
have auxP: forall a b, inc a A -> inc b A -> (gle rA a b <-> gle r a b).
   move => a b aA bA; exact :(iorder_gleP _ aA bA).
have pa: forall a b, inc a A -> inc b A ->
  (least_upper_bound rA (doubleton a b) (sup r a b) /\
   greatest_lower_bound rA (doubleton a b) (inf r a b)).
  move => a b aA bA.
  have da: sub (doubleton a b) (substrate rA).
    by move => t /set2_P [] ->; rewrite srA.
  move: (lr1 _ _ (sa _ aA) (sa _ bA)) => [ta tb].
  move: (sup_pr or (sa _ aA) (sa _ bA) ta) => [s1 s2 s3].
  move: (inf_pr or (sa _ aA) (sa _ bA) tb) => [s4 s5 s6].
  move: (sla _ _ aA bA)=> [s7 s8]; split.
    apply /(lubP orA da); rewrite /upper_bound srA;split => //.
      by split => //;move => y /set2_P [] ->; apply /auxP.
    move => z [zA sz]; apply /auxP => //; apply: s3;
       apply /auxP=> //; apply: sz; fprops.
  apply /(glbP orA da); rewrite /lower_bound srA;split => //.
      by split => //;move => y /set2_P [] ->; apply /auxP.
  move => z [zA sz]; apply /auxP=> //; apply: s6;
  apply /auxP => //; apply: sz; fprops.
split => //.
     split; first by exact.
     rewrite srA; move => x y xA yA; move: (pa _ _ xA yA)=> [qa qb].
     split; [ by exists (sup r x y) | by exists (inf r x y)].
  move => x y xA yA; move: (pa _ _ xA yA)=> [qa qb].
  exact (supremum_pr2 orA qa).
move => x y xA yA; move: (pa _ _ xA yA)=> [qa qb].
exact (infimum_pr2 orA qb).
Qed.

Lemma sublattice_dr r A :
  lattice r -> sublattice r A -> sub A (substrate r)->
  distributive_lattice1 r ->
  distributive_lattice3 (induced_order r A).
Proof.
move=> lr slr sard dl1.
move: (sublattice_pr lr slr sard) => [lA srA sA iA].
have pa: distributive_lattice1 (induced_order r A).
  move => x y z; rewrite srA => xA yA zA.
  rewrite - (sA _ _ xA zA) - (sA _ _ xA yA) - (iA _ _ yA zA).
  move:(proj1 (slr _ _ xA yA)) (proj1 (slr _ _ xA zA)) => xyA xzA.
  rewrite - (iA _ _ (proj1 (slr _ _ xA yA)) (proj1 (slr _ _ xA zA))).
  rewrite - (sA _ _ xA (proj2 (slr _ _ yA zA))).
  exact (dl1 _ _ _ (sard _ xA)(sard _ yA)(sard _ zA)).
exact (proj1 (Exercise1_16a lA) pa).
Qed.

Lemma Exercise4_9a g n A (r := order_product g):
   order_fam g -> (allf g total_order) ->
   inc n Bnat -> cardinal (domain g) = n -> n <> \0c ->
   sub A (substrate r) -> sublattice r A ->
   forall B, free_subset r B ->
      (forall x, inc x B -> sup_irred (induced_order r A) x) ->
      sub B A -> cardinal B <=c n.
Proof.
move => ofg alg nB cdg nz asr slA B frB aiB sbA.
have cn: cardinalp n by fprops.
have snb: inc (succ n) Bnat by fprops.
move: (setX_torder_dlattice ofg alg) => [lg dlg].
proof by contradiction. if false, there is a set C with n+1 elements and we forget about B
case: (card_le_to_el (CS_cardinal B) cn) => // lncB.
have [C CB cs]: exists2 C, sub C B & cardinal C = succ n.
  have pa: cardinal(succ n) <=c cardinal B.
    rewrite (card_card (CS_Bnat snb)).
    case: (finite_dichot (CS_cardinal B)).
      move /BnatP => fb.
      by apply/ (card_le_succ_ltP ).
    by move => ib; apply: finite_le_infinite => //; apply /BnatP.
  move: (cardinal_le_aux1 pa) => /(eq_subset_cardP (succ n)) [C CB eq].
  exists C => //.
  by symmetry;rewrite - (card_card (CS_Bnat snb)); apply /card_eqP.
have scA: sub C A by apply: sub_trans CB sbA.
have aiC : forall x, inc x C -> sup_irred (induced_order r A) x.
  by move => x xc; exact (aiB _ (CB _ xc)).
have frC: free_subset r C.
  by move => x y xc yc xy; move: (CB _ xc) (CB _ yc) => xb yb; apply:frB.
suff: False by done.
clear frB aiB sbA lncB CB B.
To each index, we associate x in C such that x(i) is maximal
pose mip i x := inc x C /\
    forall y, inc y C -> gle (Vg g i) (Vg y i) (Vg x i).
have fsC: finite_set C by red; rewrite cs; apply /BnatP.
have pa: forall i, inc i (domain g) -> exists x, mip i x.
  move => i idg.
  set E := fun_image C (Vg^~i).
  move: (alg _ idg) => toi.
  have fse: finite_set E by apply: finite_fun_image.
  have ser: sub E (substrate (Vg g i)).
     move => t /funI_P [z zC ->].
     move: (asr _ (scA _ zC)); rewrite /r (proj2(order_product_osr ofg)).
     move/prod_of_substratesP => [fgz dz h].
     apply: h => //;ue.
  have [c cC]: nonempty C.
   case: (emptyset_dichot C) => // ec.
   by move: cs; rewrite ec cardinal_set0 => nez; case: (@succ_nz n).
  have ne: nonempty E by exists (Vg c i); apply /funI_P; ex_tac.
  move: (finite_subset_torder_greatest toi fse ser ne) => [x []].
  move: toi => [oi oit].
  rewrite (iorder_sr oi ser) => xe xge.
  move: xe => /funI_P [z zC zv]; exists z; split => //.
  rewrite - zv; move => y yC.
  have ye: inc (Vg y i) E by apply /funI_P;ex_tac.
  exact (iorder_gle1 (xge _ ye)).
pose mx i := choose (fun x => mip i x).
have mxp: forall i, inc i (domain g)-> mip i (mx i).
  move => i idg; rewrite /mx; apply: (choose_pr (pa _ idg)).
have pb: forall i, inc i (domain g) -> inc (mx i) C.
  move => t ta; exact: (proj1 (mxp _ ta)).
Since C is big, one element is not of the form mx i, say it is x. let xb be the sup of the complement of x in C. Then x <= xb
have [x xC xne]: exists2 x, inc x C & forall i, inc i (domain g) -> mx i <> x.
  set f := Lf mx (domain g) C.
  have ff: function f by apply: lf_function.
  move: (fun_image_Starget ff); rewrite {2}/f; aw => s1.
  case: (equal_or_not (image_of_fun f) C) => h.
    move: (image_smaller_cardinal ff); rewrite {2}/f; aw; rewrite cdg.
    rewrite h cs; move:(card_lt_succ nB) => l1 l2; co_tac.
  move: (setC_ne (conj s1 h)) => [x] /setC_P [xc xp].
  exists x=> // i idg mi; case: xp; apply /(Vf_image_P1 ff).
  by rewrite /f;aw; ex_tac; aw.
set xbs:= C -s1 x.
have sxbsC: sub xbs C by move => t /setC1_P [].
have fsx: finite_set xbs by apply: (sub_finite_set sxbsC fsC).
have nex: nonempty xbs.
  case: (emptyset_dichot xbs) => // xe.
  move: cs.
  have ->: C = singleton x.
    by apply: set1_pr => // t tC; ex_middle tnx; empty_tac1 t; apply /setC1_P.
  rewrite cardinal_set1 - succ_zero => bad; case: nz.
  by rewrite (succ_injective1 CS0 (CS_Bnat nB) bad).
have allc:(forall i, inc i (domain g) -> lattice (Vg g i)).
   move => i idg; move: (alg _ idg); apply: total_order_lattice.
move: (sub_trans sxbsC (sub_trans scA asr)) => scbssr.
move: (setX_lattice_finite_sup ofg allc fsx scbssr nex).
set xb:= (supremum r xbs); rewrite -/r; move => [xbsr xbgr].
have sr: (prod_of_substrates g) = substrate r
   by rewrite (proj2 (order_product_osr _)).
have xxb: gle r x xb.
  apply /(order_product_gleP); rewrite sr;split => //.
    by apply: asr; apply: scA.
  move => i idg; rewrite (xbgr _ idg).
  move: (mxp _ idg) => [sa sb].
  move: (alg _ idg) => [ori tori].
  suff: least_upper_bound (Vg g i) (fun_image xbs (Vg^~ i)) (Vg (mx i) i).
    by move => h; rewrite - (supremum_pr2 ori h); apply: sb.
  have sc: sub (fun_image xbs (Vg^~ i)) (substrate (Vg g i)).
     move => t /funI_P [z zbs ->].
     move: (scbssr _ zbs); rewrite - sr; move /(prod_of_substratesP).
     by move => [_ _]; apply.
  have sd: inc (Vg (mx i) i) (fun_image xbs (Vg ^~i)).
    by apply/funI_P; exists (mx i)=> //; apply /setC1_P;split => //; apply: xne.
  apply /(lubP ori sc); split.
   split; first by apply: sc.
   by move => y /funI_P[z zbs ->]; apply: sb; apply sxbsC.
  by move => z [z1]; apply.
Let's rewrite that x is irreducible in A. We have: if x<= sup(a,c) with a in A and c in C then x <= a
have exfr: forall a, inc a xbs -> not (ocomparable r x a).
  move => a /setC1_P [aC ax]; case => lxa.
    by move: (frC _ _ xC aC lxa) => naw; case: ax.
    by move: (frC _ _ aC xC lxa).
move: (sublattice_pr lg slA asr) => [lrA sra supa infa].
move: (sublattice_dr lg slA asr dlg) => dlA.
have hx: forall a b, inc a A -> inc b A ->
   gle r x (sup r a b) -> gle r x a \/ gle r x b.
   move => a b aA bA.
   have auxP: forall a b, inc a A -> inc b A ->
       (gle (induced_order r A) a b <-> gle r a b).
       by move => s t sA tA; apply: iorder_gleP.
   move: (Exercise4_8a lrA dlA (aiC _ xC)); rewrite -/r sra => h.
   move: (scA _ xC) => xA.
   move: (proj1 (slA _ _ aA bA)) => sA.
   move /(auxP _ _ xA sA).
   move : (h _ _ aA bA); rewrite - (supa _ _ aA bA) => ra rb.
   by move: (ra rb); case; [left | right ]; apply /auxP.
have hx1: forall a b, inc a A -> inc b xbs ->
   gle r x (sup r a b) -> gle r x a.
  move => a b aA bb sab.
  move: (exfr _ bb) => nc.
  move: bb => /setC1_P [bC _].
  by case: (hx _ _ aA (scA _ bC) sab) => // lxb; case: nc; left.
let's write C as the set of all f(i), and consider s(i+1)= sup (s(i),f(i)), and s(1) = f(0)
have [f [bf sf tf]]:
   exists f, bijection_prop f (Bint n) xbs.
  suff: Bint n \Eq xbs => //.
   apply /card_eqP; rewrite (card_Bint nB).
   apply: (succ_injective1 (CS_Bnat nB) (CS_cardinal _)).
  by rewrite - (card_succ_pr2 xC) cs.
have ff: function f by fct_tac.
pose Ei i := image_by_fun f (Bint i).
have Eiz: Ei \0c = emptyset.
  have aux: (sub emptyset (source f))by fprops.
  rewrite /Ei Bint_co00.
  by apply /set0_P =>t /(Vf_image_P ff aux) [s] /in_set0.
have Eis: forall i, inc i Bnat -> i <c n ->
     Ei (succ i) = (Ei i) +s1 (Vf f i).
  move => i iB sin; rewrite /Ei.
  move: (BS_succ iB) => siB.
  move: (Bint_M iB) => sc.
  have sa: sub (Bint (succ i)) (source f).
    rewrite sf; apply: Bint_M1 => //.
    by apply /card_le_succ_ltP.
  have sb: sub (Bint i) (source f) by exact (sub_trans sc sa).
  set_extens t.
    move /(Vf_image_P ff sa) => [u us ->]; case: (equal_or_not u i) => ui;
    apply /setU1_P; [right; ue | left; apply /(Vf_image_P ff sb) ].
    by exists u => //;move: us => /(BintsP iB) => h; apply/(BintP iB).
  case /setU1_P=> h; apply /(Vf_image_P ff sa).
      move /(Vf_image_P ff sb):h => [z z1 z2]; by exists z=> //; apply: sc.
      by rewrite h; exists i => //;apply: Bint_si.
have zl: \0c <c n by move: nz => / (strict_pos_P1 nB).
have Eio: Ei \1c = singleton (Vf f \0c).
   rewrite - succ_zero.
   rewrite (Eis _ BS0 zl) Eiz; apply: set1_pr => //; fprops.
   by move => z;case /setU1_P => // /in_set0.
pose sei i := supremum r (Ei i).
have sen: sei n = xb.
  rewrite /sei /Ei - sf -/(image_of_fun _).
  by rewrite (image_by_fun_source ff) (surjective_pr3 (proj2 bf)) tf.
have tb: forall i, inc i Bnat -> i <c n -> inc (Vf f i) xbs.
  by move => i iB ltin; Wtac; rewrite sf; apply /BintP.
have seo: sei \1c = Vf f \0c.
  rewrite /sei Eio (supremum_singleton (proj1 lg)) //.
  apply: scbssr; apply: tb; fprops.
have sel: forall i, inc i Bnat -> i <=c n -> i <> \0c ->
    (sub (Ei i) xbs /\ least_upper_bound r (Ei i) (sei i)).
  move => i iB lein inz.
  have sa:sub (Bint i) (source f).
     rewrite sf; apply: Bint_M1 => //.
  have nei: nonempty (Ei i).
     exists (Vf f \0c); apply /(Vf_image_P ff sa).
      exists \0c => //; apply /BintP => //.
     by apply/ strict_pos_P1.
  have seix: sub (Ei i) xbs by rewrite -tf; apply: (fun_image_Starget1 ff).
  split; first by exact.
  move: (sub_finite_set seix fsx) => fe.
  apply: (supremum_pr1 (proj1 lg)).
  exact(finite_subset_lattice_sup lg fe (sub_trans seix scbssr) nei).
have ses: forall i, inc i Bnat -> i <c n -> i <> \0c ->
     sei (succ i) = sup r (sei i) (Vf f i).
  move => i iB ltin inz; move: (Eis _ iB ltin) => h.
  move: (sel _ iB (proj1 ltin) inz) => [sa sb].
  have se: has_supremum r (Ei i) by exists (sei i).
  move: (sub_trans sa scbssr) => sc.
  have sd: inc (Vf f i) (substrate r) by apply: scbssr; apply: tb.
  by move: (supremum_setU1 lg sc se sd); rewrite -h.
Each s(i) is in A. Thus x <= s(i+1) implies x <= s(i) By induction x <= s(1) absurd
have sea: forall i, inc i Bnat -> i <=c n -> i <> \0c -> inc (sei i) A.
  have ta: forall t, inc t Bnat -> t <c n -> inc (Vf f t) A.
    by move => t tB tn; apply: scA; apply: sxbsC; apply: tb.
  apply: cardinal_c_induction; first by move => _ [].
  move => t tB hrec stn _.
  case: (equal_or_not t \0c) => tnz.
    rewrite tnz succ_zero seo; apply: ta ; fprops.
  have tn: t <c n by apply /card_le_succ_ltP.
  rewrite (ses _ tB tn tnz);apply (slA _ _ (hrec (proj1 tn) tnz) (ta _ tB tn)).
have seb: forall i, inc i Bnat -> i <c n -> i <> \0c ->
   gle r x (sei (succ i)) -> gle r x (sei i).
  move => i iB ltin inz.
  move: (hx1 _ _ (sea _ iB (proj1 ltin) inz) (tb _ iB ltin)).
  by rewrite (ses _ iB ltin inz).
have sec: forall i, \1c <=c i -> i <=c n -> gle r x (sei i).
  rewrite - sen in xxb.
  apply: (cardinal_c_induction4 BS1 nB xxb) => i i1 ltin; apply: seb => //.
     Bnat_tac.
  by move /card_ge1P: i1 => [_ /nesym].
have n1: \1c <=c n by apply: card_ge1; fprops.
have c11: \1c <=c \1c by fprops.
by move: (sec _ c11 n1); rewrite seo=> h;case:(exfr _ (tb _ BS0 zl)); left.
Qed.

Converse. Assume that the maximal number of free subsets of P in n in a finite distributive lattice. Then the set F is isomorphic to a sublattice of n totally ordered sets.

Lemma fun_image_exten x f g:
   (forall t, inc t x -> f t = g t) -> fun_image x f = fun_image x g.
Proof.
   by move => h; set_extens t; move => /funI_P [z zx ->];
      apply /funI_P; ex_tac; rewrite h.
Qed.

Lemma Exercise4_9b r (P := E48P r) n:
  lattice r -> distributive_lattice1 r -> finite_set (substrate r) ->
  nonempty (substrate r) ->
  inc n Bnat -> Exercise4_5_hyp (induced_order r P) n ->
  exists g A f,
    let r' := (order_product g) in
    [/\ order_fam g, (allf g total_order), cardinal (domain g) = n,
    sub A (substrate r') & sublattice r' A /\
    order_isomorphism f r (induced_order r' A)].
Proof.
move => lr dlr fsr nesr nB eh.
move: (proj1 lr) => or.
have s1: sub P (substrate r).
  by rewrite /P/E48P => t /setC1_P [] /Zo_P [ok _] _.
move: (iorder_osr or s1) => [orp sr].
We first partition P into n sets.
move: (Exercise4_5d orp nB eh) => [X1].
rewrite (iorder_sr or s1); move=> [pX1 cX1 aX1].
have aX2: forall x, inc x X1 -> total_order (induced_order r x).
   move => x x1; move: (aX1 _ x1); rewrite iorder_trans //.
   by move: pX1 => [[pa pc] pb]; rewrite -pa; apply: setU_s1.
move: (the_least_pr (proj1 lr) (Exercise4_7c lr fsr nesr)).
set zr := (the_least r); move=> [zrr zrl].
We exclude the case n=0, because P is empty and F is a singleton
case: (equal_or_not n \0c) => nnz.
  move: (proj1(proj1 pX1)).
  rewrite nnz in cX1; rewrite (cardinal_nonemptyset cX1) setU_0 => pe.
  have sis: irreds r = singleton zr.
    rewrite (Exercise4_7f lr fsr nesr); rewrite -/P -pe -/zr.
    by apply: set1_pr => //; fprops; move => z;case /setU1_P => // /in_set0.
  have srs: substrate r = singleton zr.
     apply: set1_pr => // x xr.
     have pa: (E47S r x) = singleton zr.
       apply: set1_pr; first by apply Exercise4_7g.
       move => z /Zo_P [sa [sb _]].
       have : inc z (irreds r) by apply: Zo_i.
       by rewrite sis => /set1_P.
     move: (Exercise4_7l lr fsr nesr xr); rewrite pa.
     by rewrite (supremum_singleton or zrr).
  set g:= Lg emptyset id.
  have c1: order_fam g by rewrite /g; hnf; bw => x; case; case.
  have c2: (allf g total_order) by rewrite /g; red; bw => x /in_set0.
  have c3: cardinal (domain g) = n.
     by rewrite /g nnz; bw; rewrite cardinal_set0.
  set r' := (order_product g).
  have srr: substrate r' = singleton emptyset.
    rewrite /r' (proj2 (order_product_osr _)) /prod_of_substrates /fam_of_substrates /g; bw.
    by apply: setXb_0'.
  have or': order r' by apply: (proj1 (order_product_osr _)).
  have sr1: singletonp (substrate r) by exists zr.
  have sr2: singletonp (substrate r') by exists emptyset.
  move: (set1_order_is2 or or' sr1 sr2) => [f isf].
  set A := substrate r'.
  have c4: sub A (substrate r') by fprops.
  exists g, A, f;split => //; split.
    have esr: inc emptyset (substrate r') by rewrite srr; fprops.
    have aux: gle r' emptyset emptyset by order_tac.
   move => x y; rewrite /A srr => /set1_P -> /set1_P ->.
     rewrite (sup_comparable1 or' aux) (inf_comparable1 or' aux); split;fprops.
   by rewrite iorder_substrate.
To each element of the partition we add e, the least element of F. This gives a family of totally ordered sets Xi
pose Xf i := i +s1 zr.
have sXr: forall x, inc x X1 -> sub (Xf x) (substrate r).
   move => x x1 t;case /setU1_P => xe; last by ue.
     apply: s1; move: pX1 => [[<- pb] pc]; union_tac.
set g:= Lg X1 (fun z => (induced_order r (Xf z))).
have c2: (allf g total_order).
  rewrite /g; red; bw; move => s xs;bw.
  move: (sXr _ xs) => sr'; move: (iorder_osr or sr') => [pa pb].
  split => //; rewrite pb.
  move: (aX2 _ xs) => to1 x y xa ya.
  suff: gle r x y \/ gle r y x by case => le1;[left | right];apply /iorder_gleP.
  have sa: sub s (substrate r).
     apply: sub_trans sr'; move => t; rewrite /Xf; fprops.
  move: xa ; case /setU1_P.
    move: ya; case /setU1_P.
        move: (proj2 to1); aw => h.
        move => iys ixs; move: (h _ _ ixs iys).
        case => h1; [left | right]; apply: (iorder_gle1 h1).
     by move => -> ixs; right; apply: zrl; apply: sa.
  by move => ->; left; apply: zrl; apply: sr'.
have c1: order_fam g.
  hnf;move => x xd; exact (proj1 (c2 _ xd)).
Let gi(x) be the elements y of Xi such that y <= x, and fi(x) the greatest of these elements. The product of the fi will be the iso
pose Fo i x := Zo (Xf i) (fun z => gle r z x).
have Fozr: forall i x, inc x (substrate r) -> inc zr (Fo i x).
   move => i x xsr; apply: Zo_i; [ by rewrite /Xf; fprops | by apply: zrl].
have Fon: forall i x, inc x (substrate r) -> nonempty (Fo i x).
   move => i x xsr; exists zr; apply: (Fozr _ _ xsr).
have Fos: forall i x, inc i X1 -> sub (Fo i x) (substrate (Vg g i)).
 move => i x iX; rewrite /g; bw;rewrite iorder_sr; fprops; apply: Zo_S.
have Fof: forall i x, inc i X1 -> finite_set (Fo i x).
  move => i x iX;apply: sub_finite_set fsr; apply: sub_trans (sXr _ iX).
  apply: Zo_S.
have For: forall i x, inc i X1 -> sub (Fo i x) (substrate r).
   move => i x iX.
   have sa: sub (Fo i x) (Xf i) by apply: Zo_S.
   apply: (sub_trans sa (sXr _ iX)).
pose fo i x := the_greatest (induced_order r (Fo i x)).
have fop: forall i x, inc i X1 -> inc x (substrate r) ->
   greatest (induced_order r (Fo i x)) (fo i x).
   move => i x iX xsr.
   have idg: inc i (domain g) by rewrite /g; bw.
   move: (For _ x iX) => sf.
   move:(c2 _ idg) => tor.
   have sa: sub (Fo i x) (Xf i) by apply: Zo_S.
   have so: (induced_order (Vg g i) (Fo i x)) = (induced_order r (Fo i x)).
       rewrite /g; bw; rewrite iorder_trans //.
   have ori: order (induced_order (Vg g i) (Fo i x)).
     by rewrite so;apply: (proj1 (iorder_osr or _)).
   move:(the_greatest_pr (ori) (finite_subset_torder_greatest
           tor (Fof _ _ iX) (Fos _ _ iX) (Fon _ _ xsr))).
   by rewrite so.
pose fp x := Lg X1 (fun i => fo i x).
set r' := order_product g.
move: (order_product_osr c1) => [ppa ppb].
have ta: forall x, inc x (substrate r) -> inc (fp x) (substrate r').
   rewrite ppb /prod_of_substrates.
   rewrite /fp/g/fam_of_substrates;move => x xsr; apply/setXf_P;bw;split;fprops.
   move => i iX1; bw.
   move: (fop _ _ iX1 xsr) => [h _]; move: h.
   move: (sXr _ iX1) => s2.
   have s3: sub (Fo i x) (Xf i) by apply: Zo_S.
   rewrite (iorder_sr or (sub_trans s3 s2)) (iorder_sr or s2); apply: s3.
set A:= fun_image (substrate r) fp.
have c4: sub A (substrate r').
  by rewrite /A; move => t /funI_P [z zsr ->]; apply: ta.
We note that S(x) is the union of the gi(x). By associativity of the sup, and since x = sup S(x), we get x = sup (fi x). We deduce that f is an order isomorphism
case: (emptyset_dichot X1) => X1ne.
   by case: nnz;rewrite - cX1 X1ne cardinal_set0.
move: (X1ne) => [repX repXX].
have sxp: forall x, inc x (substrate r) ->
    E47S r x = unionb (Lg X1 (fun i => Fo i x)).
   move: pX1 => [[pa pc] pb].
   move => x xsr; set_extens t.
     move /Zo_P => [tsr [si le1]]; apply /setUb_P; bw.
     case: (equal_or_not t zr).
       by move => ->; exists repX => //; bw; apply: Fozr.
     move => ntz.
     have : inc t P by apply: Zo_i; [ apply: Zo_i | move /set1_P].
     rewrite -pa => /setU_P [y ty yx];ex_tac; bw; apply: Zo_i => //.
     rewrite /Xf; fprops.
  move => /setUb_P [y ]; rewrite Lg_domain=> y1; bw; move=>/Zo_P.
  rewrite /Xf; aw; move => [sa sb]; case/ setU1_P: sa => ty; apply /Zo_P.
    have: inc t P by rewrite -pa; union_tac.
    move => /Zo_P [] /Zo_P [ra rb] _;split => //.
   move: (Exercise4_7d lr fsr nesr) => /Zo_P.
   rewrite -/zr; move => [sc sd]; split => //; ue.
have sxp1: forall x, inc x (substrate r) ->
     x = supremum r (fun_image X1 (fun l => supremum r (Fo l x))).
  move => x xsr; move: (sxp _ xsr) => aux.
  set X := (Lg X1 (Fo^~ x)).
  move: (f_equal (supremum r) aux).
  rewrite (Exercise4_7l lr fsr nesr xsr).
  have suXdr: sub (unionb X) (substrate r).
    move =>z /setUb_P; rewrite /X; bw;move => [y yx1]; bw => /Zo_P.
    by move=> [zb _]; apply: (sXr _ yx1).
  set h := Lg (unionb X) id.
  have ra: fgraph h by rewrite /h; fprops.
  have rx: fgraph X by rewrite /X; fprops.
  have rb: sub (range h) (substrate r).
    by rewrite /h =>t /Lg_range_P [b bu ->]; apply: suXdr.
  have rc: (domain h) = unionb X by rewrite /h /X; bw; split;split;fprops.
  have rd: (forall l, inc l (domain X) -> has_sup_graph r (restr h (Vg X l))).
     move => l ld; apply Exercise4_7i => //.
     have re: fgraph (restr h (Vg X l)) by fprops.
     have svd: sub (Vg X l) (domain h) by rewrite /h; bw => t tv; union_tac.
     move => t /(range_gP re); bw; move=> [z ze ->].
     have zu: inc z (unionb X) by union_tac.
     by rewrite restr_ev // /h; bw;apply: suXdr.
  have re: has_sup_graph r h by apply Exercise4_7i => //.
  move: (sup_A2 or ra rb rx rc rd) => [_ xx]; move: (xx re).
  rewrite /sup_graph /h -/X Lg_range Lg_range.
  have -> : (fun_image (unionb X) id) = (unionb X).
     set_extens t; first by by move /funI_P => [a au ->].
     move => tu; apply /funI_P; ex_tac.
  move => ->.
  have ww: forall l, inc l X1 ->
    range (restr (Lg (unionb X) id) (Vg X l)) = (Fo l x).
     move => l lx1; rewrite {2}/X; bw.
     have qa: fgraph (restr (Lg (unionb X) id) (Fo l x)) by fprops.
     have qb: sub (Fo l x) (domain (Lg (unionb X) id)).
        bw; rewrite /X => s sf; apply /setUb_P; bw; ex_tac; bw.
     move: (qb); bw => qc.
     set_extens t.
        by move /(range_gP qa); bw; move => [u uF ->]; bw; apply: qc.
     by move => tf; apply/(range_gP qa); bw; ex_tac; bw; apply: qc.
  move => xv; rewrite {1} xv.
  rewrite {1} /X; bw; congr (supremum r).
  by apply: fun_image_exten => t tx; rewrite (ww _ tx).
have sxp2: forall x, inc x (substrate r) ->
     x = supremum r (fun_image X1 (fun i => (fo i x))).
   move => x xsr; rewrite {1} (sxp1 _ xsr); congr (supremum r).
   apply: fun_image_exten => i iX.
   symmetry; apply: (supremum_pr2 or).
   move: (For _ x iX) => sr1.
   move: (fop _ _ iX xsr) => []; rewrite (iorder_sr or sr1) => ra rb.
   apply /(lubP or sr1); split.
   split; [ apply: (sr1 _ ra) |move => y yf; exact: (iorder_gle1 (rb _ yf)) ].
   move => z [z1 z2]; exact: (z2 _ ra).
have bla: lf_axiom fp (substrate r) A.
  by move => t tsr; apply /funI_P; ex_tac.
set f := Lf fp (substrate r) A.
have bf: bijection f.
   apply: lf_bijective.
       exact.
     move => u v usr vsr suv.
     rewrite (sxp2 _ usr) (sxp2 _ vsr); congr (supremum r _).
     apply: fun_image_exten => t tx.
     move: (f_equal (Vg^~t) suv); rewrite /fp; bw.
   by move => y /funI_P.
have c3: cardinal (domain g) = n by rewrite /g; bw.
have sxp3: forall x, inc x (substrate r) ->
   sub (fun_image X1 (fo^~ x)) (substrate r).
  move => x xsr t=> /funI_P [z z1 ->].
  move: (fop _ _ z1 xsr) => [h _]; move: h.
  move: (For _ x z1) => h; rewrite iorder_sr //; apply: h.
have c6: order_isomorphism f r (induced_order (order_product g) A).
  red; rewrite /f/bijection_prop /fiso_prop lf_source lf_target.
  move: (iorder_osr ppa c4) => [pa' pb'].
  split => //.
  aw;move => x y xsr ysr; move: (bla _ xsr) (bla _ ysr) => f1a f2a.
  have f3a: inc (fp x) (prod_of_substrates g).
    by move: (c4 _ f1a); ue.
  have f4a: inc (fp y) (prod_of_substrates g).
    by move: (c4 _ f2a); ue.
  split.
    move => lexp; apply /iorder_gleP;aw;apply /(order_product_gleP);split => //.
    move => i; rewrite {1}/g; bw => iX.
    move: (fop _ _ iX xsr) => []; rewrite (iorder_sr or (For _ _ iX)).
    move: (fop _ _ iX ysr) => []; rewrite (iorder_sr or (For _ _ iX)).
    move => qa qb qc qd.
    have qe: inc (fo i x) (Xf i) by move: qc => /Zo_P [].
    have qf: inc (fo i y) (Xf i) by move: qa => /Zo_P [].
    rewrite /g /fp; bw; aw.
    have xx: inc (fo i x) (Fo i y).
       apply: Zo_i => //; move: qc => /Zo_P [_ le1]; order_tac.
    apply /iorder_gleP => //; exact: (iorder_gle1 (qb _ xx)).
   aw => le1; move: (iorder_gle1 le1) => /(order_product_gleP) [_ _ ale].
  have ale1: forall i, inc i X1 -> gle r (fo i x) y.
    move: ale; rewrite /g; bw => ale.
    move => i iX; move: (ale _ iX); bw; rewrite /fp; bw => xx.
    move: (fop _ _ iX ysr) => []; rewrite (iorder_sr or (For _ _ iX)) =>/Zo_P.
    move:(iorder_gle1 xx) => le1' [_ le2] _; order_tac.
    rewrite (sxp2 _ xsr); move: (sxp3 _ xsr) => Xsr.
    move: (Exercise4_7i lr fsr nesr Xsr) => hsX.
  move: (supremum_pr1 or hsX) => /(lubP or Xsr) [_].
  apply; split; first by exact.
  by move => t /funI_P [z zi ->]; apply: ale1.
It suffices to show that A is a sublattice
have allg: (forall i, inc i (domain g) -> lattice (Vg g i)).
  move => i idg; move: (c2 _ idg);apply: total_order_lattice.
exists g, A, f; simpl; split => //; split => //.
move => x y xA yA.
move: xA yA (c4 _ xA) (c4 _ yA).
move /funI_P => [x1 xsr ->] /funI_P [y1 ysr ->].
move => x2sr y2sr.
move: (setX_lattice_sup c1 allg x2sr y2sr); rewrite -/r'.
set sxy2 := sup _ _ _; set ixy2 := inf _ _ _.
move => [sxy2s ixy2s sxy2p ixy2p].
have dgX: domain g = X1 by rewrite /g; bw.
have srp: forall t, inc t (substrate r') -> (fgraph t /\ domain t = domain g).
  move => t;rewrite ppb /prod_of_substrates /fam_of_substrates.
  have sa: fgraph (Lg (domain g) (fun i => substrate (Vg i g))) by fprops.
  move /setXb_P => [sb -> _]; split; bw.
move: (Exercise4_7o lr xsr ysr) => Sinf.
move: (lattice_sup_pr lr xsr ysr) (lattice_inf_pr lr xsr ysr).
set sxy := sup r x1 y1; set ixy:= inf r x1 y1.
move => [qa qb qc][qd qe qf].
have sxyr: inc sxy (substrate r) by order_tac.
have ixyr: inc ixy (substrate r) by order_tac.
suff: fp sxy = sxy2 /\ fp ixy = ixy2.
   move => [<- <-]; split; apply /funI_P; [by exists sxy| by exists ixy].
move: (proj1 (Exercise1_16a lr) dlr) => dlr3.
split.
  move: (srp _ sxy2s) (srp _ (c4 _ (bla _ sxyr))) => [fg1 d1] [fg2 d2].
  apply: fgraph_exten => //; rewrite d2; first by symmetry.
  red; move => i idg;rewrite (sxy2p _ idg);move: (c2 _ idg); rewrite dgX in idg.
  rewrite /fp; bw => toi.
  have fop1: forall t, inc t (substrate r) ->
     (inc (fo i t) (Fo i t) /\ forall u, inc u (Fo i t) -> gle r u (fo i t)).
    move => t tsr; move: (fop _ _ idg tsr) => [].
    rewrite (iorder_sr or (For _ t idg)) => t1 t2; split; first by exact.
    by move => u uF; move: (iorder_gle1 (t2 _ uF)).
  move: (fop1 _ xsr) (fop1 _ ysr) (fop1 _ sxyr).
  move => [v1 v2][v3 v4][v5 v6].
  have sr1: inc (fo i x1) (substrate (Vg g i)) by apply: (Fos _ x1 idg _ v1).
  have sr2: inc (fo i y1) (substrate (Vg g i)) by apply: (Fos _ y1 idg _ v3).
  move: v1 => /Zo_P [v11 v12].
  move: v3 => /Zo_P [v31 v32].
  have le1 : gle r (fo i x1) (fo i sxy).
    apply: v6; apply: Zo_i => //; order_tac.
  have le2 : gle r (fo i y1) (fo i sxy).
    apply: v6; apply: Zo_i => //; order_tac.
  move: v5 => /Zo_P [v51 v52].
  have : inc (fo i sxy) (irreds r).
     have pi: sub P (irreds r) by apply: sub_setC.
     move: v51; case /setU1_P.
       move => fi; apply: pi; move: pX1 => [[<- _]_ ]; union_tac.
     move => ->; by apply: (Exercise4_7d).
  move /Zo_P => [_ foi].
  move: (Exercise4_8a lr dlr3 foi xsr ysr v52).
  case => lea.
    have leb: inc (fo i sxy) (Fo i x1) by apply: Zo_i.
    move: (v2 _ leb) => lec.
    have led: (fo i sxy) = (fo i x1) by order_tac.
    rewrite led ;rewrite led in le2.
    have cp1: gle (Vg g i) (fo i y1) (fo i x1)
       by rewrite /g; bw; apply/iorder_gleP.
    by rewrite sup_C (sup_comparable1 (proj1 toi) cp1).
  have leb: inc (fo i sxy) (Fo i y1) by apply: Zo_i.
  move: (v4 _ leb) => lec.
  have led: (fo i sxy) = (fo i y1) by order_tac.
  rewrite led ;rewrite led in le1.
  have cp1: gle (Vg g i) (fo i x1) (fo i y1) by rewrite /g;bw;apply/iorder_gleP.
  by rewrite (sup_comparable1 (proj1 toi) cp1).
move: (srp _ ixy2s) (srp _ (c4 _ (bla _ ixyr))) => [fg1 d1] [fg2 d2].
apply: fgraph_exten => //; rewrite d2; first by symmetry.
red;move => i idg; rewrite (ixy2p _ idg); move: (c2 _ idg); rewrite dgX in idg.
rewrite /fp; bw => toi.
have fop1: forall t, inc t (substrate r) ->
     (inc (fo i t) (Fo i t) /\ forall u, inc u (Fo i t) -> gle r u (fo i t)).
    move => t tsr; move: (fop _ _ idg tsr) => [].
    rewrite (iorder_sr or (For _ t idg)) => t1 t2; split; first by exact.
    by move => u uF; move: (iorder_gle1 (t2 _ uF)).
move: (fop1 _ xsr) (fop1 _ ysr) (fop1 _ ixyr).
move => [v1 v2][v3 v4][v5 v6].
have sr1: inc (fo i x1) (substrate (Vg g i)) by apply: (Fos _ x1 idg _ v1).
have sr2: inc (fo i y1) (substrate (Vg g i)) by apply: (Fos _ y1 idg _ v3).
move: v1 =>/Zo_P [v11 v12].
move: v3 => /Zo_P [v31 v32].
move: v5 => /Zo_P [v51 v52].
have le1 : gle r (fo i ixy) (fo i x1).
   apply: v2; apply: Zo_i => //;order_tac.
have le2 : gle r (fo i ixy) (fo i y1).
   apply: v4; apply: Zo_i => //;order_tac.
move: toi => [too tot].
case: (tot _ _ sr1 sr2) => le3.
  rewrite (inf_comparable1 too le3).
  move: le3; rewrite /g; bw => le3;move: (iorder_gle1 le3) => le4.
  have le5: gle r (fo i x1) y1 by order_tac.
  move: (qf _ v12 le5) => l6.
  have l7: gle r (fo i x1) (fo i ixy) by apply: v6; apply: Zo_i => //.
  order_tac.
rewrite inf_C (inf_comparable1 too le3).
move: le3; rewrite /g; bw => le3;move: (iorder_gle1 le3) => le4.
have le5: gle r (fo i y1) x1 by order_tac.
move: (qf _ le5 v32) => l6.
have l7: gle r (fo i y1) (fo i ixy) by apply: v6; apply: Zo_i => //.
order_tac.
Qed.

Exercise 4.10. Let Ex4_10_hyp r n be r is isomorphic to a product of n totally ordered sets; let Ex4_10_conc r n be r is the intersection of n total orders. We show that these are equivalent, and give two examples.

Definition Ex4_10_hyp r n:=
   exists g A f,
     [/\ order_fam g, (allf g total_order), cardinal (domain g) = n ,
     sub A (substrate (order_product g)) &
     order_isomorphism f r (induced_order (order_product g) A)].
Definition Ex4_10_conc r n :=
   exists g, [/\ order_fam g, (allf g total_order), cardinal (domain g) = n ,
   (forall i, inc i (domain g) -> substrate (Vg g i) = substrate r) &
   r = intersectionb g].

We show here that i => (i +c k) %%c n) is a permutation of the set of integers < n

Definition shift_mod_n n k :=
   Lf (fun i => ((i +c k) %%c n)) (Bint n)(Bint n).

Lemma shift_mod_n_ax n k:
 inc n Bnat -> n <> \0c -> inc k Bnat ->
 forall i, inc i (Bint n) -> inc ((i +c k) %%c n) (Bint n).
Proof.
move => nB nz kB i /(BintP nB) => iin; apply /(BintP nB).
apply: crem_pr => //; apply: BS_sum => //.
apply: (BS_le_int (proj1 iin) nB).
Qed.

Lemma shift_mod_n_vl n k i:
  inc n Bnat -> n <> \0c -> k <c n -> i<c n ->
  ((i +c k) %%c n) = Yo (i +c k <c n) (i +c k) ((i +c k) -c n).
Proof.
move => nB nz kn iin.
move: (BS_le_int (proj1 kn) nB) => kB.
move: (BS_le_int (proj1 iin) nB) => iB.
move: (BS_sum iB kB) => sB.
case: (card_le_to_el (CS_Bnat nB) (CS_Bnat sB)) => le1.
  move: (cdiff_pr le1) => aux.
  move: (BS_diff n sB) => dB.
  have h: card_division_prop (i +c k) n \1c ((i +c k) -c n).
     split; first by rewrite (cprod1r (CS_Bnat nB)).
   apply : (csum_lt_simplifiable nB dB nB).
   rewrite aux; exact (csum_Mlelt nB nB (proj1 iin) kn).
   Ytac w; [ co_tac | by rewrite - (proj2 (cquorem_pr sB nB BS1 dB h))].
have h: card_division_prop (i +c k) n \0c (i +c k).
  by split => //; rewrite cprod0r csum0l; fprops.
by Ytac0; rewrite -(proj2 (cquorem_pr sB nB BS0 sB h)).
Qed.

Lemma shift_mod_n_fb n k:
  inc n Bnat -> n <> \0c -> k <c n ->
  bijection (shift_mod_n n k).
Proof.
move => nB nz kn.
move: (BS_le_int (proj1 kn) nB) => kB.
apply: lf_bijective.
  by apply: shift_mod_n_ax.
move => u v /(BintP nB) un /(BintP nB) vn.
  rewrite (shift_mod_n_vl nB nz kn un).
  rewrite (shift_mod_n_vl nB nz kn vn) => le0.
  move: (BS_le_int (proj1 un) nB) => uB.
  move: (BS_le_int (proj1 vn) nB) => vB.
  apply: (csum_simplifiable_right kB uB vB).
  move: (BS_sum uB kB) (BS_sum vB kB) => suB svB.
  move: (card_le_to_el (CS_Bnat nB) (CS_Bnat svB)) => cs.
  move: le0.
  case: (card_le_to_el (CS_Bnat nB) (CS_Bnat suB)) => le1.
    Ytac ww; first by co_tac.
    case: cs => le2.
      Ytac ww1; [co_tac | move => eq1].
      move: (f_equal (card_sum2 n) eq1).
      by rewrite (cdiff_pr le1) (cdiff_pr le2).
    Ytac0 => eq1; move: (f_equal (card_sum2 n) eq1).
    rewrite (cdiff_pr le1) csumA => le3.
    move: (csum_M0le v (CS_Bnat nB)).
    rewrite -(csum_simplifiable_right kB uB (BS_sum nB vB) le3) => lt4; co_tac.
  Ytac0; case: cs => le2; last by Ytac0.
  Ytac ww1; [co_tac | move => eq1].
  move: (f_equal (card_sum2 n) eq1); rewrite (cdiff_pr le2) csumA => le3.
  move: (csum_M0le u (CS_Bnat nB)); symmetry in le3.
  rewrite -(csum_simplifiable_right kB vB (BS_sum nB uB) le3) => lt4; co_tac.
move => y /(BintP nB) yn.
  move: (BS_le_int (proj1 yn) nB) => yB.
  move:(csum_M0le y (CS_Bnat nB)); rewrite csumC => le2.
  case: (card_le_to_el (CS_Bnat kB) (CS_Bnat yB)) => le1.
    move: (cdiff_pr le1) => qa.
    have lt1: (y -c k) <c n by move: (cdiff_le_symmetry le1) => xx; co_tac.
    exists (y -c k); first by apply /(BintP nB).
    by rewrite (shift_mod_n_vl nB nz kn lt1) csumC qa; Ytac0.
  have kyn: k <=c y +c n by move: kn => [kn _]; co_tac.
  move: (cdiff_pr kyn) => eq1.
  move: (BS_diff k (BS_sum yB nB)) => dB.
  have lt1: (y +c n) -c k <c n.
    apply : (csum_lt_simplifiable kB dB nB); rewrite eq1.
    by apply: csum_Mlteq.
  exists ((y +c n) -c k); first by apply /(BintP nB).
  rewrite (shift_mod_n_vl nB nz kn lt1).
  rewrite csumC in eq1; rewrite eq1; Ytac ww; [co_tac | by rewrite cdiff_pr1].
Qed.

Lemma Exercise4_10a r n:
   order r -> inc n Bnat -> n <> \0c -> Ex4_10_hyp r n -> Ex4_10_conc r n.
Proof.
move => or nB nnz [g [A [f [ofg alt cdg saf isf]]]].
We have a family of total orders, indexed by I which is equipotent to J, the set of integers <n. For each k, shift_mod_n give a well-orderings on I, thus a total ordering on the lex product of the family
have [h [bh sh th]]:
   exists h, bijection_prop h (Bint n) (domain g).
  by apply /card_eqP; rewrite (card_Bint nB) cdg.
move: (Bintco_wor n) => [].
set rI := Bint_co n; move => worI srI.
pose hk k := (h \co shift_mod_n n k).
have bcs: forall k, k<c n -> substrate rI = source (hk k).
  move => k kn; rewrite /hk /shift_mod_n; aw.
have bcp: forall k, k<c n -> (h \coP shift_mod_n n k /\ bijection (hk k)).
  move => k kn.
  move: (shift_mod_n_fb nB nnz kn) => bs.
  have pa: h \coP shift_mod_n n k.
     split => //; try fct_tac; rewrite /shift_mod_n; aw.
  by split => //; apply: compose_fb.
pose ork k := image_by_fun (ext_to_prod (hk k) (hk k)) rI.
have orkp: forall k, k<c n ->
   [/\ substrate (ork k) = domain g,
    order_isomorphism (hk k) rI (ork k) &
    worder (ork k)].
   move => k kn.
   move: (order_transportation (proj2 (bcp _ kn)) (proj1 worI) (bcs _ kn)).
   rewrite -/(ork k) => is1; split => //.
        move: (is1) => [_ _[_ _ <-] _]; rewrite {1} /hk; aw.
   by apply: (worder_invariance _ worI); exists (hk k).
pose opk k := order_prod (ork k) g.
have opk_ax: forall k, k <c n -> orprod_ax (ork k) g.
  by move => k kn; move: (orkp _ kn) => [sr _ wo].
have opk_total: forall k, k <c n -> total_order (opk k).
   move => k kn;move: (opk_ax _ kn) => ax; apply: orprod_total=> //.
The ordering on the product F is the intersection of these n total orderings.
set F := substrate (order_product g).
move: (order_product_osr ofg) => [pa pb].
have opksr: forall k, k<c n -> substrate (opk k) = F.
  move => k kn; move: (opk_ax _ kn) => ax.
  rewrite /opk /F orprod_sr // pb //.
have oplc1: forall k, k <c n -> sub (order_product g) (opk k).
  move => k kn t t1.
  move:pa => [kg _ _ _].
  move: (kg _ t1) => pt; move: t1; rewrite - pt.
  set x := P t; set y:= Q t.
  move /order_product_gleP=> [xp yp lexy];apply /(orprod_gle1P (opk_ax _ kn)).
  move: (orkp _ kn) => [srd _ [ok _]].
  have sa: sub (Zo (domain g) (fun i => Vg x i <> Vg y i)) (substrate (ork k)).
    rewrite srd; apply: Zo_S.
  split => //; move => j []; rewrite (iorder_sr ok sa).
  move /Zo_P =>[s1 s2]; split => //; by apply: lexy.
have lt0n: \0c <c n by apply /strict_pos_P1.
have zi: inc \0c (Bint n) by apply /BintP.
have ne1: nonempty (Lg (Bint n) opk).
  by exists (J \0c (opk \0c)); apply /funI_P; exists \0c.
have conc1: (order_product g) = intersectionb (Lg (Bint n) opk).
  set_extens t.
    move => tg; apply /(setIb_P ne1); bw => i ib; bw.
   by move/(BintP nB): ib => lin; apply (oplc1 _ lin).
  move /(setIb_P ne1); bw => h1; move: (h1 _ zi); bw => tz.
  move: (opk_total _ lt0n) => [[gr0 _] _].
  move: (gr0 _ tz); rewrite /pairp; set x := P t; set y:= Q t => eq1.
  have pa': forall i, i <c n -> gle (opk i) x y.
    move => i lin.
    have lic: inc i (Bint n) by apply /(BintP nB).
    move: (h1 _ lic); rewrite - eq1; bw.
  move: (pa' _ lt0n) => /(orprod_gleP (opk_ax _ lt0n)) [xsr ysr _ _ _].
  rewrite - eq1; apply /order_product_gleP;split => //; move => i idg.
  have pc: gle (Vg g i) (Vg x i) (Vg x i).
    move: xsr => /prod_of_substratesP [fgx dx hx].
    move: (hx _ idg) (ofg _ idg) => xsr1 odg.
    by order_tac.
  move: (idg); rewrite -th => idh.
  move: (bij_surj bh idh) => [k]; rewrite sh => /(BintP nB) kn Wk.
  move: (pa' _ kn) => /(orprod_gleP (opk_ax _ kn)) [_ _ ww].
  case: ww; first by move => <-.
  move => [j [jsk lta lea]].
  case: (equal_or_not i j); first by move => ->; exact (proj1 lta).
  move => ij.
  move: (orkp _ kn) => [sa [_ _ [bk sk tk] mk] sc].
  rewrite - tk in jsk.
  move: (bij_surj bk jsk) => [ja jas jav].
  have zl1: gle rI \0c ja.
     apply /(Bintco_gleP nB).
     move: jas; rewrite sk srI; move /(BintP nB)=> jn;split => //.
     apply: czero_least; co_tac.
  red in mk;rewrite sk srI in mk jas.
  move: (proj1 (bcp _ kn)) => cop.
  have zs1:inc \0c (source (shift_mod_n n k)) by rewrite /shift_mod_n; aw.
  move: (mk _ _ zi jas); rewrite jav /hk; aw.
  move: (shift_mod_n_ax nB nnz (BS_le_int (proj1 kn) nB)) => ta.
  rewrite /shift_mod_n (lf_V ta zi) (shift_mod_n_vl nB nnz kn lt0n).
  aw; last (by co_tac); Ytac0; move => eqv; move: (proj1 eqv zl1).
  by rewrite Wk => aux; rewrite - (lea _ (conj aux ij)).
We restrict our orderings to A
pose opkA k := induced_order (opk k) A.
have altA: forall k, k <c n -> (total_order (opkA k)).
   move => k kn; move: (opk_total _ kn) => to1.
   by apply: total_order_sub => //; rewrite (opksr _ kn).
have opkAi: (induced_order (order_product g) A)
    = intersectionb (Lg (Bint n) opkA).
  rewrite /opkA /induced_order conc1.
  have ne2:nonempty (Lg (Bint n) (fun k => opk k \cap coarse A)).
    by exists (J \0c((opk \0c) \cap coarse A)); apply /funI_P; exists \0c.
  move :(setIb_P ne2) (setIb_P ne1); bw => ia ib.
  set_extens t.
    move => /setI2_P [ta tb]; apply /ia => i id; bw.
    by apply /setI2_P;split => //; move /ib: ta; bw => k; move: (k _ id); bw.
  move => pa'; apply /setI2_P; move /ia: pa' => k; split.
    by apply/ib => i id;bw; move: (k _ id); bw => /setI2_P [].
  by move: (k _ zi); bw => /setI2_P [].
It suffices to transport the orderings via the inverse of f
move: (isf) => [_ _ [bf _ _]_].
move: (inverse_bij_fb bf) => bif.
set ibf := (inverse_fun f).
pose orkE k := image_by_fun (ext_to_prod ibf ibf) (opkA k).
have qa: order (order_product g) by apply (proj1 (order_product_osr ofg)).
move: (iorder_osr qa saf) => [qb qb'].
have qc: A = target f.
  by move: isf => [_ _ [_ _ tf] _ ]; rewrite tf qb'.
have qd: substrate (induced_order (order_product g) A) = source ibf.
   rewrite iorder_sr //; rewrite /ibf; aw.
set orkEi := image_by_fun (ext_to_prod ibf ibf)
    (induced_order (order_product g) A).
have orkEip: order_isomorphism ibf (induced_order (order_product g) A) orkEi.
  by apply: order_transportation.
have eq0: orkEi = r.
  move: orkEip => [o1 o2 [bk sk tk] mk].
  move: isf => [_ _ [_ sf tf] mf].
  have tibf: target ibf = source f by rewrite /ibf; aw.
  have sibf: source ibf = target f by rewrite /ibf; aw.
  red in mk; rewrite sibf in mk.
  have ffi: forall z, inc z (source f) ->
      (inc (Vf f z) (target f) /\ Vf ibf (Vf f z) = z).
      move => e zf;split; [ Wtac; fct_tac | by rewrite inverse_V2].
  apply: order_exten => // => x y; split => cp1.
     have xs: inc x (substrate orkEi) by order_tac.
     have ys: inc y (substrate orkEi) by order_tac.
     rewrite - tk tibf in xs ys.
     move: (ffi _ xs) (ffi _ ys) => [pa' pb'] [pc pd].
     by rewrite (mf _ _ xs ys) (mk _ _ pa' pc) pb' pd.
  have xs: inc x (substrate r) by order_tac.
  have ys: inc y (substrate r) by order_tac.
     rewrite - sf in xs ys.
     move: (ffi _ xs) (ffi _ ys) => [pa' pb'] [pc pd].
     by move: cp1; rewrite (mf _ _ xs ys) (mk _ _ pa' pc) pb' pd.
have orkEp: forall k, k<c n ->
  [/\ substrate (orkE k) = substrate r,
    order_isomorphism ibf (opkA k) (orkE k) &
    total_order (orkE k)].
   move => k kn.
   move: (altA _ kn) => tor; move: (tor) => [ok _].
   move: (opk_total _ kn) (opksr _ kn) => [orkn _] srkn.
   have srk: substrate (opkA k) = source ibf.
     by rewrite /ibf; aw;rewrite -qc /opkA iorder_sr // srkn.
  move: (order_transportation bif ok srk).
  rewrite -/ibf -/(orkE k) => ois.
  move: (ois) => [_ o2 [bk sk tk] mk].
  have sr1: substrate (orkE k) = substrate r.
        by rewrite - tk /ibf; aw; move: isf => [_ _ [_ <- _]_].
  split => //; split; [ exact | move => x y xsr ysr].
  rewrite - tk in xsr ysr.
  move: (bij_surj bk xsr) => [x' x's <-].
  move: (bij_surj bk ysr) => [y' y's <-].
  move: tor => [_]; rewrite - sk => tor.
  by case: (tor _ _ x's y's); rewrite mk // => cp1; [left | right].
set G := Lg (Bint n) orkE.
have c0: forall i, inc i (domain G) ->
  [/\ order (Vg G i), total_order (Vg G i) &substrate (Vg G i) = substrate r].
  rewrite /G; bw => i idg; bw; move: idg => /(BintP nB) idg.
  by move: (orkEp _ idg) => [ta [_ tb]];split => //; move: tb => [].
have c1: order_fam G.
  by move => i idg; move: (c0 _ idg) => [ok _].
have c2: (allf G total_order).
  by move => i idg; move: (c0 _ idg) => [_ ok _ ].
have c3: cardinal (domain G) = n.
  by rewrite /G; bw; rewrite card_Bint.
have c4: forall i, inc i (domain G) -> substrate (Vg G i) = substrate r.
  by move => i idg; move: (c0 _ idg) => [_ _ ok ].
exists G;split => //.
rewrite -eq0 /orkEi opkAi /G /orkE.
have fif: injection ibf by move: bif => [].
move: (ext_to_prod_fi fif fif); set hf := (ext_to_prod ibf ibf) => fh.
rewrite /intersectionb /intersectionf (inj_image_setIt _ fh).
have ne2: nonempty (Bint n) by exists \0c; bw.
by bw; set_extens t; move => /(setIt_P _ ne2) hp;
    apply /(setIt_P _ ne2) => j; move: (R_inc j) => ri; move: (hp j); bw.
Qed.

Converse is easy

Lemma Exercise4_10b r n:
  order r -> inc n Bnat -> n <> \0c -> Ex4_10_conc r n -> Ex4_10_hyp r n.
Proof.
move => or nB nz [g [og altg cdg ssr rb]].
case: (emptyset_dichot (domain g)) => nedg.
  by case: nz; rewrite - cdg nedg cardinal_set0.
set E := substrate r.
pose f := cst_graph (domain g).
set A := fun_image E f.
set ff:= Lf f E A.
have ta: lf_axiom f E A by rewrite /A;move => t tdg; apply /funI_P; ex_tac.
have bf: bijection ff.
  apply: lf_bijective => //.
    move => u v udg vdg sv.
    move: (nedg) => [k kdg]; move: (f_equal (Vg^~ k) sv).
    rewrite /f/cst_graph; bw.
  by move => y /funI_P.
move:(order_product_osr og) => [or1 sr1].
have srA: sub A (substrate (order_product g)).
   have aux: fgraph (fam_of_substrates g) by rewrite /fam_of_substrates; fprops.
  rewrite sr1.
  move => t /funI_P [z zi ->]; rewrite /f/cst_graph; bw.
  by apply /prod_of_substratesP;split;fprops; bw;move => i idg; bw; rewrite ssr.
exists g, A, ff;split => //.
move: (iorder_osr or1 srA) => [pa' pb'].
rewrite /ff; split => //; first by rewrite pb'; split; aw.
red; aw;move => x y xE yE.
move: srA ;rewrite sr1 => srA.
move:(ta _ xE) (ta _ yE) => xA yA.
move: (srA _ xA) (srA _ yA) => fxA fyA; aw.
split.
  move => le1; apply /iorder_gleP => //;apply /order_product_gleP; split => //.
  move => i idg; rewrite /f/cst_graph; bw.
  move: le1; rewrite /gle/related rb => le1.
  exact: (setIb_hi le1 idg).
move => h; move :(iorder_gle1 h); move /order_product_gleP => [_ _ ali].
rewrite /gle/related rb; apply: setIb_i.
  case: (emptyset_dichot (domain g)) => neg.
    by case: nz; rewrite - cdg neg cardinal_set0.
  by apply /domain_set0P.
move => i idg; move: (ali _ idg); rewrite /f/cst_graph; bw.
Qed.

Let's say that r1 and r2 are orthogonal if they have the same substrate and if any pair of two distinct elements are comparable by exactly one of the two orderings.
In this case, the union r3 is a total ordering. If we replace r2 by its opposite we get r4, and r1 is the intersection of r3 and r4

Definition orthogonal_order r r' :=
   forall x y, inc x (substrate r) -> inc y (substrate r) -> x <> y ->
   exactly_one (ocomparable r x y) (ocomparable r' x y).

Lemma orthogonal_union_order r r':
   order r -> order r' -> substrate r = substrate r' -> orthogonal_order r r' ->
   (total_order (r \cup r') /\ substrate (r \cup r') = substrate r).
Proof.
move => or or' ss otr; set r'' := r \cup r'.
have gu: sgraph r'' by apply: setU2_graph; fprops.
have sr1: substrate r'' = substrate r.
  set_extens t.
     move /(substrate_P gu).
    case; case => [y];case /setU2_P => h; try substr_tac;rewrite ss; substr_tac.
  move => tsr; apply /(substrate_P gu);left.
  by exists t; apply /setU2_P; left; order_tac.
suff ors: order (r \cup r').
  split => //; split; first by exact.
  rewrite sr1 => x y xsr ysr; case: (equal_or_not x y) => exy.
     rewrite -exy; left; order_tac; ue.
  move: (otr _ _ xsr ysr exy) => [h _].
  rewrite/ocomparable /gle /related /r''; aw; case:h; case => cxy;
   try (solve [left; fprops]); right; fprops.
split => //.
    by red;rewrite sr1 => y ysr; apply /setU2_P;left; order_tac.
  move => y x z; case /setU2_P => le1; case /setU2_P => le2; apply /setU2_P.
  - left; order_tac.
  - have xsr: inc x (substrate r) by substr_tac.
    have ysr: inc y (substrate r) by substr_tac.
    have zsr: inc z (substrate r) by rewrite ss; substr_tac.
    case: (equal_or_not x z) => exz; first by rewrite exz; left; order_tac.
    move: (otr _ _ xsr zsr exz) => [h1 _].
    case: h1; case => cxz; try (by left); try (by right).
      case: (equal_or_not z y) => zy; first by rewrite zy; left.
           move: (otr _ _ zsr ysr zy) => [_]; case;split; last by right.
          left; move: cxz; rewrite /gle/related => cxz; order_tac.
      case: (equal_or_not x y) => yx; first by rewrite yx; right.
        move: (otr _ _ xsr ysr yx) => [_]; case; split; first by left.
        right; move: cxz; rewrite /gle/related => cxz; order_tac.
  - have xsr: inc x (substrate r) by rewrite ss; substr_tac.
    have ysr: inc y (substrate r) by rewrite ss; substr_tac.
    have zsr: inc z (substrate r) by substr_tac.
    case: (equal_or_not x z) => exz; first by rewrite exz; left; order_tac.
    move: (otr _ _ xsr zsr exz) => [h1 _].
    case: h1; case => cx; try (by left); try (by right).
       case: (equal_or_not x y) => xy; first by rewrite xy; left.
         move: (otr _ _ xsr ysr xy) => [_]; case; split;last by left.
         right; move: cx; rewrite /gle/related => cxz; order_tac.
     case: (equal_or_not z y) => zx; first by rewrite zx; right.
       move: (otr _ _ zsr ysr zx) => [_]; case; split;first by right.
       left; move: cx; rewrite /gle/related => cxz; order_tac.
  - right; order_tac.
move => x y; case /setU2_P => le1; case /setU2_P=> le2; try order_tac.
  ex_middle xney.
    have xsr: inc x (substrate r) by substr_tac.
    have ysr: inc y (substrate r) by substr_tac.
    have pa: ocomparable r x y by left.
    have pb: ocomparable r' x y by right.
    by move: (otr _ _ xsr ysr xney) => [_]; case.
 ex_middle xney.
    have xsr: inc x (substrate r) by substr_tac.
    have ysr: inc y (substrate r) by substr_tac.
    have pa: ocomparable r x y by right.
    have pb: ocomparable r' x y by left.
    by move: (otr _ _ xsr ysr xney) => [_]; case.
Qed.

Lemma orthogonal_union_inter r r'
   (r1 := r \cup r') (r2 := r \cup opp_order r'):
   order r -> order r' -> substrate r = substrate r' -> orthogonal_order r r' ->
   [/\ total_order r1, total_order r2,
    substrate r1 = substrate r, substrate r2 = substrate r & r = r1 \cap r2].
Proof.
move => or or' ssr ort1.
move: (opp_osr or') => [or'' sr''].
rewrite - ssr in sr''.
have cc: forall x y, ocomparable r' x y <-> ocomparable (opp_order r') x y.
   move => x y; split.
     by case => pa; [right | left]; apply /opp_gleP.
   by case => pa; [right | left]; apply /opp_gleP.
have ort2: orthogonal_order r (opp_order r').
  move => x y xsr ysr xny; move: (ort1 _ _ xsr ysr xny).
  move => [pa pb]; split.
     by case: pa => h1; [by left | right]; apply /cc.
  by move => [pc pd];case:pb; split => //; apply /cc.
symmetry in sr''.
move: (orthogonal_union_order or or' ssr ort1); rewrite -/r1; move => [pa pb].
move: (orthogonal_union_order or or'' sr'' ort2); rewrite -/r1; move => [pc pd].
split => //.
rewrite - (set_UI2r r r' (opp_order r')); symmetry; apply /setU2id_Pr.
move => t /setI2_P [ta tb].
have gr': sgraph r' by fprops.
move: (gr' _ ta); rewrite /pairp => pt.
have le1: gle r' (P t) (Q t) by rewrite /gle/related pt.
have le2: gle r' (Q t) (P t) by apply /opp_gleP; rewrite /gle/related pt.
have eq1: P t = Q t by order_tac.
have psr: inc (P t) (substrate r) by rewrite ssr; order_tac.
by rewrite - pt -eq1; order_tac.
Qed.

We show that r is isomorphic to a subset of a product of two totally ordered sets iff there is r' orthogonal to it. One way is immediate.

Lemma Exercise4_10c r: order r -> (Ex4_10_hyp r \2c <->
  exists r', [/\ substrate r' = substrate r, order r' & orthogonal_order r r']).
Proof.
move => or; set E := substrate r.
split; last first.
  move => [r' [ssr or' orth]].
  move: (orthogonal_union_inter or or' (sym_eq ssr) orth).
  set r1 := r \cup r'; set r2 := r \cup (opp_order r').
  move => [to1 to2 sr1 sr2 rin]; move: (to1) (to2) => [or1 _] [or2 _].
  apply: (Exercise4_10b or BS2 card2_nz).
  exists (variantLc r1 r2);split => //.
           hnf; bw; move => x xtp; try_lvariant xtp.
        red; bw; move => x xtp; try_lvariant xtp.
      bw; apply: cardinal_set2; fprops.
    bw; move => x xtp; try_lvariant xtp.
    rewrite /intersectionb; bw; rewrite setIf2f; bw.
Assume r isomorphic to a subset of a product of two sets. If x is in E, let x1 and x2 be the two components of the image consider x1 <x2 /\ y2 < x2 . This is an ordering
move => [g [T [f [ofg alt cdg sar oif]]]].
move: (set_of_card_two cdg) => [iA [iB [niAB vcdg]]].
have siA: inc iA (domain g) by rewrite vcdg; fprops.
have siB: inc iB (domain g) by rewrite vcdg; fprops.
set rA:= Vg g iA; set rB:= Vg g iB.
have toA: total_order rA by apply: alt.
have toB: total_order rB by apply: alt.
move: (toA) (toB) => [orA _] [orB _].
pose prA x := Vg (Vf f x) iA; pose prB x := Vg (Vf f x) iB.
pose cmp x y := x = y \/ (glt rA (prA x) (prA y) /\ (glt rB (prB y) (prB x))).
pose cmp' x y := [/\ inc x E, inc y E & cmp x y].
set r' := graph_on cmp E.
have samer: r' = graph_on cmp' E.
  by set_extens t => /Zo_P [pa pb];
   move /setX_P: (pa) => [pd pe pf];apply /Zo_P;split => //; move : pb => [_ _].
have rr': forall x, inc x E -> cmp x x by move => x _; left.
move: (graph_on_sr rr'); rewrite -/r' => sr'.
have or': order r'.
    apply: order_from_rel; split => //.
       move => y x z pa pb.
       case: (equal_or_not y z); [ by move => <- | move => ynz].
       case: pa; [by move => ->| move => [la lb]].
       case: pb; first by move => h; contradiction.
       move => [lc ld]; right; split; order_tac.
    move => x y.
       case; [by move => ->| move => [la _]].
       case; [by move => ->| move => [lb _]].
       order_tac.
  by move => x y _; split; left.
move:(order_product_osr ofg) => [orp srp].
Note that x<= y is x1 <= y1 /\ x2 <= y2. If the first or second components are the same then x and y are comparable
move: (oif) => [_ _ [ff sf tf] mn].
have ta: forall x, inc x (source f) -> inc (Vf f x) T.
  move: tf;rewrite (iorder_sr orp sar) => <-; move => x xsf; Wtac; fct_tac.
have spra: forall x, inc x E ->
   (inc (prA x) (substrate rA) /\ inc (prB x) (substrate rB)).
   rewrite /E - sf => x xsf; move: (sar _ (ta _ xsf)).
   rewrite srp; move /prod_of_substratesP.
   by move => [fgw dw hw]; rewrite /rA/rB /prA /prB; split; apply: hw.
have sprb: forall x y, inc x E -> inc y E ->
     gle rA (prA x) (prA y) -> gle rB (prB x) (prB y) -> gle r x y.
  rewrite /E - sf => x y xsf ysf cp1 cp2; rewrite (mn _ _ xsf ysf).
  move: (ta _ xsf) (ta _ ysf) => xa ya; apply /iorder_gleP => //.
  move: sar; rewrite srp => sa1.
  apply /order_product_gleP;split => //; try apply:sa1 => //.
 rewrite vcdg; move => t; case /set2_P => -> //.
have sprd: forall x y, gle r x y ->
    (gle rA (prA x) (prA y) /\ gle rB (prB x) (prB y)).
  move => x y le1.
  have xsf: inc x (source f) by rewrite sf; order_tac.
  have ysf: inc y (source f) by rewrite sf; order_tac.
  move: le1; rewrite (mn _ _ xsf ysf) => le1.
  move: (iorder_gle1 le1) => /order_product_gleP [_ _ h].
  by split; apply: h.
have sprc: forall x y, gle r' x y <-> cmp' x y.
  by move => x y; apply: graph_on_P1.
exists r'; split => //.
move => x y xsr ysr xny; split.
  move: (spra _ xsr) (spra _ ysr) => [pa pb][pc pd].
  move:(proj2 toA _ _ pa pc); move:(proj2 toB _ _ pb pd) => cp1 cp2.
  case: (equal_or_not (prA x) (prA y)) => neA.
    by left;case:cp1=>cp;[left | right ];apply:sprb => //;rewrite neA;order_tac.
  case: (equal_or_not (prB x) (prB y)) => neB.
    by left;case:cp2=>cp;[left | right ];apply:sprb => //;rewrite neB;order_tac.
  case: cp1; case: cp2 => l1 l2.
     by left; left; apply: sprb.
  right; right; rewrite sprc;split => //; right;split => //; split => //;fprops.
  right; left; rewrite sprc; split => //; right;split => //; split => //;fprops.
  by left; right; apply: sprb.
have ynx: y <> x by apply:nesym.
move => [ca cb]; case:ca => ca; move: (sprd _ _ ca) => [pa pb];
 case: cb; move/sprc => [_ _];case => //; move => [pc pd]; order_tac.
Qed.

Example. Let E be finite with n elements, F the set of singletons and complement of singletons, ordered by inclusion. The least m satisfying the condition is n.

Lemma Exercise4_10d E n
  (F := (fun_image E singleton) \cup (fun_image E (fun z => E -s1 z)))
  (r := sub_order F):
  inc n Bnat -> cardinal E = n ->
  ( Ex4_10_hyp r n /\
   forall m, inc m Bnat -> Ex4_10_hyp r m -> n <=c m).
Proof.
move=> nB cen.
move:(sub_osr F) => [or sr].
The case n= 0 is trivial
case: (equal_or_not n \0c) => nz.
  split; last by move=> m mb _; rewrite nz; apply: czero_least; fprops.
  set g := Lg emptyset id.
  have pa: order_fam g
     by rewrite /g;hnf;bw;move => t /in_set0.
  move: (order_product_osr pa) => [pb pb'].
  move: empty_function_function => [pc pd pe].
  have bef: bijection empty_function.
    split; split => //; rewrite pd ?pe; [move => x y | move => y]; case; case.
  exists g, emptyset, empty_function; rewrite/g;bw;split => //.
        by red;bw;move => t /in_set0.
      by rewrite cardinal_set0.
    fprops.
  have hh: sub emptyset (substrate (order_product g)) by fprops.
  move: (iorder_osr pb hh)=> [sa sb].
  split => //.
       rewrite sb; split => //; rewrite pd sr /F.
      rewrite nz in cen; move: (cardinal_nonemptyset cen) => ->.
      by rewrite funI_set0 funI_set0 setU2_id.
    by red; rewrite pd; move => x y /in_set0.
Basic properties of the orderings.
have pa: forall a, inc a E -> inc (singleton a) F.
  move => a ae; apply /setU2_P; left; apply /funI_P; ex_tac.
have pb: forall a, inc a E -> inc (E -s1 a) F.
  move => a ae; apply /setU2_P; right; apply /funI_P; ex_tac.
have pc: forall a b, inc a E -> inc b E -> a <> b ->
   gle r (singleton a) (E -s1 b).
  move => a b aE bE and; apply /sub_gleP;split;fprops.
  move => t /set1_P ->; apply /setC1_P;split => //.
have pd: forall a, inc a E -> singleton a <> E -s1 a.
  by move => a ae eq; move: (set1_1 a); rewrite eq;apply /setC1_P => //; case.
We show first that there is a solution for n.
split.
We have two injections E -> F, the first one with image F1. We define here the inverse mapping
  set F1:= fun_image E singleton.
  pose ra x := (union x).
  pose rb x := (union (E -s x)).
  have splitF: forall x, inc x F ->
    ( [/\ inc x F1, inc (ra x) E & x = singleton (ra x)]
     \/ [/\ inc x (F -s F1), inc (rb x) E & x = E -s1 (rb x)]).
     move => x; rewrite /F -/F1 /ra /rb => xF.
     case: (inc_or_not x F1) => xF1.
      by left; move: (xF1) => /funI_P [z zE h]; rewrite {2 4} h !setU_1.
     right;move: (xF) => /setU2_P; case => //; move /funI_P => [z zE zv].
     set t := (E -s x).
     have ->: t = singleton z by rewrite /t zv setC_K // => q /set1_P ->.
     by rewrite setU_1; split => //; apply /setC_P.
Let I be the set of integers less than n and h a bijection I -> E; by permutation hk n is another bijection.
  apply (Exercise4_10b or nB nz).
  have [h [bh sh th]]:
   exists h, bijection_prop h (Bint n) E.
     by apply /card_eqP; rewrite card_Bint.
  move: (Bintco_wor n) => [].
  set rI := Bint_co n; move => worI srI.
  pose hk k := (h \co shift_mod_n n k).
  have bcs: forall k, k<c n -> substrate rI = source (hk k).
    move => k kn; rewrite /hk /shift_mod_n; aw.
  have bcp: forall k, k<c n -> (h \coP shift_mod_n n k /\ bijection (hk k)).
    move => k kn.
    move: (shift_mod_n_fb nB nz kn) => bs.
    have qb: h \coP shift_mod_n n k.
       split => //; try fct_tac; rewrite /shift_mod_n; aw.
    by split => //; apply: compose_fb.
  have F1F: sub F1 F by move => t ta; apply /setU2_P; left.
  pose hi k x := Vf (inverse_fun (hk k)) x.
  have bce: forall k x, k <c n -> inc x E -> inc (hi k x) (substrate rI).
    move => k x kn xE.
    move: (bcp _ kn) => [_ bk].
    move: (inverse_bij_fb bk) =>[[fik _] _].
    have si: source (inverse_fun (hk k)) = E by aw; rewrite /hk; aw.
    have -> : substrate rI = target (inverse_fun (hk k)) by aw; rewrite - bcs.
    rewrite /hi;Wtac.
  have bcf:forall k x y, k <c n -> inc x E -> inc y E ->hi k x = hi k y -> x= y.
    move => k x y kn.
    move: (bcp _ kn) => [_ bk].
    have <- : target (hk k) = E by rewrite /hk; aw.
    move => xE yE sv; move : (f_equal (fun z => Vf (hk k) z) sv).
    rewrite inverse_V // inverse_V //.
  move: (worI) => [orI _].
  move: (worder_total worI) => [_ torI].
The following relation is reflexive and total
  pose r1 k x y :=
    [\/ [/\ inc x F1, inc y F1 & (gle rI (hi k (ra x)) (hi k (ra y)))],
     [/\ inc x F1, inc y (F -s F1) &
        (ra x <> rb y \/ (ra x = rb y /\ (hi k (ra x) <> cpred n)))],
     [/\ inc x (F -s F1), inc y F1, (rb x = ra y) &
        (hi k (ra y)) = cpred n ] |
     [/\ inc x (F -s F1), inc y (F -s F1) &
      (gle rI (hi k (rb y)) (hi k (rb x)))]].
  have dr1: forall k x y, r1 k x y -> (inc x F /\ inc y F).
     move => k x y; case.
     by move => [qa qb _]; split => //; apply: F1F.
     by move => [qa] /setC_P [yf _] _;split => //;apply: F1F.
     by move => [] /setC_P [xa _] yb _;split => //;apply: F1F.
     by move => [] /setC_P [xa _] /setC_P [ya _] _;split => //.
  have dr2: forall k x, k <c n -> inc x F -> r1 k x x.
    move => k x kn xF.
    case: (splitF _ xF); move => [qa qb qc].
      by constructor 1; split => //; order_tac;apply: bce.
    by constructor 4; split => //; order_tac; apply: bce.
  have dr3: forall k x y, k <c n -> inc x F -> inc y F ->
       r1 k x y \/ r1 k y x.
    move => k x y kn xF yF.
    case: (splitF _ xF) =>[] [qa qb qc]; case: (splitF _ yF)=> [] [qd qe qf].
    - move: (bce _ _ kn qb) (bce _ _ kn qe) => sr1 sr2.
         case: (torI _ _ sr1 sr2); [left | right ]; in_TP4.
    - case: (equal_or_not (ra x) (rb y)) => cpi.
           case: (equal_or_not (hi k (ra x)) (cpred n)) => cpj.
             right;in_TP4.
           by left; constructor 2; split => //; right.
          by left; constructor 2; split => //; left.
    - case: (equal_or_not (ra y) (rb x)) => cpi.
              case: (equal_or_not (hi k (ra y)) (cpred n)) => cpj.
             left; in_TP4.
           by right; constructor 2;split => //; right.
          by right; constructor 2;split => //; left.
    - move: (bce _ _ kn qb) (bce _ _ kn qe) => sr1 sr2.
        case: (torI _ _ sr2 sr1); [left | right ]; in_TP4.
the relation is antisymmetric and transitive
   have dr4: forall k x y, k<c n -> r1 k x y -> r1 k y x -> x = y.
      move => k x y kn c1 c2.
      move: (dr1 _ _ _ c1) => [xF yF]; case: c1.
      - move => [xF1 yF1 le1].
          have sa: inc x (F -s F1) -> False by move /setC_P => [].
          have sb: inc y (F -s F1) -> False by move /setC_P => [].
          case: (splitF _ xF); last by move => [].
          case: (splitF _ yF); last by move => [].
          move => [_ qb qc] [_ qb' qc'].
          case: c2; [ | move => [] | move => [] | move => []] => //.
            move => [_ _ le2].
              have eq1: (hi k (ra y)) = (hi k (ra x)) by order_tac.
              by rewrite qc qc' (bcf _ _ _ kn qb qb' eq1).
      - move => [xF1 yF1 le1].
          have sa: inc x (F -s F1) -> False by move /setC_P => [].
          move: (yF1) => /setC_P [_ sb].
          case: c2; [ move => [] | move => [] | | move => [_ ]] => //.
          move => [_ _ ta tb].
          by case: le1; rewrite ta //; move => [].
     - move => [xF1 yF1 ta tb].
          have sa: inc y (F -s F1) -> False by move => /setC_P [].
          move: (xF1); move => /setC_P [_ sb].
          case: c2; [ move => [] | | move => [] | move => [] ] => //.
         by move => [_ _]; rewrite ta;case => //; move => [].
     - move => [xF1 yF1 le1].
       move: (xF1)(yF1) =>/setC_P [_ sa] /setC_P [_ sb].
      case: c2; [move => [] | move => [] | move =>[] | move=> [_ _ le2]] => //.
       have eq1: (hi k (rb y)) = (hi k (rb x)) by order_tac.
       case: (splitF _ xF); first by move => [].
       case: (splitF _ yF); first by move => [].
       move => [_ qb ->] [_ qb' ->].
       by rewrite (bcf _ _ _ kn qb qb' eq1).
  move: (cpred_pr nB nz); move=> [pnB pnv].
  have lcpnn: cpred n <c n by rewrite {2} pnv; apply: card_lt_succ.
  have QA: forall u v, gle rI u v -> u = v \/ u <c cpred n.
    move => u v le1; case: (equal_or_not u v); [by left | move => uv; right].
    move: le1 => /(Bintco_gleP nB) [luv vn].
    move: vn; rewrite {1} pnv; move / (card_lt_succ_leP pnB) => tc.
    exact (card_lt_leT (conj luv uv) tc).
  have QB: forall u, inc u (substrate rI) -> gle rI u (cpred n).
     move => u; rewrite srI => /(BintP nB) uc.
     apply /(Bintco_gleP nB);split => //.
     by move: uc; rewrite {1} pnv;move /(card_lt_succ_leP pnB).
  have dr5: forall k x y z, k<c n -> r1 k x y -> r1 k y z -> r1 k x z.
    move => k x y z kn le1 le2.
    move: (dr1 _ _ _ le1) (dr1 _ _ _ le2) => [xF yF] [_ zF].
    case: le1.
    - move => [xF1 yF1 le1].
      have sa: inc x (F -s F1) -> False by move /setC_P => [].
      have sb: inc y (F -s F1) -> False by move /setC_P => [].
      case: (splitF _ xF); last by move => [].
      case: (splitF _ yF); last by move => [].
      move => [_ qb qc] [_ qb' qc'].
      case: le2; move => [p1 p2 p3] => //.
          constructor 1;split => //; order_tac.
        constructor 2; split => //.
        case: (equal_or_not (ra x) (ra y)); [ by move => -> | move => nexy].
        case: (equal_or_not (ra x) (rb z)) => eq1; last by left.
        right; case: (equal_or_not (hi k (ra x)) (cpred n)) => e2; last by done.
        case: (QA _ _ le1); first by move => tb; move: (bcf _ _ _ kn qb' qb tb).
        by move => [_ neq].
    - move => [xF1 yF1 le1]; move: yF1 => /setC_P [_ nyF1].
      case: le2; move=> [p1 p2 p3] //.
         move => p4; constructor 1 ;split => //; rewrite p4; apply: QB.
         apply: bce => //; case: (splitF _ xF); move => [ta tb _] //.
         by move: ta => /setC_P [_ bad].
       constructor 2; split => //.
       case: (equal_or_not (rb y) (rb z)); [ by move => <- | move => neyz].
       case: (equal_or_not (ra x) (rb z)) => eq1; last by left.
       right; case: (equal_or_not (hi k (ra x)) (cpred n)) => e2 //.
       case: (QA _ _ p3); last by rewrite -eq1; move => [_ aux];split => //.
       move => tb; case: neyz.
       case: (splitF _ yF); [by move => [] | move => [_ qb' qc']].
       case: (splitF _ zF); [move => [zf1 _] | move => [_ qb qc]].
         by move: p2 => /setC_P [].
       by rewrite (bcf _ _ _ kn qb qb' tb).
   - move=> [xF1 yF1 eq1 eq2]; move: (xF1) => /setC_P [_ nxF1].
     have tc: inc y (F -s F1) -> False by move /setC_P => [].
     case: le2; move=> [p1 p2 p3] //.
       case: (QA _ _ p3); last by move => [_].
       case: (splitF _ yF); last by move => [].
       case: (splitF _ zF); last by move => [bad _]; move: bad => /setC_P [].
       move => [_ qb qc] [_ qb' qc'] tb.
       move: (bcf _ _ _ kn qb' qb tb) => sra.
       constructor 3;split => //; ue.
     constructor 4; split => //.
     rewrite eq1 eq2;apply: QB; apply: bce => //.
     case: (splitF _ zF); last by move => [_ ok _].
     by move: p2 => /setC_P [_ qa] [qb _].
    - move => [xF1 yF1 le1].
      have sa: inc x F1 -> False by move: xF1 => /setC_P [].
      have sb: inc y F1 -> False by move: yF1 => /setC_P [].
      case: (splitF _ xF); first by move => [].
      case: (splitF _ yF); first by move => [].
      move => [_ qb qc] [_ qb' qc'].
      case: le2; move => [p1 p2 p3] //.
        move => p4; constructor 3;rewrite p3 in le1.
        case: (QA _ _ le1); last by move=> [_ h0].
        case: (splitF _ zF); move => [ta tb tc].
        move => le4; rewrite - (bcf _ _ _ kn tb qb' le4);split => //.
        by move: ta => /setC_P [].
      constructor 4;split => //; order_tac.
  pose ork k := (graph_on (r1 k) F).
  have dr6: forall k, k <c n ->
    (total_order (ork k) /\ substrate (ork k) = F).
    move => k kn.
    have srk: substrate (ork k) = F.
      by rewrite /ork graph_on_sr // => a; apply: dr2.
    split; [split | by exact].
      apply: order_from_rel; split => //.
      by move => x y z; apply: dr5.
      by move => x y ; apply: dr4.
      by move => x y xy; move: (dr1 _ _ _ xy) => [xE yE];split; apply: dr2.
      by rewrite srk => x y xE yE; move: (dr3 _ _ _ kn xE yE);
        case => au; [left | right ]; apply /graph_on_P1.
Each order extens the given one
  have dr7: forall k x y, k <c n -> gle r x y -> gle (ork k) x y.
    move => k x y kn.
    move: (dr6 _ kn) => [[ori _] sri].
    move /sub_gleP => [xF yF sxy].
    case: (equal_or_not x y) => exy; first by rewrite -exy; order_tac; ue.
    apply /graph_on_P1; split => //.
    case: (splitF _ xF); case: (splitF _ yF);move => [yF1 ry ys] [xF1 rx xs].
           move: (set1_1 (ra x)); rewrite -xs =>h0; move: (sxy _ h0).
           by rewrite ys => /set1_P => h1; case: exy; rewrite xs ys h1.
        constructor 2;split => //; left; move => h1.
        move: (set1_1 (ra x)); rewrite -xs =>h0; move: (sxy _ h0).
        by rewrite ys => /setC_P [_] /set1_P.
      case: (equal_or_not (rb x) (ra y)) => ns; last first.
         case: exy; apply: extensionality =>//.
         rewrite ys xs; move => z /set1_P ->; apply /setC_P.
         by split => // /set1_P; apply: nesym.
       have Es: E = singleton (rb x).
         apply: set1_pr => // z zE; ex_middle zb.
         have zx: inc z x by rewrite xs; apply/setC_P;split => //; move /set1_P.
         move: (sxy _ zx); rewrite ys -ns; move /set1_P => //.
       have n1: n = \1c by rewrite - cen Es cardinal_set1.
       constructor 3;split => //.
       move: (bce _ _ kn ry); rewrite srI; move /(BintP nB).
       by rewrite n1; move /card_lt1; rewrite - succ_zero (cpred_pr2 BS0).
    case: exy; rewrite xs ys; congr (E -s1 _).
      case: (p_or_not_p (inc (rb y) x)) => h1.
        by move: (sxy _ h1); rewrite {2} ys => /setC_P [_] /set1_P.
      move: h1; rewrite {1}xs => /setC_P aux; ex_middle ok;case:aux;split => //.
      by move /set1_P; apply:nesym.
It remains to show that the intersection is the given ordering We first show that each element of E is a greatest element and least
  have zz : \0c <c n by apply /strict_pos_P1.
  have zn: inc \0c (Bint n) by apply /BintP.
  have zd: inc \0c (domain (Lg (Bint n) ork)) by bw.
  case: (emptyset_dichot (Lg (Bint n) ork)) => lne.
       have : inc (J \0c (ork \0c)) (Lg (Bint n) ork).
        by apply /funI_P; ex_tac.
      by rewrite lne; move /in_set0.
  have hii: forall x, inc x E -> exists2 k, k<c n & hi k x = cpred n.
      move => x xE; move: (xE); rewrite -th => xE1.
      move: (bij_surj bh xE1) => [y ys yv].
      move: ys; rewrite sh => /(BintP nB) yn.
      have cpin: inc (cpred n) (Bint n) by apply /BintP.
      set k := Yo (y = cpred n) \0c (succ y).
      move: (BS_le_int (proj1 yn) nB) => yB.
      have kn: k <c n.
        rewrite /k; Ytac cyn => //.
        rewrite pnv; apply /(card_lt_succ_leP pnB).
        apply /(card_le_succ_ltP _ yB); split => //.
        by apply /(card_lt_succ_leP pnB); ue.
      have srhk: (source (hk k)) = (Bint n).
         rewrite /hk/shift_mod_n; aw.
      have cpsh: inc (cpred n) (source (hk k)) by rewrite srhk.
      have qh: inc (hi k x) (source (hk k))
         by move: (bce _ _ kn xE); rewrite srI srhk.
      move: (bcp _ kn) => [ta tb].
      have tc: inc (cpred n) (source (shift_mod_n n k)).
          by rewrite /shift_mod_n; aw.
      move: (shift_mod_n_ax nB nz (BS_le_int (proj1 kn) nB)) => td.
      have xv1: x = Vf (hk k) (cpred n).
        rewrite /hk; aw; rewrite /shift_mod_n; aw; rewrite shift_mod_n_vl //.
        rewrite /k; case: (equal_or_not y (cpred n)) => yp; Ytac0.
          by rewrite (csum0r (CS_Bnat pnB)); Ytac0; rewrite -yp.
        have ->: cpred n +c succ y = n +c y.
           by rewrite (csum_via_succ _ yB) - (csum_via_succ1 _ pnB) -pnv.
           Ytac ltna; first by move: (csum_M0le y (CS_Bnat nB)) => lee1; co_tac.
        by rewrite csumC cdiff_pr1.
      have xt: inc x (target (hk k)) by rewrite xv1; Wtac; fct_tac.
      exists k=> //; apply: (bij_inj tb qh cpsh).
      by rewrite /hi -/k (inverse_V tb xt).
  have hij: forall x, inc x E -> exists2 k, k<c n & hi k x = \0c.
      move => x xE; move: (xE); rewrite -th => xE1.
      move: (bij_surj bh xE1) => [y ys yv].
      move: ys; rewrite sh => /(BintP nB) yn.
      exists y => //.
      have srhk: (source (hk y)) = (Bint n).
         rewrite /hk/shift_mod_n; aw.
      have cpsh: inc \0c (source (hk y)) by rewrite srhk.
      have qh: inc (hi y x) (source (hk y))
         by move: (bce _ _ yn xE); rewrite srI srhk.
      move: (bcp _ yn) => [ta tb].
      have tc: inc \0c (source (shift_mod_n n y)).
          by rewrite /shift_mod_n; aw; bw.
      move: (shift_mod_n_ax nB nz (BS_le_int (proj1 yn) nB)) => td.
      have xv1: x = Vf (hk y) \0c.
        rewrite /hk; aw; rewrite /shift_mod_n (lf_V td zn).
        rewrite shift_mod_n_vl // (csum0l (proj31_1 yn)); Ytac0; ue.
      have xt: inc x (target (hk y)) by rewrite xv1; Wtac; fct_tac.
      apply: (bij_inj tb qh cpsh).
      by rewrite /hi (inverse_V tb xt).
  have dr8: r = intersectionb (Lg (Bint n) ork).
    set_extens t => te.
      have gr: sgraph r by fprops.
      move: (gr _ te); rewrite /pairp; set x := P t; set y := Q t => pt.
      apply: (setIb_i lne); bw => i idn; bw.
      move: idn => /(BintP nB) => idn.
      move: te; rewrite -pt -/(related r x y) -/(gle r x y).
      rewrite -/(related (ork i) x y) -/(gle (ork i) x y).
      by apply: dr7.
    move: lne => [xc xcb]; move: (setIb_hi te zd); bw => toz.
    move: (dr6 _ zz); move=> [[orz _] srz].
    have grz: sgraph (ork \0c) by fprops.
    move: (grz _ toz); rewrite /pairp; set x := P t; set y := Q t => pt.
    rewrite -pt -/(related r x y) -/(gle r x y).
    have aux1: forall k, k <c n -> gle (ork k) x y.
      move => k kn.
      have kd: inc k (Bint n) by apply /(BintP nB).
      have kd1: inc k (domain (Lg (Bint n) ork)) by bw.
      move: (setIb_hi te kd1); bw; rewrite - pt //.
    have aux: forall k, k <c n -> r1 k x y.
      by move => k kn; move: (aux1 _ kn) => /graph_on_P1 [_ _ ].
    move: (aux1 _ zz) => le1.
    have xF: inc x F by rewrite - srz; order_tac.
    have yF: inc y F by rewrite - srz; order_tac.
    clear xcb toz orz grz le1.
    apply /sub_gleP;split => //.
    case: (splitF _ xF); case: (splitF _ yF); move => [yF1 ry ys] [xF1 rx xs].
          case: (equal_or_not (ra x) (ra y)) => nsv.
            rewrite xs ys nsv; fprops.
          have b1: inc y (F -s F1) -> False by move /setC_P => [].
          have b2: inc x (F -s F1) -> False by move /setC_P => [].
          move: (hii _ rx) => [k kn hl].
          case: (aux _ kn) => [] [p1 p2 p3] //.
          case: (QA _ _ p3) => ww; last by move: ww => [_].
          rewrite ys xs; rewrite (bcf _ _ _ kn rx ry ww); fprops.
        have b2: inc x (F -s F1) -> False by move /setC_P => [].
        have b1: inc y F1 -> False by move: yF1; move /setC_P => [].
        move: (hii _ rx); move => [k kn hl].
        case: (aux _ kn) => [][p1 p2 p3] //.
        case: p3; last by move => [_ ok].
        by move => ta; rewrite xs ys /setC1_P => z /set1_P ->; apply /setC1_P.
      have b2: inc y (F -s F1) -> False by move /setC_P => [].
      have b1: inc x F1 -> False by move: xF1 => /setC_P [].
      move: (hij _ ry); move => [k kn hl].
      case: (aux _ kn) => [] [p1 p2 p3] //.
      move=>tb z; rewrite xs => /setC1_P [sa sb].
      move: cen; rewrite pnv -tb hl succ_zero => cen.
      by move: (set_of_card_one cen) sa rx sb=> [q ->] /set1_P -> /set1_P ->.
    have b2: inc y F1 -> False by move: yF1 => /setC_P [].
    have b1: inc x F1 -> False by move: xF1 => /setC_P [].
    move: (hii _ ry); move => [k kn hl].
    case: (aux _ kn) => [] [p1 p2 p3] //.
    case: (QA _ _ p3) => ww; last by move: ww => [_].
    rewrite ys xs; rewrite (bcf _ _ _ kn ry rx ww); fprops.
  exists (Lg (Bint n) ork); split => //.
        hnf;move => k kn; bw; move: kn; bw => /(BintP nB) kn.
        by move: (dr6 _ kn) ; move => [[ok _] _].
     red; bw;move =>k kn; bw; move: kn => /(BintP nB) kn.
     by move: (dr6 _ kn) ; move => [ok _].
   by bw; rewrite card_Bint.
  bw; move => k kn; bw; move: kn => /(BintP nB) kn.
  by move: (dr6 _ kn) ; move => [_ ->]; rewrite sr.
Converse. We first eliminate the case m=0
move => m mB h.
set F1:= fun_image E singleton.
case: (emptyset_dichot E).
    by move => ee //; case: nz; rewrite - cen ee // cardinal_set0.
case: (equal_or_not m \0c) => mz.
  move => [a aE]; move: (pd _ aE) (pa _ aE) (pb _ aE) => nab aF bF.
  move: h => [g [A [f [ofg atg cdg asg [_ _ [bf sf tf] _]]]]].
  rewrite sr in sf; rewrite - sf in aF bF.
  case: nab; apply (bij_inj bf aF bF).
  have ff: function f by fct_tac.
  move: (Vf_target ff aF) (Vf_target ff bF) => w1 w2.
  move:(order_product_osr ofg)=> [op sp].
  move: (asg); rewrite sp.
  move: tf; rewrite (iorder_sr op asg) => <- pe.
  move: (pe _ w1)(pe _ w2) => /prod_of_substratesP [qa qb _]
    /prod_of_substratesP [qc qd _].
  apply: fgraph_exten => //; first by ue.
  rewrite mz in cdg.
  by rewrite qb (cardinal_nonemptyset cdg) => x /in_set0.
Assume r is the union of n total orders. Let F the set of singletons. This is finite, nonempty, thus has a greatest element gei i
move => [a aE].
move: (Exercise4_10a or mB mz h) =>[g [ofg atg cdg asi ri]].
have fs1: finite_set F1.
  by apply: finite_fun_image; red; rewrite cen; apply /BnatP.
have sdf: sub F1 (substrate r) by rewrite sr /F/F1 =>t; fprops.
have nef: nonempty F1 by exists (singleton a); apply /funI_P; ex_tac.
pose gei i := the_greatest (induced_order (Vg g i) F1).
have gei_pr: forall i, inc i (domain g) ->
    greatest (induced_order (Vg g i) F1) (gei i).
  move => i idg; move: (atg _ idg) => to1.
  rewrite -(asi _ idg) in sdf.
  move: (finite_subset_torder_greatest to1 fs1 sdf nef) => h1.
  move: (iorder_osr (proj1 to1) sdf)=> [or2 _].
  exact (the_greatest_pr or2 h1).
pose gej i := union (gei i).
have gej_pr: forall i, inc i (domain g) ->
    (inc (gej i) E /\ singleton (gej i) = gei i).
  move => i idg; move: (gei_pr _ idg) => [h1 _].
  move: (proj1 (atg _ idg)) => o1.
  rewrite - (asi _ idg) in sdf.
  move: h1; rewrite iorder_sr //; move /funI_P => [z ze sz].
  by rewrite /gej sz setU_1.
If m<n, there an element xc is not gei. then singleton xc <= compl_singl xc for any ordering
case: (card_le_to_el (CS_Bnat nB) (CS_Bnat mB)) => // ltmn.
move: (fun_image_smaller (domain g) gej).
set F2:= fun_image (domain g) gej; rewrite cdg => aux.
have ss: ssub F2 E.
   split.
     move => t /funI_P [z zdg ->]; move: (gej_pr _ zdg).
     by move => [].
   have :cardinal F2 <c n by co_tac.
   by rewrite - cen; move => [_ h1]; dneg xx; rewrite xx.
move: (setC_ne ss) => [xc] /setC_P [xce nxcf2].
have cp1: forall i, inc i (domain g) ->
   gle (Vg g i) (singleton xc) (E -s1 xc).
  move => i idg; move: (gej_pr _ idg) (gei_pr _ idg) => [qa qb] [].
  have scf1: inc (singleton xc) F1 by apply /funI_P; exists xc.
  move: (ofg _ idg) => oi.
  rewrite - (asi _ idg) in sdf.
  rewrite (iorder_sr oi sdf) => [_ gt].
  move: (iorder_gle1 (gt _ scf1)) => qc.
  case: (equal_or_not (gej i) xc) => nexci.
   case: nxcf2; rewrite - nexci; apply /funI_P; ex_tac.
  have le1: gle r (gei i) (E -s1 xc) by rewrite -qb; apply: pc.
  have le2: gle (Vg g i) (gei i) (E -s1 xc).
    by move: le1; rewrite /gle/related /r ri => le1; apply: setIb_hi.
  order_tac.
case: (emptyset_dichot g) => // ge.
  by case: mz; rewrite - cdg ge domain_set0 cardinal_set0.
have : gle r (singleton xc) (E -s1 xc).
  rewrite /gle/related /r ri; apply: setIb_i => // i idg.
move /sub_gleP => [_ _ hp].
by move: (hp _ (set1_1 xc)) => /setC1_P [_].
Qed.

Exercise 4.11 Pure and Mobile sets.
Let's assume that R is a set whose elements are finite subsets of A. We say that R is mobile when, if X and Y are two distinct elements of R, for any z in X \cap Y there is a subset Z of X \cup Y in R not containing z. We say that P is pure if no subset of P is in R.

Definition mobile_r R := forall X Y, inc X R -> inc Y R -> X <> Y ->
  forall z, inc z (X\cap Y)
   -> exists Z, [/\ inc Z R, sub Z (X \cup Y) & ~ (inc z Z)].
Definition min_incl_r R :=
   Zo R (fun z => forall x, inc x R -> sub x z -> z = x).

Examples: R is mobile if (a) it contains the empty set, (b) it is formed of all finite sets whose cardinal is >n, (c) it is formed of all doubletons, (d) it contains all singletons (e.g., it is formed of all all sets with cardinal <= n

Lemma Ex4_11_ex0 R: inc emptyset R -> mobile_r R.
Proof.
move => er x y xr yr xy z zi.
by exists emptyset;split;fprops; move => /in_set0.
Qed.

Lemma Ex4_11_ex1 A n
   (R := Zo (powerset A) (fun z => finite_set z /\ n <c cardinal z)):
  inc n Bnat -> mobile_r R.
Proof.
move => nB X Y /Zo_P []/setP_P XA [fsx nX]/Zo_P [] /setP_P YA [fsy nY] XY z zXY.
have sa: sub ((X \cup Y) -s1 z) (X \cup Y) by move => t /setC1_P [].
move: (sub_finite_set sa (finite_union2 fsx fsy)) => fsz.
exists ((X \cup Y) -s1 z); split => //; last by move => /setC1_P [].
apply: Zo_i; first by apply /setP_P;move => t /setC1_P []; case /setU2_P;fprops.
split => //.
move: (setI2_2 zXY) => zY.
case: (p_or_not_p (sub X Y)) => sxy.
  move: fsz => /BnatP.
  have -> :(X \cup Y) = Y by apply /setU2id_Pl.
  move => fsz;move: (strict_sub_smaller (conj sxy XY) fsy).
  rewrite (card_succ_pr2 zY).
  move /(card_lt_succ_leP fsz) => le1; co_tac.
case: (emptyset_dichot (X -s Y)) => cne.
    by case: sxy; exact: (empty_setC cne).
move: (rep_i cne); set w := rep (X -s Y) => /setC_P [wa wb].
have ta: sub ((Y -s1 z) +s1 w) ((X \cup Y) -s1 z).
  move => t /setU1_P; case.
    move /setC1_P => [pa pb]; apply /setC1_P; fprops.
  move => ->; apply /setC1_P; split;fprops; contradict wb; ue.
apply: card_lt_leT (sub_smaller ta).
rewrite card_succ_pr; last by move=> /setC_P [].
by rewrite - (card_succ_pr2 zY).
Qed.

Lemma Ex4_11_ex2 A
   (R := Zo (powerset A) (fun z => cardinal z = \2c)):
  mobile_r R.
Proof.
move => X Y /Zo_P [] /setP_P Xa dx /Zo_P [] /setP_P Ya dy xnz z zi.
set Z:= (X \cup Y) -s1 z.
have ta: sub Z (X \cup Y) by move => a /setC_P [].
exists Z; split => //;last by move => /setC1_P [_].
apply: Zo_i.
  apply /setP_P; apply: (sub_trans ta); move => a; case /setU2_P; fprops.
move: zi;move /setI2_P => [z1 z2].
have [u unz xu]: exists2 u, u <> z & X = doubleton z u.
  move: (set_of_card_two dx); move => [u [v [unv duv]]].
  move: z1; rewrite duv;case /set2_P; move => ->; first by exists v; fprops.
  by exists u => //;rewrite set2_C.
have [v vnz vu]: exists2 v, v <> z & Y = doubleton z v.
  move: (set_of_card_two dy); move => [w [v [unv duv]]].
  move: z2; rewrite duv; case /set2_P; move => ->; first by exists v; fprops.
  by exists w => //;rewrite set2_C.
have ->: Z = doubleton u v.
  rewrite /Z xu vu; set_extens t.
  move /setC1_P => [sa sb]; case /setU2_P: sa; case /set2_P => // ->; fprops.
  case /set2_P => ->; apply /setC1_P;
    split=> //; apply /setU2_P; [left | right]; fprops.
by rewrite cardinal_set2 => // uv; case: xnz; rewrite xu vu uv.
Qed.

Lemma Ex4_11_ex3a A R:
  (forall x, inc x R -> sub x A) ->
  (forall x, inc x A -> inc (singleton x) R) ->
  mobile_r R.
Proof.
move => RA h X Y xr yr xny z /setI2_P [zX zY].
case: (p_or_not_p (sub X Y)) => xsy.
  move: (rep_i (setC_ne (conj xsy xny))).
  set w := (rep (Y -s X)) => /setC_P [ra rb].
  exists (singleton w);split => //.
      apply: h; apply: (RA _ yr _ ra).
    by move => t /set1_P ->; apply /setU2_P;right.
  move /set1_P; contradict rb; ue.
have [w wx wny]: exists2 w, inc w X & ~ (inc w Y).
  ex_middle bad; case: xsy => t tx; ex_middle ty; case: bad; ex_tac.
exists (singleton w);split => //.
    apply: h; apply: (RA _ xr _ wx).
  by move => t /set1_P ->; apply /setU2_P; left.
by move /set1_P => zw; case: wny ; rewrite - zw.
Qed.

Lemma Ex4_11_ex3b A n
   (R := Zo (powerset A) (fun z => nonempty z /\ cardinal z <=c n)):
  inc n Bnat -> n <> \0c -> mobile_r R.
Proof.
move => nb nz.
have pa: (forall x, inc x R -> sub x A).
  by move => x =>/Zo_P [] /setP_P.
apply: (Ex4_11_ex3a pa).
move => x xA; apply: Zo_i; first by apply /setP_P;apply: set1_sub.
split; fprops; rewrite cardinal_set1; apply: card_ge1;fprops.
Qed.

if R is mobile, the set of minimal elements of R is mobile

Lemma Ex4_11_minR_pr R:
   (forall x, inc x R -> finite_set x) ->
   (forall x, inc x R -> exists2 y, sub y x & inc y (min_incl_r R)).
Proof.
move => h x xr.
case: (inc_or_not emptyset R) => eR.
  exists emptyset;fprops;apply: Zo_i => // t tr te.
  apply: extensionality => //; fprops.
set n := cardinal x.
have nB: inc n Bnat by apply /BnatP; apply: h.
have cxn: cardinal x <=c n by rewrite -/n; fprops.
set B := Zo R (fun z => sub z x).
pose p k:= inc k Bnat /\ exists2 x, inc x B & cardinal x <=c k.
have pa: (forall k, p k-> inc k Bnat) by move => k [].
have pb: ~ p \0c.
  move => [_ [y yB cy]]; move: (card_le0 cy) => cy1.
  move: (cardinal_nonemptyset cy1) => ye.
  by move: yB => /Zo_P; rewrite ye; move => [].
have pc: (exists k, p k).
  by exists n => //; split =>//; exists x => //; apply: Zo_i.
move: (least_int_prop1 pa pb pc) => [k [kB psk npk]].
move: psk =>[_ [y]] /Zo_P [yR yx] ck.
exists y=> //; apply: Zo_i => // => z zR zy; symmetry;ex_middle yz.
move: (strict_sub_smaller (conj zy yz) (h _ yR)) => aux.
case: npk => //; split => //;exists z.
 by apply: Zo_i=> //; apply: (sub_trans zy yx).
apply / (card_lt_succ_leP kB); co_tac.
Qed.

Lemma Ex4_11_minR_mb R:
   (forall x, inc x R -> finite_set x) ->
   mobile_r R -> mobile_r (min_incl_r R).
Proof.
move => h mb.
move => x y /Zo_P [xR _] /Zo_P [yR _] xy z zi.
move: (mb _ _ xR yR xy _ zi) => [Z [za zb zc]].
move: (Ex4_11_minR_pr h za) => [T ta tb].
exists T; split => //; [ by apply: (sub_trans ta zb) | fprops ].
Qed.

We define pure and max pure sets, and compute some of them

Definition pure R P:= forall x, sub x P -> ~(inc x R).
Definition set_of_pure A R:= Zo (powerset A) (pure R).
Definition max_pure A R P:=
 [/\ sub P A, pure R P & forall p, pure R p -> sub P p -> sub p A -> P = p].

Lemma set_of_pureP A R x:
   inc x (set_of_pure A R) <-> (sub x A /\ pure R x).
Proof.
split; first by move /Zo_P => [] /setP_P.
by move => [pa pb]; apply: Zo_i => //; apply /setP_P.
Qed.

Lemma Ex4_11_ex0_pure A R : inc emptyset R -> set_of_pure A R = emptyset.
Proof.
move => er; apply /set0_P => y; apply /set_of_pureP.
move=>[_ h]; apply: h er; fprops.
Qed.

Lemma Ex4_11_ex1_pure A n
  (R := Zo (powerset A) (fun z => finite_set z /\ n <c cardinal z)):
  inc n Bnat ->
  [/\ set_of_pure A R = Zo (powerset A) (fun z => cardinal z <=c n),
    (n <=c cardinal A ->
     forall M, sub M A -> (max_pure A R M <-> cardinal M = n)) &
    (cardinal A <=c n ->
      (set_of_pure A R = powerset A
      /\ (forall M, max_pure A R M <-> M = A)))].
Proof.
move => nB.
have pa: forall P, sub P A -> pure R P -> cardinal P <=c n.
  move => p pa pb.
  case: (card_le_to_el (CS_cardinal p) (CS_Bnat nB)) => // h.
  case: (finite_dichot (CS_cardinal p)) => fcp.
    by case: (pb _ (@sub_refl p)); apply: Zo_i => //;apply /setP_P.
  have fsc: finite_c (succ n) by apply /BnatP; fprops.
  move: (card_card (CS_succ n)) => csn.
  move: (finite_le_infinite fsc fcp).
  rewrite - csn; move /eq_subset_cardP1=> [z zp].
  move /card_eqP; rewrite csn => zc.
  case: (pb _ zp);apply: Zo_i.
      apply /setP_P; apply: (sub_trans zp pa).
  split; first by rewrite /finite_set - zc; apply /BnatP; fprops.
  rewrite - zc; fprops.
have pb: forall P, (sub P A /\ cardinal P <=c n) -> pure R P.
  move => p [qa qb].
  move => x xp xr; move: (sub_smaller xp) => le1.
  move: (card_leT le1 qb) => le2.
  move: xr => /Zo_P [_ [_ le3]]; co_tac.
split.
    set_extens t; move /Zo_P => [ta tb]; apply /Zo_P;split => //.
       by apply: pa => //; apply /setP_P.
    by apply: pb;split => //;apply /setP_P.
   move => ca M mc; split.
     move => [_ ma mb]; ex_middle ce1; move: (pa _ mc ma) => le1.
     have cm: cardinal M <c n by split.
     have ss: ssub M A.
       split => // bad; rewrite -bad in ca; case: ce1; co_tac.
     move: (rep_i (setC_ne ss)); set w := rep _.
     move => /setC_P [sa sb]; move: (card_succ_pr sb); set p := M +s1 w => cp.
     have sp: sub p A.
        by move => t; case/setU1_P; [apply: mc | by move => -> ].
     have pp: pure R p.
       apply: pb; split => //; rewrite cp; apply /card_le_succ_lt0P; fprops.
     have mp: sub M p by move => t tm ; apply /setU1_P; fprops.
     case: sb; rewrite (mb _ pp mp) //; rewrite /p; fprops.
  move => cm; split => //; first by apply: pb; split => //; rewrite cm; fprops.
  move => p pp mp spa; move: (pa _ spa pp) => px; ex_middle mnp.
  have fsm: finite_set p.
    by apply /BnatP; apply:(BS_le_int px nB).
  move: (strict_sub_smaller (conj mp mnp) fsm); rewrite cm => h; co_tac.
move => le1.
have pd: (forall M, sub M A -> pure R M).
  move => m ma; apply: pb; split => //; move: (sub_smaller ma) => le2; co_tac.
split.
  set_extens t; first by move /Zo_P => [].
  by move /setP_P => ta; apply /set_of_pureP;split => //; apply: pd.
have pra: pure R A by apply: pd.
move => M; split; first by move => [ma sa mb]; apply: mb => //.
move => ->; split => //; move => p _; apply: extensionality.
Qed.

Lemma Ex4_11_ex2_pure A
  (R := Zo (powerset A) (fun z => cardinal z = \2c)):
  (set_of_pure A R = Zo (powerset A) small_set
    /\ ( nonempty A ->
         forall M, max_pure A R M <-> (sub M A /\ singletonp M))).
Proof.
have pa:forall M, sub M A -> small_set M -> pure R M.
  move => M ma mb x xm => /Zo_P.
  move =>[_ cx2]; move: (sub_smaller xm); rewrite cx2.
  move /(card_le2P); move => [a [b [am bm ab]]].
  by case: ab;apply: (mb _ _ am bm).
have pb: forall M, sub M A -> pure R M -> small_set M.
  move => M ma mb a b am bm; ex_middle ab.
  have sd: sub (doubleton a b) M by move => t; case /set2_P => ->.
  case: (mb _ sd); apply: Zo_i => //; last by apply: cardinal_set2.
  by apply /setP_P;apply:(sub_trans sd ma).
split.
   set_extens t => /Zo_P [ta tb];apply: Zo_i => //;
      [ apply: pb | apply: pa] => //; apply /setP_P => //.
move => neA M; split.
  move => [mc ma mb];move: (pb _ mc ma) => md; split; first by exact.
  case: (small_set_pr md) => // me.
  move: (rep_i neA) => rA.
  have qa: sub (singleton (rep A)) A by apply: set1_sub.
  have ps: pure R (singleton (rep A)).
    by apply: pa; [ move => t /set1_P => -> | apply: small1].
  have sms: sub M (singleton (rep A)) by rewrite me; fprops.
  by rewrite (mb _ ps sms qa); exists (rep A).
move => [ma [t st]]; split => //.
  by apply:pa => //; move => a b; rewrite st; move => /set1_P -> /set1_P ->.
move: (set1_1 t); rewrite - st => tm.
move => p pp mp pra; move: (pb _ pra pp) => py; apply: extensionality => //.
by move => s sp; rewrite (py _ _ sp (mp _ tm)).
Qed.

Lemma Ex4_11_ex3_pure A R:
  (forall x, inc x A -> inc (singleton x) R) ->
  (forall M, sub M A -> pure R M -> M = emptyset).
Proof.
move => asr m ma mb; case: (emptyset_dichot m) => em //.
move: (rep_i em) => rm.
by move: (set1_sub rm) => sm; case: (mb _ sm); apply: asr; apply: ma.
Qed.

Lemma Ex4_11_minR_P2 R:
   (forall x, inc x R -> finite_set x) ->
   (forall P, pure R P <-> pure (min_incl_r R) P).
Proof.
move => fr p; split.
  by move => pr x xp bad; apply: (pr _ xp); move: bad => /Zo_P [].
move => pr x xp xR; move: (Ex4_11_minR_pr fr xR) => [y yx ym].
case: (pr _ (sub_trans yx xp) ym).
Qed.

We define mobile_ext to have all properties but minimality. Adding minimality does not change the set of pures. We give a characteristic property of the pures

Definition mobile_ext R A:=
  [/\ (forall x, inc x R -> sub x A),
      (forall x, inc x R -> finite_set x),
       mobile_r R &
      ~ (inc emptyset R)].

Lemma Ex4_11_minR_pr3 A R (R' := min_incl_r R):
  mobile_ext R A ->
  (mobile_ext R' A /\ set_of_pure A R = set_of_pure A R').
Proof.
move => [pa pb pc pd]; move: (Ex4_11_minR_mb pb pc) => pe.
split;last first.
    by set_extens t => /set_of_pureP [ta tb]; apply /set_of_pureP;split => //;
      move: tb; move /(Ex4_11_minR_P2 pb).
have ta: ~ inc emptyset R' by move /Zo_P => [ta] _.
split => // w => /Zo_S wr;fprops.
Qed.

Definition pure_prop1 A S :=
  (nonempty S) /\ (forall x, inc x S -> sub x A).
Definition pure_prop2 S :=
  (inductive (sub_order S)).
Definition pure_prop3 A S :=
  (forall M N, sub M A -> sub N A -> ~ inc M S -> ~ inc N S ->
    inc (M \cap N) S ->
    forall x, inc x (M \cup N) -> ~ (inc ((M \cup N) -s1 x) S)).
Definition pure_prop4 S :=
  (forall x y, inc x S -> sub y x -> inc y S).
Definition pure_prop5 A S :=
  forall x, sub x A -> ~ (inc x S) ->
     exists y, [/\ sub y x, finite_set y & ~ (inc y S)].

Lemma pure_properties_res1 A R:
  mobile_ext R A -> (pure_prop2 (set_of_pure A R)).
Proof.
move => [pa pb pc pd].
set or := (sub_order (set_of_pure A R)).
move => X xsp tor.
move: (sub_osr (set_of_pure A R)) => [ora sra].
move: (xsp); rewrite sra => xsp1.
exists (union X); red; rewrite sra.
suff: inc (union X) (set_of_pure A R).
   move => up; split => // y yX; apply/sub_gleP;split;fprops.
   by apply: setU_s1.
have sa: sub (union X) A.
  by apply: setU_s2 => y yX; move: (xsp1 _ yX) => /Zo_P [] /setP_P.
apply: Zo_i; [ by apply /setP_P | move => x xsu xR; move: (pb _ xR) => fy].
pose f t:= choose (fun i => inc t i /\ inc i X).
have fp: forall t, inc t x -> (inc t (f t) /\ (inc (f t) X)).
  move => t tx; apply choose_pr; move: (xsu _ tx) => /setU_P.
  by move => [s s1 s2]; exists s.
move: (finite_fun_image f fy) ; set imf:= fun_image x f => fi.
case: (emptyset_dichot x) => xne; first by case: pd; ue.
have ine: nonempty imf.
  rewrite /imf;move: xne => [t tx]; exists (f t); apply /funI_P;ex_tac.
set r' := induced_order or X.
move: (iorder_osr ora xsp)=> [or' sr''].
have ssr: sub imf (substrate r').
   rewrite sr'' // => t /funI_P [z zx ->].
   by move: (fp _ zx) => [_].
move: (finite_subset_torder_greatest tor fi ssr ine) => [u []].
rewrite iorder_sr // => ui ug.
move: (ui) => /funI_P [v vx fv].
move: (fp _ vx); rewrite - fv; move => [_ uX].
move: (xsp1 _ uX) => /Zo_hi pu.
have pe: sub x u.
   move=> t tx; have pe: inc (f t) imf by apply /funI_P; ex_tac.
   move: (iorder_gle1 (iorder_gle1 (ug _ pe))) => /sub_gleP.
   by move => [_ _ h]; move: (fp _ tx) => [h2 _]; apply: h.
by move: (pu _ pe).
Qed.

Lemma pure_properties_res2 A R (S:= set_of_pure A R):
  mobile_ext R A ->
  [/\ pure_prop1 A S, pure_prop2 S, pure_prop3 A S,
  pure_prop4 S & pure_prop5 A S].
Proof.
move => h; move: (pure_properties_res1 h) => pe.
move: h => [pa pb pc pd].
have auxP: forall s, sub s A ->
  ( ~ (inc s (set_of_pure A R)) <-> (exists2 y, sub y s & inc y R)).
  move => s sA; split.
    move /set_of_pureP =>h; ex_middle bad.
     case: (p_or_not_p (pure R s)) => ps; first by case: h; split => //.
     by case: ps => x xs xr ; case: bad; exists x.
  by move => [u ys yr] /set_of_pureP [sa pr];move: (pr _ ys yr).
have p5: pure_prop5 A S.
  move => x xA; move /(auxP _ xA) => [y yx yr].
  by exists y; split;fprops;apply /(auxP _ (sub_trans yx xA)); exists y.
have p4: forall x y, inc x S -> sub y x -> inc y S.
    move => x y /set_of_pureP [xA pr] yx; apply /set_of_pureP.
split; first by apply: (sub_trans yx xA).
    move => v vy vr; exact: (pr _ (sub_trans vy yx) vr).
split => //.
  split.
    exists emptyset; apply/set_of_pureP; split;fprops.
    by move => x; rewrite sub_set0 => ->.
  by move => x /set_of_pureP [].
move => M N MA NA nM nN iR x xu.
have sa: sub ((M \cup N) -s1 x) A.
  by move => t /setC1_P [ta _]; case /setU2_P:ta; [apply: MA | apply: NA].
apply / (auxP _ sa).
move: nM nN => /(auxP _ MA) [M' mm' mr] /(auxP _ NA) [N' nn' nr].
case: (equal_or_not M' N') => nmn.
  have qd: sub M' (M \cap N).
     move => t tm'; apply /setI2_P; split;[fprops | apply: nn'; ue].
  by move: iR => /set_of_pureP [_ h]; move: (h _ qd).
case: (inc_or_not x (M' \cap N')) => xi.
  move: (pc _ _ mr nr nmn _ xi) => [Z [zr za zb]]; ex_tac.
  move => t tz.
  have tx: t <> x by dneg tx; ue.
  move: (za _ tz); case /setU2_P => tt;
       apply /setC1_P;split => //; apply /setU2_P;[left | right]; fprops.
case: (inc_or_not x M') => xm'.
have xn': ~ (inc x N') by move => bad; case: xi; apply /setI2_P.
   exists N' => // t tn'; apply /setC1_P;split;[fprops | dneg tx; ue].
exists M' => // t tn'; apply /setC1_P;split;[fprops | dneg tx; ue].
Qed.

Lemma pure_properties_res3: exists A S,
  [/\ pure_prop1 A S, pure_prop2 S, pure_prop3 A S, pure_prop5 A S &
   ~ (pure_prop4 S)].
Proof.
have xx: (substrate (sub_order (singleton C2))) = (singleton C2).
  by rewrite (proj2 (sub_osr _)).
exists C2; exists (singleton C2); split => //.
by split; fprops; move => x /set1_P ->; fprops.
  move => h ha _; exists C2; red; rewrite xx ;split;fprops.
  move => y yh; move: (ha _ yh); rewrite xx;aw; move /set1_P=> ->.
  by apply /sub_gleP;split;fprops.
move => m n ma mn /set1_P ta /set1_P tb /set1_P tc.
  case: ta; apply: extensionality => //; rewrite -tc.
  by apply: subsetI2l.
move => x xtp /set1_P xntp; exists emptyset; aw; split;fprops.
    apply: emptyset_finite.
  by move /set1_P => tpe; symmetry in tpe; empty_tac1 C0.
move => h; move: (set1_1 C2) => ta.
  have tb: sub (singleton C0) C2 by move => t /set1_P ->; fprops.
  by move: inc_C1_2; move: (h _ _ ta tb) => /set1_P <- /set1_P; fprops.
Qed.

Lemma pure_properties_res4 A S:
  (pure_prop2 S) -> (pure_prop4 S) -> (pure_prop5 A S).
Proof.
move => p2 p4.
move => M MA nMS.
case: (finite_dichot1 M) => ifm; first by exists M; split.
set T := fun_image (Zo (powerset M) (fun z => ~(inc z) S)) cardinal.
have zt: inc (cardinal M) T.
  apply /funI_P; exists M => //; apply: Zo_i; aw; fprops; apply :setP_Ti.
have cst: cardinal_set T by move => t /funI_P [y _ ->]; fprops.
move: (wordering_cardinal_le_pr cst) => [[tb tc] ta].
rewrite ta in tc.
have net: nonempty T by ex_tac.
move: (tc _ (@sub_refl T) net) => [cy []]; aw; last by rewrite ta; fprops.
move => cyt aux1.
have cym: forall y, inc y T -> cy <=c y.
  move => y yt.
  by move: (iorder_gle1 (aux1 _ yt)) => /graph_on_P1 [_ _].
move: cyt => /funI_P [N pa cN].
move: pa => /Zo_P [] /setP_P NL nNS.
have icy: cardinalp cy by rewrite cN; fprops.
case: (finite_dichot icy) => ifcy.
  by exists N;split => //; rewrite /finite_set - cN.
move: (infinite_card_limit2 ifcy) => [ya ocy ly].
move: cN; rewrite -(card_card icy);move /card_eqP=> [f [bf sf tf]].
pose vfi i := image_by_fun f i.
have ff: function f by fct_tac.
have fa: forall i, i <=o cy -> sub i (source f).
  by move => i ic; rewrite sf; move: ic => [_ _ ].
have fb: forall i j, i<=o cy -> j <=o cy -> i <=o j -> sub (vfi i) (vfi j).
  move => i j iy jy ji t; rewrite /vfi; move: (fa _ iy) (fa _ jy) => isf jsf.
  move => /(Vf_image_P ff isf) [u ui wu]; apply /(Vf_image_P ff jsf).
  by exists u => //; move: ji => [_ _ ]; apply.
have sc: forall i, i <o cy -> cardinal (vfi i) <c cy.
   move => i iy; rewrite /vfi.
   have -> : cardinal (image_by_fun f i) = cardinal i.
     symmetry; apply /card_eqP.
     move: (fa _ (proj1 iy)) => sfa.
     move: (restriction1_fb (proj1 bf) sfa) => bf1.
     exists (restriction1 f i); split => //; rewrite /restriction1; aw.
  apply /ordinal_cardinal_le2P => //; ord_tac.
have sd: forall i, i <o cy -> inc (vfi i) S.
  move => i iy; move: (sc _ iy) => cs; ex_middle nvs.
  have cvt: inc (cardinal (vfi i)) T.
     apply /funI_P;exists (vfi i) => //;apply: Zo_i => //.
     by apply/setP_P;apply: sub_trans NL; rewrite -tf; apply:fun_image_Starget1.
  move: (cym _ cvt) =>h'; co_tac.
set Z:= fun_image cy vfi.
have za: sub Z S.
   move => t /funI_P [z zy ->]; apply: sd.
   by move: zy => /(ord_ltP ya).
move:(sub_osr S) => [zc pb].
have zb: sub Z (substrate (sub_order S)) by ue.
move: (iorder_osr zc zb) => [wa wb].
have zd: total_order (induced_order (sub_order S) Z).
  split; fprops; aw; move => x y xz yz; rewrite /ocomparable; aw.
  move: (xz)(yz) => /funI_P [x' xy vx] /funI_P [y' yy vy].
  have [le1 _]: x' <o cy by move: xy => /(ord_ltP ya).
  have [le2 _]: y' <o cy by move: yy => /(ord_ltP ya).
  by case: (ord_le_to_ee (proj31 le1) (proj31 le2)) => h; [left | right ];
    apply /iorder_gleP => //; apply /sub_gleP;split;fprops;
    rewrite vx vy; apply: fb.
move: (p2 Z zb zd) => [X []]; rewrite pb => X1 X2.
have aux: forall i, i <o cy -> sub (vfi i) X.
  move => i iy.
  have h: inc (vfi i) Z.
    by apply /funI_P;exists i => //; move: iy => /(ord_ltP ya).
  by move: ( X2 _ h) => /sub_gleP [_ _].
have nt: sub N X.
  move => t; rewrite -tf => ttf; move: (bij_surj bf ttf) => [x xsf <-].
  move: xsf; rewrite sf => xcy.
  move: (ly _ xcy) => scy.
  have td: (succ_o x) <o cy by apply /ord_ltP.
  have ax2: sub (succ_o x) (source f) by apply: fa; ord_tac.
  move: (aux _ td); apply; apply /(Vf_image_P ff ax2); exists x => //.
  rewrite /succ_o; fprops.
by move: (p4 _ _ X1 nt).
Qed.

Lemma pure_properties_res5 A S:
 pure_prop1 A S -> pure_prop3 A S -> pure_prop4 S -> pure_prop5 A S ->
 exists R,
    [/\ mobile_ext R A,
        S = (set_of_pure A R) &
        (forall x z, inc x R -> inc z R -> sub x z -> z = x)].
Proof.
move => [nes p1] p3 p4 p5.
set R := Zo (powerset A)(fun z => ~(inc z S) /\
    forall v, sub v z -> ~ (inc v S) -> v = z).
have pa: (forall x z, inc x R -> inc z R-> sub x z -> z = x).
  move => x z /Zo_P [_ [xs _]] /Zo_hi [_ zp] h.
  by symmetry; apply: zp.
have pb: forall x, inc x R -> sub x A.
  by move => x /Zo_P [] /setP_P.
have pc: ~ inc emptyset R.
  move /Zo_P =>[ta [tc _]]; case: tc.
  move: nes => [w ws]; apply:(p4 w emptyset) => //; fprops.
have pd: (forall z, inc z R -> finite_set z).
  move => z => /Zo_P [] /setP_P ta [tb tc].
  move: (p5 _ ta tb) => [y [ys fsy nys]].
  by rewrite - (tc _ ys nys).
have pe: forall M, sub M A -> ~ (inc M S) -> exists2 N, sub N M & inc N R.
  move => M MA nMS.
  move: (p5 _ MA nMS) => [y [ym fy nys]].
  set T := Zo (powerset y) (fun z => ~ (inc z S)).
  have tf: (forall x, inc x T -> finite_set x).
     move => x /Zo_P [] /setP_P xy _.
     apply: (sub_finite_set xy fy).
  have yt: inc y T by apply: Zo_i => //; apply /setP_P.
  move: (Ex4_11_minR_pr tf yt) => [z zt] /Zo_P [ta tb].
  move: (sub_trans zt ym) => zM.
  exists z=> //; apply: Zo_i; first by apply /setP_P; apply: (sub_trans zM MA).
  move: ta => /Zo_P [_ zs]; split => //.
  move => v vz nvs; symmetry; apply: tb => //; apply: Zo_i => //.
  apply /setP_P; apply: (sub_trans vz zt).
have pf: mobile_r R.
  move => M N MR NR; move: (MR) (NR) => /Zo_P [] /setP_P MA [nMS Mm]
     /Zo_P [] /setP_P NA [nNS Nm] MN z zi.
  have qa: inc (M \cap N) S.
     move: (@subsetI2l M N)(@subsetI2r M N) => ta tb.
     ex_middle ins; move: (Mm _ ta ins) => tc; case: MN; apply: Nm => //; ue.
  have qb: inc z (M \cup N) by move: zi=> /setI2_P [zm _]; apply /setU2_P; left.
  move: (p3 _ _ MA NA nMS nNS qa _ qb).
  set Z := ((M \cup N) -s1 z) => zs.
  have zc: sub Z (M \cup N) by move => t /setC1_P [].
  have za: sub Z A by apply: (sub_trans zc) => t; case /setU2_P =>h; fprops.
  move: (pe _ za zs) => [Z' Z1 Z2]; exists Z'; split => //.
     apply: (sub_trans Z1 zc).
  by move => h; move: (Z1 _ h) => /setC1_P[].
have pg: S = set_of_pure A R.
  set_extens t.
     move => tS; apply /set_of_pureP;split;fprops.
      move => x xp => /Zo_P [_ [bad xb]]; case: bad; exact: (p4 _ _ tS xp).
  move /set_of_pureP => [ta pt]; ex_middle ts.
  move: (pe _ ta ts) => [N nt nr]; by move: (pt _ nt).
by exists R.
Qed.

Lemma pure_properties_res6 A S:
 pure_prop1 A S -> pure_prop2 S -> pure_prop3 A S -> pure_prop4 S ->
 exists R,
    [/\ mobile_ext R A,
        S = (set_of_pure A R) &
      (forall x z, inc x R -> inc z R -> sub x z -> z = x)].
Proof.
move => p1 p2 p3 p4; apply: pure_properties_res5 => //.
by apply: pure_properties_res4.
Qed.

Definition mobile_alt R :=
  forall E F, inc E R -> inc F R -> E <> F ->
  forall x y, inc x (E \cap F) -> inc y (E -s F) ->
  exists G, [/\ inc G R, sub G (E \cup F), inc y G & ~ (inc x G)].

Lemma pure_properties_res7 A R:
  (forall x, inc x R -> sub x A) ->
  (forall x, inc x R -> finite_set x) -> ~ (inc emptyset R) ->
  (forall x z, inc x R -> inc z R -> sub x z -> z = x) ->
  (mobile_r R <-> mobile_alt R).
Proof.
move => ra rf ner rmin; split; last first.
  move => h X Y Xr Yr XnY z zi.
  case: (emptyset_dichot (Y -s X)) => ce.
    move: (empty_setC ce) => yx.
    case: (emptyset_dichot (X -s Y)) => ce1.
      by move: (empty_setC ce1) => xy; case: XnY; apply:extensionality.
    move: ce1 => [y yc].
    move: (h _ _ Xr Yr XnY _ _ zi yc) => [w [z1 z2 z3 z4]].
    by exists w.
  have XnY': Y <> X by apply:nesym.
  move: ce => [y yc].
  rewrite setU2_C; rewrite setI2_C in zi.
  move: (h _ _ Yr Xr XnY' _ _ zi yc) => [w [z1 z2 z3 z4]].
   by exists w.
move => mr.
pose am E F := forall x y, inc x (E \cap F) -> inc y (E -s F) ->
  exists G, [/\ inc G R, sub G (E \cup F), inc y G & ~ (inc x G)].
set T := Zo (coarse R) (fun z => (P z <> Q z /\ ~(am (P z) (Q z)))).
case: (emptyset_dichot T) => nte.
  move => E F p1 p2 p3; ex_middle bad.
  empty_tac1 (J E F); apply: Zo_i; [ by apply :setXp_i | aw; split => //].
pose prop x := inc x Bnat /\ exists2 z, inc z T & cardinal (P z \cup Q z) <=c x.
have pa: forall x, prop x -> inc x Bnat by move => x [].
have pb: ~ (prop \0c).
   rewrite /prop; aw; move => [_ [z zt cu]].
   move: (cardinal_nonemptyset (card_le0 cu)) => ue.
   move: zt => /Zo_P [] /setX_P [_ pr _] _.
   have pe: P z = emptyset.
    by apply /set0_P => t tp; empty_tac1 t; aw; left.
   case: ner; by ue.
have pc: (exists x, prop x).
  move: nte => [z zT]; exists (cardinal (P z \cup Q z)).
  move: (zT) => /Zo_P [] /setX_P [_ pr qr] _.
  have cu:inc (cardinal (P z \cup Q z)) Bnat.
    by apply /BnatP; apply: finite_union2;apply: rf.
  split => //; exists z;fprops.
move: (least_int_prop1 pa pb pc).
move => [m [mB [smB [zm zmt czm]] smp]].
have smp': forall z, inc z T -> succ m <=c cardinal (P z \cup Q z).
  move => z zt.
  have cc1: cardinalp (succ m) by rewrite /succ;fprops.
  have cc2: cardinalp (cardinal (P z \cup Q z)) by fprops.
  case: (card_le_to_el cc1 cc2) => //; move /(card_lt_succ_leP mB) => cc3.
  case: smp; split => //; ex_tac.
have czm'': cardinal (P zm \cup Q zm) = succ m.
   move: (smp' _ zmt) => aux; co_tac.
move: zmt => /Zo_P [] /setX_P; set E := P zm; set F := Q zm.
move => [_ ER FR] [EnF namEF]; rewrite -/E -/F in czm''.
have smp'': forall U V, inc U R -> inc V R -> U <> V ->
    cardinal (U \cup V) <c succ m -> am U V.
  move => U V ur vr uv cle; ex_middle bad.
  have aux: inc (J U V) T by apply: Zo_i; aw; fprops; apply /setXp_P.
  move: (smp' _ aux); aw => le; co_tac.
case: namEF; move => x y xEF yEF.
move: (xEF) => /setI2_P [xE xF].
move: (mr _ _ ER FR EnF _ xEF) => [G [GR Gu xG]].
case: (inc_or_not y G) => yG; first by exists G.
case: (emptyset_dichot (G -s E)) => nge.
   case: yG; rewrite - (rmin _ _ GR ER (empty_setC nge)).
   by move: yEF; case /setC_P.
move: (rep_i nge); set z := rep _ => zd.
have fsa: finite_set (E \cup F) by apply /BnatP ; ue.
have cs1: cardinal (F \cup G) <c succ m.
  have ss1: ssub (G \cup F) (E \cup F).
    move: yEF => /setC_P [ya yb].
    split; first by move => t; case /setU2_P; fprops.
    move => bad.
    have: inc y (E \cup F) by fprops.
    by rewrite - bad; case /setU2_P.
  rewrite setU2_C - czm''; exact: (strict_sub_smaller ss1 fsa).
have nGF: F <> G by move => bad; case: xG; ue.
have xGF: inc x (F -s G) by apply /setC_P.
have zGF: inc z (F \cap G).
  move: zd => /setC_P[za zb]; apply /setI2_P; split => //; move:(Gu _ za).
  case/setU2_P => //.
move: (smp'' _ _ FR GR nGF cs1 _ _ zGF xGF).
move => [H [HR hfg xH zH]].
have ss0: sub (E \cup H) (E \cup F).
  move => t; case /setU2_P; [ fprops | move => xh].
  move: (hfg _ xh) => /setU2_P; case; [fprops | apply: Gu].
have cs2: cardinal (E \cup H) <c succ m.
  have ss1: ssub (E \cup H) (E \cup F).
    split; [exact | move => bad].
    have: inc z (E \cup F) by move: zGF => /setI2_P [sa _]; fprops.
    by rewrite - bad; case /setU2_P => //; move: zd => /setC_P [].
  rewrite - czm''; exact: (strict_sub_smaller ss1 fsa).
have yEH: inc y (E -s H).
  move: yEF => /setC_P [ye nyf]; apply /setC_P;split => //.
  move => yh; case: nyf; move: (hfg _ yh); case /setU2_P=> //.
have nEH: E <> H by move => bad; move: yEH => /setC_P; rewrite bad; case.
have xEH: inc x (E \cap H) by fprops.
move: (smp'' _ _ ER HR nEH cs2 _ _ xEH yEH).
move => [K [KR kfg xK yK]];exists K;split => //; apply: (sub_trans kfg ss0).
Qed.

Definition ppr8_hyp R f n:=
  [/\ fgraph f, domain f = Bint n,
  (forall i, i <c n -> inc (Vg f i) R) &
  (forall i, i<c n ->
       ~ (sub (Vg f i) (unionb (restr f (Bint i)))))].

Definition ppr8_conc R B f g m:=
  [/\ fgraph g, domain g = Bint m,
  (forall i, i <c m -> inc (Vg g i) R),
  (forall i, i <c m -> sub (Vg g i) (unionb f -s B)) &
  (forall i, i<c m ->
       ~ (sub (Vg g i) (unionb (restr g ((Bint m) -s1 i)))))].

Lemma pure_properties_res8 A R:
   mobile_ext R A ->
   (forall x z, inc x R -> inc z R -> sub x z -> z = x) ->
   forall r m, inc r Bnat -> inc m Bnat -> m <> \0c ->
     forall f B, ppr8_hyp R f (m +c r) -> cardinal B = r ->
     exists g, ppr8_conc R B f g m.
Proof.
move=> [srA fsa mr ner] minr.
move: (mr); rewrite (pure_properties_res7 srA fsa ner minr) => mr'.
pose p E F x y G:= [/\ inc G R, sub G (E \cup F), inc y G& ~ (inc x G)].
pose cmr E F x y := choose (p E F x y).
have cmrp: forall E F x y, inc E R -> inc F R -> inc x (E \cap F)
   -> inc y ( E -s F) -> p E F x y (cmr E F x y).
  move => E F x y er fr xef yef; apply:choose_pr.
  have ef: E <> F by move => ef; move: yef=> /setC_P []; rewrite ef.
  exact (mr' _ _ er fr ef x y xef yef) .
have ind0: forall m, inc m Bnat -> m <> \0c ->
     forall f, ppr8_hyp R f m -> exists g, ppr8_conc R emptyset f g m.
  move => m mN mnz f [fgf df fR unp].
  pose xv i := rep ((Vg f i) -s (unionb (restr f (Bint i)))).
  have xvp1: forall i, i <c m ->
     inc (xv i) ((Vg f i) -s (unionb (restr f (Bint i)))).
     move => i im; move: (unp _ im); rewrite /xv; set s := unionb _ => ss.
     apply: rep_i; case: (emptyset_dichot (Vg f i -s s)) => // ve.
     by move: (empty_setC ve).
  have xvp2: forall i, i<c m -> inc (xv i) (Vg f i).
    by move => i im; move: (xvp1 _ im)=> /setC_P [].
  have dd: forall i, i<c m -> sub (Bint i) (domain f).
     move => i im;move: (proj1 im) => im1.
     have iB: inc i Bnat by apply: (BS_le_int im1 mN).
     rewrite df; apply:Bint_M1 => //.
  have xvp3: forall i j, j <c i -> i <c m -> ~(inc (xv i) (Vg f j)).
     move => i j ji im xvi; move: (xvp1 _ im) => /setC_P [_]; case.
     have iB: inc i Bnat by apply: (BS_le_int (proj1 im) mN).
     have aux: inc j (Bint i) by apply /(BintP iB).
     move : (dd _ im) => dmf; apply /setUb_P;bw; exists j => //; bw.
  clear xvp1.
  pose nextB i Bi:=
       Lg Bnat (fun j => Yo (inc (xv i) (Vg Bi j))
          (cmr (Vg Bi j) (Vg Bi i) (xv i) (xv j)) (Vg Bi j)).
  move: (induction_term0 nextB f) (induction_terms nextB f).
  set fB := induction_term nextB f => fBa fBb.
  pose B i j := Vg (fB i) j.
  have Ba: forall j, B \0c j = Vg f j.
    by move => j; rewrite /B fBa.
  have Bp: forall i, inc i Bnat -> forall j, i<=c j -> j <c m ->
    [/\ inc (B i j) R,
     sub (B i j) (Vg f j \cup (unionb (restr f (Bint i)))),
     inc (xv j) (B i j),
     (forall k, k <c i -> ~ (inc (xv k) (B i j))) &
     (forall k, j <c k -> k <c m -> ~ (inc (xv k) (B i j)))].
    apply: cardinal_c_induction.
      move => j jz jm; rewrite Ba; split;fprops.
          apply: subsetU2l.
      by move => k k0; case: (card_lt0 k0).
    move => i iB Hrec j cji cjm.
    have jb: inc j Bnat by apply (BS_le_int (proj1 cjm) mN).
    rewrite /B; rewrite (fBb _ iB) /nextB (LVg_E _ jb).
    move: (card_leT (card_le_succ iB) cji) => cij.
    move: (dd _ (card_le_ltT cji cjm)) => dr2.
    move: (dd _ (card_le_ltT (card_le_succ iB) (card_le_ltT cji cjm))) => dr1.
    have -> : (Vg (fB i) j) = B i j by rewrite /B.
    move: (Hrec _ cij cjm)=> [pe pa pb pc pd].
    have tg: sub (unionb (restr f (Bint i)))
         (unionb (restr f (Bint (succ i)))).
       move => y /setUb_P; bw ; move=> [z zi]; bw.
      have zi':inc z (Bint (succ i)).
        by move: (Bint_M iB zi) => zi' => //; bw.
       move => yv; apply /setUb_P; bw; exists z; bw.
    Ytac aux; last first.
      split => //.
        move => t tb; move: (pa _ tb) => /setU2_P tu; apply /setU2_P.
        case: tu => tu; [by left | by right; apply: tg].
      move => k ksi.
        case: (equal_or_not k i) => ki; first by rewrite ki.
        by apply: pc;split => //; apply /(card_lt_succ_leP iB).
    move: (Hrec _ (card_leR (proj31 cij)) (card_le_ltT cij cjm))
      => [qe qa qb qc qd].
    have lij: i<c j by apply /card_le_succ_ltP.
    have ta: inc (xv i) (B i j \cap Vg (fB i) i) by fprops.
    have tb: inc (xv j) (B i j -s Vg (fB i) i)
          by apply /setC_P;split => //; apply: qd.
    move: (cmrp _ _ _ _ pe qe ta tb); set c := cmr _ _ _ _.
    move => [tc td te tf].
    have th: sub c (Vg f j \cup unionb (restr f (Bint (succ i)))).
      move => t itc; move: (td _ itc); case /setU2_P=> tic'; apply /setU2_P.
        move: (pa _ tic'); case /setU2_P=> tic''; first by left.
        by right; apply: tg.
      move: (qa _ tic'); case /setU2_P=> tv; right; last by apply:tg.
      have ii: inc i (Bint (succ i)) by apply :Bint_si.
       apply /setUb_P; bw; exists i; bw; split => //.
   have ti: forall k, k <c succ i -> ~ inc (xv k) c.
     move => k /(card_lt_succ_leP iB) ki.
     case: (equal_or_not k i) => ki1; first by ue.
     have lki: k <c i by split.
     move => bad; move: (td _ bad); case /setU2_P; first by exact (pc _ lki).
     exact (qc _ lki).
   have tj:forall k, j <c k -> k <c m -> ~ inc (xv k) c.
     move => k jk km bad; move: (td _ bad); case /setU2_P;
         [by exact (pd _ jk km) | by exact (qd _ (card_le_ltT cij jk) km)].
   split => //.
   exists (Lg (Bint m) (fun i => B i i)).
   split => //.
          fprops.
        bw.
     move => i im; bw; last by apply /BintP.
     have iB: inc i Bnat by apply (BS_le_int (proj1 im) mN).
     by move: (Bp _ iB _ (card_leR (proj31_1 im)) im) => [ok _].
   move => i im; bw; last by apply /BintP.
   move => t tb; apply /setC_P;split => //; last by move => /in_set0.
   have iB: inc i Bnat by apply (BS_le_int (proj1 im) mN).
   move: (Bp _ iB _ (card_leR (proj31_1 im)) im) => [_ pa _ _ _].
   move: (pa _ tb);case /setU2_P => ti.
     by apply /setUb_P;exists i=> //; rewrite df; apply /BintP.
   move: (dd _ im) => dr2.
   move: ti => /setUb_P; bw; move => [y yi tv].
   apply /setUb_P ;by exists y; fprops; move: tv; bw.
  move => i im; bw; [ move => bad | by apply /BintP].
  have iB: inc i Bnat by apply (BS_le_int (proj1 im) mN).
  move: (Bp _ iB _ (card_leR (proj31_1 im)) im) => [_ pa pb pc pd].
  have pg:sub (Bint m -s1 i) (Bint m).
      by move => t /setC1_P; case.
   have pe: sub (Bint m -s1 i)
        (domain (Lg (Bint m) (fun i0 => B i0 i0))) by bw.
   have pf: fgraph (Lg (Bint m) (fun i0 => B i0 i0)) by fprops.
   move: (bad _ pb) => /setUb_P; bw.
   move => [y ya]; move: (ya) => /setC1_P [ym yi]; bw.
   move: (ym) => /(BintP mN) ym1.
   have kB: inc y Bnat by apply (BS_le_int (proj1 ym1) mN).
   move: (Bp _ kB _ (card_leR (proj31_1 ym1)) ym1) => [_ _ _ qc qd].
   case: (card_le_to_el (proj31_1 ym1) (proj31_1 im)) => ciy.
        by apply: qd.
     by apply: qc.
move => r m rB mB mnz f B hyp cb.
have fsb: finite_set B by red; rewrite cb; apply /BnatP.
move: B fsb r m f rB mB hyp cb mnz.
apply: finite_set_induction0.
  move => r m f rb mb Hyp ce mn; apply: ind0 => //.
  have -> //: m = m +c r; rewrite - ce cardinal_set0; aw; fprops.
move => B x Hrec nxb r m f rB mB h8 cs1 mnz.
move: cs1; rewrite (card_succ_pr nxb) => sr.
have rnz: r <> \0c by rewrite - sr; apply: succ_nz.
move: (cpred_pr rB rnz);move: (cpred_pr1 (CS_cardinal B)); rewrite sr => ->.
set r':= cardinal B; move => [r'B rsr'].
have mrB: inc (m +c r) Bnat by fprops.
have mrB': inc (m +c r') Bnat by fprops.
have mrnz: m +c r <> \0c.
   move: (finite_sum4_lt rB mnz); rewrite csumC =>h.
   by move: (card_le_ltT (czero_least (CS_Bnat rB)) h) => [_ /nesym].
move: (ind0 _ mrB mrnz _ h8) => [Ap [fgAp dAp Apr sApu sAu]].
move: sApu.
have ->: (unionb f -s emptyset) = unionb f.
   set T:= unionb f; set_extens t; first by move /setC_P => [].
      move => tt; apply /setC_P;split => //; case; case.
move => sApu.
suff: exists g : Set, ppr8_conc R (B +s1 x) Ap g m.
  move => [g [g1 g2 g3 g4 g5]]; exists g;split => //.
  move => i im; move: (g4 _ im) => ts t tg; move: (ts _ tg).
  move /setC_P=> [ta tb]; apply /setC_P;split => //.
  move: ta => /setUb_P [y yd ty]; apply: (sApu y _ _ ty).
  by move: yd; rewrite dAp => /(BintP mrB).
have ta: m +c r' <=c m +c r.
  apply: csum_Mlele; fprops; rewrite rsr'; fprops.
case: (inc_or_not x (unionb Ap)) => xu; last first.
  set Ap' := restr Ap (Bint (m +c r')).
  have tb: sub (Bint (m +c r')) (domain Ap).
    rewrite dAp; apply: Bint_M1; fprops.
  have tc: forall i, i<c m+c r' -> Vg Ap' i = Vg Ap i.
     by move => i ilt; rewrite /Ap'; bw; apply /(BintP mrB').
  have td: domain Ap' = Bint (m +c r') by rewrite /Ap' restr_d.
  have te: fgraph Ap' by rewrite /Ap'; fprops.
  have h8': ppr8_hyp R Ap' (m +c r').
   split => //.
       move => i im; rewrite (tc _ im); apply: Apr; co_tac.
     move => i im; rewrite (tc _ im).
     have imr: i <c m +c r by co_tac.
    move => ns; move: (sAu _ imr); case => t tq.
    have iB: inc i Bnat by apply (BS_le_int (proj1 imr) mrB).
    have tr: sub (Bint i) (domain Ap').
     rewrite td; apply: (Bint_M1 mrB' (proj1 im)).
    have ts: sub (Bint (m +c r) -s1 i) (domain Ap).
       move => z /setC_P; rewrite dAp; move => []; bw.
    move: (ns _ tq) => /setUb_P;bw.
    move => [y yi]; bw => tv; apply /setUb_P; bw.
   move: yi => /(BintP iB) [ti1 ti2].
    have yk: inc y (Bint (m +c r) -s1 i).
        apply /setC1_P; split => //; apply /(BintP mrB); co_tac.
    exists y=> //; bw; rewrite - tc //; co_tac.
  move: (Hrec _ _ _ r'B mB h8' (refl_equal r') mnz).
  move => [g [g1 g2 g3 g4 g5]]; exists g;split => //.
  have sa: sub (unionb Ap') (unionb Ap).
    move => t /setUb_P;rewrite td; move => [y yi yv].
    apply /setUb_P; rewrite dAp.
     move: yi => /(BintP mrB') yi; exists y=> //;
       last by rewrite -(tc _ yi).
     apply /(BintP mrB); co_tac.
  move => i im t tv; move: (g4 _ im _ tv).
  move /setC_P=> [ua ub] => //; apply /setC_P;split;fprops.
  dneg tq; move: tq; case /setU1_P => // tx; case: xu; apply: sa; ue.
move: xu=> /setUb_P; rewrite dAp;move => [ix] /(BintP mrB) ixd xix.
pose swap i := Yo (i = ix) (m +c r') (Yo (i = m +c r') ix i).
have swp2: forall i, swap (swap i) = i.
   move => i; rewrite /swap.
   case: (equal_or_not i ix) => eix; Ytac0.
      Ytac0; Ytac xx; [ue| done].
   by case: (equal_or_not i (m +c r')) => eiy; Ytac0; Ytac0 => //; Ytac0.
have swp3: forall i, i<c m +c r -> swap i <c m +c r.
   move => i ily; rewrite /swap;Ytac le1.
     rewrite (csumC m)(csumC m);apply: csum_Mlteq => //;rewrite rsr'; fprops.
   Ytac le2 => //.
have swp4: forall i, i <c m +c r' -> swap i <> ix.
   move => i [ily nr]; rewrite /swap; Ytac eq1; last by Ytac0.
   by rewrite -eq1; apply:nesym.
have swp5: forall i, i <c m +c r' -> (swap i <c m +c r /\ swap i <> ix).
   move => i ilt; split; [ apply: swp3; co_tac | by apply: swp4 ].
pose uni i:= (unionb (restr Ap (Bint (m +c r) -s1 i))).
pose xv1 i := rep ((Vg Ap i) -s (uni i)).
have xvp1: forall i, i <c ( m +c r) -> inc (xv1 i) ((Vg Ap i) -s (uni i)).
     move => i im; move: (sAu _ im); rewrite /xv1/uni; set s := unionb _ => ss.
     apply: rep_i; case: (emptyset_dichot (Vg Ap i -s s)) => // ve.
     by move: (empty_setC ve).
have xvp2: forall i, i<c m +c r -> inc (xv1 i) (Vg Ap i).
  by move => i im; move: (xvp1 _ im) => /setC_P [].
have xvp3: forall i j, i <c m +c r -> j <c m +c r -> i <> j ->
     ~(inc (xv1 i) (Vg Ap j)).
  move => i j ilt jlt ij; move: (xvp1 _ ilt) => /setC_P [_ h]; dneg h1.
  have tb: sub (Bint (m +c r) -s1 i) (domain Ap).
    by rewrite dAp => t /setC_P [].
  have ji: inc j (Bint (m +c r) -s1 i).
    by apply /setC1_P;split;fprops; apply /(BintP mrB).
  apply /setUb_P;exists j => //; bw.
pose Bi i := Yo (inc x (Vg Ap i))(cmr (Vg Ap i) (Vg Ap ix) x (xv1 i)) (Vg Ap i).
have bip: forall i, i<c m +c r -> i <> ix ->
   [/\ inc (Bi i) R , sub (Bi i) (Vg Ap i \cup Vg Ap ix),
     inc (xv1 i) (Bi i) & ~ inc x (Bi i)].
   move => i im nix; rewrite /Bi; Ytac xai.
      have pa: inc x (Vg Ap i \cap Vg Ap ix) by fprops.
      have pb: inc (xv1 i) (Vg Ap i -s Vg Ap ix).
       apply /setC_P;split;fprops; apply: xvp3 => //.
       apply: (cmrp _ _ _ _ (Apr _ im) (Apr _ ixd) pa pb).
   split;fprops; apply: subsetU2l.
set Bf := Lg (Bint (m +c r')) (fun z => Bi (swap z)).
have h8': ppr8_hyp R Bf (m +c r').
  rewrite /Bf;split => //.
        fprops.
      bw.
    move => i im; bw; last by apply /(BintP mrB').
    by move: (swp5 _ im)=> [s1 s2]; move: (bip _ s1 s2) => [ok _].
  move => i im; bw; [ move => ns | by apply /BintP].
  move: (swp5 _ im)=> [s1 s2]; move: (bip _ s1 s2) => [p1 p2 p3 p4].
  have iB: inc i Bnat by apply (BS_le_int (proj1 im) mrB').
  have pa:fgraph (Lg (Bint (m +c r')) (fun z => Bi (swap z))).
    by fprops.
   have pb: sub (Bint i) (Bint (m +c r')).
     by apply: Bint_M1 => //; move: im =>[].
  move: (ns _ p3) => /setUb_P [y];rewrite restr_d.
  move => ya; move: (ya) => /(BintP iB) yi.
  have ph: y <c m +c r' by co_tac.
  have pc: inc y (Bint (m +c r')) by apply /BintP.
  bw; move: (xvp1 _ s1) => /setC_P [_ pd] pe; case: pd.
  have pf: sub (Bint (m +c r) -s1 swap i) (domain Ap).
    by move => t; rewrite dAp => /setC_P [].
  have pg: inc (swap y) (Bint (m +c r) -s1 swap i).
    apply /setC_P; split.
       apply/(BintP mrB); apply: swp3; move: pc; bw => yi1;co_tac.
    move /set1_P; move: yi => [_]; rewrite - {1} (swp2 i) -{1} (swp2 y).
    by move => h1 h2; case: h1; rewrite h2.
  apply /setUb_P;exists (swap y); bw.
  move: (swp5 _ ph)=> [s3 s4]; move: (bip _ s3 s4) => [q1 q2 _].
   move: (q2 _ pe); case /setU2_P;[by exact | move => inc1 ].
   case: (xvp3 (swap i) ix s1 ixd s2 inc1).
move: (Hrec _ _ _ r'B mB h8' (refl_equal r') mnz).
move=> [g [g1 g2 g3 g4 g5]]; exists g;split => //.
move => i im t tv; move: (g4 _ im _ tv) => /setC_P [] /setUb_P [y yd tv1] tB.
move: yd; rewrite /Bf; bw=> ym; move: (ym) => /(BintP mrB') ym'.
move: tv1; rewrite /Bf; bw; move => tv1.
move: (swp5 _ ym')=> [s3 s4]; move: (bip _ s3 s4) => [_ q2 _ q4].
apply /setC_P;split.
   by apply /setUb_P; rewrite dAp; move: (q2 _ tv1); case /setU2_P => h;
   [exists (swap y) | exists ix]=> //; apply /(BintP mrB).
by move /setU1_P => aux; case: tB; case: aux => // tx; case: q4; rewrite -tx.
Qed.

Lemma pure_properties_res9 A R (U := set_of_pure A R):
  mobile_ext R A ->
  (forall x z, inc x R -> inc z R -> sub x z -> z = x) ->
  forall n f B,
    inc n Bnat ->
    cardinal B <c n ->
    fgraph f -> domain f = Bint n ->
    (forall i, i <c n -> sub (Vg f i) A) ->
    (forall i, i <c n -> ~ inc (Vg f i) U) ->
    (forall i, i <c n ->
      inc ((Vg f i) \cap (unionb (restr f (Bint i)))) U) ->
    ~ (inc ((unionb f) -s B) U).
Proof.
move => mer minr n f B nB cb fgf df fA fnu ifu.
move /set_of_pureP; move => [_ dp].
have aux: forall i, i <c n -> exists2 x, inc x R & sub x (Vg f i).
  move => i idf; move: (fA _ idf) (fnu _ idf) => pa pb.
  ex_middle bad; case: pb; apply/set_of_pureP; split => //.
  by move => X xa xb;case: bad; exists X.
pose Bi i:= choose (fun x => (inc x R /\ sub x (Vg f i))).
have Bip: forall i, i <c n -> (inc (Bi i) R /\ sub (Bi i) (Vg f i)).
   move => i lin; move: (aux _ lin) => [x xa xb].
   have h: exists x , inc x R /\ sub x (Vg f i) by exists x.
   apply: (choose_pr h).
set f':= Lg (Bint n) Bi.
have h8: ppr8_hyp R f' n.
  rewrite /f';split => //.
        fprops.
      bw.
    move => i lin; bw; [by move: (Bip _ lin) =>[] | by apply /BintP].
  move => i lin; bw; [ move => sb | by apply /BintP].
  move: (Bip _ lin) => [pa _].
  have pc: sub (Bi i) (Vg f i \cap unionb (restr f (Bint i))).
    move => t tb; move: (sb _ tb).
    have sa: fgraph (Lg (Bint n) Bi) by fprops.
    have iB: inc i Bnat by apply (BS_le_int (proj1 lin) nB).
    have sc:sub (Bint i) (Bint n).
      by apply: Bint_M1 => //; move: lin => [].
    have sd: sub (Bint i) (domain (Lg (Bint n) Bi)) by bw.
    have se: sub (Bint i) (domain f) by rewrite df.
    move /setUb_P; bw; move => [y ys].
    move: (sc _ ys) => yi; bw => tc; apply setI2_P;split => //.
         by move: (Bip _ lin) => [_]; apply.
     apply /setUb_P; exists y; bw.
     have yn: y<c n by apply /BintP.
     by move: (Bip _ yn) => [_]; apply.
  move: (ifu _ lin) => /set_of_pureP [_ pb].
  by move: (pb _ pc); case.
move: (BS_le_int (proj1 cb) nB) => rB.
move: (cdiff_nz cb).
move: (cdiff_pr (proj1 cb)).
move: (BS_diff (cardinal B) nB);set m := n -c cardinal B.
rewrite csumC;move=> mB rmn mnz.
rewrite -rmn in h8.
move: (pure_properties_res8 mer minr rB mB mnz h8 (refl_equal (cardinal B))).
move => [g [g1 g2 g3 g4 g5]].
have zm: \0c <c m by split; fprops.
move: (g3 _ zm)(g4 _ zm) => ta tb.
case: (dp (Vg g \0c)) => //.
move => t tv; move: (tb _ tv) => /setC_P [sa sb] => //.
move: sa; rewrite /f' => /setUb_P; bw; move => [y yi];bw => tc.
apply /setC_P;split => //;apply /setUb_P; rewrite df; ex_tac.
by move: yi => /(BintP nB) yi; move: (Bip _ yi) => [_]; apply.
Qed.

Pure sets and max pure sets are (a) there is no pure set, (b) pure sets have cardinal <=n; max pure have cardinal n, (c) pure sets are small; max pure are singletons, (d) the only pure set is empty.

Section Exercice4_11.
Variables A R: Set.
Hypothesis mnr: mobile_ext R A.

Lemma Exercise4_11a:
  inductive (sub_order (set_of_pure A R)).
Proof. by apply: pure_properties_res1. Qed.

Lemma Exercise4_11b x: sub x A -> pure R x ->
  exists2 y, sub x y & max_pure A R y.
Proof.
move => xa px.
set po:= (sub_order (set_of_pure A R)).
move: (sub_osr (set_of_pure A R)) => [or sr].
have xsr: inc x (substrate po).
   by rewrite sr; apply: Zo_i => //; apply /setP_P.
move: (inductive_max_greater or Exercise4_11a xsr).
move => [m]; rewrite /po/maximal sr.
move => [mp xm] /sub_gleP [_ _ sm]; move: mp => /set_of_pureP.
move=> [ma prm]; exists m => //; split => // p pp cmp pa; symmetry; apply: xm.
by apply /sub_gleP;split => //; apply: Zo_i => //; apply /setP_P.
Qed.

If M is maximal pure and x is not in M then Ex4_11EM M x is the unique subset of M such that adjoining x gives an element of R

Lemma Exercise4_11c M x: max_pure A R M -> inc x (A -s M) ->
  exists !z, [/\ inc z (powerset A), sub z M & inc (z +s1 x) R].
Proof.
move: mnr => [q1 q2 q3 q4].
move => [pm1 pm2 mpx] /setC_P [xA nxm].
apply /unique_existence; split; last first.
  move => a b [aA aM saR] [bA bM sbR].
  ex_middle nab.
  have ne1: ~ inc x a by move => xa; case: nxm; apply: aM.
  have ne2: ~ inc x b by move => xa; case: nxm; apply: bM.
  have ne3: (a +s1 x) <> (b +s1 x).
    move => eta; case: nab.
    by rewrite - (setU1_K ne1) - (setU1_K ne2) eta.
  have xc: inc x ((a +s1 x) \cap (b +s1 x)) by fprops.
  move: (q3 _ _ saR sbR ne3 _ xc); move => [Z [Zr sz nxz]].
    have zM: sub Z M.
      move => t tZ; move: (sz _ tZ); case /setU2_P; case /setU1_P; fprops;
      by move => tx; case: nxz; rewrite - tx.
  by case: (pm2 _ zM).
have ta: sub (M +s1 x) A by move => t; case /setU1_P; [ fprops | by move => ->].
have [t ts tr]: exists2 t, sub t (M +s1 x) & inc t R.
  case: (p_or_not_p (pure R (M +s1 x))) => npt.
    case: nxm; rewrite (mpx _ npt (@sub_setU1 x M) ta); fprops.
  by ex_middle bad; case: npt => s ts b3;case: bad; exists s.
move: (sub_trans ts ta) => tA.
set z := t -s1 x.
have zM: sub z M.
  move => s /setC1_P [td te].
  by move: (ts _ td); case /setU1_P.
move: (pm2 _ zM) => zR.
have zt: sub z t by move => u /setC1_P [].
case: (inc_or_not x t) => xy.
  move: (setC1_K xy) => tc.
  exists z;split => //; first by (apply /setP_P; apply: (sub_trans zt tA)).
  by rewrite /z tc.
case: zR; have -> //: z = t.
set_extens s; first by move /setC1_P => [].
by move => st; apply /setC1_P;split => //; dneg sx; rewrite - sx.
Qed.

Definition Ex4_11EM M x := select (fun z => (sub z M /\ inc (z +s1 x) R))
  (powerset A).

Lemma Exercise4_11d M x: max_pure A R M -> inc x (A -s M) ->
  (sub (Ex4_11EM M x) M /\ inc ((Ex4_11EM M x) +s1 x) R).
Proof.
move => pa pb; rewrite /Ex4_11EM.
pose p z := sub z M /\ inc (z +s1 x) R; rewrite -/p -/(p _).
move:(Exercise4_11c pa pb) => [z [[qa qb qc] zb]].
have h:(singl_val2 (inc ^~ (powerset A)) p).
  move => a b aP [r1 r2] bP [r3 r4].
  by rewrite - (zb _ (And3 aP r1 r2)) (zb _ (And3 bP r3 r4)).
by rewrite - (select_uniq h qa (conj qb qc)).
Qed.

Lemma Exercise4_11e M x: max_pure A R M -> inc x (A -s M) ->
  inc (Ex4_11EM M x +s1 x) (min_incl_r R).
Proof.
move => mm xa.
move: (Exercise4_11d mm xa) => [pa pb]; apply: Zo_i => // t tr ts.
move: (mm) => [m1 m2 m3].
case: (inc_or_not x t) => xt; last first.
  have ta: sub t (Ex4_11EM M x).
    move => s st; move: (ts _ st); case /setU1_P => // sx; case: xt; ue.
  by move: (m2 _ (sub_trans ta pa) tr).
set x0 := Ex4_11EM M x.
have qa: [/\ inc x0 (powerset A), sub x0 M & inc (x0 +s1 x) R].
   rewrite /x0;split => //; apply /setP_P => //; apply: (sub_trans pa m1).
set x1 := (t -s1 x).
have ta: t = x1 +s1 x by symmetry;apply:setC1_K.
have tb: sub (t -s1 x) M.
  move => s /setC1_P [sa sb]; move: (ts _ sa); case /setU1_P => //; apply: pa.
have qb: [/\ inc x1 (powerset A), sub x1 M & inc (x1 +s1 x) R].
  rewrite /x1;split => //; [by apply /setP_P; apply: (sub_trans tb m1) | ue ].
move /unique_existence: (Exercise4_11c mm xa) => [_ un].
by rewrite (un _ _ qa qb).
Qed.

Lemma Exercise4_11f M x y: max_pure A R M -> inc x (A -s M) ->
  inc y (Ex4_11EM M x) -> max_pure A R ((M +s1 x) -s1 y).
Proof.
move => mxpm xam ye; move: (Exercise4_11d mxpm xam) => [pa pb].
move: (mxpm) (xam) => [ma pm mpm] /setC_P [xa xm].
set T := ((M +s1 x) -s1 y).
have tpP: forall u, inc u T <-> ((inc u M \/ u = x) /\ u <> y).
  move => u; split.
   by move /setC1_P =>[sa sb]; split => //; apply /setU1_P.
  by move => [sa sb]; apply /setC1_P;split => //; apply /setU1_P.
have tA: sub T A. move => t /tpP []; case; [fprops | by move => ->].
move: mnr => [q1 q2 q3 q4].
split; first by exact.
  move => z zt zr.
  case: (inc_or_not x z) => xz; last first.
    apply: pm zr; move => t tz; move: (zt _ tz) => /tpP.
    move => [h _]; case: h => // tx; case: xz; ue.
  have xe: inc x ((Ex4_11EM M x) +s1 x) by fprops.
  have xnez: (Ex4_11EM M x) +s1 x <> z.
    move => ta.
    have : inc y ((Ex4_11EM M x) +s1 x) by fprops.
    by rewrite ta =>yz; move: (zt _ yz) => /tpP [_].
  have xi: inc x ((Ex4_11EM M x) +s1 x \cap z) by fprops.
  move: (q3 _ _ pb zr xnez _ xi); move => [Z [ZR Zt xZ]].
  have ZM: sub Z M.
    move => t tZ;move: (Zt _ tZ); case /setU2_P.
      case /setU1_P; [ by apply: pa | by move => tx; case: xZ; ue].
    move => tz; move: (zt _ tz) => /tpP [ta tb].
    case: ta => //;move => tx; case: xZ; ue.
  by case: (pm _ ZM).
move => p pp sp pA.
case: (inc_or_not y p) => yp.
   have st: sub (M +s1 x) A by move => t; case /setU1_P; fprops; move => ->.
   have pt: (pure R (M +s1 x)).
     move => s sst; apply: pp.
     move => t ts; case: (equal_or_not t y) => Tp; first by rewrite Tp.
     by apply: sp; apply /tpP;split => //; apply /setU1_P; apply: sst.
   have st1: sub M (M +s1 x) by fprops.
   case: xm; rewrite (mpm _ pt st1); fprops.
ex_middle ntp.
move: (setC_ne (conj sp ntp)) =>[v] /setC_P [vp vT].
have ynv: y <> v by move => yv;case: yp; rewrite yv.
move: (pA _ vp) => vA.
have pt: pure R (T +s1 v).
  have sa: sub (T +s1 v) p by move => t; case /setU1_P;[ apply:sp | move => ->].
  move => b ba; apply: pp; apply: (sub_trans ba sa).
have nvM: inc v (A -s M).
    apply /setC_P; split => //; move => vm.
    by case: vT; apply/tpP;split => //; [ left | apply:nesym ].
have xnv: x <> v by move => xv;case: vT; apply /tpP;split; fprops.
move: (Exercise4_11d mxpm nvM); move => [sE iteR].
set Sx := ((Ex4_11EM M x) +s1 x).
set Sv := ((Ex4_11EM M v) +s1 v).
have s1: sub Sv A by move => t; case /setU1_P; fprops; move => ->.
have s2: sub Sx A by move => t ; case /setU1_P ; fprops; move => ->.
case: (inc_or_not y Sv) => yEv; last first.
  have BM: sub Sv (T +s1 v).
    move => t; case /setU1_P => te; apply/setU1_P; fprops; left.
    apply /tpP; split; first by left; apply: sE.
    dneg ty; apply /setU1_P; left; ue.
  by move: (pt _ BM).
have yEx: inc y Sx by rewrite /Sx;fprops.
have nSxv: Sx <> Sv.
  dneg sxv; have: inc x Sx by rewrite /Sx; fprops.
  by rewrite sxv /Sv;aw; case /setU1_P => // xv; case: xm; apply: sE.
have yi: inc y (Sx \cap Sv) by fprops.
move: (q3 _ _ pb iteR nSxv _ yi) => [Z [Zr zi nyz]].
have zt: sub Z (T +s1 v).
  move => t tz.
  have tny : t <> y by move => ty; case: nyz; ue.
  move: (zi _ tz); case /setU2_P; case /setU1_P => ta; apply /setU1_P.
  by left; apply /tpP;split => //; left; apply: pa.
  by left; apply /tpP;split => //; right.
  by left; apply /tpP;split => //; left; apply:sE.
  by right.
by move: (pt _ zt).
Qed.

Two maximal pure sets are equipotent. Let C = M - N. If C is empty, then M is a subset of N and M=N. If C is finite, we take a in C and b in (Ex4_11EM N a) - M (it exists by purity of M. Then N - a + b is maximal pure, has the same cardinal as N and has same cardinal as M by induction.

Lemma Exercise4_11g M N: max_pure A R M -> max_pure A R N ->
  finite_set (M -s N) -> equipotent M N.
Proof.
set C := (M -s N).
have : C = (M -s N) by done.
move: C; move => C cv mp mp' fsc; move: C fsc M N cv mp mp'.
apply: finite_set_induction0.
   move => M M' iz mp mp'.
   symmetry in iz; move: (empty_setC iz) => l1.
   move: mp mp' => [mp0 mp1 mp2] [mp5 mp3 mp4].
   rewrite (mp2 _ mp3 l1 mp5);apply: equipotentR.
move => C a Hrec naC M N cv Mp Np.
have : inc a (C +s1 a) by fprops.
rewrite cv; move => /setC_P [aM naN].
have aAN: inc a (A -s N) by apply /setC_P; split => //;apply (proj31 Mp).
move:(Exercise4_11d Np aAN) => [seN teR].
case: (emptyset_dichot ((Ex4_11EM N a) -s M)) => esd.
  move: (empty_setC esd) => s1.
  have s2: sub ((Ex4_11EM N a) +s1 a) M
     by move => t; case /setU1_P; fprops => ->.
  by move: (proj32 Mp _ s2).
move: esd => [b] /setC_P [bt nb].
move: (Exercise4_11f Np aAN bt).
set T := ((N +s1 a) -s1 b) => mpT.
have pa: C = M -s T.
  set_extens t.
    move => tc; apply /setC_P.
    have: inc t (C +s1 a) by fprops.
    rewrite cv => /setC_P [tm tn]; split => //.
    move /setC1_P => [] /setU1_P; case => // ta _;case: naC; ue.
  move => /setC_P [tm] /setC1_P aux.
  have ntb: t <> b by move=> tb; case: nb; ue.
  case: (equal_or_not t a) => nta.
     by case: aux; split; [ rewrite nta;fprops | exact].
  case: (inc_or_not t N) => ntN; first by case: aux; split; [ fprops | exact].
  have: inc t (C +s1 a) by rewrite cv; apply /setC_P; split.
  by case /setU1_P.
eqtrans T.
apply /card_eqP.
set s := (N +s1 a).
have bs: inc b s by apply /setU1_P;left; apply: seN.
have ias: inc a s by rewrite /s;fprops.
move: (card_succ_pr2 bs) (card_succ_pr2 ias).
rewrite (setU1_K naN); move => -> ss.
have ca: cardinalp (cardinal N) by apply: CS_cardinal.
have cb: cardinalp (cardinal (s -s1 b)) by apply: CS_cardinal.
by rewrite (succ_injective1 cb ca ss).
Qed.

Assume z in M-N not in the union of Ex4_11EM M x for x in N-M. Let F = Ex4_11EM N z. Admitted

Lemma Exercise4_11h M N:
  max_pure A R M -> max_pure A R N ->
  sub (M -s N) (unionb (Lg (N -s M) (fun z => (Ex4_11EM M z)))).
Proof.
move => mp np; move => z zmn; apply setUb_P; bw;ex_middle bad1.
have bad2: forall x, inc x (N -s M) -> ~(inc z (Ex4_11EM M x)).
  move => x xa xb; case: bad1; exists x; bw.
move: (zmn) => /setC_P[zM zN].
move: (proj31 mp _ zM) => zA.
have zan: inc z (A -s N) by apply /setC_P.
move: (Exercise4_11d np zan) => [F0n F0R].
move: mnr => [q1 q2 q3 q4].
have rec: forall F y, sub F (N \cup M) -> inc (F +s1 z) R ->
  inc y (F -s M) ->
  exists F', [/\ sub F' (N \cup M), inc (F +s1 z) R, ~ (inc y F') &
    sub (F' -s M) (F -s M)].
  move => F y FA FpR yFsM.
  move: yFsM => /setC_P [yF yM]; move: (FA _ yF) => yNuM.
  have yN: inc y N by move: yNuM; case /setU2_P.
  have yam: inc y (A -s M) by apply/setC_P; split => //;apply: (proj31 np _ yN).
  move: (Exercise4_11d mp yam) => [ta tb].
  have nXY: (F +s1 z) <> (Ex4_11EM M y +s1 y).
    move => heq.
    have yNM: inc y (N -s M) by apply /setC_P.
    move: (bad2 _ yNM) => nz.
    have: inc z (F +s1 z) by fprops.
    rewrite heq;case /setU1_P => // => eq2; case: zN; ue.
  have ti: inc y ((F +s1 z) \cap (Ex4_11EM M y +s1 y)) by fprops.
  move : (q3 _ _ FpR tb nXY _ ti) => [Z [Za Zb Zc]].
Admitted.

If one complement is finite, then M and N are equipotent. Otherwise we use Exercise4_11k and an upper bound of the cardinal of the union. It followd that Card(M-N) <= Card(N-M) and vice versa.

Lemma Exercise4_11i M N: max_pure A R M -> max_pure A R N ->
 equipotent M N.
Proof.
move => pM pN.
case: (finite_dichot1(N -s M)) => h1; first by eqsym;apply: Exercise4_11g.
case: (finite_dichot1 (M -s N)) => h2; first by apply: Exercise4_11g.
move: (Exercise4_11h pM pN) (Exercise4_11h pN pM).
set C1 := (M -s N); set C2 := (N -s M) => s1 s2.
move: (card_leT (sub_smaller s1) (csum_pr1 _)); bw => le1.
move: (card_leT (sub_smaller s2) (csum_pr1 _)); bw => le2.
set f1:= (Lg C2 (fun a : Set => cardinal (Vg (Lg C2 [eta Ex4_11EM M]) a))).
set f2:= (Lg C1 (fun a : Set => cardinal (Vg (Lg C1 [eta Ex4_11EM N]) a))).
have fg1 : fgraph f1 by rewrite /f1; fprops.
have fg2 : fgraph f2 by rewrite /f2; fprops.
have h1': infinite_c (cardinal C2) by move: h1; move /infinite_setP.
have h2': infinite_c (cardinal C1) by move: h2; move /infinite_setP.
have cd1: cardinal (domain f1) <=c cardinal C2 by rewrite /f1; bw; fprops.
have cd2: cardinal (domain f2) <=c cardinal C1 by rewrite /f2; bw; fprops.
move: mnr => [q1 q2 q3 q4].
have l1: (forall i, inc i (domain f1) -> Vg f1 i <=c cardinal C2).
   rewrite /f1; bw; move => i idf; bw; apply: finite_le_infinite => //.
   move: idf => /setC_P[i1 i2].
   have i3: inc i (A -s M) by apply /setC_P;split => //;apply: (proj31 pN _ i1).
   move: (Exercise4_11d pM i3) => [ _ tf].
   move: (q2 _ tf); apply: sub_finite_set; fprops.
have l2: (forall i, inc i (domain f2) -> Vg f2 i <=c cardinal C1).
   rewrite /f2; bw. move => i idf; bw; apply: finite_le_infinite => //.
   move: idf => /setC_P [i1 i2].
   have i3: inc i (A -s N) by apply /setC_P;split => //; apply:(proj31 pM _ i1).
   move: (Exercise4_11d pN i3) => [ _ tf].
   move: (q2 _ tf); apply: sub_finite_set; fprops.
move: (card_leT le1 (notbig_family_sum h1' cd1 l1)) => l3.
move: (card_leT le2 (notbig_family_sum h2' cd2 l2)) => l4.
move: (card_leA l3 l4) => /card_eqP; apply: cardinal_setC3.
Qed.

End Exercice4_11.

End Exercise4.
Export Exercise4.