Library ssete5

Bourbaki Exercices

Copyright INRIA (2012-2013) Marelle Team (Jose Grimm).
Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Export sset13 sset15 ssete4.

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

Module Exercise5.


Exercise 5.1:

Lemma Exercise5_1 p n q :
   inc n Bnat -> p <=c n -> q <c p ->
   binom n p = card_sumb (interval_cc Bnat_order q (n -c p +c q)) (fun k =>
    binom (n-c (succ k)) (p -c (succ q)) *c binom k q).
Proof.
move => nB lepn ltpq.
move: (BS_le_int lepn nB) => pB.
move: (BS_le_int (proj1 ltpq) pB) => qB.
set E := (Bint n).
set bigset := subsets_with_p_elements p E.
have ce: cardinal E = n by rewrite (card_Bint nB).
pose EV X := select (fun x => cardinal (X \cap (Bint x)) = q) X.
have PA: cardinal bigset = binom n p.
  by rewrite (subsets_with_p_elements_pr nB pB ce).
have PB: forall X, inc X bigset ->
  exists ! x, inc x X /\ cardinal (X \cap (Bint x)) = q.
  move => X /Zo_P [] /setP_P XE cx.
  pose f x := cardinal (X \cap Bint x).
  have f0: f \0c = \0c.
     have aux:(X \cap emptyset) = emptyset.
       by apply /set0_P => t /setI2_P [_] /in_set0.
     by rewrite /f Bint_co00 aux cardinal_set0.
  have fn: f n = p by rewrite /f -/E; move /setI2id_Pl: XE => ->.
  have pa: forall x, inc x Bnat ->
      Bint x +s1 x = Bint (succ x).
    move => x xn; exact (proj1 (Bint_pr4 xn)).
  have pb: forall x, inc x Bnat -> X \cap Bint (succ x) =
     (X \cap Bint x) \cup (X \cap singleton x).
    by move => x xb; rewrite - set_IU2r - (pa _ xb).
  have fnok: forall x, inc x Bnat -> ~(inc x X) -> f x = f (succ x).
    move => x xB xX; rewrite /f - (pa _ xB); congr (cardinal _).
    set_extens t; move => /setI2_P [sa sb]; apply /setI2_P; split;fprops.
    by case /setU1_P: sb => // xt; case: xX; rewrite - xt.
  have fok: forall x, inc x Bnat -> (inc x X) -> succ (f x) = f (succ x).
    move => x xB xX; rewrite /f (pb _ xB).
    have ->: (X \cap singleton x) = singleton x.
       apply: set1_pr; fprops.
       by move => z /setI2_P [_] /set1_P.
    by rewrite card_succ_pr //; move /setI2_P => [_] /(BintP xB) [].
  have cax: forall x, cardinalp (f x) by rewrite /f; fprops.
  have fm: forall x y, inc x Bnat -> inc y Bnat -> f x <=c f (x +c y).
     move => x y xb yb; move: y yb x xb; apply: cardinal_c_induction.
       move => x xb; aw; fprops.
     move => m mB hrec x xb; move: (hrec _ xb) => pc; apply: (card_leT pc).
     rewrite (csum_via_succ _ mB); case: (inc_or_not (x +c m) X) => h.
       rewrite - (fok _ (BS_sum xb mB) h); apply:card_le_succ0; fprops.
       rewrite - (fnok _ (BS_sum xb mB) h); fprops.
  have fxb: forall x, inc (f x) Bnat.
     move => x; rewrite /f.
     have h: sub (X \cap Bint x) X by apply: subsetI2l.
     move: (sub_smaller h); rewrite cx => ha.
     by move:(BS_le_int ha pB).
  have fm1: forall x y, inc x Bnat -> inc y Bnat -> x <c y -> inc x X ->
       f x <c f y.
    move => x y xb yb xy xx; move: (fok _ xb xx) => pc.
    apply /(card_le_succ_ltP _ (fxb x)).
    have ha: succ x <=c y by apply / (card_le_succ_ltP _ xb).
    rewrite - (cdiff_pr ha) pc; apply: fm; fprops.
  have XB: sub X Bnat by move => t tx; exact: (Bint_S1 (XE _ tx)).
  apply /unique_existence;split; last first.
    move => x y [xx xv][yx yv] ;move: (XB _ xx) (XB _ yx) => xb yb.
    case: (card_le_to_ell (CS_Bnat xb)(CS_Bnat yb)) => // ha.
      by move: (fm1 _ _ xb yb ha xx) => [_]; rewrite /f xv yv.
      by move: (fm1 _ _ yb xb ha yx) => [_]; rewrite /f xv yv.
  pose pr x := inc x Bnat /\ q <c f x.
  have pc: (forall x, pr x -> inc x Bnat) by move => x [].
  have pd: exists x, pr x by exists n; split => //; rewrite fn.
  move: (least_int_prop pc pd); case.
    rewrite /pr f0;move => [_ pe]; case: (card_lt0 pe).
  move => [x [xn [pe pf pg]]].
  exists x; case: (inc_or_not x X) => xx; last first.
    by case: pg; split => //;rewrite (fnok _ xn xx).
  move: pf; rewrite - (fok _ xn xx); move /(card_lt_succ_leP (fxb x)) => ph.
  split => //; ex_middle eq1; case: pg;split => //; split => //; fprops.
have PC: forall X, inc X bigset ->
  ( cardinal (X \cap (Bint (EV X))) = q /\ inc (EV X) X).
  move => X xb; move:(PB _ xb) => [z [[za zb] zc]]; apply: select_pr.
      ex_tac.
  by move => a b p1 p2 p3 p4; rewrite - (zc _ (conj p1 p2)) (zc _ (conj p3 p4)).
have PD: forall X, inc X bigset ->
  inc (EV X) (interval_cc Bnat_order q (n -c p +c q)).
  move => X px;move: (PC _ px) => [pc pd].
  move: px => /Zo_P [] /setP_P pa pb.
  have sc: inc ((n -c p) +c q) Bnat by fprops.
  move: (Bint_S1 (pa _ pd)) => xB.
  set int := (Bint (EV X)).
  move: (sub_smaller (@subsetI2r X int)); rewrite pc (card_Bint xB) => pe.
  apply /(Bint_ccP1 qB sc); split => //.
  have pf: sub (X \cap int) (X \cap E).
    by move => T /setI2_P [tx ti]; apply /setI2_P;split => //; apply: pa.
  have pg: cardinal (X \cap E) = p by move /setI2id_Pl: pa => ->.
  have ph: finite_set (X\cap E) by red; rewrite pg; apply /BnatP.
  move: (pa _ pd) => /(BintP nB) [ltxn _].
  have pf': sub int E by apply (Bint_M1) => //.
  have pg': cardinal E = n by rewrite (card_Bint nB).
  have ph': finite_set E by red; rewrite pg'; apply /BnatP.
  move: (cardinal_setC4 pf' ph'); rewrite pg' (card_Bint xB).
  move: (cardinal_setC4 pf ph); rewrite pg pc.
  have <-: X \cap (E -s int) = X \cap E -s (X \cap int).
     set_extens t.
       move =>/setI2_P [tx] /setC_P [t1 t2];apply /setC_P; split => //.
       apply /setI2_P => //.
       by move /setI2_P => [].
    move /setC_P => [] /setI2_P [t1 t2] t3; apply /setI2_P; split => //.
    by apply /setC_P;split => // ti; case: t3; apply /setI2_P.
  move => sa sb;move: (sub_smaller (@subsetI2r X (E -s int))).
  rewrite sa sb.
  move: (cdiff_pr (proj1 ltpq)); set pq := (p -c q) => sd.
  have pqB: inc pq Bnat by rewrite /pq; fprops.
  have ->: (n -c p) +c q = n -c pq.
      move: (cdiff_pr lepn); set np := (n -c p); rewrite - sd.
    rewrite csumC csumA; move => <-; symmetry; apply:cdiff_pr1; fprops.
  move: (cdiff_pr ltxn); set nx := n -c (EV X); move => <- => h.
  move: (cdiff_pr h); set y := (nx -c pq) => <-.
  have yB:inc y Bnat by apply : (BS_diff); apply : (BS_diff).
  rewrite (csumC pq) (csumA) (cdiff_pr1 (BS_sum xB yB) pqB).
  by exact: (csum_M0le y (CS_Bnat xB)).
transitivity (card_sumb (interval_cc Bnat_order q (n -c p +c q)) (fun k =>
     cardinal ( Zo bigset (fun X => EV X = k)))).
  rewrite -PA; apply:card_partition_induced; apply:PD.
rewrite /card_sumb; apply: f_equal.
apply: Lg_exten => k /Bint_ccP [_ [_ _ lin]].
have ly1: (n -c p +c q) <c n.
  move: (cdiff_pr lepn); set np := (n -c p) => <-.
  rewrite csumC; exact (csum_Mlteq (BS_diff _ nB) pB ltpq).
have ltkn: k <c n by co_tac.
move: (BS_le_int (proj1 ltkn) nB) => kB.
move: (BS_succ kB) => sk.
move/ (card_le_succ_ltP _ kB): (ltkn) => leskn.
move /(card_le_succ_ltP _ qB): (ltpq) => lesqp.
move: (cdiff_pr lesqp); set q':= (p -c succ q) => eq1.
set I2 := E -s (Bintc k).
have i2p:I2 = E -s Bint (succ k) by rewrite - (Bint_co_cc kB).
have ci2: cardinal I2 = (n -c succ k).
  have pf': sub (Bint (succ k)) E by apply (Bint_M1).
  have pg': cardinal E = n by rewrite (card_Bint nB).
  have ph': finite_set E by red; rewrite pg'; apply /BnatP.
  by move: (cardinal_setC4 pf' ph'); rewrite pg' i2p (card_Bint sk).
have q'B: inc q' Bnat by rewrite /q'; fprops.
have nskB: inc (n -c succ k) Bnat by fprops.
move: (subsets_with_p_elements_pr kB qB (card_Bint kB)).
move: (subsets_with_p_elements_pr nskB q'B ci2).
set Y:= subsets_with_p_elements _ _.
set Z := subsets_with_p_elements _ _ => -> ->.
have ->: cardinal Y *c cardinal Z = cardinal (Y \times Z).
  rewrite - cprod2_pr1;apply cprod2_pr2; apply: double_cardinal.
symmetry;apply /card_eqP.
pose f z := (P z \cup Q z) +s1 k.
exists (Lf f (Y \times Z) (Zo bigset (fun X => EV X = k))).
have ci2b: inc (cardinal I2) Bnat by rewrite ci2; fprops.
have la:lf_axiom f (Y \times Z) (Zo bigset (fun X => EV X = k)).
  move => u /setX_P [pu ] /Zo_P [] /setP_P pa pb /Zo_P [] /setP_P pc pd.
  have pe: sub ((P u \cup Q u) +s1 k) E.
    move => t; case /setU1_P.
       case /setU2_P => ta; first by move /setC_P: (pa _ ta) => [].
       move: (pc _ ta) => /(BintP kB) tk; apply /(BintP nB); co_tac.
    by move => ->; apply /(BintP nB).
  have pf: cardinal ((P u \cup Q u) +s1 k) = p.
    have nku: ~ inc k (P u \cup Q u).
      move /setU2_P; case => h.
        move: (pa _ h); rewrite i2p; move=> /setC_P [_]; case.
            apply/(BintsP kB); fprops.
      by move: (pc _ h) => /(BintP kB) [_].
    rewrite (card_succ_pr nku).
    have di: disjoint (P u) (Q u).
        apply disjoint_pr => t ta tb.
         move: (pa _ ta); rewrite i2p; move=> /setC_P [_]; case.
       by move: (pc _ tb) =>/ (BintP kB) [le1 _]; apply /(BintsP kB).
    rewrite (csum2_pr5 di) - csum2_pr2b - csum2_pr2a pb pd.
    rewrite - (csum_via_succ _ qB) cdiff_rpr //.
  have pg: inc (f u) bigset by apply /Zo_P; split => //; apply /setP_P.
  apply /Zo_P; split; first by exact.
  have ph:inc k (f u) /\ cardinal (f u \cap Bint k) = q.
    split; first by apply /setU1_P; right.
    suff: ((P u \cup Q u) +s1 k) \cap Bint k = Q u.
       by rewrite /f => ->.
    set_extens t; last by move => ts; apply /setI2_P; split;fprops.
    move /setI2_P => [sa] /(BintP kB) [tk1 tk2]; case /setU1_P: sa =>//.
     case /setU2_P => // tp; move: (pa _ tp).
     by rewrite i2p => /setC_P [te] /(BintsP kB).
  set s := EV (f u).
  have pi:inc s (f u) /\ cardinal (f u \cap Bint s) = q.
    by move: (PC _ pg)=> [sa sb].
  move/unique_existence: (PB _ pg) => [_ h]; exact (h _ _ pi ph).
have fi: forall u v,
  inc u (Y \times Z) -> inc v (Y \times Z) -> f u = f v -> u = v.
  have aux: forall u, inc u (Y \times Z) ->
    u = J (f u \cap I2) (f u \cap (Bint k)).
     move => u /setX_P [pu ] /Zo_P [] /setP_P pa _ /Zo_P [] /setP_P pb _.
     rewrite - {1} pu /f; congr (J _ _).
     set_extens t.
         move => ts; apply /setI2_P; split;fprops.
       move /setI2_P => [sa]; rewrite i2p => /setC_P [te] /(BintsP kB).
       move => tk;case /setU1_P: sa.
       by case /setU2_P => // tq; move /(BintP kB): (pb _ tq) => [tk1 _].
       move => tk1; case: tk; rewrite tk1; fprops.
    set_extens t.
        move => ts; apply /setI2_P; split;fprops.
      move /setI2_P => [sa] /(BintP kB) [tk1 tk2]; case /setU1_P: sa =>//.
      case /setU2_P => // tp; move: (pa _ tp).
      by rewrite i2p => /setC_P [te] /(BintsP kB).
  move => u v pu pv sv.
  by rewrite (aux _ pu) (aux _ pv) sv.
split; aw; apply: lf_bijective => //.
move => y /Zo_P [pa pb].
move: (PC _ pa); rewrite pb; move => [pc pd].
set A:=(y \cap Bint k); set B:= (y -s A) -s1 k.
have ay: sub A y by apply subsetI2l.
have Az: inc A Z by apply /Zo_P;split => //; apply /setP_P; apply: subsetI2r.
move: pa => /Zo_P []/setP_P y1 y2.
have b2: sub B I2.
  rewrite i2p;move => t /setC1_P [] /setC_P [ta tb] tc; apply /setC_P.
  split;fprops; move /(BintsP kB) => tk; case: tb; apply /setI2_P.
    split => //;by apply /(BintP kB); split.
  have pa: inc k (y -s A).
     by apply /setC_P;split => //; move /setI2_P => [_] /(BintP kB) [].
  move: (cardinal_setC2 ay);rewrite y2 - csum2_pr2a pc - csum2_pr2b.
  rewrite(card_succ_pr2 pa) -/B - eq1.
  move: (BS_le_int(sub_smaller b2) ci2b) => cbb.
  rewrite (csum_via_succ _ cbb) - (csum_via_succ1 _ qB) => h.
  move: (csum_simplifiable_left (BS_succ qB) q'B cbb h) => h1.
  have By: inc B Y by apply /Zo_P;split => //; apply /setP_P.
  exists (J B A); first by apply:setXp_i.
  rewrite /f; aw; set_extens t; last first.
    case /setU1_P; last by move => -> ;apply: pd.
    by case /setU2_P; [ move => /setC1_P [] /setC_P [] | move /setI2_P=> []].
  move => ty; apply /setU1_P;case: (equal_or_not t k) => tk //; first by right.
  left; apply /setU2_P; case: (inc_or_not t A) => ta; first by right.
  by left; apply /setC1_P;split => //; apply /setC_P.
Qed.


Exercise 5.2
Lemma Exercise5_2 E
  (fs_even := Zo (powerset E) (fun z => even_int (cardinal z)))
  (fs_odd := Zo (powerset E) (fun z => odd_int (cardinal z))):
  finite_set E -> nonempty E -> fs_even \Eq fs_odd.
Proof.
move => fse nne.
set n := cardinal E.
pose ce := complement E.
have cs1: forall X, sub (ce X) E by move => X; apply: sub_setC.
have ce2: forall X, sub X E -> cardinal X +c cardinal (ce X) = n.
   by move => x xe; rewrite csum2_pr2b csum2_pr2a - cardinal_setC2.
have fsx: forall X, sub X E -> inc (cardinal X) Bnat.
   move => x xe; apply /BnatP; apply: (sub_finite_set xe fse).
have cs3: forall X, inc (cardinal (ce X)) Bnat by move => X; apply: fsx.
have cs4: forall X, sub X E -> ce (ce X) = X.
   by move => X; apply:setC_K.
have nB: inc n Bnat by move: fse => /BnatP.
case: (equal_or_not (card_rem n \2c) \0c) => nev; last first.
  have oddn: odd_int n by split => //; move => [ta tb].
  exists (Lf ce fs_even fs_odd);split; aw; apply: lf_bijective.
      move => c /Zo_P [] /setP_P cee evc; apply /Zo_P;split => //.
        by apply /setP_P.
      split; [by apply: cs3 | move => cxe].
      move: (even_odd_sum (cardinal c) (cardinal (ce c))) => [_ _ eee].
      by move: (eee evc cxe); rewrite (ce2 _ cee); move =>[].
    move => u v /Zo_P [] /setP_P uE _ /Zo_P [] /setP_P vE _ eq.
    by move: (f_equal ce eq); rewrite (cs4 _ uE) (cs4 _ vE).
  move => y => /Zo_P [] /setP_P ye yo.
  move: (cs1 y) => xe; rewrite - (cs4 _ ye); exists (ce y)=> //.
  apply: Zo_i; [by apply /setP_P | ex_middle ceo1].
  have ceo: odd_int (cardinal (ce y)) by [].
  move: (even_odd_sum (cardinal y) (cardinal (ce y))) => [eee _].
  by move: (eee yo ceo); rewrite (ce2 _ ye);move =>[].
have ece: even_int n by split.
have ce_e: forall X, sub X E -> even_int (cardinal X) ->
    even_int (cardinal (ce X)).
  move=> X XE ecx; ex_middle ceo1.
  have ceo: odd_int (cardinal (ce X)) by [].
  move: (even_odd_sum (cardinal X) (cardinal (ce X))) => [_ ee _].
   by move: (ee ecx ceo);rewrite (ce2 _ XE); move => [].
have ce_o: forall X, sub X E -> odd_int (cardinal X) ->
    odd_int (cardinal (ce X)).
  move=> X XE ecx; split => // => coe.
  move: (even_odd_sum (cardinal (ce X)) (cardinal X)) => [_ ee _].
  by move: (ee coe ecx); rewrite csumC (ce2 _ XE); move => [].
move: (rep_i nne); set t:= rep E=> repe.
pose ut x := Yo (inc t x) (x -s1 t) (x +s1 t).
have uut: forall x, sub x E -> (ut (ut x)) = x.
  move => x xE; rewrite /ut; case: (inc_or_not t x) => tx; Ytac0.
    have nst: ~(inc t (x -s1 t)) by move /setC1_P => [].
    by Ytac0; rewrite setC1_K.
  have nst: inc t (x +s1 t) by apply /setU1_P; right.
  by Ytac0; apply /setU1_K.
have u1: forall x, sub x E -> sub (ut x) E.
  move => x xe s; rewrite /ut; Ytac st.
       by move => /setC_P [sx _]; apply: xe.
  by case /setU1_P; [ apply: xe | move => -> ].
exists (Lf (fun z => ut (ce z)) fs_even fs_odd);split; aw; apply: lf_bijective.
    move => s => /Zo_P [] /setP_P ta tb; apply /Zo_P; split.
      apply /setP_P; fprops.
    move: (ce_e _ ta tb) => ec; move:(fsx _ (u1 _ (cs1 s))).
    rewrite /ut; Ytac xt => cb.
      by move: (proj1 (even_odd_pred cb)); rewrite - (card_succ_pr2 xt); apply.
    by move: ((proj1 (even_odd_succ _) ec)); rewrite card_succ_pr.
  move => u v /Zo_P [] /setP_P ue _ /Zo_P [] /setP_P ve _ eq1.
  move: (f_equal ut eq1); rewrite (uut _ (cs1 _)) (uut _ (cs1 _)).
  by rewrite - {2} (cs4 _ ue) - {2} (cs4 _ ve) => ->.
move => y => /Zo_P [] /setP_P ta tb; move: (u1 _ ta) => ue.
exists (ce (ut y)) => //; last by rewrite (cs4 _ ue) (uut _ ta).
apply: Zo_i; [by apply /setP_P | apply: (ce_e _ ue) ].
move: (fsx _ ue); rewrite /ut; Ytac xt => cb.
  by move: (proj2 (even_odd_pred cb)); rewrite - (card_succ_pr2 xt); apply.
by move: ((proj2 (even_odd_succ _) tb)); rewrite card_succ_pr.
Qed.

Exercise 5.3

Lemma Exercise5_3a n p: inc n Bnat -> inc p Bnat ->
  card_sumb (Bintc p)
     (fun k => (binom n k) *c (binom (n -c k) (p -c k)))
   = \2c ^c p *c binom n p.
Proof.
move => nB pB.
set E := Bint n.
set F :=subsets_with_p_elements p E.
have ce: cardinal E = n by apply:(card_Bint nB).
set rhs := \2c ^c p *c binom n p.
set EE := (powerset E \times powerset E).
set G1 := Zo EE (fun z => inc (P z) F /\ sub (Q z) (P z)).
have res1: cardinal G1 = rhs.
  pose phi := Lf P G1 F.
  have sp: G1 = source phi by rewrite /phi; aw.
  have tp: F = target phi by rewrite /phi; aw.
  rewrite /rhs (subsets_with_p_elements_pr nB pB ce) -/F tp sp cprodC.
  have lfa: lf_axiom P G1 F by move => t /Zo_P [_ []].
  have fphi: function phi by apply: lf_function.
  apply:(shepherd_principle fphi).
  move => x; rewrite - tp => xf.
  set K := inv_image_by_fun _ _.
  pose f := Lf (fun z => J x z) (powerset x) K.
  move /Zo_P: (xf) => [] /setP_P xE cx.
  have bf: bijection f.
    apply lf_bijective.
        move => y /setP_P yx.
        have aux: inc (J x y) G1.
          apply /Zo_P; aw;split => //; apply: setXp_i; apply /setP_P => //.
          apply: (sub_trans yx xE).
        apply :(iim_fun_set1_i fphi); rewrite /phi;aw.
      move => u v _ _ h; exact (pr2_def h).
    move => y /(iim_fun_set1_P _ fphi) []; rewrite - sp => yG.
    move /Zo_P: (yG) => [pa [pb pc]]; rewrite /phi; aw => ->; exists (Q y).
      by apply /setP_P.
    by rewrite (setX_pair pa).
  have : cardinal (source f) = cardinal (target f) by apply /card_eqP;exists f.
  rewrite /f;aw; rewrite card_setP - cx => <-.
  apply: cpow_pr; fprops.
set G2 := Zo EE (fun z => [/\ cardinal (P z) <=c p,
       cardinal (Q z) = p -c cardinal (P z) & sub (Q z) (E -s (P z))]).
have fse: finite_set E by red; rewrite /E(card_Bint nB); apply /BnatP.
have res2: cardinal G2 = rhs.
  rewrite - res1; symmetry; apply /card_eqP.
  exists (Lf (fun z => J (Q z) ((P z) -s (Q z))) G1 G2);split; aw.
  apply: lf_bijective.
      move => z /Zo_P [] /setX_P [pz Pz Qz] [pa pb]; apply /Zo_P; aw.
      move /Zo_P: pa => [_ pc].
      move /setP_P:Pz => pze; move: (sub_finite_set pze fse) => fsp.
      split; last split.
      by apply: setXp_i => //; apply /setP_P => t /setC_P [pa _]; apply: pze.
      by move: (sub_smaller pb); rewrite pc.
      by rewrite (cardinal_setC4 pb fsp) pc.
      by move /setP_P:Qz => qze t /setC_P [ta tb]; apply /setC_P;split;fprops.
    move => u v /Zo_P [pa [_ pb]] /Zo_P [pc [_ pd]] eq1.
    move: (pr1_def eq1) (pr2_def eq1) => eq2 eq3.
    rewrite - (setX_pair pa) - (setX_pair pc) - (setU2_Cr pb) - (setU2_Cr pd).
    by rewrite eq3 eq2.
  move => y /Zo_P [] /setX_P [pa Py Qy] [pb pc pd].
  have a0 : ((P y \cup Q y) -s P y) = Q y.
    set_extens t.
       move => /setC_P [] /setU2_P; case => //.
     move => tq; apply /setC_P;split;fprops => py.
     by move: (pd _ tq) => /setC_P; case.
  have aux: J (P y) ((P y \cup Q y) -s P y) = y by rewrite - {5} pa a0.
  move: (Py) Qy => /setP_P Py' /setP_P Qy.
  have a2: sub (P y) (P y \cup Q y) by move => t tp; fprops.
  have a3:inc (P y \cup Q y) (powerset E).
      by apply /setP_P => // t /setU2_P;case; fprops.
  exists (J (P y \cup Q y) (P y)); aw; last by rewrite a0 pa.
  apply /Zo_P; aw;split; first by apply: setXp_i.
  split => //;apply :Zo_i => //.
  rewrite (cardinal_setC2 a2) - csum2_pr2b a0 pc - csum2_pr2a.
  by apply: cdiff_pr.
pose Xk k := Zo EE (fun z => [/\ cardinal (P z) = k,
           cardinal (Q z) = p -c cardinal (P z) & sub (Q z) (E -s P z)]).
set X := Lg (Bintc p) Xk.
have X1: fgraph X by rewrite /X; fprops.
have X2: mutually_disjoint X.
  red;rewrite /X; bw => i j ip jp; bw;mdi_tac nij => u ua ub; case: nij.
  by move: ua ub => /Zo_hi [<- _ _] /Zo_hi [<- _ _].
have X3: (unionb X) = G2.
   rewrite /X;set_extens t.
     move /setUb_P; bw; move => [y yp]; bw; move /Zo_P => [p1 [p2 p3 p4]].
      by apply /Zo_i => //; rewrite p3 p2; split => //;apply /(BintcP pB).
   move /Zo_P=> [p1 [p2 p3 p4]]; apply /setUb_P; bw.
   by move /(BintcP pB): p2 => h; ex_tac; bw; apply /Zo_P.
move: (csum_pr4 X2); rewrite X3 res2 => ->.
rewrite /X; bw; rewrite /card_sumb; apply: f_equal; apply: Lg_exten.
move => k kp. move: (kp) => /(BintcP pB) kp1; bw.
set F1 := subsets_with_p_elements k E.
pose phi := Lf P (Xk k) F1.
have sp: (Xk k) = source phi by rewrite /phi; aw.
have tp: F1 = target phi by rewrite /phi; aw.
have kB: inc k Bnat by apply (BS_le_int kp1 pB).
rewrite (subsets_with_p_elements_pr nB kB ce) -/F1 tp sp.
have lfa: lf_axiom P (Xk k) F1.
  by move => t /Zo_P [] /setX_P [pa pb pc] [pd _ _]; apply: Zo_i.
have fphi: function phi by apply: lf_function.
symmetry;apply:(shepherd_principle fphi).
move => x; rewrite - tp => xf.
set K := inv_image_by_fun _ _.
move: (xf) => /Zo_P [] /setP_P xe cx.
have nkB: inc (n -c k) Bnat by fprops.
have pkB: inc (p -c k) Bnat by fprops.
have cdx:cardinal (E -s x) = n -c k by rewrite (cardinal_setC4 xe fse) cx ce.
rewrite (subsets_with_p_elements_pr nkB pkB cdx).
apply /card_eqP.
set K0 := (subsets_with_p_elements (p -c k) (E -s x)).
exists (Lf Q K (subsets_with_p_elements (p -c k) (E -s x))); split;aw.
have k0p: forall y, inc y K <-> [/\ inc y EE, P y = x & inc (Q y) K0].
  move =>t; apply: (iff_trans (iim_fun_set1_P x fphi t)).
  rewrite - sp /phi; split.
    move => [tk]; aw=> pt.
    move: tk => /Zo_P [te [p1 p2 p3]];split => //; apply/Zo_P.
    by rewrite -p1;split => //; apply /setP_P; rewrite pt.
   move => [p1 p2 p3]; suff: inc t (Xk k) by move =>h;aw.
   by move/ Zo_P: p3 => [] /setP_P sa sb; apply/ Zo_P; rewrite p2 cx.
apply: lf_bijective.
    by move => t /k0p [_ _].
  move => u v /k0p [u1 pu _]/k0p [v1 pv _] sv.
  by rewrite - (setX_pair u1) - (setX_pair v1) pu pv sv.
move => y yk0; exists (J x y); aw; apply /k0p; aw;split => //.
apply: setXp_i => //; apply /setP_P => //.
by move /Zo_P: yk0 => [] /setP_P h _ t ty; move /setC_P: (h _ ty) => [].
Qed.

exercise 5.4 is in the main text
exercise 5.5

Definition even_card_sub I := Zo (powerset I) (fun z => even_int (cardinal z)).
Definition even_card0_sub I := even_card_sub I -s1 emptyset.
Definition odd_card_sub I := Zo (powerset I) (fun z => odd_int (cardinal z)).

Lemma odd_nonempty x: odd_int (cardinal x) -> nonempty x.
Proof.
move => h; apply /nonemptyP => h1.
by move: h; rewrite h1 cardinal_set0; move => [_]; move: even_zero.
Qed.

Section Exercise5_5.
Variables (E r: Set) (f: Set -> Set).
Hypothesis lr:lattice r.
Hypothesis dl: distributive_lattice1 r.
Hypothesis sr: E = substrate r.
Hypothesis card_f: forall x, inc x E -> cardinalp (f x).
Hypothesis hyp_f: forall x y, inc x E -> inc y E ->
    (f x) +c (f y) = (f (sup r x y)) +c f (inf r x y).

Definition Exercise5_5_conc I :=
   f (supremum r I) +c
       card_sumb (even_card0_sub I) (fun z => f (infimum r z))
    = card_sumb (odd_card_sub I) (fun z => f (infimum r z)).
Definition Exercise5_5_conc_aux I g :=
  f (supremum r (fun_image I g)) +c
       card_sumb (even_card0_sub I) (fun z => f (infimum r (fun_image z g)))
    = card_sumb (odd_card_sub I) (fun z => f (infimum r (fun_image z g))).

Lemma Exercise5_5_a1 n g (I:=Bintc n):
   inc n Bnat -> (forall i, inc i I -> inc (g i) E) ->
   Exercise5_5_conc_aux I g.
Proof.
move => nB;rewrite /I; clear I; move: n nB g.
move: (proj1 lr) => or.
apply: cardinal_c_induction.
   rewrite Bint_cc00 /Exercise5_5_conc_aux; move =>g H.
   rewrite /card_sumb; set f1 := Lg _ _; set f2 := Lg _ _.
   have pA: domain f1 = emptyset.
      rewrite /f1; bw; apply /set0_P => s /Zo_P [] /Zo_P [] /setP_P p1 p2.
      move /set1_P => se; move: p2.
      have ->: s = (singleton \0c).
         apply: set1_pr1; first by apply /nonemptyP.
         by move => z zs; apply /set1_P; apply: p1.
      by rewrite cardinal_set1; move: odd_one => [].
   have pB: inc (singleton \0c) (odd_card_sub (singleton \0c)).
     apply /Zo_P; split; first by apply /setP_P; fprops.
     rewrite cardinal_set1; apply: odd_one.
   have pC: domain f2 = singleton (singleton \0c).
     rewrite /f2; bw; apply: set1_pr => //.
     move => z /Zo_P [] /setP_P pa pb.
     apply: set1_pr1; last by move => s sz; apply /set1_P; apply: pa.
     by apply: odd_nonempty.
   move: (funI_set1 g \0c) => pD.
   have pE: inc (g \0c) (substrate r) by rewrite - sr; apply: H; fprops.
   rewrite pD (supremum_singleton or pE).
   have pF: (Vg f2 (singleton \0c)) = (f (g \0c)).
     by rewrite /f2; bw; rewrite pD (infimum_singleton or pE).
   have pG: cardinalp ( (Vg f2 (singleton \0c))).
     rewrite pF; apply:card_f; apply: H; fprops.
   rewrite (csum_trivial pA) (csum_trivial1 pC pG) pF; aw.
   by rewrite -pF.
move => n nB Hrec g gse.
move: (BS_succ nB) => snB.
set I1 := (Bintc (succ n)).
set I := (Bintc n); set z := succ n.
have [pa pb]: I +s1 z = I1 /\ ~ inc z I.
    rewrite /I /I1 (Bint_co_cc nB) (Bint_co_cc snB); apply: (Bint_pr4 snB).
rewrite / Exercise5_5_conc_aux - {1} pa funI_setU1.
have gxsr: forall i, inc i I1 -> inc (g i) (substrate r) by ue.
have gzr: inc (g z) (substrate r) by apply: gxsr; apply/ BintcP; fprops.
have sii': sub I I1 by rewrite -pa => t ti; fprops.
have fsI1: finite_set I1 by apply /BnatP; rewrite card_Bintc; fprops.
have fsI: finite_set I by apply /BnatP; rewrite card_Bintc.
pose g' x := inf r (g x) (g z).
have g'xsr: forall x, inc x I1 -> inc (g' x) (substrate r).
   move: (lattice_props lr) => [p1 [p2 _]].
   by move => x xI; apply: (p2 _ _ (gxsr _ xI) gzr).
have sr1: forall s, sub s I1 -> sub (fun_image s g) (substrate r).
  by move => s si t /funI_P [u us ->];apply: gxsr; apply: si.
have sr1': forall s, sub s I1 -> sub (fun_image s g') (substrate r).
  by move => s si t /funI_P [u us ->]; apply: g'xsr; apply: si.
have fs1: forall s, sub s I1 -> finite_set (fun_image s g).
   move => s si; apply: finite_fun_image; apply: (sub_finite_set si fsI1).
have fs1': forall s, sub s I1 -> finite_set (fun_image s g').
  move => s si; apply: finite_fun_image; apply: (sub_finite_set si fsI1).
have rec1:
   (inf r (supremum r (fun_image I g)) (g z)) = supremum r (fun_image I g').
  move: (proj1 (Exercise1_16a lr)) => h.
  move: (proj33 (Exercise1_16b lr)) => h1.
  move: (h1 (h dl)) => dl2; clear h h1.
  have dl2': forall a b, inc a E -> inc b E ->
    inf r (sup r a b) (g z) = sup r (inf r a (g z)) (inf r b (g z)).
    by rewrite sr;move => a b ae be; rewrite inf_C dl2 // inf_C (inf_C r b).
  suff: forall m, inc m Bnat -> m <=c n ->
      inf r (supremum r (fun_image (Bintc m) g)) (g z) =
        supremum r (fun_image (Bintc m) g').
      move => aux; apply: (aux n nB); fprops.
  apply: cardinal_c_induction.
    move => h; rewrite Bint_cc00 (funI_set1 g \0c) (funI_set1 g' \0c).
    have oi: inc \0c I1 by apply:sii';apply /(BintcP nB).
    have aa: inc (g \0c) (substrate r) by apply: gxsr.
    by rewrite supremum_singleton //supremum_singleton //; apply: g'xsr.
  move => m mB Hrec1 smn; move: (BS_succ mB) => smB.
  move: (proj1 (Bint_pr4 smB)).
  have sim: inc (succ m) I1 by apply: sii';apply /(BintcP nB).
  move: (card_le_succ mB) => lemsm; move: (card_leT lemsm smn) => le3.
  rewrite - (Bint_co_cc mB) - (Bint_co_cc smB); move => <-.
  have smI: sub (Bintc m) I1.
     move => t /(BintcP mB)=> tb; apply: sii'; apply /(BintcP nB).
     by apply: (card_leT tb le3).
  move: (sr1 _ smI) (sr1' _ smI)(fs1 _ smI) (fs1' _ smI) => sa sa' sc sc'.
  have sb: nonempty (fun_image (Bintc m) g).
     exists (g m); apply /funI_P; exists m => //; apply /BintcP; fprops.
  have sb': nonempty (fun_image (Bintc m) g').
     exists (g' m); apply /funI_P; exists m=> //; apply /BintcP; fprops.
  have sd: inc (g (succ m)) (substrate r) by apply: gxsr.
  have sd': inc (g' (succ m)) (substrate r) by apply: g'xsr.
  have se: inc (supremum r (fun_image (Bintc m) g)) (substrate r).
    by apply: (inc_supremum_substrate or sa); apply: lattice_finite_sup2.
  rewrite 2!funI_setU1 sup_setU1 // sup_setU1 // - (Hrec1 le3).
  by rewrite inf_C dl2 // inf_C (inf_C _ (g z)) -/(g' (succ m)).
have inf_gp: forall s, sub s I -> nonempty s ->
  infimum r (fun_image (s +s1 z) g) = (infimum r (fun_image s g')).
  move => s sa sb.
  have fs: finite_set s by apply: (sub_finite_set sa fsI).
  pose b s := infimum r (fun_image (s +s1 z) g) = infimum r (fun_image s g').
  pose a s := sub s I.
  have p1: forall u, a (singleton u) -> b (singleton u).
     move => u h; rewrite /b funI_setU1 2! funI_set1.
     have ui: inc u I1 by apply: sii';apply:h; fprops.
     rewrite (infimum_singleton or (g'xsr _ ui)) setU2_11 //.
  apply:(finite_set_induction2 p1 _ fs) => //.
  move => u v h neu; rewrite /a /b => ra.
  have vi1: inc v I1 by apply: sii'; apply: ra; fprops.
  have gvr: inc (g v) (substrate r) by apply (gxsr _ vi1).
  have gvr': inc (g' v) (substrate r) by apply (g'xsr _ vi1).
  have ->: ((u +s1 v) +s1 z) = (((u +s1 z) +s1 v) +s1 z).
    rewrite - 3!setU2_A (setU2_C _ (singleton z)).
    by rewrite (setU2_A (singleton z)) setU2_id.
  have au: a u by move => t tu;apply: ra; fprops.
  have ne1: nonempty (fun_image ((u +s1 z) +s1 v) g).
      exists (g v); apply: funI_i; fprops.
  have ne2: nonempty (fun_image (u +s1 z) g).
     exists (g z); apply: funI_i; fprops.
  have ne3: nonempty (fun_image u g').
    move:neu => [t tu]; exists (g' t); apply: funI_i; fprops.
  have aux1: sub ((u +s1 z) +s1 v) I1.
     move => t; case /setU1_P; last by move => ->.
     case /setU1_P; first by move => tu;apply: sii'; apply: au.
     move => ->; apply /(BintcP snB); fprops.
  have aux2: sub (u +s1 z) I1 by move => t ts; apply: aux1; apply/setU1_P; left.
  have aux3: sub u I1 by move => t ts; apply: sii'; apply: au.
  have aux4:inc (infimum r (fun_image (u +s1 z) g)) (substrate r).
    apply: (inc_infimum_substrate or (sr1 _ aux2)).
    apply: (lattice_finite_inf2 lr (fs1 _ aux2) (sr1 _ aux2) ne2).
  rewrite funI_setU1 (inf_setU1 lr (sr1 _ aux1) ne1 (fs1 _ aux1) gzr).
  rewrite funI_setU1 (inf_setU1 lr (sr1 _ aux2) ne2 (fs1 _ aux2) gvr).
  move: (lattice_props lr) => [_ [ _ [_ [_ [_ [idr _]]]]]].
  rewrite - (idr _ _ _ aux4 gvr gzr) -/(g' v) (h au neu).
  by rewrite funI_setU1 (inf_setU1 lr (sr1' _ aux3) ne3 (fs1' _ aux3) gvr').
have gIr: sub (fun_image I g) (substrate r) by apply: sr1.
have gIhs: has_supremum r (fun_image I g).
   apply: lattice_finite_sup2 => //; first by apply: finite_fun_image.
   exists (g n); apply : funI_i; apply/ BintcP; fprops.
move : (inc_supremum_substrate or gIr gIhs); rewrite - sr => sIE.
have pc: forall i, inc i I -> inc (g i) E.
   by rewrite sr => i iI; apply:gxsr; apply: sii'.
have pd: forall i, inc i I -> inc (g' i) E.
   by rewrite sr => i iI; apply:g'xsr; apply: sii'.
move: (Hrec _ pc) (Hrec _ pd);rewrite / Exercise5_5_conc_aux.
set seG := card_sumb _ _;set soG := card_sumb _ _.
set seG' := card_sumb _ _;set soG' := card_sumb _ _.
set seI := card_sumb _ _; set soI := card_sumb _ _.
set X := f _; set X':= f _; set X'' := f _.
move => r1 r2.
move: (gzr); rewrite - sr => gzE.
move: (hyp_f sIE gzE); rewrite rec1 - (supremum_setU1 lr gIr gIhs gzr).
move => auxx.
set ff := (fun t => t +s1 z).
clear gIr gIhs sIE pc pd gzE.
have ->: seI = seG +c soG'.
  set A := even_card0_sub I;
  set B := fun_image (odd_card_sub I) ff.
  have dAB: disjoint A B.
     apply: disjoint_pr => u /Zo_P [] /Zo_P [] /setP_P ra rb rc /funI_P.
     move => [t _ h]; case: pb; apply: ra; rewrite h /ff; fprops.
  have uAB: (even_card0_sub I1) = A \cup B.
     rewrite /B/ff;set_extens t.
       move => /Zo_P [] /Zo_P [] /setP_P ra rb te; apply /setU2_P.
       case: (inc_or_not z t) => zt.
         right; apply /funI_P; exists (t -s1 z);last by rewrite (setC1_K zt).
         apply /Zo_P; split.
           apply /setP_P => s /setC1_P [st sz];move: (ra _ st); rewrite -pa.
           by case /setU1_P.
         move: (card_succ_pr2 zt) => e1.
         split; first by apply:BS_nsucc; fprops;rewrite -e1; exact (proj1 rb).
         move => ec; move: (proj1 (even_odd_succ _) ec).
         rewrite- (card_succ_pr2 zt); by case.
       left; apply /Zo_P;split => //; apply /Zo_P;split => //; apply /setP_P.
       move => s st;move: (ra _ st); rewrite -pa;case /setU1_P => //.
       by move => sz; case: zt; rewrite - sz.
    case /setU2_P.
      move => /Zo_P [] /Zo_P [] /setP_P ra rb rc; apply/Zo_P;split => //.
      apply /Zo_P;split => //; apply /setP_P; rewrite -pa => s st.
      by apply /setU1_P; left; apply: ra.
    move /funI_P => [s ] /Zo_P [] /setP_P sa sb ->; apply/ Zo_P.
    split; last by apply /set1_P;apply /nonemptyP; exists z; fprops.
    apply /Zo_P; split; first by apply /setP_P; rewrite -pa; apply:setU2_S2.
    have zs: ~ inc z s by move => h; case: pb; apply: sa.
    rewrite (card_succ_pr zs); apply: (proj2 (even_odd_succ _) sb).
  move: (csumA_setU2 (fun z => f (infimum r (fun_image z g))) dAB).
  suff: card_sumb B (fun s => f (infimum r (fun_image s g))) = soG'.
      by move => ->; rewrite - uAB.
   rewrite /card_sumb.
   set f1 := Lf ff (odd_card_sub I) B.
   have pc: lf_axiom ff (odd_card_sub I) B.
     by move => s sa; apply: funI_i.
   have fb: bijection f1.
     apply: lf_bijective => //.
         move => u v /Zo_P [] /setP_P ui _ /Zo_P [] /setP_P vi _ sv.
         have nzu: ~ (inc z u) by move => b; apply: pb; apply: ui.
         have nzv: ~ (inc z v) by move => b; apply: pb; apply: vi.
         by rewrite - (setU1_K nzu) -/(ff _) sv (setU1_K nzv).
      by move => y /funI_P.
   have ff1: function f1 by fct_tac.
   set XX := Lg B _.
   have fgxx: fgraph XX by rewrite /XX; fprops.
   have tf1: target f1 = domain XX by rewrite /f1 /XX; aw; bw.
   rewrite (csum_Cn tf1 fb) /soG' /f1/card_sumb/composef; aw.
   apply: f_equal; apply: Lg_exten => s sa.
   move /Zo_P: (sa) => [] /setP_P sb sc.
   have rb: inc (s +s1 z) B by apply: pc.
   rewrite -/(Vf _ _); aw; rewrite /XX; bw; rewrite inf_gp //.
   by apply:odd_nonempty.
have ->: soI = soG +c seG' +c (f (g z)).
  rewrite /soI /soG /seG' -/I.
  set A := odd_card_sub I;
  set B := fun_image (even_card_sub I) ff.
  have dAB: disjoint A B.
     apply: disjoint_pr => u /Zo_P [] /setP_P ra rb /funI_P.
     move => [t _ h]; case: pb; apply: ra; rewrite h /ff; fprops.
  have uAB: (odd_card_sub I1) = A \cup B.
    set_extens t.
      move => /Zo_P []/setP_P ra rb; apply /setU2_P.
      case: (inc_or_not z t) => zt.
        right;apply /funI_P; exists (t -s1 z); last by rewrite /ff (setC1_K zt).
        apply /Zo_P; split.
          apply /setP_P => s /setC1_P [st sz];move: (ra _ st); rewrite -pa.
          by case /setU1_P.
        move: (card_succ_pr2 zt) => e1; ex_middle bad.
        have oi: odd_int (cardinal (t -s1 z)).
          split => //; apply:BS_nsucc; fprops;rewrite -e1; exact (proj1 rb).
        by move: (proj2 (even_odd_succ _) oi); rewrite - e1 => h; case: rb.
        left; apply /Zo_P;split => //; apply /setP_P.
      move => s st;move: (ra _ st); rewrite -pa;case /setU1_P => //.
      by move => sz; case: zt; rewrite - sz.
    case /setU2_P.
      move => /Zo_P [] /setP_P ra rb; apply/Zo_P;split => //; apply /setP_P.
      apply: (sub_trans ra sii').
    move /funI_P => [s] /Zo_P [] /setP_P sa sb ->; apply/ Zo_P.
    split;first by apply /setP_P; rewrite -pa; apply:setU2_S2.
    have zs: ~ inc z s by move => h; case: pb; apply: sa.
    rewrite (card_succ_pr zs); apply: (proj1 (even_odd_succ _) sb).
  move: (csumA_setU2 (fun z => f (infimum r (fun_image z g))) dAB).
  rewrite uAB => ->; rewrite - csumA; congr (_ +c _).
  rewrite /B.
  have ->: even_card_sub I = even_card0_sub I +s1 emptyset.
    set_extens t.
       move => h; apply /setU1_P;case: (emptyset_dichot t) => sd; first by right.
       by left; apply /Zo_P; split => //; move /set1_P; apply /nonemptyP.
    case /setU1_P; [ by move /Zo_P => [] | move => ->; apply /Zo_P].
    split; first by apply: setP_0i.
    by rewrite cardinal_set0; apply: even_zero.
  have di2: disjoint (fun_image (even_card0_sub I) ff)
     (singleton (singleton z)).
     apply: disjoint_pr => u /funI_P [v] /Zo_P [] /Zo_P [sa sb].
     move /set1_P => vne eq1 /set1_P uz; move: sb.
     have ->: v = singleton z.
        apply : set1_pr1; first by apply /nonemptyP.
        move => t tv; apply /set1_P; rewrite -uz eq1 /ff; fprops.
    rewrite cardinal_set1; exact (proj2 odd_one).
  rewrite /ff funI_setU1 set0_U2 (csumA_setU2 _ di2).
  rewrite {2} /card_sumb; set f2 := Lg _ _.
  have sid: domain f2 = (singleton (singleton z)) by rewrite /f2; bw.
  have eq1: Vg f2 (singleton z) = f (g z).
      rewrite /f2; bw;[ rewrite funI_set1 infimum_singleton // | fprops].
  have cf1: cardinalp (Vg f2 (singleton z)) by rewrite eq1; apply: card_f; ue.
  rewrite (csum_trivial1 sid cf1) eq1 csumC (csumC _ (f (g z))); apply:f_equal.
  set B1:= fun_image _ _.
  set f1 := Lf ff (even_card0_sub I) B1.
   have pc: lf_axiom ff (even_card0_sub I) B1.
     by move => s sa; apply: funI_i.
   have fb: bijection f1.
     apply: lf_bijective => //.
       move => u v /Zo_P [] /Zo_P [] /setP_P ui _ _.
       move => /Zo_P [] /Zo_P [] /setP_P vi _ _ sv.
       have nzu: ~ (inc z u) by move => b; apply: pb; apply: ui.
       have nzv: ~ (inc z v) by move => b; apply: pb; apply: vi.
       by rewrite - (setU1_K nzu) -/(ff _) sv (setU1_K nzv).
     by move => y /funI_P.
   have ff1: function f1 by fct_tac.
   rewrite /card_sumb; set XX := Lg B1 _.
   have fgxx: fgraph XX by rewrite /XX; fprops.
   have tf1: target f1 = domain XX by rewrite /f1 /XX; aw; bw.
   rewrite (csum_Cn tf1 fb) /soG' /f1/card_sumb/composef; aw.
   apply: f_equal; apply: Lg_exten => s sa.
   have rb: inc (s +s1 z) B1 by apply: pc.
   move /Zo_P: (sa) => [] /Zo_P [] /setP_P sb sc /set1_P sd.
   rewrite -/(Vf _ _); aw; rewrite /XX; bw; rewrite inf_gp //.
   by apply/nonemptyP.
rewrite -r2 -r1 (csumA seG) (csumC seG) 2!csumA.
rewrite -auxx -/X.
by rewrite - (csumA X) (csumC (f (g z))) csumA - csumA (csumC (f (g z))) csumA.
Qed.

Lemma Exercise5_5_a2 I: sub I E -> nonempty I -> finite_set I ->
   Exercise5_5_conc I.
Proof.
move => IE neI fsi.
set m := cardinal I.
have mB: inc m Bnat by rewrite /m; apply /BnatP.
have mz: m <> \0c.
   move => mz; move: neI;rewrite (cardinal_nonemptyset mz).
  by case /nonemptyP.
move: (card_Bintcp mB mz); move /card_eqP.
move: (cpred_pr mB mz) => [pa pb].
move => [G [bG sG tG]].
have fg: function G by fct_tac.
set K := Bintc (cpred m).
pose g x := Vf G x.
have aux: forall x, inc x K -> inc (g x) E.
  rewrite /K - sG; move => x xk; apply: IE; rewrite - tG /g; Wtac.
move: (Exercise5_5_a1 pa aux).
rewrite /Exercise5_5_conc_aux /Exercise5_5_conc.
have ->:(fun_image (Bintc (cpred m)) g) = I.
  rewrite - sG - tG;set_extens t.
     move /funI_P; rewrite /g; move => [z za ->]; Wtac.
   move => tg; move: (bij_surj bG tg) => [x xs <-].
   apply /funI_P; ex_tac.
rewrite /card_sumb; set s1 := card_sum _; set s2 := card_sum _.
set s3 := card_sum _; set s4 := card_sum _.
have ga: forall t, sub t (source G) -> sub (fun_image t g) I.
   move => t tg s /funI_P [z zt ->]; rewrite -tG /g; Wtac.
have gb: forall t, sub t (source G) ->
   cardinal t = cardinal (fun_image t g).
   move => t tg; apply /card_eqP.
   exists (Lf g t (fun_image t g)); split;aw; apply /lf_bijective.
       move=> s sa; apply /funI_P; ex_tac.
     move => u v ut vt sg; move: (tg _ ut) (tg _ vt) => ug vg.
     apply: (bij_inj bG ug vg sg).
   by move => y /funI_P.
have gc: forall u v, sub u (source G) -> sub v (source G) ->
   fun_image u g = fun_image v g -> u = v.
   move => u v us vs sf; set_extens t => tu.
     have : inc (g t) (fun_image v g) by rewrite - sf; apply: funI_i.
     move /funI_P => [z za zb].
     by rewrite (bij_inj bG (us _ tu)(vs _ za) zb).
   have : inc (g t) (fun_image u g) by rewrite sf; apply: funI_i.
   move /funI_P => [z za zb].
   by rewrite (bij_inj bG (vs _ tu) (us _ za) zb).
have gd: forall u, sub u I -> exists2 t, sub t (source G)& (fun_image t g) =u.
   move => u uI; exists (Zo (source G) (fun z => inc (g z) u)).
      by apply: Zo_S.
   set_extens t; first by move => /funI_P [z ] /Zo_P [] _ h ->.
   rewrite -tG in uI; move => tu; move: (bij_surj bG (uI _ tu)) => [x p1 p2].
   apply /funI_P; rewrite -p2 /g; exists x => //; apply: Zo_i => //; ue.
have ->: s1 = s3.
  rewrite /s1 /s3 - sG.
  set A1 := even_card0_sub _; set A2 := even_card0_sub _.
  set X := Lg A2 _.
  set h := Lf (fun z => (fun_image z g)) A1 A2.
  have pc: fgraph X by rewrite /X; fprops.
  have pd: target h = domain X by rewrite /h /X; bw; aw.
  have ta: lf_axiom (fun_image^~ g) A1 A2.
    move => t /Zo_P [] /Zo_P [] /setP_P t1 t2 /set1_P te.
    apply /Zo_P; split.
        apply /Zo_P; split; first by apply /setP_P; fprops.
        by rewrite - (gb _ t1).
    apply /set1_P => e; case: (emptyset_dichot t) => //; move => [s st].
    by empty_tac1 (g s); apply: funI_i.
  have pe: bijection h.
     apply: lf_bijective => //.
         move => u v /Zo_P [] /Zo_P [] /setP_P h1 _ _.
         by move => /Zo_P [] /Zo_P [] /setP_P h2 _ _; apply: gc.
       move => y /Zo_P [] /Zo_P [] /setP_P p1 p2 p3.
       move: (gd _ p1) => [t t1 t2]; exists t => //.
       apply /Zo_P; split.
          apply /Zo_P; split; first by apply/setP_P.
          by rewrite (gb _ t1) t2.
       move /set1_P => h1; case: p3; apply /set1_P; rewrite -t2.
       by rewrite h1; apply /set0_P => s /funI_P [z] /in_set0.
  have pf: function h by fct_tac.
  rewrite (csum_Cn pd pe) /composef {1} /h; aw; apply: f_equal.
  apply: Lg_exten => t tb; rewrite -/(Vf h t) /h; aw; rewrite /X; bw.
  by apply: ta.
have -> //: s2 = s4.
rewrite /s2 /s4 - sG.
set A1 := odd_card_sub _; set A2 := odd_card_sub _.
set X := Lg A2 _.
set h := Lf (fun z => (fun_image z g)) A1 A2.
have pc: fgraph X by rewrite /X; fprops.
have pd: target h = domain X by rewrite /h /X; bw; aw.
have ta: lf_axiom (fun_image^~ g) A1 A2.
   move => t /Zo_P [] /setP_P p1 p2; apply /Zo_P;rewrite - (gb _ p1);split=> //.
   apply /setP_P; fprops.
have pe: bijection h.
  apply lf_bijective => //.
     by move => u v /Zo_P [] /setP_P us _ /Zo_P [] /setP_P vs _; apply: gc.
   move => y /Zo_P [] /setP_P p1 p2; move: (gd _ p1) => [t t1 t2].
   exists t => //; apply /Zo_P; split; first by apply /setP_P.
   by rewrite (gb _ t1) t2.
have pf: function h by fct_tac.
rewrite (csum_Cn pd pe) /composef {1} /h; aw; apply: f_equal.
apply: Lg_exten => t tb; rewrite -/(Vf h t) /h; aw; rewrite /X; bw.
by apply: ta.
Qed.

End Exercise5_5.

Lemma setP_lattice_d1 A (r := subp_order A): distributive_lattice1 r.
Proof.
rewrite /distributive_lattice1 (proj2 (subp_osr A)) => x y z xA yA zA.
rewrite (proj1 (setP_lattice_pr xA yA)) (proj1 (setP_lattice_pr xA zA)).
rewrite (proj2 (setP_lattice_pr yA zA)).
move: (xA)(yA)(zA) => /setP_P xA' /setP_P yA' /setP_P zA'.
have yzA: inc (y \cap z) (powerset A).
  by apply /setP_P => t /setI2_P [ty _]; apply: yA'.
have xyA: inc (x \cup y) (powerset A).
  apply /setP_P => t /setU2_P; case => h; [by apply: xA' | by apply: yA'].
have xzA: inc (x \cup z) (powerset A).
  apply /setP_P => t /setU2_P; case => h; [by apply: xA' | by apply: zA'].
rewrite (proj1 (setP_lattice_pr xA yzA)) (proj2 (setP_lattice_pr xyA xzA)).
by rewrite set_UI2r.
Qed.

Lemma Exercise5_5_b1 x y:
  cardinal x +c cardinal y = cardinal (x \cup y) +c cardinal (x \cap y).
Proof.
have di: disjoint (x -s y) (x \cap y).
  by apply: disjoint_pr => u /setC_P [_ pa] /setI2_P [].
move: (csum2_pr5(set_I2Cr x y)); rewrite setU2Cr2 setU2_C => ->.
rewrite csum2_pr2b csum2_pr2b - csumA - (csum2_pr5 di).
by rewrite - setCC_r setC_v setC_0 csumC.
Qed.

Lemma Exercise5_5_b3 I (f: Set -> Set) : finite_set I ->
  cardinal (unionf I f) +c
       card_sumb (even_card0_sub I) (fun z => cardinal (intersectionf z f))
    = card_sumb (odd_card_sub I) (fun z => cardinal (intersectionf z f)).
Proof.
case: (emptyset_dichot I).
    move => ->; rewrite setUf_0 cardinal_set0.
    have ->: (even_card0_sub emptyset) = emptyset.
      by apply /set0_P => t /Zo_P [] /Zo_P [] /setP_P /sub_set0 h _ /set1_P.
    have ->: (odd_card_sub emptyset) = emptyset.
      apply /set0_P => t /Zo_P [] /setP_P/sub_set0 => te oi.
      by move: (odd_nonempty oi); move /nonemptyP; case.
    rewrite /card_sumb csum_trivial; aw; fprops; bw.
move => neI fse.
set m := cardinal I.
have mB: inc m Bnat by apply/BnatP.
have mz: m <> \0c.
   by move => h; move: (cardinal_nonemptyset h); apply /nonemptyP.
move: (card_Bintcp mB mz); move /card_eqP.
move: (cpred_pr mB mz); set n := cpred m; move=> [pa pb] [G [bG sG tG]].
have fg: function G by fct_tac.
pose g i := f (Vf G i).
set A := unionf I f; set E := powerset A;set r:= subp_order A.
have esr: E = substrate r by symmetry; apply: (proj2 (subp_osr A)).
have lr: lattice r by apply: setP_lattice.
move: (@setP_lattice_d1 A) => dl1.
have cf: forall x, inc x E -> cardinalp (cardinal x) by move => x xA; fprops.
have fp: forall x y, inc x E -> inc y E ->
     cardinal x +c cardinal y = cardinal (sup r x y) +c cardinal (inf r x y).
  move => x y xe ye; move: (setP_lattice_pr xe ye) => [-> ->].
  apply: Exercise5_5_b1.
have pc: (forall i, inc i (Bintc n) -> inc (g i) E).
  rewrite - sG => i iG; move: (Vf_target fg iG); rewrite tG => h.
  rewrite /g; apply /setP_P => s sa; apply /setUf_P; ex_tac.
move: (Exercise5_5_a1 lr dl1 esr cf fp pa pc).
rewrite /Exercise5_5_conc_aux.
set J := (Bintc n).
have pd: sub (fun_image J g) (powerset A).
   by move => t /funI_P [z za zb]; move: (pc _ za); rewrite zb.
move: (setU_sup pd) => h; rewrite - (supremum_pr2 (proj1 lr) h).
have pe: forall x, sub x J -> (fun_image x g) = fun_image (image_by_fun G x) f.
   rewrite /J - sG; move => x xJ.
    set_extens t => /funI_P [z za ->]; apply /funI_P.
      exists (Vf G z) => //; apply/ (Vf_image_P fg xJ); ex_tac.
    move /(Vf_image_P fg xJ): za => [u ux ->]; ex_tac.
have ->: (fun_image J g) = fun_image I f.
  by rewrite -tG - (surjective_pr0 (proj2 bG)) /image_of_fun sG; apply: pe.
have ->: union (fun_image I f) = A.
  set_extens t.
     move /setU_P => [z tz] /funI_P [u ui uv]; apply /setUf_P; ex_tac; ue.
  by move/setUf_P => [y yi tf]; apply /setU_P; exists (f y) => //; apply:funI_i.
have pf: forall x, inc x (powerset J) -> nonempty x ->
  (infimum r (fun_image x g)) = intersectionf (image_by_fun G x) f.
  move => x /setP_P qa qb.
  have ta: nonempty (fun_image x g) by apply: funI_setne.
  have tb: sub (fun_image x g) (powerset A).
     by move => t /funI_P [z zx ->]; apply: pc; apply: qa.
  move: (ta); rewrite {1} (pe _ qa) => ta1.
  have tc: nonempty (image_by_fun G x).
    apply /nonemptyP => ba; move: ta1; rewrite ba funI_set0.
    by case/nonemptyP.
  move: (setI_inf tb); Ytac0 => h1; rewrite - (infimum_pr2 (proj1 lr) h1).
  rewrite (pe _ qa); set_extens t.
      move /(setI_P ta1) => hi;apply: (setIf_i tc) => j ja.
      by apply: hi; apply: funI_i.
  move /(setIf_P _ tc) => hi;apply: (setI_i ta1) => j /funI_P [z za ->].
  by apply: hi.
have pg: forall s, sub s J -> sub (image_by_fun G s) I.
   by rewrite -tG; move => s sj; apply: fun_image_Starget1.
have ph: forall s, sub s J -> cardinal (image_by_fun G s) = cardinal s.
  move => s sj; symmetry;apply /card_eqP.
  apply equipotent_restriction1;[ ue | exact (proj1 bG)].
have pi: forall u v, sub u J -> sub v J ->
    image_by_fun G u = image_by_fun G v -> u = v.
  rewrite /J - sG; move => u v uJ vJ si; set_extens t => tu.
     have : inc (Vf G t) (image_by_fun G v).
       rewrite - si; apply /(Vf_image_P fg uJ); ex_tac.
     move /(Vf_image_P fg vJ) => [w wv] sv.
     by rewrite (bij_inj bG (uJ _ tu) (vJ _ wv) sv).
    have : inc (Vf G t) (image_by_fun G u).
       rewrite si; apply /(Vf_image_P fg vJ); ex_tac.
     move /(Vf_image_P fg uJ) => [w wv] sv.
     by rewrite (bij_inj bG (vJ _ tu)(uJ _ wv) sv).
have pj: forall y, inc y (powerset I) -> exists x,
    [/\ inc x (powerset J), image_by_fun G x = y & cardinal x = cardinal y].
  move => y /setP_P; rewrite - tG => yG; rewrite /J - sG.
  set x := Zo (source G) (fun z => inc (Vf G z) y).
  have xj: sub x (source G) by apply: Zo_S.
  have xj': sub x J by rewrite /J - sG.
  exists x; rewrite - (ph _ xj').
  have -> : image_by_fun G x = y.
   set_extens t.
     by move /(Vf_image_P fg xj) => [u] /Zo_P [_] hh ->.
    move => ty; apply /(Vf_image_P fg xj); move: (bij_surj bG (yG _ ty)).
    move => [a ag eq]; exists a => //; apply /Zo_P; rewrite eq;split => //.
  by split => //; apply /setP_P.
clear h.
rewrite /card_sumb; set x1 := card_sum _; set x2 := card_sum _.
set x3 := card_sum _; set x4 := card_sum _.
have [-> -> //]: x1 = x3 /\ x2 = x4; split.
   rewrite /x1 /x3.
   set A1 := even_card0_sub _; set A2 := even_card0_sub _.
   set X := Lg A2 _.
   set h := Lf (image_by_fun G) A1 A2.
   have qc: fgraph X by rewrite /X; fprops.
   have qd: target h = domain X by rewrite /X /h; bw; aw.
   have qb: lf_axiom (image_by_fun G) A1 A2.
     move => s /Zo_P [] /Zo_P [] /setP_P sj a1 /set1_P a2.
     move: (pg _ sj) (ph _ sj) => s1 s2.
     apply /Zo_P; split.
       by apply /Zo_P;rewrite s2;split => //; apply/setP_P.
     move /set1_P => s3; case: (emptyset_dichot s) => // [] [t ts].
     empty_tac1 (Vf G t); apply /Vf_image_P => //; [ ue | ex_tac].
  have qe: bijection h.
    apply: lf_bijective => //.
        move => u v /Zo_P [] /Zo_P [] /setP_P uJ _ _.
        by move => /Zo_P [] /Zo_P [] /setP_P vJ _ _; apply: pi.
    move => t /Zo_P [] /Zo_P [t1 t2] /set1_P t3.
    move: (pj _ t1) => [x [x5 x6 x7]].
    exists x => //; apply /Zo_P; split; first by apply /Zo_P; rewrite x7.
      by move /set1_P => xe; move: x6; rewrite xe fun_image_set0; apply: nesym.
  have qf: function h by fct_tac.
  rewrite (csum_Cn qd qe) /composef /h; aw; apply: f_equal.
  apply: Lg_exten => s sa; move: (qb _ sa) => qg.
  move /Zo_P: (sa) => [] /Zo_P [sb sc] /set1_P sd.
  by rewrite -/(Vf _ _) /X; aw; bw; rewrite pf //; apply /nonemptyP.
rewrite /x2 /x4.
set A1 := odd_card_sub _; set A2 := odd_card_sub _.
set X := Lg A2 _.
set h := Lf (image_by_fun G) A1 A2.
have qc: fgraph X by rewrite /X; fprops.
have qd: target h = domain X by rewrite /X /h; bw; aw.
have qb: lf_axiom (image_by_fun G) A1 A2.
  move => s /Zo_P [] /setP_P sj a1; move: (pg _ sj) (ph _ sj) => s1 s2.
  by apply /Zo_P; rewrite s2;split => //; apply/setP_P.
have qe: bijection h.
  apply /lf_bijective => //.
    by move => u v /Zo_P [] /setP_P uJ _ /Zo_P [] /setP_P vJ _; apply: pi.
  move => y /Zo_P [t1 t2]; move: (pj _ t1) => [x [x5 x6 x7]].
  exists x => //; apply /Zo_P; rewrite x7;split => //.
have qf: function h by fct_tac.
rewrite (csum_Cn qd qe) /composef /h; aw; apply: f_equal.
apply: Lg_exten => s sa; move: (qb _ sa) => qg.
move /Zo_P: (sa) => [sc sd]; move: (odd_nonempty sd) => nes.
by rewrite -/(Vf _ _) /X; aw; bw; rewrite pf.
Qed.

Lemma Exercise5_5_b2 I: finite_set I ->
  cardinal (union I) +c
       card_sumb (even_card0_sub I) (fun z => cardinal (intersection z))
    = card_sumb (odd_card_sub I) (fun z => cardinal (intersection z)).
Proof.
move => h.
move: (Exercise5_5_b3 id h).
rewrite - setU_prop /card_sumb; set s1 := Lg _ _; set s2 := Lg _ _.
set s3 := Lg _ _; set s4 := Lg _ _.
have ->: s1 = s3 by apply: Lg_exten => t; rewrite setI_prop.
have -> //: s2 = s4 by apply: Lg_exten => t; rewrite setI_prop.
Qed.


Lemma Exercise5_6 n h (I := (Bintc h))
    (f := fun i => (binom h i) *c (binom (n +c h -c i) h)):
   inc n Bnat -> inc h Bnat ->
   card_sumb (Zo I even_int) f = \1c +c card_sumb (Zo I odd_int) f.
Proof.
move => nB hB; rename f into f'.
set A := (Zo I even_int).
have za: inc \0c A by apply Zo_i; [apply/BintcP; fprops | apply: even_zero].
have nzc: ~ inc \0c (A -s1 \0c) by move /setC1_P => [].
have fc0: cardinalp (f' \0c) by rewrite /f'; fprops.
have nhB: inc (n +c h) Bnat by fprops.
rewrite - (setC1_K za) (csumA_setU1 _ nzc) {2} /f' (binom0 hB) (cdiff_n_0 nhB).
set J := (Bint h).
pose Ak k := graphs_sum_le J k.
pose Bk i := Zo (Ak n) (fun z => Vg z i <> \0c).
have cJ: cardinal J = h by rewrite card_Bint.
have fsj: finite_set J by apply /BnatP; rewrite cJ.
have r1: forall z (k:= cardinal z), sub z J -> nonempty z ->
    cardinal (intersectionf z Bk) = binom ((n +c h) -c k) h.
   move => z k zj nez.
   have ->: (intersectionf z Bk) =
      Zo (Ak n) (fun f => forall i, inc i z -> Vg f i <> \0c).
     set_extens v.
        move /(setIf_P _ nez) => p1.
        move: (p1 _ (rep_i nez)) => /Zo_P [p2 p3]; apply /Zo_P;split => //.
        by move => i iz; move: (p1 _ iz) => /Zo_P [_].
     move =>/Zo_P [p1 p2]; apply/(setIf_P _ nez) => j jz; apply /Zo_P;fprops.
  move: (sub_smaller zj); rewrite cJ - /k => kn.
  move: (BS_le_int kn hB) => kB.
  set Z := Zo _ _.
  pose ga f:= Lg J (fun i => Yo (inc i z) (cpred (Vg f i)) (Vg f i)).
  pose gb f:= Lg J (fun i => Yo (inc i z) (succ (Vg f i)) (Vg f i)).
  have pb : forall f, fgraph f -> allf f cardinalp -> domain f = J ->
       (forall i, inc i J -> inc (Vg f i) Bnat) ->
       (forall i, inc i z -> Vg f i <> \0c) ->
       card_sum (ga f) +c k = card_sum f.
    move => f p1 p2 p0 p3 p4.
    pose f2 := (graph (char_fun z J)).
    have q2: forall i, inc i J -> Vg (ga f) i +c Vg f2 i = Vg f i.
      move => i iJ; rewrite /ga /f2 -/(Vf _ i); bw; Ytac zi.
        rewrite (char_fun_V_a zj zi).
        move: (cpred_pr (p3 _ iJ) (p4 _ zi)) => [h1 h2].
        by rewrite -(Bsucc_rw h1) - h2.
      have aux: inc i (J -s z) by apply /setC_P.
      by rewrite char_fun_V_b //; aw; apply: p2; rewrite p0.
    set f3 := (Lg J (Vg f2)).
    have s1: fgraph f3 by rewrite /f3; by fprops.
    have s2: sub z (domain f3) by rewrite /f3; bw.
    have s3: forall i, inc i ((domain f3) -s z) -> Vg f3 i = \0c.
      rewrite /f3/f2; bw => i ij; bw; last by move /setC_P: ij => [].
      by rewrite -/(Vf _ _) (char_fun_V_b zj ij).
    have s4: Lg z (Vg f3) = cst_graph z \1c.
       apply : Lg_exten => i iz; move: (zj _ iz) => iJ; rewrite /f3; bw.
      exact (char_fun_V_a zj iz).
    move: (csum_zero_unit s2 s3); rewrite /card_sumb s4 csum_of_ones -/k => s5.
    move: (sum_of_sums (Vg (ga f)) (Vg f2) J); rewrite /card_sumb.
    have r1 : domain (ga f) = J by rewrite /ga; bw.
    have r3 : fgraph (ga f) by rewrite /ga; fprops.
    rewrite -{1} r1 (Lg_recovers r3) s5 => ->; apply: f_equal.
    apply: fgraph_exten; fprops; bw; first by symmetry.
    move => i ij /=; bw; exact (q2 _ ij).
  have pa: forall f, inc f Z ->
      [/\ k <=c n, inc (ga f) (Ak (n -c k)) & gb (ga f) = f].
    move => f /Zo_P [p0 p5].
    move /(setof_suml_auxP _ nB): (p0) => [p1 p2 p3 p4].
    have q1: forall i, inc i J -> inc (Vg f i) Bnat.
      move /funI_P: p0 => [f1] /Zo_P [] /fun_set_P [q0 q1 q2] q3 ->.
      rewrite - q1 => i isf; move: (Vf_target q0 isf); rewrite q2 => q4.
      exact (Bint_S q4).
    move: (pb _ p3 p4 p1 q1 p5) => q3.
    have r1 : domain (ga f) = J by rewrite /ga; bw.
    have q4: k <=c card_sum f.
      by rewrite - q3; rewrite csumC;apply:csum_M0le; fprops.
    have q5: k <=c n by apply: (card_leT q4 p2).
    move: (BS_diff k nB) =>q6.
    have q7: card_sum (ga f) <=c n -c k.
       have q4': card_sum (ga f) <=c card_sum f.
         by rewrite - q3; apply:csum_M0le; fprops.
       move: (BS_le_int (card_leT q4' p2) nB) => h1.
       move: p2; rewrite -q3 - {1} (cdiff_pr q5) csumC => s1.
       exact (csum_le_simplifiable kB h1 q6 s1).
    have r3 : fgraph (ga f) by rewrite /ga; fprops.
    have r4 : allf (ga f) cardinalp.
      red; rewrite /ga; bw => i ij; bw; move: (q1 _ ij) => ha; Ytac iz; fprops.
      move: (cpred_pr ha (p5 _ iz)) => [h1 h2]; fprops.
    have q8: inc (ga f) (Ak (n -c k)).
      apply (setof_suml_auxP _ q6); split => //; split => //.
    split => //; rewrite /gb;apply: fgraph_exten; [ fprops | done | by bw | bw].
    move => i iJ /=; bw; rewrite /ga; Ytac iz; bw; Ytac0; last by exact.
    by rewrite - (proj2 (cpred_pr (q1 _ iJ) (p5 _ iz))).
  case: (card_le_to_el (CS_Bnat kB) (CS_Bnat nB)) => aux; last first.
     have ->: Z = emptyset.
        apply /set0_P => t tz; move: (proj31 (pa _ tz)) => h1; co_tac.
     rewrite cardinal_set0 - (cdiff_pr kn); set i := h -c k.
     move: (BS_diff k hB) => iB.
     rewrite (csumC k) csumA (cdiff_pr1 (BS_sum nB iB) kB) (csumC i).
    by rewrite binom_bad //; fprops; apply: csum_Mlteq.
  have ->: (n +c h) -c k = (n -c k) +c h.
     rewrite -{1} (cdiff_pr aux) csumC (csumC k) (csumC _ h) csumA cdiff_pr1 //.
     fprops.
  move: (proj2 (set_of_functions_sum_pr (BS_diff k nB) hB)).
  rewrite (binom_symmetric2 (BS_diff k nB) hB) -/(Ak _) => <-.
  apply /card_eqP; exists (Lf ga Z (Ak (n -c k))); split;aw.
  move: (BS_diff k nB) =>q6.
  apply: lf_bijective.
      by move => f fa; move: (pa _ fa)=> [_ ok _].
   move => u v uz vz sw; move: (pa _ uz) (pa _ vz) => [_ _ e1][_ _ e2].
   by rewrite - e1 -e2 sw.
   move =>y yf.
    move /(setof_suml_auxP _ q6): (yf) => [p1 p2 p3 p4].
    have q1: forall i : Set, inc i J -> inc (Vg y i) Bnat.
      move /funI_P: yf => [f1] /Zo_P [] /fun_set_P [q0 q1 q2] q3 ->.
      rewrite - q1 => i isf; move: (Vf_target q0 isf); rewrite q2 => q4.
      exact (Bint_S q4).
    have q5:forall i, inc i z -> Vg (gb y)i <> \0c.
      move => i iz; move: (zj _ iz) => iJ;rewrite /gb; bw; Ytac0.
      apply: succ_nz.
    have q4: ga (gb y) = y.
      move: yf; rewrite /Ak; move /(setof_suml_auxP J q6)=> [s1 s2 s3 s4].
      rewrite /ga; apply: fgraph_exten; fprops; bw => //.
      move => i iJ /=; bw; rewrite /gb; bw; Ytac zi; Ytac0; last by exact.
      by apply: cpred_pr2; apply: q1.
    have q2: fgraph (gb y) by rewrite /gb; fprops.
    have dgb: (domain (gb y)) = J by rewrite /gb; bw.
    have q7: forall i, inc i J -> inc (Vg (gb y) i) Bnat.
      move => i ij; move: (q1 _ ij) => ha;rewrite /gb; bw; Ytac zi; fprops.
    have q3: (allf (gb y) cardinalp).
      move => i; rewrite dgb => ij; rewrite /gb; bw; Ytac zi; fprops.
  exists (gb y) => //.
  apply /Zo_P;split => //; apply /(setof_suml_auxP _ nB) => //;split => //.
    move: (pb _ q2 q3 dgb q7 q5); rewrite q4; move => <-.
    rewrite - (cdiff_pr aux) csumC; apply: csum_Mlele => //; fprops.
move: (Exercise5_5_b3 Bk fsj).
set s1 := card_sumb _ _;set s2 := card_sumb _ _.
set s3 := card_sumb _ _; set s4 := card_sumb _ _.
set fct0:= cst_graph J \0c.
have fct0_ok: inc fct0 (Ak n).
   apply /setof_suml_auxP => //; rewrite /fct0; bw;split => //.
      rewrite csum_of_same; aw; rewrite cprodC cprod0r; fprops.
     fprops.
   hnf; bw; move => t tj; bw; fprops.
have ue: (unionf J Bk) = Ak n -s1 fct0.
   set_extens t.
     move => /setUf_P [z tz] /Zo_P [ta tb].
     apply /setC1_P; split => //; dneg eq2; rewrite eq2 /fct0; bw.
   move => /setC1_P [t1 t2]; apply /setUf_P.
   move /(setof_suml_auxP _ nB): (t1) => [t4 _ t5 t6].
   suff: (exists2 i, inc i J & Vg t i <> \0c).
     move => [i ij t3]; ex_tac; apply /Zo_P;split => //.
   ex_middle bad; case: t2; rewrite /fct0.
   apply: fgraph_exten => //; bw; fprops.
   rewrite t4; move => s st /=; bw; ex_middle ok; case: bad; ex_tac.
suff [ -> ->]: s1 = s3 /\ s2 = s4.
  have cb1: cardinalp (binom (n +c h) h) by apply: CS_Bnat; apply:BS_binom.
  move: (card_succ_pr2 fct0_ok); rewrite -ue card_succ_pr4; last by fprops.
  rewrite csumC (cprod1l cb1) (binom_symmetric2 nB hB).
  rewrite (proj2 (set_of_functions_sum_pr nB hB)) => -> <-.
  by rewrite csumC - csumA.
split.
   have ->: s1 = card_sumb (even_card0_sub J)
        (fun z => binom ((n +c h) -c (cardinal z)) h).
     rewrite /s1/card_sumb; apply: f_equal; apply: Lg_exten => t.
     move => /Zo_P [] /Zo_P [] /setP_P ta tb /set1_P tc; apply: r1 => //.
     by apply /nonemptyP.
   set X := (even_card0_sub J); set F := (A -s1 \0c).
   have pa: (forall x : Set, inc x X -> inc (cardinal x) F).
      move => x /Zo_P [] /Zo_P [] /setP_P wJ pa /set1_P pb; apply /Zo_P; split.
         apply /Zo_P;split => //;apply /(BintcP hB).
         rewrite - cJ; apply:(sub_smaller wJ).
         move /set1_P=> ha; case: pb; exact: (cardinal_nonemptyset ha).
   rewrite (card_partition_induced1 _ pa).
   rewrite /s3 /card_sumb; apply: f_equal; apply: Lg_exten => i iF.
   rewrite /f'; set Y:= Zo _ _.
   transitivity (card_sum (cst_graph Y (binom ((n +c h) -c i) h))).
     rewrite /cst_graph; apply: f_equal; apply: fgraph_exten; fprops; bw.
     by move => j jY /=;bw; move /Zo_P: jY => [_ ->].
   rewrite csum_of_same cprodC; apply: cprod2_pr2 => //.
   move /Zo_P: iF => [] /Zo_P [i1 i2] /set1_P i3; move: (Bint_S i1) => i4.
   have ->: Y = subsets_with_p_elements i J.
     set_extens t.
       by move => /Zo_P [] /Zo_P [] /Zo_P [t1 t2] t3 t4; apply /Zo_P.
    move => /Zo_P [t1 t2]; apply/Zo_P;split => //; apply /Zo_P;split => //.
      by apply /Zo_P;split => //; rewrite t2.
    by move => /set1_P => te; case: i3; rewrite - t2 te cardinal_set0.
    rewrite - (subsets_with_p_elements_pr hB i4 cJ).
    by rewrite card_card //; apply: CS_Bnat; apply: BS_binom.
have ->: s2 = card_sumb (odd_card_sub J)
        (fun z => binom ((n +c h) -c (cardinal z)) h).
  rewrite /s2/card_sumb; apply: f_equal; apply: Lg_exten => t.
  move => /Zo_P [] /setP_P ta tb; apply: r1 => //.
  by apply: odd_nonempty.
set X := (odd_card_sub J); set F := (Zo I odd_int).
have pa: (forall x : Set, inc x X -> inc (cardinal x) F).
  move => x /Zo_P [] /setP_P pa pb; apply /Zo_P;split => //.
  apply /(BintcP hB); rewrite - cJ; apply:(sub_smaller pa).
rewrite (card_partition_induced1 _ pa).
rewrite /s4 /card_sumb; apply: f_equal; apply: Lg_exten => i iF.
rewrite /f'; set Y:= Zo _ _.
transitivity (card_sum (cst_graph Y (binom ((n +c h) -c i) h))).
   rewrite /cst_graph; apply: f_equal; apply: fgraph_exten; fprops; bw.
    by move => j jY /=;bw; move /Zo_P: jY => [_ ->].
rewrite csum_of_same cprodC; apply: cprod2_pr2 => //.
move /Zo_P: iF => [i1 i2]; move: (Bint_S i1) => i3.
have ->: Y = subsets_with_p_elements i J.
    set_extens t.
       move => /Zo_P [] /Zo_P [t1 t2] t3; apply /Zo_P;split => //.
   move => /Zo_P [t1 t2]; apply/Zo_P;split => //.
   by apply /Zo_P;split => //; rewrite t2.
rewrite - (subsets_with_p_elements_pr hB i3 cJ).
by rewrite card_card //; apply: CS_Bnat; apply: BS_binom.
Qed.


Definition surjections E F :=
  Zo (functions E F)(surjection).

Definition nbsurj n p :=
   cardinal(surjections (Bint n) (Bint p)).

Lemma nbsurj_pr E F:
  finite_set E -> finite_set F ->
  cardinal (surjections E F) = nbsurj (cardinal E) (cardinal F).
Proof.
move => pa pb.
set n := (cardinal E); set m := (cardinal F).
have nB: inc n Bnat by apply /BnatP.
have mB: inc m Bnat by apply /BnatP.
move: (card_Bint nB)(card_Bint mB).
move/card_eqP => [g [fg sg tg]].
move/card_eqP => [h [fh sh th]].
apply/card_eqP.
set s:= (surjections E F).
set t := surjections _ _.
move: (inverse_bij_fb fh) => bih.
set j := (fun f => (inverse_fun h) \co f \co g).
have pc: forall f, inc f s ->
  (inverse_fun h \coP f)/\ (inverse_fun h \co f) \coP g.
  move => f /Zo_P [] /fun_set_P [ff sf tf] sjf.
  have s1: inverse_fun h \coP f by split => //; aw; try fct_tac; ue.
  split => //; split => //; aw; try ue; try fct_tac.
exists (Lf (fun f => (inverse_fun h) \co f \co g) s t).
split;aw;apply: lf_bijective.
    move => f fp; move: (pc _ fp)=> [s1 s2]; apply/ Zo_P;split => //.
      apply /fun_set_P;red;aw;split => //; fct_tac.
      move/ Zo_hi: fp => sjf.
    move: (compose_fs sjf (proj2 bih) s1) => s3; apply:compose_fs => //.
    exact (proj2 fg).
  move => u v us vs; move: (pc _ us) (pc _ vs)=> [s1 s2][s3 s4] s5.
  move: (compf_regl fg s2 s4 s5) => s6.
  by move: (compf_regr bih s1 s3 s6).
move => y /Zo_P []/fun_set_P [fy sy ty] sjy.
set f := (h \co (y \co inverse_fun g)).
move: (inverse_bij_fb fg) => big.
have s1: (y \coP inverse_fun g) by split => //;aw; try fct_tac; ue.
have s2: h \coP (y \co inverse_fun g) by split => //; aw; try ue; try fct_tac.
have fs: inc f s.
  apply/ Zo_P; split.
    by rewrite /f;apply /fun_set_P;split => //; aw;try fct_tac.
  move: (compose_fs (proj2 big) sjy s1) => s3; apply:compose_fs => //.
  exact (proj2 fh).
exists f => //; rewrite /f (compfA (composable_inv_f fh) s2).
have pd: (source h) = target (y \co inverse_fun g) by aw; ue.
  rewrite (bij_left_inverse fh) pd (compf_id_l (proj32 s2)).
rewrite - (compfA s1 (composable_inv_f fg)) (bij_left_inverse fg) sg - sy.
by symmetry;apply (compf_id_r).
Qed.

Lemma nbsurj_rec n p: inc n Bnat -> inc p Bnat ->
  nbsurj (succ n)(succ p) =
   (succ p) *c ( nbsurj n p +c nbsurj n (succ p)).
Proof.
move => nB pB; rewrite {1} /nbsurj csumC.
move: (BS_succ pB) => spB.
set I := (Bint (succ n)); set J:= (Bint (succ p)).
set I' := Bint n.
set E := (surjections I J).
pose phi := Lf (fun f => Vf f n) E J.
have sphi: E = source phi by rewrite /phi; aw.
have pa: succ p = cardinal (target phi).
  by rewrite /phi; aw; rewrite (card_Bint spB).
rewrite {1} pa sphi; clear pa.
have lfa: lf_axiom (Vf ^~n) E J.
  move => f /Zo_P [] /fun_set_P [pa pb pc] _.
  by Wtac; rewrite pb; apply:Bint_si.
have fphi: function phi by apply: lf_function.
apply:(shepherd_principle fphi).
rewrite {1} /phi; aw; move => x xJ.
set F := inv_image_by_fun phi (singleton x).
have fp: forall f, inc f F <-> inc f (surjections I J) /\ x = Vf f n.
  move => f; split.
    move /(iim_fun_set1_P _ fphi) => []; rewrite - sphi => fe;rewrite{1}/phi.
    by aw; move => pa.
  move => [pa pb]; apply /(iim_fun_set1_P _ fphi).
  split => //;[ ue | rewrite /phi;aw].
pose sfx f := exists2 y, inc y I' & Vf f y = x.
have ii': sub I' I by apply: Bint_M.
set A1 := Zo F sfx.
have <-: cardinal A1 = nbsurj n (succ p).
  apply /card_eqP.
  exists (Lf (restriction^~ I' ) A1 (surjections I' J)); split;aw.
  apply /lf_bijective.
      move => f /Zo_P [] /fp [] /Zo_P [] /fun_set_P [ff sf tf] sjf fn sff.
      have si: sub I' (source f) by rewrite sf.
      move: (restriction_prop ff si); rewrite tf => fp'.
      apply /Zo_P; split; first by apply /fun_set_P.
      move: fp' => [sa sb sc]; split; first by exact.
      rewrite sc sb - tf=> y ytf; move: (proj2 sjf _ ytf) => [a asf va].
      move: asf; rewrite sf; move /(BintsP nB) => lean.
      case: (equal_or_not a n) => lan.
        move: sff => [b ba bb]; rewrite - va lan - fn - bb; ex_tac.
        rewrite restriction_V //.
      have aI: inc a I' by apply /(BintP nB).
      by exists a => //; rewrite restriction_V.
    move => f g /Zo_P [] /fp [] /Zo_P [] /fun_set_P [ff sf tf] sjf fn sff.
    move => /Zo_P [] /fp [] /Zo_P [] /fun_set_P [fg sg tg] sjg gn sfg sr.
    apply: function_exten => //; (try ue); move => i isf /=.
    move: isf; rewrite sf; move /(BintsP nB) => lein.
    case: (equal_or_not i n) => lin; first by rewrite lin - fn gn.
    have iI: inc i I' by apply /(BintP nB); split.
    have si: sub I' (source f) by rewrite sf.
    have sj: sub I' (source g) by rewrite sg - sf.
    move: (f_equal (Vf^~ i) sr); rewrite restriction_V // restriction_V //.
  move => y /Zo_P [] /fun_set_P [fy sy ty] sjy.
  move: (Bint_pr4 nB); rewrite -/I -/I' - sy; move => [ci pa].
  move:(extension_fs x fy pa sjy) => sjf.
  have pb: sub I' (source (extension y n x)).
       by rewrite /extension sy; aw; fprops.
  move:(proj1 sjf) => fjf.
  have si: source (extension y n x) = I by rewrite /extension; aw.
  have ti: target (extension y n x) = J.
    rewrite /extension ty; aw; rewrite setU1_eq //.
  have fx: Vf (extension y n x) n = x by rewrite extension_Vf_out.
  have re : (restriction (extension y n x) I') = y.
  move: (restriction_prop fjf pb) => [pc pd pe].
  apply : function_exten => //; rewrite ? pd ?pe ? ti//.
  move => i ii /=;rewrite restriction_V //.
    by rewrite extension_Vf_in // sy.
  have aux: sfx (extension y n x).
     rewrite -ty in xJ; move: (proj2 sjy _ xJ) => [s sa sb].
     exists s; [ ue | rewrite extension_Vf_in //].
   exists (extension y n x);last by ue.
  by apply:Zo_i=> //;apply /fp; split => //; apply:Zo_i=> //; apply /fun_set_P.
have sa1: sub A1 F by apply: Zo_S.
rewrite (cardinal_setC2 sa1) csum2_pr2a - csum2_pr2b; congr (_ +c _).
have pa: n = cardinal I' by rewrite (card_Bint nB).
have fs1: finite_set I' by red; rewrite -pa;apply /BnatP.
have pb: p = cardinal (J -s1 x).
  move: (card_succ_pr2 xJ); rewrite (card_Bint spB) => h.
  apply: succ_injective1 => //; fprops.
have fs2: finite_set (J -s1 x) by red; rewrite -pb;apply /BnatP.
rewrite pa pb - (nbsurj_pr fs1 fs2).
apply /card_eqP.
have pc: forall f, inc f (F -s A1) -> restriction2_axioms f I' (J -s1 x).
  move => f /setC_P [fF fp1].
  move: (fF) => /fp [] /Zo_P[] /fun_set_P [ff sf tf] sjf fn.
  have aux: sub I' (source f) by ue.
  red; rewrite sf tf; split => //; try apply: sub_setC.
  move => i /(Vf_image_P ff aux) [u ui ->]; apply /setC1_P; split.
      rewrite -tf; Wtac.
  by dneg fa1; apply /Zo_P;split => //; exists u.
exists (Lf (fun z => restriction2 z I' (J -s1 x))
  (F -s A1) (surjections I' (J -s1 x))); split;aw.
apply /lf_bijective.
    move => f fa /=; move: (pc _ fa) => a1.
    move: (restriction2_prop a1) => a2.
    move: fa => /Zo_P [] /fp [] /Zo_P [] /fun_set_P [ff sf tf] sjf fn sff.
    apply /Zo_P;split; first by apply /fun_set_P.
    move: a2 => [a3 a4 a5]; split; first by exact.
    rewrite a4 a5 - {1} tf=> y /setC1_P [ytf xx].
    move: (proj2 sjf _ ytf) => [a asf va].
    move: asf; rewrite sf; move /(BintsP nB) => lean.
    case: (equal_or_not a n) => lan; first by case: xx; rewrite fn - va lan.
    have aI: inc a I' by apply /(BintP nB); split.
    by exists a => //; rewrite restriction2_V.
  move => f g fa fb sr.
  move: (pc _ fa) (pc _ fb) => a1 a2.
  move: fa => /setC_P [] /fp [] /Zo_P [] /fun_set_P [ff sf tf] _ fv _.
  move: fb => /setC_P [] /fp [] /Zo_P [] /fun_set_P [fg sg tg] _ gv _.
  apply: function_exten => //; (try ue); move => i isf /=.
  move: isf; rewrite sf; move /(BintsP nB) => lein.
  case: (equal_or_not i n) => lin; first by rewrite lin - fv gv.
  have iI: inc i I' by apply /(BintP nB); split.
  move: (f_equal (Vf^~ i) sr); rewrite restriction2_V // restriction2_V //.
move => y /Zo_P [] /fun_set_P [fy sy ty] sjy.
move: (Bint_pr4 nB); rewrite -/I -/I' - sy; move => [ci pd].
move:(extension_fs x fy pd sjy) => sjf.
have pe: sub I' (source (extension y n x)).
  by rewrite /extension sy; aw; fprops.
move:(proj1 sjf) => fjf.
have si: source (extension y n x) = I by rewrite /extension; aw.
have ti: target (extension y n x) = J.
by rewrite /extension ty; aw; apply:setC1_K.
have fx: Vf (extension y n x) n = x by rewrite extension_Vf_out.
move: (extension_restr x fy pd); rewrite ty => pf.
exists (extension y n x) => //; apply/setC_P; split.
  by apply /fp; split => //; apply /Zo_P; split => //; apply /fun_set_P.
  move /Zo_P => [sa [z]]; rewrite - sy => sb;rewrite extension_Vf_in // => pg.
  by move: (Vf_target fy sb); rewrite pg ty => /setC1_P [].
Qed.

Definition partitionsx E p :=
  Zo (powerset (powerset E)) (fun z => partition_s z E /\ cardinal z = p).

Definition nbpart n p :=
  cardinal(partitionsx (Bint n) p).

Lemma nbpart_pr1 E F g p
    (f := fun_image ^~ (image_by_fun g)):
    bijection g -> source g = E -> target g = F ->
    bijection (Lf f (partitionsx E p)(partitionsx F p)).
Proof.
rewrite /f; clear f; move: E F g.
have aux: forall E F g (f := fun_image ^~ (image_by_fun g))
     (f' := fun_image ^~ (image_by_fun (inverse_fun g))),
     bijection g -> source g = E -> target g = F ->
    forall x, inc x (partitionsx E p) -> f' (f x) = x.
  move => E F g f f' bg sg tg x.
  move => /Zo_P [pa [pb pc]]; rewrite /f/f'.
  have aux: forall t, inc t x -> sub t (source g).
    by move => t tx; rewrite sg; apply /setP_P; move /setP_P: pa; apply.
  set_extens t.
    move /funI_P => [z] /funI_P [w wx ->].
    by rewrite - (inverse_direct_image_inj (proj1 bg) (aux _ wx)); move ->.
  move => tx; apply /funI_P.
  rewrite (inverse_direct_image_inj (proj1 bg) (aux _ tx));
  exists (image_by_fun g t) => //; apply /funI_P; ex_tac.
have aux2: forall E F g (f := fun_image ^~ (image_by_fun g)),
    bijection g -> source g = E -> target g = F ->
    lf_axiom f (partitionsx E p)(partitionsx F p).
  move => E F g f big sg tg; move: (proj1 (proj1 big)) => fg.
  rewrite /f;move => pr /Zo_P [p1 [p2 p3]].
  move: p2 => [[p4 p6] p5].
  set K:= (fun_image pr (image_by_fun g)).
  have ax: forall z, inc z pr -> sub z (source g).
    move => z zpr; move: p1 => /setP_P sa; move: (sa _ zpr) => /setP_P; ue.
  have pr1: inc K (powerset (powerset F)).
    apply /setP_P => t; move /funI_P => [z zpr ->]; apply /setP_P => s.
    move: (ax _ zpr) => a1.
    move /(Vf_image_P fg a1) => [u uz ->]; rewrite -tg; Wtac.
  have pr2: union K = F.
    rewrite -tg;set_extens s.
      move /setU_P=> [a sa] /funI_P [z zpr e1];move: (ax _ zpr) => a1.
      move: sa; rewrite e1; move /(Vf_image_P fg a1) => [u uz ->]; Wtac.
    move => si; move: (bij_surj big si); rewrite sg -p4; move => [x].
    move/setU_P => [z xz] zpr <-; apply /setU_P;exists (image_by_fun g z).
       by apply (Vf_image_P fg (ax _ zpr)); ex_tac.
    apply /funI_P; ex_tac.
  have pr3: alls K nonempty.
    move => t /funI_P [z zpr ->]; move: (p5 _ zpr) => [a az].
    exists (Vf g a); apply /(Vf_image_P fg (ax _ zpr)); ex_tac.
  have pr4: partition_s K F.
    split => //; split => //; move => a b ak bk; mdi_tac nab.
    move: ak bk nab => /funI_P [a1 a1p ->] /funI_P [b1 b1p ->].
    move:(ax _ a1p)(ax _ b1p) => s1 s2.
    case: (p6 _ _ a1p b1p); [ by move => -> | move => diab _ ].
    move => u /(Vf_image_P fg s1) [a2 a2p ->].
    move /(Vf_image_P fg s2)=> [b2 b2p b2v].
    move: (bij_inj big (s1 _ a2p) (s2 _ b2p)b2v) => sb.
    empty_tac1 a2; ue.
  apply /Zo_P;split => //; split => //.
  rewrite -p3; symmetry; apply /card_eqP.
  exists (Lf (fun z => (image_by_fun g z)) pr K); split;aw.
  have ifi: forall s1 s2, sub s1 (source g) -> sub s2 (source g) ->
     image_by_fun g s1 = image_by_fun g s2 -> s1 = s2.
    move => s1 s2 aa bb cc.
    rewrite (inverse_direct_image_inj (proj1 big) aa).
    by rewrite (inverse_direct_image_inj (proj1 big) bb) cc.
  apply: lf_bijective.
      move => z zp; apply /funI_P; ex_tac.
    move => u v ui vi si; exact: (ifi _ _ (ax _ ui) (ax _ vi) si).
  move => y yK.
  have aux2: sub y (target g) by rewrite tg - pr2; apply: setU_s1.
  move: (direct_inv_im_surjective (proj2 big) aux2).
  set s := (image_by_fun (inverse_fun g) y) => hh; exists s => //.
  move: (inverse_bij_fb big) => [[fib _] _].
  have syis: sub y (source (inverse_fun g)) by aw.
  have ssg: sub s (source g).
    have ->: (source g) = target (inverse_fun g) by aw.
    move => t /(Vf_image_P fib syis) [u uy ->]; Wtac.
  move: yK => /funI_P [w wp]; rewrite -hh => h1.
  by rewrite (ifi _ _ ssg (ax _ wp) h1).
move => E F g pa pb pc.
set f := (fun_image^~ (image_by_fun g)).
pose g' := inverse_fun g.
move: (inverse_bij_fb pa) => pa'.
have pb': source g' = F by rewrite /g'; aw.
have pc': target g' = E by rewrite /g'; aw.
move: (aux2 _ _ _ pa pb pc) => h.
move: (aux2 _ _ _ pa' pb' pc').
set f' := fun_image^~ (image_by_fun g') => h'.
have ff': forall x, inc x (partitionsx E p) -> f' (f x) = x.
   by move => x; apply: aux.
apply: lf_bijective => //.
  by move => u v uK vK sf; rewrite - (ff' _ uK) - (ff' _ vK) sf.
move => y yp.
move: (h' _ yp) => u1; move: (ff' _ u1) => u2.
exists (f' y) => //.
have ->: f = fun_image^~ (image_by_fun (inverse_fun g')).
     rewrite /g' ifun_involutive //; fct_tac.
by symmetry; apply: aux => //; rewrite /g'; aw; rewrite pc.
Qed.

Lemma nbpart_pr E p:
  finite_set E -> cardinal (partitionsx E p) = nbpart (cardinal E) p.
Proof.
move => fse; set n := (cardinal E).
have nB: inc n Bnat by apply /BnatP.
have : n = cardinal (Bint n) by rewrite (card_Bint nB).
move/card_eqP => [g [big sg tg]].
move: (nbpart_pr1 p big sg tg); set f := Lf _ _ _ => bf.
apply /card_eqP; exists f; rewrite /f; split; aw.
Qed.

Lemma nbsurj_part n p: inc n Bnat -> inc p Bnat ->
  nbsurj n p = (factorial p) *c (nbpart n p).
Proof.
move => nB pB.
rewrite /nbsurj /nbpart.
set I := (Bint n); set J:= (Bint p).
have cj: p = cardinal J by rewrite (card_Bint pB).
set E := (surjections I J).
set K := (partitionsx I p).
pose f g := fun_image J (fun z => inv_image_by_fun g (singleton z)).
have lfa: lf_axiom f E K.
  move => g /Zo_P [] /fun_set_P [fg sg tg] sjg.
  have p1: inc (f g) (powerset (powerset I)).
     apply /setP_P => z /funI_P [w wJ ->]; apply /setP_P => t.
     by move /(iim_fun_set1_P w fg) => []; rewrite sg.
  have p2: cardinal (f g) = p.
    symmetry; rewrite cj; apply /card_eqP.
    exists (Lf (fun z => inv_image_by_fun g (singleton z)) J (f g)).
    split;aw; apply lf_bijective.
        move => z zj; apply /funI_P; ex_tac.
      move => u v uj vj si.
      rewrite -tg in uj; move: (proj2 sjg _ uj) => [x xsg h].
      symmetry in h;move: (iim_fun_set1_i fg xsg h); rewrite si => xi.
      by rewrite (iim_fun_set1_hi fg xi) - h.
    by move => y /funI_P.
  have p3: union (f g) = I.
    set_extens t.
      move =>/setU_P [z tz h]; move /setP_P: p1 => h1.
      by move: (h1 _ h) => /setP_P; apply.
    move => ti; apply /setU_P; exists (inv_image_by_fun g (singleton (Vf g t))).
    rewrite - sg in ti.
       by exact: (iim_fun_set1_i fg ti (refl_equal (Vf g t))).
    apply /funI_P; exists (Vf g t) => //; rewrite -tg; Wtac.
  have p4: alls (f g) nonempty.
     move => z /funI_P [t]; rewrite - tg => ttg ->.
     move: (proj2 sjg _ ttg) => [x xsg h].
     symmetry in h; move: (iim_fun_set1_i fg xsg h) => h1; ex_tac.
  apply /Zo_P;split => //; split => //; split => //; split => //.
  move => a b a1 b1; mdi_tac nab => u ua ub; case: nab; move: ua ub.
  move /funI_P: a1 => [z zj ->]; move /funI_P: b1 => [w wj ->].
  by move => h1 h2;rewrite (iim_fun_set1_hi fg h1) - (iim_fun_set1_hi fg h2).
pose phi := Lf f E K.
have sphi: E = source phi by rewrite /phi; aw.
have ->: K = target phi by rewrite /phi; aw.
have fphi: function phi by apply: lf_function.
rewrite sphi cprodC; apply: (shepherd_principle fphi).
rewrite {1} /phi; aw; move => x xK.
set F := inv_image_by_fun phi (singleton x).
have fp: forall g, inc g F <-> inc g (surjections I J) /\ f g = x.
  move => g; split.
    move /(iim_fun_set1_P _ fphi) => []; rewrite - sphi => fe;rewrite{1}/phi.
    aw; move => pa;split => //.
  move => [pa pb]; apply /(iim_fun_set1_P _ fphi).
  by split => //;[ ue | rewrite /phi;aw].
move: (xK) => /Zo_P [xpp [px]]; rewrite cj.
move /card_eqP => [fa [bfa sfa tfa]].
pose fb t := select (fun s => inc t s) x.
have prb: forall t, inc t I -> inc t (fb t) /\ inc (fb t) x.
  move => t ti; apply: (select_pr); move: px => [[pa pc] pb].
    move: ti; rewrite - pa => /setU_P [z za zb]; ex_tac.
  move => a b sa sb sc sd; case: (pc _ _ sa sc) => // h; empty_tac1 t.
pose fc := Lf (fun t => (Vf fa (fb t))) I J.
have sfc: source fc = I by rewrite /fc; aw.
have tfc: target fc = J by rewrite /fc; aw.
have fc0: lf_axiom (fun t => (Vf fa (fb t))) I J.
   move=> t ti; move: (prb _ ti) => [_]; rewrite - sfa - tfa => h; Wtac;fct_tac.
have fc1: function fc by apply: lf_function.
have fc2': surjection fc.
  split => // y; rewrite /fc; aw; rewrite - tfa => yJ.
  move: (bij_surj bfa yJ); rewrite sfa; move => [z zx <-].
  move: px => [[p1 p3 p2]]; move: (p2 _ zx) => [t tz].
  have ti: inc t I by rewrite - p1; union_tac.
  rewrite tfa;ex_tac; aw.
  move: (prb _ ti) => [sa sb]; case: (p3 _ _ zx sb); first by move => ->.
  move => h; empty_tac1 t.
have fc2: inc fc (surjections I J).
  apply /Zo_P; split => //; by apply /fun_set_P.
have fc3: forall w, inc w x -> inv_image_by_fun fc (singleton (Vf fa w)) = w.
  move => w wx; move: px => [[p1 p3] p2]; set_extens s.
    move /(iim_fun_set1_P _ fc1); rewrite sfc /fc; move => [ta]; aw.
    move => vfa; move: (prb _ ta) => [tb tc].
    by rewrite - sfa in wx tc; rewrite (bij_inj bfa wx tc vfa).
  move => sw; apply /(iim_fun_set1_P _ fc1).
  have si: inc s I by rewrite - p1; union_tac.
  rewrite sfc /fc;aw;split => //; move: (prb _ si) => [tb tc].
  case: (p3 _ _ wx tc); [by move => <- | by move =>h; empty_tac1 s].
have fc4: inc fc F.
  move: (proj1 (proj1 bfa)) => ffa.
  apply /fp; split => //; rewrite /f;set_extens t.
    move /funI_P => [z zJ ->]; rewrite -tfa in zJ.
    move: (bij_surj bfa zJ); rewrite sfa; move => [w wx <-].
    by rewrite (fc3 _ wx).
  move => tx; apply /funI_P; exists (Vf fa t); first by Wtac.
  by rewrite (fc3 _ tx).
have fsj: finite_set J by red; rewrite - cj; apply /BnatP.
rewrite - (number_of_permutations fsj).
symmetry; clear fsj; apply /card_eqP.
exists (Lf (fun z => z \co fc) (permutations J) F); split; aw.
move /Zo_P: (fc2) => [sa sb]; move: (exists_right_inv_from_surj sb) => [s sc].
apply /lf_bijective.
    move => g /Zo_P [] /fun_set_P [fg sg tg] big.
    have gfc: g \coP fc by split => //; rewrite sg tfc.
    have fgfc: function (g \co fc) by fct_tac.
    have tgfc: target (g \co fc) = J by aw.
    have sgfc: source (g \co fc) = I by aw.
    have ssgfc: surjection(g \co fc) by apply/compose_fs =>//;exact (proj2 big).
    have pa:inc (g \co fc) (surjections I J).
     apply /Zo_P; split; first by apply/fun_set_P;aw.
     by apply /compose_fs => //; exact (proj2 big).
    have aux2: forall w, inc w I ->
      (inv_image_by_fun (g \co fc) (singleton (Vf (g \co fc) w)))=
      (inv_image_by_fun fc (singleton (Vf fc w))).
      move => w wi; set_extens t.
        move /(iim_fun_set1_P _ fgfc); rewrite sgfc; move => [tI].
        rewrite - sfc in wi tI;aw.
        move: (Vf_target fc1 wi) (Vf_target fc1 tI); rewrite tfc - sg.
        move => i1 i2 i3; rewrite (bij_inj big i1 i2 i3).
        by apply: (iim_fun_set1_i fc1 tI).
      rewrite - sfc in wi; move /(iim_fun_set1_P _ fc1) => [ta tb]; aw.
      apply:(iim_fun_set1_i fgfc); aw; ue.
    move /fp: fc4 => [_] xv1.
    apply /fp;split => //; set_extens t.
      move /funI_P => [z zJ ->].
      rewrite -tgfc in zJ; move: (proj2 ssgfc _ zJ); rewrite sgfc.
      move => [a ai <-]; rewrite (aux2 _ ai) - xv1.
      apply /funI_P;exists (Vf fc a) => //; Wtac.
    rewrite -xv1; move /funI_P => [z zj etc].
    apply /funI_P; rewrite -tfc in zj; move: (proj2 fc2' _ zj) etc.
    move => [a]; rewrite sfc => s1 <-; rewrite - (aux2 _ s1) => ->.
    exists (Vf (g \co fc) a) => //; rewrite - tgfc; Wtac.
  move => u v up vp sv; move: sc => [sc sd].
  move: up vp sa => /Zo_P [] /fun_set_P [fu su tu] _ /Zo_P [] /fun_set_P.
  move => [fv srv tv] _ /fun_set_P [fs sss ts].
  have c1: u \coP fc by split => //; ue.
  have c2: v \coP fc by split => //; ue.
  move: (f_equal (fun z => z \co s) sv).
  by rewrite - !compfA // sd ts - {1} su (compf_id_r fu) - srv (compf_id_r fv).
move => y yf.
move /fp: yf => [] /Zo_P []/fun_set_P [fy sy ty] sjy fyv.
move /Zo_P: fc2 => [_ sj1].
have sysj: source y = source fc by ue.
have aux: forall x0 y0 : Set,
   inc x0 (source fc) ->
   inc y0 (source fc) -> Vf fc x0 = Vf fc y0 -> Vf y x0 = Vf y y0.
   rewrite sfc; move => a b aI bI; rewrite /fc; aw => sv.
   move: (prb _ aI)(prb _ bI) => [s1 s2] [s3 s4].
   rewrite - sfa in s2 s4; move: (bij_inj bfa s2 s4 sv) => sf.
   move: s2; rewrite sfa - fyv; move /funI_P => [z zj] => ta.
   move: s1; rewrite ta => s1; rewrite - (iim_fun_set1_hi fy s1).
   by move: s3; rewrite - sf ta => s2; rewrite (iim_fun_set1_hi fy s2).
set h:= y \co s.
have pr1: fc \coP s by move:sc => [s1 s2].
have pr2: y \coP s by red;move: pr1 => [s1 s2 <-].
move:(sc) => [[_ s2 s3] s4].
have fh: function h by rewrite /h; fct_tac => //; rewrite sy - s3 sfc.
move: (f_equal source s4); aw; rewrite tfc => srs.
have hf: inc h (functions J J).
   by apply /fun_set_P; red; rewrite {2 3} /h; aw.
have sjh: surjection h.
  split => // y1; rewrite /h; aw => y1y; move: (proj2 sjy _ y1y).
  rewrite sy srs; move => [a ai <-].
  set b := Vf fc a; have bj: inc b J by rewrite - tfc /b; Wtac.
  have bs: inc b (source s) by ue.
  have bs3: inc (Vf s b) I by rewrite - sfc s3; Wtac.
  ex_tac; aw; apply: aux; rewrite ? sfc //.
  move: (f_equal (Vf^~ b) s4); aw; rewrite identity_V //; ue.
have bh: bijection h.
   move /fun_set_P: hf => [_ sh th].
   apply: bijective_if_same_finite_c_surj; rewrite ? sh ? th=> //.
   by red; rewrite - cj; apply /BnatP.
rewrite -(left_composable_value fy sj1 sysj aux sc (refl_equal h)).
by exists h=> //;apply /Zo_P.
Qed.

Lemma nbsurj_inv n p: inc n Bnat -> inc p Bnat ->
 p ^c n = card_sumb (Bintc p)
     (fun k => (binom p k) *c (nbsurj n k)).
Proof.
move => nB pB.
set I := (Bint n); set J:= (Bint p).
have ci: n = cardinal I by rewrite (card_Bint nB).
have cj: p = cardinal J by rewrite (card_Bint pB).
set K := (Bintc p).
have ->: p ^c n = cardinal (functions I J).
   rewrite ci cj; apply:cpow_pr; fprops.
have pa: forall x, inc x (functions I J) -> sub (image_of_fun x) J.
  by move => x /fun_set_P [p1 p2 <-]; apply:fun_image_Starget.
have pb: forall x, inc x (functions I J) ->
   inc (cardinal (image_of_fun x)) K.
   move => x h; move: (sub_smaller (pa _ h)).
   by rewrite - cj; move /(BintcP pB).
rewrite (card_partition_induced pb); rewrite /card_sumb; apply:f_equal.
apply: Lg_exten => k; move/(BintcP pB) => kp.
move: (BS_le_int kp pB) => kB.
rewrite (subsets_with_p_elements_pr pB kB (sym_eq cj)).
set E1 := Zo _ _; set K1 := subsets_with_p_elements _ _.
have pc: forall c, inc c E1 -> inc (image_of_fun c) K1.
  by move => c /Zo_P [pc pd]; apply /Zo_P;split => //; apply /setP_P; apply: pa.
pose phi := Lf image_of_fun E1 K1.
have sphi: E1 = source phi by rewrite /phi; aw.
have tphi: K1 = target phi by rewrite /phi; aw.
have fphi: function phi by apply: lf_function.
rewrite sphi tphi; apply: (shepherd_principle fphi).
move => tf; rewrite - tphi; move /Zo_P => [] /setP_P tfj ctf.
set K2:= Zo (functions I J) (fun f => image_of_fun f = tf).
have ->: inv_image_by_fun phi (singleton tf) = K2.
  set_extens t.
     move /(iim_fun_set1_P _ fphi) => []; rewrite - sphi /phi => t1; aw.
     move /Zo_P: t1 => [t1 t2] t3; apply /Zo_P;split => //.
  move => /Zo_P [t1 t2]; apply /(iim_fun_set1_P _ fphi); rewrite - sphi.
  have te1: inc t E1 by apply /Zo_P; rewrite t2.
  by rewrite /phi; aw.
rewrite ci - ctf.
have f1: finite_set I by red; rewrite - ci; apply /BnatP.
have f2: finite_set tf by red; rewrite ctf; apply /BnatP.
rewrite -(nbsurj_pr f1 f2); clear f1 f2.
apply /card_eqP.
exists (Lf restriction_to_image K2 (surjections I tf)); split;aw.
apply: lf_bijective.
    move => c /Zo_P [] /fun_set_P [qa qb qc] qd; apply /Zo_P.
    move: (restriction_to_image_fs qa) => qe;split => //; apply /fun_set_P.
    move: (proj1 qe) => f; split => //; rewrite /restriction_to_image.
    by rewrite /restriction2; aw.
    by rewrite /restriction2; aw.
  move => u v /Zo_P [] /fun_set_P [qa qb qc] qd.
  move => /Zo_P [] /fun_set_P [ra rb rc] rd sr.
  apply: function_exten => //; rewrite ? rb ? rc // => x xI.
  move: (f_equal (Vf ^~x) sr).
  move: (restriction_to_image_axioms qa) => h; rewrite restriction2_V //.
  move: (restriction_to_image_axioms ra) => h'; rewrite restriction2_V //.
  by rewrite rb - qb.
move => y /Zo_P [] /fun_set_P [qa qb qc] qd.
set f := Lf (Vf y) I J.
have fa: forall z, inc z I -> inc (Vf y z) J.
    rewrite -qb; move => z zi; apply: tfj; rewrite -qc; Wtac.
  have fb: function f by apply: lf_function.
  have sfi: source f = I by rewrite /f;aw.
  have fc: image_of_fun f = tf.
    set_extens t.
      move /(Vf_image_P1 fb); rewrite sfi; move => [u u1 ->]; rewrite /f; aw.
      Wtac.
    rewrite -qc => tt; move: (proj2 qd _ tt); rewrite qb; move => [u u1 u2].
    by apply /(Vf_image_P1 fb); rewrite sfi;ex_tac; rewrite /f;aw.
  have fd:inc f K2 by apply/ Zo_P; split => //;apply /fun_set_P;rewrite /f;red;aw.
  move: (proj1 (restriction_to_image_fs fb)) => ra.
  move: (restriction_to_image_axioms fb) => rb.
  have sr:source (restriction_to_image f) = source y by rewrite corresp_s sfi.
  ex_tac; apply: function_exten => //.
    by rewrite corresp_t fc.
  rewrite qb;move => t ts /=; rewrite restriction2_V // -? sfi // /f; aw.
Qed.

Definition Bell_number n := cardinal (partitions (Bint n)).

Lemma Bell_pr E :
  finite_set E ->
  cardinal (partitions E) =
  card_sumb (Bintc (cardinal E))
     (fun p => cardinal (partitionsx E p)).
Proof.
set X:= (partitions E).
set n := cardinal E; move /BnatP => nB.
set F := (Bintc n).
suff h: (forall x, inc x X -> inc (cardinal x) F).
  rewrite (card_partition_induced h) /card_sumb; apply f_equal; apply: Lg_exten.
  move => p pF /=; apply: f_equal; set_extens t.
    move => /Zo_P [] /Zo_P=> [[pa pb] pc]; apply /Zo_P;split => //.
  by move => /Zo_P [pa [pb pc]]; apply /Zo_P => //;split => //; apply /Zo_P.
move => x /Zo_P [] pa [[pb pd] pc]; apply /(BintcP nB).
have injf: injection (Lf rep x E).
  apply: lf_injective.
    by move => t tx; move: (rep_i (pc _ tx)) => h; rewrite - pb; union_tac.
  move => u v ux vx; case: (pd _ _ ux vx) => // bad sr.
  empty_tac1 (rep u).
      exact: (rep_i (pc _ ux)).
      rewrite sr;exact: (rep_i (pc _ vx)).
move: (incr_fun_morph injf); aw.
Qed.

Lemma Bell_pr1 n: inc n Bnat ->
  Bell_number n = card_sumb (Bintc n) (fun p => nbpart n p).
Proof.
move => nB.
have ce: cardinal (Bint n) = n by rewrite (card_Bint nB).
have fse: finite_set (Bint n) by red; rewrite ce; apply /BnatP.
by rewrite /Bell_number (Bell_pr fse) /nbpart ce.
Qed.

Lemma Bell_pr2 E: finite_set E ->
  cardinal (partitions E) = Bell_number (cardinal E).
Proof.
move => fse.
have nB: inc (cardinal E) Bnat by move: fse; move /BnatP.
rewrite (Bell_pr fse) (Bell_pr1 nB); rewrite /card_sumb; apply: f_equal.
apply: Lg_exten => p pn; rewrite nbpart_pr //.
Qed.

Lemma Bell_rec n : inc n Bnat ->
  Bell_number (succ n) =
  card_sumb (Bintc n) (fun k => (binom n k) *c (Bell_number k)).
Proof.
move => nB.
set E := Bint (succ n); set X := (partitions E).
set E' := (Bint n).
have nE: inc n E by apply: Bint_si.
have ce: cardinal E = succ n by rewrite (card_Bint (BS_succ nB)).
have ce1: cardinal E' = n by rewrite (card_Bint nB).
have see': sub E' E by apply:Bint_M.
pose fb p := select (fun s => inc n s) p.
have prb: forall p, inc p X -> inc n (fb p) /\ inc (fb p) p.
  move => t /Zo_P [_] [[pa pc] pb]; apply: (select_pr).
     move: nE; rewrite -pa; move /setU_P => [y sa sb]; ex_tac.
  move => x y xp nx yp ny; case: (pc _ _ xp yp) => // bad; empty_tac1 n.
have fcq: forall p, inc p X -> cardinal (fb p -s1 n) <=c n.
  move => p pX; move: (prb _ pX) => [pa pb].
  apply /(card_le_succ_succP); fprops.
  rewrite - (card_succ_pr2 pa) - ce; move /Zo_P: pX => [] /setP_P h _.
  move: (h _ pb) => /setP_P => h1; apply: (sub_smaller h1).
pose fc p := n -c cardinal (fb p -s1 n).
have fcp: forall p, inc p X-> inc (fc p) (Bintc n).
  by move => p pX; apply /(BintcP nB); apply: cdiff_le_symmetry; apply: fcq.
rewrite /Bell_number (card_partition_induced fcp) /card_sumb.
apply: f_equal; apply: Lg_exten => k /(BintcP nB) kn.
move: (BS_le_int kn nB) => kB.
rewrite (binom_symmetric nB kB kn).
rewrite (subsets_with_p_elements_pr nB (BS_diff k nB) ce1).
set E1 := Zo _ _; set K1 := subsets_with_p_elements _ _.
pose phi := Lf (fun z => (fb z -s1 n)) E1 K1.
have pc: forall c, inc c E1 -> inc (fb c -s1 n) K1.
  move => x /Zo_P [pa pb]; apply /Zo_P;split => //.
     apply /setP_P.
     move => t /setC1_P [pc pd]; apply /(BintP nB); split => //.
     move:(prb _ pa) => [_]; move: pa => /Zo_P [] /setP_P => sa _ sb.
     by move: (sa _ sb) => /setP_P => sc; apply /(BintsP nB); apply: sc.
  by rewrite -pb /fc double_diff //; apply: fcq.
have sphi: E1 = source phi by rewrite /phi; aw.
have tphi: K1 = target phi by rewrite /phi; aw.
have fphi: function phi by apply: lf_function.
rewrite sphi tphi; apply: (shepherd_principle fphi).
rewrite - tphi => S /Zo_P [] /setP_P sa sb.
have ->: (inv_image_by_fun phi (singleton S)) =
   Zo X (fun z => fb z -s1 n = S).
   set_extens t.
      move /(iim_fun_set1_P _ fphi); rewrite - sphi; move => [s1].
      by rewrite /phi; aw => s2; apply /Zo_P;split => //; move /Zo_P: s1 => [].
   move => /Zo_P [s1 s2]; apply /(iim_fun_set1_P _ fphi).
   have te1: inc t E1.
      by apply /Zo_P;split => //; rewrite /fc s2 sb double_diff.
   by rewrite - sphi /phi;split => //;aw.
have sc: E -s (S +s1 n) = E' -s S.
     set_extens t.
       move => /setC_P [te] /setU1_P h; apply /setC_P.
       case: (equal_or_not t n) => tn; first by case: h; right.
       split; last by move => h1; case: h; left.
       by apply /(BintP nB); split => //; apply /(BintsP nB).
     move => /setC_P [t1 t2]; apply /setC_P; split; first by apply: see'.
     by apply /setU1_P; case => // tn; move /(BintP nB) : t1 => [].
have sd: k = n -c cardinal S by rewrite sb double_diff.
pose E'':= (E -s (S +s1 n)).
have se: cardinal E'' = k.
  have fse': finite_set E' by apply /BnatP; rewrite (card_Bint nB).
  by rewrite /E'' sc (cardinal_setC4 sa fse') ce1 sd.
rewrite -/(Bell_number k) - se - Bell_pr2; last by apply/BnatP; rewrite se.
symmetry; apply/ card_eqP.
set A:= partitions E''; set B := Zo _ _.
pose f p := p +s1 (S +s1 n).
have pa: forall p, inc p A -> inc (f p) (powerset (powerset E)).
  move => p /Zo_P [p1 [[p2 p4] p3]]; apply /setP_P => t /setU1_P; case.
    move => tp; apply /setP_P => s st.
    move/setP_P: p1 => h1; move: (h1 _ tp) => h2; move/setP_P: h2 => h3.
    by move: (h3 _ st) => /setC_P [].
  move => ->; apply /setP_P => s /setU1_P; case; fprops.
  move => ->; apply :(Bint_si nB).
have pb: forall p, inc p A -> inc (f p) X.
  move => p pA; move: (pa _ pA) => pn; apply /Zo_P; split => //.
  move /Zo_P: pA => [_] [[p1 p3] p2]; split; last first.
    move => t /setU1_P; case; [apply: p2 | move => ->; exists n; fprops].
    split; first set_extens t.
      move => /setU_P [z tz zf]; move/setP_P: pn => h; move: (h _ zf).
      by move /setP_P; apply.
    move => te; case: (inc_or_not t (S +s1 n)) => h.
      by union_tac; apply /setU1_P; right.
    move: (setC_i te h); rewrite -/E'' -p1 => /setU_P [z za zb].
    by union_tac; apply /setU1_P; left.
  move => a b /setU1_P; case => pb /setU1_P; case => pd.
      by apply: p3.
     right; rewrite pd; move: (setU_s1 pb); rewrite p1 => h.
     by apply: disjoint_pr => s sx; move: (h _ sx) => /setC_P [].
   right; rewrite pb; move: (setU_s1 pd); rewrite p1 => h.
    by apply: disjoint_pr => s sx sy; move: (h _ sy) => /setC_P [].
  by rewrite pb pd; left.
have pd: forall p, inc p A -> fb (f p) = (S +s1 n).
  move => p pA; move: (pb _ pA) => h; move: (prb _ h) => [s1 s2].
  case /setU1_P: s2 => // h1.
  move /Zo_P: pA => [] /setP_P ha _; move: (ha _ h1) => /setP_P => hb.
  by move: (hb _ s1) => /setC_P [_] /setU1_P; case; right.
exists (Lf f A B); split; aw;apply: lf_bijective.
    move => p pA; apply /Zo_P;split; first by apply: pb.
    rewrite (pd _ pA); apply: setU1_K => ns; move: (sa _ ns).
    by move /(BintP nB) => [].
  move => u v uA vA sf.
   have aux: forall s, inc s A -> ~ inc (S +s1 n) s.
     move => s /Zo_P [] /setP_P h _ h1; move: (h _ h1) => /setP_P h2.
     have h3: inc n (S +s1 n) by fprops.
     by move: (h2 _ h3) => /setC_P [].
   by rewrite - (setU1_K (aux _ uA)) - (setU1_K (aux _ vA)) - /(f u) sf.
move => y /Zo_P [p1 p2]; move: (prb _ p1) => [p3 p4].
have aux: S +s1 n = fb y by rewrite - p2;apply: setC1_K.
exists (y -s1 (fb y)); last by symmetry;rewrite /f aux;apply: setC1_K.
have q1: inc (y -s1 fb y) (powerset (powerset E'')).
  apply /setP_P => t /setC1_P [] ta tb; apply /setP_P => s st; apply /setC_P.
  move /Zo_P: p1 => [] /setP_P ha [[q1 q3] q2]; split.
    by move: (ha _ ta) => /setP_P; apply.
  move => h; case: (q3 _ _ p4 ta); rewrite /disjoint => h1; first by case: tb.
  by empty_tac1 s; apply /setI2_P; split => //; rewrite - aux.
move /Zo_P: p1 => [_] [[q3 q5] q4].
apply /Zo_P;split => //; split; first split.
    move /setP_P: q1 => q2; set_extens t.
    by move /setU_P => [z za zb]; move: (q2 _ zb) => /setP_P; apply.
  move /setC_P => [t1 t2]; move: t1; rewrite -q3 => /setU_P [z z1 z2].
  by union_tac; apply /setC1_P;split => //; move => h; case: t2; rewrite aux -h.
by move => a b /setC1_P [s1 _] /setC1_P [s2 _]; apply: q5.
by move => s /setC1_P [sy _]; apply:q4.
Qed.


Definition derangements E :=
  Zo (permutations E) (fun z => forall x, inc x E -> Vf z x <> x).

Definition nbder n :=
  cardinal(derangements (Bint n)).

Lemma nbder_pr E: finite_set E ->
   cardinal (derangements E) = nbder (cardinal E).
Proof.
have aux: forall I J g f,
    bijection g -> source g = J -> target g = I ->
    inc f (derangements J) ->
    inc (g \co (f \co inverse_fun g)) (derangements I).
  move => I J g f big sg tg.
  move: (inverse_bij_fb big); set g1 := inverse_fun g => igb.
  move: (proj1 (proj1 big))(proj1(proj1 igb)) => fg fig.
  move => /Zo_P [] /Zo_P [] /fun_set_P [pa pb pc] pd pe.
  have qa: (f \coP g1) by rewrite /g1;red; aw;split => //; ue.
  have qb: bijection (f \co g1) by apply: compose_fb.
  have qc: (g \coP (f \co g1)) by split => //;aw; try fct_tac; ue.
  have qd: bijection (g \co (f \co g1)) by apply: compose_fb.
  have sg1: source g1 = I by rewrite /g1; aw.
  have qe: inc (g \co (f \co g1)) (permutations I).
     apply /Zo_P;split => //; apply /fun_set_P; split => //; aw;fct_tac.
  apply/ Zo_P; split => // => x xi => eq.
  move: (f_equal (Vf g1) eq).
  rewrite - sg1 in xi; aw; rewrite -/g1; set y:= Vf g1 x.
  have ye: inc y J by rewrite- sg - ifun_t /y /g1; Wtac; aw.
  have ysg: inc (Vf f y) (source g) by rewrite sg - pc; Wtac.
  rewrite (inverse_V2 big ysg); exact (pe _ ye).
move => fse; set n := cardinal E; set I :=Bint n.
have nB: inc n Bnat by apply /BnatP.
have : n = cardinal I by rewrite (card_Bint nB).
move/card_eqP => [g [big sg tg]]; apply /card_eqP.
pose c f := g \co (f \co (inverse_fun g)).
move: (inverse_bij_fb big); set g1 := inverse_fun g => igb.
move: (proj1 (proj1 big))(proj1(proj1 igb)) => fg fig.
exists (Lf c (derangements E) (derangements I)); split;aw.
apply: lf_bijective.
move => f.
    by apply: aux.
  move => u v /Zo_P [] /Zo_P [] /fun_set_P [pa pb pc] _ _.
  move => /Zo_P [] /Zo_P [] /fun_set_P [qa qb qc] _ _ sv.
  have ra: (u \coP g1) by rewrite /g1;red; aw;split => //; ue.
  have rb: function (u \co g1) by fct_tac.
  have rc: (g \coP (u \co g1)) by split => //;aw; ue.
  have ra': (v \coP g1) by rewrite /g1;red; aw;split => //; ue.
  have rb': function (v \co g1) by fct_tac.
  have rc': (g \coP (v \co g1)) by split => //;aw; ue.
  move: (fct_co_simpl_left rc rc' big sv) => sv1.
  exact: (fct_co_simpl_right ra ra' igb sv1).
move => y yv; set x := (g1 \co (y \co (inverse_fun g1))).
have sg1: source g1 = I by rewrite /g1; aw.
have tg1: target g1 = E by rewrite /g1; aw.
move: (aux _ _ _ _ igb sg1 tg1 yv); rewrite (ifun_involutive fg) => h; ex_tac.
move: yv => /Zo_P [] /Zo_P [] /fun_set_P [fy sy ty] _ _.
rewrite /c -/g1.
have pa: (y \coP g) by split => //; ue.
have pb: function (y \co g) by fct_tac.
have pc: g1 \coP (y \co g) by split; aw; ue.
have pd: (y \co g) \coP g1 by split; aw; ue.
have pe: g1 \coP ((y \co g) \co g1) by red;aw;split => //; try fct_tac; ue.
move: (composable_f_inv big) => pf.
rewrite - compfA // compfA // bij_right_inverse //.
rewrite - compfA // bij_right_inverse // tg - {2} sy compf_id_r //.
rewrite - ty compf_id_l //.
Qed.

Lemma nbder_0: nbder \0c = \1c.
Proof.
rewrite /nbder /derangements.
set E := (Bint \0c); set X:= Zo _ _.
set f := empty_function.
have EE: E = emptyset by exact Bint_co00.
move: empty_function_function => pa.
move: (pa) => [p1 p2 p3].
have bf: bijection f.
   split; split => //.
   by move => x y; rewrite p2 => /in_set0.
   by move => y; rewrite p3 => /in_set0.
have fp:inc f (permutations emptyset).
   by apply /Zo_P;split => //; apply /fun_set_P.
have fX: inc f X.
  by rewrite /X EE; apply /Zo_P; split => // x /in_set0.
have ->: X = singleton f.
   apply: set1_pr => // z /Zo_P [] /Zo_P [] /fun_set_P [sa sb sc] _ _.
   apply: function_exten => //.
      by rewrite sb EE.
     by rewrite sc EE.
   by move => t; rewrite sb EE => /in_set0.
by rewrite cardinal_set1.
Qed.

Lemma nbder_1: nbder \1c = \0c.
Proof.
rewrite /nbder;set E := derangements _.
suff: E = emptyset by move => ->; apply: cardinal_set0.
apply /set0_P => t /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] _ pf.
move:Bint_co01 => [pa pb].
move: (pf _ pa) => f0.
by rewrite - sf in pa; move: (Vf_target ff pa); rewrite tf pb => /set1_P.
Qed.

Lemma Exercise5_8a n: inc n Bnat ->
  factorial n = card_sumb (Bintc n) (fun k =>
    binom n k *c nbder k).
Proof.
move => nB.
set I := (Bint n).
have caI : cardinal I = n by rewrite (card_Bint nB).
have fsi: finite_set I by red; rewrite caI; apply /BnatP.
move: (number_of_permutations fsi); rewrite - caI => <-.
pose g f := Zo I (fun x => Vf f x <> x).
pose Xk k := Zo (permutations I) (fun z => cardinal (g z) = k).
set X := Lg (Bintc n) Xk.
have X1: fgraph X by rewrite /X; fprops.
have X2: mutually_disjoint X.
  red;rewrite /X; bw => i j ip jp; bw;mdi_tac nij => u ua ub; case: nij.
  by move: ua ub => /Zo_P [_ <- ] /Zo_P [_ <-].
have X3: (unionb X) = (permutations I).
   rewrite /X;set_extens t.
     move /setUb_P; bw; move => [y yp]; bw; move /Zo_P => [p1 p2] //.
   have sa: inc (cardinal (g t)) (Bintc n).
     have h: sub (g t) I by apply: Zo_S.
     apply /BintcP => //; rewrite - caI; apply: (sub_smaller h).
   move => ti; apply /setUb_P; bw;exists (cardinal (g t)) => //.
   rewrite /Xk; bw;apply /Zo_P;split => //.
move: (csum_pr4 X2); rewrite X3 => ->.
rewrite {1} /X /card_sumb caI; bw; apply: f_equal; apply: Lg_exten.
move => k kn; rewrite /X; bw; move/(BintcP nB): kn => kn;clear X X1 X2 X3.
move: (BS_le_int kn nB) => kB.
rewrite(subsets_with_p_elements_pr nB kB caI).
set K := (subsets_with_p_elements k I).
pose phi := Lf g (Xk k) K.
have sphi: (Xk k) = source phi by rewrite /phi; aw.
have ->: K = target phi by rewrite /phi; aw.
have ta: lf_axiom g (Xk k) K.
  by move => f /Zo_P [p1 p2]; apply/Zo_P;split => //; apply/setP_P; apply: Zo_S.
have fphi: function phi by apply: lf_function.
rewrite sphi; apply: (shepherd_principle fphi).
rewrite {1} /phi; aw; move => x xK.
set W := (inv_image_by_fun phi (singleton x)).
have kp: forall f, inc f W <-> inc f (Xk k) /\ g f = x.
  move => f; split.
    by move/(iim_fun_set1_P _ fphi); rewrite - sphi /phi; move => [h];aw => h1. move => [pa pb]; apply/(iim_fun_set1_P _ fphi).
  have fsp: inc f (source phi) by rewrite - sphi.
  by rewrite /phi;aw.
move: (xK) => /Zo_P [] /setP_P sxi cx.
pose r f := Lf (Vf f) x x.
have pa: forall f, inc f W ->
   [/\ lf_axiom (Vf f) x x,
     (forall t, inc t x -> Vf (r f) t = Vf f t),
    (forall t, inc t (I -s x) -> Vf f t = t) &
   inc (r f) (derangements x)].
  move => f /kp [] /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] bf fp gf.
  have lfa: lf_axiom (Vf f) x x.
     move => s st; move: (st); rewrite - gf => /Zo_P [si siv].
     have ax: inc (Vf f s) I by rewrite - tf; Wtac.
     apply /Zo_P;split => // => sv; rewrite - sf in si ax.
     by move:(bij_inj bf ax si sv).
  have sv: forall t, inc t x -> Vf (r f) t = Vf f t.
     move => t tx; rewrite /r; aw.
  have sv1:(forall t, inc t x -> Vf (r f) t <> t).
    by move => t tx; rewrite (sv _ tx); move: tx; rewrite - gf => /Zo_P [].
  have sv2: (forall t : Set, inc t (I -s x) -> Vf f t = t).
   by move => t /setC_P [ti tx]; ex_middle fx;case: tx;rewrite - gf; apply /Zo_P.
  rewrite /r;split => //; apply /Zo_P;split => //.
  apply /Zo_P;split => //.
    by apply /fun_set_P;split;aw => //; apply:lf_function.
  apply: lf_bijective => //.
    by move => u v ux vx; apply: (bij_inj bf); rewrite sf; apply: sxi.
  move => y yx.
  move: (sxi _ yx); rewrite -tf => ytf.
  move: (bij_surj bf ytf); rewrite sf; move => [z za zb]; exists z => //.
  by ex_middle zx; rewrite - (sv2 _ (setC_i za zx)) zb.
have ->: nbder k = cardinal (derangements x).
   have fsx: finite_set x by red; rewrite cx; apply /BnatP.
   by rewrite (nbder_pr fsx) cx.
apply /card_eqP; exists (Lf r W (derangements x)); split;aw.
apply:lf_bijective.
    by move => t ts; move: (pa _ ts) => [_ _ _].
  move => u v uw vw sr.
  move: (pa _ uw) (pa _ vw) => [_ p1 p2 _] [_ q1 q2 _].
  move: uw => /kp [] /Zo_P [] /Zo_P [] /fun_set_P [f1 f2 f3] _ _ _.
  move: vw => /kp [] /Zo_P [] /Zo_P [] /fun_set_P [f1' f2' f3'] _ _ _.
  apply: function_exten => //; try ue.
  move => t ts; case: (inc_or_not t x) => tx.
    by rewrite - (p1 _ tx) - (q1 _ tx) sr.
  by rewrite f2 in ts; move : (setC_i ts tx) => h; rewrite (p2 _ h) (q2 _ h).
move => y yd.
move: yd => /Zo_P [] /Zo_P [] /fun_set_P [y1 y2 y3] y4 y5.
set f := Lf (fun z => (Yo (inc z x) (Vf y z) z)) I I.
have sa: forall z, inc z I -> inc ((Yo (inc z x) (Vf y z) z)) I.
  move => z zi; Ytac zx => //;apply: sxi; rewrite - y3; Wtac.
have ff: function f by apply: lf_function.
have gfx: g f = x.
   set_extens t.
     by move /Zo_P => [t1 t2]; ex_middle ntx; case: t2; rewrite /f; aw; Ytac0.
   move => tx; move: (sxi _ tx) => ti.
   by apply /Zo_P;split => //;rewrite /f; aw; Ytac0; apply: y5.
have bf: bijection f.
  apply: lf_bijective.
     move => s; apply: sa.
  move => u v ui vi; case: (inc_or_not u x) => ux; Ytac0.
       case: (inc_or_not v x) => vx; Ytac0.
         by apply (bij_inj y4); rewrite y2.
       rewrite -y2 in ux; move: (Vf_target y1 ux); rewrite y3.
       by move => s1 s2; case: vx; rewrite - s2.
    case: (inc_or_not v x) => vx; Ytac0 => //.
    rewrite -y2 in vx; move: (Vf_target y1 vx); rewrite y3.
    by move => s1 s2; case: ux; rewrite s2.
  move => z zi; case: (inc_or_not z x).
    rewrite - {1} y3 => zy; move: (bij_surj y4 zy) => [t ]; rewrite y2.
    by move => tx <-; move: (sxi _ tx) => ti; ex_tac; Ytac0.
   by move => zx; ex_tac; Ytac0.
have fp: inc f (permutations I).
   apply /Zo_P;split => //; apply /fun_set_P; rewrite /f; red;aw;split => //.
have rfy: r f = y.
  symmetry;rewrite /r/f.
  have aux:
     lf_axiom (Vf (Lf (fun z0 : Set => Yo (inc z0 x) (Vf y z0) z0) I I)) x x.
    move => t tx;move: (sxi _ tx) => ti; aw;Ytac0; rewrite - y3; Wtac.
  apply: function_exten; aw; first by apply lf_function => //.
  by rewrite y2;move => s sx /=; move: (sxi _ sx) => si; aw; Ytac0.
by exists f => //; apply /kp;split => //; apply /Zo_P;split => //; rewrite gfx.
Qed.

Lemma nbder_pr2 n: inc n Bnat ->
   nbder (succ (succ n)) = (succ n) *c (nbder n +c nbder (succ n)).
Proof.
move => nB.
move: (BS_succ nB) => snB.
move: (Bint_pr4 snB).
set I :=Bint (succ n); set I' := Bint (succ (succ n)).
move => [pa pb].
have pc: inc (succ n) I' by apply:Bint_si.
have ci: cardinal I= succ n by apply:(card_Bint snB).
set G1 := (derangements I').
pose phi := Lf (Vf ^~(succ n)) G1 I.
have sp: G1 = source phi by rewrite /phi; aw.
have tp: I = target phi by rewrite /phi; aw.
have lfa: lf_axiom (Vf^~(succ n)) G1 I.
  move => f /Zo_P [] /Zo_P [] /fun_set_P [ta tb tc] td te.
  move: (te _ pc) => bad; move: pc; rewrite -tb => pc.
  by move: (Vf_target ta pc); rewrite tc -pa; case /setU1_P.
have fphi: function phi by apply: lf_function.
have ci': cardinal I'= succ (succ n) by apply:(card_Bint (BS_succ snB)).
have <-: cardinal (source phi) = nbder (succ (succ n)).
    rewrite - sp - ci'; apply:nbder_pr; red; rewrite ci'; apply /BnatP; fprops.
rewrite - {1} ci tp;apply:(shepherd_principle fphi).
rewrite {1} /phi; aw; move => x xK.
set G2 := Zo G1 (fun f => Vf f (succ n) = x).
have ->: inv_image_by_fun phi (singleton x) = G2.
   set_extens t.
    move/(iim_fun_set1_P _ fphi); rewrite - sp;move => [ts].
      rewrite /phi /G2; aw => ->; apply /Zo_P;split => //.
  by move => /Zo_P [tg1 <-]; apply /(iim_fun_set1_P _ fphi); rewrite /phi; aw.
set G3 := Zo G2 (fun f => Vf f x = (succ n)).
have sg3: sub G3 G2 by apply: Zo_S.
have h0: succ n <> x by move => h1; case: pb; rewrite h1.
have fi: finite_set I' by red; rewrite ci'; apply /BnatP; fprops.
have xi': inc x I' by rewrite - pa; fprops.
rewrite (cardinal_setC2 sg3) - csum2_pr2a - csum2_pr2b;congr (_ +c _).
  set K := I -s1 x.
  have cK: n = cardinal K.
    by apply: succ_injective1; fprops; rewrite - ci (card_succ_pr2 xK).
  have fsk: finite_set K by red; rewrite - cK; apply /BnatP.
  rewrite cK - (nbder_pr fsk); apply /card_eqP.
  exists (Lf (fun f => (restriction2 f K K)) G3 (derangements K)).
    split;aw.
  have ski': sub K I' by rewrite -pa;move => t /setC_P [ti _]; fprops.
  have pd: forall f, inc f G3 -> restriction2_axioms f K K.
     move => f /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [] /fun_set_P
        [qa qb qc] qd qe qf qg.
     have ksf: sub K (source f) by ue.
     red; rewrite qb qc ;split => // t /(Vf_image_P qa ksf) [u uk ->].
     move: (ksf _ uk) => usf; move: (Vf_target qa usf); rewrite qc -pa.
     have xsf: inc x (source f) by rewrite qb -pa; fprops.
     have nsf: inc (succ n) (source f) by rewrite qb -pa; fprops.
     move /setC1_P: uk => [ui ux]; case /setU1_P => h.
        apply /setC1_P;split => // => h1; rewrite -h1 in qf.
        by move: (bij_inj qd nsf usf qf) => us; case: pb; rewrite us.
     by rewrite -h in qg; move: (bij_inj qd xsf usf qg) => xu; case: ux.
  apply: lf_bijective.
      move => f fg3; move: (pd _ fg3) => pe.
      set g := (restriction2 f K K).
      move: (restriction2_prop pe) => p0.
      have gs: inc g (functions K K) by apply /fun_set_P.
      move: p0 => [p1 p2 p3].
      move: fg3 => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [] /fun_set_P
        [qa qb qc] qd qe qf qg.
      move: (restriction2_fi (proj1 qd) pe) => ir.
      apply /Zo_P; split; first (apply/Zo_P => //; split => //).
        apply:bijective_if_same_finite_c_inj; rewrite ? p2 ? p3 //.
      move => t tK; rewrite (restriction2_V pe tK); apply: qe; fprops.
    move => u v ug3 vg3; move: (pd _ ug3) (pd _ vg3) => pe pe' sr.
    move: ug3 => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [] /fun_set_P
      [qa qb qc] qd qe qf qg.
    move: vg3 => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [] /fun_set_P
      [qa' qb' qc'] qd' qe' qf' qg'.
    apply: function_exten; rewrite ? qb' ? qc' //.
    rewrite qb -pa => t; case /setU1_P ; last by move => ->; rewrite qf.
    move => ti; case: (equal_or_not t x); first by move => ->; rewrite qg.
    move => tx; move /setC1_P: (conj ti tx) => tK.
    by rewrite - (restriction2_V pe tK) - (restriction2_V pe' tK) sr.
  move => y ydK.
  move: ydK => /Zo_P [] /Zo_P [] /fun_set_P [fy sy ty] biy nfy.
  pose f z := Yo (z = succ n) x (Yo (z = x) (succ n) (Vf y z)).
  have f1: f (succ n) = x by rewrite /f; Ytac0; Ytac0.
  have f2: f x = (succ n) by rewrite /f; Ytac0; Ytac0.
  have f3: forall t, inc t K -> f t = Vf y t.
  move => t /setC1_P [ti tk]; rewrite /f; Ytac0; Ytac h => //; case: pb; ue.
  have f4: forall t, inc t K -> inc (f t) K.
       move => t tk; rewrite (f3 _ tk); rewrite - ty; Wtac.
  have f5: lf_axiom f I' I'.
      move => t; rewrite -pa; case: (equal_or_not t x).
        by move ->; rewrite f2; fprops.
      move => tx; case/setU1_P => ta; last by rewrite ta f1; fprops.
      by rewrite pa; apply: ski'; apply: f4;apply /setC1_P.
    have f6: function (Lf f I' I') by apply:lf_function.
    have f7: restriction2_axioms (Lf f I' I') K K.
       have h: sub K (source (Lf f I' I')) by aw.
       red; aw;split => // t; move /(Vf_image_P f6 h) => [u uK].
       by aw; fprops => ->; apply: f4.
    move: (restriction2_prop f7) => [p1 p2 p3].
    have f8: (restriction2 (Lf f I' I') K K) = y.
       apply: function_exten; rewrite ? p2 ? p3 //.
       move => t tk /=; rewrite (restriction2_V f7); aw; fprops.
    have f9: forall t, inc t I' -> f t <> t.
      move => t; rewrite -pa; case: (equal_or_not t x).
        move => -> _; rewrite f2 //.
      move => tx; case /setU1_P; last by move => ->; rewrite f1; fprops.
      move => ti; move /setC1_P: (conj ti tx) => tK.
      by rewrite (f3 _ tK);apply: nfy.
   have f10: inc (Lf f I' I') (permutations I').
     apply /Zo_P; split; first by apply /fun_set_P; red;aw;split => //.
     apply:bijective_if_same_finite_c_surj; aw; apply /lf_surjective => //.
     move => z; rewrite - pa; case /setU1_P; last first.
       move => ->; exists x;fprops.
     case: (equal_or_not z x)=> zx zi.
         by rewrite zx; exists (succ n); fprops.
     move /setC1_P: (conj zi zx); rewrite -/K - ty => yt.
     move: (bij_surj biy yt) => [w]; rewrite sy => wK <-.
     by rewrite - (f3 _ wK); exists w=> //; rewrite pa; apply: ski'.
  exists (Lf f I' I')=> //; apply /Zo_P; aw => //; split => //.
  apply /Zo_P; aw;split => //.
  by apply /Zo_P;split => // => t ti; aw; apply: f9.
set G4 := Zo G2 (fun f => Vf f x <> succ n).
have ->: (G2 -s G3) = G4.
  set_extens t.
    by move /setC_P => [tg2] /Zo_P p3; apply /Zo_P;split => // h; case: p3.
  by move => /Zo_P [p1 p2]; apply /setC_P;split => // ; move => /Zo_P [q1 q2].
pose g f := fun z => Yo (z = Vf (inverse_fun f) (succ n)) x (Vf f z).
pose g1 f := Lf (g f) I I.
have pd: forall f (y:= Vf (inverse_fun f) (succ n)), inc f G4 ->
      [/\ Vf f y = succ n, inc y I, (g f y) = x,
      (forall t, t <> y -> (g f t) = Vf f t) &
      (forall z, inc z I -> inc (g f z) I)].
  move => f y /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [].
  move /fun_set_P => [ff sg tf] bf nfp fn fx.
  move:(inverse_bij_fb bf) => ifb.
  have stf: inc (succ n) (target f) by rewrite tf -pa; fprops.
  have ysf: inc y (source f).
     by move: (Vf_target (proj1 (proj1 ifb))); aw; apply.
  have f1: Vf f y = succ n by rewrite /y inverse_V //.
  have yI: inc y I.
     rewrite sg in ysf; move: (nfp _ ysf) => yy.
     by move: ysf; rewrite -pa; case /setU1_P => // ysn; case: yy; rewrite f1.
  have f2: x <> y by dneg w; ue.
  have f3: (g f y) = x by rewrite /g /y; Ytac0.
  have f4: forall t, t <> y -> (g f t) = Vf f t.
    by move => t; rewrite /y /g => ty; Ytac0.
  have f5: (forall z, inc z I -> inc (g f z) I).
    move => z zI; case: (equal_or_not z y); first by move => ->; rewrite f3.
    move => zy; rewrite (f4 _ zy).
    have zsi: inc z (source f) by rewrite sg -pa; fprops.
    move: (Vf_target ff zsi); rewrite tf - pa; case /setU1_P => //.
    by move => h; rewrite -h in f1; case: zy; rewrite (bij_inj bf ysf zsi f1).
  done.
have fsi: finite_set I by red; rewrite ci; apply /BnatP.
move: (nbder_pr fsi); rewrite ci => <-.
apply /card_eqP; exists (Lf g1 G4 (derangements I)).
split; aw; apply: lf_bijective.
    move => f fg4; move: (pd _ fg4).
    set y := (Vf (inverse_fun f) (succ n)); move=> [f1 yI f3 f4 f5].
    move: fg4 => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [].
    move /fun_set_P => [ff sg tf] bf nfp fn fx.
    have f2: x <> y by dneg w; ue.
    have f6: function (g1 f) by apply /lf_function.
    have f7: bijection (g1 f).
      rewrite /g1.
      apply:bijective_if_same_finite_c_surj; aw; apply /lf_surjective => //.
      move => t tI; have ti': inc t (target f) by rewrite tf -pa; fprops.
      move: (bij_surj bf ti'); rewrite sg; move => [u ui uv].
      rewrite -pa in ui;case /setU1_P: ui; last first.
      move => h; exists y => //; rewrite f3 - uv h fn => //.
      by move => ui; ex_tac; rewrite f4 // => uy; case: pb; rewrite -f1 - uy uv.
    have f8: inc (g1 f) (permutations I).
      by apply /Zo_P;split => //; rewrite /g1;apply /fun_set_P;red;aw.
    apply /Zo_P; split => // t ti; case: (equal_or_not t y).
      by move => ty; rewrite /g1; aw; rewrite ty f3.
    move => ty; rewrite /g1; aw; rewrite (f4 _ ty).
    apply: nfp; rewrite -pa; fprops.
  move => u v ug4 vg4 sg1.
  move: (ug4) => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [].
  move /fun_set_P => [ff sg tf] bf nfp fn fx.
  move: (vg4) => /Zo_P [] /Zo_P [] /Zo_P [] /Zo_P [].
  move /fun_set_P => [ff' sg' tf'] bf' nfp' fn' fx'.
  apply: function_exten; rewrite ? sg ?sg' ? tf' //.
  move => t; rewrite - pa; case /setU1_P; last by move => ->; rewrite fn fn'.
  move => tI.
  move: (pd _ ug4) (pd _ vg4).
  set y := (Vf (inverse_fun u) (succ n)); move=> [f1 yI f3 f4 f5].
  set y' := (Vf (inverse_fun v) (succ n)); move=> [f1' yI' f3' f4' f5'].
  move: (f_equal (fun z => Vf z t) sg1); rewrite /g1; aw.
  have tsn: t <> succ n by move => h; case: pb; rewrite -h.
  have i1: Vf v (succ n) <> Vf v t.
    have tsv: inc t (source v) by rewrite sg' - pa; fprops.
    have nsv: inc (succ n) (source v) by rewrite sg' - pa; fprops.
    by move => h; case: tsn; rewrite (bij_inj bf' nsv tsv h).
  have i2: Vf u (succ n) <> Vf u t.
    have tsv: inc t (source u) by rewrite sg - pa; fprops.
    have nsv: inc (succ n) (source u) by rewrite sg - pa; fprops.
    by move => h; case: tsn; rewrite (bij_inj bf nsv tsv h).
  case: (equal_or_not t y) => ty.
     rewrite {1 3} ty f3 f1.
    case: (equal_or_not t y'); first by move => ->; rewrite f1'.
    by move => ty'; rewrite (f4' _ ty') - fn'.
  rewrite (f4 _ ty); case: (equal_or_not t y') => ty'; last by rewrite f4'.
  rewrite ty' f3' f1' - fn - ty' => h; by case: i2.
move => y /Zo_P [] /Zo_P [] /fun_set_P [fy sy ty] biy dy.
set xx := Vf (inverse_fun y) x.
 move:(inverse_bij_fb biy) => iyb.
have xty: inc x (target y) by ue.
have xxsf: inc xx (source y).
  by move: (Vf_target (proj1 (proj1 iyb))); aw; rewrite ty; apply.
have xxns: xx <> succ n by move => h; case: pb; rewrite -h - sy.
have f1: Vf y xx = x by rewrite /xx inverse_V //.
pose f z := Yo (z = succ n) x (Yo (z = xx) (succ n) (Vf y z)).
have f2: f (succ n) = x by rewrite /f; Ytac0; Ytac0.
have f3: f xx = (succ n) by rewrite /f; Ytac0; Ytac0.
have f4: forall t, t <> succ n -> t <> xx -> f t = Vf y t.
  by move => t t1 t2; rewrite /f; Ytac0; Ytac0.
have f5: f x <> succ n.
  rewrite /f; Ytac0; Ytac xa; first by case: (dy _ xK); rewrite xa f1.
  move => h; case: pb; rewrite -h - ty; Wtac.
have f6: forall t, inc t I' -> inc (f t) I'.
   move => t; rewrite -pa => ti; case: (equal_or_not t (succ n)) => tn.
      rewrite tn f2; fprops.
   case: (equal_or_not t xx) => txx.
      rewrite txx f3; fprops.
   rewrite (f4 _ tn txx); apply /setU1_P; left.
   rewrite -ty; Wtac; rewrite sy; case /setU1_P: ti => //.
have f7: function (Lf f I' I') by apply /lf_function.
have f8: bijection (Lf f I' I').
   apply:bijective_if_same_finite_c_surj; aw; apply /lf_surjective => //.
   move => t; rewrite -pa => /setU1_P; case; last first.
     move => ->; exists xx=> //; rewrite - sy;fprops.
   rewrite - ty => tty; move: (bij_surj biy tty) => [a asy av].
   have asn: a <> succ n by move => h; case: pb; rewrite -h - sy.
   case: (equal_or_not a xx); last first.
      by move =>axx; rewrite ty - sy; exists a;fprops; rewrite -av f4.
   by move => ax; exists (succ n); fprops;rewrite f2 - av ax f1.
have f9: inc (Lf f I' I') G1.
  apply /Zo_P; split; first by apply /Zo_P;split => //;apply /fun_set_P;red;aw.
  move => t ti;aw;
  case: (equal_or_not t (succ n)) => tn; first by rewrite tn f2; fprops.
  case: (equal_or_not t xx) => tx; first by rewrite tx f3; fprops.
  by rewrite (f4 _ tn tx); apply: dy; move: ti; rewrite -pa; case /setU1_P.
have f10: inc (Lf f I' I') G4 by apply /Zo_P; aw;split => //; apply /Zo_P; aw.
have II: sub I I' by rewrite -pa => t ti; fprops.
have f11: Vf (inverse_fun (Lf f I' I')) (succ n) = xx.
  have xxI': inc xx I' by apply: II; rewrite - sy.
  have ->: succ n = Vf (Lf f I' I') xx by aw.
  rewrite inverse_V2 //; aw.
have f12: lf_axiom (g (Lf f I' I')) I I.
  move => t ti; move: (II _ ti) => ti'; rewrite /g; aw;rewrite f11.
  Ytac aux; fprops; rewrite - ty; rewrite (f4 _ _ aux); try Wtac.
  by move => tn; case: pb; rewrite -tn.
have f13: function (Lf (g (Lf f I' I')) I I) by apply: lf_function.
ex_tac; rewrite /g1; apply: function_exten; aw.
rewrite sy => t ti; move: (II _ ti) => ti';rewrite /g;aw.
rewrite f11; Ytac aa ; rewrite ? aa //; rewrite f4//.
by move => tn; case: pb; rewrite -tn.
Qed.

Lemma nbder_pr3 f (g := fun n => (succ n) *c (f n)):
  (f \0c = \1c) -> f \1c = \0c ->
  (forall n, inc n Bnat ->
    f (succ (succ n)) = (succ n) *c (f n +c f (succ n))) ->
  (forall n, inc n Bnat -> (even_int n) -> f n <> \0c)
  /\
  (forall n, inc n Bnat ->
     f (succ n) = Yo (even_int n) (cpred (g n)) (succ (g n))).
Proof.
move => pa pb pc.
move: succ_zero => s0.
move: BS1 => bs1.
have pd': forall n, inc n Bnat -> inc (f n) Bnat /\ inc (f (succ n)) Bnat.
  apply: cardinal_c_induction; first by rewrite s0 pa pb;split;fprops.
  move => n nB [hr1 hr2]; split => //; rewrite(pc _ nB); fprops.
have pd: (forall n, inc n Bnat -> inc (f n) Bnat).
  move => n nb; exact (proj1 (pd' _ nb)).
have pe: (forall n : Set, inc n Bnat -> f (succ (succ n)) <> \0c).
  apply: cardinal_c_induction; first by rewrite (pc _ BS0) s0 pa pb; aw; fprops.
  move => n nB h; move: (BS_succ nB) => h1; rewrite (pc _ h1).
  move: (cpred_pr (pd _ (BS_succ h1)) h) => [pg ->].
  rewrite (csum_via_succ _ pg);apply: cprod2_nz; apply: succ_nz.
have pf: (forall n : Set, inc n Bnat -> even_int n -> f n <> \0c).
  move => n nB en; case: (equal_or_not n \0c).
    move => ->; rewrite pa; fprops.
  move => nz; move: (cpred_pr nB nz) => []; set p := (cpred n) => q1 q2.
  case: (equal_or_not p \0c) => pz.
    by case: odd_one => [] _; rewrite - succ_zero - pz - q2.
  move: (cpred_pr q1 pz) => [pp]; rewrite q2 => ->; fprops.
split; first by exact.
apply: cardinal_c_induction.
  have c1: cardinalp \1c by fprops.
  move: even_zero => h; Ytac0; rewrite /g pa s0 pb -(cpred_pr2 BS0) s0; aw.
move => n nB Hrec.
have snB: inc (succ n) Bnat by fprops.
rewrite (pc _ nB) cprod_sumDl.
set sn := succ n.
have sa: sn +c \1c = succ sn by rewrite Bsucc_rw.
have ->: Yo (even_int sn) (cpred (g sn)) (succ (g sn)) =
   (Yo (even_int sn) (cpred (f sn)) (succ (f sn)))
   +c (sn *c f sn).
   rewrite /g - sa cprod_sumDr csumC (cprod1l (CS_Bnat (pd _ snB))).
   Ytac ok; Ytac0; last by rewrite (csum_via_succ1 _ (pd _ snB)) //.
   case: (equal_or_not (f sn) \0c) => tz.
     by rewrite tz cprod0r (bsum0r BS0) /cpred setU_0 (bsum0r BS0).
   move: (cpred_pr (pd _ snB) tz) => [ta tb].
   rewrite {1} tb csum_via_succ1 // cpred_pr1 //; fprops.
congr (_ +c (sn *c f sn)).
move: (even_odd_succ n) => [qa qb].
rewrite Hrec /g -/sn.
case: (p_or_not_p (even_int n)) => en.
  move: (qa en) => [_] nesn; Ytac0; Ytac0.
  have gnz : sn *c f n <> \0c.
    apply: cprod2_nz; [apply: succ_nz | exact (pf _ nB en)].
  by move: (cpred_pr (BS_prod snB (pd _ nB)) gnz)=> [_].
have on: odd_int n by split.
move: (qb on) => nesn; Ytac0; Ytac0; rewrite cpred_pr1; fprops.
Qed.

Lemma nbder_pr4 n (g := fun n => (succ n) *c (nbder n)):
 inc n Bnat -> nbder (succ n) = Yo (even_int n) (cpred (g n)) (succ (g n)).
Proof.
apply:(proj2 (nbder_pr3 (f:= nbder) nbder_0 nbder_1 nbder_pr2)).
Qed.

Exercise 5.10

Lemma even_compare n p:
  inc p Bnat -> even_int n -> n <=c (\2c *c p) +c \1c -> n <=c (\2c *c p).
Proof.
move => pa pb; rewrite (half_even pb); set m := (n %/c \2c).
move: pb => [pc pd]; move: (BS_quo pc BS2) => mB.
case: (card_le_to_el (CS_Bnat mB) (CS_Bnat pa)) => le1 le2.
   exact (cprod_Mlele (card_leR CS2) le1).
move /(card_le_succ_ltP _ pa): le1 => le3.
have aux: inc (\2c *c p +c \1c) Bnat by fprops.
move: (cprod_Mlele (card_leR CS2) le3); rewrite (Bsucc_rw pa).
rewrite cprod_sumDl (two_times_n \1c) csumA - (Bsucc_rw aux).
move /(card_le_succ_ltP _ aux) => hhg; co_tac.
Qed.

Lemma cardinal_set_of_increasing_functions5 p n:
  inc p Bnat -> inc n Bnat ->
  cardinal(functions_incr (Bint_cco \1c p)(Bint_cco \0c n)) =
  binom (n +c p) p.
Proof.
move => pB nB.
move: (Binto_wor \1c p) (Binto_wor \0c n)=> [a1 a2][a3 a4].
move: (worder_total a1) (worder_total a3).
set r := (Bint_cco \1c p); set r' := (Bint_cco \0c n) => pa pb.
move: (card_Bint1c pB);rewrite /Bint1c - a2.
rewrite -/r => r1.
have pc: finite_set (substrate r) by apply /BnatP; rewrite r1.
move: (card_Bintc nB);rewrite /Bintc - a4.
rewrite -/r' => r2.
have pd: finite_set (substrate r') by apply /BnatP; rewrite r2; fprops.
move: (cardinal_set_of_increasing_functions4 pa pb pc pd).
rewrite r1 r2 (csum_via_succ1 _ nB) (Bsucc_rw (BS_sum nB pB)).
by rewrite (cdiff_pr1 (BS_sum nB pB) BS1).
Qed.

Lemma Exercise5_10 n k
    (o1 := Bint_cco \1c k) (o2 := Bint_cco \1c n)
    (even_odd_fct := fun f =>
       (forall x, inc x (source f) -> even_int x -> even_int (Vf f x))
       /\ (forall x, inc x (source f) -> odd_int x -> odd_int (Vf f x))):
   inc n Bnat -> inc k Bnat ->
   cardinal (Zo (functions_sincr o1 o2) even_odd_fct) =
   binom ((n +c k) %/c \2c) k.
Proof.
move => nB kB; set A := Zo _ _.
set I1:= Bint1c k; set I2:= Bint1c n.
move: (proj2(Binto_wor \1c n)); rewrite -/o2 -/(Bint1c n) -/I2 => sr2.
move: (proj2 (Binto_wor \1c k)); rewrite -/o1 -/(Bint1c k) -/I1 => sr1.
pose EF f z := Yo (z = \0c) \0c (Vf f z).
move: (BS_succ kB); set sk := succ k; move => skB.
have pa: forall f, inc f A -> forall i, i <> \0c -> i <c sk -> inc i (source f).
   move => f /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] _ _ i inz ik.
   rewrite sf sr1; apply /(Bint1cP kB); split => //.
   by apply /(card_lt_succ_leP kB).
have pa': forall f, inc f A -> forall i,
    inc i (source f) -> i <> \0c /\ i <c sk.
   move => f /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] _ _ i.
   rewrite sf sr1; move /(Bint1cP kB) => [p1 p2];split => //.
   by apply /(card_lt_succ_leP kB).
have pb: forall f, inc f A -> (forall i, i <c sk -> inc (EF f i) Bnat).
   move => f fa; move: (fa) => /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] _ _.
   move => i ik; rewrite /EF; Ytac iz; [fprops | move: (pa _ fa _ iz ik)=> isf].
   move: (Vf_target ff isf); rewrite tf sr2; apply: (Bint_S).
have pc: forall f, inc f A -> (forall i j, i <c j -> j <c sk ->
     (EF f i) <c (EF f j)).
   move => f fa i j ij jsk.
   have jnz: j <> \0c by move => jz; case: (card_lt0 (x := i)); ue.
   move: (pa _ fa _ jnz jsk) => jsf.
   move: (fa) => /Zo_P [] /Zo_P [p1 [p2 p3 [p4 p5 p6] p7]] _.
   move: (pb _ fa _ jsk);rewrite /EF; Ytac0 => p8; Ytac iz.
      apply /strict_pos_P1 => //; move: (Vf_target p4 jsf).
      by rewrite p6 sr2; move /(Bint1cP nB) => [].
  move: ij => [lij nij].
  move: (pa _ fa _ iz (card_le_ltT lij jsk)) jsf; rewrite p5 sr1 => qa qb.
  have aux: glt o1 i j by split => //; apply /Binto_gleP.
  by move: (p7 _ _ aux) => [] /Binto_gleP [_ _ aa] bb; split.
have pd: forall f, inc f A -> forall x, inc x (source f) -> x <=c Vf f x.
  move => f fA.
  move: (strict_increasing_prop1 skB (pb f fA) (pc f fA)) => h x xsf.
  by move: (pa' _ fA _ xsf) => [p1 p2]; move: (h _ p2); rewrite /EF; Ytac0.
case: (card_le_to_el (CS_Bnat kB) (CS_Bnat nB)) => lekn; last first.
  have -> : A = emptyset.
    apply /set0_P => f fA.
    move /Zo_P: (fA) => [] /Zo_P [] /fun_set_P [ff sf tf] _ _.
    have ksf: inc k (source f).
       rewrite sf sr1; apply /Bint1cP => //;split;fprops => kz.
       by case: (card_lt0 (x := n)); rewrite - kz.
    move: (Vf_target ff ksf); rewrite tf sr2; move/(Bint1cP nB) => [_ H].
    move: (card_leT (pd _ fA _ ksf) H) => H'; co_tac.
  rewrite cardinal_set0 binom_bad //; first by fprops.
  move: (csum_Mlteq kB kB lekn) => lt1.
  move: (card_division (BS_sum nB kB) BS2 card2_nz).
    set q := ((n +c k) %/c \2c); set r := ((n +c k) %%c \2c).
    move => [s1 s2 [s3 s4]].
  apply: (cprod_lt_simplifiable BS2 s1 kB card2_nz).
  rewrite (two_times_n k); apply: card_le_ltT lt1; rewrite s3.
  exact (Bsum_M0le (BS_prod BS2 s1) s2).
move: (BS_diff k nB) => nkB.
move: (card_division nkB BS2 card2_nz).
set p := (n -c k) %/c \2c; set r := ((n -c k) %%c \2c).
move => [pB rB [p1 p2]].
have ->: (n +c k) %/c \2c = p +c k.
   have aux:card_division_prop (n +c k) \2c (p +c k) r.
     split; last by exact.
     rewrite (csumC p) cprod_sumDl - csumA - p1 (two_times_n k) - csumA.
     by rewrite (cdiff_pr lekn) csumC.
   by rewrite (proj1 (cquorem_pr (BS_sum nB kB) BS2 (BS_sum pB kB) rB aux)).
pose EG f x := ((Vf f x) -c x) %/c \2c.
rewrite -(cardinal_set_of_increasing_functions5 kB pB).
set o3:= Bint_cco \0c p; rewrite -/o1.
set I3 := Bintc p.
have sr3: substrate o3 = I3 by apply: (proj2 (Binto_wor \0c p)).
set B := functions_incr o1 o3.
apply /card_eqP.
exists (Lf (fun f => (Lf (EG f) I1 I3)) A B); split; aw.
have pe: forall f, inc f A ->
      [/\ (forall x, inc x (source f) -> Vf f x = x +c \2c *c (EG f x)),
       lf_axiom (EG f) I1 I3 &
       inc (Lf (EG f) I1 I3) B].
  move => f fA.
  move : (fA) => /Zo_P [] /Zo_P [] /fun_set_P [ff sf tf] ff1 ff2.
  have qa: (forall i : Set, i <c sk -> EF f i <c (n -c k) +c sk).
    move =>i isk; rewrite /sk (csum_via_succ _ kB) csumC (cdiff_pr lekn).
    apply /(card_lt_succ_leP nB); rewrite /EF; Ytac zi; fprops.
    move: (pa _ fA _ zi isk) => isf.
    by move: (Vf_target ff isf); rewrite tf sr2; move/(Bint1cP nB) => [].
  have qb:(forall x, inc x (source f) -> (Vf f x) -c x <=c n -c k).
    move: (strict_increasing_prop3 skB nkB (pb f fA) (pc f fA) qa) => h.
    move => x xsf.
    by move: (pa' _ fA _ xsf) => [p4 p5]; move: (h _ p5); rewrite /EF; Ytac0.
  have qc: forall x, inc x (source f) -> inc (Vf f x -c x) Bnat.
     move => x xsf; exact: (BS_le_int (qb _ xsf) nkB).
  have qd: forall x, inc x (source f) ->x +c (Vf f x -c x) = Vf f x.
     move => x xsf; exact(cdiff_pr (pd _ fA _ xsf)).
  have qe: forall x, inc x (source f) -> even_int ((Vf f x) -c x).
    move => x xsf; move:(qd _ xsf) => h; move:(qc _ xsf) => dB.
    have xB: inc x Bnat by move: xsf; rewrite sf sr1; apply: Bint_S.
    ex_middle od; have oi: odd_int (Vf f x -c x) by split.
    case: (p_or_not_p (even_int x)) => evx.
      move: (proj1 ff2 x xsf evx) => evf.
      by move: (proj32 (even_odd_sum _ _) evx oi); rewrite h ; move => [].
    have oix: odd_int x by split.
    move: (proj2 ff2 x xsf oix) => [_ evf].
    by move: (proj31 (even_odd_sum _ _) oix oi); rewrite h.
  have qf: forall x, inc x (source f) -> Vf f x = x +c \2c *c (EG f x).
    by move => x xsf; rewrite - (qd _ xsf) (half_even (qe _ xsf)).
  have qg: forall x, inc x (source f) -> inc (EG f x) Bnat.
      move => x xsf; apply: (BS_quo (qc _ xsf) BS2).
  have qh: forall x, inc x I1 -> inc (EG f x) I3.
     rewrite - sr1 - sf => x xsf; suff: Vf f x -c x <=c \2c *c p.
       rewrite (half_even (qe _ xsf)) => h.
       apply /(BintcP pB).
       exact(cprod_le_simplifiable BS2 (qg _ xsf) pB card2_nz h).
    have aux: cardinalp (\2c *c p) by fprops.
    move: (qb _ xsf); rewrite p1; case: (card_lt2 p2) => ->; aw.
    apply: (even_compare pB (qe _ xsf)).
  have qi: increasing_fun (Lf (EG f) I1 I3) o1 o3.
    red; aw; split => //.
          by move: (Binto_wor \1c k) => [[]].
        by move: (Binto_wor \0c p) => [[]].
      by split;aw; try ue; apply: lf_function.
    move => i j /Binto_gleP [iI jI ij];aw; apply/Binto_gleP; split => //.
        by apply: qh.
      by apply: qh.
    have isf: inc i (source f) by rewrite sf sr1.
    have jsf: inc j (source f) by rewrite sf sr1.
    move: (pa' _ fA _ isf) (pa' _ fA _ jsf) => [s1 s2][s3 s4].
    move: (strict_increasing_prop2 skB (pb f fA) (pc _ fA) ij s4).
    rewrite /EF; Ytac0; Ytac0.
    rewrite (half_even (qe _ isf)) (half_even (qe _ jsf)).
    apply: (cprod_le_simplifiable BS2 (qg _ isf) (qg _ jsf) card2_nz).
  split; [exact | exact | apply /Zo_P;split => //;apply/fun_set_P;red;aw].
  move: qi => [_ _[fh _ _] _]; split => //.
apply: lf_bijective.
    by move => f fA;move: (pe _ fA) => [_ _].
  move => u v uA vA sv; move: (pe _ uA) (pe _ vA) => [a1 e1 _][a2 e2 _].
  move /Zo_P: uA => [] /Zo_P [] /fun_set_P [u1 u2 u3] _ _.
  move /Zo_P: vA => [] /Zo_P [] /fun_set_P [v1 v2 v3] _ _.
  apply: function_exten => //; try ue.
  move => i isu /=; rewrite (a1 _ isu).
  rewrite u2 - v2 in isu; rewrite (a2 _ isu).
  by rewrite v2 sr1 in isu; move: (f_equal (Vf^~ i) sv); aw => ->.
move => y /Zo_P [] /fun_set_P [fy sy tg] incy.
set f := Lf (fun i => i +c \2c *c (Vf y i)) I1 I2.
have qa: lf_axiom (fun i : Set => i +c \2c *c Vf y i) I1 I2.
  move => i i1; move: (i1) => /(Bint1cP kB) [qa qb].
  apply /(Bint1cP nB); split.
    move: (cpred_pr (BS_le_int qb kB) qa) => [sa sb].
    rewrite {1} sb (csum_via_succ1 _ sa); apply: succ_nz.
  rewrite - (cdiff_pr lekn); apply: (csum_Mlele qb); rewrite p1.
  apply: card_leT (Bsum_M0le (BS_prod BS2 pB) rB).
  apply: (cprod_Mlele (card_leR CS2)); apply /(BintcP pB).
  by rewrite -/I3- sr3 -tg; Wtac; rewrite sy sr1.
have ff: function f by apply: lf_function.
have eof: even_odd_fct f.
   have aux: forall x, inc x I1 -> even_int (\2c *c Vf y x).
      move => x x1; apply: even_double.
      have aux: inc (Vf y x) I3 by rewrite - sr3 - tg; Wtac; rewrite sy sr1.
      apply: (Bint_S aux).
   red; rewrite /f; aw;split => x xsf; aw => ex.
       exact: (proj33 (even_odd_sum _ _) ex (aux _ xsf)).
   rewrite csumC; exact (proj32 (even_odd_sum _ _) (aux _ xsf) ex).
have fa: inc f A.
  apply /Zo_P; split; last by exact.
  apply /Zo_P; split; first by rewrite/f; apply /fun_set_P;red;aw;split => //.
  rewrite /f; red;split;aw.
          by move: (Binto_wor \1c k) => [[]].
        by move: (Binto_wor \1c n) => [[]].
      split;aw => //.
    move: incy => [_ _ _ s6].
    move => i j [] q1; move: (s6 _ _ q1) => /Binto_gleP [a1 a2 q7].
    move /Binto_gleP: q1 => [q1 q2 q3] q4; aw.
    have [q5 q6]: i +c \2c *c Vf y i <c j +c \2c *c Vf y j.
      move: (BS_prod BS2 (Bint_S a1)) (BS_prod BS2 (Bint_S a2)) => a3 a4.
      rewrite (csumC i) (csumC j); move: (cprod_Mlele (card_leR CS2) q7) => q8.
      apply: (csum_Mlelt a4 (Bint_S q2) q8 (conj q3 q4)).
    split; [apply /Binto_gleP;split => //; by apply: qa | done ].
exists f => //.
move: (pe _ fa) => [sa sb sc].
symmetry;apply: function_exten; aw; try ue; first by apply: lf_function.
move => i iI1 /=; aw; rewrite /EG /f /=; aw.
have aux: inc (Vf y i) I3 by rewrite - sr3 - tg; Wtac; rewrite sy sr1.
have iB: inc i Bnat by apply: (Bint_S iI1).
have fiB: inc (Vf y i) Bnat by apply: (Bint_S aux).
rewrite csumC (cdiff_pr1 (BS_prod BS2 fiB) iB).
apply: (cdivides_pr4 BS2 fiB card2_nz).
Qed.


Section 6

Exercise 6.1

Lemma Exercise_6_1 E: infinite_set E <->
  (forall f, function_prop f E E ->
    exists S, [/\ sub S E, nonempty S, S <> E & sub (image_by_fun f S) S]).
Proof.
split.
  move=> iE f [ff sf tf].
  case: (emptyset_dichot E).
    have fce: finite_c (cardinal emptyset).
    rewrite cardinal_set0 -/BnatP; fprops.
   by move=> nE;rewrite nE in iE; case: (infinite_dichot2 fce).
   move=> [y yE].
  have p1: (forall u, inc u E -> inc (Vf f u) E) by rewrite -{1} sf -tf; fprops.
  move:(induction_defined_pr (fun n => Vf f n) y).
  move: (integer_induction_stable yE p1).
  set g:=induction_defined _ _; set (F:= target g).
  move=> stg [sg sjg g0 gs].
  have fg: function g by fct_tac.
  have yF: inc y F by rewrite -g0;apply: Vf_target => //; ue.
  have sFf:sub F (source f) by ue.
  have fF: (sub (image_by_fun f F) F).
    move=> t /(Vf_image_P ff sFf) [u uF ->].
    move: ((proj2 sjg) _ uF); rewrite sg; move => [n ns <-].
    by rewrite -gs//;apply:Vf_target;[ fct_tac |rewrite sg; apply: BS_succ].
  set (G:=image_by_fun f F).
  have sgg: sub (image_by_fun f G) G.
    have aux:sub (image_by_fun f F) (source f) by apply: (@sub_trans F).
    move=> t /(Vf_image_P ff aux) [u ui ->]; apply /(Vf_image_P ff sFf).
    exists u;fprops.
  exists G; split => //; first by apply: (@sub_trans F) =>//.
     exists (Vf f y); apply /(Vf_image_P ff sFf); ex_tac.
  move=> GE; move: yE; rewrite -GE;move=> /(Vf_image_P ff sFf)[u uF Wu].
  move: ((proj2 sjg) _ uF) => [x0 x0g Wx].
  rewrite sg in x0g; move: Wu; rewrite -Wx -gs //.
  set (k:= succ x0).
  move=> Wy.
  have kB: (inc k Bnat) by apply: BS_succ.
  have rec1: (forall i, inc i Bnat -> Vf g i = Vf g (i +c k)).
    have ck: cardinalp k by fprops.
    apply: cardinal_c_induction; aw; first by rewrite g0 Wy.
    move => n nB; rewrite (gs _ nB) (csumC (succ n) _) csum_via_succ //.
    move ->; rewrite csumC gs //; fprops.
  have rec2: (forall i, inc i Bnat -> forall j, inc j Bnat ->
     Vf g i = Vf g (i +c (j *c k))).
    move => i iB; apply: cardinal_c_induction.
      rewrite cprodC cprod0r csum0r //; fprops.
    move=> n nB. rewrite (cprodC (succ n) _) cprod_via_sum // csumA.
    rewrite cprodC -rec1 //; fprops.
  have rec4: (forall z, inc z E -> exists2 m, cardinal_lt m k & z = Vf g m).
    move=> z; rewrite -GE;move=> /(Vf_image_P ff sFf) [w w1 w2].
    move: ((proj2 sjg) _ w1) => [x xsg w3].
    rewrite sg in xsg;move: w2; rewrite -w3 -gs //; move => ->.
    have sxB: (inc (succ x) Bnat) by fprops.
    have knz: (k <> \0c) by apply: succ_nz.
    move: (card_division_exists sxB kB knz) => [q [r [qB rB [pa pb]]]].
    rewrite pa; exists r=> //; rewrite csumC cprodC -rec2 //.
  have sisg: sub (Bint k) (source g).
    rewrite sg; apply: Bint_S1.
  have sEi: (sub E (image_by_fun g (Bint k))).
    move=> t tE; move: (rec4 _ tE) => [m ml ->].
    by apply /(Vf_image_P fg sisg); exists m => //; apply /BintP.
  have fsi: (finite_set (Bint k)) by apply: finite_Bint.
  move: (finite_image_by fg sisg fsi) => fs2.
  move: (sub_finite_set sEi fs2) => fs3.
  case: (infinite_dichot2 fs3 iE).
move=> h; case: (finite_dichot1 E) => //.
rewrite /finite_set; set (n:= cardinal E); move /BnatP => nB.
have:(equipotent (Bint n) E).
  apply /card_eqP; rewrite card_Bint //.
move=> [y [bjy sy ty]].
case: (emptyset_dichot E) => neE.
  have fpi: (function_prop (identity E) E E).
     split => //;aw; apply: identity_f.
  move: (h _ fpi) => [F [FE [t tF] _]];empty_tac1 t.
have nz: n <> \0c by apply: cardinal_nonemptyset1.
set (f:= fun i => card_rem (succ i) n).
set In := (Bint n).
have Ha: forall i, inc i Bnat -> inc (card_rem i n) In.
  move=> i iB. apply /(BintP nB).
  by move: (card_division iB nB nz) => [_ _ [_]].
have Hb:sub In Bnat by apply: Bint_S1.
have Hc:(forall i, inc i In -> inc (f i) In).
  by move=> i iI; apply: Ha; apply: BS_succ; apply: Hb.
move: (inverse_bij_fb bjy).
move: (ifun_s y) (ifun_t y).
rewrite sy ty;set x := (inverse_fun y) => sx tx bx.
have fx: function x by fct_tac.
have fy: function y by fct_tac.
set (g:= fun u => Vf y (f (Vf x u))).
have ta: (lf_axiom g E E).
  rewrite /g -{1} sx -ty; move=> t tsx /=; apply: Vf_target =>//.
  rewrite sy;apply: Hc; rewrite /In -tx; fprops.
set (g1:= Lf g E E).
have fg1: (function g1) by apply: lf_function.
have fpg1: function_prop g1 E E by split => //; rewrite /g1; aw.
move: (h _ fpg1) => [F [FE [u uF] nFE Fsg]].
set (i:= Vf x u).
have iN: inc i In.
  by rewrite /In -tx; apply: Vf_target => //; rewrite sx; apply: FE.
have iB: (inc i Bnat) by apply: Hb.
have WiF: inc (Vf y i) F.
  rewrite /i; move: (FE _ uF); rewrite -ty => uty.
  by rewrite (inverse_V bjy uty).
have Hd: (forall j, inc j Bnat -> inc (Vf y (card_rem (i +c j) n)) F).
  apply: cardinal_c_induction.
    rewrite bsum0r //.
     have dp:(card_division_prop i n \0c i).
       split; first by rewrite cprod0r bsum0l //.
       by move: iN => /(BintP nB).
     by move: (cquorem_pr iB nB BS0 iB dp) => [_ ] <-.
  move => m mB.
  have imB: inc (i +c m) Bnat by fprops.
  set (v:= card_rem (i +c m) n) => WvF.
  have vB: inc v Bnat by rewrite /v; fprops.
  have : (inc (Vf g1 (Vf y v)) F).
    have aux: sub F (source g1) by rewrite /g1;aw.
    apply: Fsg; apply /(Vf_image_P fg1 aux); ex_tac.
  rewrite /g1; aw; last (by apply: (FE _ WvF)); rewrite /g.
  move: (Ha _ (BS_sum iB mB)); rewrite /In - sy -/v => vs.
  rewrite (inverse_V2 bjy vs).
  have <-: (card_rem (succ v) n = card_rem (i +c (succ m)) n) => //.
  rewrite -/(eqmod _ _ n) csum_via_succ //; apply: eqmod_succ => //.
  by rewrite /v /eqmod; symmetry; apply: eqmod_rem.
case: nFE; apply: extensionality => //.
rewrite -ty; move=> t tE.
move: (bjy) => [_ sjy].
move: ((proj2 sjy) _ tE) => [v vsy <-].
move: vsy; rewrite sy => /(BintP nB) vn.
move: iN => /(BintP nB) [lein _].
move: (f_equal (fun z => (z +c v)) (cdiff_pr lein)).
move: (vn) => [len _ ]; move: (BS_le_int len nB) => vB.
rewrite - csumA; set k:= _ +c v => aux.
have kb: inc k Bnat by rewrite /k; fprops.
have dp:(card_division_prop (i +c k) n \1c v) by split; aw; fprops.
move: (cquorem_pr (BS_sum iB kb) nB BS1 vB dp) => [_ ] ->.
by apply: Hd.
Qed.

Fixpoint chain_val x :=
  match x with chain_pair u v => singleton u
    | chain_next u v => chain_val v +s1 u
 end.

Fixpoint sub_chain x y :=
  match y with
    chain_pair u v => x = y
   | chain_next u v =>
     x = y \/ sub_chain x v
end.

Lemma sub_chainedP R p q: sub_chain p q -> chained_r R q ->
     chained_r R p /\ chain_tail p = chain_tail q.
Proof.
move => p1 p2; split.
  move: p1 p2; elim q => a x /=; first by move => -> /=.
  move => Hrec; case => aux; first by rewrite aux /= => [].
  by move => [p1 p2]; apply: Hrec.
clear p2; move: p1; elim: q => a x /=; first by move => -> /=.
move => Hrec; case => aux; [ by rewrite aux | by apply: Hrec].
Qed.

Lemma chained_prop1 g a c:
  chained_r (fun a b => a = g b) c -> chain_tail c = a ->
      sub_chain (chain_pair (g a) a) c.
Proof.
elim:c => b x /=; first by move => -> ->.
by move => Hrec [p1 p2] p3; right; apply: Hrec.
Qed.

Lemma chained_prop2 g p c:
  chained_r (fun a b => a = g b) c -> sub_chain p c ->
   p = c \/ sub_chain (chain_next (g (chain_head p)) p) c.
Proof.
elim:c => a c /=; first by left.
move => Hrec [p1 p2]; case => p3; first by left.
case: (Hrec p2 p3); last by right; right.
by move => epc; right; left; rewrite epc -p1.
Qed.

Lemma chain_valP x i: inc i (chain_val x) <->
  (exists2 p, sub_chain p x & i = chain_head p).
Proof.
split.
  elim:x => a x /=.
    by move /set1_P ->; exists (chain_pair a x).
  move => Hrec /setU1_P; case => aux.
    by move: (Hrec aux) => [p p1 p2]; exists p => //; right.
   by exists (chain_next a x) => //; left.
move => [p].
elim: x => a x /=; first by move => -> -> /=; fprops.
move => Hrec p1 p2; case: p1; first by rewrite p2; move => -> /=; fprops.
by move => p3; apply /setU1_P; left; apply: Hrec.
Qed.

Lemma chain_val_finite x: finite_set (chain_val x).
Proof.
elim: x => [pa pb /=| pa pb /= Hrec]; first by apply: set1_finite.
by apply: setU1_finite.
Qed.

Lemma Exercise_6_1bis E f: infinite_set E -> function_prop f E E ->
    exists S, [/\ sub S E, nonempty S, S <> E & sub (image_by_fun f S) S].
Proof.
move => /infinite_setP pa [pb pc pd]; pose g x := Vf f x.
have qa: forall x, inc x E -> inc (g x) E.
   move => x; rewrite - {1} pc - pd /g => xsf; Wtac.
case: (emptyset_dichot E).
  move => ee; rewrite ee in pa.
  have fce: finite_c (cardinal emptyset) by rewrite cardinal_set0; fprops.
  case: (infinite_dichot1 fce pa).
move=> [y0 y0E]; pose y := g y0.
have yE: inc y E by apply: qa.
pose stable S := forall x, inc x S -> inc (g x) S.
pose chained := chained_r (fun a b => a = g b).
set S := Zo E (fun z => exists p, [/\ chained p, chain_tail p = y0 &
   (chain_head p) = z]).
have q0: forall p, chained p -> chain_tail p = y0 -> inc (chain_head p) E.
   elim => c p //= ; [ by move => -> -> | move => Hrec [] -> rb rc].
   by apply:qa; apply: Hrec.
have q1: sub S E by apply: Zo_S.
have q2: nonempty S by exists y; apply/Zo_i => //; exists (chain_pair y y0).
have q3: stable S.
   move => t /Zo_P [tE [c [c1 c2 c3]]]; apply/Zo_P; split => //.
       by apply: qa.
   by exists (chain_next (g t) c);split => //; rewrite - c3.
have q4:forall S, sub S E -> stable S -> sub (image_by_fun f S) S.
   move => s se ss.
   have aux: sub s (source f) by ue.
   by move => t /(Vf_image_P pb aux) [u us ->]; apply: ss.
case: (equal_or_not S E) => nse; last by exists S;split;fprops.
have: inc y0 S by ue.
move /Zo_P => [_] [c0 [c1 c2 c3]].
set A:= chain_val c0.
have yA: inc y A.
  by apply /chain_valP; exists (chain_pair y y0) => //;apply chained_prop1.
have sa: stable A.
  move => s /chain_valP [p p1 ->]; case: (chained_prop2 c1 p1) => sq.
  rewrite sq c3; exact yA.
  by apply /chain_valP; exists (chain_next (g (chain_head p)) p).
have sas: sub A E.
  move => t /chain_valP [p p1 p2].
  move: (sub_chainedP p1 c1); rewrite c2 p2; move => [xx1 xx2].
  by apply: q0.
have ae: A <> E.
  move => bad.
  have : finite_set A by apply: chain_val_finite.
  by rewrite bad => fse; exact:(infinite_dichot1 fse pa).
exists A;split => //; [ by exists y | by apply: q4].
Qed.

Exercise 6.2

Lemma exercice6_2 a b c d:
  a <c c -> b <c d -> ((a +c b) <c (c +c d) /\ (a *c b) <c (c *c d)).
Proof.
move=> ac bd.
wlog: a b c d ac bd / ( c <=c d).
  move=> h.
  have cc: cardinalp c by co_tac.
  have cd: cardinalp d by co_tac.
  case: (card_le_to_ee cc cd) => aux.
    by apply: h.
  by rewrite csumC (csumC c _) cprodC (cprodC c _); apply: h.
move=> cd.
have cnz: c <> \0c.
   move=> cz; rewrite cz in ac; exact: (card_lt0 ac).
have cad: cardinalp d by co_tac.
case: (finite_dichot cad) => fcd.
  move: ac => [ac _].
  have dB: inc d Bnat by apply /BnatP.
  have bB: inc b Bnat by Bnat_tac.
  have cB: inc c Bnat by Bnat_tac.
  have aB: inc a Bnat by Bnat_tac.
  split; [ apply: csum_Mlelt => // | apply: cprod_Mlelt => //].
rewrite (cprodC c d) (csumC c d).
rewrite (product2_infinite cd fcd cnz) (sum2_infinite cd fcd).
have caa: cardinalp a by co_tac.
have cab: cardinalp b by co_tac.
have fcz: finite_c \0c by rewrite -/BnatP; fprops.
wlog : / (infinite_c b /\ cardinal_le a b); last first.
  move=> [fcb leab].
  split; first by rewrite csumC (sum2_infinite leab fcb).
  rewrite cprodC; case: (equal_or_not a \0c) => az.
    by rewrite az cprod0r; apply: finite_lt_infinite.
  by rewrite (product2_infinite leab fcb az).
move=> wwlog; case: (finite_dichot caa) => fca.
  case: (finite_dichot cab) => fcb.
    move: fca fcb; rewrite -!/BnatP => aB bB.
    split; apply: finite_lt_infinite => //;rewrite - /BnatP; fprops.
  move: (finite_le_infinite fca fcb) => ab; apply: wwlog;split => //.
case: (card_le_to_ee caa cab) => ba.
  case: (finite_dichot cab) => fcb.
   move: (finite_lt_infinite fcb fca) => ltab; co_tac.
  apply: wwlog;split => //.
have ltad: cardinal_lt a d by co_tac.
split; first by rewrite (sum2_infinite ba fca).
case: (equal_or_not b \0c) => bz.
  by rewrite bz cprod0r; apply: finite_lt_infinite.
by rewrite (product2_infinite ba fca bz).
Qed.

Exercise 6.3

Lemma Exercise6_3 E: infinite_set E ->
  (powerset E) \Eq (Zo (powerset E) (fun z => z \Eq E)).
Proof.
move=> isE; set Qo:= Zo _ _.
apply /card_eqP;apply: card_leA; last first.
  have sQ: (sub Qo (powerset E)) by apply: Zo_S.
  apply: (sub_smaller sQ).
set (n:= cardinal E).
have cnn: (n +c n = n).
  have cnn: (cardinal_le n n) by rewrite /n; fprops.
  move: isE => /infinite_setP isE.
  apply: (sum2_infinite cnn isE).
have enE: equipotent n E by rewrite /n; fprops.
set (E1:= E *s1 C0).
set (E2:= E *s1 C1).
have eq1: (equipotent E1 n) by eqtrans E; eqsym; rewrite /E1; fprops.
have eq2: (equipotent E2 n) by eqtrans E; eqsym; rewrite /E2; fprops.
have d12: (disjoint E1 E2) by apply: disjointU2_pr; fprops.
move: (csum2_pr5 d12); rewrite - csum2_pr2a - csum2_pr2b.
move /card_eqP: (eq1) => ->; move /card_eqP: (eq2) => ->.
rewrite csum2_pr2a csum2_pr2b cnn; move /card_eqP.
move=> [g [bg sg tg]].
have fg: function g by fct_tac.
pose barX X:= ((X *s1 C0) \cup E2).
pose f X := image_by_fun g (barX X).
have barXp: forall X, sub X E -> sub (barX X) (source g).
  move => X XE s; rewrite sg; case /setU2_P => //; last by fprops.
    move/indexed_P=> [ps PX Qs]; apply /setU2_P;left; apply /indexed_P; aw.
    by split => //; apply XE.
have sfE:(forall X, sub X E -> sub (f X) E).
   move=> X XE t; move: (barXp _ XE) => bE; move /(Vf_image_P fg bE).
   rewrite -tg;move=> [u ub ->]; apply: Vf_target => //;apply: bE => //.
have ei: (forall X, sub X E -> equipotent (f X) E).
  move=> X XE; move: (sfE _ XE) => ssfE.
  set (b:= image_by_fun g E2).
  have s1: sub b (f X) by apply: dirim_S; apply: subsetU2r.
  move : (sub_smaller ssfE) (sub_smaller s1) => le1 le2.
  have sE2: (sub E2 (source g)) by rewrite sg;apply: subsetU2r.
  move: (bg) => [bg1 _].
  move: (equipotent_restriction1 sE2 bg1); rewrite -/b.
  have: (cardinal E2 = cardinal E). apply /card_eqP; eqtrans n.
  move => ha /card_eqP; rewrite ha => cc.
  rewrite - cc in le2; apply /card_eqP; co_tac.
have ta: (lf_axiom f (powerset E) Qo).
  move => X /setP_P XE; apply: Zo_i;fprops;apply /setP_P; apply: sfE =>//.
set (F:= Lf f (powerset E) Qo).
have ->: (powerset E = source F) by rewrite /F; aw.
have ->: (Qo = target F) by rewrite /F; aw.
apply: incr_fun_morph.
apply: lf_injective => // a b /setP_P aE /setP_P bE; move: aE bE.
suff: forall u v, sub u E -> sub v E -> f u = f v -> sub u v.
  move=> h ae ve sf; apply: extensionality; apply: h => //.
move => u v uE vE sf t tu.
have p1: (inc (J t C0) (barX u)) by apply :setU2_1;apply :indexed_pi.
move: (barXp _ uE) => p2; move: (barXp _ vE) => p2a; move: (p2 _ p1) => p3.
have :(inc (Vf g (J t C0)) (f u)) by apply/(Vf_image_P fg p2); ex_tac.
rewrite sf => /(Vf_image_P fg p2a) [w wb wv]; move: (p2a _ wb)=> wsg.
move: bg => [[_ ig] _]; move: (ig _ _ p3 wsg wv) => wv2.
move: wb; rewrite - wv2 => /setU2_P; case; move /indexed_P => [_]; aw.
by move => _ bad; case: TP_ne.
Qed.

Exercise 6.4

Lemma infinite_powerset E:
  infinite_set E -> infinite_set (powerset E).
Proof.
move=> iE; move: (cantor (CS_cardinal E)) => lt1.
case: (finite_dichot1 (powerset E)) => //.
rewrite /finite_set card_setP => ha; move: iE => /infinite_setP iE.
move: (finite_le_infinite ha iE).
have ->: (\2c ^c E = \2c ^c (cardinal E)) by apply: cpow_pr; fprops.
move=> aux; co_tac.
Qed.

Lemma Exercise6_4 E: infinite_set E ->
   (partitions E) \Eq (powerset E).
Proof.
move=> ifE.
set (q:=partitions E).
set (f:= Lf (fun y=> partition_relset y E) q (powerset (coarse E))).
have injf: (injection f).
  apply: lf_injective.
    by move=> t tp;apply /setP_P; apply: sub_part_relsetX; move: tp =>/Zo_P [].
  move=> u v => /Zo_P [] /setP_P uE puE /Zo_P [] /setP_P vE pvE sp.
  by symmetry;apply: (part_relset_anti pvE puE).
move: (incr_fun_morph injf); rewrite /f; aw.
have -> :cardinal (powerset (coarse E)) = cardinal (powerset E).
  rewrite ! card_setP /coarse; apply: cpow_pr; fprops.
  apply /card_eqP; rewrite - cprod2_pr1.
  transitivity ((cardinal E) *c (cardinal E)).
     by apply: cprod2_pr2; rewrite double_cardinal.
  by apply:square_of_infinite => //; apply /infinite_setP.
move=> le1.
case: (emptyset_dichot E) => neE.
  move: ifE;rewrite neE; move /infinite_setP; rewrite cardinal_set0.
  move=> bad; case: (infinite_dichot1 finite_zero bad).
move: neE => [y yE].
set (F:= E -s1 y).
pose g u := doubleton u (E -s u).
have yF: ~(inc y F) by move /setC1_P => [].
have ig: (forall u v , sub u F -> sub v F -> g u = g v -> u = v).
  rewrite /g;move=> u v uF vF sg; case: (doubleton_inj sg); first by case.
  move=> [uc vc].
  case: (yF); apply: uF; rewrite uc; apply /setC_P.
  by split => // yv; move: (vF _ yv).
have pa: (forall u, sub u F -> nonempty u -> inc (g u) q).
  move=> u uF neu.
  have uE: (sub u E) by apply: (@sub_trans F)=> //; apply: sub_setC.
  rewrite /g;apply /partitionsP; split; last first.
    move=> a; case /set2_P;move => -> //; exists y; apply /setC_P;split;fprops.
  split; first by rewrite -/(_ \cup _) setU2_Cr.
  have dc: forall u, disjoint u (E -s u).
    by move => w; apply: disjoint_pr; move=> t tw; apply /setC_P; case.
  move=> a b; case/set2_P => p1; case /set2_P=> p2;
     rewrite ? p1 ?p2 /disjointVeq; fprops.
   right;apply: disjoint_S; apply: dc.
set (T:= (powerset F) -s1 emptyset).
have ct: (cardinal_le (cardinal T) (cardinal q)).
  apply /eq_subset_cardP1 /eq_subset_ex_injP; exists (Lf g T q); split;aw.
  apply: lf_injective.
    by move=> t /setC1_P [] /setP_P tF te;apply: pa => //;apply /nonemptyP.
  by move=> u v /setC1_P [] /setP_P uf _ /setC1_P [] /setP_P vf _; apply: ig.
move: (cardinal_setC1_inf y ifE); rewrite -/F => cEF.
have ipF: (infinite_set (powerset F)).
  apply: infinite_powerset; move: ifE => /infinite_setP; rewrite cEF.
  by move /infinite_setP.
move: ct; rewrite - (cardinal_setC1_inf emptyset ipF).
have ->: (cardinal (powerset F) = cardinal (powerset E)).
  rewrite ! card_setP; apply: cpow_pr; fprops.
  by apply /card_eqP.
move=> le2; apply /card_eqP; co_tac.
Qed.

Exercise 6.5

Lemma product2_infinite3 E F: nonempty E ->
   (cardinal E) <=c (cardinal F) -> infinite_set F ->
   (F \times E) \Eq F.
Proof.
move=> [a aE] le1 infF.
have pa: (cardinal E <> \0c).
 move=> aux; move: (cardinal_nonemptyset aux) => fE; empty_tac1 a.
move: infF => /infinite_setP infF.
move: (product2_infinite le1 infF pa) => hh.
apply /card_eqP.
by rewrite - cprod2_pr1 -hh;apply: cprod2_pr2;rewrite double_cardinal.
Qed.

Lemma Exercise6_5a E F:
  (cardinal (functions E F)) <=c (cardinal (sub_functions E F)).
Proof.
apply: sub_smaller.
move=> t /fun_set_P [pa pb pc];apply /sfun_set_P;split => //;rewrite pb; fprops.
Qed.

Lemma Exercise6_5b E F:
  (cardinal (sub_functions E F)) <=c (cardinal (powerset (product E F))).
Proof.
have injf:
 injection (Lf graph (sub_functions E F) (powerset (product E F))).
  apply: lf_injective.
    by move=> t ta; apply /setP_P;apply: graph_of_function_sub.
  move=> u v /sfun_set_P [y yp yq] /sfun_set_P [z zp zq] h.
  apply: function_exten1 => //; ue.
move: (incr_fun_morph injf); aw.
Qed.

Lemma Exercise6_5c E: infinite_set E ->
  (cardinal (permutations E)) <=c (cardinal (powerset E)).
Proof.
move=> isE.
set C:= (functions E E).
have pb: sub (Zo C bijection) C by apply: Zo_S.
apply: (card_leT (sub_smaller pb)).
apply: (card_leT (Exercise6_5a E E)).
case: (emptyset_dichot E) => neE.
  have ->: (sub_functions E E = singleton (identity E)).
  apply: set1_pr.
    apply /sfun_set_P; aw;split;fprops.
    move => z /sfun_set_P [sa sb sc]; apply /function_exten;aw; fprops.
      apply: extensionality => //; rewrite neE;fprops.
    by move => t te; move: (sb _ te); rewrite neE => /in_set0.
  rewrite cardinal_set1; apply: card_ge1; fprops => bad.
  move: (cardinal_nonemptyset bad) => bad1; empty_tac1 E; aw; apply /setP_Ti.
have cle2: cardinal_le (cardinal E) (cardinal E) by fprops.
move: (Exercise6_5b E E) (product2_infinite3 neE cle2 isE) => ca cb.
have -> : (cardinal (powerset E) = cardinal (powerset (product E E))) => //.
symmetry;rewrite !card_setP; apply: cpow_pr; fprops.
Qed.

Lemma Exercise6_5d E: infinite_set E ->
  (cardinal (derangements E)) <=c (cardinal (powerset E)).
Proof.
move => h.
have : sub (derangements E) (permutations E) by apply: Zo_S.
move /sub_smaller => p1.
move: (Exercise6_5c h) => p2; co_tac.
Qed.

Lemma Exercice6_5e E F h:
   bijection h -> source h = E -> target h = F ->
   (forall f, inc f (derangements F) ->
    inc ((inverse_fun h) \co (f \co h)) (derangements E)).
Proof.
move=> bh sh tg f /Zo_P [/Zo_P [/fun_set_P [ff sf tf] bf] nfx].
set g := _ \co _.
have co: f \coP h by split => //; [fct_tac | ue].
have b1: bijection (f \co h) by apply: compose_fb.
move: (inverse_bij_fb bh) => ihb.
have co1: (inverse_fun h) \coP (f \co h).
  split => //; try fct_tac; aw; ue.
have bg: bijection g by apply: compose_fb.
apply: Zo_i.
  apply: Zo_i => //; apply /fun_set_P;split => //;try fct_tac; rewrite /g; aw.
rewrite - sh /g;move => x xE; aw.
set y:= (Vf f (Vf h x)) => eq1.
have pe: inc (Vf h x) (source f) by rewrite sf -tg; Wtac; fct_tac.
have pd: inc y (target h) by rewrite /y tg -tf; Wtac.
rewrite sf in pe; move: (nfx _ pe); rewrite -/y.
by move: (inverse_V bh pd);rewrite eq1; move => ->; case.
Qed.

Lemma Exercice6_5f E F: E \Eq F ->
  (derangements E) \Eq (derangements F).
Proof.
move => [h [pa pb pc]]; eqsym.
exists (Lf (fun f => ((inverse_fun h) \co (f \co h)))
   (derangements F) (derangements E)).
move: (inverse_bij_fb pa) => bh'.
split;aw; apply: lf_bijective.
    by apply: Exercice6_5e.
  move => u v /Zo_P [] /Zo_P [] /fun_set_P [p1 p2 p3] _ _.
  move => /Zo_P [] /Zo_P [] /fun_set_P [p4 p5 p6] _ _ eq.
  have q1: u \coP h by split => //; try fct_tac; ue.
  have q2: v \coP h by split => //; try fct_tac; ue.
  have q3: function (u \co h) by fct_tac.
  have q4: function (v \co h) by fct_tac.
  have q5: inverse_fun h \coP (u \co h) by split => //; aw;try fct_tac; ue.
  have q6: inverse_fun h \coP (v \co h) by split => //; aw;try fct_tac; ue.
  move: (compf_regr bh' q5 q6 eq) => eq1.
  by move: (compf_regl pa q1 q2 eq1).
move => y yE.
exists (h \co (y \co (inverse_fun h))).
    have eq1:inverse_fun (inverse_fun h) = h by apply: ifun_involutive; fct_tac.
    rewrite -{1} eq1; apply: (Exercice6_5e bh' _ _ yE); aw.
move: yE => /Zo_P [] /Zo_P [] /fun_set_P [pd pe pf] _ _.
have p1: (y \coP inverse_fun h) by split => //;aw;try fct_tac; ue.
have p2: function (y \co inverse_fun h) by fct_tac.
have p3: (h \coP (y \co inverse_fun h)) by split => //;aw;try fct_tac; ue.
set z := (h \co (y \co inverse_fun h)).
have p4: function z by rewrite /z; fct_tac.
have p5: inverse_fun h \coP z by rewrite /z;split => //; aw;try fct_tac.
have p6: z \coP h by rewrite /z;split => //; aw;try fct_tac.
rewrite (compfA p5 p6) (compfA (composable_inv_f pa) p3)(bij_left_inverse pa).
have ->: (source h) = target (y \co inverse_fun h) by aw; rewrite pb pf.
rewrite (compf_id_l p2) - (compfA p1 (composable_inv_f pa)).
by rewrite (bij_left_inverse pa) pb -pe (compf_id_r pd).
Qed.

Lemma Exercice6_5g E: singletonp E \/ nonempty (derangements E).
Proof.
have re: forall F, equipotent F E -> nonempty (derangements F) ->
   nonempty (derangements E).
   move => F /Exercice6_5f/card_eqP h /cardinal_nonemptyset1.
   by rewrite h => h1;apply /nonemptyP => h2; case:h1; rewrite h2 cardinal_set0.
case: (finite_dichot (CS_cardinal E)) => ie; last first.
  move /infinite_setP: (ie) => iE; right.
  pose f z := J (P z) (variant C0 C1 C0 (Q z)).
  pose f':= Lf f (E \times C2)(E \times C2).
  have h: (E \times C2) \Eq E.
    apply: product2_infinite3 => //; first by exists C0; fprops.
    by apply: finite_le_infinite => //; apply: set2_finite.
  apply: (re _ h); exists f'.
  have pa: lf_axiom f (E \times C2) (E \times C2).
    move => x /setX_P [pa pb pc]; rewrite /f; apply: setXp_i=> //.
    rewrite /variant; Ytac s; fprops.
  have pb: forall x, inc x (E \times C2) -> f (f x) = x.
    move => x /setX_P [qa qb qc]; rewrite /f/variant; aw.
    case: (equal_or_not (Q x) C0) => aux; Ytac0; Ytac0.
      by rewrite - aux qa.
    by case /set2_P: qc => // <-; rewrite qa.
  have pc: bijection (Lf f (E \times C2) (E \times C2)).
    apply: lf_bijective => //.
      by move => u v u1 v1 eq; rewrite -(pb _ u1) -(pb _ v1) eq.
    by move => y ys; move: (pa _ ys) => xs; ex_tac; rewrite pb.
  rewrite /f';apply :Zo_i; first apply: Zo_i => //.
    apply /fun_set_P; red; aw;split => //; fct_tac.
  rewrite /f; move => x xi; aw => p; move: (f_equal Q p); aw.
  rewrite /variant; Ytac s; [rewrite s |]; fprops.
set n:= cardinal E.
case: (equal_or_not n \1c) => no; first by left; apply: set_of_card_one.
right.
case: (equal_or_not n \0c) => nz.
  exists (identity E).
  have ->: E = emptyset by apply: cardinal_nonemptyset; ue.
  apply: Zo_i; last by move => x /in_set0.
  apply: Zo_i; first by apply /fun_set_P; apply: identity_prop.
  apply: identity_fb.
move: ie => /BnatP nB.
have pa: equipotent (Bint n) E.
  by move: (card_Bint nB) => /card_eqP.
apply: (re _ pa); set F:= (Bint n).
move: (cpred_pr nB nz) => [pb pc].
pose f x := Yo (x = cpred n) \0c (succ x).
exists (Lf f F F).
have FB: sub F Bnat by apply: Bint_S1.
have ta: forall n, inc n F -> inc (f n) F.
  move => m mF; move: (FB _ mF) => mB; apply /(BintP nB).
  rewrite /f;Ytac mp; first by split; fprops.
  move: mF => /(BintP nB) ltmn.
  split; first by apply /card_le_succ_lt0P => //; co_tac.
  rewrite pc; dneg ms; apply: succ_injective1; fprops.
have injf: surjection (Lf f F F).
  apply: lf_surjective => // y yF.
  case: (equal_or_not y \0c) => yz.
    exists (cpred n); last by rewrite /f; Ytac0.
    apply/(BintP nB); rewrite {1} pc; apply: card_lt_succ; fprops.
  move: (cpred_pr (FB _ yF) yz) => [pyB ysc].
  move: yF => /(BintP nB) [lyn nyn].
  exists (cpred y); rewrite /f -?ysc.
    by apply /(BintP nB); rewrite - card_le_succ_ltP // -ysc.
  by rewrite Y_false//; dneg yn; rewrite ysc pc yn.
apply: Zo_i; first apply: Zo_i;first by apply /fun_set_P;split => //;aw;fct_tac.
  apply: bijective_if_same_finite_c_surj; aw; fprops.
  by red; move: pa; move/card_eqP; rewrite -/F => ->; apply /BnatP.
move => x xf; aw;rewrite /f; Ytac xx.
  by move => aux; move: pc; rewrite -xx -aux succ_zero.
move : (FB _ xf)=> /BnatP /finite_cP; case => _; apply:nesym.
Qed.

Lemma Exercice6_5h E: infinite_set E ->
  equipotent (permutations E) (powerset E).
Proof.
move=> isE.
set s:= (permutations E).
apply /card_eqP; apply: card_leA.
  by apply: Exercise6_5c.
set aux:= ((powerset E) -s (fun_image E singleton)).
have ->: cardinal (powerset E) = cardinal aux.
  rewrite /aux; set A := powerset E; set B:= fun_image _ _.
  have sBA: sub B A.
    by move=> t/funI_P [z zE ->]; apply /setP_P;apply: set1_sub.
  apply /card_eqP;eqsym; move: (cardinal_setC sBA).
  have -> : cardinal B = cardinal E.
    symmetry; apply /card_eqP;exists (Lf singleton E B); split;aw.
    apply: lf_bijective.
        move => t tE; apply /funI_P; ex_tac.
      move=> u v _ _ ss; have : inc u (singleton v) by rewrite - ss; fprops.
      by move /set1_P.
   by move=> y /funI_P.
  set C:= A -s B.
  have cE: cardinalp (cardinal E) by fprops.
  have cC: cardinalp (cardinal C) by fprops.
  move: isE => /infinite_setP isE.
  case: (card_le_to_ee cC cE) => le1.
    move: (cantor cE) => [_ bad].
    rewrite (sum2_infinite le1 isE) /A card_setP => aux1; case: bad.
    rewrite {1} aux1; apply: cpow_pr; fprops.
  case: (finite_dichot cC) => fC.
    move: (le_finite_finite fC le1) => fsE; case: (infinite_dichot1 fsE isE).
  by rewrite csumC (sum2_infinite le1 fC) => /card_eqP.
apply: surjective_cardinal_le.
exists (Lf (fun z => (E -s (invariants z))) s aux).
split;aw; apply: lf_surjective.
  move=> f /Zo_P [] /fun_set_P [ff sf tf] bf.
  apply /setC_P;split => //; first by apply /setP_P => t /setC_P [].
  move /funI_P=> [z zE sc].
  move: (set1_1 z); rewrite - sc; move /setC_P => [_ ze]; case: ze.
  apply: Zo_i; first (by ue).
  rewrite - sf in zE.
  case: (inc_or_not (Vf f z) (invariants f)).
   move /Zo_P => [pa pb]; move: bf => [[_ injf] _]; apply: (injf _ _ pa zE pb).
  move: (Vf_target ff zE); rewrite tf; move=> pa pb.
  have : inc (Vf f z) (singleton z) by rewrite - sc; apply /setC_P;split => //.
  by move /set1_P.
move=> F /setC_P [] /setP_P FE /funI_P ns.
case: (Exercice6_5g F).
   move=> [u ysu]; case: ns; exists u => //; apply: FE; rewrite ysu; fprops.
move=> [f /Zo_P [/Zo_P [pa pb] pc]].
pose g x:= Yo (inc x F) (Vf f x) x.
move: pa pb => /fun_set_P [ff sf tf] [[_ fi] sjf].
have ta: lf_axiom g E E.
  rewrite /g;move=> x xE; simpl; Ytac xf =>//.
  apply: FE; rewrite -tf; apply: Vf_target => //; ue.
have bg: (bijection (Lf g E E)).
  apply: lf_bijective => //.
    move=> u v uE vE; rewrite /g; Ytac uf; Ytac vf.
      by apply: fi; ue.
      by move => eql; rewrite -eql in vf; case: vf; rewrite -tf; Wtac.
      by move => eql; rewrite eql in uf; case: uf; rewrite -tf; Wtac.
      by [].
  move=> y yE; case: (inc_or_not y F) => yF.
    rewrite -tf in yF; move: ((proj2 sjf) _ yF) => [x].
    by rewrite sf => xF <-; move: (FE _ xF) => xE; ex_tac; rewrite /g; Ytac0.
  by exists y => //; rewrite /g; Ytac0.
exists (Lf g E E).
  by apply: Zo_i => //; apply /fun_set_P; split => //; aw; fct_tac.
symmetry;set_extens t.
   by move => /setC_P [tE] /Zo_P; aw;rewrite /g; Ytac tF => //; case.
move => tF; apply /setC_P;split => //; first by apply: FE.
move /Zo_P; rewrite lf_source; move=> [tE]; rewrite /g; aw; Ytac0 => tfi.
by case: (pc _ tF).
Qed.

Lemma Exercice6_5i E: infinite_set E ->
  equipotent (derangements E) (powerset E).
Proof.
move=> isE.
set s:= (permutations E).
apply /card_eqP; apply: card_leA.
  by apply: Exercise6_5d.
set F := E \times C3.
have pa: F \Eq E.
  apply: product2_infinite3 => //; first by exists C2; rewrite /C3; fprops.
  apply finite_le_infinite => //; last by apply /infinite_setP.
  apply: setU1_finite; apply: set2_finite.
move: (Exercice6_5f pa) => /card_eqP <-.
pose fa z := (Yo (z = C0) C1 (Yo (z = C1) C2 C0)).
pose fb z := (Yo (z = C0) C2 (Yo (z = C1) C0 C1)).
pose fc H z := (J (P z) (Yo (inc (P z) H) (fa (Q z)) (fb (Q z)))).
pose f H := Lf(fc H) F F.
suff injf: injection (Lf f (powerset E) (derangements F)).
   move:(incr_fun_morph injf); aw.
have t1: inc C0 C3 by apply /setU1_P; left; fprops.
have t2: inc C1 C3 by apply /setU1_P; left; fprops.
have t3: inc C2 C3 by apply /setU1_P; right; fprops.
move:C2_neC01 TP_ne1 TP_ne => [tpne4 tpne7] tpne5 tpne6.
have tpne3: C1 <> C2 by apply : nesym.
have tpne8: C0 <> C2 by apply:nesym.
have pb: forall v, sub v E -> lf_axiom (fc v) F F.
  move => v vE z /setX_P [za zb zc]; apply: setXp_i => //.
  rewrite /fa/fb; Ytac p1; Ytac p2; fprops; Ytac p3; fprops.
have pc: forall t, inc t E -> inc (J t C0) F by move => t tE;apply /setXp_i.
apply: lf_injective.
  move => u /setP_P uE; move: (pb _ uE) => ax1; rewrite /f.
  have t3d: forall x, inc x C3 -> x <> C0 -> x <> C1 -> x = C2.
    by move => x /setU1_P [] // /set2_P; case.
  have bfu: bijection (f u).
    have fc3: forall y, inc y F -> fc u (fc u (fc u y)) = y.
     move => y /setX_P [p1 p2 p3]; rewrite - {2} p1.
     rewrite /fc !pr1_pair !pr2_pair; apply: f_equal; Ytac pu; Ytac0; Ytac0;
     rewrite /fa/fb; case: (equal_or_not (Q y) C0) => p4; Ytac0;
       try (Ytac0; Ytac0; Ytac0; Ytac0 => //);
      case: (equal_or_not (Q y) C1) => p5; Ytac0;
       try (Ytac0; Ytac0; Ytac0; Ytac0 => //); symmetry; apply: t3d => //.
    apply: lf_bijective => //.
      by move => x y xF yF h; rewrite - (fc3 _ xF) - (fc3 _ yF) h.
      move => y yF; exists (fc u (fc u y)).
        by apply: (ax1); apply: ax1.
        by symmetry;apply: fc3.
  apply: Zo_i.
    by apply: Zo_i => //;apply /fun_set_P; red;aw;split => //; fct_tac.
  move => x xF; rewrite /fc/fa/fb; aw => eq1; move: (f_equal Q eq1); aw.
  Ytac p1; Ytac p2; rewrite ? p2; fprops;Ytac p3; rewrite ? p3; fprops.
move => u v /setP_P uE /setP_P vE sf.
move: (pb _ uE)(pb _ vE) => ax1 ax2.
set_extens t => tu.
  move: (pc _ (uE _ tu)) => pF.
  move: (f_equal (fun z => (Q (Vf z(J t C0)))) sf); rewrite /f/fc;aw.
  Ytac0; Ytac tv => //; rewrite /fa/fb; Ytac0; Ytac0; Ytac0; Ytac0 => //.
move: (pc _ (vE _ tu)) => pF.
move: (f_equal (fun z => (Q (Vf z (J t C0)))) sf); rewrite /f/fc;aw.
by Ytac0; Ytac tv => //; rewrite /fa/fb; Ytac0; Ytac0; Ytac0; Ytac0.
Qed.

Exercise 6.6
Section Exercise6_6.
Variables E F: Set.
Hypothesis Einf: infinite_set E.
Hypothesis leFE: (cardinal F) <=c (cardinal E).
Hypothesis Finf: exists a b, [/\ inc a F, inc b F & a <> b].

Lemma Exercise6_6a:
  exists G, [/\ sub G E, G \Eq E & (E -s G) \Eq F].
Proof.
move: Einf => /infinite_setP => ise1.
move:(sum2_infinite leFE ise1); aw.
move: (disjointU2_pr4 E F); move /card_eqP => pc.
have -> : (cardinal E) +c (cardinal F) = cardinal (E +c F).
  rewrite (@card_card (E +c F)); last by fprops.
  apply: csum2_pr2;apply /card_eqP;try (eqsym; fprops).
rewrite pc; move=> /card_eqP [f [bf sf tf]].
set E1:= E *s1 C0; set F1:= F *s1 C1.
have c1: equipotent E E1 by rewrite /E1; fprops.
have c2: equipotent F F1 by rewrite /F1; fprops.
move: (bf) => [injf sjf].
have sc1: sub E1 (source f) by rewrite sf; apply: subsetU2l.
have sc2: sub F1 (source f) by rewrite sf; apply: subsetU2r.
have ff: function f by fct_tac.
have sc3: sub (image_by_fun f E1) (target f) by apply: fun_image_Starget1.
move: (bf) => [bf0 _].
exists (image_by_fun f E1); split => //; first by rewrite -tf.
  eqsym; eqtrans E1; apply: (equipotent_restriction1 sc1 bf0).
move: (inj_image_C injf (refl_equal (source f)) sc1).
have ->: (source f) -s E1 = F1.
   rewrite sf setCU2_l setC_v set0_U2; set_extens t;first by move => /setC_P [].
   move => ta; apply /setC_P;split => // /indexed_P [_ _ qa].
   move /indexed_P: ta => [_ _]; rewrite qa; fprops.
move: (surjective_pr0 sjf); rewrite /image_of_fun; move => ->; rewrite tf.
move => <-.
eqsym; eqtrans F1; apply: (equipotent_restriction1 sc2 bf0).
Qed.

Lemma Exercise6_6b:
  cardinal (functions E F) = cardinal (surjections E F).
Proof.
move: Exercise6_6a => [G [sGE [f [bf sf tf]] [g [bg sg tg]]]].
symmetry;apply: card_leA; first by apply: sub_smaller; apply: Zo_S.
pose C h x := Yo (inc x G) (Vf h (Vf f x)) (Vf g x).
pose Cx h := Lf (C h) E F.
move: bf bg => [[ff _] sjf] [[fg _] sjg].
set s1 := (functions E F);set s3 := (surjections E F).
have pd: forall u, inc u s1 -> lf_axiom (C u) E F.
  move=> u /fun_set_P [fu su tu].
  move=> t te; rewrite /C; Ytac tG; [ rewrite -tu | rewrite -tg] ;Wtac.
    rewrite su -tf; Wtac.
  rewrite sg; apply /setC_P;split => //.
have pe: forall u, inc u s1 -> surjection (Cx u).
  move=> u us1; move: (pd _ us1) => ta.
  apply: lf_surjective => // y yF; rewrite -tg in yF.
  move: ((proj2 sjg) _ yF) => [z zsg <-].
  move: zsg; rewrite sg => /setC_P [ze nzg]; ex_tac.
  by rewrite /C; Ytac0.
have pf: lf_axiom Cx s1 s3.
  move=> u us1; move: (pe _ us1) => sC.
  apply: Zo_i =>//; apply /fun_set_P; rewrite /Cx; red;aw; split => //; fct_tac.
have pa: s1 = source (Lf Cx s1 s3) by aw.
have pb: s3 = target (Lf Cx s1 s3) by aw.
rewrite pb {1} pa;apply: incr_fun_morph; apply: lf_injective => //.
move=> u v us1 vs1; move: (pd _ us1) (pd _ vs1) => ta1 ta2.
move: us1 vs1 => /fun_set_P [fu su tu] /fun_set_P [fv sv tv] sC.
apply: function_exten => //; try ue.
move=> x; rewrite su -tf => xtf.
move: ((proj2 sjf) _ xtf) => [y ysf <-].
rewrite sf in ysf; move: (sGE _ ysf) => yE.
move: (f_equal (Vf^~y) sC); rewrite /Cx; aw.
by rewrite /C; Ytac0 ; Ytac0.
Qed.

Lemma Exercise6_6c (p:= powerset E) :
  (functions E F) \Eq p /\ (sub_functions E F) \Eq p.
Proof.
set s1:= (functions E F); set s2 := (sub_functions E F).
move: (Exercise6_5a E F); rewrite -/s1 -/s2 => prop1.
move: Finf => [a [b [aF bF ab]]].
have pb: cardinal_le (cardinal p) (cardinal s1).
  pose f A x := Yo (inc x A) a b.
  have ta: forall A, lf_axiom (f A) E F.
    by move=> A t tE; rewrite /f; Ytac xE.
  pose fA A := Lf (f A) E F.
  have pb:forall u v : Set, inc u p -> inc v p -> fA u = fA v -> sub u v.
    move=> u v; rewrite /p /fA => /setP_P uE /setP_P vE sf t tu.
    move: (ta u) (ta v) => ta1 ta2; move: (uE _ tu) => tE.
    move: (f_equal (Vf^~t) sf); rewrite /f; aw; Ytac0; Ytac yv => //.
  have ij: injection (Lf fA p s1).
    apply: lf_injective.
      move=> A As3; rewrite /fA;apply /fun_set_P;red;aw;split => //.
      apply: lf_function; apply: ta.
    move=> u v us3 vs3 sf; apply: extensionality; apply: pb => //.
  move: (incr_fun_morph ij); aw.
move: (Exercise6_5b E F). rewrite -/s2 -/p.
have ->: (cardinal (powerset (product E F)) = cardinal p).
 rewrite /p ! card_setP;apply: cpow_pr; fprops.
 by apply: product2_infinite3 => //; exists a.
move=> pa.
have pd : cardinal_le (cardinal p) (cardinal s2) by co_tac.
have pe: (cardinal s2) = (cardinal p) by co_tac.
split; apply /card_eqP;rewrite pe in prop1; co_tac.
Qed.

End Exercise6_6.

Exercise 6.7

Lemma Exercise6_7a E F (B := injections E F)
    (C := Zo (powerset F)(fun x => equipotent x E)):
    (cardinal C) <=c (cardinal B).
Proof.
apply: surjective_cardinal_le.
exists (Lf (fun f => (range (graph f))) B C); split; aw.
have pa: lf_axiom (fun f => (range (graph f))) B C.
  move=> f => /Zo_P [] /fun_set_P [ff sf tf] injf.
  move: (equipotent_range injf); rewrite sf => aux.
  apply: Zo_i; last by eqsym.
  by apply /setP_P; rewrite -tf;fprops; apply: f_range_graph; fct_tac.
apply: lf_surjective => //.
move=> y => /Zo_P [] /setP_P yF ey.
have : (equipotent E y) by eqsym.
move=> [f [bf sf tf]].
have ta: lf_axiom (Vf f) E F.
  move=> t; rewrite - sf => zE; apply: yF; rewrite -tf.
  apply: Vf_target => //; fct_tac.
move: bf => [[ff injf] sjf].
have fi: injection (Lf (Vf f) E F).
  apply: lf_injective =>// u v uE vE; by apply: injf; rewrite sf.
have ffi:function (Lf (Vf f) E F) by fct_tac.
exists (Lf (Vf f) E F).
  apply: Zo_i =>//; apply /fun_set_P;split;aw.
symmetry;set_extens t.
   move /(range_fP ffi); aw; move => [x xE];aw => ->; Wtac.
rewrite - tf;move => ty; apply /(range_fP ffi); aw.
move: ((proj2 sjf) _ ty); rewrite sf; move=> [x xE <-]; ex_tac; aw.
Qed.

Lemma image_by_fun_injective f u v:
  injection f -> sub u (source f) -> sub v (source f) ->
  image_by_fun f u = image_by_fun f v -> u = v.
Proof.
move=> [ff injf]; move: u v.
have aux: forall u v, sub u (source f) -> sub v (source f) ->
  image_by_fun f u = image_by_fun f v -> sub u v.
  move=> u v usf vsf aux t tu.
  have : inc (Vf f t) (image_by_fun f u) by apply /(Vf_image_P ff usf); ex_tac.
  rewrite aux;move /(Vf_image_P ff vsf)=> [w wv sf].
  by rewrite (injf _ _ (usf _ tu) (vsf _ wv) sf).
move=> u v usf vsf auw; apply: extensionality; apply: aux =>//.
Qed.

Lemma Exercise6_7b E F (A:= functions E F) (B := injections E F)
    (C:= Zo (powerset F)(fun x => equipotent x E)):
  infinite_set F -> cardinal_le (cardinal E) (cardinal F) ->
  (cardinal A = cardinal B /\ cardinal A = cardinal C).
Proof.
move => infF leEF.
case: (emptyset_dichot E) => ne.
  have -> : C= singleton emptyset.
    apply:set1_pr.
       by apply/ Zo_P;split;[apply /setP_P | rewrite ne]; fprops.
       move => z /Zo_P [_]; rewrite ne;move /card_eqP.
       rewrite cardinal_set0; apply: cardinal_nonemptyset.
  rewrite cardinal_set1.
  move: (@fun_set_small_source F); rewrite -ne -/A => sA.
  set f:= empty_function_tg F.
  have injf: injection f.
    move: (empty_function_tg_function F) => [xa xb xc].
    by split => // x y; rewrite xb => /in_set0.
  have fA: inc f A.
    rewrite /A /f/empty_function_tg.
    by apply /fun_set_P; red;aw;split => //; fct_tac.
  have As: A = singleton f.
    by set_extens t; [ move=> tA; apply /set1_P;apply: sA | move /set1_P=> -> ].
  have Bs: B = singleton f.
    set_extens t; aw; first by move => /Zo_P; rewrite -/A As; case.
    by move /set1_P => ->; apply: Zo_i.
  rewrite As Bs ! cardinal_set1; split => //.
have prop1:cardinal A = cardinal B.
  symmetry;apply: card_leA.
    have pa: sub B A by apply: Zo_S.
    apply: (sub_smaller pa).
  move: (product2_infinite3 ne leEF infF) => [g [bg sg tg]].
  pose Cf f := Lf (fun x => Vf g (J (Vf f x) x)) E F.
  suff pa: injection (Lf Cf A B) by move: (incr_fun_morph pa); aw.
  have pa: forall u x, inc u A -> inc x E -> inc (J (Vf u x) x) (source g).
    move=> u x; rewrite /A sg;move=> /fun_set_P [fu su tu] xE.
    apply: setXp_i => //; rewrite -tu; Wtac.
  have pb: forall u, inc u A -> lf_axiom (fun x=> Vf g (J (Vf u x) x)) E F.
    move=> u uA x xE; rewrite -tg; apply:Vf_target;[fct_tac | by apply: pa].
  move: bg => [[fg ig] sjg].
  have pc:lf_axiom Cf A B.
    move=> t tA.
    have aux: injection (Cf t).
      apply: lf_injective; first by apply: pb.
      move=> u v uE vE h;exact(pr2_def (ig _ _ (pa _ _ tA uE)(pa _ _ tA vE) h)).
    apply: Zo_i => //; rewrite /Cf;apply /fun_set_P;split => //; aw; fct_tac.
  apply: lf_injective => //.
  move=> u v uA vA; move: (pb _ uA) (pb _ vA) => ta1 ta2.
  move: (uA) (vA); move=> /fun_set_P [fu su tu] /fun_set_P [fv sv tv] sf.
  apply: function_exten => //; try ue; rewrite su => x xs.
  move: (f_equal (Vf^~ x) sf); rewrite /Cf; aw => sw.
  exact: (pr1_def (ig _ _ (pa _ _ uA xs) (pa _ _ vA xs) sw)).
split => //.
move: (product2_infinite3 ne leEF infF) => aux.
have : equipotent (product E F) F.
   eqtrans (product F E); apply: equipotent_product_sym.
move=> [g [bg sg tg]].
pose k f := image_by_fun g (graph f).
have pa: forall f, inc f A -> sub (graph f) (source g).
  move=> f /fun_set_P [ff sf tf].
  by rewrite sg - sf -tf; move: ff => [[_ qa] _].
have ig: injection g by move: bg => [ok _].
have ta: lf_axiom k A C.
  move=> f fA; move: (pa _ fA)=> ha; apply: Zo_i.
    apply /setP_P;rewrite /k -tg; apply: fun_image_Starget1; fct_tac.
  eqtrans (graph f).
     eqsym; rewrite /k; apply: equipotent_restriction1 => //.
  move: fA; move=> /fun_set_P [ff sf tf].
  rewrite - sf; apply: equipotent_source_graph => //.
have i1: injection (Lf k A C).
  apply: lf_injective => //.
  move=> u v uA vA; move: (pa _ uA) (pa _ vA) => g1 g2; move: uA vA.
  move=> /fun_set_P [fu su tu] /fun_set_P [fv sv tv] => aux2.
  apply: function_exten1 => //; last by ue.
  apply: (image_by_fun_injective ig) => //.
apply: card_leA.
   move: (incr_fun_morph i1); aw.
rewrite prop1; apply: Exercise6_7a.
Qed.

Exercise 6.8

Lemma Exercice6_8b E:
  (cardinal (permutations E)) <=c
   (cardinal (Zo (powerset (coarse E)) (fun r => worder_on r E))).
Proof.
set s3 := permutations E; set s2 := Zo _ _.
pose C f r:= graph_on (fun x y => gle r (Vf f x) (Vf f y)) E.
have Cp1: forall f r, inc f s3 -> inc r s2 -> inc (C f r) s2.
  move=> f r => /Zo_P [] /fun_set_P [ff sf tf] bf.
  move /Zo_P => [] /setP_P rc [[or wor] sr]; apply: Zo_i.
    apply /setP_P; apply: Zo_S.
  have pa: forall a : Set, inc a E -> gle r (Vf f a) (Vf f a).
    by rewrite - sf => a aE; order_tac; rewrite sr -tf;Wtac.
  have sfr: substrate (C f r) = E.
    rewrite /C graph_on_sr //;split => //.
  have pb: order (C f r).
    rewrite /C; apply: order_from_rel1 => //.
      move=> x y z; simpl => le1 le2; order_tac.
    rewrite - sf => x y xE yE le1 le2; move: bf => [[_ injf] _].
    apply: injf =>//; order_tac.
  rewrite /worder;split => //; split => //;move=> x xE nex.
  set X := image_by_fun f x.
  rewrite sfr in xE.
  have XE: sub X (substrate r).
    rewrite sr -tf;apply: fun_image_Starget1 => //.
  have sxt: sub x (source f) by rewrite sf.
  have neX: nonempty X.
    move: nex => [a ax]; exists (Vf f a); apply /(Vf_image_P ff sxt);ex_tac.
  move: (wor _ XE neX) => [y []]; aw; move => yX ylX.
  move: yX => /(Vf_image_P ff sxt) [u ux wu].
  have pc: sub x (substrate (C f r)) by ue.
  exists u; red; aw;split => // a ax; apply /iorder_gleP => //; apply /Zo_P;aw.
  split; first by apply: setXp_i;fprops.
  have wx: inc (Vf f a) X by apply /(Vf_image_P ff sxt); ex_tac.
  by move: (iorder_gle1 (ylX _ wx)); rewrite -wu.
have Cp2: forall f r, inc f s3 -> inc r s2 -> order_isomorphism f (C f r) r.
  move=> f r fs3 rs2; move: (Cp1 _ _ fs3 rs2).
  move:fs3 rs2 => /Zo_P [] /fun_set_P [ff sf tf] bf.
  move => /Zo_P [] /setP_P rc [[or wor] sr] /Zo_P [] rc1 [[or1 wor1] sr1].
  split => //; first by split => //; ue.
  move => x y xsf ysr; split;first by move /Zo_P => [_]; aw.
  move => pa; apply /Zo_P;aw;split => //; apply: setXp_i => //; ue.
have cp3: forall f1 f2 r, inc f1 s3 -> inc f2 s3 -> inc r s2 ->
   C f1 r = C f2 r -> f1 = f2.
  move=> f1 f2 r f1s3 f2s3 rs2 sv; move: (Cp2 _ _ f1s3 rs2)(Cp2 _ _ f2s3 rs2).
  rewrite - sv => p1 p2.
  move: (order_isomorphism_w p1) (order_isomorphism_w p2) => p3 p4.
  move: rs2 (Cp1 _ _ f1s3 rs2) => /Zo_P [q1 [q2 q3]] /Zo_P [q4 [q5 q6]].
  have sr1: segmentp r (range (graph f1)).
    move: p1 => [_ _ [ [_ sj1] _ tf1] _ ].
    rewrite (surjective_pr3 sj1) tf1; apply: substrate_segment; fprops.
  have sr2: segmentp r (range (graph f2)).
    move: p2 => [_ _ [ [_ sj1] _ tf1] _ ].
    rewrite (surjective_pr3 sj1) tf1; apply: substrate_segment; fprops.
   exact (isomorphism_worder_unique q5 q2 sr1 sr2 p3 p4).
move: (Zermelo E) => [r [wor sr]].
have rs2: inc r s2.
  apply: Zo_i => //; apply /setP_P;rewrite - sr.
  apply: sub_graph_coarse_substrate; fprops.
have p3: injection (Lf (fun f => C f r) s3 s2).
  apply: lf_injective => //.
      by move=> f fe; simpl; apply: Cp1.
  by move=> u v us3 vs3 su; apply: (cp3 _ _ _ us3 vs3 rs2).
move: (incr_fun_morph p3); aw.
Qed.

Lemma Exercice6_8c E: infinite_set E ->
  let s1 := Zo (powerset (coarse E)) (fun r => order_on r E) in
    let s2 := Zo (powerset (coarse E))(fun r => worder_on r E) in
  (s1 \Eq s2 /\ s2 \Eq (powerset E)).
Proof.
move=> isE s1 s2.
have pa: sub s2 s1.
  by move=> r /Zo_P [pa [[pb1 pb2] pc]]; apply /Zo_P.
move: (sub_smaller pa) => le1.
have pb: sub s1 (powerset (coarse E)) by apply: Zo_S.
move: (sub_smaller pb); rewrite /coarse.
have -> :(cardinal (powerset (product E E)) = cardinal (powerset E)).
  rewrite ! card_setP;apply: cpow_pr; fprops.
  move: isE => /infinite_setP isE.
  move: (square_of_infinite isE)=> hh;apply /card_eqP.
  by rewrite - cprod2_pr1 -hh;apply: cprod2_pr2;rewrite double_cardinal.
move=> le3.
move: (Exercice6_5h isE) (Exercice6_8b E).
move /card_eqP => ->; rewrite -/s2 => le4.
move: (card_leT le1 le3) => le5.
move: (card_leA le4 le5) => eq1.
split => //; apply /card_eqP;rewrite eq1 in le3; co_tac.
Qed.

Exercise 6.9

Lemma Exercise6_9a n: inc n Bnat ->
   (Bint_co n = induced_order Bnat_order (segment Bnat_order n)).
Proof.
move =>nB; rewrite segment_Bnat_order //.
move : Bnat_order_wor => [[o2 _] sb].
move: (Bintco_wor n) => [o1 _].
rewrite -/(Bint n).
move: (@Bint_S1 n); rewrite - sb => si.
move: (iorder_osr o2 si)=> [o3 sr3].
rewrite -/(Bint n); apply: order_exten => //.
  fprops.
move=> x y; split.
   move => h; move /(Bintco_gleP nB):(h) => [pa pb].
   move: h => /Zo_P [] /setXp_P [xi yi] _.
   move: (xi) (yi) => /Zo_P [xsr _] /Zo_P [ysr _].
   apply /iorder_gleP => //; apply /Bnat_order_leP; split => //; ue.
move /iorder_gle5P => [pa pb] /Bnat_order_leP [pc pd pe].
by apply /(Bintco_gleP nB);split => //; apply /(BintP nB).
Qed.

Lemma Exercise6_9 r: worder r ->
  (forall x, inc x (substrate r) ->
    (least r x \/
    (exists y, greatest (induced_order r (segment r x)) y))) ->
  r \Is Bnat_order
  \/ (exists2 n, inc n Bnat & r \Is (Bint_co n)).
Proof.
move => wor hyp.
move: Bnat_order_wor => [h1 s1].
case: (isomorphism_worder2 wor h1);first (by left); last first.
   move=> [n]; rewrite s1;move => nB io1.
   by right => //;ex_tac; rewrite (Exercise6_9a nB);apply: orderIS.
move=> [x xsr [f [o1 o2 [bf sf tg] etc]]].
have pa: sub (segment r x) (substrate r) by apply: sub_segment.
move: wor => [or _];move: sf; aw => sf.
rewrite s1 in tg.
case: (hyp _ xsr) => aux.
  have zt: inc \0c (target f) by rewrite tg ; fprops.
  move: (inverse_Vis bf zt); rewrite sf => ys.
  move: (inc_segment ys) => ylt.
  move: aux => [a1 a2]; move: (a2 _ (sub_segment ys)) => yle; order_tac.
move: aux => [y]; rewrite /greatest; aw; move => [ysr yfg].
rewrite - sf in ysr.
have wb:(inc (Vf f y) Bnat) by Wtac; fct_tac.
set z := succ (Vf f y).
have zb: inc z (target f) by rewrite tg /z; fprops.
move: (inverse_Vis bf zb); rewrite sf => ys.
move: (yfg _ ys); rewrite - sf in ys; rewrite (etc _ _ ys ysr).
rewrite (inverse_V bf zb) /z.
move /Bnat_order_leP => [qa qb qc].
move: (card_lt_succ qb) => bad; co_tac.
Qed.

Exercise 6.10 points a b d and part of c are in the main text we show here the remainder of c
Lemma aleph_pr9 x: ordinalp x ->
  let y:= (omega_fct x) in
  let src := (succ_o x) in
   let trg := Zo (cardinals_le y) infinite_c in
  order_isomorphism
    (Lf (fun z => (omega_fct z)) src trg)
    (graph_on ordinal_le src)(graph_on cardinal_le trg).
Proof.
move=> ox y src trg.
have osrc: ordinalp src by apply: OS_succ.
move:(wordering_ordinal_le_pr (ordinal_set_ordinal osrc)) => [p2 p1].
move: p2 => [p2 _].
have cy: cardinalp y by apply: CS_aleph.
have cse:cardinal_set trg by move => t /Zo_P [_] [].
have [[p3 _] p4]:=(wordering_cardinal_le_pr cse).
have ta:lf_axiom (fun z => (omega_fct z)) src trg.
  move=> z;rewrite /src/trg; move /(ord_leP ox) => pa; apply /Zo_P; split.
    apply /cardinals_leP => //.
      apply: (aleph_le_lec pa).
  have oz: ordinalp z by ord_tac.
  apply: (aleph_pr5c oz).
split => //; aw.
  split;aw => //; apply: lf_bijective => //.
    move => u v usr vsr.
    move: (ordinal_hi osrc usr) (ordinal_hi osrc vsr) => oa ob.
    by apply: aleph_eq.
  move=> z /Zo_P [] /(cardinals_leP cy) zy iz.
  move: (ord_index_pr1 iz)=> [ot tp].
  exists (ord_index z) => //.
   rewrite /src; apply/ord_leP => //.
   by apply: aleph_lec_le => //; rewrite tp.
red;aw;move=> a b ais bis; aw.
split; move /Zo_P => [] /setXp_P [pa pb]; aw => h;
   apply: Zo_i; try apply:setXp_i => //; try apply: ta => //; aw.
by apply: aleph_le_lec.
by apply: aleph_lec_le => //; ord_tac0.
Qed.

Exercise 6.11; see main text
Exercise 6.12; (a) is in the main text, (b) not yet done; (c) is here

Definition Ex6_12_e (n: Set):= fun i => (Yo (i = n) \0o \1o).
Definition Ex6_12_c (f: fterm) n:=
    fun i => (Yo (i = n) (Yo (n = \0c) \1o (f \1c))
            (Yo (succ i = n) \1o (f (succ (succ i))))).
Definition Ex6_12_ax f n:=
   (forall i, inc i (Bint1c n) -> \0o <o (f i) /\ (f i) <o omega0).

Definition Ex6_12_v f n:= CNFpv (Ex6_12_e n) (Ex6_12_c f n) n.

Lemma Exercise6_12a n: inc n Bnat -> n <> \0c ->
  (inc \1c (Bint1c n) /\ inc n (Bint1c n)).
Proof.
move => nB nz; split; apply/(Bint1cP nB); split; fprops.
apply /card_ge1P;apply: card_ne0_pos => //; fprops.
Qed.

Lemma Exercise6_12b f n: Ex6_12_ax f n -> inc n Bnat ->
  CNFp_ax (Ex6_12_e n) (Ex6_12_c f n) n.
Proof.
move => pb nB; split.
+ move => i [_ inz]; rewrite /Ex6_12_e; Ytac0; apply: ord_lt_01.
+ have h: (\0o <o \1o /\ \1o <o omega0).
     by split; [ apply: ord_lt_01 | apply: ord_lt_1omega].
  move => i lein;rewrite/ Ex6_12_c; case: (equal_or_not i n) => nin; Ytac0.
    case: (equal_or_not n \0c) => nz; Ytac0 => //.
    exact: (pb _ (proj1 (Exercise6_12a nB nz))).
  case: (equal_or_not (succ i) n) => nsi; Ytac0 => //.
  have sin: succ i <=c n by apply/card_le_succ_lt0P; [co_tac | exact | split].
  apply: pb; apply/(Bint1cP nB); split. apply: succ_nz.
  by apply/(card_le_succ_lt0P (proj31 sin) nB).
+ rewrite /Ex6_12_e; Ytac0; fprops.
Qed.

Lemma Exercise6_12c f g n:
  inc n Bnat -> Ex6_12_ax f n -> Ex6_12_ax g n ->
  Ex6_12_v f n = Ex6_12_v g n ->
  forall i, inc i (Bint1c n) -> f i = g i.
Proof.
move => nB pa pb eq.
move: (Exercise6_12b pa nB) (Exercise6_12b pb nB) => h1 h2.
move: (CNFp_unique h1 h2 nB nB eq) => [_ _ h3 _ h4].
move => i /(Bint1cP nB) [eq1 lein].
move: (cpred_pr (BS_le_int lein nB) eq1) => [sa sb].
case: (equal_or_not (cpred i) \0c) => piz.
  rewrite sb piz succ_zero; case: (equal_or_not n \0c) => nz.
    by rewrite nz in lein; case:eq1; apply:card_le0.
  by move: h3; rewrite / Ex6_12_c; repeat Ytac0.
move: (cpred_pr sa piz) => [sa' sb'].
rewrite sb in lein.
move/(card_le_succ_ltP n sa): lein => ha.
move:(proj2 ha) => hb.
rewrite sb' in ha; move/(card_le_succ_ltP n sa'): (proj1 ha) => lt1.
move:(lt1) => [_ nt1].
by move: (h4 _ lt1); rewrite /Ex6_12_c - sb' - sb; repeat Ytac0.
Qed.

Lemma Exercise6_12d n f: inc n Bnat -> Ex6_12_ax f n ->
  Ex6_12_v f n = Yo (n = \0c) \1o
    ((f \1c) *o oprod_expansion
       (fun i => (succ_o (omega0 *o (Yo (succ i = n) \1o (f (succ (succ i)))))))
     n).
Proof.
move => nB pa.
move:(Exercise6_12b pa nB) => /CNFp_ax_ax1 ax1.
rewrite /Ex6_12_v /CNFpv {1}/Ex6_12_e {1}/Ex6_12_c.
case (equal_or_not n \0c) => nz; repeat Ytac0.
  by rewrite nz /CNFpv1 oprod_expansion0 opowx0 !(oprod1l OS1).
move: (Exercise6_12a nB nz) => [/pa [[[_ of1 _] _] _] /pa [[[_ ofn _] _] _]].
rewrite opowx0 (oprod1l of1); apply: f_equal.
apply:(oprod_expansion_exten nB) => i [_ lin].
by rewrite /Ex6_12_e /Ex6_12_c /CNFp_value1 !(Y_false lin) (opowx1 OS_omega).
Qed.

Lemma Exercise6_12e n:
  \0o <o n -> n <o omega0 -> n *o (succ_o omega0) = (omega0 +o n).
Proof.
move => np no; move: (proj31_1 no) => on.
have h := (oprod_int_omega no np).
by rewrite -(ord_succ_pr OS_omega)(osum_prodD OS_omega OS1 on) h (oprod1r on).
Qed.

Lemma Exercise6_12f f n:
   inc n Bnat -> Ex6_12_ax f n ->
   Ex6_12_v f n = oprod_expansion (fun z => (omega0 +o f(succ z))) n.
Proof.
move => nB ax; rewrite (Exercise6_12d nB ax) /CNFpv1.
case (equal_or_not n \0c) => nz; Ytac0.
  by rewrite nz oprod_expansion0.
move: (cpred_pr nB nz); set m := cpred n; move => [mB sv].
move: ax; rewrite sv; clear sv; move: m mB; clear n nB nz.
have Ha:= OS_succ OS_omega.
apply: cardinal_c_induction.
  move:(Exercise6_12a BS1 (card1_nz)) => [_]; rewrite - {2} succ_zero => H.
  move=> ax; move: (ax _ H) => [sa sb].
  have os:= (OS_sum2 OS_omega (proj31_1 sb)).
  by rewrite succ_zero oprod_expansion1 succ_zero (Y_true (erefl \1c))
   (oprod1r OS_omega) //(oprod_expansion1) succ_zero // (Exercise6_12e sa sb).
move => n nB Hrec ax.
have snB := BS_succ nB; have ssnB := BS_succ snB.
have ax2: Ex6_12_ax f (succ n).
   move => i/(Bint1cP snB) [inz lein]; apply: ax; apply/(Bint1cP ssnB).
   split => //; move: (card_le_succ snB) => h; co_tac.
have nsn:= (proj2(card_lt_succ snB)).
rewrite (oprod_expansion_succ _ snB) (oprod_expansion_succ _ snB).
rewrite - (Hrec ax2).
rewrite (oprod_expansion_succ _ nB) (oprod_expansion_succ _ nB).
repeat Ytac0.
set w1 := oprod_expansion _ _.
set w2 := oprod_expansion _ _.
have <- : w1 = w2.
  apply: (oprod_expansion_exten nB) => i lein.
  move: (card_lt_leT lein (card_le_succ nB)) => [_ nin].
  Ytac h1; first by move: (succ_injective1 (proj31_1 lein) (CS_succ n) h1).
  Ytac h2 => //.
  by move:(succ_injective1 (proj31_1 lein) (proj32_1 lein) h2) (proj2 lein).
move: (Exercise6_12a ssnB (@succ_nz (succ n))) => [/ax [ua _] /ax [sa sb]].
rewrite (oprod1r OS_omega) - (Exercise6_12e sa sb).
move: (CNFp_pr1 ord_lt_01 sa sb).
rewrite /CNFp_value1/CNFp_value2 (opowx1 OS_omega) => ->.
have ow1: ordinalp w1.
   apply:(OS_oprod_expansion nB) => i lin; apply: OS_succ.
   apply:(OS_prod2 OS_omega); Ytac y; fprops.
   move / (card_le_succ_succP (proj31_1 lin) (proj32_1 lin)): (proj1 lin)=> h.
   move /(card_le_succ_succP (CS_succ i) (CS_succ n)): h => h1.
   have ii: inc (succ (succ i)) (Bint1c (succ (succ n))).
     apply/(Bint1cP ssnB); split => //; apply: succ_nz.
   exact (proj32_1 (proj1 (ax _ ii))).
have of1: ordinalp (f \1c) by ord_tac.
move: (OS_prod2 ow1 Ha) (proj32_1 sa) => owa ofn.
rewrite (oprodA ow1 Ha ofn) (oprodA of1 (OS_prod2 owa ofn) Ha).
by rewrite (oprodA (OS_prod2 of1 owa) ofn Ha) (oprodA of1 owa ofn).
Qed.

Lemma Exercise6_12g n:
  inc n Bnat ->
  factorial n =
  cardinal (fun_image (permutations (Bint1c n))
           (fun s => oprod_expansion (fun i => (omega0 +o Vf s (succ i))) n)).
Proof.
move => nB.
move: (card_Bint1c nB); set F := (Bint1c n) => cf.
have fsf: finite_set F by red; rewrite cf; apply /BnatP.
set f := (fun s : Set => _).
rewrite - cf - (number_of_permutations fsf).
apply /card_eqP.
set E := permutations F; exists (Lf f E (fun_image E f)); split;aw.
have H: forall s, inc s E -> Ex6_12_ax (Vf s) n.
  move => s /Zo_P [] /fun_set_P [fs ss ts] _ i ii.
  have: inc (Vf s i) F by rewrite - ts; Wtac; rewrite ss.
  move /(Bint1cP nB) => [sa sb].
  move: (BS_le_int sb nB) => /olt_omegaP ao;split => //.
  apply: ord_ne0_pos => //; ord_tac.
apply: lf_bijective.
+ move => t te; apply /funI_P; ex_tac.
+ move => u v ue ve.
  move: (H _ ue) (H _ ve) => ax1 ax2.
  rewrite /f - (Exercise6_12f nB ax1) - (Exercise6_12f nB ax2) => eq.
  move: (Exercise6_12c nB ax1 ax2 eq) => h.
  move: ue ve => /Zo_S /fun_set_P [fs ss ts] /Zo_S /fun_set_P [fs' ss' ts'] .
  apply: function_exten; [exact | exact | by rewrite ss' | by rewrite ts'|].
  by move => i; rewrite ss; apply: h.
+ by move => t /funI_P.
Qed.

Exercise 6.13. points a, c, d, e are in the main text.

Lemma ord_induction_p20 u w0 g b
  (f:= ord_induction_defined w0 g):
  OIax2 u w0 g ->
 ordinalp b -> exists2 E, finite_set E &
 forall y, (inc y E) <-> (exists x, [/\ u <=o x, ordinalp y & f x y = b]).
Proof.
move=> axx ob; move: (axx) => [ax1 _ _ _].
have fv: f = ord_induction_defined w0 g by done.
pose p x y:= [/\ u <=o x, ordinalp y & f x y = b].
set E := Zo (succ_o b) (fun y => exists x, p x y).
exists E; last first.
  move=> y; split; first by move /Zo_P => [].
  move=> h; apply/Zo_P;split; last (by exact).
  move: h=> [x [ux oy fb]]; apply /(ord_leP ob); rewrite - fb.
  exact: (ord_induction_p9 fv ax1 ux oy).
pose the_x y := choose (fun x => p x y).
have the_xp: forall y, inc y E -> p (the_x y) y.
  by move=> y yE; apply choose_pr; move: yE => /Zo_P [_].
pose the_lx y := least_ordinal (fun x => p x y) (the_x y).
have the_lxp: forall y, inc y E ->
     [/\ ordinalp (the_lx y) , p (the_lx y) y &
      (forall z, ordinalp z -> p z y -> (the_lx y) <=o z )].
  move=> y yE; move: (the_xp _ yE) => pv.
  move: (pv) => [[_ pw _] _ _].
  exact:(least_ordinal4 (p:= p ^~y) pw pv).
have thex_dec: forall y1 y2, inc y1 E -> inc y2 E ->
    y1 <o y2 -> (the_lx y2) <o (the_lx y1).
  move=> y1 y2 /the_lxp [ox1 px1 minx1] /the_lxp [ox2 px2 minx2] y12.
  case: (ord_le_to_el ox1 ox2) => le1 //.
  move: px1 px2 => [pa pb pc] [pd pe pf].
  move: (ord_induction_p16 fv axx pa le1 (ord_leR pb)).
  move: (ord_induction_p8 fv ax1 pd y12); rewrite pc pf => lea lta ; ord_tac.
have ose: ordinal_set E by move=> x => /Zo_P [_ [y [_ p3 _]]].
move: (wordering_ordinal_le_pr ose).
set r:= graph_on ordinal_le E; move => [pd pc].
rewrite -pc; apply: well_ordered_opposite => //.
move: pd => [pd pe].
move: (opp_osr pd) => [or1]; rewrite pc => sr1.
split; fprops; rewrite /least sr1 => X XE neX.
rewrite iorder_sr; [ | fprops | ue].
set Y := fun_image X the_lx.
have neY: nonempty Y .
   move: neX => [x xE]; exists (the_lx x); apply /funI_P; ex_tac.
have osy: ordinal_set Y.
  move=> x /funI_P [y yx yv].
  by move: (the_lxp _ (XE _ yx)); rewrite yv; move=> [p1 _ _].
move: (wordering_ordinal_le_pr osy) => [pd1 pc1].
rewrite - pc1 in neY; move: (worder_least pd1 neY) => [y []].
rewrite pc1 => /funI_P [x xX xv] => xv1.
exists x; split => //;move => t tX; apply /iorder_gleP => //.
apply /opp_gleP/graph_on_P1;split => //; try apply:XE => //.
have aux: inc (the_lx t) Y by apply /funI_P; ex_tac.
move: (xv1 _ aux) => /graph_on_P1 [p1 p2 p3].
have ox: ordinalp x by move: (ose _ (XE _ xX)).
have ot: ordinalp t by move: (ose _ (XE _ tX)).
case: (ord_le_to_el ot ox) => le1 //.
move: (thex_dec _ _ (XE _ xX) (XE _ tX) le1); rewrite - xv => bad; ord_tac.
Qed.

Exercise 6.14

Lemma rev_succ_pr x: ordinalp x ->
  x <o omega0 \/ x = \1o +o x.
Proof. by case /(ord_le_to_el OS_omega); [ move/osum_1inf; right | left]. Qed.

Lemma ord_square_inj a: ordinalp a ->
   a ^o \2o = (a *o \2o) ^o \2o -> a = \0o.
Proof.
move => oa.
case: (ord_zero_dichot oa) => az; first by exact.
have s1: succ_o \1c = \2o by rewrite succ_o_one.
have oa2:= (OS_prod2 oa OS2).
have e1: forall u, ordinalp u -> u *o u = u ^o \2o.
  by move=> u ou; rewrite - s1 (opow_succ ou OS1) (opowx1 ou).
rewrite - (e1 _ oa) - (e1 _ oa2) => eq.
have e2: a = \2o *o (a *o \2o).
   move: eq; rewrite - (oprodA oa OS2 oa2) => h.
   exact: (oprod2_simpl oa (OS_prod2 OS2 oa2) az h).
have ha:=(oprod_Mle1 oa ord_lt_02).
move:(oprod_M1le ord_lt_02 oa2) ; rewrite - e2 => hb.
move:(ord_leA ha hb) =>eq2.
by case: card_12; exact: (esym (oprod2_simpl1 OS2 az (esym eq2))).
Qed.

Lemma critical_product_P2:
  let CP := critical_ordinal \1o ord_prod2 in
  let p1 := fun y => [/\ infinite_o y, ordinalp y &
       (forall z, \1o <o z -> z <=o y ->
          exists2 t, ordinalp t & y = z ^o t)] in
  forall y, CP y <-> p1 y.
Proof.
move=> CP p1 y.
move: (critical_productP y) => [pa ]; rewrite pa => pb; clear pa.
rewrite -/CP in pb; split.
  rewrite pb; move=> [qa qb qc]; split => //.
  by move=> z z1 z2; move: (qc _ z1 z2) => [t [t1 t2 t3]]; exists t.
move=> [ify oy hy].
have yinf: omega0 <=o y.
  have yy: ~ inc y y by apply: ordinal_irreflexive.
  have iy: infinite_set y by apply: infinite_set_pr2.
  apply: (ordinal_finite4 oy iy).
have lt1y: \1o <o y by move:ord_lt_1omega => lt1; ord_tac.
split => // x x1 xy; move: (xy) => [lexy nexy].
have ox: ordinalp x by ord_tac.
case: (ord_zero_dichot ox)=> xp.
  by move:ord_lt_01; rewrite - xp=> h; ord_tac.
case: (ord_one_dichot xp) => xl1; first by rewrite xl1 (oprod1l oy).
move: (hy _ xl1 lexy) => [t ot yt].
case: (rev_succ_pr ot); last first.
  by rewrite {1} yt - {1} (opowx1 ox) - (opow_sum ox OS1 ot) => <-.
have xl2: \2o <=o x by apply ord2_lt_P.
move => tf; move: yt.
have yn1: y <> \1o by move => bad; move: lt1y => [_]; rewrite bad.
case: (ord_zero_dichot ot); first by move => ->; rewrite opowx0.
move=> tnz yt; apply: ord_leA; last by apply: oprod_M1le.
move: OS0 OS1 OS2 ord_lt_02=> os0 os1 os2 l02.
case: (equal_or_not t \2o) => tnt.
  move: (opow_Mspec2 OS2 xl2).
  rewrite - {2} tnt -yt => leby.
  have xx: y = x *o x.
    rewrite yt tnt - osum_11_2 opow_sum // opowx1 //.
  have lexx2: x <=o (x *o \2o) by apply: oprod_Mle1 => //.
  have b1: \1o <o (x *o \2o) by ord_tac.
  move: (hy _ b1 leby) => [u ou yuv].
  case: (ord2_trichotomy ou) => uz; first by move: yuv; rewrite uz opowx0 //.
    move: yuv; rewrite uz (opowx1 (proj32 lexx2)) => eq1.
    rewrite {1} eq1 oprodA // xx -{1} xx eq1 - oprodA //.
    apply: oprod_Mlele => //; first by ord_tac.
    case: (ord_le_to_el OS_omega ox) => oxo.
      have l2o: \2o <o omega0 by apply:ord_lt_2omega.
      move: (oprod2_lt_omega l2o l2o) => [le4o _].
      ord_tac.
    move: (oprod2_lt_omega oxo oxo); rewrite - xx => bad; ord_tac.
  move: (odiff_pr uz) =>[]; set v := u -o \2o => v1 v2.
  move: yuv; rewrite v2 opow_sum //; last by fprops.
  set w := ((x *o \2o) ^o \2o) => le1.
  have od: ordinalp (x *o \2o) by fprops.
  have : y = w.
     apply: ord_leA.
       rewrite /w yt tnt; apply: opow_Mleeq => //; ord_tac1.
      rewrite le1; apply: oprod_Mle1; rewrite /w; fprops.
    apply:(opow_pos) => //; apply: oprod2_pos => //.
  rewrite /w yt tnt; move => /(ord_square_inj ox) => h.
  by move: (proj2 xp); rewrite h; case.
rewrite {1} yt - {1} (opowx1 ox) - opow_sum //.
have tb: inc t Bnat by apply /olt_omegaP.
have tnz': t <> \0o by ord_tac1.
move: (cpred_pr tb tnz') => []; set u := (cpred t) => [uB tsu].
have uo: u <o omega0 by apply /olt_omegaP.
have ou: ordinalp u by ord_tac.
have us: t = succ_o u.
  by rewrite tsu; apply: succ_of_finite; move: uB => /BnatP.
set z := x ^o u.
case: (equal_or_not u \0o) => unz.
   case: nexy; rewrite yt tsu unz // succ_zero opowx1 //.
have z1: \1o <o z.
   rewrite /z - (opowx0 x) - opow_Meqltr //.
   by split => //; [apply ozero_least | apply:nesym ].
have oz: ordinalp z by ord_tac.
have z2: z <=o y.
   rewrite /z yt; apply: opow_Meqle => //.
   by rewrite us;move: (ord_succ_lt ou) => [ok _].
move: (hy _ z1 z2) => [v ov].
case: (ord2_trichotomy ov).
    by move => ->; rewrite opowx0.
  move => ->; rewrite opowx1 // /z us yt.
  move=> se; move: (opow_regular xl2 ot ou se); rewrite us => bad.
  by move: (ord_succ_lt ou) => [_]; rewrite bad.
move=> v2.
have le1: (u +o u <=o (u *o v)).
  rewrite - (ord_double ou); apply: oprod_Meqle => //.
suff aux : ((\1o +o succ_o u) <=o (u +o u)).
  move => yv; rewrite yv /z - opow_prod //.
  apply: opow_Meqle => //; rewrite us; ord_tac.
have ->: \1o +o succ_o u = u +o \2o.
  have oB: inc \1o Bnat by fprops.
  have tB: inc \2o Bnat by fprops.
  have su: inc (succ_o u) Bnat by ue.
  have fcu: finite_c u by apply /BnatP.
  rewrite osum2_2int // osum2_2int // - succ_of_finite // (Bsucc_rw uB).
  by rewrite csumC - csumA card_two_pr.
apply: osum_Meqle => //.
case: (ord2_trichotomy ou);[ done | move => u1 | done ].
by case: tnt; rewrite us u1 succ_o_one.
Qed.

Lemma critical_product_pr3 a b: \1o <o a -> \1o <o b ->
 ord_indecomposable b ->
 critical_ordinal \1o ord_prod2 (a ^o b).
Proof.
move=> a1 b1 bi.
have ob: ordinalp b by ord_tac.
move: (indecomp_prop3 bi) => [c oc bv].
have cnz: c <> \0o.
  by move=> cz; move: b1; rewrite bv cz opowx0; move => [].
move: (CNF_singleton oc ord_lt_1omega ord_le_2omega).
set ec:= (fun _ : Set => c); set cc:= (fun _ : Set => \1o).
move => [_ yv h].
move: (h ord_lt_01) => ay {h}.
have pc: \0o <o (ec \0c) by rewrite /ec; ord_tac1.
have x2: \2o <=o a by apply /ord2_lt_P.
have oa: ordinalp a by ord_tac.
move: OS_omega => oo.
apply/(proj2 (critical_productP (a ^o b))).
suff: exists m, [/\ ordinalp m, ord_indecomposable m& a ^o b = omega0 ^o m].
  move=> [m [om im ->]].
  move: (indecomp_prop3 im) => [n nc -> ].
  by exists n.
have ap: \0o <o a by move: ord_lt_02 => h; ord_tac.
move:(the_CNF_p0 oa) => [/CNFB_ax_simp [mB ax] xv].
move: (the_CNF_p2 ap); set n:= cpred _; move => [nB nv].
rewrite nv in ax.
have ay': CNFb_axo ec cc (succ \0c) by rewrite succ_zero.
set le := (Vg (P (Q (the_CNF a))) n).
have o1: (ordinalp le).
   move: ax => [[_ a4 _ _] _]; apply: a4; apply: (card_lt_succ nB).
have eq1: CNFbvo ec cc (succ \0c) = b.
  by rewrite /CNFbvo succ_zero yv -bv oprod1r.
case (ord_zero_dichot o1) => hh; last first.
  move: (CNF_pow_pr4 ax hh nB ay' pc BS0).
  rewrite eq1 -/le - nv -/(CNFBv _) xv => eq2.
  by exists (le *o b); split;[ fprops | apply/(indecomp_prodP b1 hh) | exact].
case (equal_or_not n \0c) => nz; last first.
  move: (cpred_pr nB nz) ax => [sa sb] [[_ _ _ a3] _].
  have sp: succ (cpred n) <c succ n by rewrite - sb; apply: (card_lt_succ nB).
  by move: (a3 _ sa sp); rewrite - sb -/le hh; move => /ord_lt0.
have alo: a <o omega0.
  move: (ax) => [[_ _ a4 _] _]; move:(a4 _ (card_lt_succ nB)).
  set lc := (Vg (Q (Q (the_CNF a))) n) => lo.
  move: (proj1 ax) xv; rewrite /CNFBv nv nz succ_zero /CNFbvo.
  move => ax1; rewrite (CNFq_p3 ax1 card_lt_01) /cantor_mon - nz -/le -/lc.
  by rewrite hh opowx0 (oprod1l (proj31_1 lo)) => <-.
move: (CNF_pow_pr5 x2 alo ay' pc BS0) => [z [sa sb sc]].
rewrite eq1 in sb sc;exists z; split; [ exact | | exact].
case: (ord_zero_dichot sa) => zz.
   move: b1; rewrite sb zz oprod0r ; move /ord_ltP0 => [_ _ [[]]].
case: (ord_one_dichot zz) => z1; first by rewrite z1; apply: indecomp_one.
apply /(indecomp_prodP z1 ord_lt_0omega); ue.
Qed.

Exercises of Section 6

Exercise 6.15

Section Exercise6_15.
Variable (b: Set).
Hypothesis bg2: \2o <=o b.

Definition the_cnf_len x := (P (the_cnf b x)).

Definition the_cnf_expos x :=
   CNF_exponents (Vg (P (Q (the_cnf b x)))) (the_cnf_len x).

Lemma the_cnf_e_p2 x (E := the_cnf_expos x):
  ordinalp x -> (finite_set E /\ ordinal_set E).
Proof.
move => ox.
move:(the_cnf_p0 bg2 ox) => [/(cnfb_ax_simp) [sa sb] sc].
exact: (CNF_exponents_of (proj1 sb) sa).
Qed.

Lemma the_cnf_expos_zero: the_cnf_expos \0o = emptyset.
Proof.
rewrite /the_cnf_expos /the_cnf_len (the_cnf_p1 bg2) /CNF_exponents Bint_co00.
by apply /set0_P => y;aw; move => /funI_P [z /in_set0].
Qed.

Lemma the_cnf_e_p3 e c n:
  inc n Bnat -> CNFb_ax b e c (succ n) ->
  e n <=o (CNFbv b e c (succ n)).
Proof.
move => nB ax; move: (CNFq_pg4 nB ax) => sa.
move:(ax) => [[_ sb _ _] _]; move: (sb _ (card_lt_succ nB)) => op.
move: (ord_leT (opow_Mspec2 op bg2) sa) => le2.
exact:(ord_leT (oprod_M1le (ord_lt_leT ord_lt_02 bg2) op) le2).
Qed.

Lemma the_cnf_e_p4 x:
  ordinalp x -> (forall y, inc y (the_cnf_expos x) -> y <=o x).
Proof.
move => ox y.
case: (ord_zero_dichot ox) => xz.
  by rewrite xz the_cnf_expos_zero => /in_set0.
move:(the_cnf_p0 bg2 ox) => [/(cnfb_ax_simp) [sa sb] sc].
move:(the_cnf_p2 bg2 xz) => []; set m := cpred _ => mB mv.
move: sb;rewrite /the_cnf_expos /the_cnf_len mv => sb.
move /(CNF_exponentsP _ (BS_succ mB)) => [i lim ->].
move: (the_cnf_e_p3 mB sb); rewrite - mv -/(cnfbv _ _) sc => ea.
move: (proj1 (card_lt_succ_leP mB i) lim) (card_lt_succ mB) => se sf.
exact:(ord_leT (CNF_exponents_M (BS_succ mB) (proj1 sb) se sf) ea).
Qed.

Definition b_critical x := b ^o x = x.

Lemma the_cnf_e_p5 e c n (x := CNFbv b e c (succ n)):
 inc n Bnat -> CNFb_ax b e c (succ n) ->
  (e n = x -> b_critical x)
   /\ (b_critical x -> (n = \0c /\ (e n = x))).
Proof.
move=> nB ax.
move:(CNFq_p1 b e c nB); rewrite -/x.
have bp :=(ord_lt_leT ord_lt_02 bg2).
set en:= (e n);set A := cantor_mon _ _ _ _; set B := CNFbv _ _ _ _ => xv.
have oen: ordinalp (e n).
  by move: (ax) => [[_ a2 _ _] _]; apply: (a2 _ (card_lt_succ nB)).
have cnp := ((proj2 ax) _ (card_lt_succ nB)).
move: (opow_Mspec2 oen bg2) => le1.
have op: ordinalp (b ^o en) by ord_tac.
move: (oprod_Mle1 op cnp); rewrite -/(cantor_mon b e c n) -/A => le2.
have oA:=(CNFq_p0 (proj1 ax) (card_lt_succ nB)).
have le3: en <=o b *o en by apply oprod_M1le.
have le4:= (ord_leT le3 le1).
have le5:= (ord_leT le4 le2).
have ax1:=(CNFb_p5 nB ax).
have oB:= (OS_CNFq nB (proj1 ax1)).
have le7:= (osum_Mle0 oA oB).
have pg: en = x -> B = \0o.
  rewrite xv; move=> es; rewrite es in le5.
  exact (osum_a_ab oA oB (ord_leA le5 le7)).
split.
  by move=> ex; apply: ord_leA; [rewrite -{1} ex xv (pg ex) (osum0r oA) | ue].
rewrite /b_critical => ci.
have le6: en <=o x by rewrite xv; ord_tac.
move: (CNFq_pg1 nB (proj1 ax)); rewrite -/x -/e - {1} ci => le8.
case: (equal_or_not en x) => nex; last first.
  have xx: succ_o en <=o x by apply /ord_succ_ltP.
  move: (opow_Meqle bp xx) => le9; ord_tac.
split => //; ex_middle n0.
move:(cpred_pr nB n0) => [mB mv].
move:(pg nex) ax1; rewrite /B mv => uu ax1.
by move: (proj2 (CNFq_pg5 mB ax1)); rewrite uu.
Qed.

Lemma the_cnf_e_p6 x (y:=the_cnf_expos x): ordinalp x ->
   ((b_critical x -> y = singleton x) /\
   (~ (b_critical x) -> forall a, inc a y -> a <o x)).
Proof.
move => ox.
move:(the_cnf_p0 bg2 ox) => [/(cnfb_ax_simp) [nB ax] xv].
case: (ord_zero_dichot ox) => nz.
  split; first by rewrite nz /b_critical opowx0 => h; case: card1_nz.
  by rewrite /y nz the_cnf_expos_zero => _ t /in_set0.
move:(the_cnf_p2 bg2 nz) => []; set m := cpred _ => mB mv.
rewrite mv in ax.
move: (the_cnf_e_p5 mB ax). rewrite -mv -/(cnfbv _ _) xv; move=> [ph pi].
split.
   move=> cx; move: (pi cx) => [pj pk].
   rewrite /y /the_cnf_expos / CNF_exponents /the_cnf_len mv pj succ_zero.
   by rewrite (proj2 Bint_co01) funI_set1 - pj pk.
move=> ncx.
move: (the_cnf_e_p3 mB ax); rewrite - mv -/(cnfbv _ _) xv => le1.
have lt1: Vg (P (Q (the_cnf b x))) m <o x by split => //; dneg h; apply: ph.
rewrite /y /the_cnf_expos / CNF_exponents /the_cnf_len mv.
move=> a /funI_P [z /(BintP (BS_succ mB)) zi ->].
have zle: z <=c m by apply /(card_lt_succ_leP mB).
move:(CNF_exponents_M (BS_succ mB) (proj1 ax) zle (card_lt_succ mB)) =>h1.
ord_tac.
Qed.

Definition the_cnf_expos_rec x:=
 induction_defined (fun z => union (fun_image z the_cnf_expos))
    (the_cnf_expos x).

Definition the_cnf_expos_rec_nc x n :=
  Zo (Vf (the_cnf_expos_rec x) n) (fun z => ~ (b_critical z)).

Lemma the_cnf_e_p7 x n (y := Vf (the_cnf_expos_rec x) n):
   ordinalp x -> inc n Bnat -> (finite_set y /\ ordinal_set y).
Proof.
move=> ox; rewrite /y; clear y; move : n.
move: (induction_defined_pr (fun z => union (fun_image z the_cnf_expos))
    (the_cnf_expos x)).
rewrite -/(the_cnf_expos_rec x); move=> [sg sjg gz gnz].
apply: cardinal_c_induction.
  rewrite gz.
  exact (the_cnf_e_p2 ox).
move => n nB [pa pb]; rewrite (gnz _ nB); split.
  rewrite - setUb_identity; apply: finite_union_finite.
   hnf;rewrite /identity_g; bw =>i idf; bw.
    move: idf => /funI_P [z zn ->].
    by move: (the_cnf_e_p2 (pb _ zn)) => [ok _].
 by rewrite /identity_g; bw; apply: finite_fun_image.
move=> t /setU_P [y ty] /funI_P [z zw yv].
move: (the_cnf_e_p2 (pb _ zw)) => [_ ok].
by rewrite - yv in ok; apply: ok.
Qed.

Lemma the_cnf_e_p8 x n (f := (the_cnf_expos_rec x)):
  ordinalp x -> inc n Bnat ->
  the_cnf_expos_rec_nc x n = emptyset ->
  ( (forall a, inc a (Vf f n) -> b_critical a)
  /\ (forall k, inc k Bnat -> n <=c k -> Vf f k = Vf f n)).
Proof.
move=> ox nB me.
pose q m := the_cnf_expos_rec_nc x m = emptyset.
have pa: forall m, q m -> (forall a, inc a (Vf f m) -> b_critical a).
  by rewrite /q => m h a aw; ex_middle anc; empty_tac1 a; apply: Zo_i.
move: (induction_defined_pr (fun z => union (fun_image z the_cnf_expos))
  (the_cnf_expos x)); rewrite -/ (the_cnf_expos_rec x) -/f.
move=> [sg sjg gz gnz].
have pb: forall m, inc m Bnat -> q m -> (Vf f m = Vf f (succ m) /\ q (succ m)).
  move=> m mB qm.
  suff h: Vf f m = Vf f (succ m).
   by split => //; move: qm; rewrite /q /the_cnf_expos_rec_nc h //.
  rewrite (gnz _ mB); move: (pa _ qm) => ax.
  move: (the_cnf_e_p7 ox mB) => [_ osf].
  set_extens t.
    move => ts; apply /setU_P.
    move: (ax _ ts) (the_cnf_e_p6 (osf _ ts)) => cy [ h _].
    move: (h cy) => px; exists (singleton t); first by fprops.
    apply /funI_P; ex_tac.
  move /setU_P => [y ty] /funI_P [z zw yv].
  move: (ax _ zw) (the_cnf_e_p6 (osf _ zw)) => cy [ h _].
  by move: ty; rewrite yv (h cy) => /set1_P ->.
split; first by apply: pa.
suff: forall k : Set, inc k Bnat -> n <=c k -> (q k /\ Vf f k = Vf f n).
  by move=> aux k kB nk; move: (aux _ kB nk) => [ _ ].
apply: cardinal_c_induction.
  move=> aux; move: me; rewrite (card_le0 aux); split => //.
move => k kB hrec nsk0.
case: (equal_or_not n (succ k)) => nsk; first by rewrite -nsk //.
move: (conj nsk0 nsk); move /(card_lt_succ_leP kB) => h1.
move: (hrec h1) => [pc pd]; move: (pb _ kB pc) => [pe pf]; split => //; ue.
Qed.

Lemma the_cnf_e_p9 x: ordinalp x ->
  exists2 n, inc n Bnat & the_cnf_expos_rec_nc x n = emptyset.
Proof.
move=> ox; ex_middle aux.
have pa: forall n, inc n Bnat -> nonempty (the_cnf_expos_rec_nc x n).
  move=> n nB; case: (emptyset_dichot (the_cnf_expos_rec_nc x n)) => //.
  move => p; case: aux; ex_tac.
pose T := (the_cnf_expos_rec_nc x).
pose h n := \osup (T n).
have hp: forall n, inc n Bnat ->
   [/\ (forall a, inc a (T n) -> a <=o h n),
     inc (h n) (T n) &
     forall a, inc a (T (succ n)) -> a <o (h n)].
   move=> n nB; move: (the_cnf_e_p7 ox nB) => [fs os].
   have sT: sub (T n) (Vf(the_cnf_expos_rec x) n) by apply: Zo_S.
   have osT: ordinal_set (T n) by move=> t aT; apply (os _ (sT _ aT)).
   have pX: (forall a : Set, inc a (T n) -> a <=o h n).
      by move=> a aT; apply: ord_sup_ub.
   have pY: inc (h n) (T n).
     move:(wordering_ordinal_le_pr osT).
     set r := (graph_on ordinal_le (T n)); move=> [wor sr].
     move: (worder_total wor) => tor.
     have srt: sub (T n) (substrate r) by rewrite sr; fprops.
     move: (sub_finite_set sT fs) => fsT.
     move: (finite_subset_torder_greatest tor fsT srt (pa _ nB)) => [g gr].
     move: tor => [or _].
     move: gr => []; rewrite iorder_sr // => p1 p2.
     have <- //: g = h n.
     apply: (ord_leA); first by apply: ord_sup_ub.
     apply: ord_ub_sup => //; first by apply: osT.
     move=> i iT; move: (iorder_gle1 (p2 _ iT)).
     by move /graph_on_P1 => [_ _].
  split => //.
  move => a /Zo_P [qa qb].
  move: (induction_defined_pr (fun z => union (fun_image z the_cnf_expos))
    (the_cnf_expos x)); rewrite -/ (the_cnf_expos_rec x).
  move=> [_ _ _ gnz].
  move: qa; rewrite (gnz _ nB) => /setU_P [y ay] /funI_P [z zT yv].
  rewrite yv in ay.
  move: (the_cnf_e_p6 (os _ zT)) => [zp zq].
  case: (p_or_not_p (b_critical z)) => zc.
    by case: qb; move: ay; rewrite (zp zc) => /set1_P ->.
  move: ((zq zc) _ ay) => z1.
  by apply: (ord_lt_leT z1); apply:pX; apply: Zo_i.
have xx: forall n, inc n Bnat -> h (succ n) <o h n.
  move=> n nB; move: (hp _ nB) => [_ _ p3]; apply: p3.
  by move:(hp _ (BS_succ nB)) => [_ p2 _].
set R:= fun_image Bnat h.
have neR: nonempty R by exists (h \0c); apply /funI_P; exists \0c;fprops.
have osR: ordinal_set R.
  by move =>t /funI_P [n nB ->]; move: (xx _ nB) => [[_]].
move: (ordinal_setI neR osR); set t := intersection R.
move=> /funI_P [n nB nv]; move: (xx _ nB).
have hsi: inc (h (succ n)) R by apply /funI_P;exists (succ n); fprops.
move: (setI_s1 hsi); rewrite -/t nv.
move => th /ord_ltP0 [oh _ ih].
by move: (ordinal_irreflexive oh (th _ ih)).
Qed.

End Exercise6_15.

Exercise 6.16

Lemma Exercise6_16a r: total_order r -> exists2 X,
  cofinal r X & (worder (induced_order r X)).
Proof.
move => [or tor];move: (Exercise2_2b or) => [X [Xsr worX ub]].
exists X => //; split => // x xsr.
case: (inc_or_not x X) => xX; first by ex_tac; order_tac.
ex_middle h; case: xX; apply: ub.
split => // z zX; case: (tor _ _ xsr (Xsr _ zX)) => //.
move=> xz; case: h; ex_tac.
Qed.

Lemma cofinality'_pr1 r: total_order r ->
   (nonempty (cofinality' r) /\ ordinal_set (cofinality' r)).
Proof.
move => tor; rewrite /cofinality'.
move: (Exercise6_16a tor) => [X ta tb].
split.
   exists (ordinal (induced_order r X)); apply /funI_P; exists X => //.
   by apply: Zo_i => //; move: ta => [tc _]; apply /setP_P.
move=> x => /funI_P [z szf ->]; apply: OS_ordinal.
by move: szf => /Zo_hi [_].
Qed.

Lemma intersection_sub1 A B C:
   A = union2 B C -> (forall x, inc x C -> exists y, inc y B /\ sub y x)
   -> intersection A = intersection B.
Proof.
move=> -> h.
case: (emptyset_dichot B) => bne.
  rewrite bne set0_U2.
  have -> //: C = emptyset.
  by apply /set0_P => t /h [y []]; rewrite bne => /in_set0.
have neA: nonempty (B \cup C).
  by move: bne => [x xB]; exists x; apply /setU2_P; left.
set_extens t.
   move /(setI_P neA) => aux; apply /(setI_P bne) => i iB; apply: aux; fprops.
move /(setI_P bne) => aux; apply /(setI_P neA) => i iB.
case/setU2_P: iB => iB; first by apply: aux.
by move: (h _ iB) => [y [yB]]; apply; apply: aux.
Qed.

Lemma cofinal_trans r x y:
   order r -> cofinal r x -> cofinal (induced_order r x) y ->
   cofinal r y.
Proof.
move=> or [xsr cx]; move /(cofinal_inducedP or y xsr).
move=> [yx xy]; split; first by apply: sub_trans xsr.
move=> t tx; move: (cx _ tx) => [z zx zy].
move: (xy _ zx) => [u uy zu]; ex_tac; order_tac.
Qed.

Lemma cofinal_image r r' f x:
    order_isomorphism f r r' -> cofinal r x ->
    cofinal r' (image_by_fun f x).
Proof.
move=> [o1 o2 [bf sf tf] isf] [xsr cx].
have ff: function f by fct_tac.
have xsf: sub x (source f) by ue.
split.
  move=> t /(Vf_image_P ff xsf) [u ux ->]; rewrite - tf; Wtac.
rewrite - tf; move => y yt; move: (bij_surj bf yt) => [z zf <-].
rewrite sf in zf; move: (cx _ zf) => [t tx ty].
exists (Vf f t); first by apply/(Vf_image_P ff xsf); ex_tac.
rewrite -isf //; [ ue | by apply: xsf].
Qed.

Lemma worder_image r r' f A:
  order_isomorphism f r r' -> sub A (substrate r) ->
  let oa := (induced_order r A) in
  let ob := (induced_order r' (image_by_fun f A)) in
  worder oa -> (worder ob /\ ordinal oa = ordinal ob).
Proof.
move=> isf Asr oa ob wo1.
move: (isf) => [o1 o2 [bf sf tf] isfo].
have ff: function f by fct_tac.
have sAs: sub A (source f) by ue.
have pa: sub (image_by_fun f A) (substrate r').
  move => t /(Vf_image_P ff sAs) [u uA ->]; rewrite - tf; Wtac.
move: (iorder_osr o2 pa) => [oob sob].
move: (bf) => [injf _].
move: (restriction1_fb injf sAs) => br.
have sr1: (source (restriction1 f A)) = A by rewrite /restriction1 ; aw.
have aux: forall x, inc x A -> inc (Vf f x) (image_by_fun f A).
  move => x xA; apply /(Vf_image_P ff sAs); ex_tac.
have abis: oa \Is ob.
   exists (restriction1 f A); split;fprops; first split => //.
       rewrite /oa sr1; aw.
     rewrite /ob/restriction1; aw.
   hnf;rewrite sr1; move=> x y xA yA.
   move: (sAs _ xA) (sAs _ yA) => xs ys.
   rewrite restriction1_V // restriction1_V //.
   by split;move / iorder_gle5P => [qa qb qc]; apply /iorder_gle5P;split => //;
       try (apply: aux =>//); apply/(isfo _ _ xs ys).
suff soob: worder ob by split => //; apply: ordinal_o_isu1.
split => //.
move: wo1 => [ _ ].
rewrite iorder_sr // iorder_sr // => wo1.
move => x xi nex; rewrite iorder_trans //.
set z:= image_by_fun (inverse_fun f) x.
move: (inverse_bij_fb bf) => ibf.
have fif: function (inverse_fun f) by fct_tac.
have sxt: sub x (target f) by apply: (sub_trans xi); apply: fun_image_Starget1.
have sxt1: sub x (source (inverse_fun f)) by aw.
have sxs: sub x (substrate r') by ue.
have nez: nonempty z.
   move: nex => [w wx]; exists (Vf (inverse_fun f) w).
   apply /(Vf_image_P fif sxt1); ex_tac.
have za: sub z A.
  move=> t /(Vf_image_P fif sxt1) [u ux ->].
  move: (xi _ ux) => /(Vf_image_P ff sAs); move=> [v vA ->].
  by rewrite (inverse_V2 bf (sAs _ vA)).
move: (wo1 _ za nez); rewrite iorder_trans //; move => [y []].
have zr: sub z (substrate r) by rewrite - sf; apply: sub_trans sAs.
rewrite /least iorder_sr // iorder_sr //.
move /(Vf_image_P fif sxt1) => [z1 z2 ->] yl;exists z1; split => //.
move => a ax; apply /iorder_gleP => //.
set b := Vf (inverse_fun f) a.
have bz: inc b z by apply /(Vf_image_P fif sxt1); ex_tac.
have atf: inc a (target f) by apply sxt.
have z1tf: inc z1 (target f) by apply sxt.
have qa: inc (Vf (inverse_fun f) z1) (source f) by apply: inverse_Vis.
have qb: inc (Vf (inverse_fun f) a) (source f) by apply: inverse_Vis.
move: (yl _ bz) => le1; move: (iorder_gle1 le1).
rewrite /b isfo // (inverse_V bf z1tf) // (inverse_V bf atf) //.
Qed.



Exercise 6.10


Lemma cofinality_pr6 a f (b:= omega_fct a):
   ordinalp a ->
   inc f (functions b b) ->
   exists g, inc g (injections b b) /\
   (forall x, inc x b -> Vf f x <=o Vf g x).
Proof.
move => oa /fun_set_P [ff sf tf].
move: (aleph_limit oa); rewrite -/b => lb.
move: (lb) => [ob zb plb].
move: (ordinal_o_wor ob); set r := ordinal_o _ => wor.
have sr: substrate r = b by rewrite /r ordinal_o_sr.
pose unsrc f:= Yo (inc (source f) b) (source f) \0o.
have cp3: forall x, inc (unsrc x) b by move=> x; rewrite /unsrc; Ytac h => //.
pose coer1 v y := intersection (b -s (union2 v y)).
pose coex v := (Yo (inc v b) v \0o).
pose p g := let s := unsrc g in
   coex (coer1 (Vf f s) (image_by_fun g s)).
have ts: (forall g, function g -> segmentp r (source g) ->
      sub (target g) b -> inc (p g) b).
 by move=> g gf srg sta; rewrite /p /coex; Ytac h.
move: (transfinite_defined_pr p wor); rewrite /transfinite_def sr.
move: (transfinite_definition_stable wor ts).
set g:= transfinite_defined r p; move=> tg1 [[fg _] sg tgp].
pose Tf := image_by_fun g.
have sfa: forall x, inc x b -> sub x (source g).
   move=> x xb; rewrite sg; apply: (ordinal_transitive ob xb).
have cp4: forall x, inc x b->
   [/\ (source (restriction_to_segment r x g)) = x,
    function (restriction_to_segment r x g) &
   Vf g x = (coer1 (Vf f x) (Tf x)) ].
  move=> x xb.
  rewrite (tgp _ xb) /p /unsrc.
  have -> : (source (restriction_to_segment r x g)) = x.
    rewrite /restriction_to_segment /restriction1; aw.
    rewrite /r ordinal_segment //.
  have s1: sub (segment r x) (source g) by rewrite sg - sr;apply: sub_segment.
  move: (proj1 (restriction1_fs fg s1)) => qa.
  split => //.
  move: (ordinal_hi ob xb)=> ox.
  rewrite Y_true //.
  set wa := (image_by_fun _ _).
  have -> :coex (coer1 (Vf f x) wa) = coer1 (Vf f x) wa.
    rewrite /coex/coer1; set c:= _ -s _; apply: Y_true.
    case: (emptyset_dichot c) => ce.
      rewrite ce setI_0; exact.
    have os: ordinal_set c by move => t /setC_P [tb _]; ord_tac0.
    by move: (ordinal_setI ce os) => /setC_P [].
  congr ((coer1 (Vf f x) _)).
  have aux: forall w, inc w x -> inc w (segment r x).
    move=> w wx; apply /segmentP.
    move: (ordinal_transitive ox wx) => wx1.
    move: ((ordinal_transitive ob xb) _ wx) => wc.
    split; last by move=> ewx; rewrite ewx in wx; case: (ordinal_decent ox wx).
    apply /sub_gleP;split => //.
  move: (sfa _ xb) => qb.
  have qc: sub x (source (restriction_to_segment r x g)).
    rewrite /restriction_to_segment /restriction1; aw.
   set H := restriction1_V fg s1.
  set_extens t.
     move /(Vf_image_P qa qc) => [w wx]; rewrite (H _ (aux _ wx)).
     move => h;apply /(Vf_image_P fg qb); ex_tac.
  move/(Vf_image_P fg qb) => [w wx j];apply /(Vf_image_P qa qc);ex_tac.
  by rewrite (H _ (aux _ wx)).
have ta: lf_axiom (Vf g) b b.
  move => t ta; apply: tg1; apply: Vf_target => //; ue.
have taa: forall x, inc x b -> lf_axiom (Vf g) x b.
  move=> x xb t ita; move: (ordinal_transitive ob xb ita); apply ta.
set h:= Lf (fun z => Vf g z) b b.
have hp: forall x, inc x b -> Vf h x = Vf g x.
  move => x xsf; rewrite /h lf_V //.
have off1: forall x, inc x b -> inc (Vf f x) b.
  by move => x xb; rewrite - tf; apply: Vf_target => //; ue.
have off2: forall x, inc x b -> ordinalp (Vf f x).
  by move => x xb; move: (off1 _ xb) => wb; ord_tac0.
have cp5: forall x, inc x b -> nonempty (b -s (union2 (Vf f x) (Tf x))).
  move => x xb.
  have cb: cardinalp b by apply: CS_aleph.
  move: (off2 _ xb) => cw.
  have: Vf f x <o b by move /(ord_ltP ob): (off1 _ xb).
  move/ (ordinal_cardinal_le2P cb cw) => lec1.
  have ox: ordinalp x by ord_tac0.
  have: x <o b by move/(ord_ltP ob): xb.
  move /(ordinal_cardinal_le2P cb ox) => lec2.
  move: (cp4 _ xb) => [q1 q2 q3].
  have s1: sub (segment r x) (source g) by rewrite sg - sr;apply: sub_segment.
  have eq1: Tf x = image_of_fun (restriction_to_segment r x g).
    have ss1: sub x (source (restriction_to_segment r x g)) by rewrite q1.
    have ss2: sub x (source g) by rewrite sg; apply: (ordinal_transitive ob xb).
    have sw: forall u, inc u x -> Vf (restriction_to_segment r x g)u = Vf g u.
      move => u ux.
      have iub: inc u b by rewrite sg in ss2; apply: ss2.
      by rewrite (restriction1_V fg s1) //; apply /segmentP; apply/ordo_ltP.
    set_extens t.
      move /(Vf_image_P fg ss2) => [w wx ->] ; apply/(Vf_image_P1 q2).
      exists w; [ by apply: ss1 | by symmetry;apply: sw].
    move /(Vf_image_P1 q2); rewrite q1; move => [u ux ->]; rewrite (sw _ ux).
    apply /(Vf_image_P fg ss2); ex_tac.
   move: (image_smaller_cardinal q2); rewrite - eq1 q1 => le1.
   move: (card_le_ltT le1 lec2) => le2.
   apply: (infinite_union2 (aleph_pr5c oa) lec1 le2).
have cp6: forall x, inc x b ->
   inc (Vf g x) (b -s (union2 (Vf f x) (Tf x))).
  move => x xb; move: (cp5 _ xb)=> ne.
  rewrite (proj33 (cp4 _ xb)) /coer1; set c:= _ -s _.
  have os: ordinal_set c by move => t /setC_P [tb _]; ord_tac0.
  exact (ordinal_setI ne os).
have ra: function_prop h b b
  by rewrite /h; red; aw; split => //; apply: lf_function.
have rb: (forall x, inc x b -> Vf f x <=o Vf h x).
  move => x xb; rewrite (hp _ xb).
  move: (cp6 _ xb) => /setC_P [p1] /setU2_P p2.
   have os1: ordinalp (Vf g x) by ord_tac0.
  have ow: ordinalp (Vf f x) by apply: off2.
  case: (ord_le_to_el ow os1) => //; move /ord_ltP0 => [_ _ pc].
  by case: p2; left.
have rc: injection h.
  apply: lf_injective => //.
  move => u v ub vb sv.
  have svg: sub v (source g) by rewrite sg => t tv; ord_tac0.
  have sug: sub u (source g) by rewrite sg => t tv; ord_tac0.
  case: (ord_le_to_ell (ordinal_hi ob ub)(ordinal_hi ob vb)) => // cuv.
    move: (cp6 _ vb) => /setC_P [p1] /setU2_P;case; right.
    apply /(Vf_image_P fg svg); exists u => //.
    by move: cuv => /ord_ltP0 [_ ].
  move: (cp6 _ ub) => /setC_P [p1] /setU2_P;case; right.
  apply /(Vf_image_P fg sug); exists v => //.
  by move: cuv => /ord_ltP0 [_ ].
exists h;split => //;apply: Zo_i => //; apply /fun_set_P; exact ra.
Qed.

Lemma cofinality_pr7 X b f (E := omega_fct b):
  ofg_Mle_leo X -> domain X = omega_fct b -> ordinalp b ->
  limit_ordinal (\osup (range X)) ->
  inc f (functions E (omega_fct (union (range X)))) ->
  exists2 g, inc g (injections E E) &
    (forall x, inc x (source f) -> Vf f x <=o omega_fct (Vg X (Vf g x))).
Proof.
move=> [p1 p2 p2'] p4 p3.
have lb: limit_ordinal (domain X) by rewrite p4; apply: aleph_limit.
set a := (union (range X)) => la.
set E1 := functions E (omega_fct a).
set F2 := functions E E.
move => /fun_set_P [ff sf tf].
move: (p1)(lb) => fgX [p5 p5' p6].
move: (ofg_Mle_leo_os p1 p2) => p8.
have p9: forall t, inc t (omega_fct a) ->
    exists u, inc u E /\ t <=o omega_fct (Vg X u).
    move => t ta.
    move: (la) => [oa _].
    move: (OS_aleph oa) => pa0.
    move: aleph_pr11 => [_ ap1]; move: (ap1 _ la) => ap2.
    have ap3: (ordinal_set (fun_image a omega_fct)).
      move => u /funI_P [v ve ->]; apply OS_aleph; ord_tac0.
    have ap4: t <o \osup (fun_image a omega_fct).
      by rewrite - ap2; apply /ord_ltP.
    move: (ord_lt_sup ap3 ap4) => [z ] /funI_P [w wa ->].
    move => le1.
    have le2: w <o union (range X) by apply /ord_ltP.
    move: (ord_lt_sup p8 le2) => [u q1 q2].
    move:q1 => /(range_gP fgX) [v vd vv].
    rewrite /E - p4; exists v; split => //; apply: (ord_leT (proj1 le1)).
    rewrite - vv; apply: (aleph_le_leo (proj1 q2)).
pose bv t := choose (fun u => inc u E /\ t <=o omega_fct (Vg X u)).
have p10: forall t, inc t (omega_fct a) ->
      (inc (bv t) (omega_fct b) /\ t <=o omega_fct (Vg X (bv t))).
   move => t to;apply: (choose_pr (p9 _ to)).
pose bff := Lf (fun z => bv (Vf f z)) E E.
have p11: lf_axiom (fun z : Set => bv (Vf f z)) E E.
  move => z ze.
  have wt: inc (Vf f z)(omega_fct a) by rewrite -tf; Wtac.
  by move: (p10 _ wt) => [].
have p12: inc bff F2.
   apply /fun_set_P;rewrite /bff;red;aw;split => //.
   apply: lf_function; apply: p11.
have p13: forall x, inc x (source f) -> Vf f x <=o omega_fct (Vg X (Vf bff x)).
  move => x xsf.
  rewrite sf in xsf; rewrite /bff; aw.
  have wt: inc (Vf f x)(omega_fct a) by rewrite -tf; Wtac.
  by move: (p10 _ wt) => [].
move: (cofinality_pr6 p3 p12)=> [g [ge H]]; exists g=> //.
move => x xsf; move: (p13 _ xsf) => le1.
apply (ord_leT le1); apply: aleph_le_leo.
rewrite sf in xsf.
move: (H _ xsf) => h1.
have q4: inc (Vf bff x) (domain X).
  by move: p12 => /fun_set_P [s1 s2 s3]; rewrite p4 -/E - s3; Wtac.
have q5: inc (Vf g x) (domain X).
  move: ge => /Zo_P [] /fun_set_P [s1 s2 s3] _.
  by rewrite p4 /E - s3; Wtac; rewrite s2.
exact: (p2' _ _ q4 q5 h1).
Qed.

Lemma infinite_increasing_power3 X b:
  ofg_Mle_leo X -> domain X = omega_fct b -> ordinalp b ->
  limit_ordinal (\osup (range X)) ->
  card_prod (Lg (domain X) (fun z => \aleph (Vg X z))) =
  \aleph (\osup (range X)) ^c \aleph b.
Proof.
move => si dx ob lb.
move: (si) => [fgf oob incx].
apply: card_leA.
  have ->: omega_fct b = cardinal (domain X).
    by rewrite dx card_card //; apply: CS_aleph.
  by apply: infinite_increasing_power_bound1.
set a := (\osup (range X)).
set E := (functions (omega_fct b) (omega_fct (union (range X)))).
set F := (functions (omega_fct b) (omega_fct b)).
set F1 := (injections (omega_fct b) (omega_fct b)).
pose G g := Lg (omega_fct b) (fun z => succ_o (omega_fct (Vg X(Vf g z)))).
have pa: forall f, inc f E -> exists2 g,
   inc g F1 & inc (graph f) (productb (G g)).
   move => f fe; move: (cofinality_pr7 si dx ob lb fe) => [g ge h].
   move: fe => /fun_set_P [ff sf tf].
   have pa: fgraph (G g) by rewrite /G; fprops.
   exists g => //; apply /setXb_P => //.
   rewrite /G; bw; aw;split => //; first by fprops.
   move => i isf; bw.
   rewrite - sf in isf; move: (h _ isf) => le1.
   rewrite -/(Vf f i); apply/ ord_leP => //; ord_tac.
have -> : omega_fct a ^c omega_fct b = cardinal E.
   rewrite cpow_pr1 -/a; apply: cpow_pr; fprops.
set E1 := gfunctions (omega_fct b) (omega_fct a).
have ->: cardinal E = cardinal E1.
  apply /card_eqP; apply:fun_set_equipotent.
have eu: sub E1 (unionb (Lg F1 (fun g => (productb (G g))))).
  move=> f; rewrite /E1 => fe.
  move: (gfun_set_hi fe) => [h [fh sh tf gh]].
  have hd: inc h E by apply /fun_set_P;split => //.
  move: (pa _ hd) => [g ge gv].
  by apply /setUb_P; bw; exists g=> //; bw; rewrite -gh.
move: (sub_smaller eu).
set Y := Lg _ _.
have fgy: fgraph Y by rewrite /Y; fprops.
move: (csum_pr1 Y) => le1 le2; move: (card_leT le2 le1).
rewrite {1}/Y; bw ;move => le3; apply: (card_leT le3); clear le1 le2 le3.
set p := card_prod _.
have aux: p *c F1 <=c p.
   have -> : p *c F1 = p *c (cardinal F1) by symmetry; apply: cprod2_pr2b.
   have ne1: cardinal F1 <> \0c.
     apply: cardinal_nonemptyset1.
     exists (identity (omega_fct b)); apply: Zo_i.
       apply /fun_set_P; apply:identity_prop.
     by move: (identity_fb (omega_fct b)) => [].
   have s1: sub F1 F by apply: Zo_S.
   move: (sub_smaller s1); rewrite /F cpow_pr1.
   move: (aleph_pr5c ob) => icb.
   rewrite (card_card (proj1 icb)) (infinite_power1_b icb) => le2.
   have le3: \2c ^c omega_fct b <=c p.
     rewrite - cpow_pr2 /cst_graph /p - dx; apply: cprod_increasing; fprops; bw.
     move => x xd; bw; apply: infinite_ge_two; apply: aleph_pr5c.
      apply: (oob _ xd).
   have le1: cardinal F1 <=c p by co_tac.
   have icp: infinite_c p.
     move: (cantor (proj1 icb)) => le4.
     exact (ge_infinite_infinite icb (card_leT (proj1 le4) le3)).
   rewrite (product2_infinite le1 icp ne1).
   apply: card_leR; co_tac.
suff qa: forall g, inc g F1 -> cardinal (Vg Y g) <=c p.
   have : card_sum (Lg F1 (fun a0 : Set => cardinal (Vg Y a0))) <=c
    card_sum (cst_graph F1 p).
    apply: csum_increasing.
          fprops.
         rewrite /cst_graph; fprops.
      rewrite /cst_graph; bw.
    by rewrite /cst_graph; bw => x xf; bw; apply: qa.
  by rewrite csum_of_same => xx; apply: (card_leT xx).
move => g gi; rewrite /Y; bw.
move: gi => /Zo_P [] /fun_set_P [fg sg tg] ig.
set f:= (Lg (omega_fct b) (fun z : Set => (omega_fct (Vg X (Vf g z))))).
have ->: cardinal (productb (G g)) = card_prod f.
   apply /card_eqP; apply: equipotent_setXb.
  rewrite /G/f; split;fprops; bw; move => x xd; bw; eqsym.
  have wi: inc (Vf g x) (domain X).
     rewrite dx -tg; apply: Vf_target => //; ue.
  move: (aleph_pr5c (oob _ wi)) => [_].
  apply.
rewrite /p.
set h := Lg _ _.
move: (fun_image_Starget fg) => sd1.
move: (sd1); rewrite tg - dx => sd.
have sd2: sub (image_of_fun g) (domain h) by rewrite /h; bw.
have ca: cardinal_fam h.
   rewrite /h/cardinal_fam; red;bw => i idx; bw.
   apply: CS_aleph; exact (oob _ idx).
have -> : card_prod f = card_prod (restr h (image_of_fun g)).
  have fgh: fgraph h by rewrite /h; fprops.
  rewrite /f /h.
  move: (restriction_to_image_fb ig) => bg.
  set Z:= restr _ _.
  have fgz: fgraph Z by rewrite /Z/restr; apply: restr_fgraph.
  have trt: target (restriction_to_image g) = domain Z.
    rewrite /restriction_to_image /restriction2 /Z restr_d //; aw.
  rewrite (cprod_Cn trt bg) /composef (f_domain_graph (proj1 (proj1 bg))).
  rewrite {1} /restriction_to_image /restriction2; aw; rewrite sg.
  apply: f_equal; apply: Lg_exten => x xd.
  have xsd: inc x (source g) by ue.
  have wi: inc (Vf g x) (image_of_fun g).
    apply /(Vf_image_P1 fg); ex_tac.
  have ra: restriction2_axioms g (source g) (image_of_fun g) by split.
  rewrite -/(Vf (restriction_to_image g) x) /restriction_to_image /Z.
  by rewrite restriction2_V //restr_ev //; bw; apply: sd.
rewrite /h; apply: (cprod_increasing1); red; bw.
move => x xd; bw; apply: aleph_nz; exact (oob _ xd).
Qed.

Lemma exercise_6_19b a (ba := ord_index (cofinality (\aleph a)))
  (x := \aleph a) (y := \aleph ba):
  ordinalp a ->
  (x <c x ^c y /\
   (forall n c, cardinalp n -> ordinalp c -> x = n ^c (\aleph c) ->
       c <o ba)).
Proof.
move => oa.
move: (aleph_pr5c oa) => io.
move: (cofinality_pr3 (proj1 (proj1 io))).
move: (cofinality_infinite io).
rewrite (cofinality_card io) =>pa pd.
move: (cofinality_card io) => H.
move: (ord_index_pr1 pa) => [pb]; rewrite - /ba -/y -/x - H.
move => yc.
split.
  rewrite yc; apply: power_cofinality.
  by apply: infinite_ge_two; apply: aleph_pr5c.
move => n c cn oc eq.
have qa: \2c <=c n.
  apply: card_ge2 => //.
    move=> n0; move: eq; rewrite n0 cpow0x; by apply: aleph_nz.
  move => n1; move: eq; rewrite n1 cpow1x => x1.
  move: (aleph_pr5c oa); rewrite -/x x1.
  apply: infinite_dichot1; fprops.
have qb:infinite_c (\aleph c) by apply: aleph_pr5c.
move: (power_cofinality5 qa qb); rewrite -eq - H - yc => l2.
apply: aleph_ltc_lt => //.
Qed.


Exercise 6 24

Section Exercise6_24.
Variables (E F a: Set).
Hypothesis FE: forall x, inc x F -> sub x E.
Hypothesis cF: cardinal F = a.
Hypothesis ceF: forall x, inc x F -> cardinal x = a.
Hypothesis iF: infinite_c a.

Lemma Exercise6_24a:
   exists P, [/\ sub P E,cardinal (P) = a &
   forall x, inc x F -> ~ (sub x P)].
Proof.
move: (proj1 iF) => ca.
move: (sym_eq cF); rewrite - (card_card ca); move /card_eqP => [g [bg sg tg]].
have fg: function g by fct_tac.
have oa: ordinalp a by apply: OS_cardinal.
have g1: forall b, b <o a -> inc (Vf g b) F.
   move => b /(ord_ltP oa); rewrite - sg - tg => h; Wtac.
have g2: forall x, inc x F -> exists2 b, b <o a & (Vf g b) = x.
  rewrite -tg => x xt; move: (bij_surj bg xt) => [b b1 b2]; exists b => //.
  apply /(ord_ltP oa); ue.
pose PP x b p := [/\ pairp p, (inc (P p) ((Vf g b) -s x)),
   (inc (Q p) ((Vf g b) -s x)) & P p <> Q p].
have g3: forall x b, cardinal x <c a -> b <o a -> exists p, PP x b p.
  move => x b cx ba; rewrite /PP;move: (g1 _ ba); set s:= (Vf g b) => sF.
  have cs: cardinal s = a by apply: ceF.
  have ifs: infinite_set s by apply /infinite_setP; rewrite cs.
  rewrite - cs in cx.
  move: (infinite_compl ifs cx); rewrite cs => h.
  have: (\2c <=c cardinal (s -s x)) by apply: finite_le_infinite; fprops; ue.
  move/card_le2P => [u [v [u1 u2 u3]]].
  exists (J u v);split => //; aw; fprops.
fprops; aw.
pose g4 x b := choose (PP x b).
have g5: forall x b, cardinal x <c a -> b <o a -> PP x b (g4 x b).
move => x b p1 p2; move: (g3 _ _ p1 p2); apply: choose_pr.
pose mu X := (domain X \cup range X).
have mu1: forall X, cardinal X <c a -> cardinal (mu X) <c a.
  move => X xs; apply: csum2_pr6_inf2 => //;
  apply: card_le_ltT xs; apply: fun_image_smaller.
pose g6 fct := g4 (mu (target fct)) (source fct).
move: (ordinal_o_wor oa) => wor.
move: (transfinite_defined_pr g6 wor).
set f := transfinite_defined _ _.
rewrite /transfinite_def (ordinal_o_sr a); move=> [pa pb pc].
have g7: forall x, inc x a -> Vf f x = g4 (mu (image_by_fun f x)) x.
  move => x xa; rewrite (pc _ xa) /restriction_to_segment
    (ordinal_segment oa xa) /g6 /restriction1; aw.
have g8: forall x, inc x a -> cardinal x <c a.
  move => x /(ord_ltP oa) h.
  apply /(ordinal_cardinal_le2P ca) => //; ord_tac.
have g9: forall x, inc x a -> PP (mu (image_by_fun f x)) x (Vf f x).
   move => x xa.
   have: x <o a by apply /ord_ltP.
   rewrite (g7 _ xa); apply: g5; apply: mu1; apply: (card_le_ltT _ (g8 _ xa)).
   exact: (image_smaller_cardinal1 x (proj1 pa)).
pose f1 z:= P (Vf f z).
have g10: forall z, inc z a -> inc (f1 z) E.
  move => z za; move: (g9 _ za) => [_ /setC_P [h _] _ _]; apply: FE h.
  by apply: g1; apply /(ord_ltP oa).
have aT: forall s, inc s a -> sub s (source f).
  by move => s sa; rewrite pb; apply: ordinal_transitive.
set r := fun_image a f1.
have r1: sub r E by move => t /funI_P [z za ->]; apply g10.
have r2: cardinal r = cardinal a.
  symmetry; apply/card_eqP; exists (Lf f1 a r); aw.
    split; aw;apply: lf_bijective.
        move => t ta; apply /funI_P; ex_tac.
     suff: forall u v, u <o v -> inc v a -> f1 u <> f1 v.
      move => H u v ua va sf.
      have ou: ordinalp u by ord_tac.
      have ov: ordinalp v by ord_tac.
      case: (ord_le_to_ell ou ov) => // l1.
        by case: (H _ _ l1 va).
        by case: (H _ _ l1 ua).
    move => u v uv va sv; move: (g9 _ va) => [_ /setC_P [sa sb] _ _ ].
    case: sb; rewrite -/(f1 v) - sv; apply /setU2_P; left; apply /funI_P.
    have iuv: inc u v by apply /ord_ltP => //; ord_tac.
    exists (Vf f u) => //; apply /(Vf_image_P (proj1 pa));fprops;last by ex_tac.
  by move => y /funI_P.
exists r ;split => //.
move => x; rewrite - tg => xtg; move: (bij_surj bg xtg); rewrite sg.
move => [z za <-] bad.
move: (g9 _ za) => [_ _ /setC_P [f2g f2r]] f1f2.
move: (bad _ f2g) => /funI_P [s sa sb].
have oz: ordinalp z by ord_tac.
have os: ordinalp s by ord_tac.
case: (ord_le_to_ell oz os); move => zs; first by case: f1f2; rewrite sb zs.
  move: (g9 _ sa) => [_]; rewrite -/(f1 s).
  move => /setC_P [_ f1r'] _.
  case: f1r'; rewrite - sb; apply /setU2_P; right; apply /funI_P.
  have iuv: inc z s by apply /ord_ltP => //; ord_tac.
  exists (Vf f z) => //; apply /(Vf_image_P (proj1 pa)); fprops; by ex_tac.
case: f2r; rewrite sb; apply /setU2_P; left; apply /funI_P.
have iuv: inc s z by apply /ord_ltP => //; ord_tac.
exists (Vf f s) => //; apply /(Vf_image_P (proj1 pa));fprops;last by ex_tac.
Qed.

Lemma Exercise6_24b:
   (forall G, sub G F -> cardinal G <c a ->
       a <=c cardinal (E -s union G)) ->
   exists P, [/\ sub P E, cardinal (P) = a &
   forall x, inc x F -> (cardinal (P \cap x)) <c a].
move: (proj1 iF) => ca.
move: (sym_eq cF); rewrite - {1 4} (card_card ca).
move /card_eqP => [g [bg sg tg]].
have fg: function g by fct_tac.
have oa: ordinalp a by apply: OS_cardinal.
have g1: forall b, b <o a -> inc (Vf g b) F.
   move => b /(ord_ltP oa); rewrite - sg - tg => h; Wtac.
have g2: forall x, inc x F -> exists2 b, b <o a & (Vf g b) = x.
  rewrite -tg => x xt; move: (bij_surj bg xt) => [b b1 b2]; exists b => //.
  apply /(ord_ltP oa); ue.
move => bighyp.
pose PP x b p := [/\ inc p E, ~ inc p x & ~ inc p (unionf b (Vf g))].
have g3: forall x b, cardinal x <c a -> b <o a -> exists p, PP x b p.
   move => X z cx za; rewrite /PP.
   set G := (fun_image z (Vf g)).
   have sza : sub z a by move: za => [[_ _ H] _].
   have sG: sub G F.
       move => t /funI_P [s sa ->]; apply: g1.
       apply /(ord_ltP oa); exact(sza s sa).
   have oz: ordinalp z by ord_tac.
   move /(ordinal_cardinal_le2P ca oz): za => lt1.
   have cG: cardinal G <c a.
       apply: card_le_ltT lt1; apply: (fun_image_smaller).
   move: (bighyp _ sG cG) => le1.
   move: (card_lt_leT cx le1) => le2.
   have ifs: infinite_set (E -s union G).
     by apply /infinite_setP;apply: (ge_infinite_infinite iF le1).
   move: (infinite_compl ifs le2) => le3.
   case: (emptyset_dichot ((E -s union G) -s X)) => ee.
   move: ifs => /infinite_setP; rewrite -le3 ee cardinal_set0 => le4.
   case: (infinite_dichot1 finite_0 le4).
   move: ee => [x /setC_P [/setC_P [xe xg]] xX]; ex_tac => // xu; case: xg.
   move /setUf_P: xu => [y ya yb]; apply /setU_P; exists (Vf g y)=> //.
   apply /funI_P; ex_tac.
pose g4 x b := choose (PP x b).
have g5: forall x b, cardinal x <c a -> b <o a -> PP x b (g4 x b).
  move => x b p1 p2; move: (g3 _ _ p1 p2); apply: choose_pr.
pose g6 fct := g4 (target fct) (source fct).
move: (ordinal_o_wor oa) => wor.
move: (transfinite_defined_pr g6 wor).
set f := transfinite_defined _ _.
rewrite /transfinite_def (ordinal_o_sr a); move=> [pa pb pc].
have g7: forall x, inc x a -> Vf f x = g4 (image_by_fun f x) x.
  move => x xa; rewrite (pc _ xa) /restriction_to_segment
    (ordinal_segment oa xa) /g6 /restriction1; aw.
have g8: forall x, inc x a -> cardinal x <c a.
  move => x /(ord_ltP oa) h.
  apply /(ordinal_cardinal_le2P ca) => //; ord_tac.
have g9: forall x, inc x a -> PP (image_by_fun f x) x (Vf f x).
   move => x xa.
   have: x <o a by apply /ord_ltP.
   rewrite (g7 _ xa); apply: g5; apply: (card_le_ltT _ (g8 _ xa)).
   exact: (image_smaller_cardinal1 x (proj1 pa)).
have aT: forall s, inc s a -> sub s (source f).
  by move => s sa; rewrite pb; apply: ordinal_transitive.
exists (target f);split => //.
    by move => t /(proj2 pa); rewrite pb; move => [x /g9 [xe _ _]] <-.
   symmetry; apply /card_eqP; exists f; split; aw; split => //.
   split; first by fct_tac.
   suff: forall u v, u <o v -> inc v a -> (Vf f u) <> Vf f v.
     rewrite pb => H x y xsf ysf sv.
     have ox: ordinalp x by ord_tac.
     have oy: ordinalp y by ord_tac.
     case:(ord_le_to_ell ox oy) => // h.
      by case: (H _ _ h ysf).
      by case: (H _ _ h xsf).
  move => u v uv va sv; move: (g9 _ va) => [_ h1 _].
  have ov: ordinalp v by ord_tac.
  move /(ord_ltP ov): uv => uv1.
  case: h1; rewrite - sv; apply /(Vf_image_P (proj1 pa)); fprops; ex_tac.
move => x; rewrite -tg => xtg; move: (bij_surj bg xtg); rewrite sg.
move => [b ba <-]; set G := _ \cap _.
have: sub G (fun_image (succ_o b) (fun z => Vf f z)).
  move => t /setI2_P [/(proj2 pa)]; rewrite pb; move => [z za <-] zb.
  move:(g9 _ za) => [_ h1 h2].
  have oz: ordinalp z by ord_tac.
  have ob: ordinalp b by ord_tac.
  apply /funI_P; exists z => //.
  case:(ord_le_to_ell oz ob) => // h.
      rewrite h; fprops.
    by apply /setU1_P; left; apply /ord_ltP.
  by case: h2; apply /setUf_P; exists b => //; apply /ord_ltP.
move /sub_smaller => h1; apply: (card_le_ltT h1).
  apply: (@card_le_ltT _ (cardinal (succ_o b))).
    by apply:fun_image_smaller.
  move: (infinite_card_limit2 iF) => [_ _ h].
  move: (h _ ba) => /(ord_ltP oa) lt1.
  apply /(ordinal_cardinal_le2P ca) => //; ord_tac.
Qed.

End Exercise6_24.



Definition zprod a := Zo (powerset (union a))
  (fun y=> forall x, inc x a -> singletonp (y \cap x)).

Definition zprod2 a b:= zprod (doubleton a b).

Lemma zprod2_P a b y:
  inc y (zprod2 a b) <->
  [/\ sub y (a \cup b), singletonp (y \cap a) & singletonp (y \cap b)].
Proof.
split.
  move => /Zo_P [] /setP_P pa pb;split => //; apply: pb; fprops.
move => [pa pb pc]; apply /Zo_P; split; first by apply /setP_P.
by move => x /set2_P; case => ->.
Qed.

Definition zpr x a := union (x \cap a).

Lemma zprod2_pr1 a b x:
  inc x (zprod2 a b) ->
  ((x \cap a = singleton (zpr x a)) /\
   (x \cap b = singleton (zpr x b))).
Proof.
rewrite /zpr.
by move /zprod2_P => [pa [t ->] [s ->]]; rewrite ! setU_1.
Qed.

Lemma zprod2_pr0 a b x:
  inc x (zprod2 a b) ->
  [/\ inc (zpr x a) a, inc (zpr x b) b, inc (zpr x a) x & inc (zpr x b) x].
Proof.
move=> xz; move: (zprod2_pr1 xz) => [pa pb].
have : (inc (zpr x a) (x \cap a)) by rewrite pa; fprops.
have : (inc (zpr x b) (x \cap b)) by rewrite pb; fprops.
by move /setI2_P => [sa sb] /setI2_P [sc sd].
Qed.

Lemma zprod2_pr0aa a b x:
  inc x (zprod2 a b) ->inc (zpr x a) a.
Proof. by move=> xz; case: (zprod2_pr0 xz). Qed.

Lemma zprod2_pr0ax a b x:
  inc x (zprod2 a b) ->inc (zpr x a) x.
Proof. by move=> xz; move: (zprod2_pr0 xz) => []. Qed.

Lemma zprod2_pr0bb a b x:
  inc x (zprod2 a b) -> inc (zpr x b) b.
Proof. by move=> xz; move: (zprod2_pr0 xz) => []. Qed.

Lemma zprod2_pr0bx a b x:
  inc x (zprod2 a b) ->inc (zpr x b) x.
Proof. by move=> xz; move: (zprod2_pr0 xz) => []. Qed.

Lemma zprod2_pr1a a b x z:
  inc x (zprod2 a b) ->
  inc z a -> inc z x -> z = zpr x a.
Proof.
move=> xz za zb; move: (zprod2_pr1 xz)=> [pa pb].
have :(inc z (x \cap a)) by apply /setI2_P.
by rewrite pa => /set1_P.
Qed.

Lemma zprod2_pr1b a b x z:
  inc x (zprod2 a b) ->
  inc z b -> inc z x -> z = zpr x b.
Proof.
move=> xz zb zx; move: (zprod2_pr1 xz)=> [pa pb].
have :(inc z (x \cap b)) by apply /setI2_P.
by rewrite pb => /set1_P.
Qed.

Lemma zprod2_pr2 a b y:
  inc y (zprod2 a b) -> y = doubleton (zpr y a) (zpr y b).
Proof.
move=> yz; set_extens x; aw.
  move: (yz) => /zprod2_P [pa pb pc].
  move=> xy; move: (pa _ xy);case /setU2_P => h.
   rewrite (zprod2_pr1a yz h xy); fprops.
   rewrite (zprod2_pr1b yz h xy); fprops.
by move: (zprod2_pr0ax yz) (zprod2_pr0bx yz) => pa pb;case /set2_P=> ->.
Qed.

Lemma intersection_singletonP a b c:
  (a \cap (singleton b) = singleton c) <->
  (inc c a /\ c = b).
Proof.
split.
  move=> iis; move:(set1_1 c); rewrite -iis => /setI2_P.
  move => [pa] /set1_P;split => //.
move=> [pa <-]; apply: set1_pr; first by fprops.
by move => t /setI2_P [_] /set1_P.
Qed.

Lemma zprod_singleton M r: ~ inc r M ->
  let N := zprod2 M (singleton r) in
    ( (forall u, inc u M -> inc (doubleton u r) N) /\
      (forall x, inc x N -> exists2 u, inc u M & x = doubleton u r)).
Proof.
move=> nrM N; split.
  move=> u uM; apply /zprod2_P;split => //.
      move=> t /set2_P; case => ->; apply /setU2_P; [left | right]; fprops.
    exists u; apply: set1_pr; first by fprops.
    by move=> t /setI2_P [] /set2_P; case => // ->.
  exists r; apply /intersection_singletonP;fprops.
move=> x xN; move: (zprod2_pr0 xN) => [pa /set1_P <- _ _].
by ex_tac; exact: (zprod2_pr2 xN).
Qed.

Definition zmap f a b := sub f (zprod2 a b) /\
  (forall x, inc x (a \cup b)-> exists !z, inc z f /\ inc x z).

Definition ziequivalent a b := disjoint a b /\ exists f, zmap f a b.

Lemma zmap_example1 a b: a <> b ->
  let A := singleton a in
    let B := singleton b in
    zmap (singleton (doubleton a b)) A B.
Proof.
move=> nab A B; rewrite /A/B.
move: (setU2_11 a b); set (u := doubleton a b) => aux.
split.
  by move=> t /set1_P ->; apply /zprod2_P; rewrite aux /u;split => //;
   [exists a | exists b]; apply:set1_pr; try (apply /setI2_P;split;fprops);
     move => z /setI2_P [_] /set1_P.
rewrite aux; move=> x xu; exists u; split => //; first split; fprops.
by move => t [] /set1_P.
Qed.

Lemma zmap_example2 a b c d: let A := doubleton a b in
  let B := doubleton c d in
    disjoint A B -> a <> b -> c <> d ->
    zmap (doubleton (doubleton a c) (doubleton b d)) A B.
Proof.
move=> A B dab nab ncd.
move: dab; rewrite /disjoint /A/B=> ie.
have nac: a <> c. move => ac; empty_tac1 a; rewrite ac; fprops.
have nad: a <> d by move => ac; empty_tac1 a;rewrite ac; fprops.
have nbc: b <> c by move => ac; empty_tac1 b;rewrite ac; fprops.
have nbd: b <> d by move => ac; empty_tac1 b;rewrite ac; fprops.
have Hx: forall x y z, y <> z ->
    singletonp (intersection2 (doubleton x y) (doubleton x z)).
  move=> x y z yz; exists x; apply: set1_pr; first by fprops.
  move => t /setI2_P []/set2_P; case => // -> /set2_P; case => //.
split.
  move=> t t1; apply / zprod2_P; case /set2_P: t1 => ->; split => //;
    try (move => w /set2_P; case => ->; fprops).
   by apply: Hx; apply: nesym.
   by rewrite (set2_C a c); apply: Hx.
   by rewrite (set2_C a b); apply: Hx; apply:nesym.
   by rewrite set2_C (set2_C c d); apply: Hx.
have ->: ((doubleton a b) \cup (doubleton c d)) =
    (doubleton a c) \cup (doubleton b d).
   set_extens t => /setU2_P; case => /set2_P; case => ->; fprops.
move => x xu; apply /unique_existence; split.
   case /setU2_P: xu => h;
    [ exists (doubleton a c) | exists (doubleton b d) ]; split;fprops.
move=> u v [] /set2_P pa qa [] /set2_P pb qb; move: qa qb.
have aux: inc x (doubleton a c) -> inc x (doubleton b d) -> False.
  by case /set2_P => ->; case /set2_P => //; apply:nesym.
by case: pa => ->; case: pb =>-> // qc qd; case: aux.
Qed.

Lemma zequiv_example1 a b: a <> b ->
  ziequivalent (singleton a) (singleton b).
Proof.
move=> ab; split; first by apply: disjoint_pr => u /set1_P -> /set1_P.
exists (singleton (doubleton a b)); apply: (zmap_example1 ab).
Qed.

Lemma zequiv_example2 a b c d: let A := doubleton a b in
  let B := doubleton c d in
    disjoint A B -> a <> b -> c <> d ->
    ziequivalent A B.
Proof.
move=> A B dAB nab ncd; split => //.
exists (doubleton (doubleton a c) (doubleton b d)); by apply: zmap_example2.
Qed.

Definition zbijective F a b :=
  [/\ (forall x, inc x a -> inc (F x) b) ,
      (forall x x', inc x a -> inc x' a -> F x = F x' -> x = x') &
      (forall y, inc y b -> exists2 x, inc x a & F x = y)].

Lemma is_singleton_int a b c:
  inc c a -> inc c b -> (forall u, inc u a-> inc u b -> u = c) ->
  singletonp (a \cap b).
Proof.
move=> ca cb h;exists c; apply: set1_pr; first by fprops.
by move => t /setI2_P [pa pb]; apply : h.
Qed.

Lemma zmap_example3 F a b: disjoint a b -> zbijective F a b ->
  ziequivalent a b.
Proof.
move=> dab [pa pb pc]; split => //.
set (f := Zo (powerset (union2 a b)) (fun z => exists2 x, inc x a &
    z = doubleton x (F x))).
red in dab.
exists f; split.
  move=> t => /Zo_P [] /setP_P tu [x xa td]; apply /zprod2_P.
  move: (pa _ xa)=> fb; split => //.
    apply: (@is_singleton_int _ _ x) => //; first by rewrite td;fprops.
    rewrite td => u;case/set2_P =>// qa qb; empty_tac1 u.
    apply /setI2_P;split => //;ue.
   apply: (@is_singleton_int _ _ (F x)) => //; first by rewrite td;fprops.
   rewrite td => u; case /set2_P =>// qa qb; empty_tac1 u.
   apply /setI2_P;split => //;ue.
move=> x; aw => xu; apply /unique_existence; split.
  case /setU2_P: xu => xu.
    exists (doubleton x (F x)); split; last by fprops.
    apply: Zo_i; last by ex_tac.
    apply /setP_P;move => t;case /set2_P=> ->; [ fprops | apply /setU2_P].
    by right; apply: pa.
  move: (pc _ xu)=> [z za Fz]; exists (doubleton z x);split;fprops.
  apply: Zo_i; first by apply /setP_P;move=> t; case /set2_P=> ->; fprops.
  ex_tac; ue.
move=> u v [uf xz] [yf xy].
move: uf yf => /Zo_P [] /setP_P uu [z za zu] /Zo_P [] /setP_P vy [w wa vw].
move: xz xy;rewrite zu vw; case /set2_P => xpa; case /set2_P=> xpb.
by rewrite -xpa -xpb.
by empty_tac1 x; apply /setI2_P;split => //; ue.
by empty_tac1 x; apply /setI2_P; split => //; ue; rewrite xpa; apply: pa.
by rewrite xpa in xpb; rewrite (pb _ _ za wa xpb).
Qed.

Lemma zmap_symm f a b: zmap f a b -> zmap f b a.
Proof. rewrite /zmap setU2_C /zprod2 set2_C //. Qed.

Lemma zequiv_symm a b: ziequivalent a b -> ziequivalent b a.
Proof.
move => []; rewrite /disjoint setI2_C; move=> h [f zf].
by move: (zmap_symm zf) => zf1; split => //; exists f.
Qed.

Lemma zmap_pr1 f a b: zmap f a b -> union f = a \cup b.
Proof.
move=> [pa pb]; set_extens t.
  move /setU_P => [y ty yf]; move: (pa _ yf) => /zprod2_P.
   by move=> [yu _ _]; apply: yu.
move => tu; move: (pb _ tu) => [z [[zf xz] _]]; union_tac.
Qed.

Definition zmap_aux f x := select (fun z => inc x z) f.

Lemma zmap_aux_pr1 f a b x:
  zmap f a b -> inc x (a \cup b) ->
  (inc (zmap_aux f x) f /\ inc x (zmap_aux f x)).
Proof.
move=> [pa pb] xu; move: (pb _ xu) => [u [[ta tb] pd]].
have h: singl_val2 (inc^~ f) (fun z => inc x z).
  by move => t y sa sb sc sd; rewrite -(pd _ (conj sa sb)) -(pd _ (conj sc sd)).
rewrite /zmap_aux - (select_uniq h ta tb);split => //.
Qed.

Lemma zmap_aux_pr2 f a b x y:
  zmap f a b -> inc x (a \cup b) -> inc y f -> inc x y
  -> y = (zmap_aux f x).
Proof.
move => zm xu yf xy;move: (zmap_aux_pr1 zm xu) => [pa pb].
move: zm=> [_ pc]; move: (pc _ xu) => [z [zx unq]].
by rewrite - (unq _ (conj yf xy)) (unq _ (conj pa pb)).
Qed.

Lemma zmap_aux_pr3a f a b x y:
  zmap f a b -> inc x f -> inc y f -> zpr x a = zpr y a
  -> x = y.
Proof.
move=> zm xf yf szp; move: (zm) => [pa pb].
have zxu: (inc (zpr x a) (union2 a b)).
  by apply: setU2_1; apply: (zprod2_pr0aa (pa _ xf)).
have zyu: (inc (zpr y a) (union2 a b)) by ue.
rewrite (zmap_aux_pr2 zm zxu xf (zprod2_pr0ax (pa _ xf))).
by rewrite (zmap_aux_pr2 zm zyu yf (zprod2_pr0ax (pa _ yf))) szp.
Qed.

Lemma zmap_aux_pr3b f a b x y:
  zmap f a b -> inc x f -> inc y f -> zpr x b = zpr y b
  -> x = y.
Proof. move=> zm; apply: (zmap_aux_pr3a (zmap_symm zm)). Qed.

Definition zmap_val f a x:= zpr (zmap_aux f x) a.

Lemma zmap_val_pr1a f a b x: zmap f a b -> inc x (a \cup b) ->
  inc (zmap_val f a x) a.
Proof.
move=> zm xu;move: (zmap_aux_pr1 zm xu) => [pc pd].
move: (zm) => [pa pb]; apply: (zprod2_pr0aa (pa _ pc)).
Qed.

Lemma zmap_val_pr1b f a b x: zmap f a b -> inc x (a \cup b) ->
  inc (zmap_val f b x) b.
Proof.
move => zmf xu; move: (zmap_aux_pr1 zmf xu) => [zf xz].
move: zmf => [pa pb];move: (pa _ zf); apply: zprod2_pr0bb.
Qed.

Lemma zmap_val_pr2a f a b x: zmap f a b -> inc x a ->
  (zmap_val f a x) = x.
Proof.
move => cx xa.
have xu: (inc x (union2 a b)) by apply: setU2_1.
move : (zmap_aux_pr1 cx xu) => [zf xz]; move: cx => [pa pb].
symmetry; apply: (zprod2_pr1a (pa _ zf) xa xz).
Qed.

Lemma zmap_val_pr2b f a b x: zmap f a b -> inc x b ->
  (zmap_val f b x) = x.
Proof.
move => cx xb.
have xu: (inc x (union2 a b)) by apply: setU2_2.
move : (zmap_aux_pr1 cx xu) => [zf xz]; move: cx => [pa pb].
symmetry; apply: (zprod2_pr1b (pa _ zf) xb xz).
Qed.

Lemma zmap_val_pr3a f a b x: zmap f a b -> inc x a ->
  (zmap_val f a (zmap_val f b x)) = x.
Proof.
move=> zm xa.
have xu: inc x (union2 a b) by apply: setU2_1.
move: (zmap_aux_pr1 zm xu) => [zf xz].
move: (zm) => [pa pb]; move: (pa _ zf) => xx.
move: (zprod2_pr1 xx) => [pc pd].
set (t := zmap_val f b x); set y := zmap_aux f x.
have: inc t (y \cap b) by rewrite pd; fprops.
move /setI2_P => [ta1 ta2].
have tab: (inc t (a \cup b)) by apply: setU2_2.
suff: y = zmap_aux f t.
   rewrite /zmap_val; move => <-;symmetry; apply: (zprod2_pr1a (pa _ zf) xa xz).
apply: (zmap_aux_pr2 zm tab zf ta1).
Qed.

Lemma zmap_val_pr3b f a b x: zmap f a b -> inc x b ->
  (zmap_val f b (zmap_val f a x)) = x.
Proof.
move => zm; have: (zmap f b a) by apply: zmap_symm.
apply: zmap_val_pr3a.
Qed.

Lemma zmap_bijective f a b: zmap f a b ->
  zbijective (zmap_val f b) a b.
Proof.
move=> zm; rewrite /zbijective; split => //.
    move=> x xa; apply: (zmap_val_pr1b zm (setU2_1 b xa)).
  move=> x x' xa x'a sv; move: (f_equal (zmap_val f a) sv).
  rewrite zmap_val_pr3a // zmap_val_pr3a //.
move=> y yb; exists ( zmap_val f a y).
  by apply: (zmap_val_pr1a zm); apply /setU2_2.
by apply: zmap_val_pr3b.
Qed.

Lemma zmap_setP a b: exists s,
  forall f, zmap f a b <-> inc f s.
Proof.
exists (Zo (powerset (zprod2 a b)) (fun z => zmap z a b)).
move=> f; split; last by move => /Zo_P [].
by move => h; apply /Zo_P;split => //; apply /setP_P;move: h => [].
Qed.

Lemma sub_disjoint a b a' b':
  disjoint a b -> sub a' a -> sub b' b -> disjoint a' b'.
Proof.
move=> di sa sb; apply: disjoint_pr => u ua ub.
red in di; empty_tac1 u; aw;split => //.
Qed.

Lemma zmap_sub f a b a': zmap f a b -> sub a' a ->
  exists f' b', [/\ sub f' f, sub b' b & zmap f' a' b'].
Proof.
move=> zm saa.
move: (zm) => [pa pb].
set (f' := Zo f (fun z => inc (zpr z a) a')).
set (b':= Zo b (fun z => exists2 x, inc x f' & z = zpr x b)).
have sf: sub f' f by apply: Zo_S.
have sb: sub b' b by apply: Zo_S.
exists f'; exists b'; split => //.
have pc: (forall y, inc y f' -> y = doubleton (zpr y a) (zpr y b)).
   by move=> y yf'; apply: zprod2_pr2; apply: pa; apply: sf.
split.
  move => x xf'.
  have ha: inc x (zprod2 a b) by apply: pa; apply: sf.
  have hb: (inc (zpr x a) a') by move: xf' => /Zo_P [].
  have hc: (inc (zpr x b) b') by apply: Zo_i; [apply:(zprod2_pr0bb ha)| ex_tac].
  move: (zprod2_pr1 ha) => [pd pe].
  apply /zprod2_P;split => //.
      rewrite (pc _ xf'); move=> t;case /set2_P => ->; fprops.
    apply: (@is_singleton_int _ _ (zpr x a)) => //.
      apply: (@setI2_1 _ a); rewrite pd; fprops.
    move=> u ux ua'.
    have : (inc u (x \cap a)) by fprops.
    by rewrite pd => /set1_P.
  apply: (@is_singleton_int _ _ (zpr x b)) => //.
    apply: (@setI2_1 _ b); rewrite pe; fprops.
  move=> u ux ua'.
  have : (inc u (x \cap b)) by fprops.
  by rewrite pe => /set1_P.
move=> x xu.
have xu': (inc x (a \cup b)) by move: xu; case /setU2_P => xs; fprops.
move: (zmap_aux_pr1 zm xu') => [pd pe]; exists (zmap_aux f x); split.
    split => //. apply: Zo_i => //.
  move: xu; case /setU2_P => xs.
    by move: (zmap_val_pr2a zm (saa _ xs)); rewrite /zmap_val; move => ->.
  move: xs => /Zo_P [xb [z zf' xv]].
  move: zf' => /Zo_P [pf pg].
  have <- //: (z = zmap_aux f x).
  apply: (zmap_aux_pr2 zm xu' pf); rewrite xv; apply: (zprod2_pr0bx (pa _ pf)).
move=> u [uf' ux]; move: (pb _ xu') => [z [zv zu]].
by rewrite - (zu _ (conj pd pe)) (zu _ (conj (sf _ uf') ux)).
Qed.

Lemma zequiv_sub a b a': ziequivalent a b -> sub a' a ->
  exists b', (sub b' b /\ ziequivalent a' b').
Proof.
move=> [pa [f zm]] a'a.
move: (zmap_sub zm a'a) => [f' [b' [pb pc pd]]]; exists b';split => //.
split; [ apply: (sub_disjoint pa a'a pc) | by exists f'].
Qed.

Lemma zmap_transitive a b c: disjoint a c ->
  ziequivalent a b -> ziequivalent b c -> ziequivalent a c.
Proof.
move=> dac [dab [f zmf]] [dbc [g zmg]].
move: (zmap_bijective zmf) (zmap_bijective zmg) => [pa pb pc][pd pe pf].
set (f1 := zmap_val f b); set (f2 := zmap_val g c).
set (h := fun x => f2 (f1 x)).
suff : (zbijective h a c) by apply: (zmap_example3 dac).
split => //; first by move=> x xa; apply: pd; apply: pa.
  fprops.
move=> y yc; move: (pf _ yc) => [x xb xb1].
by move: (pc _ xb) => [u ua uv]; ex_tac; rewrite - xb1 -uv.
Qed.

Lemma disjointness M: exists N,
  sub N M /\ ~ inc N M.
Proof.
set (N := Zo M (fun x => ~ (inc x x))).
have NM: (sub N M) by apply: Zo_S.
exists N; split => //; move=> nm.
have aux: (~ (inc N N))by move=> bad; move: (bad) => /Zo_P [].
by apply: (aux); apply: Zo_i.
Qed.

Lemma disjointness1 M N: exists r,
  let M1 := zprod2 M (singleton r) in
   [/\ ~ (inc r M) , disjoint M M1 & disjoint N M1].
Proof.
move: (disjointness (M \cup (union (M \cup N)))) => [K [pa pb]].
have : (~ (inc K (union (M \cup N)))) by dneg k; fprops.
have kM: (~ inc K M) by dneg km; fprops.
have d1: (disjoint (union2 M N) (zprod2 M (singleton K))).
  apply: disjoint_pr => u uu us.
  move: (zprod_singleton kM) => [pc pd]; move: (pd _ us) => [v vM ud].
  case: pb; apply: setU2_2; apply /setU_P; exists u => //; rewrite ud; fprops.
by red in d1;move=> nku;exists K; simpl;split => //;
  apply: disjoint_pr => u um aux; empty_tac1 xx; aw.
Qed.

Lemma zmap_example4 M r:
  let N := zprod2 M (singleton r) in
    ~ (inc r M) -> disjoint M N ->
    ziequivalent M N.
Proof.
move=> N h1 h2.
move: (zprod_singleton h1) => [pa pb].
suff : (zbijective (fun x => doubleton x r) M N) by apply: (zmap_example3 h2).
split => //.
  move=> x x' xM xM' sf.
  have : (inc x (doubleton x r)) by fprops.
  rewrite sf;case /set2_P => // aux;case: h1; ue.
by move=> y yN; move: (pb _ yN) => [x xM xv]; exists x.
Qed.

Lemma zequiv_example4 M N: exists M',
  disjoint N M' /\ ziequivalent M M'.
Proof.
move: (disjointness1 M N) => [r [a pa pb]].
by exists (zprod2 M (singleton r)); split => //; apply: zmap_example4.
Qed.

Lemma zequiv_empty M: ziequivalent M emptyset -> M = emptyset.
Proof.
  move=> [_ [f zm]]; apply /set0_P => x xM.
have xu: (inc x (union2 M emptyset)) by move: zm => [pa pb]; fprops.
move: (zmap_val_pr1b zm xu); case; case.
Qed.

Lemma zequiv_no_graph M: nonempty M ->
  ~ (exists S, forall M', ziequivalent M M' -> inc M' S).
Proof.
move=> nM [S hs].
move: (zequiv_example4 M (union S)) => [M' [ds emm']].
move: (hs _ emm') => ms'.
case: (emptyset_dichot M') => me.
  rewrite me in emm'; move: (zequiv_empty emm') => em.
  by move: nM; rewrite em; case /nonemptyP.
move: me => [x xm]; empty_tac1 x; union_tac.
Qed.

Definition zequiv M N := exists2 R, ziequivalent M R & ziequivalent N R.

Lemma zequiv_reflexive M: zequiv M M.
Proof. by move: (zequiv_example4 M M) =>[N [_ nv]]; exists N. Qed.

Lemma zequiv_symmetric M N:
   zequiv M N -> zequiv N M.
Proof. by move=> [f [fa fb]]; exists f. Qed.

Lemma zequiv_transitive M N P:
   zequiv M N -> zequiv N P -> zequiv M P.
Proof.
move=> [f fa fb] [g ga gb].
move: (zequiv_example4 f (g \cup (P \cup (M \cup N)))) => [h [hd he]].
red in hd.
exists h => //.
  have d1: (disjoint M h) by apply: disjoint_pr => u uM uh; empty_tac1 u; aw.
  exact: (zmap_transitive d1 fa he).
have d2: (disjoint N h) by apply: disjoint_pr => u uM uh; empty_tac1 u; aw.
move: (zmap_transitive d2 fb he) => Nh.
have d3: (disjoint g h) by apply: disjoint_pr => u uM uh; empty_tac1 u; aw.
move: (zmap_transitive d3 (zequiv_symm ga) Nh) => gh.
have d4: (disjoint P h) by apply: disjoint_pr => u uM uh; empty_tac1 u; aw.
exact (zmap_transitive d4 gb gh).
Qed.

End Exercise5.